diff --git a/src/HomeAssistant/Runtime/Bus.hs b/src/HomeAssistant/Runtime/Bus.hs index db8b597..bb5ead5 100644 --- a/src/HomeAssistant/Runtime/Bus.hs +++ b/src/HomeAssistant/Runtime/Bus.hs @@ -23,7 +23,7 @@ import HomeAssistant.Controller (HASSEff (..), Service) import Network.WebSockets (Connection) -- | Shared runtime state: inbound is a broadcast channel (controllers --- read from 'dupTChanIO' copies), outbound queues service calls for the +-- read from 'dupTChan' copies), outbound queues service calls for the -- writer, conn holds the current websocket (Nothing before first connect). data Bus = Bus { busInbound :: TChan Value diff --git a/src/HomeAssistant/Runtime/Connection.hs b/src/HomeAssistant/Runtime/Connection.hs index 1c85500..b6aed1a 100644 --- a/src/HomeAssistant/Runtime/Connection.hs +++ b/src/HomeAssistant/Runtime/Connection.hs @@ -15,6 +15,7 @@ import Control.Concurrent.STM , writeTChan , writeTVar ) +import Control.Exception (onException) import Control.Exception.Annotated (throw) import Control.Lens ((^?)) import Control.Monad (forever) @@ -38,7 +39,8 @@ readerAction host port token bus = subscribe bus conn atomically $ writeTVar (busConn bus) (Just conn) putStrLn "[reader] connected" - receiveLoop bus conn + -- Unpublish on exit so the writer blocks and the backlog survives the outage. + receiveLoop bus conn `onException` atomically (writeTVar (busConn bus) Nothing) handshake :: WS.Connection -> String -> IO () handshake conn token = do diff --git a/src/HomeAssistant/Runtime/Supervisor.hs b/src/HomeAssistant/Runtime/Supervisor.hs index 756f390..a8e7454 100644 --- a/src/HomeAssistant/Runtime/Supervisor.hs +++ b/src/HomeAssistant/Runtime/Supervisor.hs @@ -42,7 +42,7 @@ defaultBackoff = Backoff 0.1 30 30 -- | Delay before the @attempt@-th restart: doubles from base, clamped at cap. backoffDelay :: Backoff -> Int -> NominalDiffTime -backoffDelay (Backoff base cap _) attempt = go (attempt - 1) base +backoffDelay (Backoff base cap _) attempt = go (max 0 (attempt - 1)) base where go 0 d = d go n d = go (n - 1) (min cap (d * 2)) @@ -68,13 +68,13 @@ supervised name backoff action = go 1 [ Handler $ \(f :: Fatal) -> pure (Just (Left f)) , Handler $ \(e :: SomeException) -> pure (Just (Right e)) ] + end <- getCurrentTime case outcome of Nothing -> error "unreachable: supervised action returned" Just (Left f) -> throw f Just (Right e) -> do putStrLn $ "[" <> T.unpack name <> "] attempt " <> show attempt <> " crashed: " <> displayException e let delay = backoffDelay backoff attempt - putStrLn $ "[" <> T.unpack name <> "] restarting in " <> show delay <> "s" + putStrLn $ "[" <> T.unpack name <> "] restarting in " <> show delay threadDelay (round (realToFrac delay * 1000000 :: Double)) - end <- getCurrentTime go (nextAttempt backoff (diffUTCTime end start) attempt) diff --git a/test/RuntimeSpec.hs b/test/RuntimeSpec.hs index 03ccbc5..9e30744 100644 --- a/test/RuntimeSpec.hs +++ b/test/RuntimeSpec.hs @@ -3,7 +3,7 @@ module RuntimeSpec (spec) where import Control.Concurrent (threadDelay) import Control.Concurrent.Async (async) -import Control.Concurrent.STM (atomically, readTChan, writeTChan) +import Control.Concurrent.STM (atomically, isEmptyTChan, readTChan, writeTChan) import Data.Aeson (Value, object, (.=)) import Data.Text (Text) import HomeAssistant.Controller (light, lightController) @@ -24,6 +24,7 @@ spec = describe "runController" $ do svc2 <- atomically (readTChan (busOutbound bus)) svc1 `shouldBe` light True svc2 `shouldBe` light False + atomically (isEmptyTChan (busOutbound bus)) `shouldReturn` True doorEvent :: Text -> Value doorEvent state = object