never executed always true always false
1 module PureClaw.CLI.Commands
2 ( -- * Entry point
3 runCLI
4 -- * Command types (exported for testing)
5 , Command (..)
6 , ChatOptions (..)
7 , chatOptionsParser
8 -- * Enums (exported for testing)
9 , ProviderType (..)
10 , MemoryBackend (..)
11 -- * Policy (exported for testing)
12 , buildPolicy
13 ) where
14
15 import Control.Exception (IOException, bracket_, try)
16 import Control.Monad (unless, when)
17 import Data.ByteString (ByteString)
18 import Data.IORef
19 import Data.Map.Strict qualified as Map
20 import Data.Maybe
21 import Data.Set qualified as Set
22 import Data.Text qualified as T
23 import Data.Text.Encoding qualified as TE
24 import Data.Time.Clock (getCurrentTime)
25 import Data.Time.Format (defaultTimeLocale, formatTime)
26 import Network.HTTP.Client qualified as HTTP
27 import Network.HTTP.Client.TLS qualified as HTTP
28 import Options.Applicative
29 import System.Directory (createDirectoryIfMissing, doesFileExist)
30
31 import System.Exit (exitFailure)
32 import System.FilePath ((</>))
33 import System.IO
34 import System.Process.Typed qualified as P
35
36 import PureClaw.Auth.AnthropicOAuth
37 import PureClaw.CLI.Config
38
39 import PureClaw.Agent.AgentDef qualified as AgentDef
40 import PureClaw.Agent.Completion
41 import PureClaw.Agent.Env
42 import PureClaw.Agent.Identity
43 import PureClaw.Agent.Loop
44 import PureClaw.Agent.SlashCommands
45 import PureClaw.Session.Handle (mkNoOpSessionHandle)
46 import PureClaw.Handles.Transcript
47 import PureClaw.Channels.CLI
48 import PureClaw.Channels.Signal
49 import PureClaw.CLI.Import
50 ( ImportOptions (..)
51 , DirImportResult (..)
52 , ImportResult (..)
53 , importOpenClawDir
54 , resolveImportOptions
55 )
56 import PureClaw.Channels.Signal.Transport
57 import PureClaw.Core.Types
58 import PureClaw.Handles.Channel
59 import PureClaw.Handles.File
60 import PureClaw.Handles.Log
61 import PureClaw.Handles.Memory
62 import PureClaw.Handles.Network
63 import PureClaw.Handles.Shell
64 import PureClaw.Memory.Markdown
65 import PureClaw.Memory.SQLite
66 import PureClaw.Providers.Anthropic
67 import PureClaw.Providers.Class
68 import PureClaw.Providers.Ollama
69 import PureClaw.Providers.OpenAI
70 import PureClaw.Providers.OpenRouter
71 import PureClaw.Security.Policy
72 import PureClaw.Security.Secrets
73 import PureClaw.Security.Vault
74 import PureClaw.Security.Vault.Age
75 import PureClaw.Security.Vault.Passphrase
76 import PureClaw.Security.Vault.Plugin
77 import PureClaw.Tools.FileRead
78 import PureClaw.Tools.FileWrite
79 import PureClaw.Tools.Git
80 import PureClaw.Tools.HttpRequest
81 import PureClaw.Tools.Memory
82 import PureClaw.Tools.Registry
83 import PureClaw.Tools.Shell
84
85 -- | Supported LLM providers.
86 data ProviderType
87 = Anthropic
88 | OpenAI
89 | OpenRouter
90 | Ollama
91 deriving stock (Show, Eq, Ord, Bounded, Enum)
92
93 -- | Supported memory backends.
94 data MemoryBackend
95 = NoMemory
96 | SQLiteMemory
97 | MarkdownMemory
98 deriving stock (Show, Eq, Ord, Bounded, Enum)
99
100 -- | CLI chat options.
101 -- Fields with defaults use 'Maybe' so config file values can fill in omitted flags.
102 data ChatOptions = ChatOptions
103 { _co_model :: Maybe String
104 , _co_apiKey :: Maybe String
105 , _co_system :: Maybe String
106 , _co_provider :: Maybe ProviderType
107 , _co_allowCommands :: [String]
108 , _co_autonomy :: Maybe AutonomyLevel
109 , _co_channel :: Maybe String
110 , _co_memory :: Maybe MemoryBackend
111 , _co_soul :: Maybe String
112 , _co_config :: Maybe FilePath
113 , _co_noVault :: Bool
114 , _co_oauth :: Bool
115 , _co_agent :: Maybe String
116 }
117 deriving stock (Show, Eq)
118
119 -- | Parser for chat options.
120 chatOptionsParser :: Parser ChatOptions
121 chatOptionsParser = ChatOptions
122 <$> optional (strOption
123 ( long "model"
124 <> short 'm'
125 <> help "Model to use (default: claude-sonnet-4-20250514)"
126 ))
127 <*> optional (strOption
128 ( long "api-key"
129 <> help "API key (default: from config file or env var for chosen provider)"
130 ))
131 <*> optional (strOption
132 ( long "system"
133 <> short 's'
134 <> help "System prompt (overrides SOUL.md)"
135 ))
136 <*> optional (option parseProviderType
137 ( long "provider"
138 <> short 'p'
139 <> help "LLM provider: anthropic, openai, openrouter, ollama (default: anthropic)"
140 ))
141 <*> many (strOption
142 ( long "allow"
143 <> short 'a'
144 <> help "Allow a shell command (repeatable, e.g. --allow git --allow ls)"
145 ))
146 <*> optional (option parseAutonomyLevel
147 ( long "autonomy"
148 <> help "Autonomy level: full, supervised, deny (default: deny with no --allow, full with --allow)"
149 ))
150 <*> optional (strOption
151 ( long "channel"
152 <> help "Chat channel: cli, signal, telegram (default: cli)"
153 ))
154 <*> optional (option parseMemoryBackend
155 ( long "memory"
156 <> help "Memory backend: none, sqlite, markdown (default: none)"
157 ))
158 <*> optional (strOption
159 ( long "soul"
160 <> help "Path to SOUL.md identity file (default: ./SOUL.md if it exists)"
161 ))
162 <*> optional (strOption
163 ( long "config"
164 <> short 'c'
165 <> help "Path to config file (default: ~/.pureclaw/config.toml or ~/.config/pureclaw/config.toml)"
166 ))
167 <*> switch
168 ( long "no-vault"
169 <> help "Disable vault even if configured in config file"
170 )
171 <*> switch
172 ( long "oauth"
173 <> help "Authenticate with Anthropic via OAuth (opens browser). Tokens are cached in the vault."
174 )
175 <*> optional (strOption
176 ( long "agent"
177 <> help "Load a named agent from ~/.pureclaw/agents/<name>/ as the system prompt"
178 ))
179
180 -- | Parse a provider type from a CLI string.
181 parseProviderType :: ReadM ProviderType
182 parseProviderType = eitherReader $ \s -> case s of
183 "anthropic" -> Right Anthropic
184 "openai" -> Right OpenAI
185 "openrouter" -> Right OpenRouter
186 "ollama" -> Right Ollama
187 _ -> Left $ "Unknown provider: " <> s <> ". Choose: anthropic, openai, openrouter, ollama"
188
189 -- | Display a provider type as a CLI string.
190 providerToText :: ProviderType -> String
191 providerToText Anthropic = "anthropic"
192 providerToText OpenAI = "openai"
193 providerToText OpenRouter = "openrouter"
194 providerToText Ollama = "ollama"
195
196 -- | Parse a memory backend from a CLI string.
197 parseMemoryBackend :: ReadM MemoryBackend
198 parseMemoryBackend = eitherReader $ \s -> case s of
199 "none" -> Right NoMemory
200 "sqlite" -> Right SQLiteMemory
201 "markdown" -> Right MarkdownMemory
202 _ -> Left $ "Unknown memory backend: " <> s <> ". Choose: none, sqlite, markdown"
203
204 -- | Display a memory backend as a CLI string.
205 memoryToText :: MemoryBackend -> String
206 memoryToText NoMemory = "none"
207 memoryToText SQLiteMemory = "sqlite"
208 memoryToText MarkdownMemory = "markdown"
209
210 -- | Top-level CLI command.
211 data Command
212 = CmdTui ChatOptions -- ^ Interactive terminal UI (always CLI channel)
213 | CmdGateway ChatOptions -- ^ Gateway mode (channel from config/flags)
214 | CmdImport ImportOptions (Maybe FilePath) -- ^ Import an OpenClaw state directory
215 deriving stock (Show, Eq)
216
217 -- | Full CLI parser with subcommands.
218 cliParserInfo :: ParserInfo Command
219 cliParserInfo = info (commandParser <**> helper)
220 ( fullDesc
221 <> progDesc "Haskell-native AI agent runtime"
222 <> header "pureclaw — Haskell-native AI agent runtime"
223 )
224
225 -- | Parser for the top-level command.
226 -- @pureclaw tui@ — interactive terminal
227 -- @pureclaw gateway run@ — channel-aware agent
228 -- No subcommand defaults to @tui@ for backward compatibility.
229 commandParser :: Parser Command
230 commandParser = subparser
231 ( command "tui" (info (CmdTui <$> chatOptionsParser <**> helper)
232 (progDesc "Interactive terminal chat UI"))
233 <> command "gateway" (info (subparser
234 (command "run" (info (CmdGateway <$> chatOptionsParser <**> helper)
235 (progDesc "Run the the PureClaw gateway")))
236 <**> helper)
237 (progDesc "PureClaw Gateway"))
238 <> command "import" (info (importParser <**> helper)
239 (progDesc "Import an OpenClaw state directory"))
240 )
241 <|> (CmdTui <$> chatOptionsParser) -- default to tui when no subcommand
242
243 -- | Parser for the import subcommand.
244 importParser :: Parser Command
245 importParser = CmdImport
246 <$> (ImportOptions
247 <$> optional (strOption
248 ( long "from"
249 <> help "Source OpenClaw state directory (default: ~/.openclaw)"
250 ))
251 <*> optional (strOption
252 ( long "to"
253 <> help "Destination PureClaw state directory (default: ~/.pureclaw)"
254 )))
255 <*> optional (argument str (metavar "PATH" <> help "Path to OpenClaw dir or config file (backward compat)"))
256
257 -- | Main CLI entry point.
258 runCLI :: IO ()
259 runCLI = do
260 cmd <- execParser cliParserInfo
261 case cmd of
262 CmdTui opts -> runChat opts { _co_channel = Just "cli" }
263 CmdGateway opts -> runChat opts
264 CmdImport opts mPos -> runImport opts mPos
265
266 -- | Import an OpenClaw state directory.
267 runImport :: ImportOptions -> Maybe FilePath -> IO ()
268 runImport opts mPositional = do
269 (fromDir, toDir) <- resolveImportOptions opts mPositional
270 putStrLn $ "Importing OpenClaw state from: " <> fromDir
271 putStrLn $ "Writing to: " <> toDir
272 result <- importOpenClawDir fromDir toDir
273 case result of
274 Left err -> do
275 putStrLn $ "Error: " <> T.unpack err
276 exitFailure
277 Right dir -> do
278 let ir = _dir_configResult dir
279 configDir = toDir </> "config"
280 putStrLn ""
281 putStrLn "Import complete!"
282 putStrLn ""
283 putStrLn " Imported:"
284 putStrLn $ " Config: " <> configDir </> "config.toml"
285 case _ir_agentsWritten ir of
286 [] -> pure ()
287 agents -> do
288 putStrLn $ " Agents: " <> T.unpack (T.intercalate ", " agents)
289 mapM_ (\a -> putStrLn $ " " <> configDir </> "agents" </> T.unpack a </> "AGENTS.md") agents
290 when (_dir_credentialsOk dir)
291 $ putStrLn $ " Credentials: " <> toDir </> "credentials.json"
292 case _dir_deviceId dir of
293 Just did -> putStrLn $ " Device ID: " <> T.unpack did
294 Nothing -> pure ()
295 case _dir_workspacePath dir of
296 Just ws -> putStrLn $ " Workspace: " <> ws <> " (referenced in config)"
297 Nothing -> pure ()
298 when (_dir_modelsImported dir)
299 $ putStrLn $ " Models: " <> toDir </> "models.json"
300
301 -- Skipped items
302 let skipped =
303 [("Cron jobs", "PureClaw cron format not yet supported") | _dir_cronSkipped dir]
304 if null skipped
305 then pure ()
306 else do
307 putStrLn ""
308 putStrLn " Skipped:"
309 mapM_ (\(item, reason) -> putStrLn $ " " <> item <> ": " <> reason) skipped
310
311 -- Extra workspaces
312 case _dir_extraWorkspaces dir of
313 [] -> pure ()
314 ws -> do
315 putStrLn ""
316 putStrLn " Additional workspaces found (noted in config comments):"
317 mapM_ (\w -> putStrLn $ " " <> w) ws
318
319 -- Warnings
320 let allWarnings = _ir_warnings ir <> _dir_warnings dir
321 case allWarnings of
322 [] -> pure ()
323 ws -> do
324 putStrLn ""
325 putStrLn " Warnings:"
326 mapM_ (\w -> putStrLn $ " " <> T.unpack w) ws
327
328 putStrLn ""
329 putStrLn "Next steps:"
330 putStrLn " 1. Review the imported config and agent files"
331 if _dir_credentialsOk dir
332 then putStrLn " 2. Move credentials.json secrets into the PureClaw vault: /vault setup"
333 else putStrLn " 2. Configure your API key: pureclaw tui --api-key <key>"
334 putStrLn " 3. Run: pureclaw tui"
335
336 -- | Run an interactive chat session.
337 runChat :: ChatOptions -> IO ()
338 runChat opts = do
339 let logger = mkStderrLogHandle
340
341 -- Load config file: --config flag overrides default search locations
342 configResult <- maybe loadConfigDiag loadFileConfigDiag (_co_config opts)
343 let fileCfg = configFileConfig configResult
344
345 -- Log config loading result
346 case configResult of
347 ConfigLoaded path _ ->
348 _lh_logInfo logger $ "Config: " <> T.pack path
349 ConfigParseError path err -> do
350 _lh_logWarn logger $ "Config file has errors: " <> T.pack path
351 _lh_logWarn logger err
352 _lh_logWarn logger "Using default configuration."
353 ConfigFileNotFound path ->
354 _lh_logWarn logger $ "Config file not found: " <> T.pack path
355 ConfigNotFound _paths ->
356 _lh_logInfo logger "No config file found"
357
358 -- Resolve effective values: CLI flag > config file > default
359 let effectiveProvider = fromMaybe Anthropic (_co_provider opts <|> parseProviderMaybe (_fc_provider fileCfg))
360 effectiveModel = fromMaybe "claude-sonnet-4-20250514" (_co_model opts <|> fmap T.unpack (_fc_model fileCfg))
361 effectiveMemory = fromMaybe NoMemory (_co_memory opts <|> parseMemoryMaybe (_fc_memory fileCfg))
362 effectiveApiKey = _co_apiKey opts <|> fmap T.unpack (_fc_apiKey fileCfg)
363 effectiveSystem = _co_system opts <|> fmap T.unpack (_fc_system fileCfg)
364 effectiveAllow = _co_allowCommands opts <> maybe [] (map T.unpack) (_fc_allow fileCfg)
365 effectiveAutonomy = _co_autonomy opts
366 <|> parseAutonomyMaybe (_fc_autonomy fileCfg)
367
368 -- Vault (opened before provider so API keys can be fetched from vault)
369 vaultOpt <- resolveVault fileCfg (_co_noVault opts) logger
370
371 -- Provider (may be Nothing if no credentials are configured yet)
372 manager <- HTTP.newTlsManager
373 mProvider <- if effectiveProvider == Anthropic && _co_oauth opts
374 then Just <$> resolveAnthropicOAuth vaultOpt manager
375 else resolveProvider effectiveProvider effectiveApiKey vaultOpt manager
376
377 -- Model
378 let model = ModelId (T.pack effectiveModel)
379
380 -- Agent resolution: CLI --agent > config default_agent > Nothing.
381 -- On invalid name or missing agent, log a clear error and exit non-zero.
382 let rawAgentName =
383 fmap T.pack (_co_agent opts) <|> _fc_defaultAgent fileCfg
384 pureclawDir <- getPureclawDir
385 let agentsDir = pureclawDir </> "agents"
386 truncateLimit = fromMaybe 8000 (_fc_agentTruncateLimit fileCfg)
387 mAgentDef <- case rawAgentName of
388 Nothing -> pure Nothing
389 Just raw -> case AgentDef.mkAgentName raw of
390 Left _ -> do
391 _lh_logWarn logger $ "invalid agent name: " <> raw
392 exitFailure
393 Right validName -> do
394 mDef <- AgentDef.loadAgent agentsDir validName
395 case mDef of
396 Just d -> pure (Just d)
397 Nothing -> do
398 defs <- AgentDef.discoverAgents logger agentsDir
399 let names = [AgentDef.unAgentName (AgentDef._ad_name d) | d <- defs]
400 avail = if null names then "(none)" else T.intercalate ", " names
401 _lh_logWarn logger $
402 "Agent \"" <> raw <> "\" not found. Available agents: " <> avail
403 exitFailure
404
405 agentSysPrompt <- case mAgentDef of
406 Nothing -> pure Nothing
407 Just def -> Just <$> AgentDef.composeAgentPrompt logger def truncateLimit
408
409 -- System prompt: agent > effective --system flag > SOUL.md > nothing
410 sysPrompt <- case agentSysPrompt of
411 Just p -> pure (Just p)
412 Nothing -> case effectiveSystem of
413 Just s -> pure (Just (T.pack s))
414 Nothing -> do
415 let soulPath = fromMaybe "SOUL.md" (_co_soul opts)
416 ident <- loadIdentity soulPath
417 if ident == defaultIdentity
418 then pure Nothing
419 else pure (Just (identitySystemPrompt ident))
420
421 -- Security policy
422 let policy = buildPolicy effectiveAutonomy effectiveAllow
423
424 -- Handles
425 let workspace = WorkspaceRoot "."
426 sh = mkShellHandle logger
427 fh = mkFileHandle workspace
428 nh = mkNetworkHandle manager
429 mh <- resolveMemory effectiveMemory
430
431 -- Tool registry
432 let registry = buildRegistry policy sh workspace fh mh nh
433
434 hSetBuffering stdout LineBuffering
435 case mProvider of
436 Just _ -> _lh_logInfo logger $ "Provider: " <> T.pack (providerToText effectiveProvider)
437 Nothing -> _lh_logInfo logger
438 "No providers configured \x2014 use /provider to get started"
439 _lh_logInfo logger $ "Model: " <> T.pack effectiveModel
440 case mAgentDef of
441 Just d -> _lh_logInfo logger $
442 "Agent: " <> AgentDef.unAgentName (AgentDef._ad_name d)
443 Nothing -> pure ()
444 _lh_logInfo logger $ "Memory: " <> T.pack (memoryToText effectiveMemory)
445 case (_sp_allowedCommands policy, _sp_autonomy policy) of
446 (AllowAll, Full) -> do
447 _lh_logInfo logger "Commands: allow all (unrestricted mode)"
448 _lh_logInfo logger
449 "\x26a0\xfe0f Running in unrestricted mode \x2014 the agent can execute any command without approval."
450 (_, Deny) ->
451 _lh_logInfo logger "Commands: none (deny all)"
452 (AllowList s, _) | Set.null s ->
453 _lh_logInfo logger "Commands: none (deny all)"
454 _ ->
455 _lh_logInfo logger $ "Commands: " <> T.intercalate ", " (map T.pack effectiveAllow)
456
457 -- Channel selection: CLI flag > config file > default (cli)
458 let effectiveChannel = fromMaybe "cli"
459 (_co_channel opts <|> fmap T.unpack (_fc_defaultChannel fileCfg))
460
461 -- IORef for two-phase init: completer is built before AgentEnv exists,
462 -- but reads the env at completion time via this ref.
463 envRef <- newIORef Nothing
464 slashCompleter <- buildCompleter envRef
465
466 let startWithChannel :: ChannelHandle -> IO ()
467 startWithChannel channel = do
468 putStrLn "PureClaw 0.1.0 \x2014 Haskell-native AI agent runtime"
469 case effectiveChannel of
470 "cli" -> putStrLn "Type your message and press Enter. Ctrl-D to exit."
471 _ -> putStrLn $ "Channel: " <> effectiveChannel
472 putStrLn ""
473 -- Create transcript handle
474 let transcriptDir = pureclawDir </> "transcripts"
475 createDirectoryIfMissing True transcriptDir
476 timestamp <- getCurrentTime
477 let transcriptFile = transcriptDir
478 </> formatTime defaultTimeLocale "%Y%m%d-%H%M%S" timestamp
479 <> "-" <> effectiveChannel <> ".jsonl"
480 th <- mkFileTranscriptHandle logger transcriptFile
481 transcriptRef <- newIORef (Just th)
482 -- Discover any harnesses still running from a previous session
483 (discoveredHarnesses, nextWindowIdx) <- discoverHarnesses th
484 unless (Map.null discoveredHarnesses) $
485 _lh_logInfo logger $ "Discovered " <> T.pack (show (Map.size discoveredHarnesses))
486 <> " running harness(es) from previous session"
487 harnessRef <- newIORef discoveredHarnesses
488 vaultRef <- newIORef vaultOpt
489 providerRef <- newIORef mProvider
490 modelRef <- newIORef model
491 targetRef <- newIORef TargetProvider
492 windowIdxRef <- newIORef nextWindowIdx
493 sessionHandle <- mkNoOpSessionHandle
494 let env = AgentEnv
495 { _env_provider = providerRef
496 , _env_model = modelRef
497 , _env_channel = channel
498 , _env_logger = logger
499 , _env_systemPrompt = sysPrompt
500 , _env_registry = registry
501 , _env_vault = vaultRef
502 , _env_pluginHandle = mkPluginHandle
503 , _env_transcript = transcriptRef
504 , _env_policy = policy
505 , _env_harnesses = harnessRef
506 , _env_target = targetRef
507 , _env_nextWindowIdx = windowIdxRef
508 , _env_agentDef = mAgentDef
509 , _env_session = sessionHandle
510 }
511 -- Fill the envRef so the tab completer can access the live env
512 writeIORef envRef (Just env)
513 runAgentLoop env
514
515 case effectiveChannel of
516 "signal" -> do
517 let sigCfg = resolveSignalConfig fileCfg
518 -- Check that signal-cli is installed
519 signalCliResult <- try @IOException $
520 P.readProcess (P.proc "signal-cli" ["--version"])
521 case signalCliResult of
522 Left _ -> do
523 _lh_logWarn logger "signal-cli is not installed or not in PATH."
524 _lh_logWarn logger "Install it from: https://github.com/AsamK/signal-cli"
525 _lh_logWarn logger " brew install signal-cli (macOS)"
526 _lh_logWarn logger " nix-env -i signal-cli (NixOS)"
527 _lh_logWarn logger "Falling back to CLI channel."
528 mkCLIChannelHandle (Just slashCompleter) >>= startWithChannel
529 Right _ -> do
530 _lh_logInfo logger $ "Signal account: " <> _sc_account sigCfg
531 transport <- mkSignalCliTransport (_sc_account sigCfg) logger
532 withSignalChannel sigCfg transport logger startWithChannel
533 "cli" ->
534 mkCLIChannelHandle (Just slashCompleter) >>= startWithChannel
535 other -> do
536 _lh_logWarn logger $ "Unknown channel: " <> T.pack other <> ". Using CLI."
537 mkCLIChannelHandle (Just slashCompleter) >>= startWithChannel
538
539 -- | Parse a provider type from a text value (used for config file).
540 parseProviderMaybe :: Maybe T.Text -> Maybe ProviderType
541 parseProviderMaybe Nothing = Nothing
542 parseProviderMaybe (Just t) = case T.unpack t of
543 "anthropic" -> Just Anthropic
544 "openai" -> Just OpenAI
545 "openrouter" -> Just OpenRouter
546 "ollama" -> Just Ollama
547 _ -> Nothing
548
549 -- | Parse an autonomy level from a CLI string.
550 parseAutonomyLevel :: ReadM AutonomyLevel
551 parseAutonomyLevel = eitherReader $ \s -> case s of
552 "full" -> Right Full
553 "supervised" -> Right Supervised
554 "deny" -> Right Deny
555 _ -> Left $ "Unknown autonomy level: " <> s <> ". Choose: full, supervised, deny"
556
557 -- | Parse an autonomy level from a text value (used for config file).
558 parseAutonomyMaybe :: Maybe T.Text -> Maybe AutonomyLevel
559 parseAutonomyMaybe Nothing = Nothing
560 parseAutonomyMaybe (Just t) = case t of
561 "full" -> Just Full
562 "supervised" -> Just Supervised
563 "deny" -> Just Deny
564 _ -> Nothing
565
566 -- | Parse a memory backend from a text value (used for config file).
567 parseMemoryMaybe :: Maybe T.Text -> Maybe MemoryBackend
568 parseMemoryMaybe Nothing = Nothing
569 parseMemoryMaybe (Just t) = case T.unpack t of
570 "none" -> Just NoMemory
571 "sqlite" -> Just SQLiteMemory
572 "markdown" -> Just MarkdownMemory
573 _ -> Nothing
574
575 -- | Build the tool registry with all available tools.
576 buildRegistry :: SecurityPolicy -> ShellHandle -> WorkspaceRoot -> FileHandle -> MemoryHandle -> NetworkHandle -> ToolRegistry
577 buildRegistry policy sh workspace fh mh nh =
578 let reg = uncurry registerTool
579 in reg (shellTool policy sh)
580 $ reg (fileReadTool workspace fh)
581 $ reg (fileWriteTool workspace fh)
582 $ reg (gitTool policy sh)
583 $ reg (memoryStoreTool mh)
584 $ reg (memoryRecallTool mh)
585 $ reg (httpRequestTool AllowAll nh)
586 emptyRegistry
587
588 -- | Build a security policy from optional autonomy level and allowed commands.
589 --
590 -- Behavior:
591 -- * @Just Full@ + empty allow list → 'AllowAll' + 'Full' (unrestricted mode)
592 -- * @Just Full@ + allow list → 'AllowList' of those commands + 'Full'
593 -- * @Just Supervised@ + allow list → 'AllowList' + 'Supervised'
594 -- * @Just Deny@ → 'defaultPolicy' ('Deny', empty 'AllowList')
595 -- * @Nothing@ + empty allow list → 'defaultPolicy' (backward compat)
596 -- * @Nothing@ + allow list → 'Full' + 'AllowList' (backward compat)
597 buildPolicy :: Maybe AutonomyLevel -> [String] -> SecurityPolicy
598 buildPolicy (Just Deny) _ = defaultPolicy
599 buildPolicy (Just level) [] = SecurityPolicy
600 { _sp_allowedCommands = AllowAll
601 , _sp_autonomy = level
602 }
603 buildPolicy (Just level) cmds =
604 let cmdNames = Set.fromList (map (CommandName . T.pack) cmds)
605 in SecurityPolicy
606 { _sp_allowedCommands = AllowList cmdNames
607 , _sp_autonomy = level
608 }
609 buildPolicy Nothing [] = defaultPolicy
610 buildPolicy Nothing cmds =
611 let cmdNames = Set.fromList (map (CommandName . T.pack) cmds)
612 in SecurityPolicy
613 { _sp_allowedCommands = AllowList cmdNames
614 , _sp_autonomy = Full
615 }
616
617 -- | Resolve the LLM provider from the provider type.
618 -- Checks CLI flag first, then the vault for the API key.
619 -- Returns 'Nothing' if no credentials are available (the agent loop
620 -- will still start, allowing the user to configure credentials via
621 -- slash commands like /vault setup).
622 resolveProvider :: ProviderType -> Maybe String -> Maybe VaultHandle -> HTTP.Manager -> IO (Maybe SomeProvider)
623 resolveProvider Anthropic keyOpt vaultOpt manager = do
624 mApiKey <- resolveApiKey keyOpt "ANTHROPIC_API_KEY" vaultOpt
625 case mApiKey of
626 Just k -> pure (Just (MkProvider (mkAnthropicProvider manager k)))
627 Nothing -> do
628 -- Fall back to cached OAuth tokens in the vault
629 cachedBs <- tryVaultLookup vaultOpt oauthVaultKey
630 case cachedBs >>= eitherToMaybe . deserializeTokens of
631 Nothing -> pure Nothing
632 Just tokens -> do
633 let cfg = defaultOAuthConfig
634 now <- getCurrentTime
635 t <- if _oat_expiresAt tokens <= now
636 then do
637 putStrLn "OAuth access token expired \x2014 refreshing..."
638 newT <- refreshOAuthToken cfg manager (_oat_refreshToken tokens)
639 saveOAuthTokens vaultOpt newT
640 pure newT
641 else pure tokens
642 handle <- mkOAuthHandle cfg manager t
643 pure (Just (MkProvider (mkAnthropicProviderOAuth manager handle)))
644 resolveProvider OpenAI keyOpt vaultOpt manager = do
645 mApiKey <- resolveApiKey keyOpt "OPENAI_API_KEY" vaultOpt
646 pure (fmap (MkProvider . mkOpenAIProvider manager) mApiKey)
647 resolveProvider OpenRouter keyOpt vaultOpt manager = do
648 mApiKey <- resolveApiKey keyOpt "OPENROUTER_API_KEY" vaultOpt
649 pure (fmap (MkProvider . mkOpenRouterProvider manager) mApiKey)
650 resolveProvider Ollama _ _ manager =
651 pure (Just (MkProvider (mkOllamaProvider manager)))
652
653 -- | Vault key used to cache OAuth tokens between sessions.
654 oauthVaultKey :: T.Text
655 oauthVaultKey = "ANTHROPIC_OAUTH_TOKENS"
656
657 -- | Resolve an Anthropic provider via OAuth 2.0 PKCE.
658 -- Loads cached tokens from the vault if available; runs the full browser
659 -- flow otherwise. Refreshes expired access tokens automatically.
660 resolveAnthropicOAuth :: Maybe VaultHandle -> HTTP.Manager -> IO SomeProvider
661 resolveAnthropicOAuth vaultOpt manager = do
662 let cfg = defaultOAuthConfig
663 cachedBs <- tryVaultLookup vaultOpt oauthVaultKey
664 tokens <- case cachedBs >>= eitherToMaybe . deserializeTokens of
665 Just t -> do
666 now <- getCurrentTime
667 if _oat_expiresAt t <= now
668 then do
669 putStrLn "OAuth access token expired — refreshing..."
670 newT <- refreshOAuthToken cfg manager (_oat_refreshToken t)
671 saveOAuthTokens vaultOpt newT
672 pure newT
673 else pure t
674 Nothing -> do
675 t <- runOAuthFlow cfg manager
676 saveOAuthTokens vaultOpt t
677 pure t
678 handle <- mkOAuthHandle cfg manager tokens
679 pure (MkProvider (mkAnthropicProviderOAuth manager handle))
680
681 -- | Save OAuth tokens to the vault (best-effort; logs on failure).
682 saveOAuthTokens :: Maybe VaultHandle -> OAuthTokens -> IO ()
683 saveOAuthTokens Nothing _ = pure ()
684 saveOAuthTokens (Just vh) tokens = do
685 result <- _vh_put vh oauthVaultKey (serializeTokens tokens)
686 case result of
687 Left err -> putStrLn $ "Warning: could not cache OAuth tokens: " <> show err
688 Right () -> pure ()
689
690 -- | Convert 'Either' to 'Maybe', discarding the error.
691 eitherToMaybe :: Either e a -> Maybe a
692 eitherToMaybe (Left _) = Nothing
693 eitherToMaybe (Right a) = Just a
694
695 -- | Resolve an API key from: CLI flag → vault.
696 -- Returns 'Nothing' if no key is found.
697 resolveApiKey :: Maybe String -> String -> Maybe VaultHandle -> IO (Maybe ApiKey)
698 resolveApiKey (Just key) _ _ = pure (Just (mkApiKey (TE.encodeUtf8 (T.pack key))))
699 resolveApiKey Nothing vaultKeyName vaultOpt = do
700 vaultKey <- tryVaultLookup vaultOpt (T.pack vaultKeyName)
701 case vaultKey of
702 Just bs -> pure (Just (mkApiKey bs))
703 Nothing -> pure Nothing
704
705 -- | Try to look up a key from the vault. Returns 'Nothing' if the vault is
706 -- absent, locked, or does not contain the key.
707 tryVaultLookup :: Maybe VaultHandle -> T.Text -> IO (Maybe ByteString)
708 tryVaultLookup Nothing _ = pure Nothing
709 tryVaultLookup (Just vh) key = do
710 result <- _vh_get vh key
711 case result of
712 Right bs -> pure (Just bs)
713 Left _ -> pure Nothing
714
715 -- | Resolve the memory backend.
716 resolveMemory :: MemoryBackend -> IO MemoryHandle
717 resolveMemory NoMemory = pure mkNoOpMemoryHandle
718 resolveMemory SQLiteMemory = do
719 dir <- getPureclawDir
720 mkSQLiteMemoryHandle (dir ++ "/memory.db")
721 resolveMemory MarkdownMemory = do
722 dir <- getPureclawDir
723 mkMarkdownMemoryHandle (dir ++ "/memory")
724
725 -- | Open the vault if configured. Returns 'Nothing' if @--no-vault@ is set.
726 -- When age keys are configured, uses age public-key encryption.
727 -- Otherwise, falls back to passphrase-based encryption (works out of the box).
728 resolveVault :: FileConfig -> Bool -> LogHandle -> IO (Maybe VaultHandle)
729 resolveVault _ True _ = pure Nothing
730 resolveVault fileCfg False logger =
731 case (_fc_vault_recipient fileCfg, _fc_vault_identity fileCfg) of
732 (Just recipient, Just identity) -> resolveAgeVault fileCfg recipient identity logger
733 _ -> resolvePassphraseVault fileCfg logger
734
735 -- | Resolve vault using age public-key encryption (existing behaviour).
736 resolveAgeVault :: FileConfig -> T.Text -> T.Text -> LogHandle -> IO (Maybe VaultHandle)
737 resolveAgeVault fileCfg recipient identity logger = do
738 encResult <- mkAgeEncryptor
739 case encResult of
740 Left err -> do
741 _lh_logInfo logger $ "Vault disabled (age not available): " <> T.pack (show err)
742 pure Nothing
743 Right enc -> do
744 dir <- getPureclawDir
745 let path = maybe (dir ++ "/vault/vault.age") T.unpack (_fc_vault_path fileCfg)
746 mode = parseUnlockMode (_fc_vault_unlock fileCfg)
747 enc' = ageVaultEncryptor enc recipient identity
748 cfg = VaultConfig
749 { _vc_path = path
750 , _vc_keyType = inferAgeKeyType recipient
751 , _vc_unlock = mode
752 }
753 vault <- openVault cfg enc'
754 exists <- doesFileExist path
755 if exists
756 then do
757 case mode of
758 UnlockStartup -> do
759 result <- _vh_unlock vault
760 case result of
761 Left err -> _lh_logInfo logger $
762 "Vault startup unlock failed (vault will be locked): " <> T.pack (show err)
763 Right () -> _lh_logInfo logger "Vault unlocked."
764 _ -> pure ()
765 pure (Just vault)
766 else do
767 _lh_logInfo logger "No vault found — use `/vault setup` to create one."
768 pure Nothing
769
770 -- | Resolve vault using passphrase-based encryption (default when no age keys configured).
771 -- Prompts for passphrase on stdin at startup (if vault file exists).
772 resolvePassphraseVault :: FileConfig -> LogHandle -> IO (Maybe VaultHandle)
773 resolvePassphraseVault fileCfg logger = do
774 dir <- getPureclawDir
775 let path = maybe (dir ++ "/vault/vault.age") T.unpack (_fc_vault_path fileCfg)
776 cfg = VaultConfig
777 { _vc_path = path
778 , _vc_keyType = "AES-256 (passphrase)"
779 , _vc_unlock = UnlockStartup
780 }
781 let getPass = do
782 putStr "Vault passphrase: "
783 hFlush stdout
784 pass <- bracket_
785 (hSetEcho stdin False)
786 (hSetEcho stdin True >> putStrLn "")
787 getLine
788 pure (TE.encodeUtf8 (T.pack pass))
789 enc <- mkPassphraseVaultEncryptor getPass
790 vault <- openVault cfg enc
791 exists <- doesFileExist path
792 if exists
793 then do
794 result <- _vh_unlock vault
795 case result of
796 Left err -> _lh_logInfo logger $
797 "Vault unlock failed: " <> T.pack (show err)
798 Right () -> _lh_logInfo logger "Vault unlocked."
799 pure (Just vault)
800 else do
801 _lh_logInfo logger "No vault found — use `/vault setup` to create one."
802 pure Nothing
803
804 -- | Infer a human-readable key type from the age recipient prefix.
805 inferAgeKeyType :: T.Text -> T.Text
806 inferAgeKeyType recipient
807 | "age-plugin-yubikey" `T.isPrefixOf` recipient = "YubiKey PIV"
808 | "age1" `T.isPrefixOf` recipient = "X25519"
809 | otherwise = "Unknown"
810
811 -- | Parse vault unlock mode from config text.
812 parseUnlockMode :: Maybe T.Text -> UnlockMode
813 parseUnlockMode Nothing = UnlockOnDemand
814 parseUnlockMode (Just t) = case t of
815 "startup" -> UnlockStartup
816 "on_demand" -> UnlockOnDemand
817 "per_access" -> UnlockPerAccess
818 _ -> UnlockOnDemand
819
820 -- | Resolve Signal channel config from the file config.
821 resolveSignalConfig :: FileConfig -> SignalConfig
822 resolveSignalConfig fileCfg =
823 let sigCfg = _fc_signal fileCfg
824 dmPolicy = sigCfg >>= _fsc_dmPolicy
825 allowFrom = case dmPolicy of
826 Just "open" -> AllowAll
827 _ -> case sigCfg >>= _fsc_allowFrom of
828 Nothing -> AllowAll
829 Just [] -> AllowAll
830 Just users -> AllowList (Set.fromList (map UserId users))
831 in SignalConfig
832 { _sc_account = fromMaybe "+0000000000" (sigCfg >>= _fsc_account)
833 , _sc_textChunkLimit = fromMaybe 6000 (sigCfg >>= _fsc_textChunkLimit)
834 , _sc_allowFrom = allowFrom
835 }