66 lines
2.7 KiB
Haskell
66 lines
2.7 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module RuntimeSpec (spec) where
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Concurrent.Async (async, cancel, race, waitCatch)
|
|
import Control.Exception (bracket)
|
|
import Control.Monad (forever)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import HomeAssistant.Runtime.Supervisor (supervised)
|
|
import Katip (LogEnv, closeScribes, initLogEnv, runKatipContextT)
|
|
import Test.Hspec
|
|
|
|
spec :: Spec
|
|
spec = describe "supervised" $ do
|
|
it "propagates ThreadKilled instead of retrying" $
|
|
withTestLogEnv $ \le -> do
|
|
worker <- async $ runKatipContextT le () mempty $
|
|
supervised "test" (liftIO (forever (threadDelay 100000)))
|
|
threadDelay 200000
|
|
cancel worker
|
|
result <- race (threadDelay 5000000) (waitCatch worker)
|
|
case result of
|
|
Left () -> expectationFailure
|
|
"supervised retried on ThreadKilled (process would hang)"
|
|
Right _ -> pure ()
|
|
|
|
withTestLogEnv :: (LogEnv -> IO a) -> IO a
|
|
withTestLogEnv = bracket (initLogEnv "test" "test") closeScribes
|
|
|
|
-- I'm commenting out the test as that specific controller
|
|
-- was just a dummy for seeing how the data flows (dead code)
|
|
-- But leaving it commented as it retains some code sample on how and what to test
|
|
--
|
|
-- spec :: Spec
|
|
-- spec = describe "runController" $ do
|
|
-- it "feeds inbound events through the machine and forwards service calls" $ withBus severity appMetrics $ \bus -> do
|
|
-- _ <- async (runController bus (Controller "test" lightController True))
|
|
-- putStrLn "Before the delay"
|
|
-- threadDelay 100000 -- let the controller dup its inbound channel
|
|
-- putStrLn "After the delay"
|
|
-- atomically $ writeTChan (busInbound bus) (Event (doorEvent "on")) -- initial value: no change event
|
|
-- atomically $ writeTChan (busInbound bus) (Event (doorEvent "off")) -- door closes: lights on
|
|
-- atomically $ writeTChan (busInbound bus) (Event (doorEvent "on")) -- door opens: lights off
|
|
-- putStrLn "After the writes"
|
|
-- Right (_, svc1) <- boundedRead (busOutbound bus)
|
|
-- Right (_, svc2) <- boundedRead (busOutbound bus)
|
|
-- putStrLn "After the reads"
|
|
-- svc1 `shouldBe` light [EntityId "light.bedroom_masse"] True
|
|
-- svc2 `shouldBe` light [EntityId "light.bedroom_masse"] False
|
|
-- atomically (isEmptyTChan (busOutbound bus)) `shouldReturn` True
|
|
-- where
|
|
-- boundedRead channel = race (threadDelay 10000) (atomically (readTChan channel))
|
|
--
|
|
-- doorEvent :: Text -> Value
|
|
-- doorEvent state = object
|
|
-- [ "event" .= object
|
|
-- [ "variables" .= object
|
|
-- [ "trigger" .= object
|
|
-- [ "entity_id" .= ("binary_sensor.makuuhuone_ovi_contact" :: Text)
|
|
-- , "to_state" .= object ["state" .= state]
|
|
-- ]
|
|
-- ]
|
|
-- ]
|
|
-- ]
|