Add Flags module for runtime handler toggling

src/HomeAssistant/Runtime/Flags.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module HomeAssistant.Runtime.Flags
+  ( Name
+  , Flags(..)
+  , loadFlags
+  , isEnabled
+  , setEnabled
+  , allFlags
+  , validNames
+  ) where
+
+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 ((.|))
+import Data.Aeson (decodeFileStrict', encode)
+import qualified Data.ByteString.Lazy as BL
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import System.FilePath ((</>))
+import System.IO.Error (isDoesNotExistError)
+
+type Name = Text
+
+data Flags = Flags
+  { flagsState     :: TVar (Map Name Bool)
+  , flagsLock      :: MVar ()
+  , flagsPath      :: FilePath
+  , flagsValidNames :: Set Text
+  }
+
+loadFlags :: MonadIO m => FilePath -> [Name] -> m Flags
+loadFlags rootPath allNames = liftIO $ 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 ()
+  pure Flags
+    { flagsState = tv
+    , flagsLock = lock
+    , flagsPath = path
+    , flagsValidNames = S.fromList allNames
+    }
+
+readFlagsFile :: FilePath -> IO (Map Name Bool)
+readFlagsFile path =
+  handle onMissingOrUnreadable $ do
+    decoded <- decodeFileStrict' path
+    case decoded of
+      Nothing -> do
+        putStrLn ("handlers.json is unparseable; treating all handlers as enabled: " <> path)
+        pure mempty
+      Just m -> pure (maybe mempty id m)
+  where
+    onMissingOrUnreadable :: IOException -> IO (Map Name Bool)
+    onMissingOrUnreadable e
+      | isDoesNotExistError e = pure mempty
+      | otherwise = do
+          putStrLn ("could not read handlers.json (" <> show e <> "); treating all handlers as enabled")
+          pure mempty
+
+isEnabled :: MonadIO m => Flags -> Name -> m Bool
+isEnabled flags name = liftIO $
+  M.findWithDefault True name <$> readTVarIO (flagsState flags)
+
+allFlags :: MonadIO m => Flags -> m (Map Name Bool)
+allFlags flags = liftIO $ readTVarIO (flagsState flags)
+
+setEnabled :: MonadIO m => Flags -> Name -> Bool -> m ()
+setEnabled Flags{flagsState, flagsLock, flagsPath} name val =
+  liftIO $ withMVar flagsLock $ \_ -> do
+    m <- atomically $ stateTVar flagsState $ \cur ->
+      let next = M.insert name val cur in (next, next)
+    safeWrite flagsPath m
+
+validNames :: Flags -> Set Text
+validNames = flagsValidNames
+
+safeWrite :: FilePath -> Map Name Bool -> IO ()
+safeWrite path m = C.runResourceT $ C.runConduit $
+  C.yieldMany [BL.toStrict (encode m)] .| C.sinkFileCautious path