Add Flags module for runtime handler toggling

test/FlagsSpec.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module FlagsSpec (spec) where
+
+import Control.Concurrent.Async (mapConcurrently_)
+import Control.Monad.IO.Class (liftIO)
+import Data.Aeson (decodeFileStrict)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import System.IO.Temp (withTempDirectory)
+import Test.Hspec
+import Test.Hspec.Hedgehog
+
+import HomeAssistant.Runtime.Flags
+
+spec :: Spec
+spec = describe "Flags" $ do
+  describe "loadFlags" $ do
+    it "defaults all names to True when the file is missing (opt-out)" $
+      withTempDirectory "/tmp" "flags-spec" $ \dir -> do
+        flags <- loadFlags dir ["a", "b"]
+        m <- allFlags flags
+        m `shouldBe` M.fromList [("a" :: Text, True), ("b", True)]
+
+    it "lets the file override the True default, missing keys stay True" $
+      withTempDirectory "/tmp" "flags-spec" $ \dir -> do
+        let path = dir <> "/handlers.json"
+        writeFile path "{\"b\": false}"
+        flags <- loadFlags dir ["a", "b"]
+        m <- allFlags flags
+        m `shouldBe` M.fromList [("a" :: Text, True), ("b" :: Text, False)]
+
+    it "treats a corrupt file as empty (all-enabled) without throwing" $
+      withTempDirectory "/tmp" "flags-spec" $ \dir -> do
+        let path = dir <> "/handlers.json"
+        writeFile path "not json at all"
+        flags <- loadFlags dir ["a"]
+        m <- allFlags flags
+        m `shouldBe` M.fromList [("a" :: Text, True)]
+
+  describe "isEnabled" $ do
+    it "returns the stored value" $
+      withTempDirectory "/tmp" "flags-spec" $ \dir -> do
+        let path = dir <> "/handlers.json"
+        writeFile path "{\"a\": false}"
+        flags <- loadFlags dir ["a"]
+        isEnabled flags "a" `shouldReturn` False
+
+    it "defaults unknown names to True" $
+      withTempDirectory "/tmp" "flags-spec" $ \dir -> do
+        flags <- loadFlags dir []
+        isEnabled flags "unknown" `shouldReturn` True
+
+  describe "setEnabled" $ do
+    it "updates the in-memory map and persists to disk" $
+      withTempDirectory "/tmp" "flags-spec" $ \dir -> do
+        flags <- loadFlags dir ["a"]
+        setEnabled flags "a" False
+        isEnabled flags "a" `shouldReturn` False
+        -- reload from disk to confirm persistence
+        flags' <- loadFlags dir ["a"]
+        isEnabled flags' "a" `shouldReturn` False
+
+    it "concurrent writes leave the file consistent with the TVar" $
+      hedgehog $ do
+        n <- forAll $ Gen.int (Range.linear 1 50)
+        liftIO $ withTempDirectory "/tmp" "flags-spec" $ \dir -> do
+          flags <- loadFlags dir ["x"]
+          mapConcurrently_ (\i -> setEnabled flags "x" (even i)) [1 .. n]
+          m <- allFlags flags
+          decoded <- decodeFileStrict (dir <> "/handlers.json")
+          (decoded :: Maybe (Map Text Bool)) `shouldBe` Just m

test/Main.hs

@@ -6,6 +6,7 @@ import qualified AFRPSpec
 import qualified BedroomSpec
 import qualified BusSpec
 import qualified ConnectionSpec
+import qualified FlagsSpec
 import qualified GraphingSpec
 import qualified MetricsSpec
 import qualified RuntimeSpec
@@ -17,6 +18,7 @@ main = hspec $ do
   BedroomSpec.spec
   BusSpec.spec
   ConnectionSpec.spec
+  FlagsSpec.spec
   GraphingSpec.spec
   MetricsSpec.spec
   RuntimeSpec.spec