Logging and really not working light restoration
This commit is contained in:
@@ -10,6 +10,7 @@ reactive programming (AFRP). Haskell, built with cabal.
|
||||
- Vertical modules: split by feature/concept, not by layer.
|
||||
- Comments are minimal. They describe the contract, not the implementation,
|
||||
and should stay stable as the implementation changes.
|
||||
- Never ever log directly to stdout via `putStr` and friends. Always use proper logging functions
|
||||
|
||||
## Build
|
||||
|
||||
|
||||
@@ -4,5 +4,4 @@ import qualified HomeAssistant.Runtime (defaultMain)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "Hello, Haskell!"
|
||||
HomeAssistant.Runtime.defaultMain
|
||||
|
||||
+7
-5
@@ -56,7 +56,7 @@ import qualified Data.Set as S
|
||||
import qualified Data.Text as T
|
||||
import Data.Serialize (Get, Putter, Serialize (put), runGet, get)
|
||||
import qualified Data.ByteString as B
|
||||
import Control.Exception (IOException, handle, throwIO)
|
||||
import Control.Exception (IOException)
|
||||
import System.IO.Error (isDoesNotExistError)
|
||||
import GHC.Generics (Generic)
|
||||
import Data.Sequence (Seq, (|>))
|
||||
@@ -65,6 +65,8 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Conduit (ConduitT, (.|))
|
||||
import qualified Data.Conduit.Cereal as CC
|
||||
import qualified Conduit as C
|
||||
import Control.Monad.Catch (MonadCatch, handle)
|
||||
import Control.Exception.Annotated (throw)
|
||||
|
||||
|
||||
data Codec s = Codec { getter :: !(Get s), putter :: !(Putter s) }
|
||||
@@ -247,13 +249,13 @@ save path s
|
||||
isDirty _ = False
|
||||
|
||||
|
||||
load :: forall m a b. FilePath -> Auto m a b -> IO (DecodedAuto m a b)
|
||||
load path a = handle defaultOnMissingFile (flip deserialize a <$> B.readFile path)
|
||||
load :: forall eff a b m. (MonadCatch m, MonadIO m) => FilePath -> Auto eff a b -> m (DecodedAuto eff a b)
|
||||
load path a = handle defaultOnMissingFile (flip deserialize a <$> liftIO (B.readFile path))
|
||||
where
|
||||
defaultOnMissingFile :: IOException -> IO (DecodedAuto m a b)
|
||||
defaultOnMissingFile :: IOException -> m (DecodedAuto eff a b)
|
||||
defaultOnMissingFile e
|
||||
| isDoesNotExistError e = pure $ FailDecode "State doesn't exist yet" a
|
||||
| otherwise = throwIO e
|
||||
| otherwise = throw e
|
||||
|
||||
-- | The set of entity ids an arrow subscribes to. Static: it does not
|
||||
-- change as the machine steps, so the runtime can read it once to build
|
||||
|
||||
@@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE Arrows #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
module HomeAssistant.Controller.Bedroom where
|
||||
|
||||
import HomeAssistant.Controller
|
||||
@@ -14,6 +15,7 @@ import Data.Map (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Serialize.Text ()
|
||||
import Data.Default (def)
|
||||
import Data.Serialize (Serialize)
|
||||
|
||||
|
||||
|
||||
@@ -48,32 +50,38 @@ presenceLightEvents =
|
||||
offEvent = arr not >>> AFRP.waitFor 300 >>> arr (AFRP.tag LightingOff)
|
||||
|
||||
|
||||
bedroomLightSnapshots :: HASS (Event Value) (Map T.Text LightSnapshot)
|
||||
bedroomLightSnapshots = M.fromList <$> traverse (\e -> (e,) <$> observedLight e) [e | EntityId e <- bedroomLightTargets]
|
||||
bedroomLightStatus :: HASS (Event Value) (Map T.Text LightObservation)
|
||||
bedroomLightStatus = M.fromList <$> traverse (\e -> (e,) <$> observedLight e) [e | EntityId e <- bedroomLightTargets]
|
||||
|
||||
newtype Snapshot = Snapshot { getSnapshot :: Map T.Text LightObservation }
|
||||
deriving (Show, Eq)
|
||||
deriving Serialize via (Map T.Text LightObservation)
|
||||
|
||||
bedroomPresenceController :: HASS (Event Value) ()
|
||||
bedroomPresenceController = proc x -> do
|
||||
p <- presenceLightEvents >>> traceEvent -< x
|
||||
snap <- (doSnapshot &&& bedroomLightSnapshots) >>> AFRP.snapshot M.empty >>> traceValue -< x
|
||||
-- This line is just for debugging purposes
|
||||
_ <- bedroomLightStatus >>> AFRP.changes >>> traceEvent -< x
|
||||
snap <- (doSnapshot &&& bedroomLightStatus) >>> AFRP.snapshot M.empty >>> arr Snapshot -< x
|
||||
-- This line is just for debugging
|
||||
_ <- AFRP.changes >>> traceEvent -< snap
|
||||
case p of
|
||||
Event LightingOff -> do
|
||||
callService (light bedroomLightTargets Off) -< ()
|
||||
Event LightingOn -> do
|
||||
-- callService (activateSceneWith "scene.makuuhuone_lights_snapshot" transition) -< ()
|
||||
callServicesDyn (concatMap (uncurry toLight)) -< M.toList snap
|
||||
callServicesDyn (concatMap (uncurry toLight)) -< M.toList (getSnapshot snap)
|
||||
returnA -< ()
|
||||
Event LightingSleep -> do
|
||||
callService createBedroomScene -< ()
|
||||
callService (activateSceneWith "scene.makuuhuone_lepotila" transition) -< ()
|
||||
_ -> returnA -< ()
|
||||
where
|
||||
-- This is the meat of this change. To support transitioning the brightness, exactly,
|
||||
-- we need to do the brightness call separately and last
|
||||
toLight :: T.Text -> LightSnapshot -> [Service]
|
||||
toLight entityId LightSnapshot{observedOn=False} = [light [EntityId entityId] Off]
|
||||
toLight entityId LightSnapshot{observedOn=True, observedTemperature=t, observedBrightness=b} =
|
||||
[ light [EntityId entityId] (On def{lightColorTemperature=Just t})
|
||||
, light [EntityId entityId] (On def{lightTransition=Just 5, lightBrightness=Just (BrightnessAbsolute b)})
|
||||
toLight :: T.Text -> LightObservation -> [Service]
|
||||
toLight entityId LightObservation{observedOn=False} = [light [EntityId entityId] Off]
|
||||
toLight entityId LightObservation{observedOn=True, observedTemperature=t, observedBrightness=b} =
|
||||
[ light [EntityId entityId] (On def{lightTransition = Just 2, lightBrightness = Just (BrightnessAbsolute b), lightColorTemperature=Just t})
|
||||
-- , light [EntityId entityId] (On def{lightTransition = Just 2, lightBrightness=Just (BrightnessAbsolute b)})
|
||||
]
|
||||
doSnapshot = presenceLightEvents
|
||||
>>> arr (\ev -> if ev == Event LightingSleep then Event () else Tick)
|
||||
|
||||
@@ -2,7 +2,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module HomeAssistant.Controller.Light.Observation
|
||||
( LightSnapshot(..)
|
||||
( LightObservation(..)
|
||||
, observedLight
|
||||
, lightBrightnessEvent
|
||||
, lightTemperatureEvent
|
||||
@@ -37,17 +37,17 @@ lightTemperatureEvent entityId =
|
||||
where
|
||||
eventTemperature v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "color_temp_kelvin" . _Integral
|
||||
|
||||
data LightSnapshot = LightSnapshot
|
||||
data LightObservation = LightObservation
|
||||
{ observedOn :: Bool
|
||||
, observedBrightness :: Int
|
||||
, observedTemperature :: Int
|
||||
}
|
||||
deriving (Show, Generic, Eq)
|
||||
instance Serialize LightSnapshot
|
||||
instance Serialize LightObservation
|
||||
|
||||
observedLight :: T.Text -> HASS (Event Value) LightSnapshot
|
||||
observedLight :: T.Text -> HASS (Event Value) LightObservation
|
||||
observedLight entityId = proc ev -> do
|
||||
e <- hold False . entityBool entityId -< ev
|
||||
b <- hold 0 . lightBrightnessEvent entityId -< ev
|
||||
t <- hold 0 . lightTemperatureEvent entityId -< ev
|
||||
returnA -< LightSnapshot e b t
|
||||
returnA -< LightObservation e b t
|
||||
|
||||
@@ -4,46 +4,50 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module HomeAssistant.Runtime
|
||||
( defaultMain
|
||||
, step
|
||||
, CallIdGen
|
||||
, mkCallIdGen
|
||||
, dryRunHassEval
|
||||
, Controller(..)
|
||||
, runController
|
||||
) where
|
||||
( defaultMain,
|
||||
step,
|
||||
CallIdGen,
|
||||
mkCallIdGen,
|
||||
dryRunHassEval,
|
||||
Controller (..),
|
||||
runController,
|
||||
)
|
||||
where
|
||||
|
||||
import AFRP (Event (..), Mealy (..), Request (..), Auto, stepAutoSerializing, load, DecodedAuto (..))
|
||||
import AFRP (Auto, DecodedAuto (..), Event (..), Mealy (..), Request (..), load, stepAutoSerializing)
|
||||
import Control.Concurrent.STM (atomically, dupTChan, readTChan)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Data.Aeson (Value)
|
||||
import qualified Data.Text as T
|
||||
import Data.Foldable (forM_)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text qualified as T
|
||||
import Data.Time (getCurrentTime, getCurrentTimeZone)
|
||||
import Data.UUID (UUID, toText)
|
||||
import Data.UUID.V4 qualified as UUID.V4
|
||||
import Data.Void (Void)
|
||||
import GHC.Stack (HasCallStack)
|
||||
import HomeAssistant.Controller (HASS, HASSEff (..))
|
||||
import HomeAssistant.Controller.Bedroom (bedroomButtonController, bedroomDrawerController, bedroomPresenceController, humidifierController)
|
||||
import HomeAssistant.Controller.Children (childrenBedroomButtonController, schoolLightController)
|
||||
import HomeAssistant.Controller.Hallway (hallwayLightsController)
|
||||
import HomeAssistant.Controller.Kitchen (kitchenMotionController)
|
||||
import HomeAssistant.Controller.Livingroom (livingroomPlantLights, livingroomPresenceController)
|
||||
import HomeAssistant.Runtime.Bus
|
||||
import HomeAssistant.Runtime.Connection (readerAction, writerAction)
|
||||
import HomeAssistant.Runtime.Flags (loadFlags)
|
||||
import HomeAssistant.Runtime.Connection (writerAction, readerAction)
|
||||
import HomeAssistant.Runtime.Metrics qualified
|
||||
import HomeAssistant.Runtime.RateLimit (registerRateLimitMetrics, slidingWindowLimiter)
|
||||
import HomeAssistant.Runtime.Supervisor (supervised)
|
||||
import HttpServer qualified
|
||||
import Katip (KatipContext, Namespace (Namespace), Severity (..), logF, logLocM, ls, runKatipContextT, runKatipT, sl, katipAddNamespace)
|
||||
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 System.Metrics qualified
|
||||
import Text.Read (readMaybe)
|
||||
import HomeAssistant.Controller.Kitchen (kitchenMotionController)
|
||||
import HomeAssistant.Controller.Livingroom (livingroomPresenceController, livingroomPlantLights)
|
||||
import HomeAssistant.Runtime.RateLimit (slidingWindowLimiter, registerRateLimitMetrics)
|
||||
import UnliftIO.Async
|
||||
import HomeAssistant.Runtime.Supervisor (supervised)
|
||||
import HomeAssistant.Controller.Hallway (hallwayLightsController)
|
||||
import qualified HttpServer
|
||||
import Data.Foldable (forM_)
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import Control.Exception.Annotated (checkpoint, Annotation (..))
|
||||
|
||||
step :: (MonadIO m) => FilePath -> T.Text -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
|
||||
step path name trace st a = do
|
||||
@@ -56,73 +60,79 @@ data Controller = forall b. Controller T.Text (HASS (Event Value) b)
|
||||
|
||||
controllers :: [Controller]
|
||||
controllers =
|
||||
[ Controller "bedroom-presence" bedroomPresenceController
|
||||
, Controller "bedroom-button" bedroomButtonController
|
||||
, Controller "bedroom-drawer" bedroomDrawerController
|
||||
, Controller "bedroom-humidifier" humidifierController
|
||||
, Controller "school-light-controller" schoolLightController
|
||||
, Controller "kitchen-motion-controller" kitchenMotionController
|
||||
, Controller "livingroom-presence" livingroomPresenceController
|
||||
, Controller "hallway-motion-controller" hallwayLightsController
|
||||
, Controller "children-button" childrenBedroomButtonController
|
||||
, Controller "livingroom-plants" livingroomPlantLights
|
||||
[ Controller "bedroom-presence" bedroomPresenceController,
|
||||
Controller "bedroom-button" bedroomButtonController,
|
||||
Controller "bedroom-drawer" bedroomDrawerController,
|
||||
Controller "bedroom-humidifier" humidifierController,
|
||||
Controller "school-light-controller" schoolLightController,
|
||||
Controller "kitchen-motion-controller" kitchenMotionController,
|
||||
Controller "livingroom-presence" livingroomPresenceController,
|
||||
Controller "hallway-motion-controller" hallwayLightsController,
|
||||
Controller "children-button" childrenBedroomButtonController,
|
||||
Controller "livingroom-plants" livingroomPlantLights
|
||||
]
|
||||
|
||||
-- | 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 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)
|
||||
runController :: forall m. (HasCallStack, MonadCatch m, KatipContext m, MonadIO m) => FilePath -> Bus -> Controller -> m Void
|
||||
runController rootDir bus (Controller name machine) = checkpoint (Annotation name) $ katipAddNamespace ns $ do
|
||||
inbound <- liftIO $ atomically (dupTChan (busInbound bus))
|
||||
let workerDefinition = runMealy machine (channelHassEval @m bus)
|
||||
let path = rootDir </> T.unpack name
|
||||
worker <-
|
||||
load path workerDefinition >>= \case
|
||||
Decoded a -> pure a
|
||||
FailDecode err a -> a <$ logLocM WarningS (ls ("Failed to load (" <> T.unpack name <> "): " <> err))
|
||||
go path inbound worker
|
||||
where
|
||||
ns = Namespace [name]
|
||||
go path inbound f = do
|
||||
msg <- atomically (readTChan inbound)
|
||||
uuid <- UUID.V4.nextRandom
|
||||
msg <- liftIO $ atomically (readTChan inbound)
|
||||
uuid <- liftIO UUID.V4.nextRandom
|
||||
(_, next) <- step path name uuid f msg
|
||||
go path inbound next
|
||||
|
||||
lookupPort :: IO Int
|
||||
lookupPort :: (MonadFail m, MonadIO m) => m Int
|
||||
lookupPort = do
|
||||
m <- lookupEnv "HA_METRICS_PORT"
|
||||
m <- liftIO (lookupEnv "HA_METRICS_PORT")
|
||||
case m of
|
||||
Nothing -> pure 8124
|
||||
Just s -> case readMaybe s of
|
||||
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
|
||||
rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR"
|
||||
let allNames = map (\(Controller n _) -> n) controllers
|
||||
flags <- loadFlags rootPath allNames
|
||||
withBus severity appMetrics flags $ \bus -> do
|
||||
token <- getEnv "HA_TOKEN"
|
||||
host <- getEnv "HA_HOST"
|
||||
let rrdPath = rootPath </> "hass-controller.rrd"
|
||||
rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL"
|
||||
metricsPort <- lookupPort
|
||||
writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20
|
||||
let ents = foldMap (\(Controller _ m) -> entities m) controllers
|
||||
workers =
|
||||
[ ("reader", readerAction host 8123 token ents bus)
|
||||
, ("writer", writerAction writerLimiter bus)
|
||||
, ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)
|
||||
, ("metrics-http", HttpServer.runHttpServer (busLogEnv bus) rrdPath rrdtool (busFlags bus) metricsPort)
|
||||
] ++ [ (name, runController rootPath bus c) | c@(Controller name _) <- controllers ]
|
||||
runKatipContextT (busLogEnv bus) () mempty $
|
||||
mapConcurrently_ (uncurry supervised) workers
|
||||
defaultMain =
|
||||
withSocketsDo $
|
||||
getSeverity >>= \s -> withLogEnv s $ \le -> runKatipContextT le () mempty $ do
|
||||
logLocM InfoS "Hello world"
|
||||
store <- liftIO System.Metrics.newStore
|
||||
liftIO $ System.Metrics.registerGcMetrics store
|
||||
appMetrics <- liftIO $ HomeAssistant.Runtime.Metrics.registerAppMetrics store
|
||||
rateLimitMetrics <- registerRateLimitMetrics store
|
||||
rootPath <- fromMaybe "/tmp/" <$> liftIO (lookupEnv "HA_LIB_DIR")
|
||||
let allNames = map (\(Controller n _) -> n) controllers
|
||||
flags <- loadFlags rootPath allNames
|
||||
withBus le appMetrics flags $ \bus -> do
|
||||
token <- liftIO $ getEnv "HA_TOKEN"
|
||||
host <- liftIO $ getEnv "HA_HOST"
|
||||
let rrdPath = rootPath </> "hass-controller.rrd"
|
||||
rrdtool <- fromMaybe "rrdtool" <$> liftIO (lookupEnv "HA_RRDTOOL")
|
||||
metricsPort <- lookupPort
|
||||
writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20
|
||||
let ents = foldMap (\(Controller _ m) -> entities m) controllers
|
||||
workers =
|
||||
[ ("reader", readerAction host 8123 token ents bus),
|
||||
("writer", writerAction writerLimiter bus),
|
||||
("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool),
|
||||
("metrics-http", HttpServer.runHttpServer (busLogEnv bus) rrdPath rrdtool (busFlags bus) metricsPort)
|
||||
]
|
||||
++ [(name, runController rootPath bus c) | c@(Controller name _) <- controllers]
|
||||
runKatipContextT (busLogEnv bus) () mempty $
|
||||
mapConcurrently_ (uncurry supervised) workers
|
||||
where
|
||||
getSeverity = maybe InfoS (const DebugS) <$> lookupEnv "HA_DEBUG"
|
||||
|
||||
dryRunHassEval :: Namespace -> Bus -> HASSEff a -> IO a
|
||||
dryRunHassEval ns bus = \case
|
||||
|
||||
@@ -10,6 +10,7 @@ module HomeAssistant.Runtime.Bus
|
||||
, recordInbound
|
||||
, recordOutbound
|
||||
, channelHassEval
|
||||
, withLogEnv
|
||||
) where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
@@ -51,33 +52,36 @@ data Bus = Bus
|
||||
, busFlags :: Flags
|
||||
}
|
||||
|
||||
withBus :: Severity -> AppMetrics -> Flags -> (Bus -> IO a) -> IO a
|
||||
withBus severity metrics flags callback = do
|
||||
withLogEnv :: Severity -> (LogEnv -> IO a) -> IO a
|
||||
withLogEnv severity f = do
|
||||
let makeLogEnv = registerJournalScribe =<< registerHandleScribe =<< initLogEnv "hass-controller" "production"
|
||||
-- closeScribes will stop accepting new logs, flush existing ones and clean up resources
|
||||
bracket makeLogEnv closeScribes $ \le -> do
|
||||
bus <- Bus
|
||||
<$> newBroadcastTChanIO
|
||||
<*> newTChanIO
|
||||
<*> newTVarIO Nothing
|
||||
<*> mkCallIdGen 0
|
||||
<*> pure le
|
||||
<*> pure metrics
|
||||
<*> pure flags
|
||||
callback bus
|
||||
bracket makeLogEnv closeScribes $ \le -> f le
|
||||
where
|
||||
registerJournalScribe :: LogEnv -> IO LogEnv
|
||||
registerJournalScribe le = do
|
||||
journalScribe <- mkJournalScribe (permitItem severity) V2
|
||||
registerScribe "journalctl" journalScribe defaultScribeSettings le
|
||||
registerHandleScribe le = do
|
||||
systemdUnit <- isJust <$> lookupEnv "INVOCATION_ID"
|
||||
systemdUnit <- isJust <$> lookupEnv "HA_CONTROLLER_SYSTEMD"
|
||||
if systemdUnit
|
||||
then pure le -- ignore stdout when running in systemd
|
||||
else do
|
||||
handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem severity) V2
|
||||
registerScribe "stdout" handleScribe defaultScribeSettings le
|
||||
|
||||
withBus :: MonadIO m => LogEnv -> AppMetrics -> Flags -> (Bus -> m a) -> m a
|
||||
withBus le metrics flags callback = do
|
||||
bus <- Bus
|
||||
<$> liftIO newBroadcastTChanIO
|
||||
<*> liftIO newTChanIO
|
||||
<*> liftIO (newTVarIO Nothing)
|
||||
<*> liftIO (mkCallIdGen 0)
|
||||
<*> pure le
|
||||
<*> pure metrics
|
||||
<*> pure flags
|
||||
callback bus
|
||||
|
||||
recordInbound :: Bus -> IO ()
|
||||
recordInbound bus = inc (amTriggersIn (busMetrics bus))
|
||||
|
||||
|
||||
@@ -17,9 +17,7 @@ import Control.Concurrent.STM
|
||||
, writeTChan
|
||||
, writeTVar
|
||||
)
|
||||
import Control.Concurrent.Async (race)
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Exception (onException)
|
||||
import Control.Exception.Annotated (throw)
|
||||
import Control.Lens ((^?))
|
||||
import Control.Monad (forever, forM_, when)
|
||||
@@ -33,25 +31,28 @@ import HomeAssistant.Runtime.Bus
|
||||
import HomeAssistant.Runtime.Flags (isEnabled)
|
||||
import HomeAssistant.Runtime.Supervisor (Fatal (..))
|
||||
import qualified Network.WebSockets as WS
|
||||
import Katip (sl, logFM, Severity (..), ls, Namespace (Namespace), KatipContext, katipAddNamespace, katipAddContext)
|
||||
import Katip (sl, logFM, Severity (..), ls, Namespace (Namespace), KatipContext, katipAddNamespace, katipAddContext, logLocM)
|
||||
import Data.UUID (toText)
|
||||
import AFRP (Request(..), Event(..))
|
||||
import Control.Monad.IO.Class (liftIO, MonadIO)
|
||||
import HomeAssistant.Runtime.RateLimit (RateLimited, RateLimiter, runRateLimited)
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import GHC.Stack (HasCallStack)
|
||||
import UnliftIO (MonadUnliftIO, race, withRunInIO)
|
||||
import Control.Monad.Catch (onException)
|
||||
|
||||
-- | Connect, authenticate, subscribe, then receive and broadcast forever.
|
||||
-- Restarting this action reconnects. All setup sends happen before the
|
||||
-- connection is published in the bus, so only the writer sends afterwards.
|
||||
readerAction :: MonadIO m => String -> Int -> String -> S.Set T.Text -> Bus -> m Void
|
||||
readerAction host port token ents bus = liftIO $
|
||||
WS.runClient host port "/api/websocket" $ \conn -> do
|
||||
handshake conn token
|
||||
readerAction :: (MonadCatch m, HasCallStack, KatipContext m, MonadUnliftIO m, MonadIO m) => String -> Int -> String -> S.Set T.Text -> Bus -> m Void
|
||||
readerAction host port token ents bus = katipAddNamespace "receiver" $ withRunInIO $ \rio ->
|
||||
WS.runClient host port "/api/websocket" $ \conn -> rio $ do
|
||||
liftIO $ handshake conn token
|
||||
subscribe bus conn ents
|
||||
atomically $ writeTVar (busConn bus) (Just conn)
|
||||
putStrLn "[reader] connected"
|
||||
liftIO $ atomically $ writeTVar (busConn bus) (Just conn)
|
||||
logLocM InfoS "connected"
|
||||
-- Unpublish on exit so the writer blocks and the backlog survives the outage.
|
||||
receiveLoop bus conn `onException` atomically (writeTVar (busConn bus) Nothing)
|
||||
receiveLoop bus conn `onException` liftIO (atomically (writeTVar (busConn bus) Nothing))
|
||||
|
||||
handshake :: WS.Connection -> String -> IO ()
|
||||
handshake conn token = do
|
||||
@@ -73,12 +74,12 @@ expectType expected msg =
|
||||
isTriggerEvent :: Value -> Bool
|
||||
isTriggerEvent v = v ^? key "type" . _String == Just "event"
|
||||
|
||||
subscribe :: Bus -> WS.Connection -> S.Set T.Text -> IO ()
|
||||
subscribe :: HasCallStack => KatipContext m => Bus -> WS.Connection -> S.Set T.Text -> m ()
|
||||
subscribe bus conn ents =
|
||||
forM_ (S.toList ents) $ \entityId -> do
|
||||
print entityId
|
||||
sid <- generateCallId (busGen bus)
|
||||
WS.sendTextData conn $ encode $ object
|
||||
logLocM InfoS $ ls entityId
|
||||
sid <- liftIO $ generateCallId (busGen bus)
|
||||
liftIO $ WS.sendTextData conn $ encode $ object
|
||||
[ "id" .= sid
|
||||
, "type" .= ("subscribe_trigger" :: T.Text)
|
||||
, "trigger" .= object
|
||||
@@ -93,14 +94,14 @@ subscribe bus conn ents =
|
||||
-- Each read races a one-second timeout: a timeout broadcasts 'Tick' so
|
||||
-- time-based primitives (debounce, rollup, fixed, ...) keep advancing
|
||||
-- even when no state changes arrive.
|
||||
receiveLoop :: Bus -> WS.Connection -> IO Void
|
||||
receiveLoop :: (HasCallStack, MonadUnliftIO m, KatipContext m) => Bus -> WS.Connection -> m Void
|
||||
receiveLoop bus conn = forever $ do
|
||||
winner <- race (threadDelay 1_000_000) (WS.receiveData conn)
|
||||
winner <- race (liftIO $ threadDelay 1_000_000) (liftIO $ WS.receiveData conn)
|
||||
case winner of
|
||||
Left () -> atomically $ writeTChan (busInbound bus) Tick
|
||||
Left () -> liftIO $ atomically $ writeTChan (busInbound bus) Tick
|
||||
Right msg -> case eitherDecode msg of
|
||||
Left err -> putStrLn $ "[reader] skipping undecodable message: " <> err
|
||||
Right v -> do
|
||||
Left err -> logLocM WarningS $ ls $ "skipping undecodable message: " <> err
|
||||
Right v -> liftIO $ do
|
||||
when (isTriggerEvent v) (recordInbound bus)
|
||||
atomically $ writeTChan (busInbound bus) (Event v)
|
||||
|
||||
@@ -134,11 +135,11 @@ dispatchService
|
||||
=> RateLimiter -> Bus -> Request -> Service -> m ()
|
||||
dispatchService rateLimiter bus request svc = do
|
||||
enabled <- isEnabled (busFlags bus) (requestHandler request)
|
||||
if enabled
|
||||
then do
|
||||
conn <- liftIO $ atomically $ readTVar (busConn bus) >>= maybe retry pure
|
||||
runRateLimited rateLimiter $ sendWithId bus conn svc
|
||||
else logFM InfoS (ls $ "skipped disabled handler: " <> show svc)
|
||||
let logPrefix = if enabled then "Calling: " else "Skipping: "
|
||||
logFM InfoS (ls $ logPrefix <> show svc)
|
||||
when enabled $ do
|
||||
conn <- liftIO $ atomically $ readTVar (busConn bus) >>= maybe retry pure
|
||||
runRateLimited rateLimiter $ sendWithId bus conn svc
|
||||
|
||||
encodeService :: Int -> Service -> Value
|
||||
encodeService callId Service{..} = object $
|
||||
|
||||
@@ -12,7 +12,6 @@ module HomeAssistant.Runtime.Flags
|
||||
|
||||
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
|
||||
import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVarIO, stateTVar)
|
||||
import Control.Exception (IOException, handle)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import qualified Conduit as C
|
||||
import Conduit ((.|))
|
||||
@@ -24,8 +23,12 @@ import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import System.FilePath ((</>))
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import System.IO.Error (isDoesNotExistError)
|
||||
import GHC.Stack (HasCallStack)
|
||||
import Katip (KatipContext, logLocM, Severity (..), ls)
|
||||
import Control.Monad.Catch (MonadCatch, handle)
|
||||
import Control.Exception (IOException)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
type Name = Text
|
||||
|
||||
@@ -36,14 +39,14 @@ data Flags = Flags
|
||||
, flagsValidNames :: Set Text
|
||||
}
|
||||
|
||||
loadFlags :: MonadIO m => FilePath -> [Name] -> m Flags
|
||||
loadFlags rootPath allNames = liftIO $ do
|
||||
loadFlags :: (KatipContext m, MonadCatch m, MonadIO m) => FilePath -> [Name] -> m Flags
|
||||
loadFlags rootPath allNames = do
|
||||
let path = rootPath </> "handlers.json"
|
||||
fileMap <- readFlagsFile path
|
||||
let defaults = M.fromList [(n, True) | n <- allNames]
|
||||
initial = M.unionWith (\fileVal _default -> fileVal) fileMap defaults
|
||||
tv <- newTVarIO initial
|
||||
lock <- newMVar ()
|
||||
initial = M.unionWith (\fileVal -> const fileVal) fileMap defaults
|
||||
tv <- liftIO $ newTVarIO initial
|
||||
lock <- liftIO $ newMVar ()
|
||||
pure Flags
|
||||
{ flagsState = tv
|
||||
, flagsLock = lock
|
||||
@@ -51,21 +54,21 @@ loadFlags rootPath allNames = liftIO $ do
|
||||
, flagsValidNames = S.fromList allNames
|
||||
}
|
||||
|
||||
readFlagsFile :: FilePath -> IO (Map Name Bool)
|
||||
readFlagsFile :: forall m. (HasCallStack, KatipContext m, MonadCatch m) => FilePath -> m (Map Name Bool)
|
||||
readFlagsFile path =
|
||||
handle onMissingOrUnreadable $ do
|
||||
decoded <- decodeFileStrict' path
|
||||
decoded <- liftIO $ decodeFileStrict' path
|
||||
case decoded of
|
||||
Nothing -> do
|
||||
hPutStrLn stderr ("handlers.json is unparseable; treating all handlers as enabled: " <> path)
|
||||
logLocM WarningS $ ls ("handlers.json is unparseable; treating all handlers as enabled: " <> path)
|
||||
pure mempty
|
||||
Just m -> pure (maybe mempty id m)
|
||||
Just m -> pure (fromMaybe mempty m)
|
||||
where
|
||||
onMissingOrUnreadable :: IOException -> IO (Map Name Bool)
|
||||
onMissingOrUnreadable :: HasCallStack => IOException -> m (Map Name Bool)
|
||||
onMissingOrUnreadable e
|
||||
| isDoesNotExistError e = pure mempty
|
||||
| otherwise = do
|
||||
hPutStrLn stderr ("could not read handlers.json (" <> show e <> "); treating all handlers as enabled")
|
||||
logLocM WarningS $ ls ("could not read handlers.json (" <> show e <> "); treating all handlers as enabled")
|
||||
pure mempty
|
||||
|
||||
isEnabled :: MonadIO m => Flags -> Name -> m Bool
|
||||
|
||||
@@ -38,12 +38,13 @@ data RateLimiter = RateLimiter
|
||||
|
||||
|
||||
slidingWindowLimiter
|
||||
:: RateLimitMetrics
|
||||
:: MonadIO m
|
||||
=> RateLimitMetrics
|
||||
-> NominalDiffTime -- ^ Within how many seconds
|
||||
-> Int -- ^ How many requests we can make
|
||||
-> IO RateLimiter
|
||||
-> m RateLimiter
|
||||
slidingWindowLimiter metrics timeWindow size = do
|
||||
window <- newTVarIO []
|
||||
window <- liftIO $ newTVarIO []
|
||||
return $ RateLimiter metrics $ \(RateLimited action) -> do
|
||||
now <- liftIO getPOSIXTime
|
||||
allowed <- liftIO $ atomically $ do
|
||||
|
||||
Reference in New Issue
Block a user