113 lines
4.8 KiB
Haskell
113 lines
4.8 KiB
Haskell
{-# LANGUAGE ExistentialQuantification #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module HomeAssistant.Runtime
|
|
( defaultMain
|
|
, step
|
|
, CallIdGen
|
|
, mkCallIdGen
|
|
, dryRunHassEval
|
|
, Controller(..)
|
|
, runController
|
|
) where
|
|
|
|
import AFRP (Event (..), Mealy (..), Request (..), Auto, stepAutoSerializing, load, DecodedAuto (..))
|
|
import Control.Concurrent.Async (async, waitAny)
|
|
import Control.Concurrent.STM (atomically, dupTChan, readTChan)
|
|
import Data.Aeson (Value)
|
|
import qualified Data.Text as T
|
|
import Data.Time (getCurrentTime, getCurrentTimeZone)
|
|
import Data.Void (Void, absurd)
|
|
import HomeAssistant.Controller (HASS, HASSEff (..))
|
|
import HomeAssistant.Runtime.Bus
|
|
import HomeAssistant.Runtime.Connection (readerAction, writerAction)
|
|
import HomeAssistant.Runtime.Supervisor (defaultBackoff, supervised)
|
|
import Network.Socket (withSocketsDo)
|
|
import System.Environment (getEnv, lookupEnv)
|
|
import HomeAssistant.Controller.Bedroom (bedroomPresenceController, bedroomButtonController, bedroomDrawerController, humidifierController)
|
|
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 HomeAssistant.Controller.Ruuvi (ruuviController)
|
|
import HomeAssistant.Controller.Children (schoolLightController)
|
|
import Data.Maybe (fromMaybe)
|
|
import qualified System.Metrics
|
|
import qualified HomeAssistant.Runtime.Metrics
|
|
import System.FilePath ((</>))
|
|
import HomeAssistant.Controller.Kitchen (kitchenMotionController)
|
|
|
|
step :: (MonadIO m) => FilePath -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
|
|
step path trace st a = do
|
|
now <- liftIO getCurrentTime
|
|
tz <- liftIO getCurrentTimeZone
|
|
let req = Request now tz trace
|
|
stepAutoSerializing path st req a
|
|
|
|
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 -- This works but leaving for vacation
|
|
, Controller "bedroom-drawer" bedroomDrawerController True
|
|
, Controller "bedroom-humidifier" humidifierController True
|
|
, Controller "ruuvi-controller" ruuviController False
|
|
, Controller "school-light-controller" schoolLightController True
|
|
, Controller "kitchen-motion-controller" kitchenMotionController True
|
|
]
|
|
|
|
-- | 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 :: FilePath -> Bus -> Controller -> IO Void
|
|
runController rootDir bus (Controller name machine _enabled) = do
|
|
inbound <- atomically (dupTChan (busInbound bus))
|
|
let ns = Namespace [name]
|
|
let workerDefinition = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus)
|
|
let path = rootDir </> T.unpack name
|
|
worker <- load path workerDefinition >>= \case
|
|
Decoded a -> pure a
|
|
FailDecode err a -> a <$ putStrLn ("Failed to load (" <> T.unpack name <> "): " <> err)
|
|
go path inbound worker
|
|
where
|
|
go path inbound f = do
|
|
msg <- atomically (readTChan inbound)
|
|
uuid <- UUID.V4.nextRandom
|
|
(_, next) <- step path uuid f msg
|
|
go path inbound next
|
|
|
|
defaultMain :: IO ()
|
|
defaultMain = withSocketsDo $ do
|
|
severity <- maybe InfoS (const DebugS) <$> lookupEnv "HA_DEBUG"
|
|
withBus severity $ \bus -> do
|
|
token <- getEnv "HA_TOKEN"
|
|
host <- getEnv "HA_HOST"
|
|
rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR"
|
|
store <- System.Metrics.newStore
|
|
System.Metrics.registerGcMetrics store
|
|
rrdPath <- fromMaybe "hass-controller.rrd" <$> lookupEnv "HA_RRD_PATH"
|
|
rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL"
|
|
let active = [c | c@(Controller _ _ True) <- controllers]
|
|
ents = foldMap (\(Controller _ m _) -> entities m) active
|
|
workers =
|
|
[ ("reader", readerAction host 8123 token ents bus)
|
|
, ("writer", writerAction bus)
|
|
] ++ [ (name, runController rootPath bus c) | c@(Controller name _ True) <- controllers ]
|
|
++ [("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)]
|
|
as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers
|
|
(_, v) <- waitAny as
|
|
absurd v
|
|
|
|
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)
|