Merge branch 'refactor/module-split'
This commit is contained in:
+2
-2
@@ -1,8 +1,8 @@
|
|||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
import qualified MyLib (defaultMain)
|
import qualified HomeAssistant.Runtime (defaultMain)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
putStrLn "Hello, Haskell!"
|
putStrLn "Hello, Haskell!"
|
||||||
MyLib.defaultMain
|
HomeAssistant.Runtime.defaultMain
|
||||||
|
|||||||
@@ -59,7 +59,9 @@ library
|
|||||||
import: warnings
|
import: warnings
|
||||||
|
|
||||||
-- Modules exported by the library.
|
-- Modules exported by the library.
|
||||||
exposed-modules: MyLib
|
exposed-modules: AFRP
|
||||||
|
, HomeAssistant.Controller
|
||||||
|
, HomeAssistant.Runtime
|
||||||
|
|
||||||
-- Modules included in this library but not exported.
|
-- Modules included in this library but not exported.
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
|
|||||||
+148
@@ -0,0 +1,148 @@
|
|||||||
|
{-# 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(..))
|
||||||
|
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)
|
||||||
@@ -0,0 +1,120 @@
|
|||||||
|
{-# 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, filterA, (>>|), toEvent)
|
||||||
|
import Control.Arrow (Arrow(..), 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 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
|
||||||
|
|
||||||
|
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
|
||||||
|
_ -> False
|
||||||
|
|
||||||
|
entityRead :: (Read a) => T.Text -> Mealy eff (Event Value) (Event a)
|
||||||
|
entityRead entityId = entityRead' entityId >>> toEvent
|
||||||
|
|
||||||
|
entityBool :: T.Text -> Mealy eff (Event Value) (Event Bool)
|
||||||
|
entityBool entityId = entityBool' entityId >>> toEvent
|
||||||
@@ -0,0 +1,124 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
|
|
||||||
|
module HomeAssistant.Runtime
|
||||||
|
( defaultMain
|
||||||
|
, app
|
||||||
|
, step
|
||||||
|
, CallIdGen
|
||||||
|
, mkCallIdGen
|
||||||
|
, hassEval
|
||||||
|
, dryRunHassEval
|
||||||
|
, 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 (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 (dryRunHassEval gen) 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
|
||||||
|
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
|
||||||
-352
@@ -1,352 +0,0 @@
|
|||||||
{-# 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
|
|
||||||
|
|
||||||
Reference in New Issue
Block a user