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