132 lines
5.7 KiB
Haskell
132 lines
5.7 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.STM (atomically, dupTChan, readTChan)
|
|
import Data.Aeson (Value)
|
|
import qualified Data.Text as T
|
|
import Data.Time (getCurrentTime, getCurrentTimeZone)
|
|
import Data.Void (Void)
|
|
import HomeAssistant.Controller (HASS, HASSEff (..))
|
|
import HomeAssistant.Runtime.Bus
|
|
import HomeAssistant.Runtime.Connection (writerAction, readerAction)
|
|
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.Children (schoolLightController, childrenBedroomButtonController)
|
|
import Data.Maybe (fromMaybe)
|
|
import qualified System.Metrics
|
|
import qualified HomeAssistant.Runtime.Metrics
|
|
import System.FilePath ((</>))
|
|
import Text.Read (readMaybe)
|
|
import HomeAssistant.Controller.Kitchen (kitchenMotionController)
|
|
import HomeAssistant.Controller.Livingroom (livingroomPresenceController)
|
|
import HomeAssistant.Runtime.RateLimit (slidingWindowLimiter, registerRateLimitMetrics)
|
|
import UnliftIO.Async
|
|
import HomeAssistant.Runtime.Supervisor (supervised)
|
|
import HomeAssistant.Controller.Hallway (hallwayLightsController)
|
|
import qualified HttpServer
|
|
|
|
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 Bool T.Text (HASS (Event Value) b)
|
|
|
|
controllers :: [Controller]
|
|
controllers =
|
|
[ Controller True "bedroom-presence" bedroomPresenceController
|
|
, Controller True "bedroom-button" bedroomButtonController
|
|
, Controller True "bedroom-drawer" bedroomDrawerController
|
|
, Controller True "bedroom-humidifier" humidifierController
|
|
, Controller True "school-light-controller" schoolLightController
|
|
, Controller True "kitchen-motion-controller" kitchenMotionController
|
|
, Controller True "livingroom-presence" livingroomPresenceController
|
|
, Controller True "hallway-motion-controller" hallwayLightsController
|
|
, Controller True "children-button" childrenBedroomButtonController
|
|
]
|
|
|
|
-- | 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 :: MonadIO m => FilePath -> Bus -> Controller -> m Void
|
|
runController rootDir bus (Controller _enabled name machine ) = liftIO $ 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
|
|
|
|
lookupPort :: IO Int
|
|
lookupPort = do
|
|
m <- lookupEnv "HA_METRICS_PORT"
|
|
case m of
|
|
Nothing -> pure 8124
|
|
Just s -> case readMaybe s of
|
|
Just p | p >= 1 && p <= 65535 -> pure p
|
|
_ -> fail ("HA_METRICS_PORT must be a port in 1..65535: " <> s)
|
|
|
|
defaultMain :: IO ()
|
|
defaultMain = withSocketsDo $ do
|
|
severity <- maybe InfoS (const DebugS) <$> lookupEnv "HA_DEBUG"
|
|
store <- System.Metrics.newStore
|
|
System.Metrics.registerGcMetrics store
|
|
appMetrics <- HomeAssistant.Runtime.Metrics.registerAppMetrics store
|
|
rateLimitMetrics <- registerRateLimitMetrics store
|
|
withBus severity appMetrics $ \bus -> do
|
|
token <- getEnv "HA_TOKEN"
|
|
host <- getEnv "HA_HOST"
|
|
rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR"
|
|
rrdPath <- fromMaybe "hass-controller.rrd" <$> lookupEnv "HA_RRD_PATH"
|
|
rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL"
|
|
metricsPort <- lookupPort
|
|
writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20
|
|
let active = [c | c@(Controller True _ _) <- controllers]
|
|
ents = foldMap (\(Controller _ _ m) -> entities m) active
|
|
workers =
|
|
[ ("reader", readerAction host 8123 token ents bus)
|
|
, ("writer", writerAction writerLimiter bus)
|
|
, ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)
|
|
, ("metrics-http", HttpServer.runHttpServer rrdPath rrdtool metricsPort)
|
|
] ++ [ (name, runController rootPath bus c) | c@(Controller True name _) <- active ]
|
|
runKatipContextT (busLogEnv bus) () mempty $
|
|
mapConcurrently_ (uncurry supervised) workers
|
|
|
|
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)
|