diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,24 @@ +# Changelog + +## 0.1.0.0 — 2026-07-14 + +### Added + +- Added commands for memory and session demonstrations, hybrid recall, manual L1 distillation, L2 + scenes, L3 personas, and background workers. +- Added one-shot embedding backfill, timer processing, continuous worker supervision, startup + backfill, and graceful worker draining. +- Added parser validation for session identifiers, scope references, mutually exclusive worker + modes, and bounded result limits. + +### Fixed + +- Wired recall-based merge candidates into timer-driven distillation. +- Allowed colons in scope references while preserving namespace and kind boundaries. + +### Changed + +- `demo` and `demo-session` now require `--yes-write-events`, redact database credentials in their + warning, and write only to the isolated `kioku_demo/demo/demo` scope. +- Session arguments now require the `kioku_session` prefix instead of silently rebranding other + TypeID prefixes. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2026, Nadeem Bitar +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Kioku.Cli qualified + +main :: IO () +main = Kioku.Cli.main diff --git a/kioku-cli.cabal b/kioku-cli.cabal new file mode 100644 --- /dev/null +++ b/kioku-cli.cabal @@ -0,0 +1,94 @@ +cabal-version: 3.0 +name: kioku-cli +version: 0.1.0.0 +synopsis: kioku command-line interface +description: + Command-line entry point for kioku demos and operational commands. + +license: BSD-3-Clause +license-file: LICENSE +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: 2026 Nadeem Bitar +category: Data +build-type: Simple +tested-with: GHC >=9.12 && <9.13 +homepage: https://github.com/shinzui/kioku +bug-reports: https://github.com/shinzui/kioku/issues +extra-doc-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/shinzui/kioku.git + subdir: kioku-cli + +common warnings + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + +common shared + default-language: GHC2024 + default-extensions: + BlockArguments + DeriveAnyClass + DuplicateRecordFields + MultilineStrings + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + QualifiedDo + TemplateHaskell + +library + import: warnings, shared + hs-source-dirs: src + exposed-modules: + Kioku.Cli + Kioku.Cli.Commands.Demo + Kioku.Cli.Commands.DemoSession + Kioku.Cli.Commands.Distill + Kioku.Cli.Commands.Persona + Kioku.Cli.Commands.Recall + Kioku.Cli.Commands.Scenes + Kioku.Cli.Commands.Worker + Kioku.Cli.Options + Kioku.Cli.Scope + + build-depends: + , async >=2.2 && <2.3 + , base >=4.21 && <5 + , containers >=0.6 && <0.8 + , effectful >=2.5 && <2.7 + , kioku-api ^>=0.1.0.0 + , kioku-core ^>=0.1.0.0 + , kiroku-store ^>=0.3.0.1 + , optparse-applicative >=0.18 && <0.20 + , text >=2.1 && <2.2 + , time >=1.12 && <1.15 + +executable kioku + import: warnings, shared + main-is: Main.hs + hs-source-dirs: app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , base >=4.21 && <5 + , kioku-cli ^>=0.1.0.0 + +test-suite kioku-cli-test + import: warnings, shared + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: Kioku.Cli.ParserSpec + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , base >=4.21 && <5 + , kioku-api ^>=0.1.0.0 + , kioku-cli ^>=0.1.0.0 + , kioku-core ^>=0.1.0.0 + , optparse-applicative >=0.18 + , tasty >=1.5 + , tasty-hunit >=0.10 + , text >=2.1 diff --git a/src/Kioku/Cli.hs b/src/Kioku/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Cli.hs @@ -0,0 +1,60 @@ +module Kioku.Cli + ( main, + ) +where + +import Kioku.Cli.Commands.Demo (DemoOptions, demoOptionsParser, runDemo) +import Kioku.Cli.Commands.DemoSession (DemoSessionOptions, demoSessionOptionsParser, runDemoSession) +import Kioku.Cli.Commands.Distill (DistillOptions, distillOptionsParser, runDistill) +import Kioku.Cli.Commands.Persona (PersonaOptions, personaOptionsParser, runPersona) +import Kioku.Cli.Commands.Recall (RecallOptions, recallOptionsParser, runRecall) +import Kioku.Cli.Commands.Scenes (ScenesOptions, runScenes, scenesOptionsParser) +import Kioku.Cli.Commands.Worker (WorkerOptions, runWorker, workerOptionsParser) +import Options.Applicative + +data Command = Demo DemoOptions | DemoSession DemoSessionOptions | Distill DistillOptions | Persona PersonaOptions | Recall RecallOptions | Scenes ScenesOptions | Worker WorkerOptions + +main :: IO () +main = run =<< execParser opts + where + opts = + info + (commandParser <**> helper) + ( fullDesc + <> progDesc "kioku reusable agent memory tools" + <> header "kioku" + ) + +commandParser :: Parser Command +commandParser = + subparser $ + command + "demo" + (info (Demo <$> (helper <*> demoOptionsParser)) (progDesc "Run the memory/session demonstration (writes permanent events)")) + <> command + "demo-session" + (info (DemoSession <$> (helper <*> demoSessionOptionsParser)) (progDesc "Run the session aggregate demonstration (writes permanent events)")) + <> command + "distill" + (info (Distill <$> (helper <*> distillOptionsParser)) (progDesc "Run distillation commands")) + <> command + "persona" + (info (Persona <$> (helper <*> personaOptionsParser)) (progDesc "Print distilled L3 persona")) + <> command + "recall" + (info (Recall <$> (helper <*> recallOptionsParser)) (progDesc "Recall memories by query")) + <> command + "scenes" + (info (Scenes <$> (helper <*> scenesOptionsParser)) (progDesc "Print distilled L2 scenes")) + <> command + "worker" + (info (Worker <$> (helper <*> workerOptionsParser)) (progDesc "Run kioku background workers")) + +run :: Command -> IO () +run (Demo opts) = runDemo opts +run (DemoSession opts) = runDemoSession opts +run (Distill opts) = runDistill opts +run (Persona opts) = runPersona opts +run (Recall opts) = runRecall opts +run (Scenes opts) = runScenes opts +run (Worker opts) = runWorker opts diff --git a/src/Kioku/Cli/Commands/Demo.hs b/src/Kioku/Cli/Commands/Demo.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Cli/Commands/Demo.hs @@ -0,0 +1,93 @@ +module Kioku.Cli.Commands.Demo + ( DemoOptions (..), + demoOptionsParser, + demoScope, + runDemo, + ) +where + +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time (getCurrentTime) +import Kioku.Api.Scope (MemoryScope (..), Namespace (..), ScopeKind (..)) +import Kioku.Api.Types (Confidence (..), MemoryRecord (..), MemoryType (..)) +import Kioku.App (runAppIO, withNoopAppEnv) +import Kioku.Cli.Options (redactConnectionString, yesWriteEventsFlag) +import Kioku.Id (genMemoryId, idText) +import Kioku.Memory qualified as Memory +import Kioku.Memory.Domain (RecordMemoryData (..)) +import Kioku.Recall qualified as Recall +import Kiroku.Store.Connection (defaultConnectionSettings) +import Options.Applicative +import System.Environment (lookupEnv) + +data DemoOptions = DemoOptions + deriving stock (Eq, Show) + +demoOptionsParser :: Parser DemoOptions +demoOptionsParser = DemoOptions <$ yesWriteEventsFlag + +-- | The demo writes into a namespace nothing else reads. +-- +-- It used to write into @rei:intention:intention_demo@ — the same namespace real Rei data +-- lives in — and those events are permanent, because kioku has no delete. They also fed the +-- distillation timers. A dedicated @kioku_demo@ namespace makes demo residue unmistakable and +-- keeps distillation of demo data confined to a namespace nothing else reads. +demoScope :: MemoryScope +demoScope = ScopeEntity (Namespace "kioku_demo") (ScopeKind "demo") "demo" + +runDemo :: DemoOptions -> IO () +runDemo DemoOptions = do + connStr <- requireEnv "PG_CONNECTION_STRING" + putStrLn "kioku demo appends permanent memory events (kioku has no delete)." + putStrLn ("Target: " <> Text.unpack (redactConnectionString (Text.pack connStr))) + putStrLn "Scope: kioku_demo/demo/demo" + withNoopAppEnv (defaultConnectionSettings (Text.pack connStr)) \env -> do + mid <- genMemoryId + now <- getCurrentTime + let scope = demoScope + payload = + RecordMemoryData + { memoryId = mid, + agentId = "demo-agent", + sessionId = Nothing, + scope = scope, + memoryType = MemoryPreference, + content = "prefers concise answers", + priority = 100, + confidence = HighConfidence, + tags = Set.fromList ["style"], + supersedes = Nothing, + recordedAt = now + } + result <- runAppIO env do + writeResult <- Memory.record payload + recallResult <- Recall.getActiveByScope scope + pure (writeResult, recallResult) + case result of + Left storeErr -> ioError (userError ("kioku demo store error: " <> show storeErr)) + Right (Left writeErr, _) -> ioError (userError ("kioku demo write error: " <> show writeErr)) + Right (Right writtenId, Left recallErr) -> + ioError (userError ("kioku demo recall error after writing " <> show writtenId <> ": " <> show recallErr)) + Right (Right writtenId, Right records) -> do + putStrLn ("Recorded memory " <> Text.unpack (idText writtenId) <> " in scope kioku_demo/demo/demo") + mapM_ printRecord records + +requireEnv :: String -> IO String +requireEnv name = do + found <- lookupEnv name + case found of + Just value -> pure value + Nothing -> ioError (userError (name <> " is not set")) + +printRecord :: MemoryRecord -> IO () +printRecord record = + putStrLn $ + "- " + <> Text.unpack record.memoryId + <> " [" + <> Text.unpack record.memoryType + <> "/" + <> Text.unpack record.confidence + <> "] " + <> Text.unpack record.content diff --git a/src/Kioku/Cli/Commands/DemoSession.hs b/src/Kioku/Cli/Commands/DemoSession.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Cli/Commands/DemoSession.hs @@ -0,0 +1,103 @@ +module Kioku.Cli.Commands.DemoSession + ( DemoSessionOptions (..), + demoSessionOptionsParser, + runDemoSession, + ) +where + +import Data.Text qualified as Text +import Data.Time (getCurrentTime) +import Kioku.App (runAppIO, withNoopAppEnv) +import Kioku.Cli.Commands.Demo (demoScope) +import Kioku.Cli.Options (redactConnectionString, yesWriteEventsFlag) +import Kioku.Id (genSessionId, idText) +import Kioku.Session qualified as Session +import Kioku.Session.Domain (CompleteSessionData (..), RecordTurnData (..), StartSessionData (..)) +import Kioku.Session.ReadModel (SessionRow (..), TurnRow (..)) +import Kiroku.Store.Connection (defaultConnectionSettings) +import Options.Applicative +import System.Environment (lookupEnv) + +data DemoSessionOptions = DemoSessionOptions + deriving stock (Eq, Show) + +demoSessionOptionsParser :: Parser DemoSessionOptions +demoSessionOptionsParser = DemoSessionOptions <$ yesWriteEventsFlag + +runDemoSession :: DemoSessionOptions -> IO () +runDemoSession DemoSessionOptions = do + connStr <- requireEnv "PG_CONNECTION_STRING" + putStrLn "kioku demo-session appends permanent session events (kioku has no delete)." + putStrLn ("Target: " <> Text.unpack (redactConnectionString (Text.pack connStr))) + putStrLn "Scope: kioku_demo/demo/demo" + putStrLn "Note: completing this session schedules a distillation timer; a running worker will process it (an LLM call)." + withNoopAppEnv (defaultConnectionSettings (Text.pack connStr)) \env -> do + sid <- genSessionId + now <- getCurrentTime + let scope = demoScope + startPayload = + StartSessionData + { sessionId = sid, + agentId = "demo-agent", + focus = "demo", + scope = scope, + subjectRef = Just "demo", + previousSessionId = Nothing, + parentSessionId = Nothing, + delegationDepth = 0, + startedAt = now + } + turnPayload = + RecordTurnData + { sessionId = sid, + turnId = idText sid <> "-turn-1", + turnIndex = 1, + role = "user", + content = "Please remember I prefer concise answers.", + toolSummary = Nothing, + promptTokens = Just 7, + outputTokens = Nothing, + recordedAt = now + } + completePayload = + CompleteSessionData + { sessionId = sid, + completedAt = now, + modelUsed = Just "demo-model", + summary = Just "Demo session completed" + } + result <- runAppIO env do + startResult <- Session.start startPayload + turnResult <- Session.recordTurn turnPayload + completeResult <- Session.complete completePayload + rowResult <- Session.getById sid + turnsResult <- Session.getTurns sid + pure (startResult, turnResult, completeResult, rowResult, turnsResult) + case result of + Left storeErr -> ioError (userError ("kioku session demo store error: " <> show storeErr)) + Right (Left writeErr, _, _, _, _) -> ioError (userError ("kioku session demo start error: " <> show writeErr)) + Right (_, Left writeErr, _, _, _) -> ioError (userError ("kioku session demo turn error: " <> show writeErr)) + Right (_, _, Left writeErr, _, _) -> ioError (userError ("kioku session demo complete error: " <> show writeErr)) + Right (_, _, _, Left readErr, _) -> ioError (userError ("kioku session demo read error: " <> show readErr)) + Right (_, _, _, _, Left readErr) -> ioError (userError ("kioku session demo turns read error: " <> show readErr)) + Right (_, _, _, Right Nothing, Right _) -> ioError (userError "kioku session demo did not project the session row") + Right (_, _, _, Right (Just row), Right turns) -> do + putStrLn ("Recorded session " <> Text.unpack (idText sid) <> " with status " <> Text.unpack row.status) + mapM_ printTurn turns + +requireEnv :: String -> IO String +requireEnv name = do + found <- lookupEnv name + case found of + Just value -> pure value + Nothing -> ioError (userError (name <> " is not set")) + +printTurn :: TurnRow -> IO () +printTurn turn = + putStrLn $ + "- turn " + <> show turn.turnIndex + <> " " + <> Text.unpack turn.role + <> ": " + <> Text.unpack turn.content diff --git a/src/Kioku/Cli/Commands/Distill.hs b/src/Kioku/Cli/Commands/Distill.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Cli/Commands/Distill.hs @@ -0,0 +1,131 @@ +module Kioku.Cli.Commands.Distill + ( CandidateSource (..), + DistillOptions (..), + distillOptionsParser, + runDistill, + ) +where + +import Data.Text qualified as Text +import Kioku.App (runAppIO, withNoopAppEnv) +import Kioku.Cli.Options (boundedIntReader) +import Kioku.Distill.L1 (L1Outcome (..), L1RunMode (..), L1Summary (..), distillSessionL1, recallCandidates, scopedScanCandidates) +import Kioku.Distill.Runtime (newDistillRuntime) +import Kioku.Id (SessionId, idText, parseId) +import Kioku.Memory.Embedding (EmbeddingConfig (..), resolveEmbeddingConfig, toEmbeddingModel) +import Kioku.Recall.Capability (detectVectorCapability) +import Kiroku.Store.Connection (defaultConnectionSettings) +import Options.Applicative +import System.Environment (lookupEnv) + +data CandidateSource = CandidateScan | CandidateRecall + deriving stock (Eq, Show) + +data DistillOptions = DistillOptions + { sessionId :: !SessionId, + candidateSource :: !CandidateSource, + candidateLimit :: !Int, + force :: !Bool + } + deriving stock (Eq, Show) + +distillOptionsParser :: Parser DistillOptions +distillOptionsParser = + hsubparser $ + command + "session" + ( info + sessionOptionsParser + (progDesc "Run one L1 distillation pass for a session") + ) + +sessionOptionsParser :: Parser DistillOptions +sessionOptionsParser = + DistillOptions + <$> argument + (eitherReader parseSessionId) + (metavar "SESSION_ID") + <*> option + (eitherReader parseCandidateSource) + ( long "candidates" + <> metavar "scan|recall" + <> value CandidateScan + <> help "Candidate lookup source" + ) + <*> option + (boundedIntReader "LIMIT" 1 50) + ( long "limit" + <> metavar "N" + <> value 5 + <> help "Maximum merge candidates per extracted atom (1-50)" + ) + <*> switch + ( long "force" + <> help "Re-run even when the session has no turns newer than the last successful pass" + ) + +runDistill :: DistillOptions -> IO () +runDistill opts = do + connStr <- requireEnv "PG_CONNECTION_STRING" + rt <- newDistillRuntime + recallConfig <- + case opts.candidateSource of + CandidateScan -> pure Nothing + CandidateRecall -> Just <$> resolveEmbeddingConfig + withNoopAppEnv (defaultConnectionSettings (Text.pack connStr)) \env -> do + result <- runAppIO env do + finder <- + case (opts.candidateSource, recallConfig) of + (CandidateRecall, Just config) -> do + capability <- detectVectorCapability config.dimensions + pure (recallCandidates (toEmbeddingModel config) capability opts.candidateLimit) + _ -> + pure (scopedScanCandidates opts.candidateLimit) + distillSessionL1 (runMode opts) rt finder opts.sessionId + case result of + Left storeErr -> ioError (userError ("kioku distill store error: " <> show storeErr)) + Right (Left l1Err) -> ioError (userError ("kioku distill error: " <> show l1Err)) + Right (Right (L1Distilled summary)) -> printSummary opts.sessionId summary + Right (Right L1SkippedUpToDate) -> + putStrLn "Session already distilled (no new turns); use --force to re-run." + +runMode :: DistillOptions -> L1RunMode +runMode opts + | opts.force = IgnoreWatermark + | otherwise = RespectWatermark + +-- | Strict: only a @kioku_session@ id is accepted here. The lenient parser this used to call +-- would take a @kioku_memory@ id, throw its prefix away, and rebrand the UUID — so the pass ran +-- against a session that does not exist and reported nothing wrong. +parseSessionId :: String -> Either String SessionId +parseSessionId raw = + case parseId (Text.pack raw) of + Left err -> Left (Text.unpack err) + Right sid -> Right sid + +parseCandidateSource :: String -> Either String CandidateSource +parseCandidateSource = \case + "scan" -> Right CandidateScan + "recall" -> Right CandidateRecall + other -> Left ("unknown candidate source: " <> other) + +printSummary :: SessionId -> L1Summary -> IO () +printSummary sid summary = + putStrLn $ + "Distilled session " + <> Text.unpack (idText sid) + <> ": extracted=" + <> show summary.extracted + <> " stored=" + <> show summary.stored + <> " merged=" + <> show summary.merged + <> " skipped=" + <> show summary.skipped + +requireEnv :: String -> IO String +requireEnv name = do + found <- lookupEnv name + case found of + Just envValue -> pure envValue + Nothing -> ioError (userError (name <> " is not set")) diff --git a/src/Kioku/Cli/Commands/Persona.hs b/src/Kioku/Cli/Commands/Persona.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Cli/Commands/Persona.hs @@ -0,0 +1,51 @@ +module Kioku.Cli.Commands.Persona + ( PersonaOptions (..), + personaOptionsParser, + runPersona, + ) +where + +import Data.Text qualified as Text +import Kioku.Api.Scope (MemoryScope) +import Kioku.App (runAppIO, withNoopAppEnv) +import Kioku.Cli.Scope (parseScope) +import Kioku.Distill.L3 (PersonaRow (..), getPersonaByScope) +import Kiroku.Store.Connection (defaultConnectionSettings) +import Options.Applicative +import System.Environment (lookupEnv) + +newtype PersonaOptions = PersonaOptions + { scope :: MemoryScope + } + deriving stock (Eq, Show) + +personaOptionsParser :: Parser PersonaOptions +personaOptionsParser = + PersonaOptions + <$> option + (eitherReader parseScope) + ( long "scope" + <> metavar "NAMESPACE[:KIND:REF]" + <> help "Memory scope whose persona should be printed; REF may contain ':'" + ) + +runPersona :: PersonaOptions -> IO () +runPersona opts = do + connStr <- requireEnv "PG_CONNECTION_STRING" + withNoopAppEnv (defaultConnectionSettings (Text.pack connStr)) \env -> do + result <- runAppIO env (getPersonaByScope opts.scope) + case result of + Left storeErr -> ioError (userError ("kioku persona store error: " <> show storeErr)) + Right Nothing -> putStrLn "(no persona yet)" + Right (Just persona) -> printPersona persona + +printPersona :: PersonaRow -> IO () +printPersona row = + putStrLn (Text.unpack row.bodyMd) + +requireEnv :: String -> IO String +requireEnv name = do + found <- lookupEnv name + case found of + Just envValue -> pure envValue + Nothing -> ioError (userError (name <> " is not set")) diff --git a/src/Kioku/Cli/Commands/Recall.hs b/src/Kioku/Cli/Commands/Recall.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Cli/Commands/Recall.hs @@ -0,0 +1,121 @@ +module Kioku.Cli.Commands.Recall + ( RecallOptions (..), + recallOptionsParser, + runRecall, + ) +where + +import Data.Text (Text) +import Data.Text qualified as Text +import Kioku.Api.Scope (MemoryScope) +import Kioku.Api.Types (MemoryRecord (..)) +import Kioku.App (runAppIO, withNoopAppEnv) +import Kioku.Cli.Options (boundedIntReader) +import Kioku.Cli.Scope (parseScope) +import Kioku.Memory.Embedding (EmbeddingConfig (..), resolveEmbeddingConfig, toEmbeddingModel) +import Kioku.Recall (RecallHit (..), RecallRequest (..), RecallStrategy (..), recall) +import Kioku.Recall.Capability (detectVectorCapability) +import Kiroku.Store.Connection (defaultConnectionSettings) +import Options.Applicative +import System.Environment (lookupEnv) +import Text.Printf (printf) + +data RecallOptions = RecallOptions + { query :: !Text, + scope :: !MemoryScope, + strategy :: !RecallStrategy, + limit :: !Int, + showScores :: !Bool + } + deriving stock (Eq, Show) + +recallOptionsParser :: Parser RecallOptions +recallOptionsParser = + RecallOptions + <$> (Text.pack <$> argument str (metavar "QUERY")) + <*> option + (eitherReader parseScope) + ( long "scope" + <> metavar "NAMESPACE[:KIND:REF]" + <> help "Memory scope to search; REF may contain ':'" + ) + <*> option + (eitherReader parseStrategy) + ( long "strategy" + <> metavar "keyword|embedding|hybrid" + <> value Hybrid + <> help "Recall strategy" + ) + <*> option + (boundedIntReader "LIMIT" 1 100) + ( long "limit" + <> metavar "N" + <> value 8 + <> help "Maximum hits to return (1-100)" + ) + <*> switch + ( long "show-scores" + <> help "Print fused scores and component ranks" + ) + +runRecall :: RecallOptions -> IO () +runRecall opts = do + connStr <- requireEnv "PG_CONNECTION_STRING" + config <- resolveEmbeddingConfig + withNoopAppEnv (defaultConnectionSettings (Text.pack connStr)) \env -> do + let model = toEmbeddingModel config + request = + RecallRequest + { scope = opts.scope, + query = opts.query, + strategy = opts.strategy, + maxResults = opts.limit + } + result <- runAppIO env do + capability <- detectVectorCapability config.dimensions + recall model capability request + case result of + Left storeErr -> ioError (userError ("kioku recall store error: " <> show storeErr)) + Right [] -> putStrLn "(no matches)" + Right hits -> mapM_ (printHit opts.showScores) (zip [(1 :: Int) ..] hits) + +parseStrategy :: String -> Either String RecallStrategy +parseStrategy = \case + "keyword" -> Right Keyword + "embedding" -> Right Embedding + "hybrid" -> Right Hybrid + other -> Left ("unknown strategy: " <> other) + +printHit :: Bool -> (Int, RecallHit) -> IO () +printHit showScores (index, hit) + | showScores = + putStrLn $ + show index + <> ". score=" + <> printf "%.4f" hit.score + <> " fts=" + <> rankText hit.ftsRank + <> " vec=" + <> rankText hit.vecRank + <> " " + <> Text.unpack hit.memory.memoryType + <> " " + <> show (Text.unpack hit.memory.content) + | otherwise = + putStrLn $ + show index + <> ". " + <> Text.unpack hit.memory.memoryType + <> " " + <> show (Text.unpack hit.memory.content) + +rankText :: Maybe Int -> String +rankText Nothing = "-" +rankText (Just rank) = show rank + +requireEnv :: String -> IO String +requireEnv name = do + found <- lookupEnv name + case found of + Just envValue -> pure envValue + Nothing -> ioError (userError (name <> " is not set")) diff --git a/src/Kioku/Cli/Commands/Scenes.hs b/src/Kioku/Cli/Commands/Scenes.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Cli/Commands/Scenes.hs @@ -0,0 +1,53 @@ +module Kioku.Cli.Commands.Scenes + ( ScenesOptions (..), + runScenes, + scenesOptionsParser, + ) +where + +import Data.Text qualified as Text +import Kioku.Api.Scope (MemoryScope) +import Kioku.App (runAppIO, withNoopAppEnv) +import Kioku.Cli.Scope (parseScope) +import Kioku.Distill.L2 (SceneRow (..), getScenesByScope) +import Kiroku.Store.Connection (defaultConnectionSettings) +import Options.Applicative +import System.Environment (lookupEnv) + +newtype ScenesOptions = ScenesOptions + { scope :: MemoryScope + } + deriving stock (Eq, Show) + +scenesOptionsParser :: Parser ScenesOptions +scenesOptionsParser = + ScenesOptions + <$> option + (eitherReader parseScope) + ( long "scope" + <> metavar "NAMESPACE[:KIND:REF]" + <> help "Memory scope whose scenes should be printed; REF may contain ':'" + ) + +runScenes :: ScenesOptions -> IO () +runScenes opts = do + connStr <- requireEnv "PG_CONNECTION_STRING" + withNoopAppEnv (defaultConnectionSettings (Text.pack connStr)) \env -> do + result <- runAppIO env (getScenesByScope opts.scope) + case result of + Left storeErr -> ioError (userError ("kioku scenes store error: " <> show storeErr)) + Right [] -> putStrLn "(no scenes)" + Right scenes -> mapM_ printScene scenes + +printScene :: SceneRow -> IO () +printScene row = do + putStrLn ("# " <> Text.unpack row.title) + putStrLn "" + putStrLn (Text.unpack row.bodyMd) + +requireEnv :: String -> IO String +requireEnv name = do + found <- lookupEnv name + case found of + Just envValue -> pure envValue + Nothing -> ioError (userError (name <> " is not set")) diff --git a/src/Kioku/Cli/Commands/Worker.hs b/src/Kioku/Cli/Commands/Worker.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Cli/Commands/Worker.hs @@ -0,0 +1,237 @@ +module Kioku.Cli.Commands.Worker + ( WorkerOptions (..), + workerOptionsParser, + runWorker, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (race) +import Control.Exception (SomeException, displayException, try) +import Data.Text qualified as Text +import Data.Time (getCurrentTime) +import Effectful (IOE, (:>)) +import Kioku.App (AppEnv, runAppIO, withNoopAppEnv) +import Kioku.Distill.L1 (FindMergeCandidates, recallCandidates) +import Kioku.Distill.Runtime (newDistillRuntime) +import Kioku.Distill.Timer.Worker (drainKiokuTimers, runKiokuTimerWorkerOnce) +import Kioku.Memory.Embedding (EmbeddingConfig (..), resolveEmbeddingConfig, toEmbeddingModel) +import Kioku.Memory.Embedding.Worker (backfillMissingEmbeddings, runEmbeddingWorkerHost) +import Kioku.Recall.Capability (VectorCapability (..), detectVectorCapability) +import Kiroku.Store.Connection (KirokuStore, defaultConnectionSettings, withStore) +import Kiroku.Store.Effect (Store) +import Options.Applicative +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..), exitWith) +import System.IO (hPutStrLn, stderr) + +-- | The two one-shot modes are unrelated — an embedding backfill and firing one distillation +-- timer — so there is no combined meaning to define. As two 'switch'es they were silently +-- ordered: @--backfill --timers-once@ checked @timersOnce@ first and ignored @--backfill@ +-- without a word. As a sum parsed from mutually exclusive alternatives, passing both is a +-- parse error. +data WorkerOptions + = WorkerContinuous + | WorkerBackfill + | WorkerTimersOnce + deriving stock (Eq, Show) + +workerOptionsParser :: Parser WorkerOptions +workerOptionsParser = + flag' + WorkerBackfill + ( long "backfill" + <> help "Run one embedding backfill pass and exit (conflicts with --timers-once)" + ) + <|> flag' + WorkerTimersOnce + ( long "timers-once" + <> help "Claim and fire at most one due kioku distillation timer, then exit (conflicts with --backfill)" + ) + <|> pure WorkerContinuous + +runWorker :: WorkerOptions -> IO () +runWorker opts = do + connStr <- requireEnv "PG_CONNECTION_STRING" + config <- resolveEmbeddingConfig + let settings = defaultConnectionSettings (Text.pack connStr) + withStore settings $ \st -> + withNoopAppEnv settings \env -> + case opts of + WorkerTimersOnce -> runTimerOnce env config + WorkerBackfill -> withCapability env config \capability -> + runBackfill env capability config + WorkerContinuous -> withCapability env config \capability -> + runContinuousWorker env st capability config + +withCapability :: AppEnv -> EmbeddingConfig -> (VectorCapability -> IO a) -> IO a +withCapability env config k = do + result <- runAppIO env (detectVectorCapability config.dimensions) + case result of + Left storeErr -> ioError (userError ("kioku worker store error: " <> show storeErr)) + Right capability -> k capability + +-- | Merge candidates come from hybrid recall over the atom's own text, not from +-- a priority-ordered scan prefix: a duplicate ranked below the scan window was +-- invisible to the consolidator and got re-stored forever. Recall degrades to +-- FTS-only without pgvector and to keyword-only when the embedding call fails, +-- so no capability gating is needed here. +mergeCandidateFinder :: + (IOE :> es, Store :> es) => + EmbeddingConfig -> + VectorCapability -> + FindMergeCandidates es +mergeCandidateFinder config capability = + recallCandidates (toEmbeddingModel config) capability mergeCandidateLimit + +mergeCandidateLimit :: Int +mergeCandidateLimit = 8 + +runBackfill :: AppEnv -> VectorCapability -> EmbeddingConfig -> IO () +runBackfill env capability config = do + -- Refuse before any event is touched: a backfill under a mismatched dimension count would + -- embed every memory in the store and fail the ::vector cast on every single one. + case capability of + VectorDimensionMismatch configured actual -> + dieWorker (dimensionMismatchMessage configured actual) + _ -> pure () + let model = toEmbeddingModel config + result <- runAppIO env (backfillMissingEmbeddings capability model config.dimensions) + case result of + Left storeErr -> ioError (userError ("kioku worker backfill store error: " <> show storeErr)) + Right count -> putStrLn ("Backfilled " <> show count <> " memory embeddings.") + +-- | Run both pipelines under supervision. +-- +-- The timer loop used to run on a bare 'forkIO', which produced two silent +-- deaths. A store error aborted the loop's single error scope and killed only +-- the forked thread, leaving a process that looked alive while all distillation +-- had stopped. In the other direction, an embedding halt made shibuya exit its +-- processor gracefully, 'waitApp' return, and the whole process exit 0 — taking +-- the timer loop with it. +-- +-- 'race' makes both directions loud: whichever pipeline stops first ends the +-- race, and the process exits non-zero with a reason so a supervisor restarts +-- it. Neither side is expected to return at all. +runContinuousWorker :: AppEnv -> KirokuStore -> VectorCapability -> EmbeddingConfig -> IO () +runContinuousWorker env store capability config = do + let model = toEmbeddingModel config + case capability of + VectorAvailable -> do + startupBackfill env capability config + outcome <- + try @SomeException $ + race + (runTimerLoop env capability config) + (runAppIO env (runEmbeddingWorkerHost store capability model config.dimensions)) + case outcome of + -- A halted processor can tear its own machinery down hard enough to + -- surface as an exception rather than a clean return (shibuya's halt path + -- can leave a thread blocked in STM). Either way the pipeline is gone; + -- what matters is that the operator gets a reason and a non-zero exit + -- instead of a process that looks alive. + Left err -> + dieWorker ("worker pipeline crashed: " <> displayException err) + Right (Left ()) -> + dieWorker "timer loop stopped unexpectedly" + Right (Right (Left storeErr)) -> + dieWorker ("embedding worker stopped with store error: " <> show storeErr) + Right (Right (Right ())) -> + -- The handler already printed the halt reason at decision time. + dieWorker "embedding worker stopped (processor halted or subscription ended)" + VectorExtensionUnavailable -> do + putStrLn "pgvector is not available; recall will run FTS-only; running kioku timer worker only." + runTimerLoop env capability config + VectorColumnsUnavailable missing -> do + putStrLn ("pgvector columns are missing (" <> Text.unpack (Text.intercalate ", " missing) <> "); running kioku timer worker only.") + runTimerLoop env capability config + -- Loud, but not fatal. Every embedding write would fail on the ::vector cast, so there + -- is no point starting the embedding host — but distillation timers have nothing to do + -- with embeddings, and killing the whole worker would stop them too. + VectorDimensionMismatch configured actual -> do + hPutStrLn stderr ("kioku worker: " <> dimensionMismatchMessage configured actual <> "; running kioku timer worker only.") + runTimerLoop env capability config + +-- | A dimension mismatch would otherwise be discovered one failed event at a time, forever. +dimensionMismatchMessage :: Int -> Int -> String +dimensionMismatchMessage configured actual = + "embedding dimension mismatch: KIOKU_EMBEDDING_DIMENSIONS=" + <> show configured + <> " but kiroku.kioku_memories.embedding is vector(" + <> show actual + <> "); fix the env var or migrate the column" + +-- | Recover embeddings lost to an outage that outlasted the retry window. +-- Idempotent, so it is safe on every start. A failure here is only a warning: +-- if the database is down, the loops' own retry and exit behavior is the honest +-- place for that to surface, not a special case at startup. +startupBackfill :: AppEnv -> VectorCapability -> EmbeddingConfig -> IO () +startupBackfill env capability config = do + result <- runAppIO env (backfillMissingEmbeddings capability (toEmbeddingModel config) config.dimensions) + case result of + Left storeErr -> + hPutStrLn stderr ("kioku worker: startup backfill failed: " <> show storeErr) + Right count -> + putStrLn ("Startup backfill: embedded " <> show count <> " missing memory embeddings.") + +dieWorker :: String -> IO () +dieWorker msg = do + hPutStrLn stderr ("kioku worker: " <> msg <> "; exiting") + exitWith (ExitFailure 1) + +runTimerOnce :: AppEnv -> EmbeddingConfig -> IO () +runTimerOnce env config = do + rt <- newDistillRuntime + now <- getCurrentTime + result <- runAppIO env do + capability <- detectVectorCapability config.dimensions + runKiokuTimerWorkerOnce Nothing rt (mergeCandidateFinder config capability) now + case result of + Left storeErr -> ioError (userError ("kioku timer worker store error: " <> show storeErr)) + Right Nothing -> putStrLn "No due kioku distillation timers." + Right (Just _) -> putStrLn "Processed one due kioku distillation timer." + +-- | Drain due timers, sleep, repeat — forever. +-- +-- Each pass gets its own 'runAppIO', and therefore its own store-error scope. +-- That is the whole point: the old loop lived inside a single 'runAppIO', so the +-- first transient store error aborted the @forever@ and killed the loop. Here a +-- store error is logged and retried with capped exponential backoff (5s doubling +-- to 60s, reset on success), because a database outage should not require an +-- operator to restart anything — and restarting would not have helped. +-- +-- This never returns normally, so 'race' seeing it finish genuinely means +-- something impossible happened. Non-store exceptions propagate to 'race', which +-- is equally loud. +runTimerLoop :: AppEnv -> VectorCapability -> EmbeddingConfig -> IO () +runTimerLoop env capability config = do + rt <- newDistillRuntime + putStrLn "kioku timer worker started." + let go failures = do + result <- runAppIO env (drainKiokuTimers Nothing rt (mergeCandidateFinder config capability)) + case result of + Left storeErr -> do + hPutStrLn stderr ("kioku timer worker: store error (will retry): " <> show storeErr) + threadDelay (storeErrorBackoffMicros failures) + go (failures + 1) + Right _processed -> do + threadDelay defaultTimerPollMicros + go 0 + go 0 + +-- | 5s doubling per consecutive failure, capped at 60s. +storeErrorBackoffMicros :: Int -> Int +storeErrorBackoffMicros failures = + min (60 * 1000 * 1000) (5 * 1000 * 1000 * (2 ^ min 8 (max 0 failures))) + +-- | With draining, the poll interval no longer caps throughput: a burst of due +-- timers is processed in one pass rather than one per interval. +defaultTimerPollMicros :: Int +defaultTimerPollMicros = 5 * 1000 * 1000 + +requireEnv :: String -> IO String +requireEnv name = do + found <- lookupEnv name + case found of + Just envValue -> pure envValue + Nothing -> ioError (userError (name <> " is not set")) diff --git a/src/Kioku/Cli/Options.hs b/src/Kioku/Cli/Options.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Cli/Options.hs @@ -0,0 +1,66 @@ +-- | Shared option readers and helpers for the kioku CLI. +module Kioku.Cli.Options + ( boundedIntReader, + yesWriteEventsFlag, + redactConnectionString, + ) +where + +import Data.Text (Text) +import Data.Text qualified as Text +import Options.Applicative + +-- | An integer option reader that enforces an inclusive range at parse time. +-- +-- @label@ names the value in the error message, e.g. @\"LIMIT\"@. Without this, @--limit -1@ +-- travelled all the way to Postgres and came back as @LIMIT must not be negative@, and an +-- unbounded large value was a cost and latency footgun rather than a parse error. +boundedIntReader :: String -> Int -> Int -> ReadM Int +boundedIntReader label lo hi = do + n <- auto + if n >= lo && n <= hi + then pure n + else + readerError + (label <> " must be between " <> show lo <> " and " <> show hi <> " (got " <> show n <> ")") + +-- | Required opt-in for a command that appends permanent events. +-- +-- 'flag'' with no default, so omitting it is a parse error (@Missing: --yes-write-events@) and +-- the requirement is visible in @--help@. Deliberately not an environment variable: an +-- exported @KIOKU_ALLOW_DEMO=1@ is sticky state that outlives the moment of consent, which is +-- exactly how accidents happen in a long-lived shell. +yesWriteEventsFlag :: Parser () +yesWriteEventsFlag = + flag' + () + ( long "yes-write-events" + <> help + "Required confirmation: this command appends PERMANENT events (kioku has no delete) to the database at PG_CONNECTION_STRING" + ) + +-- | Best-effort password redaction for printing a libpq connection string. +-- +-- Handles the keyword form (@password=...@) and the URI form (@user:pass\@host@). Best-effort +-- is the honest description: it exists so the preflight can show the operator which database +-- they are about to write to without echoing a secret into a terminal or a CI log. +redactConnectionString :: Text -> Text +redactConnectionString conn = + case Text.stripPrefix "postgres://" conn of + Just rest -> "postgres://" <> redactUserInfo rest + Nothing -> + case Text.stripPrefix "postgresql://" conn of + Just rest -> "postgresql://" <> redactUserInfo rest + Nothing -> Text.unwords (map redactPair (Text.words conn)) + where + redactPair kv + | "password=" `Text.isPrefixOf` kv = "password=REDACTED" + | otherwise = kv + + redactUserInfo rest = + case Text.breakOn "@" rest of + (_, "") -> rest + (userinfo, hostPart) -> + case Text.breakOn ":" userinfo of + (_, "") -> userinfo <> hostPart + (user, _) -> user <> ":REDACTED" <> hostPart diff --git a/src/Kioku/Cli/Scope.hs b/src/Kioku/Cli/Scope.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Cli/Scope.hs @@ -0,0 +1,43 @@ +module Kioku.Cli.Scope + ( parseScope, + scopeGrammarError, + ) +where + +import Data.Text qualified as Text +import Kioku.Api.Scope (MemoryScope (..), mkNamespace, mkScopeKind) + +-- | @NAMESPACE@ or @NAMESPACE:KIND:REF@. +-- +-- Only the first two colons split. Everything after the second colon is the ref, colons +-- included, so a URL or a @host:port@ pair is expressible: @ops:host:db.internal:5432@ has the +-- ref @db.internal:5432@. Splitting on /every/ colon (the old behavior) made those refs +-- unreachable from the CLI — they parsed as four segments and were rejected. +-- +-- Namespace and kind still go through the validating constructors, so a @\/@ or @%@ that would +-- make the scope's derived identity ambiguous is rejected here rather than silently escaped +-- into a row id; a @:@ in either is now impossible by construction rather than by validation. +-- The ref is not validated beyond being non-empty: refs are host free text, and +-- 'Kioku.Distill.ScopeIdentity.escapeScopeComponent' escapes the colons they may now contain, +-- so a colon-bearing ref still gets a collision-free identity. +parseScope :: String -> Either String MemoryScope +parseScope raw = + case Text.breakOn ":" (Text.pack raw) of + (ns, afterNs) + | Text.null afterNs -> ScopeGlobal <$> namespace ns + | otherwise -> + case Text.breakOn ":" (Text.drop 1 afterNs) of + (kind, afterKind) + | Text.null afterKind -> Left scopeGrammarError + | ref <- Text.drop 1 afterKind -> + if Text.null ref + then Left "REF must not be empty" + else ScopeEntity <$> namespace ns <*> scopeKind kind <*> pure ref + where + namespace = first Text.unpack . mkNamespace + scopeKind = first Text.unpack . mkScopeKind + first f = either (Left . f) Right + +scopeGrammarError :: String +scopeGrammarError = + "expected NAMESPACE or NAMESPACE:KIND:REF (REF may contain ':'; NAMESPACE and KIND may not)" diff --git a/test/Kioku/Cli/ParserSpec.hs b/test/Kioku/Cli/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/Kioku/Cli/ParserSpec.hs @@ -0,0 +1,214 @@ +-- | Pure tests for the CLI's parsing boundary: no database, no network, no environment. +-- +-- optparse-applicative parsers are ordinary values, so 'execParserPure' exercises exactly what +-- an operator's argv hits — including the failure text they will read. +module Kioku.Cli.ParserSpec (tests) where + +import Data.List (isInfixOf) +import Data.Text qualified as Text +import Kioku.Api.Scope (MemoryScope (..), Namespace (..), ScopeKind (..)) +import Kioku.Cli.Commands.Demo (DemoOptions (..), demoOptionsParser, demoScope) +import Kioku.Cli.Commands.DemoSession (DemoSessionOptions (..), demoSessionOptionsParser) +import Kioku.Cli.Commands.Distill (DistillOptions (..), distillOptionsParser) +import Kioku.Cli.Commands.Recall (RecallOptions (..), recallOptionsParser) +import Kioku.Cli.Commands.Worker (WorkerOptions (..), workerOptionsParser) +import Kioku.Cli.Options (redactConnectionString) +import Kioku.Cli.Scope (parseScope) +import Kioku.Id (genMemoryId, genSessionId, idText) +import Options.Applicative +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Kioku.Cli parsers" + [ sessionIdTests, + scopeTests, + limitTests, + demoGuardTests, + redactionTests, + workerModeTests + ] + +-- | Run a parser against an argument list, rendering a failure the way the real CLI would. +parseWith :: Parser a -> [String] -> Either String a +parseWith p args = + case execParserPure defaultPrefs (info (p <**> helper) mempty) args of + Success a -> Right a + Failure failure -> Left (fst (renderFailure failure "kioku")) + CompletionInvoked _ -> Left "unexpected completion" + +sessionIdTests :: TestTree +sessionIdTests = + testGroup + "distill session id parsing is strict" + [ testCase "a kioku_session id is accepted" do + sid <- genSessionId + case parseWith distillOptionsParser ["session", Text.unpack (idText sid)] of + Left err -> assertBool ("expected success, got: " <> err) False + Right opts -> opts.sessionId @?= sid, + testCase "a kioku_memory id is rejected, naming both prefixes" do + mid <- genMemoryId + case parseWith distillOptionsParser ["session", Text.unpack (idText mid)] of + Right _ -> + assertBool "expected a memory id to be rejected where a session id is expected" False + Left err -> do + assertBool ("error should name the expected prefix: " <> err) ("kioku_session" `isInfixOf` err) + assertBool ("error should name the received prefix: " <> err) ("kioku_memory" `isInfixOf` err), + testCase "a bare uuid with no prefix is rejected" do + case parseWith distillOptionsParser ["session", "01h455vb4pex5vsknk084sn02q"] of + Right _ -> assertBool "expected a prefixless id to be rejected" False + Left err -> assertBool ("error should name the expected prefix: " <> err) ("kioku_session" `isInfixOf` err) + ] + +-- | The ref is everything after the second colon, colons included; the namespace and kind are +-- not. Splitting on every colon used to make a URL or @host:port@ ref unreachable. +scopeTests :: TestTree +scopeTests = + testGroup + "scope grammar splits on the first two colons only" + [ testCase "a bare namespace is the global scope" do + parseScope "mori" @?= Right (ScopeGlobal (Namespace "mori")), + testCase "a plain entity scope" do + parseScope "rei:intention:intention_demo" + @?= Right (ScopeEntity (Namespace "rei") (ScopeKind "intention") "intention_demo"), + testCase "a ref may contain slashes" do + parseScope "mori:repo:github.com/shinzui/kioku" + @?= Right (ScopeEntity (Namespace "mori") (ScopeKind "repo") "github.com/shinzui/kioku"), + testCase "a host:port ref keeps its colon" do + parseScope "ops:host:db.internal:5432" + @?= Right (ScopeEntity (Namespace "ops") (ScopeKind "host") "db.internal:5432"), + testCase "a URL ref keeps every colon" do + parseScope "rei:url:https://example.com:8080/x" + @?= Right (ScopeEntity (Namespace "rei") (ScopeKind "url") "https://example.com:8080/x"), + testCase "one colon is not an entity scope" do + assertLeft "a:b" (parseScope "a:b"), + testCase "an empty ref is rejected" do + assertLeft "a:b:" (parseScope "a:b:"), + testCase "an empty namespace is rejected" do + assertLeft ":b:c" (parseScope ":b:c"), + testCase "an empty kind is rejected" do + assertLeft "a::c" (parseScope "a::c"), + testCase "the empty string is rejected" do + assertLeft "" (parseScope ""), + -- The identity encoding gives these characters meaning; EP-5 (docs/plans/13) rejects + -- them at the constructor, and the CLI must not route around that. + testCase "a slash in the namespace is still rejected" do + assertLeft "a/b:kind:ref" (parseScope "a/b:kind:ref") + ] + where + assertLeft label = \case + Left _ -> pure () + Right scope -> assertBool (label <> " should not parse, got: " <> show scope) False + +-- | Out-of-range limits are a parse error, not a Postgres error (@--limit -1@ used to reach +-- SQL and come back as @LIMIT must not be negative@). +limitTests :: TestTree +limitTests = + testGroup + "--limit is bounded at the parser" + [ testCase "recall rejects a negative limit, naming the range" do + assertLimitError "between 1 and 100" (recallWith ["--limit", "-1"]), + testCase "recall rejects zero" do + assertLimitError "between 1 and 100" (recallWith ["--limit", "0"]), + testCase "recall rejects one past the maximum" do + assertLimitError "between 1 and 100" (recallWith ["--limit", "101"]), + testCase "recall accepts both ends of the range" do + fmap (.limit) (recallWith ["--limit", "1"]) @?= Right 1 + fmap (.limit) (recallWith ["--limit", "100"]) @?= Right 100, + testCase "recall's default limit is unchanged" do + fmap (.limit) (recallWith []) @?= Right 8, + testCase "distill rejects one past its lower maximum" do + sid <- genSessionId + assertLimitError "between 1 and 50" (distillWith sid ["--limit", "51"]), + testCase "distill accepts the top of its range" do + sid <- genSessionId + fmap (.candidateLimit) (distillWith sid ["--limit", "50"]) @?= Right 50, + testCase "distill's default limit is unchanged" do + sid <- genSessionId + fmap (.candidateLimit) (distillWith sid []) @?= Right 5 + ] + where + recallWith extra = + parseWith recallOptionsParser (["query", "--scope", "mori"] <> extra) + + distillWith sid extra = + parseWith distillOptionsParser (["session", Text.unpack (idText sid)] <> extra) + + assertLimitError needle = \case + Right _ -> assertBool ("expected a parse error mentioning " <> show needle) False + Left err -> assertBool ("error should state the valid range: " <> err) (needle `isInfixOf` err) + +-- | The demo commands append permanent events (kioku has no delete) to whatever +-- @PG_CONNECTION_STRING@ points at. Consent is a required flag, so a bare invocation dies in +-- the parser — before the environment is read and before anything is written. +demoGuardTests :: TestTree +demoGuardTests = + testGroup + "demo commands require --yes-write-events" + [ testCase "bare `demo` does not parse" do + assertMissingFlag (parseWith demoOptionsParser []), + testCase "`demo --yes-write-events` parses" do + parseWith demoOptionsParser ["--yes-write-events"] @?= Right DemoOptions, + testCase "bare `demo-session` does not parse" do + assertMissingFlag (parseWith demoSessionOptionsParser []), + testCase "`demo-session --yes-write-events` parses" do + parseWith demoSessionOptionsParser ["--yes-write-events"] @?= Right DemoSessionOptions, + testCase "the demo writes into its own namespace, not rei" do + demoScope @?= ScopeEntity (Namespace "kioku_demo") (ScopeKind "demo") "demo" + ] + where + assertMissingFlag = \case + Right _ -> assertBool "expected the demo command to refuse without --yes-write-events" False + Left err -> + assertBool + ("failure should name the missing flag: " <> err) + ("Missing: --yes-write-events" `isInfixOf` err) + +-- | The preflight prints the target database. A password must not travel with it into a +-- terminal or a CI log. +redactionTests :: TestTree +redactionTests = + testGroup + "redactConnectionString" + [ testCase "keyword form: the password is replaced" do + let redacted = redactConnectionString "host=x dbname=y password=hunter2" + assertBool "password should be redacted" ("password=REDACTED" `Text.isInfixOf` redacted) + assertBool "the secret should not survive" (not ("hunter2" `Text.isInfixOf` redacted)), + testCase "URI form: the userinfo password is replaced" do + let redacted = redactConnectionString "postgres://me:hunter2@db:5432/kioku" + assertBool + ("host and user should survive: " <> Text.unpack redacted) + ("me:REDACTED@db:5432" `Text.isInfixOf` redacted) + assertBool "the secret should not survive" (not ("hunter2" `Text.isInfixOf` redacted)), + testCase "a connection string with no password is unchanged" do + redactConnectionString "host=x dbname=y user=me" @?= "host=x dbname=y user=me", + testCase "a URI with no password is unchanged" do + redactConnectionString "postgres://db:5432/kioku" @?= "postgres://db:5432/kioku" + ] + +-- | The two one-shot worker modes are unrelated, so passing both is a mistake. It used to be a +-- silent one: --timers-once was checked first and --backfill was ignored without a word. +workerModeTests :: TestTree +workerModeTests = + testGroup + "worker one-shot modes are mutually exclusive" + [ testCase "no flags means the continuous worker" do + parseWith workerOptionsParser [] @?= Right WorkerContinuous, + testCase "--backfill" do + parseWith workerOptionsParser ["--backfill"] @?= Right WorkerBackfill, + testCase "--timers-once" do + parseWith workerOptionsParser ["--timers-once"] @?= Right WorkerTimersOnce, + testCase "both flags is a parse error" do + assertConflict "--timers-once" (parseWith workerOptionsParser ["--backfill", "--timers-once"]), + testCase "both flags in the other order is also a parse error" do + assertConflict "--backfill" (parseWith workerOptionsParser ["--timers-once", "--backfill"]) + ] + where + assertConflict rejected = \case + Right mode -> assertBool ("expected a conflict error, got: " <> show mode) False + Left err -> + assertBool + ("failure should name the conflicting flag " <> rejected <> ": " <> err) + (rejected `isInfixOf` err) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Kioku.Cli.ParserSpec qualified as ParserSpec +import Test.Tasty (defaultMain) + +main :: IO () +main = defaultMain ParserSpec.tests