diff --git a/src/AFRP.hs b/src/AFRP.hs index e3855e7..3a0bbba 100644 --- a/src/AFRP.hs +++ b/src/AFRP.hs @@ -103,9 +103,10 @@ mergeCodec (Codec agetter aputter) (Codec bgetter bputter) = Codec (mergeGet age data Pair a b = Pair !a !b data Request = Request - { requestTime :: !UTCTime - , requestTimeZone :: !TimeZone - , requestTraceId :: !UUID + { requestTime :: !UTCTime + , requestTimeZone :: !TimeZone + , requestTraceId :: !UUID + , requestHandler :: !T.Text } deriving (Show, Eq) diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 891ec51..ea940ae 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -43,11 +43,11 @@ import HomeAssistant.Runtime.Supervisor (supervised) import HomeAssistant.Controller.Hallway (hallwayLightsController) import qualified HttpServer -step :: (MonadIO m) => FilePath -> UUID -> Auto m a b -> a -> m (b, Auto m a b) -step path trace st a = do +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 now <- liftIO getCurrentTime tz <- liftIO getCurrentTimeZone - let req = Request now tz trace + let req = Request now tz trace name stepAutoSerializing path st req a data Controller = forall b. Controller Bool T.Text (HASS (Event Value) b) @@ -83,7 +83,7 @@ runController rootDir bus (Controller _enabled name machine ) = liftIO $ do go path inbound f = do msg <- atomically (readTChan inbound) uuid <- UUID.V4.nextRandom - (_, next) <- step path uuid f msg + (_, next) <- step path name uuid f msg go path inbound next lookupPort :: IO Int diff --git a/test/AFRPSpec.hs b/test/AFRPSpec.hs index c47c463..f201dc3 100644 --- a/test/AFRPSpec.hs +++ b/test/AFRPSpec.hs @@ -21,7 +21,7 @@ import Test.Hspec import Test.Hspec.Hedgehog fakeRequest :: Request -fakeRequest = Request (sec 0) utc nil +fakeRequest = Request (sec 0) utc nil "test" sec :: Integer -> UTCTime sec n = UTCTime (toEnum 0) (fromIntegral n) @@ -42,7 +42,7 @@ runTimed m = go (runMealy m id) where go _ [] = [] go w ((s, a) : as) = - case runIdentity (stepAuto w (Request (sec s) utc nil) a) of + case runIdentity (stepAuto w (Request (sec s) utc nil "test") a) of (b, w') -> b : go w' as -- | A minimal State monad for observing effectful arrows (e.g. whenA gating). diff --git a/test/BusSpec.hs b/test/BusSpec.hs index a8c37d8..3bc50c6 100644 --- a/test/BusSpec.hs +++ b/test/BusSpec.hs @@ -33,7 +33,7 @@ spec = describe "Bus" $ do r2 `shouldBe` (Event (Number 1), Event (Number 2)) it "channelHassEval writes CallService to the outbound channel" $ withTestBus $ \bus -> do - let req = Request (UTCTime (toEnum 0) 0) utc nil + let req = Request (UTCTime (toEnum 0) 0) utc nil "test" svc = Service "light" "turn_on" Nothing [EntityId "light.bedroom_masse"] runKatipContextT (busLogEnv bus) () (Namespace ["test"]) $ channelHassEval bus (CallService req svc) diff --git a/test/ConnectionSpec.hs b/test/ConnectionSpec.hs index 733fb36..f4c30a0 100644 --- a/test/ConnectionSpec.hs +++ b/test/ConnectionSpec.hs @@ -47,7 +47,7 @@ spec = do req :: Int -> Request req n = Request (UTCTime (toEnum 0) (fromIntegral (0 :: Int))) utc - (fromJust (fromString uuid)) + (fromJust (fromString uuid)) "test" where pad i = replicate (12 - length (show i)) '0' <> show i uuid = "00000000-0000-0000-0000-" <> pad n diff --git a/test/Support.hs b/test/Support.hs index ff09e2b..781652c 100644 --- a/test/Support.hs +++ b/test/Support.hs @@ -20,7 +20,7 @@ import AFRP (Mealy (..), Request (..), stepAuto) import HomeAssistant.Controller (HASSEff (..), Service) fakeRequest :: Request -fakeRequest = Request (sec 0) utc nil +fakeRequest = Request (sec 0) utc nil "test" sec :: Integer -> UTCTime sec n = UTCTime (toEnum 0) (fromIntegral n)