Add requestHandler field to Request

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
+  { requestTime     :: !UTCTime
-  , requestTimeZone :: !TimeZone
+  , requestTimeZone  :: !TimeZone
-  , requestTraceId :: !UUID
+  , requestTraceId  :: !UUID
+  , requestHandler  :: !T.Text
   } deriving (Show, Eq)
 
 

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 :: (MonadIO m) => FilePath -> T.Text -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
-step path trace st a = do
+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

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).

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)

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

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)