diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Changelog +## 0.2.0.11 — 2026-10-26 + +### Other Changes + +- Support `kiroku-store ^>=0.12.0.0` while retaining `^>=0.11.0.0` compatibility + in library and test dependencies. The CLI API and runtime behavior are unchanged. + ## 0.2.0.10 — 2026-10-11 ### Other Changes diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -11,16 +11,16 @@ main :: IO () main = do - opts <- execParser standaloneParserInfo - env <- getEnvironment - case resolveStandaloneOptions env opts of - Left err -> do - TIO.hPutStrLn stderr err - exitFailure - Right runtime -> do - result <- try (runStandaloneCommand runtime) - case result of - Left (err :: SomeException) -> do - TIO.hPutStrLn stderr ("kiroku: " <> T.pack (show err)) - exitFailure - Right output -> TIO.putStrLn output + opts <- execParser standaloneParserInfo + env <- getEnvironment + case resolveStandaloneOptions env opts of + Left err -> do + TIO.hPutStrLn stderr err + exitFailure + Right runtime -> do + result <- try (runStandaloneCommand runtime) + case result of + Left (err :: SomeException) -> do + TIO.hPutStrLn stderr ("kiroku: " <> T.pack (show err)) + exitFailure + Right output -> TIO.putStrLn output diff --git a/kiroku-cli.cabal b/kiroku-cli.cabal --- a/kiroku-cli.cabal +++ b/kiroku-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: kiroku-cli -version: 0.2.0.10 +version: 0.2.0.11 synopsis: Embeddable operator CLI for Kiroku description: Parser, runner, and executable entry points for Kiroku operator commands. @@ -50,7 +50,7 @@ , http-client >=0.7 && <0.8 , http-client-tls >=0.3 && <0.4 , http-types >=0.12 && <0.13 - , kiroku-store ^>=0.11.0.0 + , kiroku-store ^>=0.11.0.0 || ^>=0.12.0.0 , lens >=5.2 && <5.4 , optparse-applicative >=0.19 && <0.20 , text >=2.0 && <2.2 @@ -83,7 +83,7 @@ , http-client >=0.7 && <0.8 , http-client-tls >=0.3 && <0.4 , kiroku-cli - , kiroku-store ^>=0.11.0.0 + , kiroku-store ^>=0.11.0.0 || ^>=0.12.0.0 , kiroku-test-support , lens , optparse-applicative diff --git a/src/Kiroku/Cli.hs b/src/Kiroku/Cli.hs --- a/src/Kiroku/Cli.hs +++ b/src/Kiroku/Cli.hs @@ -1,12 +1,13 @@ -module Kiroku.Cli ( - KirokuCommand (..), +module Kiroku.Cli + ( KirokuCommand (..), kirokuCommandParser, kirokuParserInfo, kirokuSubparser, runKirokuCommand, runKirokuCommandWithStore, renderKirokuCommandWithStore, -) where + ) +where import Kiroku.Cli.Command (KirokuCommand (..)) import Kiroku.Cli.Parser (kirokuCommandParser, kirokuParserInfo, kirokuSubparser) diff --git a/src/Kiroku/Cli/Command.hs b/src/Kiroku/Cli/Command.hs --- a/src/Kiroku/Cli/Command.hs +++ b/src/Kiroku/Cli/Command.hs @@ -1,38 +1,37 @@ -module Kiroku.Cli.Command ( - KirokuCommand (..), +module Kiroku.Cli.Command + ( KirokuCommand (..), OutputFormat (..), RemoteEndpoint (..), StatusOptions (..), SubscriptionCommand (..), -) where + ) +where import Data.Text (Text) data KirokuCommand - = KirokuNoCommand - | KirokuSubscriptions SubscriptionCommand - deriving stock (Eq, Show) + = KirokuNoCommand + | KirokuSubscriptions SubscriptionCommand + deriving stock (Eq, Show) data SubscriptionCommand - = SubscriptionStatus StatusOptions - deriving stock (Eq, Show) + = SubscriptionStatus StatusOptions + deriving stock (Eq, Show) -{- | The base URL of a running worker's @kiroku-metrics@ server (e.g. -@http://worker:9091@), used to query its @\/subscriptions@ endpoint. --} +-- | The base URL of a running worker's @kiroku-metrics@ server (e.g. +-- @http://worker:9091@), used to query its @\/subscriptions@ endpoint. newtype RemoteEndpoint = RemoteEndpoint Text - deriving stock (Eq, Show) + deriving stock (Eq, Show) data StatusOptions = StatusOptions - { outputFormat :: !OutputFormat - , endpoint :: !(Maybe RemoteEndpoint) - {- ^ 'Nothing' = read the in-process registry (embeddable library); 'Just' = - query a remote worker over HTTP. - -} - } - deriving stock (Eq, Show) + { outputFormat :: !OutputFormat, + -- | 'Nothing' = read the in-process registry (embeddable library); 'Just' = + -- query a remote worker over HTTP. + endpoint :: !(Maybe RemoteEndpoint) + } + deriving stock (Eq, Show) data OutputFormat - = OutputTable - | OutputJson - deriving stock (Eq, Show) + = OutputTable + | OutputJson + deriving stock (Eq, Show) diff --git a/src/Kiroku/Cli/Parser.hs b/src/Kiroku/Cli/Parser.hs --- a/src/Kiroku/Cli/Parser.hs +++ b/src/Kiroku/Cli/Parser.hs @@ -1,15 +1,16 @@ -module Kiroku.Cli.Parser ( - kirokuCommandParser, +module Kiroku.Cli.Parser + ( kirokuCommandParser, kirokuParserInfo, kirokuSubparser, -) where + ) +where import Control.Applicative (optional) import Data.Text qualified as T import Kiroku.Cli.Command (KirokuCommand (..)) import Kiroku.Cli.Command qualified as Command -import Options.Applicative ( - CommandFields, +import Options.Applicative + ( CommandFields, Mod, Parser, ParserInfo, @@ -28,53 +29,53 @@ subparser, value, (<**>), - ) + ) kirokuCommandParser :: Parser KirokuCommand kirokuCommandParser = - maybe KirokuNoCommand id - <$> optional - ( subparser - ( command - "subscriptions" - ( info - (KirokuSubscriptions <$> subscriptionCommandParser) - (fullDesc <> progDesc "Inspect live subscriptions in this process's KirokuStore registry.") - ) - ) - ) + maybe KirokuNoCommand id + <$> optional + ( subparser + ( command + "subscriptions" + ( info + (KirokuSubscriptions <$> subscriptionCommandParser) + (fullDesc <> progDesc "Inspect live subscriptions in this process's KirokuStore registry.") + ) + ) + ) subscriptionCommandParser :: Parser Command.SubscriptionCommand subscriptionCommandParser = - subparser - ( command - "status" - ( info - (Command.SubscriptionStatus <$> statusOptionsParser <**> helper) - (fullDesc <> progDesc "List live subscription phases and global cursor positions.") - ) + subparser + ( command + "status" + ( info + (Command.SubscriptionStatus <$> statusOptionsParser <**> helper) + (fullDesc <> progDesc "List live subscription phases and global cursor positions.") ) + ) statusOptionsParser :: Parser Command.StatusOptions statusOptionsParser = - Command.StatusOptions - <$> option - (eitherReader parseOutputFormat) - ( long "format" - <> metavar "table|json" - <> value Command.OutputTable - <> help "Render as a human table or script-friendly JSON." - ) - <*> optional - ( Command.RemoteEndpoint . T.pack - <$> strOption - ( long "remote-url" - <> metavar "URL" - <> help - "Query a running worker's kiroku-metrics /subscriptions endpoint \ - \(e.g. http://worker:9091) instead of this process's local registry." - ) + Command.StatusOptions + <$> option + (eitherReader parseOutputFormat) + ( long "format" + <> metavar "table|json" + <> value Command.OutputTable + <> help "Render as a human table or script-friendly JSON." + ) + <*> optional + ( Command.RemoteEndpoint . T.pack + <$> strOption + ( long "remote-url" + <> metavar "URL" + <> help + "Query a running worker's kiroku-metrics /subscriptions endpoint \ + \(e.g. http://worker:9091) instead of this process's local registry." ) + ) parseOutputFormat :: String -> Either String Command.OutputFormat parseOutputFormat "table" = Right Command.OutputTable @@ -83,20 +84,20 @@ kirokuParserInfo :: ParserInfo KirokuCommand kirokuParserInfo = - info - (kirokuCommandParser <**> helper) - ( fullDesc - <> progDesc "Run Kiroku operator commands." - <> header "kiroku - operator commands for Kiroku event stores" - ) + info + (kirokuCommandParser <**> helper) + ( fullDesc + <> progDesc "Run Kiroku operator commands." + <> header "kiroku - operator commands for Kiroku event stores" + ) kirokuSubparser :: (KirokuCommand -> command) -> Mod CommandFields command kirokuSubparser wrap = - command - "kiroku" - ( info - (wrap <$> kirokuCommandParser <**> helper) - ( fullDesc - <> progDesc "Run Kiroku operator commands." - ) + command + "kiroku" + ( info + (wrap <$> kirokuCommandParser <**> helper) + ( fullDesc + <> progDesc "Run Kiroku operator commands." ) + ) diff --git a/src/Kiroku/Cli/Run.hs b/src/Kiroku/Cli/Run.hs --- a/src/Kiroku/Cli/Run.hs +++ b/src/Kiroku/Cli/Run.hs @@ -1,38 +1,39 @@ -module Kiroku.Cli.Run ( - runKirokuCommand, +module Kiroku.Cli.Run + ( runKirokuCommand, runKirokuCommandWithStore, renderKirokuCommandWithStore, -) where + ) +where import Data.Text (Text) import Data.Text.IO qualified as TIO import Kiroku.Cli.Command (KirokuCommand (..), StatusOptions (..), SubscriptionCommand (..)) -import Kiroku.Cli.Subscription.Status ( - renderRemoteSubscriptionStatus, +import Kiroku.Cli.Subscription.Status + ( renderRemoteSubscriptionStatus, renderSubscriptionStatusRows, subscriptionStatusRows, - ) + ) import Kiroku.Store (KirokuStore) import Kiroku.Store.Subscription (subscriptionStates) runKirokuCommand :: KirokuCommand -> IO () runKirokuCommand KirokuNoCommand = - putStrLn "No Kiroku operator command was selected." + putStrLn "No Kiroku operator command was selected." runKirokuCommand (KirokuSubscriptions _) = - putStrLn "This command needs a live KirokuStore. Use runKirokuCommandWithStore from the embeddable library API." + putStrLn "This command needs a live KirokuStore. Use runKirokuCommandWithStore from the embeddable library API." runKirokuCommandWithStore :: KirokuStore -> KirokuCommand -> IO () runKirokuCommandWithStore store command = - renderKirokuCommandWithStore store command >>= TIO.putStrLn + renderKirokuCommandWithStore store command >>= TIO.putStrLn renderKirokuCommandWithStore :: KirokuStore -> KirokuCommand -> IO Text renderKirokuCommandWithStore _ KirokuNoCommand = - pure "No Kiroku operator command was selected." + pure "No Kiroku operator command was selected." renderKirokuCommandWithStore store (KirokuSubscriptions (SubscriptionStatus (StatusOptions format endpoint))) = - case endpoint of - -- An optional remote override: a host can point the in-process command at - -- a sibling worker over HTTP instead of reading its own registry. - Just ep -> renderRemoteSubscriptionStatus ep format - Nothing -> do - snapshot <- subscriptionStates store - pure (renderSubscriptionStatusRows format (subscriptionStatusRows snapshot)) + case endpoint of + -- An optional remote override: a host can point the in-process command at + -- a sibling worker over HTTP instead of reading its own registry. + Just ep -> renderRemoteSubscriptionStatus ep format + Nothing -> do + snapshot <- subscriptionStates store + pure (renderSubscriptionStatusRows format (subscriptionStatusRows snapshot)) diff --git a/src/Kiroku/Cli/Standalone.hs b/src/Kiroku/Cli/Standalone.hs --- a/src/Kiroku/Cli/Standalone.hs +++ b/src/Kiroku/Cli/Standalone.hs @@ -1,27 +1,28 @@ -module Kiroku.Cli.Standalone ( - StandaloneOptions (..), +module Kiroku.Cli.Standalone + ( StandaloneOptions (..), StandaloneRuntime (..), standaloneOptionsParser, standaloneParserInfo, resolveStandaloneOptions, runStandaloneCommand, -) where + ) +where import Control.Applicative ((<|>)) import Data.Generics.Labels () import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) -import Kiroku.Cli.Command ( - KirokuCommand (..), +import Kiroku.Cli.Command + ( KirokuCommand (..), RemoteEndpoint (..), StatusOptions (..), SubscriptionCommand (..), - ) + ) import Kiroku.Cli.Parser (kirokuCommandParser) import Kiroku.Cli.Subscription.Status (renderRemoteSubscriptionStatus) -import Options.Applicative ( - Parser, +import Options.Applicative + ( Parser, ParserInfo, fullDesc, header, @@ -29,75 +30,72 @@ info, progDesc, (<**>), - ) + ) -{- | Options for the standalone @kiroku@ binary. The binary is a pure remote -client: it carries only the parsed command (whose @--remote-url@ lives inside -'StatusOptions'); it never opens a store. --} +-- | Options for the standalone @kiroku@ binary. The binary is a pure remote +-- client: it carries only the parsed command (whose @--remote-url@ lives inside +-- 'StatusOptions'); it never opens a store. newtype StandaloneOptions = StandaloneOptions - { command :: KirokuCommand - } - deriving stock (Generic, Eq, Show) + { command :: KirokuCommand + } + deriving stock (Generic, Eq, Show) -{- | The resolved command, with any subscription-status endpoint filled in from -@--remote-url@ or @KIROKU_REMOTE_URL@. --} +-- | The resolved command, with any subscription-status endpoint filled in from +-- @--remote-url@ or @KIROKU_REMOTE_URL@. newtype StandaloneRuntime = StandaloneRuntime - { command :: KirokuCommand - } - deriving stock (Generic) + { command :: KirokuCommand + } + deriving stock (Generic) standaloneParserInfo :: ParserInfo StandaloneOptions standaloneParserInfo = - info - (standaloneOptionsParser <**> helper) - ( fullDesc - <> progDesc - "Inspect a running Kiroku worker over HTTP. Subscription status queries the worker's \ - \kiroku-metrics /subscriptions endpoint (--remote-url or KIROKU_REMOTE_URL); the binary \ - \opens no store of its own." - <> header "kiroku - remote operator client for Kiroku event stores" - ) + info + (standaloneOptionsParser <**> helper) + ( fullDesc + <> progDesc + "Inspect a running Kiroku worker over HTTP. Subscription status queries the worker's \ + \kiroku-metrics /subscriptions endpoint (--remote-url or KIROKU_REMOTE_URL); the binary \ + \opens no store of its own." + <> header "kiroku - remote operator client for Kiroku event stores" + ) standaloneOptionsParser :: Parser StandaloneOptions standaloneOptionsParser = - StandaloneOptions <$> kirokuCommandParser + StandaloneOptions <$> kirokuCommandParser -{- | Resolve the parsed options into a runnable command. For a subscription-status -command, the endpoint is taken from @--remote-url@ or, failing that, the -@KIROKU_REMOTE_URL@ environment variable; if neither is present, fail with -guidance. Commands that need no endpoint pass through unchanged. --} +-- | Resolve the parsed options into a runnable command. For a subscription-status +-- command, the endpoint is taken from @--remote-url@ or, failing that, the +-- @KIROKU_REMOTE_URL@ environment variable; if neither is present, fail with +-- guidance. Commands that need no endpoint pass through unchanged. resolveStandaloneOptions :: [(String, String)] -> StandaloneOptions -> Either Text StandaloneRuntime resolveStandaloneOptions env (StandaloneOptions cmd) = - case cmd of - KirokuNoCommand -> Right (StandaloneRuntime KirokuNoCommand) - KirokuSubscriptions (SubscriptionStatus (StatusOptions format mEndpoint)) -> - case mEndpoint <|> envEndpoint of - Just ep -> - Right - ( StandaloneRuntime - (KirokuSubscriptions (SubscriptionStatus (StatusOptions format (Just ep)))) - ) - Nothing -> Left noEndpointMessage + case cmd of + KirokuNoCommand -> Right (StandaloneRuntime KirokuNoCommand) + KirokuSubscriptions (SubscriptionStatus (StatusOptions format mEndpoint)) -> + case mEndpoint <|> envEndpoint of + Just ep -> + Right + ( StandaloneRuntime + (KirokuSubscriptions (SubscriptionStatus (StatusOptions format (Just ep)))) + ) + Nothing -> Left noEndpointMessage where envEndpoint = - case T.pack <$> lookup "KIROKU_REMOTE_URL" env of - Just url | not (T.null url) -> Just (RemoteEndpoint url) - _ -> Nothing + case T.pack <$> lookup "KIROKU_REMOTE_URL" env of + Just url | not (T.null url) -> Just (RemoteEndpoint url) + _ -> Nothing noEndpointMessage = - "kiroku: no worker endpoint; pass --remote-url or set KIROKU_REMOTE_URL. \ - \The standalone binary inspects a running worker over HTTP; it cannot see \ - \in-process subscriptions because it runs none." + "kiroku: no worker endpoint; pass --remote-url or set KIROKU_REMOTE_URL. \ + \The standalone binary inspects a running worker over HTTP; it cannot see \ + \in-process subscriptions because it runs none." runStandaloneCommand :: StandaloneRuntime -> IO Text runStandaloneCommand (StandaloneRuntime cmd) = - case cmd of - KirokuNoCommand -> pure "No Kiroku operator command was selected." - KirokuSubscriptions (SubscriptionStatus (StatusOptions format (Just ep))) -> - renderRemoteSubscriptionStatus ep format - KirokuSubscriptions (SubscriptionStatus (StatusOptions _ Nothing)) -> - -- Unreachable: resolveStandaloneOptions fills the endpoint or fails. - pure - "kiroku: no worker endpoint; pass --remote-url or set KIROKU_REMOTE_URL." + case cmd of + KirokuNoCommand -> pure "No Kiroku operator command was selected." + KirokuSubscriptions (SubscriptionStatus (StatusOptions format (Just ep))) -> + renderRemoteSubscriptionStatus ep format + KirokuSubscriptions (SubscriptionStatus (StatusOptions _ Nothing)) -> + -- Unreachable: resolveStandaloneOptions fills the endpoint or fails. + pure + "kiroku: no worker endpoint; pass --remote-url or set KIROKU_REMOTE_URL." diff --git a/src/Kiroku/Cli/Subscription/Status.hs b/src/Kiroku/Cli/Subscription/Status.hs --- a/src/Kiroku/Cli/Subscription/Status.hs +++ b/src/Kiroku/Cli/Subscription/Status.hs @@ -1,10 +1,11 @@ -module Kiroku.Cli.Subscription.Status ( - SubscriptionStatusRow (..), +module Kiroku.Cli.Subscription.Status + ( SubscriptionStatusRow (..), renderSubscriptionStatusRows, subscriptionStatusRows, fetchRemoteSubscriptionStatusRows, renderRemoteSubscriptionStatus, -) where + ) +where import Control.Exception (SomeException, try) import Control.Lens ((^.)) @@ -23,63 +24,62 @@ import Kiroku.Store.Subscription (SubscriptionStateView (..)) import Kiroku.Store.Subscription.Types (SubscriptionName (..)) import Kiroku.Store.Types (GlobalPosition (..)) -import Network.HTTP.Client ( - Request, +import Network.HTTP.Client + ( Request, Response, httpLbs, newManager, parseRequest, responseBody, responseStatus, - ) + ) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Status (statusCode) data SubscriptionStatusRow = SubscriptionStatusRow - { subscription :: !Text - , member :: !Int32 - , phase :: !Text - , globalPosition :: !Int64 - } - deriving stock (Generic, Eq, Show) + { subscription :: !Text, + member :: !Int32, + phase :: !Text, + globalPosition :: !Int64 + } + deriving stock (Generic, Eq, Show) -{- | The IP-5 wire contract: a JSON object with keys @subscription@, @member@, -@phase@, @global_position@. This is the single source of truth shared by the -@kiroku-metrics@ @\/subscriptions@ endpoint (which encodes) and the CLI remote -client (which decodes). --} +-- | The IP-5 wire contract: a JSON object with keys @subscription@, @member@, +-- @phase@, @global_position@. This is the single source of truth shared by the +-- @kiroku-metrics@ @\/subscriptions@ endpoint (which encodes) and the CLI remote +-- client (which decodes). instance Aeson.ToJSON SubscriptionStatusRow where - toJSON row = - Aeson.object - [ "subscription" Aeson..= (row ^. #subscription) - , "member" Aeson..= (row ^. #member) - , "phase" Aeson..= (row ^. #phase) - , "global_position" Aeson..= (row ^. #globalPosition) - ] + toJSON row = + Aeson.object + [ "subscription" Aeson..= (row ^. #subscription), + "member" Aeson..= (row ^. #member), + "phase" Aeson..= (row ^. #phase), + "global_position" Aeson..= (row ^. #globalPosition) + ] instance Aeson.FromJSON SubscriptionStatusRow where - parseJSON = Aeson.withObject "SubscriptionStatusRow" $ \o -> - SubscriptionStatusRow - <$> o Aeson..: "subscription" - <*> o Aeson..: "member" - <*> o Aeson..: "phase" - <*> o Aeson..: "global_position" + parseJSON = Aeson.withObject "SubscriptionStatusRow" $ \o -> + SubscriptionStatusRow + <$> o Aeson..: "subscription" + <*> o Aeson..: "member" + <*> o Aeson..: "phase" + <*> o Aeson..: "global_position" subscriptionStatusRows :: Map (SubscriptionName, Int32) SubscriptionStateView -> [SubscriptionStatusRow] subscriptionStatusRows = - sortOn (\row -> (row ^. #subscription, row ^. #member)) - . fmap toRow - . Map.elems + sortOn (\row -> (row ^. #subscription, row ^. #member)) + . fmap toRow + . Map.elems where toRow view = - let SubscriptionName name = subscriptionName view - GlobalPosition position = cursor view - in SubscriptionStatusRow - { subscription = name - , member = view ^. #member - , phase = view ^. #statePhase - , globalPosition = position - } + let SubscriptionName name = subscriptionName view + GlobalPosition position = cursor view + in SubscriptionStatusRow + { subscription = name, + member = view ^. #member, + phase = view ^. #statePhase, + globalPosition = position + } renderSubscriptionStatusRows :: OutputFormat -> [SubscriptionStatusRow] -> Text renderSubscriptionStatusRows OutputTable = renderTable @@ -87,77 +87,75 @@ renderTable :: [SubscriptionStatusRow] -> Text renderTable rows = - T.unlines (header : fmap renderRow rows) + T.unlines (header : fmap renderRow rows) where header = - pad subWidth "SUBSCRIPTION" - <> " " - <> pad memberWidth "MEMBER" - <> " " - <> pad phaseWidth "PHASE" - <> " GLOBAL_POSITION" + pad subWidth "SUBSCRIPTION" + <> " " + <> pad memberWidth "MEMBER" + <> " " + <> pad phaseWidth "PHASE" + <> " GLOBAL_POSITION" subWidth = columnWidth "SUBSCRIPTION" (fmap (^. #subscription) rows) memberWidth = columnWidth "MEMBER" (fmap (T.pack . show . (^. #member)) rows) phaseWidth = columnWidth "PHASE" (fmap (^. #phase) rows) renderRow row = - pad subWidth (row ^. #subscription) - <> " " - <> pad memberWidth (T.pack (show (row ^. #member))) - <> " " - <> pad phaseWidth (row ^. #phase) - <> " " - <> T.pack (show (row ^. #globalPosition)) + pad subWidth (row ^. #subscription) + <> " " + <> pad memberWidth (T.pack (show (row ^. #member))) + <> " " + <> pad phaseWidth (row ^. #phase) + <> " " + <> T.pack (show (row ^. #globalPosition)) columnWidth :: Text -> [Text] -> Int columnWidth label values = - maximum (T.length label : fmap T.length values) + maximum (T.length label : fmap T.length values) pad :: Int -> Text -> Text pad width value = - value <> T.replicate (width - T.length value) " " + value <> T.replicate (width - T.length value) " " renderJson :: [SubscriptionStatusRow] -> Text renderJson = - TE.decodeUtf8 - . LBS.toStrict - . Aeson.encode + TE.decodeUtf8 + . LBS.toStrict + . Aeson.encode -{- | Fetch a running worker's @\/subscriptions@ endpoint and decode the rows. -GETs @\/subscriptions@ (trimming a trailing slash on the base), and on a -2xx response decodes @[SubscriptionStatusRow]@ via the shared 'Aeson.FromJSON'. -Non-2xx responses, connection failures, and decode errors are returned as a -readable 'Left' message rather than thrown. --} +-- | Fetch a running worker's @\/subscriptions@ endpoint and decode the rows. +-- GETs @\/subscriptions@ (trimming a trailing slash on the base), and on a +-- 2xx response decodes @[SubscriptionStatusRow]@ via the shared 'Aeson.FromJSON'. +-- Non-2xx responses, connection failures, and decode errors are returned as a +-- readable 'Left' message rather than thrown. fetchRemoteSubscriptionStatusRows :: RemoteEndpoint -> IO (Either Text [SubscriptionStatusRow]) fetchRemoteSubscriptionStatusRows (RemoteEndpoint base) = do - let url = T.unpack (T.dropWhileEnd (== '/') base) <> "/subscriptions" - reqResult <- try (parseRequest url) :: IO (Either SomeException Request) - case reqResult of - Left err -> pure (Left ("kiroku: invalid --remote-url " <> T.pack url <> ": " <> T.pack (show err))) - Right req -> do - manager <- newManager tlsManagerSettings - respResult <- try (httpLbs req manager) :: IO (Either SomeException (Response LBS.ByteString)) - pure $ case respResult of - Left err -> Left ("kiroku: could not reach " <> T.pack url <> ": " <> T.pack (show err)) - Right resp -> decodeResponse url resp + let url = T.unpack (T.dropWhileEnd (== '/') base) <> "/subscriptions" + reqResult <- try (parseRequest url) :: IO (Either SomeException Request) + case reqResult of + Left err -> pure (Left ("kiroku: invalid --remote-url " <> T.pack url <> ": " <> T.pack (show err))) + Right req -> do + manager <- newManager tlsManagerSettings + respResult <- try (httpLbs req manager) :: IO (Either SomeException (Response LBS.ByteString)) + pure $ case respResult of + Left err -> Left ("kiroku: could not reach " <> T.pack url <> ": " <> T.pack (show err)) + Right resp -> decodeResponse url resp where decodeResponse :: String -> Response LBS.ByteString -> Either Text [SubscriptionStatusRow] decodeResponse url resp = - let code = statusCode (responseStatus resp) - in if code >= 200 && code < 300 - then case Aeson.eitherDecode (responseBody resp) of - Right rows -> Right rows - Left decodeErr -> - Left ("kiroku: could not decode response from " <> T.pack url <> ": " <> T.pack decodeErr) - else - Left ("kiroku: " <> T.pack url <> " returned HTTP " <> T.pack (show code)) + let code = statusCode (responseStatus resp) + in if code >= 200 && code < 300 + then case Aeson.eitherDecode (responseBody resp) of + Right rows -> Right rows + Left decodeErr -> + Left ("kiroku: could not decode response from " <> T.pack url <> ": " <> T.pack decodeErr) + else + Left ("kiroku: " <> T.pack url <> " returned HTTP " <> T.pack (show code)) -{- | Fetch and render a remote worker's subscription status, reusing the same -table/JSON renderer the in-process command uses. On error, returns the error text. --} +-- | Fetch and render a remote worker's subscription status, reusing the same +-- table/JSON renderer the in-process command uses. On error, returns the error text. renderRemoteSubscriptionStatus :: RemoteEndpoint -> OutputFormat -> IO Text renderRemoteSubscriptionStatus ep format = do - result <- fetchRemoteSubscriptionStatusRows ep - pure $ case result of - Left err -> err - Right rows -> renderSubscriptionStatusRows format rows + result <- fetchRemoteSubscriptionStatusRows ep + pure $ case result of + Left err -> err + Right rows -> renderSubscriptionStatusRows format rows diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -14,8 +14,8 @@ import Kiroku.Store import Kiroku.Store.Subscription.Fsm (SubscriptionState (..)) import Kiroku.Test.Postgres (withMigratedTestDatabase) -import Options.Applicative ( - Parser, +import Options.Applicative + ( Parser, ParserInfo, ParserResult (..), defaultPrefs, @@ -27,227 +27,227 @@ renderFailure, subparser, (<**>), - ) + ) import Options.Applicative qualified as Options import Test.Hspec data HostCommand - = HostOnly - | HostKiroku KirokuCommand - deriving stock (Eq, Show) + = HostOnly + | HostKiroku KirokuCommand + deriving stock (Eq, Show) main :: IO () main = - hspec $ do - describe "kirokuParserInfo" $ do - it "renders top-level help" $ do - let result = execParserPure defaultPrefs kirokuParserInfo ["--help"] - renderedHelp result `shouldSatisfy` isInfixOf "operator commands for Kiroku" + hspec $ do + describe "kirokuParserInfo" $ do + it "renders top-level help" $ do + let result = execParserPure defaultPrefs kirokuParserInfo ["--help"] + renderedHelp result `shouldSatisfy` isInfixOf "operator commands for Kiroku" - it "parses subscriptions status with the default table format" $ do - case execParserPure defaultPrefs kirokuParserInfo ["subscriptions", "status"] of - Success parsed -> - parsed `shouldBe` KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputTable Nothing)) - other -> expectationFailure ("expected parser success, got " <> renderedHelp other) + it "parses subscriptions status with the default table format" $ do + case execParserPure defaultPrefs kirokuParserInfo ["subscriptions", "status"] of + Success parsed -> + parsed `shouldBe` KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputTable Nothing)) + other -> expectationFailure ("expected parser success, got " <> renderedHelp other) - it "parses subscriptions status with JSON output" $ do - case execParserPure defaultPrefs kirokuParserInfo ["subscriptions", "status", "--format", "json"] of - Success parsed -> - parsed `shouldBe` KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputJson Nothing)) - other -> expectationFailure ("expected parser success, got " <> renderedHelp other) + it "parses subscriptions status with JSON output" $ do + case execParserPure defaultPrefs kirokuParserInfo ["subscriptions", "status", "--format", "json"] of + Success parsed -> + parsed `shouldBe` KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputJson Nothing)) + other -> expectationFailure ("expected parser success, got " <> renderedHelp other) - it "parses subscriptions status with a remote URL" $ do - case execParserPure defaultPrefs kirokuParserInfo ["subscriptions", "status", "--remote-url", "http://worker:9091"] of - Success parsed -> - parsed - `shouldBe` KirokuSubscriptions - (SubscriptionStatus (StatusOptions OutputTable (Just (RemoteEndpoint "http://worker:9091")))) - other -> expectationFailure ("expected parser success, got " <> renderedHelp other) + it "parses subscriptions status with a remote URL" $ do + case execParserPure defaultPrefs kirokuParserInfo ["subscriptions", "status", "--remote-url", "http://worker:9091"] of + Success parsed -> + parsed + `shouldBe` KirokuSubscriptions + (SubscriptionStatus (StatusOptions OutputTable (Just (RemoteEndpoint "http://worker:9091")))) + other -> expectationFailure ("expected parser success, got " <> renderedHelp other) - it "renders status help" $ do - let result = execParserPure defaultPrefs kirokuParserInfo ["subscriptions", "status", "--help"] - renderedHelp result `shouldSatisfy` isInfixOf "List live subscription phases" + it "renders status help" $ do + let result = execParserPure defaultPrefs kirokuParserInfo ["subscriptions", "status", "--help"] + renderedHelp result `shouldSatisfy` isInfixOf "List live subscription phases" - describe "kirokuSubparser" $ do - it "parses as a nested host command" $ do - case execParserPure defaultPrefs hostParserInfo ["kiroku"] of - Success parsed -> parsed `shouldBe` HostKiroku KirokuNoCommand - other -> expectationFailure ("expected parser success, got " <> renderedHelp other) + describe "kirokuSubparser" $ do + it "parses as a nested host command" $ do + case execParserPure defaultPrefs hostParserInfo ["kiroku"] of + Success parsed -> parsed `shouldBe` HostKiroku KirokuNoCommand + other -> expectationFailure ("expected parser success, got " <> renderedHelp other) - it "parses a nested subscription status command" $ do - case execParserPure defaultPrefs hostParserInfo ["kiroku", "subscriptions", "status", "--format", "json"] of - Success parsed -> - parsed `shouldBe` HostKiroku (KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputJson Nothing))) - other -> expectationFailure ("expected parser success, got " <> renderedHelp other) + it "parses a nested subscription status command" $ do + case execParserPure defaultPrefs hostParserInfo ["kiroku", "subscriptions", "status", "--format", "json"] of + Success parsed -> + parsed `shouldBe` HostKiroku (KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputJson Nothing))) + other -> expectationFailure ("expected parser success, got " <> renderedHelp other) - it "renders nested help under a host command parser" $ do - let result = execParserPure defaultPrefs hostParserInfo ["kiroku", "--help"] - renderedHelp result `shouldSatisfy` isInfixOf "Run Kiroku operator commands." + it "renders nested help under a host command parser" $ do + let result = execParserPure defaultPrefs hostParserInfo ["kiroku", "--help"] + renderedHelp result `shouldSatisfy` isInfixOf "Run Kiroku operator commands." - describe "standaloneParserInfo (remote client)" $ do - it "parses a status command with a remote URL and format" $ do - case execParserPure defaultPrefs standaloneParserInfo ["subscriptions", "status", "--remote-url", "http://worker:9091", "--format", "json"] of - Success parsed -> - parsed - `shouldBe` StandaloneOptions - { command = - KirokuSubscriptions - (SubscriptionStatus (StatusOptions OutputJson (Just (RemoteEndpoint "http://worker:9091")))) - } - other -> expectationFailure ("expected parser success, got " <> renderedHelp other) + describe "standaloneParserInfo (remote client)" $ do + it "parses a status command with a remote URL and format" $ do + case execParserPure defaultPrefs standaloneParserInfo ["subscriptions", "status", "--remote-url", "http://worker:9091", "--format", "json"] of + Success parsed -> + parsed + `shouldBe` StandaloneOptions + { command = + KirokuSubscriptions + (SubscriptionStatus (StatusOptions OutputJson (Just (RemoteEndpoint "http://worker:9091")))) + } + other -> expectationFailure ("expected parser success, got " <> renderedHelp other) - it "no longer accepts --database-url" $ do - case execParserPure defaultPrefs standaloneParserInfo ["--database-url", "postgres://x", "subscriptions", "status"] of - Success _ -> expectationFailure "expected --database-url to be rejected" - _ -> pure () + it "no longer accepts --database-url" $ do + case execParserPure defaultPrefs standaloneParserInfo ["--database-url", "postgres://x", "subscriptions", "status"] of + Success _ -> expectationFailure "expected --database-url to be rejected" + _ -> pure () - it "resolves the endpoint from --remote-url" $ do - let opts = - StandaloneOptions - { command = - KirokuSubscriptions - (SubscriptionStatus (StatusOptions OutputTable (Just (RemoteEndpoint "http://flag:9091")))) - } - case resolveStandaloneOptions [("KIROKU_REMOTE_URL", "http://env:9091")] opts of - Right (StandaloneRuntime{command = KirokuSubscriptions (SubscriptionStatus (StatusOptions _ endpoint))}) -> - endpoint `shouldBe` Just (RemoteEndpoint "http://flag:9091") - other -> expectationFailure ("expected resolved remote runtime, got " <> show' other) + it "resolves the endpoint from --remote-url" $ do + let opts = + StandaloneOptions + { command = + KirokuSubscriptions + (SubscriptionStatus (StatusOptions OutputTable (Just (RemoteEndpoint "http://flag:9091")))) + } + case resolveStandaloneOptions [("KIROKU_REMOTE_URL", "http://env:9091")] opts of + Right (StandaloneRuntime {command = KirokuSubscriptions (SubscriptionStatus (StatusOptions _ endpoint))}) -> + endpoint `shouldBe` Just (RemoteEndpoint "http://flag:9091") + other -> expectationFailure ("expected resolved remote runtime, got " <> show' other) - it "falls back to KIROKU_REMOTE_URL when no flag is given" $ do - let opts = - StandaloneOptions - { command = KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputTable Nothing)) - } - case resolveStandaloneOptions [("KIROKU_REMOTE_URL", "http://env:9091")] opts of - Right (StandaloneRuntime{command = KirokuSubscriptions (SubscriptionStatus (StatusOptions _ endpoint))}) -> - endpoint `shouldBe` Just (RemoteEndpoint "http://env:9091") - other -> expectationFailure ("expected resolved remote runtime, got " <> show' other) + it "falls back to KIROKU_REMOTE_URL when no flag is given" $ do + let opts = + StandaloneOptions + { command = KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputTable Nothing)) + } + case resolveStandaloneOptions [("KIROKU_REMOTE_URL", "http://env:9091")] opts of + Right (StandaloneRuntime {command = KirokuSubscriptions (SubscriptionStatus (StatusOptions _ endpoint))}) -> + endpoint `shouldBe` Just (RemoteEndpoint "http://env:9091") + other -> expectationFailure ("expected resolved remote runtime, got " <> show' other) - it "errors with guidance when no endpoint is given" $ do - let opts = - StandaloneOptions - { command = KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputTable Nothing)) - } - case resolveStandaloneOptions [] opts of - Left err -> T.unpack err `shouldSatisfy` isInfixOf "no worker endpoint" - Right _ -> expectationFailure "expected missing endpoint to fail" + it "errors with guidance when no endpoint is given" $ do + let opts = + StandaloneOptions + { command = KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputTable Nothing)) + } + case resolveStandaloneOptions [] opts of + Left err -> T.unpack err `shouldSatisfy` isInfixOf "no worker endpoint" + Right _ -> expectationFailure "expected missing endpoint to fail" - it "reports an unreachable endpoint as a readable error, not an exception" $ do - let opts = - StandaloneOptions - { command = - -- 127.0.0.1:1 is reserved and refuses connections. - KirokuSubscriptions - (SubscriptionStatus (StatusOptions OutputTable (Just (RemoteEndpoint "http://127.0.0.1:1")))) - } - case resolveStandaloneOptions [] opts of - Right runtime -> do - output <- runStandaloneCommand runtime - T.unpack output `shouldSatisfy` isInfixOf "could not reach" - Left err -> expectationFailure ("expected resolved runtime, got " <> T.unpack err) + it "reports an unreachable endpoint as a readable error, not an exception" $ do + let opts = + StandaloneOptions + { command = + -- 127.0.0.1:1 is reserved and refuses connections. + KirokuSubscriptions + (SubscriptionStatus (StatusOptions OutputTable (Just (RemoteEndpoint "http://127.0.0.1:1")))) + } + case resolveStandaloneOptions [] opts of + Right runtime -> do + output <- runStandaloneCommand runtime + T.unpack output `shouldSatisfy` isInfixOf "could not reach" + Left err -> expectationFailure ("expected resolved runtime, got " <> T.unpack err) - describe "SubscriptionStatusRow codec (IP-5 wire contract)" $ do - it "round-trips through encode/decode" $ do - let rows = - [ SubscriptionStatusRow "alpha" 0 "catching_up" 7 - , SubscriptionStatusRow "beta" 1 "live" 9223372036854775807 - , SubscriptionStatusRow "gamma" 2 "reconnecting" 0 - ] - Aeson.decode (Aeson.encode rows) `shouldBe` Just rows + describe "SubscriptionStatusRow codec (IP-5 wire contract)" $ do + it "round-trips through encode/decode" $ do + let rows = + [ SubscriptionStatusRow "alpha" 0 "catching_up" 7, + SubscriptionStatusRow "beta" 1 "live" 9223372036854775807, + SubscriptionStatusRow "gamma" 2 "reconnecting" 0 + ] + Aeson.decode (Aeson.encode rows) `shouldBe` Just rows - it "uses the exact wire keys" $ do - Aeson.decode (Aeson.encode (SubscriptionStatusRow "alpha" 0 "live" 12)) - `shouldBe` Just - ( Aeson.object - [ "subscription" Aeson..= ("alpha" :: Text) - , "member" Aeson..= (0 :: Int) - , "phase" Aeson..= ("live" :: Text) - , "global_position" Aeson..= (12 :: Int) - ] - ) + it "uses the exact wire keys" $ do + Aeson.decode (Aeson.encode (SubscriptionStatusRow "alpha" 0 "live" 12)) + `shouldBe` Just + ( Aeson.object + [ "subscription" Aeson..= ("alpha" :: Text), + "member" Aeson..= (0 :: Int), + "phase" Aeson..= ("live" :: Text), + "global_position" Aeson..= (12 :: Int) + ] + ) - describe "subscriptionStatusRows" $ do - it "sorts rows and extracts public scalar fields" $ do - subscriptionStatusRows - ( Map.fromList - [ ((SubscriptionName "beta", 1), view "beta" 1 "live" 42) - , ((SubscriptionName "alpha", 0), view "alpha" 0 "catching_up" 7) - ] - ) - `shouldBe` [ SubscriptionStatusRow "alpha" 0 "catching_up" 7 - , SubscriptionStatusRow "beta" 1 "live" 42 - ] + describe "subscriptionStatusRows" $ do + it "sorts rows and extracts public scalar fields" $ do + subscriptionStatusRows + ( Map.fromList + [ ((SubscriptionName "beta", 1), view "beta" 1 "live" 42), + ((SubscriptionName "alpha", 0), view "alpha" 0 "catching_up" 7) + ] + ) + `shouldBe` [ SubscriptionStatusRow "alpha" 0 "catching_up" 7, + SubscriptionStatusRow "beta" 1 "live" 42 + ] - describe "renderSubscriptionStatusRows" $ do - it "renders a header for an empty table" $ do - renderSubscriptionStatusRows OutputTable [] - `shouldBe` "SUBSCRIPTION MEMBER PHASE GLOBAL_POSITION\n" + describe "renderSubscriptionStatusRows" $ do + it "renders a header for an empty table" $ do + renderSubscriptionStatusRows OutputTable [] + `shouldBe` "SUBSCRIPTION MEMBER PHASE GLOBAL_POSITION\n" - it "renders table rows" $ do - renderSubscriptionStatusRows OutputTable [SubscriptionStatusRow "alpha" 0 "live" 12] - `shouldSatisfy` T.isInfixOf "alpha 0 live 12" + it "renders table rows" $ do + renderSubscriptionStatusRows OutputTable [SubscriptionStatusRow "alpha" 0 "live" 12] + `shouldSatisfy` T.isInfixOf "alpha 0 live 12" - it "renders script-friendly JSON" $ do - Aeson.eitherDecodeStrictText (renderSubscriptionStatusRows OutputJson [SubscriptionStatusRow "alpha" 0 "live" 12]) - `shouldBe` Right - [ Aeson.object - [ "subscription" Aeson..= ("alpha" :: Text) - , "member" Aeson..= (0 :: Int) - , "phase" Aeson..= ("live" :: Text) - , "global_position" Aeson..= (12 :: Int) - ] - ] + it "renders script-friendly JSON" $ do + Aeson.eitherDecodeStrictText (renderSubscriptionStatusRows OutputJson [SubscriptionStatusRow "alpha" 0 "live" 12]) + `shouldBe` Right + [ Aeson.object + [ "subscription" Aeson..= ("alpha" :: Text), + "member" Aeson..= (0 :: Int), + "phase" Aeson..= ("live" :: Text), + "global_position" Aeson..= (12 :: Int) + ] + ] - describe "renderKirokuCommandWithStore" $ do - it "renders status from a live KirokuStore registry" $ - withTestStore $ \store -> do - let name = SubscriptionName "cli-registry" - Right _ <- runStoreIO store $ appendToStream (StreamName "cli-registry-1") NoStream [makeEvent "A" (Aeson.object [])] - handle <- subscribe store (defaultSubscriptionConfig name AllStreams (\_ -> pure Continue)) - live <- waitUntilPhase 5_000_000 store (name, 0) "live" - live `shouldBe` True - output <- - renderKirokuCommandWithStore - store - (KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputTable Nothing))) - output `shouldSatisfy` T.isInfixOf "cli-registry" - output `shouldSatisfy` T.isInfixOf "live" - output `shouldSatisfy` T.isInfixOf "0" - cancel handle + describe "renderKirokuCommandWithStore" $ do + it "renders status from a live KirokuStore registry" $ + withTestStore $ \store -> do + let name = SubscriptionName "cli-registry" + Right _ <- runStoreIO store $ appendToStream (StreamName "cli-registry-1") NoStream [makeEvent "A" (Aeson.object [])] + handle <- subscribe store (defaultSubscriptionConfig name AllStreams (\_ -> pure Continue)) + live <- waitUntilPhase 5_000_000 store (name, 0) "live" + live `shouldBe` True + output <- + renderKirokuCommandWithStore + store + (KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputTable Nothing))) + output `shouldSatisfy` T.isInfixOf "cli-registry" + output `shouldSatisfy` T.isInfixOf "live" + output `shouldSatisfy` T.isInfixOf "0" + cancel handle - it "runs nested Kiroku commands through a host command wrapper" $ - withTestStore $ \store -> do - output <- runHostCommand store (HostKiroku (KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputJson Nothing)))) - output `shouldBe` "[]" + it "runs nested Kiroku commands through a host command wrapper" $ + withTestStore $ \store -> do + output <- runHostCommand store (HostKiroku (KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputJson Nothing)))) + output `shouldBe` "[]" hostParserInfo :: ParserInfo HostCommand hostParserInfo = - info - (hostCommandParser <**> helper) - (fullDesc <> progDesc "Fake host CLI used to prove parser embedding.") + info + (hostCommandParser <**> helper) + (fullDesc <> progDesc "Fake host CLI used to prove parser embedding.") hostCommandParser :: Parser HostCommand hostCommandParser = - subparser - ( Options.command - "host" - (info (pure HostOnly) (progDesc "Run a host-only command.")) - <> kirokuSubparser HostKiroku - ) + subparser + ( Options.command + "host" + (info (pure HostOnly) (progDesc "Run a host-only command.")) + <> kirokuSubparser HostKiroku + ) runHostCommand :: KirokuStore -> HostCommand -> IO Text runHostCommand _ HostOnly = - pure "host command" + pure "host command" runHostCommand store (HostKiroku kirokuCommand) = - renderKirokuCommandWithStore store kirokuCommand + renderKirokuCommandWithStore store kirokuCommand renderedHelp :: ParserResult a -> String renderedHelp (Failure failure) = - fst (renderFailure failure "test") + fst (renderFailure failure "test") renderedHelp (Success _) = - "" + "" renderedHelp (CompletionInvoked _) = - "" + "" -- | 'StandaloneRuntime' has no 'Show'; describe a resolved/failed result for test messages. show' :: Either Text StandaloneRuntime -> String @@ -256,37 +256,37 @@ view :: Text -> Int32 -> Text -> Int64 -> SubscriptionStateView view name member phase position = - SubscriptionStateView - { subscriptionName = SubscriptionName name - , member = member - , state = Live (GlobalPosition position) - , statePhase = phase - , cursor = GlobalPosition position - } + SubscriptionStateView + { subscriptionName = SubscriptionName name, + member = member, + state = Live (GlobalPosition position), + statePhase = phase, + cursor = GlobalPosition position + } withTestStore :: (KirokuStore -> IO ()) -> IO () withTestStore action = - withMigratedTestDatabase $ \connStr -> - withStore (defaultConnectionSettings connStr) action + withMigratedTestDatabase $ \connStr -> + withStore (defaultConnectionSettings connStr) action makeEvent :: Text -> Aeson.Value -> EventData makeEvent typ payload = - EventData - { eventId = Nothing - , eventType = EventType typ - , payload = payload - , metadata = Nothing - , causationId = Nothing - , correlationId = Nothing - } + EventData + { eventId = Nothing, + eventType = EventType typ, + payload = payload, + metadata = Nothing, + causationId = Nothing, + correlationId = Nothing + } waitUntilPhase :: Int -> KirokuStore -> (SubscriptionName, Int32) -> Text -> IO Bool waitUntilPhase budget store key phase - | budget <= 0 = pure False - | otherwise = do - snapshot <- subscriptionStates store - case Map.lookup key snapshot of - Just status | statePhase status == phase -> pure True - _ -> do - threadDelay 20_000 - waitUntilPhase (budget - 20_000) store key phase + | budget <= 0 = pure False + | otherwise = do + snapshot <- subscriptionStates store + case Map.lookup key snapshot of + Just status | statePhase status == phase -> pure True + _ -> do + threadDelay 20_000 + waitUntilPhase (budget - 20_000) store key phase