Add REST endpoints for handler flags

src/HomeAssistant/Runtime.hs

@@ -119,7 +119,7 @@ defaultMain = withSocketsDo $ do
           [ ("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 metricsPort)
+          , ("metrics-http", HttpServer.runHttpServer (busLogEnv bus) rrdPath rrdtool (busFlags bus) metricsPort)
           ] ++ [ (name, runController rootPath bus c) | c@(Controller True name _) <- active ]
     runKatipContextT (busLogEnv bus) () mempty $
       mapConcurrently_ (uncurry supervised) workers

src/HttpServer.hs

@@ -7,13 +7,17 @@ import Control.Monad.IO.Class (liftIO, MonadIO)
 import qualified Data.ByteString as BS
 import Data.Void (Void)
 import Network.Wai.Handler.Warp (run)
-import Servant.API ((:>), Capture, Get, QueryParam, (:-), MimeRender (..), Accept (..), NamedRoutes)
+import Servant.API ((:>), Capture, Get, QueryParam, (:-), MimeRender (..), Accept (..), NamedRoutes, JSON, ReqBody, Put)
 import Data.ByteString (ByteString)
 import GHC.Generics (Generic)
 import Servant (Handler, err404)
 import Control.Monad.Catch (throwM, MonadCatch, MonadThrow)
 import Servant.Server (err500, ServerT)
 import Data.Maybe (fromMaybe)
+import Data.Map.Strict (Map)
+import qualified Data.Set as S
+import Data.Text (Text)
+import HomeAssistant.Runtime.Flags (Flags, allFlags, setEnabled, validNames)
 import Control.Exception.Annotated (checkpoint, Annotation (Annotation))
 import Servant.Server.Generic (genericServeT)
 import Network.Wai (Application)
@@ -30,12 +34,25 @@ instance Accept ImagePng where
   contentType _ = "image" // "png"
 
 
-newtype API mode = API
+data API mode = API
   { getMetrics :: mode :- "metrics" :> Capture "graph" Graph :> QueryParam "range" Range :> Get '[ImagePng] ByteString
+  , getFlags   :: mode :- "flags" :> Get '[JSON] (Map Text Bool)
+  , putFlag    :: mode :- "flags" :> Capture "name" Text :> ReqBody '[JSON] Bool :> Put '[JSON] (Map Text Bool)
   }
   deriving Generic
 
 
+getFlagsHandler :: Flags -> LoggingHandler (Map Text Bool)
+getFlagsHandler flags = allFlags flags
+
+putFlagHandler :: Flags -> Text -> Bool -> LoggingHandler (Map Text Bool)
+putFlagHandler flags name val
+  | name `S.notMember` validNames flags = throwM err404
+  | otherwise = do
+      setEnabled flags name val
+      allFlags flags
+
+
 getMetricsHandler :: FilePath -> FilePath -> Graph -> Maybe Range -> LoggingHandler ByteString
 getMetricsHandler rrdPath rrdtool graphMode mRange = checkpoint (Annotation (graphMode, mRange)) $ do
   case lookupGraph graphs graphMode of
@@ -46,14 +63,18 @@ getMetricsHandler rrdPath rrdtool graphMode mRange = checkpoint (Annotation (gra
       either (\e -> logFM ErrorS (ls e) >> throwM err500) pure g
 
 -- server :: FilePath -> FilePath -> API AsServer
-server :: FilePath -> FilePath -> ServerT (NamedRoutes API) LoggingHandler
-server rrdPath rrdtool = API { getMetrics = getMetricsHandler rrdPath rrdtool }
+server :: FilePath -> FilePath -> Flags -> ServerT (NamedRoutes API) LoggingHandler
+server rrdPath rrdtool flags = API
+  { getMetrics = getMetricsHandler rrdPath rrdtool
+  , getFlags   = getFlagsHandler flags
+  , putFlag    = putFlagHandler flags
+  }
 
-servantApp :: LogEnv -> FilePath -> FilePath -> Application
-servantApp le rrdPath rrdtool = genericServeT (toHandler le) (server rrdPath rrdtool)
+servantApp :: LogEnv -> FilePath -> FilePath -> Flags -> Application
+servantApp le rrdPath rrdtool flags = genericServeT (toHandler le) (server rrdPath rrdtool flags)
 
-runHttpServer :: MonadIO m => LogEnv -> FilePath -> FilePath -> Int -> m Void
-runHttpServer le rrdPath rrdtool port = liftIO $ forever $ run port (servantApp le rrdPath rrdtool)
+runHttpServer :: MonadIO m => LogEnv -> FilePath -> FilePath -> Flags -> Int -> m Void
+runHttpServer le rrdPath rrdtool flags port = liftIO $ forever $ run port (servantApp le rrdPath rrdtool flags)
 
 newtype LoggingHandler a = LoggingHandler (KatipContextT Handler a)
   deriving (Functor, Applicative, Monad, MonadIO, Katip, KatipContext, MonadCatch, MonadThrow) via (KatipContextT Handler)