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

Initial commit

Browse Source
This commit is contained in:
MasseR
2026-08-20 13:53:44 +03:00
commit f82e179c4b
12 changed files with 685 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.gitignore
+4
View File
@@ -0,0 +1,4 @@
dist-newstyle
.envrc
.direnv
.sops.yaml
+3
View File
@@ -0,0 +1,3 @@
creation_rules:
- path_regex: "secrets.yaml"
pgp: "95DBE64C2EA64D6B0E0C8C2F9DE6E04ED1918118"
CHANGELOG.md
+5
View File
@@ -0,0 +1,5 @@
# Revision history for home-assistant-controller
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.
LICENSE
+29
View File
@@ -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.
app/Main.hs
+8
View File
@@ -0,0 +1,8 @@
module Main (main) where
import qualified MyLib (defaultMain)
main :: IO ()
main = do
putStrLn "Hello, Haskell!"
MyLib.defaultMain
default.nix
+17
View File
@@ -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";
}
flake.lock
Generated
+58
View File
@@ -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
}
flake.nix
+41
View File
@@ -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
];
};
}
);
}
home-assistant-controller.cabal
+136
View File
@@ -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
secrets.yaml
+28
View File
@@ -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
src/MyLib.hs
+352
View File
@@ -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
test/Main.hs
+4
View File
@@ -0,0 +1,4 @@
module Main (main) where
main :: IO ()
main = putStrLn "Test suite not yet implemented."