diff --git a/default.nix b/default.nix index 8c28190..c0e28b6 100644 --- a/default.nix +++ b/default.nix @@ -1,7 +1,7 @@ { mkDerivation, aeson, annotated-exception, async, base, bytestring -, containers, directory, ekg-core, hedgehog, hspec, hspec-hedgehog -, katip, lens, lens-aeson, lib, network, process, stm, text, time -, unordered-containers, uuid, websockets +, cereal, containers, directory, ekg-core, hedgehog, hspec +, hspec-hedgehog, katip, lens, lens-aeson, lib, network, process +, stm, text, time, unordered-containers, uuid, websockets }: mkDerivation { pname = "home-assistant-controller"; @@ -10,7 +10,7 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson annotated-exception async base bytestring containers + aeson annotated-exception async base bytestring cereal containers directory ekg-core katip lens lens-aeson network process stm text time unordered-containers uuid websockets ]; diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 5fd9f42..497c0ff 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -96,6 +96,7 @@ library , unordered-containers , process , directory + , cereal -- Directories containing source files. hs-source-dirs: src diff --git a/src/AFRP.hs b/src/AFRP.hs index baa7ef9..4553b7c 100644 --- a/src/AFRP.hs +++ b/src/AFRP.hs @@ -35,19 +35,59 @@ module AFRP , debounce , currentTime , onEvent + , save + , load ) where import Control.Category (Category(..), (>>>)) import Prelude hiding ((.), id) -import Control.Arrow (Arrow(..), ArrowChoice(..), ArrowLoop(..)) +import Control.Arrow (Arrow(..), ArrowChoice(..)) import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime, utcToLocalTime) -import Control.Monad.Fix (MonadFix (mfix)) import Data.Either (fromLeft) import Data.Bool (bool) import Data.Monoid (Endo(..)) import Data.UUID (UUID) import qualified Data.Set as S import qualified Data.Text as T +import Data.Serialize (Get, Putter, runPut, Serialize (put), runGet) +import qualified Data.ByteString as B +import Control.Exception (IOException, handle, throwIO) +import System.IO.Error (isDoesNotExistError) + + +data Codec s = Codec { getter :: !(Get s), putter :: !(Putter s) } + +data State s = State {state :: !s, dirty :: !Bool} + deriving Functor + + +instance Semigroup s => Semigroup (State s) where + s1 <> s2 = State (state s1 <> state s2) (dirty s1 || dirty s2) + +instance Monoid s => Monoid (State s) where + mempty = State mempty False + +instance Applicative State where + pure a = State a False + s1 <*> s2 = State + { state = + let a = state s2 + f = state s1 + in f a + , dirty = dirty s1 || dirty s2 + } + +mergeState :: State s1 -> State s2 -> State (s1, s2) +mergeState s1 s2 = (,) <$> s1 <*> s2 + + +mergeCodec :: Codec s -> Codec s1 -> Codec (s, s1) +mergeCodec (Codec agetter aputter) (Codec bgetter bputter) = Codec (mergeGet agetter bgetter) (mergePut aputter bputter) + where + mergePut :: Putter s -> Putter s1 -> Putter (s, s1) + mergePut p1 p2 (s, s1) = p1 s >> p2 s1 + mergeGet :: Get s -> Get s' -> Get (s, s') + mergeGet g1 g2 = (,) <$> g1 <*> g2 data Pair a b = Pair !a !b @@ -57,12 +97,150 @@ data Request = Request , requestTraceId :: !UUID } deriving (Show, Eq) + +data Auto m a b + = Fun (a -> b) -- Stateless variant, needed at least for 'id' + | forall s. Stateful !(Codec s) !(State s) !(State s -> a -> m (b, State s)) -- State is explicitly part of it + + +instance Monad m => Functor (Auto m a) where + fmap f = \case + Fun x -> Fun $ f . x + Stateful codec s x -> Stateful codec s $ \s' a -> do + (a',s'') <- x s' a + pure (f a', s'') + +instance Monad m => Applicative (Auto m a) where + pure a = Fun (const a) + fa <*> fb = + case (fa,fb) of + (Fun af, Fun bf) -> Fun (af <*> bf) + (Stateful codec s af, Fun bf) -> Stateful codec s + (\s' x -> do + let a = bf x + (h, s'') <- af s' x + pure (h a, s'') + ) + (Fun af, Stateful codec s bf) -> Stateful codec s + (\s' x -> do + (a, s'') <- bf s' x + let h = af x + pure (h a, s'') + ) + (Stateful acodec as af, Stateful bcodec bs bf) -> Stateful (mergeCodec acodec bcodec) (mergeState as bs) + (\s' x -> do + (a, as') <- bf (snd <$> s') x + (h, bs') <- af (fst <$> s') x + pure (h a, mergeState bs' as') + ) + + +instance (Monad m, Semigroup b) => Semigroup (Auto m a b) where + fa <> fb = + case (fa,fb) of + (Fun af, Fun bf) -> Fun (af <> bf) + (Stateful codec s af, Fun bf) -> Stateful codec s + (\s' a -> do + (ab, s'') <- af s' a + let bb = bf a + pure (ab <> bb, s'') + ) + (Fun af, Stateful codec s bf) -> Stateful codec s + (\s' a -> do + let ab = af a + (bb, s'') <- bf s' a + pure (ab <> bb, s'') + ) + (Stateful acodec as af , Stateful bcodec bs bf) -> Stateful (mergeCodec acodec bcodec) (mergeState as bs) + (\s a -> do + (ab, as'') <- af (fst <$> s) a + (bb, bs'') <- bf (snd <$> s) a + pure (ab <> bb, mergeState as'' bs'') + ) + + +instance Monad m => Category (Auto m) where + id = Fun id + af . ag = + case (af, ag) of + (Fun f, Fun g) -> Fun (f . g) + (Stateful codec s f, Fun g) -> Stateful codec s (\s' -> f s' . g) + (Fun f, Stateful codec s g) -> Stateful codec s (\s' -> fmap (first f) . g s') + (Stateful fcodec fs f , Stateful gcodec gs g) -> + Stateful (mergeCodec fcodec gcodec) (mergeState fs gs) (\s a -> do + (b, s') <- g (snd <$> s) a + (c, s'') <- f (fst <$> s) b + pure (c, mergeState s'' s')) + + + +instance Monad m => Arrow (Auto m) where + arr = Fun + first = \case + Fun f -> Fun $ first f + Stateful codec s f -> Stateful codec s $ \s' (b,d) -> do + (c, s'') <- f s' b + pure ((c,d), s'') + +instance Monad m => ArrowChoice (Auto m) where + left = \case + Fun f -> Fun $ + \case + Left b -> Left $ f b + Right d -> Right d + Stateful codec s f -> Stateful codec s $ \s' -> \case + Right d -> pure (Right d, s') + Left b -> do + (c, s'') <- f s' b + pure (Left c, s'') + +serialize :: Auto m a b -> B.ByteString +serialize = \case + Fun _ -> runPut $ put () + Stateful Codec{putter} s _ -> runPut $ putter (state s) + +data DecodedAuto m a b + = Decoded (Auto m a b) -- decoded from serialized state + | FailDecode String (Auto m a b) -- gives back the original + errmsg + +deserialize :: B.ByteString -> Auto m a b -> DecodedAuto m a b +deserialize bs = \case + Fun f -> Decoded (Fun f) -- no state to decode, success by default + Stateful codec s f -> + either + (\err -> FailDecode err (Stateful codec s f)) + (\s' -> Decoded $ Stateful codec (pure s') f) + $ runGet (getter codec) bs + +save :: FilePath -> Auto m a b -> IO (Auto m a b) +save path s + | isDirty s = do + _ <- B.writeFile path $ serialize s + pure $ cleanDirty s + | otherwise = pure s + where + cleanDirty :: Auto m a b -> Auto m a b + cleanDirty (Stateful codec s' f) = Stateful codec s'{dirty=False} f + cleanDirty a = a + isDirty :: Auto m a b -> Bool + isDirty (Stateful _ s' _) = dirty s' + isDirty _ = False + + +load :: forall m a b. FilePath -> Auto m a b -> IO (DecodedAuto m a b) +load path a = handle defaultOnMissingFile (flip deserialize a <$> B.readFile path) + where + defaultOnMissingFile :: IOException -> IO (DecodedAuto m a b) + defaultOnMissingFile e + | isDoesNotExistError e = pure $ FailDecode "State doesn't exist eyt" a + | otherwise = throwIO e + -- | The set of entity ids an arrow subscribes to. Static: it does not -- change as the machine steps, so the runtime can read it once to build -- trigger subscriptions. data Mealy eff a b = Mealy { entities :: S.Set T.Text - , runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (Pair b (Mealy eff a b)) + , runMealy :: forall m. Monad m => (forall x. eff x -> m x) -> Request -> a -> m (Pair b (Mealy eff a b)) }