From 81159ade69fab8a42250e3ec6288ba61a80c20fb Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Thu, 20 Aug 2026 14:30:56 +0300
Subject: [PATCH] Split MyLib into AFRP, Controller, Runtime

---
 app/Main.hs                     |   4 +-
 home-assistant-controller.cabal |   4 +-
 src/AFRP.hs                     | 148 ++++++++++++++
 src/HomeAssistant/Controller.hs | 135 ++++++++++++
 src/HomeAssistant/Runtime.hs    | 117 +++++++++++
 src/MyLib.hs                    | 352 --------------------------------
 6 files changed, 405 insertions(+), 355 deletions(-)
 create mode 100644 src/AFRP.hs
 create mode 100644 src/HomeAssistant/Controller.hs
 create mode 100644 src/HomeAssistant/Runtime.hs
 delete mode 100644 src/MyLib.hs

diff --git a/app/Main.hs b/app/Main.hs
index 104d7c1..7650e74 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,8 +1,8 @@
 module Main (main) where
 
-import qualified MyLib (defaultMain)
+import qualified HomeAssistant.Runtime (defaultMain)
 
 main :: IO ()
 main = do
   putStrLn "Hello, Haskell!"
-  MyLib.defaultMain
+  HomeAssistant.Runtime.defaultMain
diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal
index a7f5d7d..630f3e2 100644
--- a/home-assistant-controller.cabal
+++ b/home-assistant-controller.cabal
@@ -59,7 +59,9 @@ library
     import:           warnings
 
     -- Modules exported by the library.
-    exposed-modules:  MyLib
+    exposed-modules:  AFRP
+                    , HomeAssistant.Controller
+                    , HomeAssistant.Runtime
 
     -- Modules included in this library but not exported.
     -- other-modules:
diff --git a/src/AFRP.hs b/src/AFRP.hs
new file mode 100644
index 0000000..2b733a6
--- /dev/null
+++ b/src/AFRP.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE LambdaCase #-}
+
+module AFRP
+  ( Mealy(..)
+  , eff
+  , Event(..)
+  , hold
+  , events
+  , switch
+  , preMapAccum
+  , preMapAccumUTCTime
+  , mapAccum
+  , mapAccumUTCTime
+  , changes
+  , whenA
+  , filterA
+  , thenA
+  , (>>|)
+  , toEvent
+  ) where
+
+import Control.Category (Category(..), (>>>))
+import Prelude hiding ((.), id)
+import Control.Arrow (Arrow(..), ArrowChoice(..), ArrowLoop(..), returnA)
+import Data.Time (UTCTime)
+import Control.Monad.Fix (MonadFix (mfix))
+import Data.Either (fromLeft)
+import Data.Bool (bool)
+
+newtype Mealy eff a b = Mealy
+  { runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> UTCTime -> a -> m (b, Mealy eff a b) }
+
+eff :: (a -> eff b) -> Mealy eff a b
+eff f = Mealy $ \nt _ x ->
+  nt (f x) >>= \b -> pure (b, eff f)
+
+instance Category (Mealy eff) where
+  id = Mealy (\_ _ x -> pure (x, id))
+  (Mealy f) . (Mealy g) = Mealy $ \nt t a -> do
+    (b, g') <- g nt t a
+    (c, f') <- f nt t b
+    pure (c, f' . g')
+
+instance Arrow (Mealy eff) where
+  arr f = Mealy $ \_ _ b -> pure (f b, arr f)
+  first (Mealy f) = Mealy $ \nt t (b,d) -> do
+    (c, f') <- f nt t b
+    pure ((c, d), first f')
+
+instance ArrowChoice (Mealy eff) where
+  left (Mealy f) = Mealy $ \nt t -> \case
+    Left b -> do
+      (c, f') <- f nt t b
+      pure (Left c, left f')
+    Right d -> pure (Right d, left (Mealy f))
+
+instance ArrowLoop (Mealy eff) where
+  loop (Mealy f) = Mealy $ \nt t b -> do
+    ((c,_), f') <- mfix $ \((_,d), _) -> f nt t (b,d)
+    pure (c, loop f')
+
+instance Functor (Mealy eff a) where
+  fmap f (Mealy g) = Mealy $ \nt t a -> do
+    (b, g') <- g nt t a
+    pure (f b, fmap f g')
+
+instance Applicative (Mealy eff a) where
+  pure b = Mealy $ \_ _ _ -> pure (b, pure b)
+  Mealy f <*> Mealy x = Mealy $ \nt t a -> do
+    (f', fNext) <- f nt t a
+    (x', xNext) <- x nt t a
+    pure (f' x', fNext <*> xNext)
+
+data Event a
+  = Tick
+  | Event a
+  deriving (Show, Functor, Foldable, Traversable)
+
+hold :: a -> Mealy eff (Event a) a
+hold a = Mealy $ \_ _ -> \case
+  Tick -> pure (a, hold a)
+  Event a' -> pure (a', hold a')
+
+events :: Mealy eff (Event a) (Either () a)
+events = arr $ \case
+  Tick -> Left ()
+  Event a -> Right a
+
+switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b
+switch (Mealy f) s = Mealy $ \nt t a -> do
+  ((b, ev), f') <- f nt t a
+  case ev of
+          Tick -> pure (b, switch f' s)
+          Event x -> runMealy (s x) nt t a
+
+preMapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+preMapAccum f x extract = go x
+  where
+    go b = Mealy $ \_ _ a ->
+      let next = f b a
+      in pure (extract b, go next)
+
+preMapAccumUTCTime :: (UTCTime -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+preMapAccumUTCTime f x extract = go x
+  where
+    go b = Mealy $ \_ t a ->
+      let next = f t b a
+      in pure (extract b, go next)
+
+mapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+mapAccum f x extract = go x
+  where
+    go b = Mealy $ \_ _ a ->
+      let next = f b a
+      in pure (extract next, go next)
+
+mapAccumUTCTime :: (UTCTime -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+mapAccumUTCTime f x extract = go x
+  where
+    go b = Mealy $ \_ t a ->
+      let next = f t b a
+      in pure (extract next, go next)
+
+changes :: Eq a => Mealy eff a (Event a)
+changes = mapAccum go Nothing (maybe Tick snd)
+  where
+    go :: Eq a => Maybe (a, Event a) -> a -> Maybe (a, Event a)
+    -- The first observed value is not a change I think
+    go Nothing x = Just (x, Tick)
+    go (Just (y, _)) x | x == y = Just (x, Tick)
+                       | otherwise = Just (x, Event x)
+
+whenA :: (a -> Bool) -> Mealy eff a () -> Mealy eff a ()
+whenA predicate auto = arr (\a -> if predicate a then Left a else Right ()) >>> left auto >>> arr (fromLeft ())
+
+filterA :: (a -> Bool) -> Mealy eff a (Either () a)
+filterA f = arr $ \a -> bool (Left ()) (Right a) (f a)
+
+thenA :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
+thenA f g = f >>> arr Left ||| g
+
+(>>|) :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
+(>>|) = thenA
+
+infixl 1 >>|
+
+toEvent :: Mealy eff (Either () a) (Event a)
+toEvent = arr (either (const Tick) Event)
diff --git a/src/HomeAssistant/Controller.hs b/src/HomeAssistant/Controller.hs
new file mode 100644
index 0000000..5c9bcf7
--- /dev/null
+++ b/src/HomeAssistant/Controller.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GADTs #-}
+
+module HomeAssistant.Controller
+  ( Service(..)
+  , HASSEff(..)
+  , HASS
+  , callService
+  , entityChangeEvent
+  , entityChangeEvent'
+  , entityRead
+  , entityRead'
+  , entityBool
+  , entityBool'
+  , Ruuvi(..)
+  , ruuvi
+  , ruuviTemperatures
+  , ruuviPressures
+  , DoorState(..)
+  , door
+  , light
+  , lightController
+  ) where
+
+import AFRP (Mealy, eff, Event(..), hold, events, changes, mapAccum, filterA, (>>|), toEvent)
+import Control.Arrow (Arrow(..), ArrowChoice(..), returnA)
+import Control.Category ((>>>))
+import Data.Aeson (Value)
+import qualified Data.Text as T
+import Control.Lens (has, only, (^?), to)
+import Data.Aeson.Lens (key, _String)
+import qualified Data.Text.Lens as TL
+import Data.Bool (bool)
+
+data Service = Service
+  { serviceDomain :: T.Text
+  , serviceName :: T.Text
+  , serviceData :: Maybe Value
+  , serviceTarget :: T.Text
+  }
+  deriving Show
+
+data HASSEff a where
+  CallService :: Service -> HASSEff ()
+  Pure :: a -> HASSEff a
+
+type HASS a b = Mealy HASSEff a b
+
+callService :: Service -> HASS a ()
+callService service = eff (\_ -> CallService service)
+
+ruuviTemperatures :: Mealy eff (Event Value) Double
+ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0
+
+ruuviPressures :: Mealy eff (Event Value) Double
+ruuviPressures = entityRead "sensor.ruuvitag_b168_pressure" >>> hold 0
+
+data Ruuvi = Ruuvi { ruuviTemperature :: Double, ruuviPressure :: Double }
+            deriving (Show, Eq)
+
+ruuvi :: Mealy eff (Event Value) (Event Ruuvi)
+ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes
+
+data Direction = Increase | Decrease | Steady
+  deriving (Show, Eq)
+
+numericDirection = mapAccum go (Nothing, Nothing) extract
+  where
+    go (_, old) new = (old, new)
+    extract :: (Maybe Double, Maybe Double) -> Direction
+    extract (old, new) = maybe Steady (\x -> if x >  0 then Increase else Decrease) $ (-) <$> old <*> new
+
+data DoorState = Open | Closed
+  deriving (Show, Eq)
+
+door :: HASS (Event Value) (Event DoorState)
+door = entityBool "binary_sensor.makuuhuone_ovi_contact"
+  >>> arr (fmap (bool Closed Open))
+  >>> hold Open
+  >>> changes
+
+-- Turn off lights when door is closed
+light :: Bool -> Service
+light b = Service
+  { serviceDomain="light"
+  , serviceName= bool "turn_off" "turn_on" b
+  , serviceData=Nothing
+  , serviceTarget="light.bedroom_masse"
+  }
+
+lightController :: HASS (Event Value) (Event DoorState)
+lightController = proc ev -> do
+  doorState <- door -< ev
+  case doorState of
+       Event Open -> callService (light False) -< ()
+       Event Closed -> callService (light True) -< ()
+       _ -> returnA -< ()
+  returnA -< doorState
+
+entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value)
+entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent
+  where
+    isEntity :: Value -> Bool
+    isEntity = has (key "event" . key "data" . key "entity_id" . _String . only entityId)
+
+entityChangeEvent' :: T.Text -> Mealy eff (Event Value) (Either () Value)
+entityChangeEvent' entityId = events >>| filterA isEntity
+  where
+    isEntity :: Value -> Bool
+    isEntity = has (key "event" . key "data" . key "entity_id" . _String . only entityId)
+
+entityRead' :: (Read a) => T.Text -> Mealy eff (Event Value) (Either () a)
+entityRead' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right))
+  where
+    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read
+
+entityBool' :: T.Text -> Mealy eff (Event Value) (Either () Bool)
+entityBool' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right))
+  where
+    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to toBool
+    toBool = \case
+      "on" -> True
+      "off" -> False
+
+entityRead :: (Read a) => T.Text -> Mealy eff (Event Value) (Event a)
+entityRead entityId = entityRead' entityId >>> toEvent
+  where
+    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read
+
+entityBool :: T.Text -> Mealy eff (Event Value) (Event Bool)
+entityBool entityId = entityBool' entityId >>> toEvent
+  where
+    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read
diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs
new file mode 100644
index 0000000..d7f8925
--- /dev/null
+++ b/src/HomeAssistant/Runtime.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GADTs #-}
+
+module HomeAssistant.Runtime
+  ( defaultMain
+  , app
+  , step
+  , CallIdGen
+  , mkCallIdGen
+  , hassEval
+  , receiveJSON
+  , wsCallService
+  ) where
+
+import AFRP (Mealy(..), Event(..))
+import HomeAssistant.Controller (HASSEff(..), lightController, Service(..))
+import Data.Aeson ((.=), Value (Null), encode, eitherDecode, object)
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+import qualified Network.WebSockets as WS
+import Network.Socket (withSocketsDo)
+import System.Environment (getEnv)
+import Data.Time (UTCTime, getCurrentTime)
+import Data.IORef (newIORef, atomicModifyIORef')
+
+step :: (forall x. eff x -> IO x) -> Mealy eff a b -> a -> IO (b, Mealy eff a b)
+step nt (Mealy f) a = do
+  now <- getCurrentTime
+  f nt now a
+
+defaultMain :: IO ()
+defaultMain = withSocketsDo $ do
+    token <- getEnv "HA_TOKEN"
+    gen <- mkCallIdGen 0
+    WS.runClient "last-resort-redux" 8123 "/api/websocket" (app gen token)
+
+app :: CallIdGen -> String -> WS.ClientApp ()
+app gen token conn = do
+    -- HA speaks first: {"type":"auth_required", ...}
+    authRequired <- receiveJSON conn
+    print authRequired
+
+    WS.sendTextData conn $ encode $ object
+        [ "type"         .= ("auth" :: T.Text)
+        , "access_token" .= token
+        ]
+
+    -- Expect {"type":"auth_ok", ...}
+    authResult <- receiveJSON conn
+    print authResult
+
+    getStateId <- generateCallId gen
+    WS.sendTextData conn $ encode $ object
+      [ "id" .= getStateId
+      , "type" .= ("get_states" :: T.Text)
+      ]
+    msg <- WS.receiveData conn :: IO BL.ByteString
+    BL.writeFile "/tmp/states.json" msg
+
+    subscribeId <- generateCallId gen
+    -- Subscription 1: all entity state changes
+    WS.sendTextData conn $ encode $ object
+        [ "id"         .= subscribeId
+        , "type"       .= ("subscribe_events" :: T.Text)
+        , "event_type" .= ("state_changed" :: T.Text)
+        ]
+
+    go lightController
+
+  where
+    go f = do
+      msg <- WS.receiveData conn :: IO BL.ByteString
+      let decoded = Event $ either (const Null) id $ eitherDecode @Value msg
+      (x, f') <- step (hassEval gen conn) f decoded
+      mapM_ print x
+      go f'
+
+receiveJSON :: WS.Connection -> IO Value
+receiveJSON conn = do
+    msg <- WS.receiveData conn
+    case eitherDecode msg of
+        Left err -> fail $ "Invalid JSON from Home Assistant: " ++ err
+        Right x  -> pure x
+
+wsCallService
+  :: WS.Connection
+  -> Int
+  -> T.Text
+  -> T.Text
+  -> T.Text
+  -> IO ()
+wsCallService conn requestId domain service entityId =
+  WS.sendTextData conn $ encode $ object
+    [ "id"      .= requestId
+    , "type"    .= ("call_service" :: T.Text)
+    , "domain"  .= domain
+    , "service" .= service
+    , "target"  .= object
+        [ "entity_id" .= entityId
+        ]
+    ]
+
+newtype CallIdGen = CallIdGen { generateCallId :: IO Int  }
+
+mkCallIdGen :: Int -> IO CallIdGen
+mkCallIdGen start = do
+  gen <- newIORef start
+  pure $ CallIdGen $ atomicModifyIORef' gen (\old -> let new = old + 1 in new `seq` (new, new))
+
+hassEval :: CallIdGen -> WS.Connection -> HASSEff a -> IO a
+hassEval gen conn = \case
+  CallService x -> do
+    callId <- generateCallId gen
+    print (callId, x)
+    -- wsCallService conn callId (serviceDomain x) (serviceName x) (serviceTarget x)
+  Pure a -> pure a
diff --git a/src/MyLib.hs b/src/MyLib.hs
deleted file mode 100644
index 72690fb..0000000
--- a/src/MyLib.hs
+++ /dev/null
@@ -1,352 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE Arrows #-}
-{-# LANGUAGE GADTs #-}
-
-module MyLib (defaultMain) where
-
-import Control.Monad (forever)
-import Data.Aeson ((.=), Value (Null), encode, eitherDecode, object)
-import qualified Data.Aeson.KeyMap as KM
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import qualified Network.WebSockets as WS
-import Network.Socket (withSocketsDo)
-import System.Environment (getEnv)
-import Control.Category (Category(..), (>>>))
-import Prelude hiding ((.), id)
-import Control.Arrow (Arrow(..), ArrowChoice(..), ArrowLoop(..), returnA)
-import Data.Time (UTCTime, getCurrentTime)
-import Data.Either (fromLeft)
-import Data.Bool (bool)
-import Control.Lens (has, only, prefixed, (^?), _Show, to)
-import Data.Aeson.Lens (key, _String)
-import qualified Data.Text.Lens as TL
-import Control.Monad.Fix (MonadFix (mfix))
-import Data.IORef (newIORef, atomicModifyIORef')
-
-newtype Mealy eff a b = Mealy
-  { runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> UTCTime -> a -> m (b, Mealy eff a b) }
-
-data HASSEff a where
-  CallService :: Service -> HASSEff ()
-  Pure :: a -> HASSEff a
-
-data Service = Service
-  { serviceDomain :: T.Text
-  , serviceName :: T.Text
-  , serviceData :: Maybe Value
-  , serviceTarget :: T.Text
-  }
-  deriving Show
-
-
-eff :: (a -> eff b) -> Mealy eff a b
-eff f = Mealy $ \nt _ x ->
-  nt (f x) >>= \b -> pure (b, eff f)
-
-
-type HASS a b = Mealy HASSEff a b
-
-callService :: Service -> HASS a ()
-callService service = eff (\_ -> CallService service)
-
-instance Category (Mealy eff) where
-  id = Mealy (\_ _ x -> pure (x, id))
-  (Mealy f) . (Mealy g) = Mealy $ \nt t a -> do
-    (b, g') <- g nt t a
-    (c, f') <- f nt t b
-    pure (c, f' . g')
-
-instance Arrow (Mealy eff) where
-  arr f = Mealy $ \_ _ b -> pure (f b, arr f)
-  first (Mealy f) = Mealy $ \nt t (b,d) -> do
-    (c, f') <- f nt t b
-    pure ((c, d), first f')
-
-instance ArrowChoice (Mealy eff) where
-  left (Mealy f) = Mealy $ \nt t -> \case
-    Left b -> do
-      (c, f') <- f nt t b
-      pure (Left c, left f')
-    Right d -> pure (Right d, left (Mealy f))
-
-instance ArrowLoop (Mealy eff) where
-  loop (Mealy f) = Mealy $ \nt t b -> do
-    ((c,_), f') <- mfix $ \((_,d), _) -> f nt t (b,d)
-    pure (c, loop f')
-
-instance Functor (Mealy eff a) where
-  fmap f (Mealy g) = Mealy $ \nt t a -> do
-    (b, g') <- g nt t a
-    pure (f b, fmap f g')
-
-instance Applicative (Mealy eff a) where
-  pure b = Mealy $ \_ _ _ -> pure (b, pure b)
-  Mealy f <*> Mealy x = Mealy $ \nt t a -> do
-    (f', fNext) <- f nt t a
-    (x', xNext) <- x nt t a
-    pure (f' x', fNext <*> xNext)
-
-
-data Event a
-  = Tick
-  | Event a
-  deriving (Show, Functor, Foldable, Traversable)
-
-
-hold :: a -> Mealy eff (Event a) a
-hold a = Mealy $ \_ _ -> \case
-  Tick -> pure (a, hold a)
-  Event a' -> pure (a', hold a')
-
-events :: Mealy eff (Event a) (Either () a)
-events = arr $ \case
-  Tick -> Left ()
-  Event a -> Right a
-
-switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b
-switch (Mealy f) s = Mealy $ \nt t a -> do
-  ((b, ev), f') <- f nt t a
-  case ev of
-          Tick -> pure (b, switch f' s)
-          Event x -> runMealy (s x) nt t a
-
-
-
-preMapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-preMapAccum f x extract = go x
-  where
-    go b = Mealy $ \_ _ a ->
-      let next = f b a
-      in pure (extract b, go next)
-
-preMapAccumUTCTime :: (UTCTime -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-preMapAccumUTCTime f x extract = go x
-  where
-    go b = Mealy $ \_ t a ->
-      let next = f t b a
-      in pure (extract b, go next)
-
-mapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-mapAccum f x extract = go x
-  where
-    go b = Mealy $ \_ _ a ->
-      let next = f b a
-      in pure (extract next, go next)
-
-mapAccumUTCTime :: (UTCTime -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-mapAccumUTCTime f x extract = go x
-  where
-    go b = Mealy $ \_ t a ->
-      let next = f t b a
-      in pure (extract next, go next)
-
-
-
-changes :: Eq a => Mealy eff a (Event a)
-changes = mapAccum go Nothing (maybe Tick snd)
-  where
-    go :: Eq a => Maybe (a, Event a) -> a -> Maybe (a, Event a)
-    -- The first observed value is not a change I think
-    go Nothing x = Just (x, Tick)
-    go (Just (y, _)) x | x == y = Just (x, Tick)
-                       | otherwise = Just (x, Event x)
-
-
-whenA :: (a -> Bool) -> Mealy eff a () -> Mealy eff a ()
-whenA predicate auto = arr (\a -> if predicate a then Left a else Right ()) >>> left auto >>> arr (fromLeft ())
-
-filterA :: (a -> Bool) -> Mealy eff a (Either () a)
-filterA f = arr $ \a -> bool (Left ()) (Right a) (f a)
-
-thenA :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
-thenA f g = f >>> arr Left ||| g
-
-(>>|) :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
-(>>|) = thenA
-
-infixl 1 >>|
-
-toEvent :: Mealy eff (Either () a) (Event a)
-toEvent = arr (either (const Tick) Event)
-
-ruuviTemperatures :: Mealy eff (Event Value) Double
-ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0
-
-ruuviPressures :: Mealy eff (Event Value) Double
-ruuviPressures = entityRead "sensor.ruuvitag_b168_pressure" >>> hold 0
-
-data Ruuvi = Ruuvi { ruuviTemperature :: Double, ruuviPressure :: Double }
-           deriving (Show, Eq)
-
-ruuvi :: Mealy eff (Event Value) (Event Ruuvi)
-ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes
-
-data Direction = Increase | Decrease | Steady
-  deriving (Show, Eq)
-
-numericDirection = mapAccum go (Nothing, Nothing) extract
-  where
-    go (_, old) new = (old, new)
-    extract :: (Maybe Double, Maybe Double) -> Direction
-    extract (old, new) = maybe Steady (\x -> if x >  0 then Increase else Decrease) $ (-) <$> old <*> new
-
-data DoorState = Open | Closed
-  deriving (Show, Eq)
-
-door :: HASS (Event Value) (Event DoorState)
-door = entityBool "binary_sensor.makuuhuone_ovi_contact"
-  >>> arr (fmap (bool Closed Open))
-  >>> hold Open
-  >>> changes
-
--- Turn off lights when door is closed
-light :: Bool -> Service
-light b = Service
-  { serviceDomain="light"
-  , serviceName= bool "turn_off" "turn_on" b
-  , serviceData=Nothing
-  , serviceTarget="light.bedroom_masse"
-  }
-
-lightController :: HASS (Event Value) (Event DoorState)
-lightController = proc ev -> do
-  doorState <- door -< ev
-  case doorState of
-       Event Open -> callService (light False) -< ()
-       Event Closed -> callService (light True) -< ()
-       _ -> returnA -< ()
-  returnA -< doorState
-
-entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value)
-entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent
-  where
-    isEntity :: Value -> Bool
-    isEntity = has (key "event" . key "data" . key "entity_id" . _String . only entityId)
-
-entityChangeEvent' :: T.Text -> Mealy eff (Event Value) (Either () Value)
-entityChangeEvent' entityId = events >>| filterA isEntity
-  where
-    isEntity :: Value -> Bool
-    isEntity = has (key "event" . key "data" . key "entity_id" . _String . only entityId)
-
-entityRead' :: (Read a) => T.Text -> Mealy eff (Event Value) (Either () a)
-entityRead' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right))
-  where
-    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read
-
-entityBool' :: T.Text -> Mealy eff (Event Value) (Either () Bool)
-entityBool' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right))
-  where
-    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to toBool
-    toBool = \case
-      "on" -> True
-      "off" -> False
-
-entityRead :: (Read a) => T.Text -> Mealy eff (Event Value) (Event a)
-entityRead entityId = entityRead' entityId >>> toEvent
-  where
-    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read
-
-entityBool :: T.Text -> Mealy eff (Event Value) (Event Bool)
-entityBool entityId = entityBool' entityId >>> toEvent
-  where
-    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read
-
-
-step :: (forall x. eff x -> IO x) -> Mealy eff a b -> a -> IO (b, Mealy eff a b)
-step nt (Mealy f) a = do
-  now <- getCurrentTime
-  f nt now a
-
-defaultMain :: IO ()
-defaultMain = withSocketsDo $ do
-    token <- getEnv "HA_TOKEN"
-    gen <- mkCallIdGen 0
-    WS.runClient "last-resort-redux" 8123 "/api/websocket" (app gen token)
-
-app :: CallIdGen -> String -> WS.ClientApp ()
-app gen token conn = do
-    -- HA speaks first: {"type":"auth_required", ...}
-    authRequired <- receiveJSON conn
-    print authRequired
-
-    WS.sendTextData conn $ encode $ object
-        [ "type"         .= ("auth" :: T.Text)
-        , "access_token" .= token
-        ]
-
-    -- Expect {"type":"auth_ok", ...}
-    authResult <- receiveJSON conn
-    print authResult
-
-    getStateId <- generateCallId gen
-    WS.sendTextData conn $ encode $ object
-      [ "id" .= getStateId
-      , "type" .= ("get_states" :: T.Text)
-      ]
-    msg <- WS.receiveData conn :: IO BL.ByteString
-    BL.writeFile "/tmp/states.json" msg
-
-    subscribeId <- generateCallId gen
-    -- Subscription 1: all entity state changes
-    WS.sendTextData conn $ encode $ object
-        [ "id"         .= subscribeId
-        , "type"       .= ("subscribe_events" :: T.Text)
-        , "event_type" .= ("state_changed" :: T.Text)
-        ]
-
-
-    go lightController
-
-  where
-    go f = do
-      msg <- WS.receiveData conn :: IO BL.ByteString
-      let decoded = Event $ either (const Null) id $ eitherDecode @Value msg
-      (x, f') <- step (hassEval gen conn) f decoded
-      mapM_ print x
-      go f'
-
-receiveJSON :: WS.Connection -> IO Value
-receiveJSON conn = do
-    msg <- WS.receiveData conn
-    case eitherDecode msg of
-        Left err -> fail $ "Invalid JSON from Home Assistant: " ++ err
-        Right x  -> pure x
-
-
-wsCallService
-  :: WS.Connection
-  -> Int           -- ^ request id
-  -> T.Text        -- ^ domain
-  -> T.Text        -- ^ service
-  -> T.Text        -- ^ entity id
-  -> IO ()
-wsCallService conn requestId domain service entityId =
-  WS.sendTextData conn $ encode $ object
-    [ "id"      .= requestId
-    , "type"    .= ("call_service" :: T.Text)
-    , "domain"  .= domain
-    , "service" .= service
-    , "target"  .= object
-        [ "entity_id" .= entityId
-        ]
-    ]
-
-newtype CallIdGen = CallIdGen { generateCallId :: IO Int  }
-
-mkCallIdGen :: Int -> IO CallIdGen
-mkCallIdGen start = do
-  gen <- newIORef start
-  pure $ CallIdGen $ atomicModifyIORef' gen (\old -> let new = old + 1 in new `seq` (new, new))
-
-hassEval :: CallIdGen -> WS.Connection -> HASSEff a -> IO a
-hassEval gen conn = \case
-  CallService x -> do
-    callId <- generateCallId gen
-    print (callId, x)
-    -- wsCallService conn callId (serviceDomain x) (serviceName x) (serviceTarget x)
-  Pure a -> pure a
-