kiroku-cli 0.2.0.10 → 0.2.0.11
raw patch · 10 files changed
+474/−469 lines, 10 filesdep ~kiroku-storePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: kiroku-store
API changes (from Hackage documentation)
Files
- CHANGELOG.md +7/−0
- app/Main.hs +13/−13
- kiroku-cli.cabal +3/−3
- src/Kiroku/Cli.hs +4/−3
- src/Kiroku/Cli/Command.hs +21/−22
- src/Kiroku/Cli/Parser.hs +55/−54
- src/Kiroku/Cli/Run.hs +18/−17
- src/Kiroku/Cli/Standalone.hs +59/−61
- src/Kiroku/Cli/Subscription/Status.hs +89/−91
- test/Main.hs +205/−205
CHANGELOG.md view
@@ -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
app/Main.hs view
@@ -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
kiroku-cli.cabal view
@@ -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
src/Kiroku/Cli.hs view
@@ -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)
src/Kiroku/Cli/Command.hs view
@@ -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)
src/Kiroku/Cli/Parser.hs view
@@ -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." )+ )
src/Kiroku/Cli/Run.hs view
@@ -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))
src/Kiroku/Cli/Standalone.hs view
@@ -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."
src/Kiroku/Cli/Subscription/Status.hs view
@@ -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 @\<base\>/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 @\<base\>/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
test/Main.hs view
@@ -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