diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ +# Changelog + +## Unreleased + +## 0.1.0.0 — 2026-05-31 + +### New Features + +* Initial package with embeddable parser, runner facade, executable wrapper, + and parser composition tests. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,26 @@ +module Main where + +import Control.Exception (SomeException, try) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Kiroku.Cli.Standalone (resolveStandaloneOptions, runStandaloneCommand, standaloneParserInfo) +import Options.Applicative (execParser) +import System.Environment (getEnvironment) +import System.Exit (exitFailure) +import System.IO (stderr) + +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 diff --git a/kiroku-cli.cabal b/kiroku-cli.cabal new file mode 100644 --- /dev/null +++ b/kiroku-cli.cabal @@ -0,0 +1,84 @@ +cabal-version: 3.0 +name: kiroku-cli +version: 0.1.0.0 +synopsis: Embeddable operator CLI for Kiroku +description: + Parser, runner, and executable entry points for Kiroku operator commands. + The library is designed for embedding in host application CLIs, while the + executable is a thin wrapper over the same parser and runner. + +homepage: https://github.com/shinzui/kiroku +bug-reports: https://github.com/shinzui/kiroku/issues +author: Nadeem Bitar +maintainer: nadeem@gmail.com +license: BSD-3-Clause +build-type: Simple +category: Database, Eventing +extra-doc-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/shinzui/kiroku.git + +common common + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + OverloadedLabels + OverloadedStrings + + ghc-options: -Wall + +library + import: common + exposed-modules: + Kiroku.Cli + Kiroku.Cli.Command + Kiroku.Cli.Parser + Kiroku.Cli.Run + Kiroku.Cli.Standalone + Kiroku.Cli.Subscription.Status + + build-depends: + , aeson >=2.1 && <2.3 + , base >=4.18 && <5 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.8 + , generic-lens >=2.2 && <2.4 + , kiroku-store ^>=0.2 + , lens >=5.2 && <5.4 + , optparse-applicative >=0.19 && <0.20 + , text >=2.0 && <2.2 + + hs-source-dirs: src + +executable kiroku + import: common + main-is: Main.hs + hs-source-dirs: app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , base + , kiroku-cli + , optparse-applicative + , text + +test-suite kiroku-cli-test + import: common + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , aeson + , base + , containers + , generic-lens >=2.2 && <2.4 + , hspec >=2.10 && <2.12 + , kiroku-cli + , kiroku-store + , kiroku-test-support + , lens + , optparse-applicative + , text diff --git a/src/Kiroku/Cli.hs b/src/Kiroku/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Cli.hs @@ -0,0 +1,13 @@ +module Kiroku.Cli ( + KirokuCommand (..), + kirokuCommandParser, + kirokuParserInfo, + kirokuSubparser, + runKirokuCommand, + runKirokuCommandWithStore, + renderKirokuCommandWithStore, +) where + +import Kiroku.Cli.Command (KirokuCommand (..)) +import Kiroku.Cli.Parser (kirokuCommandParser, kirokuParserInfo, kirokuSubparser) +import Kiroku.Cli.Run (renderKirokuCommandWithStore, runKirokuCommand, runKirokuCommandWithStore) diff --git a/src/Kiroku/Cli/Command.hs b/src/Kiroku/Cli/Command.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Cli/Command.hs @@ -0,0 +1,25 @@ +module Kiroku.Cli.Command ( + KirokuCommand (..), + OutputFormat (..), + StatusOptions (..), + SubscriptionCommand (..), +) where + +data KirokuCommand + = KirokuNoCommand + | KirokuSubscriptions SubscriptionCommand + deriving stock (Eq, Show) + +data SubscriptionCommand + = SubscriptionStatus StatusOptions + deriving stock (Eq, Show) + +newtype StatusOptions = StatusOptions + { outputFormat :: OutputFormat + } + deriving stock (Eq, Show) + +data OutputFormat + = OutputTable + | OutputJson + deriving stock (Eq, Show) diff --git a/src/Kiroku/Cli/Parser.hs b/src/Kiroku/Cli/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Cli/Parser.hs @@ -0,0 +1,90 @@ +module Kiroku.Cli.Parser ( + kirokuCommandParser, + kirokuParserInfo, + kirokuSubparser, +) where + +import Control.Applicative (optional) +import Kiroku.Cli.Command (KirokuCommand (..)) +import Kiroku.Cli.Command qualified as Command +import Options.Applicative ( + CommandFields, + Mod, + Parser, + ParserInfo, + command, + eitherReader, + fullDesc, + header, + help, + helper, + info, + long, + metavar, + option, + progDesc, + 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.") + ) + ) + ) + +subscriptionCommandParser :: Parser Command.SubscriptionCommand +subscriptionCommandParser = + 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." + ) + +parseOutputFormat :: String -> Either String Command.OutputFormat +parseOutputFormat "table" = Right Command.OutputTable +parseOutputFormat "json" = Right Command.OutputJson +parseOutputFormat other = Left ("unsupported output format " <> show other <> "; expected table or json") + +kirokuParserInfo :: ParserInfo KirokuCommand +kirokuParserInfo = + 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." + ) + ) diff --git a/src/Kiroku/Cli/Run.hs b/src/Kiroku/Cli/Run.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Cli/Run.hs @@ -0,0 +1,29 @@ +module Kiroku.Cli.Run ( + runKirokuCommand, + runKirokuCommandWithStore, + renderKirokuCommandWithStore, +) where + +import Data.Text (Text) +import Data.Text.IO qualified as TIO +import Kiroku.Cli.Command (KirokuCommand (..), StatusOptions (..), SubscriptionCommand (..)) +import Kiroku.Cli.Subscription.Status (renderSubscriptionStatusRows, subscriptionStatusRows) +import Kiroku.Store (KirokuStore) +import Kiroku.Store.Subscription (subscriptionStates) + +runKirokuCommand :: KirokuCommand -> IO () +runKirokuCommand KirokuNoCommand = + putStrLn "No Kiroku operator command was selected." +runKirokuCommand (KirokuSubscriptions _) = + 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 :: KirokuStore -> KirokuCommand -> IO Text +renderKirokuCommandWithStore _ KirokuNoCommand = + pure "No Kiroku operator command was selected." +renderKirokuCommandWithStore store (KirokuSubscriptions (SubscriptionStatus (StatusOptions format))) = do + snapshot <- subscriptionStates store + pure (renderSubscriptionStatusRows format (subscriptionStatusRows snapshot)) diff --git a/src/Kiroku/Cli/Standalone.hs b/src/Kiroku/Cli/Standalone.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Cli/Standalone.hs @@ -0,0 +1,118 @@ +module Kiroku.Cli.Standalone ( + StandaloneOptions (..), + StandaloneRuntime (..), + standaloneOptionsParser, + standaloneParserInfo, + resolveStandaloneOptions, + runStandaloneCommand, +) where + +import Control.Applicative (optional, (<|>)) +import Control.Lens ((&), (.~)) +import Data.Generics.Labels () +import Data.Text (Text) +import Data.Text qualified as T +import Kiroku.Cli.Command (KirokuCommand (..), OutputFormat (..), StatusOptions (..), SubscriptionCommand (..)) +import Kiroku.Cli.Parser (kirokuCommandParser) +import Kiroku.Cli.Subscription.Status (renderSubscriptionStatusRows, subscriptionStatusRows) +import Kiroku.Store (ConnectionSettings, KirokuStore, defaultConnectionSettings, withStore) +import Kiroku.Store.Subscription (subscriptionStates) +import Options.Applicative ( + Parser, + ParserInfo, + auto, + fullDesc, + header, + help, + helper, + info, + long, + metavar, + option, + progDesc, + strOption, + value, + (<**>), + ) + +data StandaloneOptions = StandaloneOptions + { databaseUrl :: !(Maybe Text) + , schema :: !Text + , poolSize :: !Int + , standaloneCommand :: !KirokuCommand + } + deriving stock (Eq, Show) + +data StandaloneRuntime = StandaloneRuntime + { settings :: !ConnectionSettings + , runtimeCommand :: !KirokuCommand + } + +standaloneParserInfo :: ParserInfo StandaloneOptions +standaloneParserInfo = + info + (standaloneOptionsParser <**> helper) + ( fullDesc + <> progDesc "Run Kiroku operator commands against a store opened by this process. Subscription status reads this process-local live registry." + <> header "kiroku - operator commands for Kiroku event stores" + ) + +standaloneOptionsParser :: Parser StandaloneOptions +standaloneOptionsParser = + StandaloneOptions + <$> optional + ( strOption + ( long "database-url" + <> metavar "URL" + <> help "PostgreSQL connection string. Defaults to KIROKU_DATABASE_URL." + ) + ) + <*> strOption + ( long "schema" + <> metavar "SCHEMA" + <> value "kiroku" + <> help "PostgreSQL schema that owns Kiroku objects." + ) + <*> option + auto + ( long "pool-size" + <> metavar "INT" + <> value 2 + <> help "Connection pool size for this operator command." + ) + <*> kirokuCommandParser + +resolveStandaloneOptions :: [(String, String)] -> StandaloneOptions -> Either Text StandaloneRuntime +resolveStandaloneOptions env opts + | poolSize opts <= 0 = Left "kiroku: --pool-size must be greater than zero" + | otherwise = do + conn <- case databaseUrl opts <|> (T.pack <$> lookup "KIROKU_DATABASE_URL" env) of + Just connString | not (T.null connString) -> Right connString + _ -> Left "kiroku: missing database connection string; pass --database-url or set KIROKU_DATABASE_URL" + pure + StandaloneRuntime + { settings = + defaultConnectionSettings conn + & #schema .~ schema opts + & #poolSize .~ poolSize opts + , runtimeCommand = standaloneCommand opts + } + +runStandaloneCommand :: StandaloneRuntime -> IO Text +runStandaloneCommand runtime = + withStore (settings runtime) $ \store -> + renderStandaloneCommand store (runtimeCommand runtime) + +renderStandaloneCommand :: KirokuStore -> KirokuCommand -> IO Text +renderStandaloneCommand _ KirokuNoCommand = + pure "No Kiroku operator command was selected." +renderStandaloneCommand store (KirokuSubscriptions (SubscriptionStatus (StatusOptions format))) = do + snapshot <- subscriptionStates store + let rows = subscriptionStatusRows snapshot + rendered = renderSubscriptionStatusRows format rows + pure $ + case (format, rows) of + (OutputTable, []) -> + rendered + <> "No live subscriptions in this process-local registry. Standalone status cannot inspect subscriptions running in another service process." + _ -> rendered diff --git a/src/Kiroku/Cli/Subscription/Status.hs b/src/Kiroku/Cli/Subscription/Status.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Cli/Subscription/Status.hs @@ -0,0 +1,93 @@ +module Kiroku.Cli.Subscription.Status ( + SubscriptionStatusRow (..), + renderSubscriptionStatusRows, + subscriptionStatusRows, +) where + +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy qualified as LBS +import Data.Int (Int32, Int64) +import Data.List (sortOn) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Kiroku.Cli.Command (OutputFormat (..)) +import Kiroku.Store.Subscription (SubscriptionStateView (..)) +import Kiroku.Store.Subscription.Types (SubscriptionName (..)) +import Kiroku.Store.Types (GlobalPosition (..)) + +data SubscriptionStatusRow = SubscriptionStatusRow + { rowSubscription :: !Text + , rowMember :: !Int32 + , rowPhase :: !Text + , rowGlobalPosition :: !Int64 + } + deriving stock (Eq, Show) + +subscriptionStatusRows :: Map (SubscriptionName, Int32) SubscriptionStateView -> [SubscriptionStatusRow] +subscriptionStatusRows = + sortOn (\row -> (rowSubscription row, rowMember row)) + . fmap toRow + . Map.elems + where + toRow view = + let SubscriptionName name = subscriptionName view + GlobalPosition position = cursor view + in SubscriptionStatusRow + { rowSubscription = name + , rowMember = member view + , rowPhase = statePhase view + , rowGlobalPosition = position + } + +renderSubscriptionStatusRows :: OutputFormat -> [SubscriptionStatusRow] -> Text +renderSubscriptionStatusRows OutputTable = renderTable +renderSubscriptionStatusRows OutputJson = renderJson + +renderTable :: [SubscriptionStatusRow] -> Text +renderTable rows = + T.unlines (header : fmap renderRow rows) + where + header = + pad subWidth "SUBSCRIPTION" + <> " " + <> pad memberWidth "MEMBER" + <> " " + <> pad phaseWidth "PHASE" + <> " GLOBAL_POSITION" + subWidth = columnWidth "SUBSCRIPTION" (fmap rowSubscription rows) + memberWidth = columnWidth "MEMBER" (fmap (T.pack . show . rowMember) rows) + phaseWidth = columnWidth "PHASE" (fmap rowPhase rows) + renderRow row = + pad subWidth (rowSubscription row) + <> " " + <> pad memberWidth (T.pack (show (rowMember row))) + <> " " + <> pad phaseWidth (rowPhase row) + <> " " + <> T.pack (show (rowGlobalPosition row)) + +columnWidth :: Text -> [Text] -> Int +columnWidth label values = + maximum (T.length label : fmap T.length values) + +pad :: Int -> Text -> Text +pad width value = + value <> T.replicate (width - T.length value) " " + +renderJson :: [SubscriptionStatusRow] -> Text +renderJson = + TE.decodeUtf8 + . LBS.toStrict + . Aeson.encode + . fmap rowJson + where + rowJson row = + Aeson.object + [ "subscription" Aeson..= rowSubscription row + , "member" Aeson..= rowMember row + , "phase" Aeson..= rowPhase row + , "global_position" Aeson..= rowGlobalPosition row + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,265 @@ +module Main where + +import Control.Concurrent (threadDelay) +import Control.Lens ((^.)) +import Data.Aeson qualified as Aeson +import Data.Generics.Labels () +import Data.Int (Int32, Int64) +import Data.List (isInfixOf) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Kiroku.Cli (KirokuCommand (..), kirokuParserInfo, kirokuSubparser, renderKirokuCommandWithStore) +import Kiroku.Cli.Command (OutputFormat (..), StatusOptions (..), SubscriptionCommand (..)) +import Kiroku.Cli.Standalone (StandaloneOptions (..), StandaloneRuntime (..), resolveStandaloneOptions, runStandaloneCommand, standaloneParserInfo) +import Kiroku.Cli.Subscription.Status (SubscriptionStatusRow (..), renderSubscriptionStatusRows, subscriptionStatusRows) +import Kiroku.Store +import Kiroku.Store.Subscription.Fsm (SubscriptionState (..)) +import Kiroku.Test.Postgres (withMigratedTestDatabase) +import Options.Applicative ( + Parser, + ParserInfo, + ParserResult (..), + command, + defaultPrefs, + execParserPure, + fullDesc, + helper, + info, + progDesc, + renderFailure, + subparser, + (<**>), + ) +import Test.Hspec + +data HostCommand + = 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" + + 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)) + 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)) + 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" + + 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))) + 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." + + describe "standaloneParserInfo" $ do + it "parses process options separately from the Kiroku command" $ do + case execParserPure defaultPrefs standaloneParserInfo ["--database-url", "postgres://flag", "--schema", "ops", "--pool-size", "3", "subscriptions", "status", "--format", "json"] of + Success parsed -> + parsed + `shouldBe` StandaloneOptions + { databaseUrl = Just "postgres://flag" + , schema = "ops" + , poolSize = 3 + , standaloneCommand = KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputJson)) + } + other -> expectationFailure ("expected parser success, got " <> renderedHelp other) + + it "resolves database URL from the environment when the flag is absent" $ do + case execParserPure defaultPrefs standaloneParserInfo ["subscriptions", "status"] of + Success parsed -> + case resolveStandaloneOptions [("KIROKU_DATABASE_URL", "postgres://env")] parsed of + Right StandaloneRuntime{settings = settings, runtimeCommand = parsedCommand} -> do + settings ^. #connString `shouldBe` "postgres://env" + settings ^. #schema `shouldBe` "kiroku" + settings ^. #poolSize `shouldBe` 2 + parsedCommand `shouldBe` KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputTable)) + Left err -> expectationFailure ("expected resolved runtime, got " <> show err) + other -> expectationFailure ("expected parser success, got " <> renderedHelp other) + + it "lets --database-url override the environment and rejects invalid pool sizes" $ do + let opts = + StandaloneOptions + { databaseUrl = Just "postgres://flag" + , schema = "ops" + , poolSize = 0 + , standaloneCommand = KirokuNoCommand + } + case resolveStandaloneOptions [("KIROKU_DATABASE_URL", "postgres://env")] opts of + Left err -> err `shouldBe` "kiroku: --pool-size must be greater than zero" + Right _ -> expectationFailure "expected invalid pool size to fail" + + it "requires a database URL from either flag or environment" $ do + let opts = + StandaloneOptions + { databaseUrl = Nothing + , schema = "kiroku" + , poolSize = 2 + , standaloneCommand = KirokuNoCommand + } + case resolveStandaloneOptions [] opts of + Left err -> err `shouldBe` "kiroku: missing database connection string; pass --database-url or set KIROKU_DATABASE_URL" + Right _ -> expectationFailure "expected missing database URL to fail" + + 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" + + 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) + ] + ] + + 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))) + 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)))) + output `shouldBe` "[]" + + describe "runStandaloneCommand" $ do + it "opens a migrated store and reports an empty process-local registry successfully" $ + withMigratedTestDatabase $ \connStr -> do + let opts = + StandaloneOptions + { databaseUrl = Just connStr + , schema = "kiroku" + , poolSize = 2 + , standaloneCommand = KirokuSubscriptions (SubscriptionStatus (StatusOptions OutputTable)) + } + case resolveStandaloneOptions [] opts of + Left err -> expectationFailure ("expected resolved runtime, got " <> show err) + Right runtime -> do + output <- runStandaloneCommand runtime + output `shouldSatisfy` T.isInfixOf "SUBSCRIPTION" + output `shouldSatisfy` T.isInfixOf "No live subscriptions in this process-local registry" + +hostParserInfo :: ParserInfo HostCommand +hostParserInfo = + info + (hostCommandParser <**> helper) + (fullDesc <> progDesc "Fake host CLI used to prove parser embedding.") + +hostCommandParser :: Parser HostCommand +hostCommandParser = + subparser + ( command + "host" + (info (pure HostOnly) (progDesc "Run a host-only command.")) + <> kirokuSubparser HostKiroku + ) + +runHostCommand :: KirokuStore -> HostCommand -> IO Text +runHostCommand _ HostOnly = + pure "host command" +runHostCommand store (HostKiroku kirokuCommand) = + renderKirokuCommandWithStore store kirokuCommand + +renderedHelp :: ParserResult a -> String +renderedHelp (Failure failure) = + fst (renderFailure failure "test") +renderedHelp (Success _) = + "" +renderedHelp (CompletionInvoked _) = + "" + +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 + } + +withTestStore :: (KirokuStore -> IO ()) -> IO () +withTestStore 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 + } + +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