MasseR/home-assistant-controller
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Works

Browse Source
This commit is contained in:
MasseR
2026-08-21 13:15:31 +03:00
parent dfc744842d
commit e50a505a13
16 changed files with 85 additions and 3072 deletions
Download Patch File Download Diff File Expand all files Collapse all files
default.nix
+4 -4
View File
@@ -1,6 +1,6 @@
{ mkDerivation, aeson, annotated-exception, async, base, bytestring
, hedgehog, hspec, hspec-hedgehog, lens, lens-aeson, lib, network
, stm, text, time, uuid, websockets
, hedgehog, hspec, hspec-hedgehog, katip, lens, lens-aeson, lib
, network, stm, text, time, uuid, websockets
}:
mkDerivation {
pname = "home-assistant-controller";
@@ -9,8 +9,8 @@ mkDerivation {
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
aeson annotated-exception async base bytestring lens lens-aeson
network stm text time uuid websockets
aeson annotated-exception async base bytestring katip lens
lens-aeson network stm text time uuid websockets
];
executableHaskellDepends = [ base ];
testHaskellDepends = [
docs/superpowers/plans/2026-08-20-concurrent-runtime.md
-874
View File
@@ -1,874 +0,0 @@
# Concurrent Runtime Implementation Plan
> **For agentic workers:** REQUIRED SUB-SKILL: Use superpowers:subagent-driven-development (recommended) or superpowers:executing-plans to implement this plan task-by-task. Steps use checkbox (`- [ ]`) syntax for tracking.
**Goal:** Support multiple controllers over a single websocket connection: one reader thread broadcasting to per-controller channels, a writer thread sending queued service calls, supervised worker threads with backoff restarts, and reconnect-on-network-failure.
**Architecture:** A `Bus` (broadcast `TChan` inbound, `TChan` outbound, `TVar (Maybe Connection)`, existing `CallIdGen`) connects a reader thread (connect/auth/subscribe/receive-broadcast; restart = reconnect) and a writer thread to N controller threads, each stepping a `Mealy HASSEff` machine over its own dup'd channel. Slice 1 wires them with `mapConcurrently_` (any crash exits). Slice 2 wraps each worker in `supervised` (annotated-exception, exponential backoff, `Fatal` rethrow).
**Tech Stack:** Haskell (GHC 9.10, GHC2024), stm, async, annotated-exception, websockets, aeson, hspec, hedgehog. Nix/cabal build.
**Spec:** `docs/superpowers/specs/2026-08-20-concurrent-runtime-design.md`
## Global Constraints
- Run cabal only through the devShell: `nix develop -c cabal build` / `nix develop -c cabal test`.
- After changing the .cabal file, regenerate the derivation: `nix run nixpkgs#cabal2nix -- ./. > default.nix`. Never edit it by hand.
- `-Wall` (common `warnings` stanza) must produce zero warnings.
- Comments are minimal, contract-style: describe what, not how.
- Never read, print, or commit `secrets.yaml`.
- Commit after every task. Message style: short imperative, no prefix (see `git log`).
- Unit tests: hspec. Property tests: hedgehog.
- Modules are vertical (split by feature/concept, not layer).
## File Structure
| File | Responsibility |
|---|---|
| `src/HomeAssistant/Runtime/Bus.hs` (create) | Shared channels + connection cell + call-id gen + channel interpreter |
| `src/HomeAssistant/Runtime/Connection.hs` (create) | Reader/writer thread actions, pure `encodeService` |
| `src/HomeAssistant/Runtime/Supervisor.hs` (create, slice 2) | Generic restart-with-backoff combinator, `Backoff`, `Fatal` |
| `src/HomeAssistant/Runtime.hs` (rewrite) | Glue: `Controller`, `runController`, `controllers`, `defaultMain`, `step`, `dryRunHassEval` |
| `src/HomeAssistant/Controller.hs` (1-word change) | Derive `Eq` on `Service` (tests need it) |
| `test/Main.hs` (rewrite) | hspec runner |
| `test/BusSpec.hs`, `test/ConnectionSpec.hs`, `test/RuntimeSpec.hs`, `test/SupervisorSpec.hs`, `test/BackoffProp.hs` (create) | Specs |
| `home-assistant-controller.cabal` | Deps + module lists per task |
Slices: Tasks 1–3 = slice 1 (concurrency). Tasks 4–5 = slice 2 (robustness).
---
### Task 1: Bus module
**Files:**
- Create: `src/HomeAssistant/Runtime/Bus.hs`
- Modify: `src/HomeAssistant/Runtime.hs` (move `CallIdGen` out, re-export from Bus)
- Modify: `src/HomeAssistant/Controller.hs:43` (derive `Eq`)
- Modify: `home-assistant-controller.cabal` (exposed module, `stm` dep, test deps)
- Rewrite: `test/Main.hs`
- Create: `test/BusSpec.hs`
**Interfaces:**
- Consumes: `HASSEff(..)`, `Service` from `HomeAssistant.Controller`.
- Produces (Bus exports): `Bus(..)` with fields `busInbound :: TChan Value`, `busOutbound :: TChan Service`, `busConn :: TVar (Maybe WS.Connection)`, `busGen :: CallIdGen`; `CallIdGen(..)` (record field `generateCallId :: IO Int`); `mkCallIdGen :: Int -> IO CallIdGen`; `newBus :: Int -> IO Bus`; `channelHassEval :: Bus -> HASSEff a -> IO a`.
- [ ] **Step 1: Write the failing test**
`test/BusSpec.hs`:
```haskell
module BusSpec (spec) where
import Control.Concurrent.STM
( atomically
, dupTChan
, readTChan
, writeTChan
)
import Data.Aeson (Value (..))
import HomeAssistant.Controller (HASSEff (..), Service (..))
import HomeAssistant.Runtime.Bus
import Test.Hspec
spec :: Spec
spec = describe "Bus" $ do
it "broadcasts inbound messages to every dup'd channel in order" $ do
bus <- newBus 0
p1 <- atomically (dupTChan (busInbound bus))
p2 <- atomically (dupTChan (busInbound bus))
atomically $ writeTChan (busInbound bus) (Number 1)
atomically $ writeTChan (busInbound bus) (Number 2)
r1 <- atomically $ (,) <$> readTChan p1 <*> readTChan p1
r2 <- atomically $ (,) <$> readTChan p2 <*> readTChan p2
r1 `shouldBe` (Number 1, Number 2)
r2 `shouldBe` (Number 1, Number 2)
it "channelHassEval writes CallService to the outbound channel" $ do
bus <- newBus 0
let svc = Service "light" "turn_on" Nothing "light.bedroom_masse"
channelHassEval bus (CallService svc)
atomically (readTChan (busOutbound bus)) `shouldReturn` svc
it "channelHassEval leaves Pure untouched" $ do
bus <- newBus 0
channelHassEval bus (Pure 42) `shouldReturn` (42 :: Int)
it "generates unique sequential call ids" $ do
gen <- mkCallIdGen 0
a <- generateCallId gen
b <- generateCallId gen
(a, b) `shouldBe` (1, 2)
```
`test/Main.hs`:
```haskell
module Main (main) where
import Test.Hspec (hspec)
import qualified BusSpec
main :: IO ()
main = hspec BusSpec.spec
```
In `home-assistant-controller.cabal`:
Library section: add to `exposed-modules`: `HomeAssistant.Runtime.Bus`; add to `build-depends`: `stm`.
Test suite section: add `other-modules: BusSpec` and set:
```
build-depends:
base ^>=4.20.2.0,
home-assistant-controller,
hspec,
stm,
aeson,
text
```
In `src/HomeAssistant/Controller.hs` change line 43 from `deriving Show` to `deriving (Show, Eq)`.
- [ ] **Step 2: Run test to verify it fails**
Run: `nix develop -c cabal test`
Expected: FAIL — compile error, `Could not find module 'HomeAssistant.Runtime.Bus'`.
- [ ] **Step 3: Write the implementation**
`src/HomeAssistant/Runtime/Bus.hs`:
```haskell
{-# LANGUAGE LambdaCase #-}
module HomeAssistant.Runtime.Bus
( Bus(..)
, CallIdGen(..)
, mkCallIdGen
, newBus
, channelHassEval
) where
import Control.Concurrent.STM
( TChan
, TVar
, atomically
, newBroadcastTChanIO
, newTChanIO
, newTVarIO
, writeTChan
)
import Data.Aeson (Value)
import Data.IORef (atomicModifyIORef', newIORef)
import HomeAssistant.Controller (HASSEff (..), Service)
import Network.WebSockets (Connection)
-- | Shared runtime state: inbound is a broadcast channel (controllers
-- read from 'dupTChan' copies), outbound queues service calls for the
-- writer, conn holds the current websocket (Nothing before first connect).
data Bus = Bus
{ busInbound :: TChan Value
, busOutbound :: TChan Service
, busConn :: TVar (Maybe Connection)
, busGen :: CallIdGen
}
newBus :: Int -> IO Bus
newBus start = Bus
<$> newBroadcastTChanIO
<*> newTChanIO
<*> newTVarIO Nothing
<*> mkCallIdGen start
channelHassEval :: Bus -> HASSEff a -> IO a
channelHassEval bus = \case
CallService svc -> atomically $ writeTChan (busOutbound bus) svc
Pure a -> pure a
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))
```
Then in `src/HomeAssistant/Runtime.hs`:
- Delete the local `newtype CallIdGen`/`mkCallIdGen` definitions (lines 105–110).
- Add import: `import HomeAssistant.Runtime.Bus (CallIdGen(..), mkCallIdGen)`.
- Export list stays the same (`CallIdGen`, `mkCallIdGen` now re-exported from Bus).
- [ ] **Step 4: Regenerate the nix derivation**
Run: `nix run nixpkgs#cabal2nix -- ./. > default.nix`
Expected: no output; `git diff default.nix` shows the new `stm`/test dependencies.
- [ ] **Step 5: Run tests to verify they pass**
Run: `nix develop -c cabal build && nix develop -c cabal test`
Expected: build with zero warnings; 4 examples, 0 failures.
- [ ] **Step 6: Commit**
```bash
git add src test home-assistant-controller.cabal default.nix
git commit -m "Add Runtime.Bus with channel-based effect interpreter"
```
---
### Task 2: Connection module (reader/writer actions)
**Files:**
- Create: `src/HomeAssistant/Runtime/Connection.hs`
- Create: `test/ConnectionSpec.hs`
- Modify: `test/Main.hs`, `home-assistant-controller.cabal`
**Interfaces:**
- Consumes: `Bus(..)`, `CallIdGen(..)` from Task 1.
- Produces (Connection exports): `readerAction :: String -> Int -> String -> Bus -> IO Void` (host, port, token; restart = reconnect); `writerAction :: Bus -> IO Void`; `encodeService :: Int -> Service -> Data.Aeson.Value`.
**Background for the implementer (verified facts, do not re-verify):**
- `WS.runClient` runs the `ClientApp` under `bracket` and closes the socket/stream when the app throws — reconnects do not leak fds.
- Exceptions from `WS.receiveData` (e.g. `ConnectionClosed`) are what make the reader restartable; connect failures throw `IOException`.
- HA sends a `result` ack for `subscribe_events`; we deliberately do not read it — it flows to controllers and is filtered out by their entity-id lenses (same as current behavior).
- [ ] **Step 1: Write the failing test**
`test/ConnectionSpec.hs`:
```haskell
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)]
]
```
`test/Main.hs`: add `import qualified ConnectionSpec` and change `main` to:
```haskell
main :: IO ()
main = hspec $ do
BusSpec.spec
ConnectionSpec.spec
```
Cabal: library `exposed-modules` += `HomeAssistant.Runtime.Connection`; test `other-modules` += `ConnectionSpec`.
- [ ] **Step 2: Run test to verify it fails**
Run: `nix develop -c cabal test`
Expected: FAIL — `Could not find module 'HomeAssistant.Runtime.Connection'`.
- [ ] **Step 3: Write the implementation**
`src/HomeAssistant/Runtime/Connection.hs`:
```haskell
{-# 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
```
- [ ] **Step 4: Run tests to verify they pass**
Run: `nix develop -c cabal build && nix develop -c cabal test`
Expected: zero warnings; 6 examples, 0 failures.
- [ ] **Step 5: Commit**
```bash
git add src test home-assistant-controller.cabal
git commit -m "Add Runtime.Connection reader and writer actions"
```
---
### Task 3: Runtime rewrite — controller threads and wiring (completes slice 1)
**Files:**
- Rewrite: `src/HomeAssistant/Runtime.hs`
- Create: `test/RuntimeSpec.hs`
- Modify: `test/Main.hs`, `home-assistant-controller.cabal`
**Interfaces:**
- Consumes: `Bus(..)`, `newBus`, `channelHassEval`, `CallIdGen(..)`, `mkCallIdGen` (Task 1); `readerAction`, `writerAction` (Task 2).
- Produces (Runtime exports): `defaultMain :: IO ()`, `step`, `dryRunHassEval`, `CallIdGen`, `mkCallIdGen`, `Controller(..)` with `data Controller = forall b. Controller T.Text (HASS (Event Value) b)`, `runController :: Bus -> Controller -> IO Void`.
- Removes exports: `app`, `hassEval`, `wsCallService`, `receiveJSON` (deleted or internal to Connection). The `get_states` debug dump goes away.
**Background:** `mapConcurrently_` rethrows the first worker exception and cancels the rest — a crash exits the process, same as today. That is intended for slice 1.
- [ ] **Step 1: Write the failing test**
`test/RuntimeSpec.hs`:
```haskell
{-# LANGUAGE OverloadedStrings #-}
module RuntimeSpec (spec) where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async)
import Control.Concurrent.STM (atomically, readTChan, writeTChan)
import Data.Aeson (Value, object, (.=))
import Data.Text (Text)
import HomeAssistant.Controller (light, lightController)
import HomeAssistant.Runtime (Controller (..), runController)
import HomeAssistant.Runtime.Bus
import Test.Hspec
spec :: Spec
spec = describe "runController" $ do
it "feeds inbound events through the machine and forwards service calls" $ do
bus <- newBus 0
_ <- async (runController bus (Controller "test" lightController))
threadDelay 100000 -- let the controller dup its inbound channel
atomically $ writeTChan (busInbound bus) (doorEvent "on") -- initial value: no change event
atomically $ writeTChan (busInbound bus) (doorEvent "off") -- door closes: lights on
atomically $ writeTChan (busInbound bus) (doorEvent "on") -- door opens: lights off
svc1 <- atomically (readTChan (busOutbound bus))
svc2 <- atomically (readTChan (busOutbound bus))
svc1 `shouldBe` light True
svc2 `shouldBe` light False
doorEvent :: Text -> Value
doorEvent state = object
[ "event" .= object
[ "data" .= object
[ "entity_id" .= ("binary_sensor.makuuhuone_ovi_contact" :: Text)
, "new_state" .= object ["state" .= state]
]
]
]
```
Note: the first event only seeds the machine (`changes` does not fire on the initial value), hence two expected service calls, not three.
`test/Main.hs`: add `import qualified RuntimeSpec`; run all three specs. Cabal: test `other-modules` += `RuntimeSpec`, test `build-depends` += `async`.
- [ ] **Step 2: Run test to verify it fails**
Run: `nix develop -c cabal test`
Expected: FAIL — `Controller` / `runController` not in scope.
- [ ] **Step 3: Rewrite the Runtime module**
Replace `src/HomeAssistant/Runtime.hs` entirely with:
```haskell
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module HomeAssistant.Runtime
( defaultMain
, step
, CallIdGen
, mkCallIdGen
, dryRunHassEval
, Controller(..)
, runController
) where
import AFRP (Event (..), Mealy (..))
import Control.Concurrent.Async (mapConcurrently_)
import Control.Concurrent.STM (atomically, dupTChan, readTChan)
import Data.Aeson (Value)
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import Data.Void (Void)
import HomeAssistant.Controller (HASS, HASSEff (..), lightController)
import HomeAssistant.Runtime.Bus
import HomeAssistant.Runtime.Connection (readerAction, writerAction)
import Network.Socket (withSocketsDo)
import System.Environment (getEnv)
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
data Controller = forall b. Controller T.Text (HASS (Event Value) b)
controllers :: [Controller]
controllers = [Controller "light" lightController]
-- | Steps the machine for every inbound message; service calls go to the
-- bus. A restart re-dups the inbound channel and starts from the machine's
-- initial state; messages broadcast during the restart window are lost.
runController :: Bus -> Controller -> IO Void
runController bus (Controller _name machine) = do
inbound <- atomically (dupTChan (busInbound bus))
go inbound machine
where
go inbound f = do
msg <- atomically (readTChan inbound)
(_, f') <- step (channelHassEval bus) f (Event msg)
go inbound f'
defaultMain :: IO ()
defaultMain = withSocketsDo $ do
token <- getEnv "HA_TOKEN"
bus <- newBus 0
mapConcurrently_ id $
[ readerAction "last-resort-redux" 8123 token bus
, writerAction bus
] ++ map (runController bus) controllers
dryRunHassEval :: CallIdGen -> HASSEff a -> IO a
dryRunHassEval gen = \case
CallService x -> do
callId <- generateCallId gen
print (callId, x)
Pure a -> pure a
```
- [ ] **Step 4: Regenerate derivation and run tests**
Run: `nix run nixpkgs#cabal2nix -- ./. > default.nix && nix develop -c cabal build && nix develop -c cabal test`
Expected: zero warnings; 7 examples, 0 failures.
- [ ] **Step 5: Commit**
```bash
git add src test home-assistant-controller.cabal default.nix
git commit -m "Run controllers on their own threads over the bus"
```
---
### Task 4: Supervisor module (starts slice 2)
**Files:**
- Create: `src/HomeAssistant/Runtime/Supervisor.hs`
- Create: `test/SupervisorSpec.hs`, `test/BackoffProp.hs`
- Modify: `test/Main.hs`, `home-assistant-controller.cabal`
**Interfaces:**
- Consumes: nothing from other runtime modules (generic).
- Produces: `supervised :: Text -> Backoff -> IO Void -> IO Void`; `Backoff(..)` (`backoffBase`, `backoffCap`, `backoffQuiet`, all `NominalDiffTime`); `defaultBackoff` (= `Backoff 0.1 30 30`); `backoffDelay :: Backoff -> Int -> NominalDiffTime`; `nextAttempt :: Backoff -> NominalDiffTime -> Int -> Int`; `Fatal (..)` (`newtype Fatal = Fatal Text`).
**Background (verified, do not re-verify):** `Control.Exception.Annotated` is built on safe-exceptions: its `catch`/`catches`/`try` only catch *synchronous* exceptions, so async exceptions propagate without any manual `SomeAsyncException` filtering. `catch @(AnnotatedException e)` sees through a single `AnnotatedException` wrapper (bare `e` gets an empty annotation set), which is how the `Fatal` handler below works.
**Invariant (document in code):** actions passed to `supervised` must not be wrapped in `checkpoint`s around `Fatal`-throwing code — a double-wrapped `Fatal` is invisible to the handler and would restart instead of crashing. The reader honors this (Task 5).
- [ ] **Step 1: Write the failing tests**
`test/SupervisorSpec.hs`:
```haskell
{-# LANGUAGE OverloadedStrings #-}
module SupervisorSpec (spec) where
import Control.Concurrent (newEmptyMVar, putMVar, readMVar, threadDelay)
import Control.Concurrent.Async (async, cancel, poll, waitCatch)
import Control.Exception (SomeException, fromException)
import Control.Exception.Annotated (AnnotatedException (..), throw)
import Control.Monad (forever)
import Data.IORef (atomicModifyIORef', newIORef, readIORef)
import Data.Maybe (isJust, isNothing)
import HomeAssistant.Runtime.Supervisor
import System.IO.Error (ioError, userError)
import Test.Hspec
tinyBackoff :: Backoff
tinyBackoff = Backoff 0.001 0.002 0.001
spec :: Spec
spec = describe "supervised" $ do
it "restarts a crashing action until it stays up" $ do
counter <- newIORef (0 :: Int)
up <- newEmptyMVar
let action = do
n <- atomicModifyIORef' counter (\c -> (c + 1, c + 1))
if n < 3
then ioError (userError "boom")
else do putMVar up (); forever (threadDelay 1000000)
sup <- async (supervised "test" tinyBackoff action)
readMVar up
threadDelay 50000
status <- poll sup
isNothing status `shouldBe` True
readIORef counter `shouldReturn` 3
cancel sup
it "rethrows Fatal instead of restarting" $ do
counter <- newIORef (0 :: Int)
let action = do
atomicModifyIORef' counter (\c -> (c + 1, c + 1))
throw (Fatal "auth_invalid")
sup <- async (supervised "test" tinyBackoff action)
res <- waitCatch sup
case res of
Left se -> case fromException se :: Maybe (AnnotatedException Fatal) of
Just _ -> pure ()
Nothing -> expectationFailure "expected Fatal to propagate"
Right _ -> expectationFailure "supervised returned"
threadDelay 50000
readIORef counter `shouldReturn` 1
it "does not restart on async exceptions" $ do
counter <- newIORef (0 :: Int)
let action = do
atomicModifyIORef' counter (\c -> (c + 1, c + 1))
forever (threadDelay 1000000)
sup <- async (supervised "test" tinyBackoff action)
threadDelay 100000
cancel sup
threadDelay 100000
readIORef counter `shouldReturn` 1
status <- poll sup
isJust status `shouldBe` True
describe "nextAttempt" $ do
it "resets after a quiet period" $
nextAttempt tinyBackoff 0.001 5 `shouldBe` 1
it "increments otherwise" $
nextAttempt tinyBackoff 0.0005 5 `shouldBe` 6
describe "backoffDelay" $ do
it "starts at base" $ backoffDelay tinyBackoff 1 `shouldBe` 0.001
it "doubles" $ backoffDelay tinyBackoff 2 `shouldBe` 0.002
it "clamps at cap" $ backoffDelay tinyBackoff 3 `shouldBe` 0.002
```
`test/BackoffProp.hs`:
```haskell
module BackoffProp (spec) where
import Data.Time (NominalDiffTime)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import HomeAssistant.Runtime.Supervisor (Backoff (..), backoffDelay)
import Test.Hspec (Spec, describe, it)
import Test.Hspec.Hedgehog (hedgehog, forAll, (===))
spec :: Spec
spec = describe "backoffDelay" $
it "doubles from base, clamped at cap" $ hedgehog $ do
baseD <- forAll $ Gen.double (Range.constant 0.0001 10)
ratio <- forAll $ Gen.double (Range.constant 1 100)
let base = realToFrac baseD :: NominalDiffTime
cap = realToFrac (baseD * ratio) :: NominalDiffTime
backoff = Backoff base cap 1
delays = map (backoffDelay backoff) [1 .. 100 :: Int]
head delays === min cap base
mapM_ (\(a, b) -> b === min cap (a * 2)) (zip delays (drop 1 delays))
```
(`hspec-hedgehog` provides the `hedgehog` bridge — plain hedgehog 1.5 has
no hspec integration — and re-exports `forAll` and `(===)`.)
`test/Main.hs`: add imports and run all five specs. Cabal: library `exposed-modules` += `HomeAssistant.Runtime.Supervisor`, library `build-depends` += `annotated-exception`; test `other-modules` += `SupervisorSpec, BackoffProp`, test `build-depends` += `hedgehog, hspec-hedgehog, annotated-exception, time`.
- [ ] **Step 2: Run tests to verify they fail**
Run: `nix develop -c cabal test`
Expected: FAIL — `Could not find module 'HomeAssistant.Runtime.Supervisor'`.
- [ ] **Step 3: Write the implementation**
`src/HomeAssistant/Runtime/Supervisor.hs`:
```haskell
{-# LANGUAGE ScopedTypeVariables #-}
module HomeAssistant.Runtime.Supervisor
( supervised
, Backoff(..)
, defaultBackoff
, backoffDelay
, nextAttempt
, Fatal(..)
) where
import Control.Concurrent (threadDelay)
import Control.Exception.Annotated
( Exception
, Handler (..)
, SomeException
, catches
, displayException
, throw
)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime)
import Data.Void (Void)
-- | A failure that cannot be fixed by restarting; propagates out of
-- 'supervised' and terminates the process.
newtype Fatal = Fatal Text
deriving (Show, Exception)
data Backoff = Backoff
{ backoffBase :: NominalDiffTime -- ^ Delay before the first restart
, backoffCap :: NominalDiffTime -- ^ Maximum delay between restarts
, backoffQuiet :: NominalDiffTime -- ^ Uptime after which the delay resets
}
deriving (Eq, Show)
defaultBackoff :: Backoff
defaultBackoff = Backoff 0.1 30 30
-- | Delay before the @attempt@-th restart: doubles from base, clamped at cap.
backoffDelay :: Backoff -> Int -> NominalDiffTime
backoffDelay (Backoff base cap _) attempt = go (attempt - 1) base
where
go 0 d = d
go n d = go (n - 1) (min cap (d * 2))
-- | Attempt number to use after a crash that ran for the given uptime.
nextAttempt :: Backoff -> NominalDiffTime -> Int -> Int
nextAttempt (Backoff _ _ quiet) uptime attempt
| uptime >= quiet = 1
| otherwise = attempt + 1
-- | Runs the action forever, restarting it with backoff after synchronous
-- exceptions; async exceptions propagate. 'Fatal' is rethrown (crashing the
-- caller) rather than restarted. The action must never return normally and
-- must not be wrapped in checkpoints around 'Fatal'-throwing code: a
-- doubly-wrapped 'Fatal' is indistinguishable from a crash and would be
-- restarted instead of escalated.
supervised :: Text -> Backoff -> IO Void -> IO Void
supervised name backoff action = go 1
where
go attempt = do
start <- getCurrentTime
outcome <- (action >> pure (Nothing :: Maybe (Either Fatal SomeException))) `catches`
[ Handler $ \(f :: Fatal) -> pure (Just (Left f))
, Handler $ \(e :: SomeException) -> pure (Just (Right e))
]
case outcome of
Nothing -> error "unreachable: supervised action returned"
Just (Left f) -> throw f
Just (Right e) -> do
putStrLn $ "[" <> T.unpack name <> "] attempt " <> show attempt <> " crashed: " <> displayException e
let delay = backoffDelay backoff attempt
putStrLn $ "[" <> T.unpack name <> "] restarting in " <> show delay <> "s"
threadDelay (round (realToFrac delay * 1000000))
end <- getCurrentTime
go (nextAttempt backoff (diffUTCTime end start) attempt)
```
- [ ] **Step 4: Regenerate derivation and run tests**
Run: `nix run nixpkgs#cabal2nix -- ./. > default.nix && nix develop -c cabal build && nix develop -c cabal test`
Expected: zero warnings; 15 examples and 1 property, 0 failures.
- [ ] **Step 5: Commit**
```bash
git add src test home-assistant-controller.cabal default.nix
git commit -m "Add supervisor with backoff restarts"
```
---
### Task 5: Supervised wiring and fatal auth (completes slice 2)
**Files:**
- Modify: `src/HomeAssistant/Runtime.hs` (defaultMain only)
- Modify: `src/HomeAssistant/Runtime/Connection.hs` (Fatal in handshake)
**Interfaces:**
- Consumes: `supervised`, `defaultBackoff`, `Fatal` (Task 4).
- Produces: no new exports; `defaultMain` behavior changes: workers are supervised, auth failure exits the process with `Fatal`.
**Background:** `waitAny` rethrows the exception of the first completed async. Supervised workers only complete by rethrowing `Fatal`, so `waitAny` blocks forever in normal operation and propagates `Fatal` otherwise.
- [ ] **Step 1: Change `defaultMain` in `src/HomeAssistant/Runtime.hs`**
Update imports: replace `mapConcurrently_` with `async, waitAny` from `Control.Concurrent.Async`; add `absurd` to the `Data.Void` import; add `import HomeAssistant.Runtime.Supervisor (defaultBackoff, supervised)`. Replace `defaultMain` with:
```haskell
defaultMain :: IO ()
defaultMain = withSocketsDo $ do
token <- getEnv "HA_TOKEN"
bus <- newBus 0
let workers =
[ ("reader", readerAction "last-resort-redux" 8123 token bus)
, ("writer", writerAction bus)
] ++ [ (name, runController bus c) | c@(Controller name _) <- controllers ]
as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers
(_, v) <- waitAny as
absurd v
```
- [ ] **Step 2: Make handshake failures fatal in `src/HomeAssistant/Runtime/Connection.hs`**
Add imports: `import HomeAssistant.Runtime.Supervisor (Fatal)` and `throw` from `Control.Exception.Annotated`. Change `expectType` and `receiveJSON`:
```haskell
expectType :: T.Text -> Value -> IO ()
expectType expected msg =
case msg ^? key "type" . _String of
Just t | t == expected -> pure ()
_ -> throw (Fatal $ "expected " <> expected <> ", got: " <> T.pack (show msg))
```
```haskell
receiveJSON :: WS.Connection -> IO Value
receiveJSON conn = do
msg <- WS.receiveData conn
case eitherDecode msg of
Left err -> throw (Fatal $ "Invalid JSON from Home Assistant: " <> T.pack err)
Right x -> pure x
```
The `fail`-based behavior (crash the process) is preserved for slice 1's semantics but now carries a `Fatal` marker the supervisor escalates. Do **not** add checkpoints around the handshake — see the `supervised` contract.
- [ ] **Step 3: Build and test**
Run: `nix develop -c cabal build && nix develop -c cabal test`
Expected: zero warnings, zero test failures.
- [ ] **Step 4: Manual smoke check (optional, needs real HA)**
Run: `HA_TOKEN=... nix develop -c cabal run home-assistant-controller` (only if a Home Assistant instance is reachable; otherwise skip — unit tests cover the wiring logic).
- [ ] **Step 5: Commit**
```bash
git add src
git commit -m "Supervise workers and make auth failures fatal"
```
---
## Verification (all tasks)
- `nix develop -c cabal build` — zero warnings under `-Wall`.
- `nix develop -c cabal test` — all specs green.
- `git status` clean after each commit.
## Non-goals (from spec)
- Request/response correlation for service calls; dynamic controller registration; structured logging; env-based host/port config; state pre-seeding via `get_states`; multiple websocket connections.
## Gaps accepted by spec
- Reader's connect/auth/subscribe loop has no integration test (thin IO glue over `WS.runClient`; localhost fake-server scaffolding judged not worth the complexity).
- `Fatal` detection relies on the no-checkpoints-around-handshake invariant (documented in `supervised`'s contract and Task 5).
docs/superpowers/plans/2026-08-20-module-split.md
-732
View File
@@ -1,732 +0,0 @@
# Module Split & Warning Cleanup Implementation Plan
> **For agentic workers:** REQUIRED SUB-SKILL: Use superpowers:subagent-driven-development (recommended) or superpowers:executing-plans to implement this plan task-by-task. Steps use checkbox (`- [ ]`) syntax for tracking.
**Goal:** Split the monolithic `src/MyLib.hs` into three vertically-separated modules and fix all compiler warnings, committing between changes.
**Architecture:** Three modules: `AFRP` (generic Mealy/Event FRP machinery), `HomeAssistant.Controller` (HA domain: effects, entity parsers, controllers), `HomeAssistant.Runtime` (IO interpreter, websocket client, `defaultMain`). Two commits: mechanical split, then warning fixes.
**Tech Stack:** Haskell, GHC 9.10.3, cabal, GHC2024 default language
## Global Constraints
- Build tool: `cabal build`
- GHC 9.10.3, `default-language: GHC2024` (provides `RankNTypes`, `TypeApplications`, `GADTSyntax` — do not re-declare these)
- Warning baseline: cabal `common warnings` uses `-Wall`; verify with `cabal build --ghc-options="-Wall -Wincomplete-uni-patterns -Wincomplete-record-updates"`
- No test framework (test suite is a placeholder; testing is out of scope per spec)
- Commit between every change (user instruction)
- The only behavioral change: dormant `wsCallService` call is activated inside real `hassEval`, but `app` wires to `dryRunHassEval` to preserve current print-only behavior
---
## File Structure
| File | Responsibility | Created/Modified |
|---|---|---|
| `src/AFRP.hs` | Generic Mealy/Event FRP machinery — zero HA knowledge | Created in Task 1 |
| `src/HomeAssistant/Controller.hs` | HA domain: `HASSEff`, `Service`, entity parsers, controllers | Created in Task 1, edited in Task 2 |
| `src/HomeAssistant/Runtime.hs` | IO interpreter, websocket client, `defaultMain` | Created in Task 1, edited in Task 2 |
| `src/MyLib.hs` | (deleted) | Deleted in Task 1 |
| `app/Main.hs` | Entry point; import updated | Modified in Task 1 |
| `home-assistant-controller.cabal` | `exposed-modules` updated | Modified in Task 1 |
---
## Task 1: Split MyLib into AFRP, Controller, Runtime
**Files:**
- Create: `src/AFRP.hs`
- Create: `src/HomeAssistant/Controller.hs`
- Create: `src/HomeAssistant/Runtime.hs`
- Delete: `src/MyLib.hs`
- Modify: `app/Main.hs`
- Modify: `home-assistant-controller.cabal`
**Interfaces:**
- `AFRP` produces: `Mealy(..)`, `eff`, `Event(..)`, `hold`, `events`, `switch`, `preMapAccum`, `preMapAccumUTCTime`, `mapAccum`, `mapAccumUTCTime`, `changes`, `whenA`, `filterA`, `thenA`, `(>>|)`, `toEvent`
- `HomeAssistant.Controller` consumes from `AFRP`: `Mealy`, `eff`, `Event(..)`, `hold`, `events`, `changes`, `mapAccum`, `filterA`, `(>>|)`, `toEvent`
- `HomeAssistant.Controller` produces: `Service(..)`, `HASSEff(..)`, `HASS`, `callService`, entity helpers, domain types/values, `lightController`
- `HomeAssistant.Runtime` consumes from `AFRP`: `Mealy(..)`, `Event(..)`; from `HomeAssistant.Controller`: `HASSEff(..)`, `lightController`, `Service(..)`
- `HomeAssistant.Runtime` produces: `defaultMain`, `app`, `step`, `CallIdGen`, `mkCallIdGen`, `hassEval`, `receiveJSON`, `wsCallService`
After this task: build succeeds, 6 warnings remain (numericDirection, isEntity, state x2, toBool, conn).
- [ ] **Step 1: Create `src/AFRP.hs`**
```haskell
{-# 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)
```
- [ ] **Step 2: Create the `src/HomeAssistant/` directory**
Run: `mkdir -p src/HomeAssistant`
- [ ] **Step 3: Create `src/HomeAssistant/Controller.hs`**
Note: This is the Task 1 version — it still contains `numericDirection`, dead `where` clauses, and non-exhaustive `toBool`. Those are fixed in Task 2.
```haskell
{-# 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
```
- [ ] **Step 4: Create `src/HomeAssistant/Runtime.hs`**
Note: This is the Task 1 version — `hassEval` still has the commented-out `wsCallService` call and `conn` is unused. `dryRunHassEval` does not exist yet. Both are addressed in Task 2.
```haskell
{-# 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
```
- [ ] **Step 5: Delete `src/MyLib.hs`**
Run: `git rm src/MyLib.hs`
- [ ] **Step 6: Update `app/Main.hs`**
Replace the entire file content with:
```haskell
module Main (main) where
import qualified HomeAssistant.Runtime (defaultMain)
main :: IO ()
main = do
putStrLn "Hello, Haskell!"
HomeAssistant.Runtime.defaultMain
```
- [ ] **Step 7: Update `home-assistant-controller.cabal`**
In the `library` section, replace:
```
exposed-modules: MyLib
```
with:
```
exposed-modules: AFRP
, HomeAssistant.Controller
, HomeAssistant.Runtime
```
- [ ] **Step 8: Build to verify it compiles**
Run: `cabal build`
Expected: Build succeeds. Warnings appear for: `numericDirection`, `isEntity`, `state` (x2), `toBool` (non-exhaustive), `conn` (unused match). The `entityChangeEvent`, `entityRead'`, `entityRead`, and `wsCallService` warnings are resolved by the export lists.
If the build fails, read the error, fix the issue, and rebuild before proceeding.
- [ ] **Step 9: Commit**
```bash
git add src/AFRP.hs src/HomeAssistant/Controller.hs src/HomeAssistant/Runtime.hs app/Main.hs home-assistant-controller.cabal
git commit -m "Split MyLib into AFRP, Controller, Runtime"
```
---
## Task 2: Fix warnings
**Files:**
- Modify: `src/HomeAssistant/Controller.hs`
- Modify: `src/HomeAssistant/Runtime.hs`
**Interfaces:**
- `HomeAssistant.Runtime` new export: `dryRunHassEval :: CallIdGen -> HASSEff a -> IO a`
- `HomeAssistant.Runtime` changed export list: add `dryRunHassEval`
After this task: `cabal build --ghc-options="-Wall -Wincomplete-uni-patterns -Wincomplete-record-updates"` produces zero warnings.
- [ ] **Step 1: Delete `Direction` and `numericDirection` from `Controller.hs`**
Remove these lines from `src/HomeAssistant/Controller.hs`:
```haskell
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
```
- [ ] **Step 2: Remove `mapAccum` from the AFRP import in `Controller.hs`**
In `src/HomeAssistant/Controller.hs`, change:
```haskell
import AFRP (Mealy, eff, Event(..), hold, events, changes, mapAccum, filterA, (>>|), toEvent)
```
to:
```haskell
import AFRP (Mealy, eff, Event(..), hold, events, changes, filterA, (>>|), toEvent)
```
- [ ] **Step 3: Delete dead `isEntity` from `entityChangeEvent` in `Controller.hs`**
Change:
```haskell
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)
```
to:
```haskell
entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value)
entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent
```
- [ ] **Step 4: Delete dead `state` from `entityRead` in `Controller.hs`**
Change:
```haskell
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
```
to:
```haskell
entityRead :: (Read a) => T.Text -> Mealy eff (Event Value) (Event a)
entityRead entityId = entityRead' entityId >>> toEvent
```
- [ ] **Step 5: Delete dead `state` from `entityBool` in `Controller.hs`**
Change:
```haskell
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
```
to:
```haskell
entityBool :: T.Text -> Mealy eff (Event Value) (Event Bool)
entityBool entityId = entityBool' entityId >>> toEvent
```
- [ ] **Step 6: Add catch-all to `toBool` in `entityBool'` in `Controller.hs`**
Change:
```haskell
toBool = \case
"on" -> True
"off" -> False
```
to:
```haskell
toBool = \case
"on" -> True
"off" -> False
_ -> False
```
- [ ] **Step 7: Add `dryRunHassEval` and fix `hassEval` in `Runtime.hs`**
In `src/HomeAssistant/Runtime.hs`, change:
```haskell
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
```
to:
```haskell
hassEval :: CallIdGen -> WS.Connection -> HASSEff a -> IO a
hassEval gen conn = \case
CallService x -> do
callId <- generateCallId gen
wsCallService conn callId (serviceDomain x) (serviceName x) (serviceTarget x)
Pure a -> pure a
dryRunHassEval :: CallIdGen -> HASSEff a -> IO a
dryRunHassEval gen = \case
CallService x -> do
callId <- generateCallId gen
print (callId, x)
Pure a -> pure a
```
- [ ] **Step 8: Add `dryRunHassEval` to the export list in `Runtime.hs`**
In `src/HomeAssistant/Runtime.hs`, change:
```haskell
module HomeAssistant.Runtime
( defaultMain
, app
, step
, CallIdGen
, mkCallIdGen
, hassEval
, receiveJSON
, wsCallService
) where
```
to:
```haskell
module HomeAssistant.Runtime
( defaultMain
, app
, step
, CallIdGen
, mkCallIdGen
, hassEval
, dryRunHassEval
, receiveJSON
, wsCallService
) where
```
- [ ] **Step 9: Wire `app` to use `dryRunHassEval` in `Runtime.hs`**
In `src/HomeAssistant/Runtime.hs`, inside the `go` function in `app`, change:
```haskell
(x, f') <- step (hassEval gen conn) f decoded
```
to:
```haskell
(x, f') <- step (dryRunHassEval gen) f decoded
```
- [ ] **Step 10: Build with full warning flags to verify zero warnings**
Run: `cabal build --ghc-options="-Wall -Wincomplete-uni-patterns -Wincomplete-record-updates"`
Expected: Build succeeds with zero warnings. If any warnings remain, read them, fix, and rebuild.
- [ ] **Step 11: Commit**
```bash
git add src/HomeAssistant/Controller.hs src/HomeAssistant/Runtime.hs
git commit -m "Fix warnings"
```
docs/superpowers/plans/2026-08-21-katip-logging.md
-750
View File
@@ -1,750 +0,0 @@
# katip logging Implementation Plan
> **For agentic workers:** REQUIRED SUB-SKILL: Use superpowers:subagent-driven-development (recommended) or superpowers:executing-plans to implement this plan task-by-task. Steps use checkbox (`- [ ]`) syntax for tracking.
**Goal:** Replace all `print`/`putStrLn` logging under `src/` with katip structured logging, threading a `LogEnv` through the existing `Bus`-based runtime.
**Architecture:** Approach A — `Bus` gains a `busLogEnv :: LogEnv` field; `defaultMain` builds the `LogEnv` (one stdout scribe, bracketed `closeScribes`) and passes it to `newBus`. The `HASSEff` interpreters (`dryRunHassEval`, `channelHassEval`) gain the controller name as a 2nd arg and log via `runKatipT`. `supervised` gains a leading `LogEnv`. The AFRP layer and controller definitions are untouched.
**Tech Stack:** Haskell (GHC2024), cabal, nix devShell, katip 0.8.8.4 (in nixpkgs), hspec/hedgehog.
## Global Constraints
- Build always via the nix devShell: `nix develop -c cabal build`.
- Tests always via the nix devShell: `nix develop -c cabal test`.
- After any edit to `home-assistant-controller.cabal`, regenerate `default.nix` with `nix run nixpkgs#cabal2nix -- ./. > default.nix` — never hand-edit `default.nix` (AGENTS.md).
- `secrets.yaml` is sops-encrypted — never read, print, or commit its contents.
- Code style: vertical modules, minimal comments describing contracts not implementation (AGENTS.md). No comments unless asked.
- `app/Main.hs` is outside `src/` and is NOT modified.
- AFRP layer (`AFRP.hs`) and controller definitions (`Controller.hs`, `Controller/Bedroom.hs`) remain logging-free.
- `-Wall` is on (cabal `common warnings`); all code must compile without warnings (no unused bindings).
---
## File Structure
| File | Responsibility | Change |
|------|---------------|--------|
| `home-assistant-controller.cabal` | build config | add `katip` to library + test `build-depends`; add `Support` to test `other-modules` |
| `default.nix` | generated cabal derivation | regenerated by cabal2nix (twice) |
| `src/HomeAssistant/Runtime/Bus.hs` | `Bus`, `newBus`, `channelHassEval` | add `busLogEnv`; `newBus :: LogEnv -> Int -> IO Bus`; `channelHassEval :: Bus -> Text -> ...` with katip |
| `src/HomeAssistant/Runtime.hs` | `defaultMain`, `runController`, `dryRunHassEval` | build `LogEnv` + bracket; thread controller `name`; `dryRunHassEval :: Bus -> Text -> ...` with katip |
| `src/HomeAssistant/Runtime/Supervisor.hs` | `supervised` | `supervised :: LogEnv -> Text -> Backoff -> IO Void -> IO Void` with katip |
| `src/HomeAssistant/Runtime/Connection.hs` | reader/writer workers | two `putStrLn` → `logMsg` |
| `test/Support.hs` | test helpers (new) | `silentLogEnv :: IO LogEnv` |
| `test/BusSpec.hs` | bus tests | pass `silentLogEnv`, add name arg |
| `test/RuntimeSpec.hs` | runtime tests | pass `silentLogEnv` |
| `test/SupervisorSpec.hs` | supervisor tests | pass `silentLogEnv`, add `LogEnv` arg (3 sites) |
No new modules under `src/`. No changes to `AFRP.hs`, `Controller.hs`, `Controller/Bedroom.hs`, `ConnectionSpec.hs`, `BackoffProp.hs`, `app/Main.hs`.
---
### Task 1: Add katip dependency
**Files:**
- Modify: `home-assistant-controller.cabal` (library `build-depends` ~line 77-89, test-suite `build-depends` ~line 149-160)
- Regenerate: `default.nix`
**Interfaces:**
- Consumes: nothing
- Produces: `katip` available to library and test-suite; `default.nix` lists `katip` in `libraryHaskellDepends` and `testHaskellDepends`
- [ ] **Step 1: Add katip to library build-depends**
In `home-assistant-controller.cabal`, in the `library` stanza's `build-depends` (after `uuid`), add `, katip`. The library block becomes:
```
build-depends: base ^>=4.20.2.0
, websockets
, aeson
, lens-aeson
, lens
, text
, network
, bytestring
, time
, stm
, async
, annotated-exception
, uuid
, katip
```
- [ ] **Step 2: Add katip to test-suite build-depends**
In the `test-suite home-assistant-controller-test` stanza's `build-depends` (after `time`), add `, katip`:
```
build-depends:
base ^>=4.20.2.0,
home-assistant-controller,
hspec,
stm,
aeson,
text,
async,
hedgehog,
hspec-hedgehog,
annotated-exception,
time,
katip
```
- [ ] **Step 3: Regenerate default.nix**
Run:
```bash
nix run nixpkgs#cabal2nix -- ./. > default.nix
```
Expected: `default.nix` now lists `katip` in `libraryHaskellDepends` and `testHaskellDepends`. Verify with:
```bash
grep katip default.nix
```
Expected output: two lines mentioning `katip`.
- [ ] **Step 4: Build to verify the dependency resolves**
Run:
```bash
nix develop -c cabal build
```
Expected: builds successfully (no code uses katip yet, so no compile errors). If nix needs to build katip first this may take a while on the first run.
- [ ] **Step 5: Commit**
```bash
git add home-assistant-controller.cabal default.nix
git commit -m "Add katip dependency"
```
---
### Task 2: Add busLogEnv to Bus; newBus signature; silentLogEnv helper; update callers
This task adds the `LogEnv` field to `Bus`, changes `newBus` to take `LogEnv`, adds a silent test helper, and updates every `newBus` caller so the build compiles. No logging behavior changes yet (the interpreters still `print`; they switch in Task 3).
**Files:**
- Modify: `src/HomeAssistant/Runtime/Bus.hs` (full file)
- Modify: `src/HomeAssistant/Runtime.hs` (`defaultMain` ~line 62-72)
- Modify: `home-assistant-controller.cabal` (test `other-modules` ~line 130)
- Regenerate: `default.nix`
- Create: `test/Support.hs`
- Modify: `test/BusSpec.hs` (~line 19)
- Modify: `test/RuntimeSpec.hs` (~line 17)
**Interfaces:**
- Consumes: `katip` (`LogEnv`, `initLogEnv`) from Task 1
- Produces:
- `Bus` has field `busLogEnv :: LogEnv`
- `newBus :: LogEnv -> Int -> IO Bus`
- `Support.silentLogEnv :: IO LogEnv`
- [ ] **Step 1: Add busLogEnv field and update newBus in Bus.hs**
In `src/HomeAssistant/Runtime/Bus.hs`, add imports and the field. The full updated file:
```haskell
{-# LANGUAGE LambdaCase #-}
module HomeAssistant.Runtime.Bus
( Bus(..)
, CallIdGen(..)
, mkCallIdGen
, newBus
, channelHassEval
) where
import Control.Concurrent.STM
( TChan
, TVar
, atomically
, newBroadcastTChanIO
, newTChanIO
, newTVarIO
, writeTChan
)
import Data.Aeson (Value)
import Data.IORef (atomicModifyIORef', newIORef)
import HomeAssistant.Controller (HASSEff (..), Service)
import Katip (LogEnv)
import Network.WebSockets (Connection)
-- | Shared runtime state: inbound is a broadcast channel (controllers
-- read from 'dupTChan' copies), outbound queues service calls for the
-- writer, conn holds the current websocket (Nothing before first connect).
data Bus = Bus
{ busInbound :: TChan Value
, busOutbound :: TChan Service
, busConn :: TVar (Maybe Connection)
, busGen :: CallIdGen
, busLogEnv :: LogEnv
}
newBus :: LogEnv -> Int -> IO Bus
newBus le start = Bus
<$> newBroadcastTChanIO
<*> newTChanIO
<*> newTVarIO Nothing
<*> mkCallIdGen start
<*> pure le
channelHassEval :: Bus -> HASSEff a -> IO a
channelHassEval bus = \case
CallService svc -> atomically $ writeTChan (busOutbound bus) svc
Debug x -> print x
Trace req x -> print (req, x)
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))
```
Note: `channelHassEval` still uses `print` here — it is converted in Task 3. Keeping it temporarily so this task compiles. `Data.Text (Text)` is NOT imported yet (it would be unused here, triggering `-Wall`); Task 3 adds it when the signature gains the `Text` name parameter.
- [ ] **Step 2: Update defaultMain to build a LogEnv and pass to newBus**
In `src/HomeAssistant/Runtime.hs`, update imports and `defaultMain`. Add these imports near the top (with the other imports):
```haskell
import Control.Exception (bracket)
import Katip
( ColorStrategy (ColorIfTerminal)
, Severity (DebugS)
, Verbosity (V2)
, closeScribes
, defaultScribeSettings
, initLogEnv
, mkHandleScribe
, permitItem
, registerScribe
)
import System.IO (stdout)
```
Then replace `defaultMain` with:
```haskell
defaultMain :: IO ()
defaultMain = withSocketsDo $ do
scribe <- mkHandleScribe ColorIfTerminal stdout (permitItem DebugS) V2
le <- registerScribe "stdout" scribe defaultScribeSettings
=<< initLogEnv "home-assistant-controller" "production"
bracket (pure le) closeScribes $ \le' -> do
token <- getEnv "HA_TOKEN"
bus <- newBus le' 0
let workers =
[ ("reader", readerAction "last-resort-redux" 8123 token bus)
, ("writer", writerAction bus)
] ++ [ (name, runController bus c) | c@(Controller name _) <- controllers ]
as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers
(_, v) <- waitAny as
absurd v
```
Note: `supervised` still has its 3-arg signature here — it is updated in Task 4. The `Controller name _` pattern (was `_name`) is required now so the workers list can use `name`; this is safe since `Controller`'s first field is already `T.Text`. `mkHandleScribe`, `ColorIfTerminal`, `permitItem`, and `V2` are all re-exported by the main `Katip` module, so no separate `Katip.Scribes.Handle` import is needed.
- [ ] **Step 3: Create test/Support.hs with silentLogEnv**
Create `test/Support.hs`:
```haskell
module Support
( silentLogEnv
) where
import Katip (LogEnv, initLogEnv)
-- | A LogEnv with no scribes: all log calls are no-ops. For tests that
-- must construct a Bus or call supervised without spewing output.
silentLogEnv :: IO LogEnv
silentLogEnv = initLogEnv "home-assistant-controller" "test"
```
- [ ] **Step 4: Add Support to test-suite other-modules in cabal**
In `home-assistant-controller.cabal`, in the test-suite's `other-modules` (currently lists `BusSpec`, `ConnectionSpec`, `RuntimeSpec`, `SupervisorSpec`, `BackoffProp`), add `, Support`:
```
other-modules: BusSpec
, ConnectionSpec
, RuntimeSpec
, SupervisorSpec
, BackoffProp
, Support
```
- [ ] **Step 5: Regenerate default.nix**
Run:
```bash
nix run nixpkgs#cabal2nix -- ./. > default.nix
```
Expected: `default.nix` regenerated; `katip` still present, `Support` is not listed (test modules aren't in the derivation) — this is fine.
- [ ] **Step 6: Update BusSpec to use silentLogEnv**
In `test/BusSpec.hs`, add the import and update the two `newBus 0` calls. Add to imports:
```haskell
import Support (silentLogEnv)
```
Replace each `bus <- newBus 0` with:
```haskell
le <- silentLogEnv
bus <- newBus le 0
```
There are two occurrences (lines ~19 and ~30). The `channelHassEval bus (CallService svc)` call on ~line 32 is unchanged in this task (Task 3 adds the name arg).
- [ ] **Step 7: Update RuntimeSpec to use silentLogEnv**
In `test/RuntimeSpec.hs`, add the import:
```haskell
import Support (silentLogEnv)
```
Replace `bus <- newBus 0` (line ~17) with:
```haskell
le <- silentLogEnv
bus <- newBus le 0
```
- [ ] **Step 8: Build and run tests to verify green**
Run:
```bash
nix develop -c cabal build && nix develop -c cabal test
```
Expected: builds with no warnings (the `print` in `channelHassEval` is still used, so no unused-binding warning); all tests pass.
- [ ] **Step 9: Commit**
```bash
git add src/HomeAssistant/Runtime/Bus.hs src/HomeAssistant/Runtime.hs test/Support.hs test/BusSpec.hs test/RuntimeSpec.hs home-assistant-controller.cabal default.nix
git commit -m "Add busLogEnv to Bus, silentLogEnv test helper"
```
---
### Task 3: Convert HASSEff interpreters to katip; thread controller name
Both interpreters gain the controller name (`Text`) as the 2nd arg and log via `runKatipT` + `logMsg`/`logF`. `runController` threads the `Controller` name into the active interpreter call. `Debug`/`Trace` use the controller name as the namespace; `Trace` logs `requestTraceId` as a structured field.
**Files:**
- Modify: `src/HomeAssistant/Runtime/Bus.hs` (`channelHassEval`)
- Modify: `src/HomeAssistant/Runtime.hs` (`dryRunHassEval`, `runController`, imports)
- Modify: `test/BusSpec.hs` (`channelHassEval` call)
**Interfaces:**
- Consumes: `busLogEnv :: LogEnv` from Task 2
- Produces:
- `channelHassEval :: Bus -> Text -> HASSEff a -> IO a`
- `dryRunHassEval :: Bus -> Text -> HASSEff a -> IO a`
- `runController` passes the controller name to the interpreter
- [ ] **Step 1: Convert channelHassEval to katip in Bus.hs**
In `src/HomeAssistant/Runtime/Bus.hs`, update imports and `channelHassEval`. First add `OverloadedStrings` to the pragmas at the top of the file (needed so the `"traceId"` literal in `sl` is `Text`):
```haskell
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
```
Replace the `import Katip (LogEnv)` line with:
```haskell
import AFRP (Request (requestTraceId))
import Data.Text (Text)
import Data.UUID (toText)
import Katip
( LogEnv
, Namespace (Namespace)
, Severity (DebugS)
, logF
, logMsg
, runKatipT
, showLS
, sl
)
```
Replace the `channelHassEval` definition with:
```haskell
channelHassEval :: Bus -> Text -> HASSEff a -> IO a
channelHassEval bus name = \case
CallService svc -> atomically $ writeTChan (busOutbound bus) svc
Debug x -> runKatipT (busLogEnv bus) $
logMsg (Namespace [name]) DebugS (showLS x)
Trace req x -> runKatipT (busLogEnv bus) $
logF (sl "traceId" (toText (requestTraceId req))) (Namespace [name]) DebugS (showLS x)
```
`Trace req x` binds `req :: Request` (from `HASSEff`'s `Trace` constructor, imported via `HASSEff (..)`); `requestTraceId` is the record field brought into scope by `import AFRP (Request (requestTraceId))`. `toText :: UUID -> Text` (aeson's `ToJSON Text` makes `sl` happy). `UUID`'s `ToJSON` would also work directly, but `toText` is used consistently with `Runtime.hs` per the spec.
- [ ] **Step 2: Convert dryRunHassEval to katip in Runtime.hs**
In `src/HomeAssistant/Runtime.hs`, update imports. Extend the `Data.UUID` import to include `toText`:
```haskell
import Data.UUID (UUID, toText)
```
Add to the `Katip` import list (from Task 2) the logging functions. The full `Katip` import for `Runtime.hs` becomes:
```haskell
import Katip
( ColorStrategy (ColorIfTerminal)
, Namespace (Namespace)
, Severity (DebugS)
, Verbosity (V2)
, closeScribes
, defaultScribeSettings
, initLogEnv
, logF
, logMsg
, mkHandleScribe
, permitItem
, registerScribe
, runKatipT
, showLS
, sl
)
```
Replace `dryRunHassEval` with:
```haskell
dryRunHassEval :: Bus -> T.Text -> HASSEff a -> IO a
dryRunHassEval bus name = \case
CallService svc -> do
callId <- generateCallId (busGen bus)
runKatipT (busLogEnv bus) $
logF (sl "callId" callId) (Namespace [name]) DebugS (showLS svc)
Debug x -> runKatipT (busLogEnv bus) $
logMsg (Namespace [name]) DebugS (showLS x)
Trace req x -> runKatipT (busLogEnv bus) $
logF (sl "traceId" (toText (requestTraceId req))) (Namespace [name]) DebugS (showLS x)
```
Note: the `callId` is logged as a structured field (keeping `generateCallId` meaningful under `-Wall` — a small refinement over the spec's `logMsg ... showLS svc`, which would have left `callId` unused). `requestTraceId` is accessed via the `Request` record; `Runtime.hs` already imports `AFRP (Event (..), Mealy (..), Request (..))` — confirm `Request (..)` brings `requestTraceId` into scope. The current import is `import AFRP (Event (..), Mealy (..), Request (..))`, so `requestTraceId` is in scope. Good.
- [ ] **Step 3: Thread controller name in runController**
In `src/HomeAssistant/Runtime.hs`, update `runController` to use the name and pass it to the interpreter. Replace `runController` with:
```haskell
runController :: Bus -> Controller -> IO Void
runController bus (Controller name machine) = do
inbound <- atomically (dupTChan (busInbound bus))
go inbound machine
where
go inbound f = do
msg <- atomically (readTChan inbound)
uuid <- UUID.V4.nextRandom
-- (_, f') <- step (channelHassEval bus name) uuid f (Event msg)
(_, f') <- step (dryRunHassEval bus name) uuid f (Event msg)
go inbound f'
```
The commented `channelHassEval` line is updated to the new signature too, so enabling it later requires no further edits.
- [ ] **Step 4: Update BusSpec channelHassEval call**
In `test/BusSpec.hs`, the test "channelHassEval writes CallService to the outbound channel" calls `channelHassEval bus (CallService svc)`. Update it to pass a name:
```haskell
channelHassEval bus "test" (CallService svc)
```
- [ ] **Step 5: Build and run tests to verify green**
Run:
```bash
nix develop -c cabal build && nix develop -c cabal test
```
Expected: builds with no warnings; all tests pass. The `print` calls in `channelHassEval`/`dryRunHassEval` are now gone — confirm with:
```bash
rg -n "print" src/HomeAssistant/Runtime/Bus.hs src/HomeAssistant/Runtime.hs
```
Expected: no output (no `print` remains in those two files).
- [ ] **Step 6: Commit**
```bash
git add src/HomeAssistant/Runtime/Bus.hs src/HomeAssistant/Runtime.hs test/BusSpec.hs
git commit -m "Convert HASSEff interpreters to katip, thread controller name"
```
---
### Task 4: Convert supervised to take LogEnv and use katip
`supervised` gains a leading `LogEnv` argument and replaces its two `putStrLn` calls with `logMsg`. The crash message is `WarningS`, the restart message is `InfoS`, both under namespace `runtime.supervisor.<name>`. `defaultMain` and `SupervisorSpec` are updated.
**Files:**
- Modify: `src/HomeAssistant/Runtime/Supervisor.hs` (imports, `supervised`)
- Modify: `src/HomeAssistant/Runtime.hs` (`defaultMain` supervised call)
- Modify: `test/SupervisorSpec.hs` (3 `supervised` call sites + import)
**Interfaces:**
- Consumes: `LogEnv` from katip (Task 1), `busLogEnv` (Task 2) for the `defaultMain` call
- Produces: `supervised :: LogEnv -> Text -> Backoff -> IO Void -> IO Void`
- [ ] **Step 1: Update supervised in Supervisor.hs**
In `src/HomeAssistant/Runtime/Supervisor.hs`, add `OverloadedStrings` to the pragmas at the top (needed so the message string literals are `LogStr`):
```haskell
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
```
Add imports. Add after the existing imports:
```haskell
import Katip
( LogEnv
, Namespace (Namespace)
, Severity (InfoS, WarningS)
, logMsg
, ls
, runKatipT
, showLS
)
```
Also **remove** the now-unused `import qualified Data.Text as T` line (the only `T.` usages were `T.unpack`/`T.pack` in the removed `putStrLn` calls; with `-Wall` the unused qualified import would warn). Keep `import Data.Text (Text)` — it is still used by `Fatal :: Text` and the `supervised` signature.
Update the export list (the type signature changes but `supervised` stays exported). Update `supervised`'s type and body. Replace the `supervised` definition with:
```haskell
supervised :: LogEnv -> Text -> Backoff -> IO Void -> IO Void
supervised le name backoff action = go 1
where
go attempt = do
start <- getCurrentTime
outcome <- (action >> pure (Nothing :: Maybe (Either Fatal SomeException))) `catches`
[ Handler $ \(f :: Fatal) -> pure (Just (Left f))
, Handler $ \(e :: SomeException) -> pure (Just (Right e))
]
end <- getCurrentTime
case outcome of
Nothing -> error "unreachable: supervised action returned"
Just (Left f) -> throw f
Just (Right e) -> do
runKatipT le $
logMsg (Namespace ["runtime", "supervisor", name]) WarningS
("attempt " <> showLS attempt <> " crashed: " <> ls (displayException e))
let delay = backoffDelay backoff attempt
runKatipT le $
logMsg (Namespace ["runtime", "supervisor", name]) InfoS
("restarting in " <> showLS delay)
threadDelay (round (realToFrac delay * 1000000 :: Double))
go (nextAttempt backoff (diffUTCTime end start) attempt)
```
Note: `logMsg`'s message is a `LogStr`; `(<>)` concatenates `LogStr` (it has a `Semigroup` instance). `showLS` uses `show`, so it is right for `attempt` (`Int`) and `delay` (`NominalDiffTime`) but **wrong for `displayException e`** (a `String`) — `showLS` would double-quote/escape it. Use `ls` (which converts via `StringConv` to `Text`) for raw `String` values. `displayException` is already imported from `Control.Exception.Annotated`. `Data.Text (Text)` stays for `Fatal`/the signature; the qualified `T` import is dropped (see above).
- [ ] **Step 2: Update defaultMain supervised call in Runtime.hs**
In `src/HomeAssistant/Runtime.hs`, in `defaultMain`, the supervised call is currently `async (supervised name defaultBackoff act)`. Update it to pass the `LogEnv`:
```haskell
as <- mapM (\(name, act) -> async (supervised le' name defaultBackoff act)) workers
```
(`le'` is the bracketed `LogEnv` from Task 2.)
- [ ] **Step 3: Update SupervisorSpec to pass silentLogEnv**
In `test/SupervisorSpec.hs`, add imports:
```haskell
import Support (silentLogEnv)
```
There are three `async (supervised "test" tinyBackoff action)` calls (lines ~28, ~41, ~56). Each must become:
```haskell
le <- silentLogEnv
sup <- async (supervised le "test" tinyBackoff action)
```
Insert the `le <- silentLogEnv` line before each `async` call. The three sites are in the `it` blocks: "restarts a crashing action until it stays up", "rethrows Fatal instead of restarting", and "does not restart on async exceptions".
For "rethrows Fatal instead of restarting" the surrounding block becomes:
```haskell
it "rethrows Fatal instead of restarting" $ do
counter <- newIORef (0 :: Int)
let action = do
_ <- atomicModifyIORef' counter (\c -> (c + 1, c + 1))
throw (Fatal "auth_invalid")
le <- silentLogEnv
sup <- async (supervised le "test" tinyBackoff action)
res <- waitCatch sup
```
Apply the same `le <- silentLogEnv` insertion to the other two sites.
- [ ] **Step 4: Build and run tests to verify green**
Run:
```bash
nix develop -c cabal build && nix develop -c cabal test
```
Expected: builds with no warnings; all tests pass. Confirm no `putStrLn` remains in Supervisor.hs:
```bash
rg -n "putStrLn" src/HomeAssistant/Runtime/Supervisor.hs
```
Expected: no output.
- [ ] **Step 5: Commit**
```bash
git add src/HomeAssistant/Runtime/Supervisor.hs src/HomeAssistant/Runtime.hs test/SupervisorSpec.hs
git commit -m "Convert supervised to katip logging"
```
---
### Task 5: Convert Connection.hs reader/writer putStrLn to katip
The two `putStrLn` sites in `Connection.hs` (reader "connected" and "skipping undecodable message") become `logMsg` calls under namespace `runtime.reader`. "connected" is `InfoS`; "skipping undecodable" is `WarningS`.
**Files:**
- Modify: `src/HomeAssistant/Runtime/Connection.hs` (imports, two log sites)
**Interfaces:**
- Consumes: `busLogEnv :: LogEnv` from Task 2
- Produces: no signature changes (reader/writer already take `Bus`)
- [ ] **Step 1: Add katip imports to Connection.hs**
In `src/HomeAssistant/Runtime/Connection.hs`, add after the existing imports:
```haskell
import Katip
( Namespace (Namespace)
, Severity (InfoS, WarningS)
, logMsg
, ls
, runKatipT
)
```
(`showLS` is not needed here — both messages use string literals / `ls` for the raw `String` `err`.)
- [ ] **Step 2: Replace the "connected" putStrLn**
In `readerAction`, replace:
```haskell
putStrLn "[reader] connected"
```
with:
```haskell
runKatipT (busLogEnv bus) $
logMsg (Namespace ["runtime", "reader"]) InfoS "connected"
```
`"connected"` is a `LogStr` via `IsString`. The `onException` line that follows is unchanged.
- [ ] **Step 3: Replace the "skipping undecodable" putStrLn**
In `receiveLoop`, replace:
```haskell
Left err -> putStrLn $ "[reader] skipping undecodable message: " <> err
```
with:
```haskell
Left err -> runKatipT (busLogEnv bus) $
logMsg (Namespace ["runtime", "reader"]) WarningS
("skipping undecodable message: " <> ls err)
```
`err` is a `String` from `eitherDecode`; `ls err` converts it to a `LogStr` without `show`'s quoting (use `ls`, not `showLS`, for raw `String`s). (`<>` on `LogStr`.)
- [ ] **Step 4: Build and run tests to verify green**
Run:
```bash
nix develop -c cabal build && nix develop -c cabal test
```
Expected: builds with no warnings; all tests pass. Confirm no `putStrLn` remains in Connection.hs:
```bash
rg -n "putStrLn" src/HomeAssistant/Runtime/Connection.hs
```
Expected: no output.
- [ ] **Step 5: Commit**
```bash
git add src/HomeAssistant/Runtime/Connection.hs
git commit -m "Convert reader/writer logging to katip"
```
---
### Task 6: Final verification — no manual printing remains under src/
Confirm the whole logging swap is complete: the build and tests are green, and no `print`/`putStrLn`/`putStr` remains under `src/`.
**Files:**
- None modified (verification only)
- [ ] **Step 1: Confirm no manual printing remains under src/**
Run:
```bash
rg -n "print|putStrLn|putStr|hPutStr" src/
```
Expected: no output. If any match remains, it is a missed site — fix it before committing (revisit the relevant task).
- [ ] **Step 2: Full clean build and test**
Run:
```bash
nix develop -c cabal build && nix develop -c cabal test
```
Expected: builds with no warnings (`-Wall`); all tests pass (BusSpec, ConnectionSpec, RuntimeSpec, SupervisorSpec, BackoffProp).
- [ ] **Step 3: Confirm default.nix is in sync with the cabal file**
Run:
```bash
nix run nixpkgs#cabal2nix -- ./. > default.nix
git diff --exit-code default.nix
```
Expected: `git diff --exit-code` exits 0 (no changes — `default.nix` was already regenerated in Tasks 1 and 2). If it does change, the cabal file was edited without regenerating; stage and amend the relevant commit.
- [ ] **Step 4: Smoke-check the executable wiring (optional, manual)**
If a Home Assistant instance and `HA_TOKEN` are available, run the executable and confirm katip-formatted lines appear on stdout (e.g. `[home-assistant-controller.runtime.reader][Info][...] connected`). This is a manual check, not automated.
- [ ] **Step 5: Final commit if any fixes were needed**
If Steps 1-3 required fixes, commit them:
```bash
git add -A
git commit -m "Finish katip logging swap"
```
Otherwise no commit is needed — the work is already committed across Tasks 1-5.
docs/superpowers/specs/2026-08-20-concurrent-runtime-design.md
-258
View File
@@ -1,258 +0,0 @@
# Concurrent runtime: multiple controllers, channels, supervision, reconnect
Date: 2026-08-20
Status: Approved (pending spec review)
## Goal
Make the HASS runtime production-quality:
- Support multiple controllers.
- A single websocket read loop; no per-controller connections.
- The read loop broadcasts messages to controllers over channels (`TChan`).
- Each controller runs on its own thread (`async`).
- Controllers know nothing of the websocket connection: service calls go
through an outbound channel; a writer thread does the actual sends.
- Crashed worker threads are restarted with backoff (`annotated-exception`
for context).
- The websocket reconnects on network failure.
Implemented as two slices, each independently buildable and committed:
1. **Concurrency architecture**: bus, reader/writer threads, controller
threads, channel interpreter, wiring. Any worker crash exits the
process (today's behavior).
2. **Robustness**: supervisor with backoff, `annotated-exception`, fatal
vs retryable failures, reconnect-as-restart.
## Current state
`HomeAssistant.Runtime.app` runs everything on one thread inside
`WS.runClient`: auth handshake, a `get_states` debug dump, one
`subscribe_events`, then a loop that steps a single `lightController`
via `dryRunHassEval`. The `get_states` dump is dead debug code and is
removed (state pre-seeding is a separate future concern).
## Architecture
```
HA websocket
▲ │
sends │ ▼ receives
┌─────────────┴──┐ ┌──────────────┐
│ writer thread │ │ reader thread │
└───────▲────────┘ └───────┬──────┘
│ │ decode → Value
│ TChan Service │ broadcast (single write)
│ ▼
┌───────┴───────────────────────────┐
│ busInbound (broadcast TChan) │
└──┬──────────────┬──────────────┬──┘
▼ dupTChan ▼ ▼
controller 1 controller 2 controller N (1 thread each)
```
### Bus
```haskell
data Bus = Bus
{ busInbound :: TChan Value -- newBroadcastTChanIO; reader writes only
, busOutbound :: TChan Service -- controllers → writer; fire-and-forget
, busConn :: TVar (Maybe WS.Connection)
, busGen :: CallIdGen -- existing IORef-based, thread-safe
}
```
- `busInbound` comes from `newBroadcastTChanIO`: a write-only broadcast
channel. A plain never-read `TChan` would pin its entire history; the
broadcast variant does not. Controllers receive via
`dupTChanIO busInbound`; the reader writes each message once.
- `busConn` is a plain current-value cell (no `MVar` blocking semantics).
`Maybe` + STM `retry` lets the writer block until a connection exists
and lets `defaultMain` spawn all workers up front: the initial connect
is just the reader's first attempt, so first-connect failures and
reconnect failures take the same backoff path.
- The controller list is static. Each entry is an existential:
```haskell
data Controller = forall b. Controller T.Text (HASS (Event Value) b)
```
No `Show` constraint: machine outputs are discarded; observability will
come from a logging effect later. The name tags restart logs.
### Send-safety without locks
No two threads ever send on the same live connection:
- The reader performs all setup sends (auth, subscribe) **before**
swapping the connection into `busConn`; afterwards it only receives.
- The writer only sends on connections read from `busConn`.
On reconnect the reader builds a new connection, handshakes, then
atomically swaps `busConn`. A writer mid-send on the dead connection
throws, its supervisor restarts it, and it picks up the new connection.
### Outbound backpressure
Fire-and-forget: services queue in `busOutbound` during outages and are
sent after reconnect. The queue is naturally bounded in practice: no
inbound events means controllers produce no calls.
## Module layout
| Module | Concern |
|---|---|
| `HomeAssistant.Runtime.Supervisor` | Generic restart-with-backoff combinator, `Backoff`, `Fatal`; no HA knowledge |
| `HomeAssistant.Runtime.Bus` | `Bus`, `newBus`, channel interpreter for `HASSEff` |
| `HomeAssistant.Runtime.Connection` | `readerAction`, `writerAction`; connect/auth/subscribe, receive-decode-broadcast loop, send loop |
| `HomeAssistant.Runtime` | Glue: `defaultMain`, `controllers`, `Controller`, `runController`, `step`, `dryRunHassEval` |
Exports removed from `HomeAssistant.Runtime`: `app`, `hassEval`,
`wsCallService`, `receiveJSON` (internal or superseded). Kept:
`defaultMain`, `step`, `dryRunHassEval`, `CallIdGen`, `mkCallIdGen`.
`app/Main.hs` unchanged.
## Connection lifecycle
**Reader action** (restartable unit; restart = reconnect):
```
connect → expect auth_required → send token → expect auth_ok
→ send subscribe_events state_changed (id from busGen)
→ swap busConn
→ forever: receive → decode → broadcast to busInbound
```
- `auth_invalid` (and undecodable handshake messages) is **fatal**: a bad
token cannot be fixed by retrying. The reader throws `Fatal`; the
supervisor rethrows it (with annotations) and the process exits.
- Undecodable messages in the receive loop are **not** fatal: log a
warning and skip. Reconnecting cannot fix a decode problem, so
crash-restarting would just be a hot loop.
- Controller Mealy state survives reconnects (explicit decision). State
may be stale until each watched entity's next `state_changed` event.
Re-seeding via `get_states` is a separate future concern.
**Writer action**:
```
forever: readTChan busOutbound
→ readTVar busConn (retry until Just)
→ encode with fresh id from busGen → send
```
Encoding fixes a latent bug: today's `wsCallService` drops
`serviceData`; the writer encodes it as `"service_data"` when present.
## Supervision
```haskell
supervised :: Text -> Backoff -> IO a -> IO Void -- never returns normally
```
- Catches synchronous exceptions; rethrows `SomeAsyncException`
(no restarting on cancellation).
- On `Fatal`: rethrow with annotations; process exits.
- Otherwise: log (component name, attempt, annotated exception), sleep
per backoff, restart the action.
- Backoff: exponential from base, capped; resets after a quiet period.
```haskell
data Backoff = Backoff
{ backoffBase :: NominalDiffTime -- first restart delay, e.g. 100ms
, backoffCap :: NominalDiffTime -- max delay, e.g. 30s
, backoffQuiet :: NominalDiffTime -- uptime that resets delay, e.g. 30s
}
```
Delay after the n-th consecutive crash: `min cap (base * 2^(n-1))`.
- `annotated-exception` adds context at catch sites (component, phase
such as "authenticating" / "receiving") so logs read like
`[reader] attempt 3: ConnectionClosed while receiving`.
### Wiring
- Slice 1: `defaultMain` = `newBus` → `mapConcurrently_` over reader,
writer, and controller actions. First worker crash cancels the rest
and exits the process.
- Slice 2: each action wrapped in `supervised`; main waits forever.
The worker `IO` actions are identical in both slices; only the
spawning changes.
## Controller runner
```haskell
runController :: Bus -> Controller -> IO Void
-- dupTChanIO busInbound
-- loop: readTChan → step (channelHassEval bus) → discard output
```
On a supervised restart the action re-dups: a fresh port sees only
messages written after the dup, consistent with the machine also
restarting from its initial state. Messages broadcast during a restart
window are lost (accepted, documented).
## Interpreter
```haskell
channelHassEval :: Bus -> HASSEff a -> IO a
channelHassEval bus (CallService svc) = atomically (writeTChan (busOutbound bus) svc)
channelHassEval _ (Pure a) = pure a
```
`dryRunHassEval` stays exported for experiments/tests.
## Logging
Tagged plain lines (`[reader] …`) via `putStrLn`. No framework.
## Dependencies
Added: `stm`, `async` (slice 1); `annotated-exception` (slice 2).
After editing the cabal file, regenerate `default.nix` via
`nix run nixpkgs#cabal2nix -- ./. > default.nix` (AGENTS.md).
## Testing
hspec for unit tests, hedgehog for property tests (AGENTS.md):
- hspec:
- Broadcast semantics: two `dupTChan` ports see all writes, in order.
- `channelHassEval` writes `Service` to the outbound chan.
- `runController` end-to-end on a real `Bus` with a test controller:
feed values into `busInbound`, assert services land in `busOutbound`.
- Writer encoding: golden JSON for `call_service` incl. `service_data`.
- Supervisor (tiny backoff values): crash-twice-then-succeed restarts;
`Fatal` rethrown, not restarted; async exceptions not restarted.
- hedgehog:
- Backoff property: delays double from base, clamp at cap, reset after
quiet period.
## Slices
1. **Concurrency architecture**: `Bus` (already reconnect-ready:
`TVar (Maybe Connection)`), `channelHassEval`, `readerAction`,
`writerAction`, `runController`, module split, cabal deps, wiring via
`mapConcurrently_`, tests for bus/runner/encoding. Decode
log-and-skip included.
2. **Robustness**: `Supervisor` module, `annotated-exception` dep,
backoff, `Fatal` auth failures, rewire `defaultMain` to supervised
workers, supervisor tests and backoff property.
In slice 1 an `auth_invalid` response exits the process like any other
crash; the fatal/retryable distinction only exists once the supervisor
does (slice 2).
Each slice: builds clean, tests green, committed separately.
## Non-goals
- Request/response correlation for service calls (approach B, deferred;
outbound message type can grow later).
- Dynamic controller registration (static list).
- Structured logging / logging effect (future).
- Host/port/token configuration via env (beyond current `HA_TOKEN`).
- State pre-seeding via `get_states` (user's future concern).
- Multiple websocket connections.
docs/superpowers/specs/2026-08-20-module-split-design.md
-130
View File
@@ -1,130 +0,0 @@
# Module split & warning cleanup for `MyLib.hs`
Date: 2026-08-20
Status: Approved (pending spec review)
## Goal
Split `src/MyLib.hs` (352 lines, monolithic) into vertically-separated modules and fix all compiler warnings, committing between every change.
Two concerns were named upfront:
1. AFRP (Mealy) internals — generic FRP machinery.
2. Home Assistant business logic.
A third concern emerged during exploration:
3. IO runtime — websocket client, effect interpreter, `defaultMain`.
## Module layout
Three vertical modules with hierarchical naming. `MyLib` is removed; `app/Main.hs` and the cabal `exposed-modules` are updated.
| Module | Concern | Depends on |
|---|---|---|
| `AFRP` | Generic Mealy/Event machinery — no HA knowledge | base, time |
| `HomeAssistant.Controller` | HA domain: effect type, entity parsers, controllers | `AFRP`, aeson, lens |
| `HomeAssistant.Runtime` | IO interpreter, websocket client, `defaultMain` | both, websockets |
### Naming rationale
`AFRP` lives at the top level (not `HomeAssistant.AFRP`) because the code is generic FRP machinery with zero HA references; nesting it under `HomeAssistant.*` would misrepresent it. It stays in-project per the user's decision, so a short top-level name is fine.
### Future direction (deferred)
When real controllers exist, split `HomeAssistant.Controller` further into sub-modules:
- `HomeAssistant.Controller.Effect` — `HASSEff`, `Service`, `HASS`, `callService`
- `HomeAssistant.Controller.Entity` — entity parsers
- `HomeAssistant.Controller` (or `.Controllers`) — actual controllers (`lightController`, etc.)
Deferred now because there's only one proof-of-concept controller.
## Module contents
### `AFRP` (from MyLib.hs lines 29–91, 99–173)
Exports:
- `Mealy(..)`, `eff`
- `Event(..)`, `hold`, `events`, `switch`
- accumulators: `preMapAccum`, `preMapAccumUTCTime`, `mapAccum`, `mapAccumUTCTime`
- `changes`, `whenA`, `filterA`, `thenA`, `(>>|)`, `toEvent`
- instances come along with `Mealy(..)`
### `HomeAssistant.Controller` (from lines 32–42, 50–53, 175–256)
Exports:
- `Service(..)`, `HASSEff(..)`, `HASS`, `callService`
- entity helpers: `entityChangeEvent`, `entityChangeEvent'`, `entityRead`, `entityRead'`, `entityBool`, `entityBool'`
- domain types/values: `Ruuvi(..)`, `ruuvi`, `ruuviTemperatures`, `ruuviPressures`, `DoorState(..)`, `door`, `light`, `lightController`
### `HomeAssistant.Runtime` (from lines 259–268, 270–352)
Exports:
- `defaultMain`, `app`, `step`
- `CallIdGen`, `mkCallIdGen`, `hassEval`, `dryRunHassEval`, `receiveJSON`, `wsCallService`
## Warning fixes
Per-warning, applied during the split-then-fix commit sequence:
| Warning (line) | Fix |
|---|---|
| `numericDirection` (190) + `Direction`/`Increase`/`Decrease`/`Steady` (187) — unused, no sig | **Delete.** True experiment; used nowhere. |
| `entityChangeEvent` (224), `entityRead'` (236), `entityRead` (249) — unused top-binds | **Export** from `HomeAssistant.Controller`. Useful Either/Event-returning entity helpers the others build on; the split's export lists make them used. |
| `isEntity` (227) — unused local in `entityChangeEvent` | **Delete.** `entityChangeEvent` delegates to `entityChangeEvent' >>> toEvent`; its `isEntity` is a dead duplicate. |
| `state` (251) in `entityRead`, `state` (256) in `entityBool` — unused locals | **Delete.** Both functions delegate to their `'`-primed versions; the `where` clauses are dead duplicates. |
| `toBool` (244) — non-exhaustive (`"on"`/`"off"` only) | **Add catch-all `_ -> False`.** Conservative: treat unknown HA state as off rather than crashing. |
| `wsCallService` (327) + `conn` (346) — unused, paired | See option C below. |
### `wsCallService` / `conn` — option C (chosen)
The commented-out `wsCallService conn ...` call on line 350 made `conn` unused. Rather than uncomment (behavior change) or paper over with `_conn` (dishonest), expose both behaviors as named, exported functions:
```haskell
hassEval :: CallIdGen -> WS.Connection -> HASSEff a -> IO a
hassEval gen conn = \case
CallService x -> do
callId <- generateCallId gen
wsCallService conn callId (serviceDomain x) (serviceName x) (serviceTarget x)
Pure a -> pure a
dryRunHassEval :: CallIdGen -> HASSEff a -> IO a
dryRunHassEval gen = \case
CallService x -> do
callId <- generateCallId gen
print (callId, x)
Pure a -> pure a
```
Both `conn` and `wsCallService` become used by the real `hassEval`; the current print-only behavior lives in `dryRunHassEval`. `app` wires up **`dryRunHassEval`** to preserve current runtime behavior — flipping to real `hassEval` later is a one-word change.
## Commit sequence
Two commits, each building cleanly:
1. **`Split MyLib into AFRP, Controller, Runtime`**
- Mechanical move of code into `src/AFRP.hs`, `src/HomeAssistant/Controller.hs`, `src/HomeAssistant/Runtime.hs`.
- Proper export lists (which naturally exports the "useful but unused" entity helpers, resolving those three unused-binding warnings).
- Delete `src/MyLib.hs`.
- Update `app/Main.hs` import (`MyLib` -> `HomeAssistant.Runtime`).
- Update cabal `exposed-modules`.
- Build still warns on remaining items.
2. **`Fix warnings`**
- Delete `numericDirection`/`Direction` and dead `where` clauses (`isEntity` in `entityChangeEvent`, `state` in `entityRead`/`entityBool`).
- Add `_ -> False` catch-all to `toBool`.
- Implement real `hassEval` (uncommented `wsCallService`) + add `dryRunHassEval`; export both from `HomeAssistant.Runtime`.
- Wire `app` to `dryRunHassEval` to preserve current behavior.
- Build clean (no warnings).
## Verification
After each commit:
- `cabal build` succeeds.
- After commit 2: `cabal build --ghc-options="-Wall -Wincomplete-uni-patterns -Wincomplete-record-updates"` produces zero warnings.
- `app/Main.hs` still compiles and imports `defaultMain` from its new home.
## Non-goals
- Splitting `HomeAssistant.Controller` into Effect/Entity/Controller sub-modules (deferred until real controllers exist).
- Adding tests (test suite is a placeholder; out of scope).
- Changing `app` to call real `hassEval` (stays on `dryRunHassEval` to preserve behavior).
- Any behavioral changes beyond warning fixes and the dormant `wsCallService` activation (which is itself inert until `app` switches to `hassEval`).
docs/superpowers/specs/2026-08-21-katip-logging-design.md
-278
View File
@@ -1,278 +0,0 @@
# Replace manual printing with katip logging
Date: 2026-08-21
Status: Approved (pending spec review)
## Goal
Replace all `print`/`putStrLn` logging under `src/` with [katip], a
structured logging framework. The AFRP layer and controller definitions
stay logging-free; only the `HASSEff` interpreters and runtime workers
log.
[katip]: https://hackage.haskell.org/package/katip
## Current state
Nine logging sites under `src/`, all unstructured stdout:
| Site | Current code |
|------|-------------|
| `Runtime.hs:78` | `print (callId, x)` — dry-run `CallService` |
| `Runtime.hs:79` | `print x` — `Debug` |
| `Runtime.hs:80` | `print (req, x)` — `Trace` |
| `Bus.hs:45` | `print x` — `Debug` (channelHassEval) |
| `Bus.hs:46` | `print (req, x)` — `Trace` (channelHassEval) |
| `Supervisor.hs:76` | `putStrLn ... "crashed: ..."` |
| `Supervisor.hs:78` | `putStrLn ... "restarting in ..."` |
| `Connection.hs:41` | `putStrLn "[reader] connected"` |
| `Connection.hs:77` | `putStrLn "[reader] skipping undecodable message: ..."` |
`app/Main.hs`'s `putStrLn "Hello, Haskell!"` is outside `src/` and left
alone. `AFRP.hs`, `Controller.hs`, and `Controller/Bedroom.hs` contain
no logging and remain untouched.
## Approach
Approach A: `LogEnv` stored in `Bus`, explicit `runKatipT` per site.
- `Bus` gains `busLogEnv :: LogEnv`; `defaultMain` builds the env and
passes it to `newBus`.
- Every existing worker already takes `Bus`, so it reads `busLogEnv`
and logs with `runKatipT le $ logMsg ns sev msg` — no worker
signature changes.
- `dryRunHassEval` and `channelHassEval` gain the controller name
(`Text`) so debug/trace logs get a per-controller namespace.
- `supervised` is the one function without a `Bus`; it gains a leading
`LogEnv` param.
- Tests get a silent `LogEnv` (no scribes) via a helper so they don't
spew.
Rejected alternatives: B (`KatipContextT IO` worker monad — large
churn, async context loss undermines the main benefit, fights the
existing `IO`+`Bus` design); C (a new `App` `ReaderT` monad —
over-scoped for a logging swap).
## Scribe setup
One scribe in `defaultMain`:
```haskell
scribe <- mkHandleScribe ColorIfTerminal stdout (permitItem DebugS) V2
```
- `ColorIfTerminal`: color codes only when stdout is a TTY.
- `permitItem DebugS`: lets all severities through. The dev run shows
everything; a production deployment can swap `DebugS` for `InfoS` (or
register a second, more restrictive scribe) without code changes
elsewhere.
- `V2` verbosity: renders structured payload fields (e.g. `traceId`)
inline in bracket format, e.g. `[traceId:<uuid>] <message>`.
- `bracket ... closeScribes`: the current `waitAny`+`absurd` exits
abruptly; wrapping the body in `bracket` ensures scribe queues flush
and finalizers run on exit.
App namespace (set once): `initLogEnv "home-assistant-controller"
"production"`. Every log's full namespace is `home-assistant-controller
. <component>`.
## Severity & namespace mapping
| Site | Namespace | Severity |
|------|-----------|----------|
| dryRun `CallService` | `<controllerName>` | DebugS |
| `Debug` (both interpreters) | `<controllerName>` | DebugS |
| `Trace req x` (both interpreters) | `<controllerName>` | DebugS |
| Supervisor crash | `runtime.supervisor.<name>` | WarningS |
| Supervisor restart | `runtime.supervisor.<name>` | InfoS |
| reader connected | `runtime.reader` | InfoS |
| reader undecodable | `runtime.reader` | WarningS |
Rationale: crashes that get restarted are recoverable → WarningS; the
restart notice is normal operation → InfoS. "reader connected" is an
operational milestone → InfoS; skipping a bad message is
abnormal-but-handled → WarningS. All interpreter output
(CallService dry-run, Debug, Trace) is developer instrumentation →
DebugS, so a production scribe (`permitItem InfoS`) filters it out
while a dev scribe keeps it.
## Structured traceId
`Trace req x` carries `requestTraceId :: UUID`. Logged via `logF` with
a `SimpleLogPayload` so the traceId is a structured field rather than
text concatenated into the message. `Data.UUID.toText` renders the UUID
as a hyphenated `Text` (which is `ToJSON`, as `sl` requires):
```haskell
Trace req x -> runKatipT le $
logF (sl "traceId" (toText (requestTraceId req))) ns DebugS (showLS x)
```
Renders in bracket format as
`[home-assistant-controller.<name>][Debug][...][traceId:<uuid>] <x>`.
The `toText` import comes from `Data.UUID` (already a dependency).
## Signature changes
### `Bus` (Bus.hs)
```haskell
data Bus = Bus
{ busInbound :: TChan Value
, busOutbound :: TChan Service
, busConn :: TVar (Maybe Connection)
, busGen :: CallIdGen
, busLogEnv :: LogEnv -- new
}
newBus :: LogEnv -> Int -> IO Bus -- LogEnv first
```
`LogEnv` is the more "environmental" arg; `Int` is the call-id seed.
### `HASSEff` interpreters (Runtime.hs, Bus.hs)
Both gain the controller name as the 2nd arg and read `LogEnv` from
`Bus`/`busLogEnv`:
```haskell
dryRunHassEval :: Bus -> Text -> HASSEff a -> IO a
channelHassEval :: Bus -> Text -> HASSEff a -> IO a
```
- `dryRunHassEval` changes from `CallIdGen -> ...` to `Bus -> Text ->
...` (it needs both `busGen` for call ids and `busLogEnv` for
logging). Matches `channelHassEval`'s shape for symmetry.
- `Debug`: `print x` → `runKatipT (busLogEnv bus) $ logMsg ns DebugS
(showLS x)`.
- `Trace`: `print (req, x)` → the structured `logF` call in
[Structured traceId](#structured-traceid).
- `CallService`:
- `dryRunHassEval`: keeps `generateCallId (busGen bus)` (call id for
dry-run output) and replaces `print (callId, x)` with a DebugS log
of the `Service`:
`runKatipT (busLogEnv bus) $ logMsg ns DebugS (showLS svc)`.
- `channelHassEval`: unchanged — writes `Service` to `busOutbound`
and emits no log (the writer does the actual send; logging here
would be new behavior, not a replacement).
### `supervised` (Supervisor.hs)
```haskell
supervised :: LogEnv -> Text -> Backoff -> IO Void -> IO Void
```
Logs via `runKatipT le $ logMsg ("runtime.supervisor." <> name) sev
msg`. `defaultMain` passes `busLogEnv bus`.
### `defaultMain` (Runtime.hs)
Builds `LogEnv` at the top, passes to `newBus`, wraps body in
`bracket ... closeScribes`:
```haskell
defaultMain = withSocketsDo $ do
scribe <- mkHandleScribe ColorIfTerminal stdout (permitItem DebugS) V2
le <- registerScribe "stdout" scribe defaultScribeSettings
=<< initLogEnv "home-assistant-controller" "production"
bracket (pure le) closeScribes $ \le' -> do
token <- getEnv "HA_TOKEN"
bus <- newBus le' 0
let workers = ...
as <- mapM (\(name, act) -> async (supervised le' name defaultBackoff act)) workers
(_, v) <- waitAny as
absurd v
```
### `runController` (Runtime.hs)
`Controller _name` becomes `Controller name`; the name threads into the
interpreter:
```haskell
runController :: Bus -> Controller -> IO Void
runController bus (Controller name machine) = do
inbound <- atomically (dupTChan (busInbound bus))
go inbound machine
where
go inbound f = do
msg <- atomically (readTChan inbound)
uuid <- UUID.V4.nextRandom
(_, f') <- step (dryRunHassEval bus name) uuid f (Event msg)
go inbound f'
```
### `Connection.hs` workers
`readerAction`/`writerAction` signatures unchanged — they already take
`Bus`. The two `putStrLn` sites read `busLogEnv bus` and log via
`runKatipT (busLogEnv bus) $ logMsg "runtime.reader" sev msg`.
### No changes to
`AFRP.hs`, `Controller.hs`, `Controller/Bedroom.hs`,
`Connection.hs`'s pure `encodeService`, or any controller definition —
they remain logging-free.
## Tests
A silent `LogEnv` helper (in `test/Main.hs` or a new `test/Support.hs`)
lets tests construct a `Bus`/call `supervised` without spewing:
```haskell
silentLogEnv :: IO LogEnv
silentLogEnv = initLogEnv "home-assistant-controller" "test"
```
No scribe registered → all `logMsg` calls are no-ops (katip drops
silently).
Mechanical call-site updates:
- `BusSpec`: `newBus 0` → `silentLogEnv >>= \le -> newBus le 0`;
`channelHassEval bus (CallService svc)` →
`channelHassEval bus "test" (CallService svc)`.
- `RuntimeSpec`: `newBus 0` → with `silentLogEnv`; `runController bus
(Controller "test" lightController)` unchanged.
- `SupervisorSpec`: `supervised "test" tinyBackoff action` →
`silentLogEnv >>= \le -> supervised le "test" tinyBackoff action`
(3 call sites).
- `ConnectionSpec`/`BackoffProp`: no change (test pure code).
No new tests required — the logging swap is behavior-preserving for
existing assertions. A capturing-scribe test asserting debug logs
*would* fire is out of scope (noted as a future option).
## Cabal & nix
- Add `katip` to library `build-depends` and to test-suite
`build-depends` (the test helper imports `Katip`).
- After editing the `.cabal`, regenerate the derivation per AGENTS.md:
```
nix run nixpkgs#cabal2nix -- ./. > default.nix
```
- `flake.nix`: no change. nixpkgs has `katip` 0.8.8.4 (verified), and
`callPackage ./.` picks up new deps from `default.nix` automatically.
- `default.nix`: regenerated by the cabal2nix command — never hand-edit.
## Imports added
| Module | Import |
|--------|--------|
| `Bus.hs` | `import Katip` |
| `Runtime.hs` | `import Katip` |
| `Supervisor.hs` | `import Katip` (+ `qualified Data.Text as T` if not present) |
| `Connection.hs` | `import Katip` |
| test helper | `import Katip` |
## Non-goals
- Logging inside the AFRP layer or controller definitions.
- A custom capturing-scribe test.
- Log-level configuration via env or CLI (the scribe `permitItem` is a
code constant for now).
- JSON output / file scribe / multiple scribes (deferred; the single
stdout text scribe is the drop-in replacement for current `print`).
- Changing `app/Main.hs` (outside `src/`).
home-assistant-controller.cabal
+4 -1
View File
@@ -87,6 +87,7 @@ library
, async
, annotated-exception
, uuid
, katip
-- Directories containing source files.
hs-source-dirs: src
@@ -157,4 +158,6 @@ test-suite home-assistant-controller-test
hedgehog,
hspec-hedgehog,
annotated-exception,
time
time,
uuid,
katip
src/AFRP.hs
+3 -3
View File
@@ -39,9 +39,9 @@ data Request = Request
newtype Mealy eff a b = Mealy
{ runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> 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)
eff :: (Request -> a -> eff b) -> Mealy eff a b
eff f = Mealy $ \nt req x ->
nt (f req x) >>= \b -> pure (b, eff f)
instance Category (Mealy eff) where
id = Mealy (\_ _ x -> pure (x, id))
src/HomeAssistant/Controller.hs
+3 -3
View File
@@ -52,18 +52,18 @@ data Service = Service
deriving (Show, Eq)
data HASSEff a where
CallService :: Service -> HASSEff ()
CallService :: Request -> Service -> HASSEff ()
Debug :: Show a => a -> HASSEff ()
Trace :: Show a => Request -> a -> HASSEff ()
type HASS a b = Mealy HASSEff a b
callService :: Service -> HASS a ()
callService service = eff (\_ -> CallService service)
callService service = eff (\req _ -> CallService req service)
debug :: Show a => HASS a a
debug = proc x -> do
eff Debug -< x
eff (const Debug) -< x
returnA -< x
traceEvent :: Show a => HASS (Event a) (Event a)
src/HomeAssistant/Controller/Bedroom.hs
+2 -2
View File
@@ -114,10 +114,10 @@ drawer = entityBool "binary_sensor.bedroom_nightstand_drawer_sensor_masse_contac
bedroomDrawerController :: HASS (Event Value) ()
bedroomDrawerController = proc x -> do
st <- drawer -< x
st <- drawer >>> traceEvent -< x
case st of
Event Open -> callService (switch [entity] True) -< ()
Event Closed -> callService (switch [entity] False) -< ()
_ -> returnA -< ()
where
entity = EntityId "bedroom_drawer_light_masse"
entity = EntityId "switch.bedroom_drawer_light_masse"
src/HomeAssistant/Runtime.hs
+20 -15
View File
@@ -27,12 +27,15 @@ import HomeAssistant.Runtime.Supervisor (defaultBackoff, supervised)
import Network.Socket (withSocketsDo)
import System.Environment (getEnv)
import HomeAssistant.Controller.Bedroom (bedroomPresenceController, bedroomButtonController, bedroomDrawerController)
import Data.UUID (UUID)
import Data.UUID (UUID, toText)
import qualified Data.UUID.V4 as UUID.V4
import Katip (runKatipT, logF, sl, Severity (..), ls, Namespace (Namespace), runKatipContextT)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Fix (MonadFix)
step :: (forall x. eff x -> IO x) -> UUID -> Mealy eff a b -> a -> IO (b, Mealy eff a b)
step :: (MonadFix m, MonadIO m) => (forall x. eff x -> m x) -> UUID -> Mealy eff a b -> a -> m (b, Mealy eff a b)
step nt trace (Mealy f) a = do
now <- getCurrentTime
now <- liftIO getCurrentTime
f nt (Request now trace) a
data Controller = forall b. Controller T.Text (HASS (Event Value) b) Bool
@@ -40,7 +43,7 @@ data Controller = forall b. Controller T.Text (HASS (Event Value) b) Bool
controllers :: [Controller]
controllers =
[ Controller "bedroom-presence" bedroomPresenceController False
, Controller "bedroom-button" bedroomButtonController False
, Controller "bedroom-button" bedroomButtonController False -- This works but leaving for vacation
, Controller "bedroom-drawer" bedroomDrawerController True
]
@@ -48,20 +51,20 @@ controllers =
-- bus. A restart re-dups the inbound channel and starts from the machine's
-- initial state; messages broadcast during the restart window are lost.
runController :: Bus -> Controller -> IO Void
runController bus (Controller _name machine _enabled) = do
runController bus (Controller name machine _enabled) = do
inbound <- atomically (dupTChan (busInbound bus))
go inbound machine
where
go inbound f = do
msg <- atomically (readTChan inbound)
uuid <- UUID.V4.nextRandom
(_, f') <- step (channelHassEval bus) uuid f (Event msg)
let ns = Namespace [name]
(_, f') <- step (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) uuid f (Event msg)
go inbound f'
defaultMain :: IO ()
defaultMain = withSocketsDo $ do
defaultMain = withSocketsDo $ withBus $ \bus -> do
token <- getEnv "HA_TOKEN"
bus <- newBus 0
let workers =
[ ("reader", readerAction "last-resort-redux" 8123 token bus)
, ("writer", writerAction bus)
@@ -70,10 +73,12 @@ defaultMain = withSocketsDo $ do
(_, v) <- waitAny as
absurd v
dryRunHassEval :: CallIdGen -> HASSEff a -> IO a
dryRunHassEval gen = \case
CallService x -> do
callId <- generateCallId gen
print (callId, x)
Debug x -> print x
Trace req x -> print (req, x)
dryRunHassEval :: Namespace -> Bus -> HASSEff a -> IO a
dryRunHassEval ns bus = \case
CallService req x -> runKatipT (busLogEnv bus) $ do
callId <- liftIO $ generateCallId (busGen bus)
logF (sl "traceId" (toText (requestTraceId req))) ns DebugS (ls $ show (callId, x))
Debug x -> runKatipT (busLogEnv bus) $ do
logF () ns DebugS (ls $ show x)
Trace req x -> runKatipT (busLogEnv bus) $ do
logF (sl "traceId" (toText (requestTraceId req))) ns InfoS (ls $ show x)
src/HomeAssistant/Runtime/Bus.hs
+30 -12
View File
@@ -1,10 +1,11 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module HomeAssistant.Runtime.Bus
( Bus(..)
, CallIdGen(..)
, mkCallIdGen
, newBus
, withBus
, channelHassEval
) where
@@ -21,29 +22,46 @@ import Data.Aeson (Value)
import Data.IORef (atomicModifyIORef', newIORef)
import HomeAssistant.Controller (HASSEff (..), Service)
import Network.WebSockets (Connection)
import Katip (LogEnv, closeScribes, mkHandleScribe, ColorStrategy (..), permitItem, Severity (..), Verbosity (V2), registerScribe, defaultScribeSettings, initLogEnv, ls, sl, logFM, katipAddContext, KatipContext)
import Control.Exception (bracket)
import System.IO (stdout)
import Data.UUID (toText)
import AFRP (Request(..))
import Control.Monad.IO.Class (MonadIO, liftIO)
-- | Shared runtime state: inbound is a broadcast channel (controllers
-- read from 'dupTChan' copies), outbound queues service calls for the
-- writer, conn holds the current websocket (Nothing before first connect).
data Bus = Bus
{ busInbound :: TChan Value
, busOutbound :: TChan Service
, busOutbound :: TChan (Request, Service)
, busConn :: TVar (Maybe Connection)
, busGen :: CallIdGen
, busLogEnv :: LogEnv
}
newBus :: Int -> IO Bus
newBus start = Bus
<$> newBroadcastTChanIO
<*> newTChanIO
<*> newTVarIO Nothing
<*> mkCallIdGen start
withBus :: (Bus -> IO a) -> IO a
withBus callback = do
handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem DebugS) V2
let makeLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "hass-controller" "production"
-- closeScribes will stop accepting new logs, flush existing ones and clean up resources
bracket makeLogEnv closeScribes $ \le -> do
bus <- Bus
<$> newBroadcastTChanIO
<*> newTChanIO
<*> newTVarIO Nothing
<*> mkCallIdGen 0
<*> pure le
callback bus
channelHassEval :: Bus -> HASSEff a -> IO a
channelHassEval :: (MonadIO m, KatipContext m) => Bus -> HASSEff a -> m a
channelHassEval bus = \case
CallService svc -> atomically $ writeTChan (busOutbound bus) svc
Debug x -> print x
Trace req x -> print (req, x)
CallService req svc -> katipAddContext (sl "traceId" (toText (requestTraceId req))) $ do
logFM DebugS (ls $ show svc)
liftIO $ atomically $ writeTChan (busOutbound bus) (req, svc)
Debug x -> logFM DebugS (ls $ show x)
Trace req x -> katipAddContext (sl "traceId" (toText (requestTraceId req))) $
logFM InfoS (ls $ show x)
newtype CallIdGen = CallIdGen { generateCallId :: IO Int }
src/HomeAssistant/Runtime/Connection.hs
+8 -2
View File
@@ -28,6 +28,9 @@ import HomeAssistant.Controller (Service (..), Target (..))
import HomeAssistant.Runtime.Bus
import HomeAssistant.Runtime.Supervisor (Fatal (..))
import qualified Network.WebSockets as WS
import Katip (runKatipContextT, sl, logFM, Severity (..), ls)
import Data.UUID (toText)
import AFRP (Request(..))
-- | Connect, authenticate, subscribe, then receive and broadcast forever.
-- Restarting this action reconnects. All setup sends happen before the
@@ -86,10 +89,13 @@ receiveJSON conn = do
writerAction :: Bus -> IO Void
writerAction bus = forever $ do
svc <- atomically $ readTChan (busOutbound bus)
(request, svc) <- atomically $ readTChan (busOutbound bus)
conn <- atomically $ readTVar (busConn bus) >>= maybe retry pure
callId <- generateCallId (busGen bus)
WS.sendTextData conn $ encode $ encodeService callId svc
let textData = encode $ encodeService callId svc
runKatipContextT (busLogEnv bus) (sl "traceId" (toText (requestTraceId request))) "connection" $
logFM DebugS (ls textData)
WS.sendTextData conn textData
encodeService :: Int -> Service -> Value
encodeService callId Service{..} = object $
test/BusSpec.hs
+10 -6
View File
@@ -2,6 +2,7 @@
module BusSpec (spec) where
import AFRP (Request (..))
import Control.Concurrent.STM
( atomically
, dupTChan
@@ -9,14 +10,16 @@ import Control.Concurrent.STM
, writeTChan
)
import Data.Aeson (Value (..))
import Data.Time (UTCTime (..))
import Data.UUID (nil)
import HomeAssistant.Controller (HASSEff (..), Service (..), Target(..))
import HomeAssistant.Runtime.Bus
import Katip (Namespace (Namespace), runKatipContextT)
import Test.Hspec
spec :: Spec
spec = describe "Bus" $ do
it "broadcasts inbound messages to every dup'd channel in order" $ do
bus <- newBus 0
it "broadcasts inbound messages to every dup'd channel in order" $ withBus $ \bus -> do
p1 <- atomically $ dupTChan (busInbound bus)
p2 <- atomically $ dupTChan (busInbound bus)
atomically $ writeTChan (busInbound bus) (Number 1)
@@ -26,10 +29,11 @@ spec = describe "Bus" $ do
r1 `shouldBe` (Number 1, Number 2)
r2 `shouldBe` (Number 1, Number 2)
it "channelHassEval writes CallService to the outbound channel" $ do
bus <- newBus 0
let svc = Service "light" "turn_on" Nothing [EntityId "light.bedroom_masse"]
channelHassEval bus (CallService svc)
it "channelHassEval writes CallService to the outbound channel" $ withBus $ \bus -> do
let req = Request (UTCTime (toEnum 0) 0) nil
svc = Service "light" "turn_on" Nothing [EntityId "light.bedroom_masse"]
runKatipContextT (busLogEnv bus) () (Namespace ["test"]) $
channelHassEval bus (CallService req svc)
atomically (readTChan (busOutbound bus)) `shouldReturn` svc
test/RuntimeSpec.hs
+1 -2
View File
@@ -13,8 +13,7 @@ import Test.Hspec
spec :: Spec
spec = describe "runController" $ do
it "feeds inbound events through the machine and forwards service calls" $ do
bus <- newBus 0
it "feeds inbound events through the machine and forwards service calls" $ withBus $ \bus -> do
_ <- async (runController bus (Controller "test" lightController True))
putStrLn "Before the delay"
threadDelay 100000 -- let the controller dup its inbound channel