commit f82e179c4b5105ee98cdb90c29bed867ea2612db
Author: Mats Rauhala <mats.rauhala@iki.fi>
Date:   Thu Aug 20 13:53:44 2026 +0300

    Initial commit

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..d96cce1
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+dist-newstyle
+.envrc
+.direnv
+
diff --git a/.sops.yaml b/.sops.yaml
new file mode 100644
index 0000000..c9c2d47
--- /dev/null
+++ b/.sops.yaml
@@ -0,0 +1,3 @@
+creation_rules:
+  - path_regex: "secrets.yaml"
+    pgp: "95DBE64C2EA64D6B0E0C8C2F9DE6E04ED1918118"
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
index 0000000..ee79217
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for home-assistant-controller
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..b7bde10
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,29 @@
+Copyright (c) 2026, Mats Rauhala
+
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of the copyright holder nor the names of its
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..104d7c1
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,8 @@
+module Main (main) where
+
+import qualified MyLib (defaultMain)
+
+main :: IO ()
+main = do
+  putStrLn "Hello, Haskell!"
+  MyLib.defaultMain
diff --git a/default.nix b/default.nix
new file mode 100644
index 0000000..cbd2874
--- /dev/null
+++ b/default.nix
@@ -0,0 +1,17 @@
+{ mkDerivation, aeson, base, bytestring, lens, lens-aeson, lib
+, network, text, time, websockets
+}:
+mkDerivation {
+  pname = "home-assistant-controller";
+  version = "0.1.0.0";
+  src = ./.;
+  isLibrary = true;
+  isExecutable = true;
+  libraryHaskellDepends = [
+    aeson base bytestring lens lens-aeson network text time websockets
+  ];
+  executableHaskellDepends = [ base ];
+  testHaskellDepends = [ base ];
+  license = lib.meta.getLicenseFromSpdxId "BSD-3-Clause";
+  mainProgram = "home-assistant-controller";
+}
diff --git a/flake.lock b/flake.lock
new file mode 100644
index 0000000..e076a6c
--- /dev/null
+++ b/flake.lock
@@ -0,0 +1,58 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1731533236,
+        "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1787172299,
+        "narHash": "sha256-LS/aXgJh+/1UgtrOxdS5Wum/PgmQYa1AMFZHdH+xGyo=",
+        "rev": "07e1d92cdc0ed416cfa11ff3ca40d17e61cfba7a",
+        "type": "tarball",
+        "url": "https://releases.nixos.org/nixpkgs/nixpkgs-26.11pre1058374.07e1d92cdc0e/nixexprs.tar.xz"
+      },
+      "original": {
+        "id": "nixpkgs",
+        "type": "indirect"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "nixpkgs": "nixpkgs"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}
diff --git a/flake.nix b/flake.nix
new file mode 100644
index 0000000..78aa659
--- /dev/null
+++ b/flake.nix
@@ -0,0 +1,41 @@
+{
+  description = "A very basic flake";
+
+  inputs = {
+    flake-utils = {
+      url = "github:numtide/flake-utils";
+    };
+  };
+
+  outputs = { self, nixpkgs, flake-utils }:
+  flake-utils.lib.eachSystem ["x86_64-linux"] (system:
+    let pkgs = nixpkgs.legacyPackages.${system};
+        hp = nixpkgs.legacyPackages.${system}.haskellPackages.override (old: {
+      overrides = pkgs.lib.composeExtensions (old.overrides or (_: _: {})) (f: p: {
+        home-assistant-controller = pkgs.haskell.lib.overrideCabal (f.callPackage ./. {}) (_: {
+          preBuild = ''
+            export COMMIT="${self.rev or "unknown"}"
+          '';
+        });
+      });
+    });
+    in rec {
+      packages.home-assistant-controller = pkgs.haskell.lib.justStaticExecutables hp.home-assistant-controller;
+      defaultPackage = packages.home-assistant-controller;
+      devShell = hp.shellFor {
+        packages = h: [h.home-assistant-controller];
+        withHoogle = false;
+        buildInputs = with pkgs; [
+          cabal-install
+          hp.hlint
+          cabal2nix
+          ghcid
+
+          hp.graphmod
+
+          hp.haskell-language-server
+        ];
+      };
+    }
+  );
+}
diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal
new file mode 100644
index 0000000..a7f5d7d
--- /dev/null
+++ b/home-assistant-controller.cabal
@@ -0,0 +1,136 @@
+cabal-version:      3.0
+-- The cabal-version field refers to the version of the .cabal specification,
+-- and can be different from the cabal-install (the tool) version and the
+-- Cabal (the library) version you are using. As such, the Cabal (the library)
+-- version used must be equal or greater than the version stated in this field.
+-- Starting from the specification version 2.2, the cabal-version field must be
+-- the first thing in the cabal file.
+
+-- Initial package description 'home-assistant-controller' generated by
+-- 'cabal init'. For further documentation, see:
+--   http://haskell.org/cabal/users-guide/
+--
+-- The name of the package.
+name:               home-assistant-controller
+
+-- The package version.
+-- See the Haskell package versioning policy (PVP) for standards
+-- guiding when and how versions should be incremented.
+-- https://pvp.haskell.org
+-- PVP summary:     +-+------- breaking API changes
+--                  | | +----- non-breaking API additions
+--                  | | | +--- code changes with no API change
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- The license under which the package is released.
+license:            BSD-3-Clause
+
+-- The file containing the license text.
+license-file:       LICENSE
+
+-- The package author(s).
+author:             Mats Rauhala
+
+-- An email address to which users can send suggestions, bug reports, and patches.
+maintainer:         mats.rauhala@iki.fi
+
+-- A copyright notice.
+-- copyright:
+category:           Web
+build-type:         Simple
+
+-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.
+extra-doc-files:    CHANGELOG.md
+
+-- Extra source files to be distributed with the package, such as examples, or a tutorial module.
+-- extra-source-files:
+
+common warnings
+    ghc-options: -Wall
+
+library
+    -- Import common warning flags.
+    import:           warnings
+
+    -- Modules exported by the library.
+    exposed-modules:  MyLib
+
+    -- Modules included in this library but not exported.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+
+    -- Other library packages from which modules are imported.
+    build-depends:    base ^>=4.20.2.0
+                    , websockets
+                    , aeson
+                    , lens-aeson
+                    , lens
+                    , text
+                    , network
+                    , bytestring
+                    , time
+
+    -- Directories containing source files.
+    hs-source-dirs:   src
+
+    -- Base language which the package is written in.
+    default-language: GHC2024
+
+executable home-assistant-controller
+    -- Import common warning flags.
+    import:           warnings
+
+    -- .hs or .lhs file containing the Main module.
+    main-is:          Main.hs
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+
+    -- Other library packages from which modules are imported.
+    build-depends:
+        base ^>=4.20.2.0,
+        home-assistant-controller
+
+    -- Directories containing source files.
+    hs-source-dirs:   app
+
+    -- Base language which the package is written in.
+    default-language: GHC2024
+
+test-suite home-assistant-controller-test
+    -- Import common warning flags.
+    import:           warnings
+
+    -- Base language which the package is written in.
+    default-language: GHC2024
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+
+    -- The interface type and version of the test suite.
+    type:             exitcode-stdio-1.0
+
+    -- Directories containing source files.
+    hs-source-dirs:   test
+
+    -- The entrypoint to the test suite.
+    main-is:          Main.hs
+
+    -- Test dependencies.
+    build-depends:
+        base ^>=4.20.2.0,
+        home-assistant-controller
diff --git a/secrets.yaml b/secrets.yaml
new file mode 100644
index 0000000..646c18c
--- /dev/null
+++ b/secrets.yaml
@@ -0,0 +1,28 @@
+HA_TOKEN: ENC[AES256_GCM,data:zs9nTT2EV/OhBiH9alUuupUvYURXj40lxe7IKKWXdExW+BW98yEDHcQr/KNsQ0Iu9+U2GrsA8WpODeM351kI3Owj3rl082tObBJ2jwF1iyYcXhoH3xvbHb+HN802SBOTIO32m+ZwGvIVPjF8W+67eGKTrIUcqnKj7Ab/TchG+mYPLdil0mYjITY+DCUi0mW1nElCaTTexovj4PHlUdA1xIsCYF+XnTypQv8o+Zy8MsMZtdzNQKJG,iv:Lmxmp5y15sqhQvEO7liVk6x3Y26qtoL39TT2MSqZdok=,tag:1Xvs6YUilP/XH0UxYngTIg==,type:str]
+HA_HOST: ENC[AES256_GCM,data:6ivOMsDGVWsc+xV+Qjk5Y/bbu7cy/g==,iv:nFkLQCNk6DlW5vFq8So44YoICL95GYlhrvj4Rqes9kM=,tag:Nkqnflf4lazGdYnoDkFVVw==,type:str]
+sops:
+    lastmodified: "2026-08-20T10:49:23Z"
+    mac: ENC[AES256_GCM,data:Vfks6xgIizhaYD90vEtWFwjFG1qox56/rlSOMzLZ30xKx1x+085hrlSsq4XOgqBXTDAXeRbMXTpZe/U259gNbfHeBYfpQOgwjHg5MrXl8K3G6eIEWkv/OBQfPpR1DVrhfJsN34ehOUkt3h7K+uHad/XAUavwNNaOQ8fInvRCMqo=,iv:XAvgJJONoI8G5bJ09nR7wxnoH/HJVsPkz2ahXP5fOvI=,tag:hprULBSFR/JpLTot9+B/ng==,type:str]
+    pgp:
+        - created_at: "2026-08-20T05:39:51Z"
+          enc: |-
+            -----BEGIN PGP MESSAGE-----
+
+            hQIMA5Urps8/GyTEAQ//ZQeXRy2SHcR2/hVqleE8V9/3u150TWX7GpDPVdjK7pxu
+            zK1JZSw/FSpNrUPFHXk6rWDm6lv1k/GCx34egHwgumlO1/192nQLMxwNHXhDeJmc
+            k6y44pb3Z1m/upVp62fIif2/f7X2BIQqGI0nZBaCM6sD5FE8HqXCk+jYw4YMvNZp
+            I6dtxxnYwW5wK5Gfv86hTHkn2ibDqARMgd0QsB8fv9fpE9iHWTeeSHqkCBVnb5Kn
+            s0Xk1DeED/ylLAlHfY0p0LVIjeCK5KCQCbIHXh4yb8ioxUxg9LQp8glXbjqbfaBx
+            FadLksLDxBuO0CWxAB4bVk4G/MKCL1nN3KzZBWfy96aknHHGQre0DCe7IxfmSYjd
+            f5UhfeFCVrWQTOtaoq3Oimw6CFeoGe04FKogQmZOWK1zmJmHxjCRGn4n5vzEZB1g
+            Cq+fzDLl2+Krr91Wq/xGwatoWaPl+SDzw1i7CnfGhWJn50BtO/YI1229yLSyANhs
+            M2R9JXxiWFst8xur0nJBKkzH+EZpaVOOLT7FgFpf/vWOO/se1kVPaMAhg6fQ3IwJ
+            JphPD+FTkTDY4GBefVP/qOhOnibcIjhwTiDWP6ppcaOxgVjyDyLsqS96jYSwfyKQ
+            puDyzrD4BlLv1lc2lULCtgMwZj428Vpd7YI1SjnxxKnKhIQ1IZx0ddneHn9fSivS
+            XgE6NpQKQ110FFYse8P1fb2yNaYb2ZRbLh0cUOe2qcTATTvK5OdDVlgCjNsO8Fgl
+            OO8hwmsk+1QziCwO4Md8NPdyNn4Kup1iRojMyAh23CT5LyYXoccakWvF/awLvz8=
+            =nX50
+            -----END PGP MESSAGE-----
+          fp: 95DBE64C2EA64D6B0E0C8C2F9DE6E04ED1918118
+    unencrypted_suffix: _unencrypted
+    version: 3.13.3
diff --git a/src/MyLib.hs b/src/MyLib.hs
new file mode 100644
index 0000000..72690fb
--- /dev/null
+++ b/src/MyLib.hs
@@ -0,0 +1,352 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE GADTs #-}
+
+module MyLib (defaultMain) where
+
+import Control.Monad (forever)
+import Data.Aeson ((.=), Value (Null), encode, eitherDecode, object)
+import qualified Data.Aeson.KeyMap as KM
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Network.WebSockets as WS
+import Network.Socket (withSocketsDo)
+import System.Environment (getEnv)
+import Control.Category (Category(..), (>>>))
+import Prelude hiding ((.), id)
+import Control.Arrow (Arrow(..), ArrowChoice(..), ArrowLoop(..), returnA)
+import Data.Time (UTCTime, getCurrentTime)
+import Data.Either (fromLeft)
+import Data.Bool (bool)
+import Control.Lens (has, only, prefixed, (^?), _Show, to)
+import Data.Aeson.Lens (key, _String)
+import qualified Data.Text.Lens as TL
+import Control.Monad.Fix (MonadFix (mfix))
+import Data.IORef (newIORef, atomicModifyIORef')
+
+newtype Mealy eff a b = Mealy
+  { runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> UTCTime -> a -> m (b, Mealy eff a b) }
+
+data HASSEff a where
+  CallService :: Service -> HASSEff ()
+  Pure :: a -> HASSEff a
+
+data Service = Service
+  { serviceDomain :: T.Text
+  , serviceName :: T.Text
+  , serviceData :: Maybe Value
+  , serviceTarget :: T.Text
+  }
+  deriving Show
+
+
+eff :: (a -> eff b) -> Mealy eff a b
+eff f = Mealy $ \nt _ x ->
+  nt (f x) >>= \b -> pure (b, eff f)
+
+
+type HASS a b = Mealy HASSEff a b
+
+callService :: Service -> HASS a ()
+callService service = eff (\_ -> CallService service)
+
+instance Category (Mealy eff) where
+  id = Mealy (\_ _ x -> pure (x, id))
+  (Mealy f) . (Mealy g) = Mealy $ \nt t a -> do
+    (b, g') <- g nt t a
+    (c, f') <- f nt t b
+    pure (c, f' . g')
+
+instance Arrow (Mealy eff) where
+  arr f = Mealy $ \_ _ b -> pure (f b, arr f)
+  first (Mealy f) = Mealy $ \nt t (b,d) -> do
+    (c, f') <- f nt t b
+    pure ((c, d), first f')
+
+instance ArrowChoice (Mealy eff) where
+  left (Mealy f) = Mealy $ \nt t -> \case
+    Left b -> do
+      (c, f') <- f nt t b
+      pure (Left c, left f')
+    Right d -> pure (Right d, left (Mealy f))
+
+instance ArrowLoop (Mealy eff) where
+  loop (Mealy f) = Mealy $ \nt t b -> do
+    ((c,_), f') <- mfix $ \((_,d), _) -> f nt t (b,d)
+    pure (c, loop f')
+
+instance Functor (Mealy eff a) where
+  fmap f (Mealy g) = Mealy $ \nt t a -> do
+    (b, g') <- g nt t a
+    pure (f b, fmap f g')
+
+instance Applicative (Mealy eff a) where
+  pure b = Mealy $ \_ _ _ -> pure (b, pure b)
+  Mealy f <*> Mealy x = Mealy $ \nt t a -> do
+    (f', fNext) <- f nt t a
+    (x', xNext) <- x nt t a
+    pure (f' x', fNext <*> xNext)
+
+
+data Event a
+  = Tick
+  | Event a
+  deriving (Show, Functor, Foldable, Traversable)
+
+
+hold :: a -> Mealy eff (Event a) a
+hold a = Mealy $ \_ _ -> \case
+  Tick -> pure (a, hold a)
+  Event a' -> pure (a', hold a')
+
+events :: Mealy eff (Event a) (Either () a)
+events = arr $ \case
+  Tick -> Left ()
+  Event a -> Right a
+
+switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b
+switch (Mealy f) s = Mealy $ \nt t a -> do
+  ((b, ev), f') <- f nt t a
+  case ev of
+          Tick -> pure (b, switch f' s)
+          Event x -> runMealy (s x) nt t a
+
+
+
+preMapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+preMapAccum f x extract = go x
+  where
+    go b = Mealy $ \_ _ a ->
+      let next = f b a
+      in pure (extract b, go next)
+
+preMapAccumUTCTime :: (UTCTime -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+preMapAccumUTCTime f x extract = go x
+  where
+    go b = Mealy $ \_ t a ->
+      let next = f t b a
+      in pure (extract b, go next)
+
+mapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+mapAccum f x extract = go x
+  where
+    go b = Mealy $ \_ _ a ->
+      let next = f b a
+      in pure (extract next, go next)
+
+mapAccumUTCTime :: (UTCTime -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+mapAccumUTCTime f x extract = go x
+  where
+    go b = Mealy $ \_ t a ->
+      let next = f t b a
+      in pure (extract next, go next)
+
+
+
+changes :: Eq a => Mealy eff a (Event a)
+changes = mapAccum go Nothing (maybe Tick snd)
+  where
+    go :: Eq a => Maybe (a, Event a) -> a -> Maybe (a, Event a)
+    -- The first observed value is not a change I think
+    go Nothing x = Just (x, Tick)
+    go (Just (y, _)) x | x == y = Just (x, Tick)
+                       | otherwise = Just (x, Event x)
+
+
+whenA :: (a -> Bool) -> Mealy eff a () -> Mealy eff a ()
+whenA predicate auto = arr (\a -> if predicate a then Left a else Right ()) >>> left auto >>> arr (fromLeft ())
+
+filterA :: (a -> Bool) -> Mealy eff a (Either () a)
+filterA f = arr $ \a -> bool (Left ()) (Right a) (f a)
+
+thenA :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
+thenA f g = f >>> arr Left ||| g
+
+(>>|) :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
+(>>|) = thenA
+
+infixl 1 >>|
+
+toEvent :: Mealy eff (Either () a) (Event a)
+toEvent = arr (either (const Tick) Event)
+
+ruuviTemperatures :: Mealy eff (Event Value) Double
+ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0
+
+ruuviPressures :: Mealy eff (Event Value) Double
+ruuviPressures = entityRead "sensor.ruuvitag_b168_pressure" >>> hold 0
+
+data Ruuvi = Ruuvi { ruuviTemperature :: Double, ruuviPressure :: Double }
+           deriving (Show, Eq)
+
+ruuvi :: Mealy eff (Event Value) (Event Ruuvi)
+ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes
+
+data Direction = Increase | Decrease | Steady
+  deriving (Show, Eq)
+
+numericDirection = mapAccum go (Nothing, Nothing) extract
+  where
+    go (_, old) new = (old, new)
+    extract :: (Maybe Double, Maybe Double) -> Direction
+    extract (old, new) = maybe Steady (\x -> if x >  0 then Increase else Decrease) $ (-) <$> old <*> new
+
+data DoorState = Open | Closed
+  deriving (Show, Eq)
+
+door :: HASS (Event Value) (Event DoorState)
+door = entityBool "binary_sensor.makuuhuone_ovi_contact"
+  >>> arr (fmap (bool Closed Open))
+  >>> hold Open
+  >>> changes
+
+-- Turn off lights when door is closed
+light :: Bool -> Service
+light b = Service
+  { serviceDomain="light"
+  , serviceName= bool "turn_off" "turn_on" b
+  , serviceData=Nothing
+  , serviceTarget="light.bedroom_masse"
+  }
+
+lightController :: HASS (Event Value) (Event DoorState)
+lightController = proc ev -> do
+  doorState <- door -< ev
+  case doorState of
+       Event Open -> callService (light False) -< ()
+       Event Closed -> callService (light True) -< ()
+       _ -> returnA -< ()
+  returnA -< doorState
+
+entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value)
+entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent
+  where
+    isEntity :: Value -> Bool
+    isEntity = has (key "event" . key "data" . key "entity_id" . _String . only entityId)
+
+entityChangeEvent' :: T.Text -> Mealy eff (Event Value) (Either () Value)
+entityChangeEvent' entityId = events >>| filterA isEntity
+  where
+    isEntity :: Value -> Bool
+    isEntity = has (key "event" . key "data" . key "entity_id" . _String . only entityId)
+
+entityRead' :: (Read a) => T.Text -> Mealy eff (Event Value) (Either () a)
+entityRead' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right))
+  where
+    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read
+
+entityBool' :: T.Text -> Mealy eff (Event Value) (Either () Bool)
+entityBool' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right))
+  where
+    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to toBool
+    toBool = \case
+      "on" -> True
+      "off" -> False
+
+entityRead :: (Read a) => T.Text -> Mealy eff (Event Value) (Event a)
+entityRead entityId = entityRead' entityId >>> toEvent
+  where
+    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read
+
+entityBool :: T.Text -> Mealy eff (Event Value) (Event Bool)
+entityBool entityId = entityBool' entityId >>> toEvent
+  where
+    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read
+
+
+step :: (forall x. eff x -> IO x) -> Mealy eff a b -> a -> IO (b, Mealy eff a b)
+step nt (Mealy f) a = do
+  now <- getCurrentTime
+  f nt now a
+
+defaultMain :: IO ()
+defaultMain = withSocketsDo $ do
+    token <- getEnv "HA_TOKEN"
+    gen <- mkCallIdGen 0
+    WS.runClient "last-resort-redux" 8123 "/api/websocket" (app gen token)
+
+app :: CallIdGen -> String -> WS.ClientApp ()
+app gen token conn = do
+    -- HA speaks first: {"type":"auth_required", ...}
+    authRequired <- receiveJSON conn
+    print authRequired
+
+    WS.sendTextData conn $ encode $ object
+        [ "type"         .= ("auth" :: T.Text)
+        , "access_token" .= token
+        ]
+
+    -- Expect {"type":"auth_ok", ...}
+    authResult <- receiveJSON conn
+    print authResult
+
+    getStateId <- generateCallId gen
+    WS.sendTextData conn $ encode $ object
+      [ "id" .= getStateId
+      , "type" .= ("get_states" :: T.Text)
+      ]
+    msg <- WS.receiveData conn :: IO BL.ByteString
+    BL.writeFile "/tmp/states.json" msg
+
+    subscribeId <- generateCallId gen
+    -- Subscription 1: all entity state changes
+    WS.sendTextData conn $ encode $ object
+        [ "id"         .= subscribeId
+        , "type"       .= ("subscribe_events" :: T.Text)
+        , "event_type" .= ("state_changed" :: T.Text)
+        ]
+
+
+    go lightController
+
+  where
+    go f = do
+      msg <- WS.receiveData conn :: IO BL.ByteString
+      let decoded = Event $ either (const Null) id $ eitherDecode @Value msg
+      (x, f') <- step (hassEval gen conn) f decoded
+      mapM_ print x
+      go f'
+
+receiveJSON :: WS.Connection -> IO Value
+receiveJSON conn = do
+    msg <- WS.receiveData conn
+    case eitherDecode msg of
+        Left err -> fail $ "Invalid JSON from Home Assistant: " ++ err
+        Right x  -> pure x
+
+
+wsCallService
+  :: WS.Connection
+  -> Int           -- ^ request id
+  -> T.Text        -- ^ domain
+  -> T.Text        -- ^ service
+  -> T.Text        -- ^ entity id
+  -> IO ()
+wsCallService conn requestId domain service entityId =
+  WS.sendTextData conn $ encode $ object
+    [ "id"      .= requestId
+    , "type"    .= ("call_service" :: T.Text)
+    , "domain"  .= domain
+    , "service" .= service
+    , "target"  .= object
+        [ "entity_id" .= entityId
+        ]
+    ]
+
+newtype CallIdGen = CallIdGen { generateCallId :: IO Int  }
+
+mkCallIdGen :: Int -> IO CallIdGen
+mkCallIdGen start = do
+  gen <- newIORef start
+  pure $ CallIdGen $ atomicModifyIORef' gen (\old -> let new = old + 1 in new `seq` (new, new))
+
+hassEval :: CallIdGen -> WS.Connection -> HASSEff a -> IO a
+hassEval gen conn = \case
+  CallService x -> do
+    callId <- generateCallId gen
+    print (callId, x)
+    -- wsCallService conn callId (serviceDomain x) (serviceName x) (serviceTarget x)
+  Pure a -> pure a
+
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
index 0000000..3e2059e
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,4 @@
+module Main (main) where
+
+main :: IO ()
+main = putStrLn "Test suite not yet implemented."