From 3c729366db09d0c37757a956e4c3559f48f53ac8 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Thu, 20 Aug 2026 19:34:56 +0300 Subject: [PATCH] Add Runtime.Connection reader and writer actions --- home-assistant-controller.cabal | 2 + src/HomeAssistant/Runtime/Connection.hs | 97 +++++++++++++++++++++++++ test/ConnectionSpec.hs | 32 ++++++++ test/Main.hs | 5 +- 4 files changed, 135 insertions(+), 1 deletion(-) create mode 100644 src/HomeAssistant/Runtime/Connection.hs create mode 100644 test/ConnectionSpec.hs diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index ff7a2e2..adda1d6 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -63,6 +63,7 @@ library , HomeAssistant.Controller , HomeAssistant.Runtime , HomeAssistant.Runtime.Bus + , HomeAssistant.Runtime.Connection -- Modules included in this library but not exported. -- other-modules: @@ -121,6 +122,7 @@ test-suite home-assistant-controller-test -- Modules included in this executable, other than Main. other-modules: BusSpec + , ConnectionSpec -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/src/HomeAssistant/Runtime/Connection.hs b/src/HomeAssistant/Runtime/Connection.hs new file mode 100644 index 0000000..a242468 --- /dev/null +++ b/src/HomeAssistant/Runtime/Connection.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module HomeAssistant.Runtime.Connection + ( readerAction + , writerAction + , encodeService + ) where + +import Control.Concurrent.STM + ( atomically + , readTChan + , readTVar + , retry + , writeTChan + , writeTVar + ) +import Control.Lens ((^?)) +import Control.Monad (forever) +import Data.Aeson (Value, eitherDecode, encode, object, (.=)) +import Data.Aeson.Lens (key, _String) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import Data.Void (Void) +import HomeAssistant.Controller (Service (..)) +import HomeAssistant.Runtime.Bus +import qualified Network.WebSockets as WS + +-- | Connect, authenticate, subscribe, then receive and broadcast forever. +-- Restarting this action reconnects. All setup sends happen before the +-- connection is published in the bus, so only the writer sends afterwards. +readerAction :: String -> Int -> String -> Bus -> IO Void +readerAction host port token bus = + WS.runClient host port "/api/websocket" $ \conn -> do + handshake conn token + subscribe bus conn + atomically $ writeTVar (busConn bus) (Just conn) + putStrLn "[reader] connected" + receiveLoop bus conn + +handshake :: WS.Connection -> String -> IO () +handshake conn token = do + required <- receiveJSON conn + expectType "auth_required" required + WS.sendTextData conn $ encode $ object + [ "type" .= ("auth" :: T.Text) + , "access_token" .= token + ] + ok <- receiveJSON conn + expectType "auth_ok" ok + +expectType :: T.Text -> Value -> IO () +expectType expected msg = + case msg ^? key "type" . _String of + Just t | t == expected -> pure () + _ -> fail $ "expected " <> T.unpack expected <> ", got: " <> show msg + +subscribe :: Bus -> WS.Connection -> IO () +subscribe bus conn = do + sid <- generateCallId (busGen bus) + WS.sendTextData conn $ encode $ object + [ "id" .= sid + , "type" .= ("subscribe_events" :: T.Text) + , "event_type" .= ("state_changed" :: T.Text) + ] + +-- | Undecodable messages are skipped: reconnecting cannot fix a decode +-- problem, so crashing here would only produce a hot restart loop. +receiveLoop :: Bus -> WS.Connection -> IO Void +receiveLoop bus conn = forever $ do + msg <- WS.receiveData conn :: IO BL.ByteString + case eitherDecode msg of + Left err -> putStrLn $ "[reader] skipping undecodable message: " <> err + Right v -> atomically $ writeTChan (busInbound bus) v + +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 + +writerAction :: Bus -> IO Void +writerAction bus = forever $ do + svc <- atomically $ readTChan (busOutbound bus) + conn <- atomically $ readTVar (busConn bus) >>= maybe retry pure + callId <- generateCallId (busGen bus) + WS.sendTextData conn $ encode $ encodeService callId svc + +encodeService :: Int -> Service -> Value +encodeService callId Service{..} = object $ + [ "id" .= callId + , "type" .= ("call_service" :: T.Text) + , "domain" .= serviceDomain + , "service" .= serviceName + , "target" .= object ["entity_id" .= serviceTarget] + ] <> maybe [] (\d -> ["service_data" .= d]) serviceData diff --git a/test/ConnectionSpec.hs b/test/ConnectionSpec.hs new file mode 100644 index 0000000..8079c19 --- /dev/null +++ b/test/ConnectionSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ConnectionSpec (spec) where + +import Data.Aeson (object, (.=)) +import Data.Text (Text) +import HomeAssistant.Controller (Service (..)) +import HomeAssistant.Runtime.Connection (encodeService) +import Test.Hspec + +spec :: Spec +spec = describe "encodeService" $ do + it "encodes a call_service message" $ + encodeService 7 (Service "light" "turn_on" Nothing "light.bedroom_masse") + `shouldBe` object + [ "id" .= (7 :: Int) + , "type" .= ("call_service" :: Text) + , "domain" .= ("light" :: Text) + , "service" .= ("turn_on" :: Text) + , "target" .= object ["entity_id" .= ("light.bedroom_masse" :: Text)] + ] + + it "includes service_data when present" $ + encodeService 8 (Service "light" "turn_on" (Just (object ["brightness" .= (200 :: Int)])) "light.bedroom_masse") + `shouldBe` object + [ "id" .= (8 :: Int) + , "type" .= ("call_service" :: Text) + , "domain" .= ("light" :: Text) + , "service" .= ("turn_on" :: Text) + , "target" .= object ["entity_id" .= ("light.bedroom_masse" :: Text)] + , "service_data" .= object ["brightness" .= (200 :: Int)] + ] diff --git a/test/Main.hs b/test/Main.hs index 163a4fe..0c2739e 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -2,6 +2,9 @@ module Main (main) where import Test.Hspec (hspec) import qualified BusSpec +import qualified ConnectionSpec main :: IO () -main = hspec BusSpec.spec +main = hspec $ do + BusSpec.spec + ConnectionSpec.spec