From e50a505a137f498fa1ab3ce23d619fdf7b019f0b Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Fri, 21 Aug 2026 13:15:31 +0300 Subject: [PATCH] Works --- default.nix | 8 +- .../plans/2026-08-20-concurrent-runtime.md | 874 ------------------ .../plans/2026-08-20-module-split.md | 732 --------------- .../plans/2026-08-21-katip-logging.md | 750 --------------- .../2026-08-20-concurrent-runtime-design.md | 258 ------ .../specs/2026-08-20-module-split-design.md | 130 --- .../specs/2026-08-21-katip-logging-design.md | 278 ------ home-assistant-controller.cabal | 5 +- src/AFRP.hs | 6 +- src/HomeAssistant/Controller.hs | 6 +- src/HomeAssistant/Controller/Bedroom.hs | 4 +- src/HomeAssistant/Runtime.hs | 35 +- src/HomeAssistant/Runtime/Bus.hs | 42 +- src/HomeAssistant/Runtime/Connection.hs | 10 +- test/BusSpec.hs | 16 +- test/RuntimeSpec.hs | 3 +- 16 files changed, 85 insertions(+), 3072 deletions(-) delete mode 100644 docs/superpowers/plans/2026-08-20-concurrent-runtime.md delete mode 100644 docs/superpowers/plans/2026-08-20-module-split.md delete mode 100644 docs/superpowers/plans/2026-08-21-katip-logging.md delete mode 100644 docs/superpowers/specs/2026-08-20-concurrent-runtime-design.md delete mode 100644 docs/superpowers/specs/2026-08-20-module-split-design.md delete mode 100644 docs/superpowers/specs/2026-08-21-katip-logging-design.md diff --git a/default.nix b/default.nix index 33ee412..6618ebe 100644 --- a/default.nix +++ b/default.nix @@ -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 = [ diff --git a/docs/superpowers/plans/2026-08-20-concurrent-runtime.md b/docs/superpowers/plans/2026-08-20-concurrent-runtime.md deleted file mode 100644 index 7764720..0000000 --- a/docs/superpowers/plans/2026-08-20-concurrent-runtime.md +++ /dev/null @@ -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). diff --git a/docs/superpowers/plans/2026-08-20-module-split.md b/docs/superpowers/plans/2026-08-20-module-split.md deleted file mode 100644 index 667817e..0000000 --- a/docs/superpowers/plans/2026-08-20-module-split.md +++ /dev/null @@ -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" -``` diff --git a/docs/superpowers/plans/2026-08-21-katip-logging.md b/docs/superpowers/plans/2026-08-21-katip-logging.md deleted file mode 100644 index e898b17..0000000 --- a/docs/superpowers/plans/2026-08-21-katip-logging.md +++ /dev/null @@ -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.`. `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. diff --git a/docs/superpowers/specs/2026-08-20-concurrent-runtime-design.md b/docs/superpowers/specs/2026-08-20-concurrent-runtime-design.md deleted file mode 100644 index 4e1ba58..0000000 --- a/docs/superpowers/specs/2026-08-20-concurrent-runtime-design.md +++ /dev/null @@ -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. diff --git a/docs/superpowers/specs/2026-08-20-module-split-design.md b/docs/superpowers/specs/2026-08-20-module-split-design.md deleted file mode 100644 index 57ddd82..0000000 --- a/docs/superpowers/specs/2026-08-20-module-split-design.md +++ /dev/null @@ -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`). diff --git a/docs/superpowers/specs/2026-08-21-katip-logging-design.md b/docs/superpowers/specs/2026-08-21-katip-logging-design.md deleted file mode 100644 index 4d1b972..0000000 --- a/docs/superpowers/specs/2026-08-21-katip-logging-design.md +++ /dev/null @@ -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:] `. -- `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 -. `. - -## Severity & namespace mapping - -| Site | Namespace | Severity | -|------|-----------|----------| -| dryRun `CallService` | `` | DebugS | -| `Debug` (both interpreters) | `` | DebugS | -| `Trace req x` (both interpreters) | `` | DebugS | -| Supervisor crash | `runtime.supervisor.` | WarningS | -| Supervisor restart | `runtime.supervisor.` | 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.][Debug][...][traceId:] `. -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/`). diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index a79a616..92b0a71 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -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 diff --git a/src/AFRP.hs b/src/AFRP.hs index 2d8fc60..18a5834 100644 --- a/src/AFRP.hs +++ b/src/AFRP.hs @@ -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)) diff --git a/src/HomeAssistant/Controller.hs b/src/HomeAssistant/Controller.hs index 522f817..bed1ed9 100644 --- a/src/HomeAssistant/Controller.hs +++ b/src/HomeAssistant/Controller.hs @@ -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) diff --git a/src/HomeAssistant/Controller/Bedroom.hs b/src/HomeAssistant/Controller/Bedroom.hs index b8e3a27..15a45e3 100644 --- a/src/HomeAssistant/Controller/Bedroom.hs +++ b/src/HomeAssistant/Controller/Bedroom.hs @@ -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" diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index a8b2b04..00ea32c 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -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) diff --git a/src/HomeAssistant/Runtime/Bus.hs b/src/HomeAssistant/Runtime/Bus.hs index 0b987f5..6e346bf 100644 --- a/src/HomeAssistant/Runtime/Bus.hs +++ b/src/HomeAssistant/Runtime/Bus.hs @@ -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 } diff --git a/src/HomeAssistant/Runtime/Connection.hs b/src/HomeAssistant/Runtime/Connection.hs index e5d6473..0b4df48 100644 --- a/src/HomeAssistant/Runtime/Connection.hs +++ b/src/HomeAssistant/Runtime/Connection.hs @@ -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 $ diff --git a/test/BusSpec.hs b/test/BusSpec.hs index dcaae6f..a36b797 100644 --- a/test/BusSpec.hs +++ b/test/BusSpec.hs @@ -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 diff --git a/test/RuntimeSpec.hs b/test/RuntimeSpec.hs index 35b907b..59e6742 100644 --- a/test/RuntimeSpec.hs +++ b/test/RuntimeSpec.hs @@ -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