Split MyLib into AFRP, Controller, Runtime

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