runtime: start the metrics graph server worker

src/HomeAssistant/Runtime.hs

@@ -36,7 +36,9 @@ import HomeAssistant.Controller.Children (schoolLightController)
 import Data.Maybe (fromMaybe)
 import qualified System.Metrics
 import qualified HomeAssistant.Runtime.Metrics
+import qualified HomeAssistant.Runtime.Graphing
 import System.FilePath ((</>))
+import Text.Read (readMaybe)
 import HomeAssistant.Controller.Kitchen (kitchenMotionController)
 
 step :: (MonadIO m) => FilePath -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
@@ -79,6 +81,13 @@ runController rootDir bus (Controller name machine _enabled) = do
       (_, 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  -> maybe (fail ("HA_METRICS_PORT is not a number: " <> s)) pure (readMaybe s)
+
 defaultMain :: IO ()
 defaultMain = withSocketsDo $ do
   severity <- maybe InfoS (const DebugS) <$> lookupEnv "HA_DEBUG"
@@ -91,13 +100,16 @@ defaultMain = withSocketsDo $ do
     rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR"
     rrdPath <- fromMaybe "hass-controller.rrd" <$> lookupEnv "HA_RRD_PATH"
     rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL"
+    metricsPort <- lookupPort
     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)]
+            ++ [ ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)
+               , ("metrics-http", HomeAssistant.Runtime.Graphing.graphAction rrdPath rrdtool metricsPort)
+               ]
     as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers
     (_, v) <- waitAny as
     absurd v