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 agent with channel from config (Signal, Telegram, CLI)"))))
224 (progDesc "Gateway — channel-aware agent"))
225 <> command "import" (info (importParser <**> helper)
226 (progDesc "Import an OpenClaw state directory"))
227 )
228 <|> (CmdTui <$> chatOptionsParser) -- default to tui when no subcommand
229
230 -- | Parser for the import subcommand.
231 importParser :: Parser Command
232 importParser = CmdImport
233 <$> (ImportOptions
234 <$> optional (strOption
235 ( long "from"
236 <> help "Source OpenClaw state directory (default: ~/.openclaw)"
237 ))
238 <*> optional (strOption
239 ( long "to"
240 <> help "Destination PureClaw state directory (default: ~/.pureclaw)"
241 )))
242 <*> optional (argument str (metavar "PATH" <> help "Path to OpenClaw dir or config file (backward compat)"))
243
244 -- | Main CLI entry point.
245 runCLI :: IO ()
246 runCLI = do
247 cmd <- execParser cliParserInfo
248 case cmd of
249 CmdTui opts -> runChat opts { _co_channel = Just "cli" }
250 CmdGateway opts -> runChat opts
251 CmdImport opts mPos -> runImport opts mPos
252
253 -- | Import an OpenClaw state directory.
254 runImport :: ImportOptions -> Maybe FilePath -> IO ()
255 runImport opts mPositional = do
256 (fromDir, toDir) <- resolveImportOptions opts mPositional
257 putStrLn $ "Importing OpenClaw state from: " <> fromDir
258 putStrLn $ "Writing to: " <> toDir
259 result <- importOpenClawDir fromDir toDir
260 case result of
261 Left err -> do
262 putStrLn $ "Error: " <> T.unpack err
263 exitFailure
264 Right dir -> do
265 let ir = _dir_configResult dir
266 configDir = toDir </> "config"
267 putStrLn ""
268 putStrLn "Import complete!"
269 putStrLn ""
270 putStrLn " Imported:"
271 putStrLn $ " Config: " <> configDir </> "config.toml"
272 case _ir_agentsWritten ir of
273 [] -> pure ()
274 agents -> do
275 putStrLn $ " Agents: " <> T.unpack (T.intercalate ", " agents)
276 mapM_ (\a -> putStrLn $ " " <> configDir </> "agents" </> T.unpack a </> "AGENTS.md") agents
277 when (_dir_credentialsOk dir)
278 $ putStrLn $ " Credentials: " <> toDir </> "credentials.json"
279 case _dir_deviceId dir of
280 Just did -> putStrLn $ " Device ID: " <> T.unpack did
281 Nothing -> pure ()
282 case _dir_workspacePath dir of
283 Just ws -> putStrLn $ " Workspace: " <> ws <> " (referenced in config)"
284 Nothing -> pure ()
285 when (_dir_modelsImported dir)
286 $ putStrLn $ " Models: " <> toDir </> "models.json"
287
288 -- Skipped items
289 let skipped =
290 [("Cron jobs", "PureClaw cron format not yet supported") | _dir_cronSkipped dir]
291 if null skipped
292 then pure ()
293 else do
294 putStrLn ""
295 putStrLn " Skipped:"
296 mapM_ (\(item, reason) -> putStrLn $ " " <> item <> ": " <> reason) skipped
297
298 -- Extra workspaces
299 case _dir_extraWorkspaces dir of
300 [] -> pure ()
301 ws -> do
302 putStrLn ""
303 putStrLn " Additional workspaces found (noted in config comments):"
304 mapM_ (\w -> putStrLn $ " " <> w) ws
305
306 -- Warnings
307 let allWarnings = _ir_warnings ir <> _dir_warnings dir
308 case allWarnings of
309 [] -> pure ()
310 ws -> do
311 putStrLn ""
312 putStrLn " Warnings:"
313 mapM_ (\w -> putStrLn $ " " <> T.unpack w) ws
314
315 putStrLn ""
316 putStrLn "Next steps:"
317 putStrLn " 1. Review the imported config and agent files"
318 if _dir_credentialsOk dir
319 then putStrLn " 2. Move credentials.json secrets into the PureClaw vault: /vault setup"
320 else putStrLn " 2. Configure your API key: pureclaw tui --api-key <key>"
321 putStrLn " 3. Run: pureclaw tui"
322
323 -- | Run an interactive chat session.
324 runChat :: ChatOptions -> IO ()
325 runChat opts = do
326 let logger = mkStderrLogHandle
327
328 -- Load config file: --config flag overrides default search locations
329 configResult <- maybe loadConfigDiag loadFileConfigDiag (_co_config opts)
330 let fileCfg = configFileConfig configResult
331
332 -- Log config loading result
333 case configResult of
334 ConfigLoaded path _ ->
335 _lh_logInfo logger $ "Config: " <> T.pack path
336 ConfigParseError path err -> do
337 _lh_logWarn logger $ "Config file has errors: " <> T.pack path
338 _lh_logWarn logger err
339 _lh_logWarn logger "Using default configuration."
340 ConfigFileNotFound path ->
341 _lh_logWarn logger $ "Config file not found: " <> T.pack path
342 ConfigNotFound _paths ->
343 _lh_logInfo logger "No config file found"
344
345 -- Resolve effective values: CLI flag > config file > default
346 let effectiveProvider = fromMaybe Anthropic (_co_provider opts <|> parseProviderMaybe (_fc_provider fileCfg))
347 effectiveModel = fromMaybe "claude-sonnet-4-20250514" (_co_model opts <|> fmap T.unpack (_fc_model fileCfg))
348 effectiveMemory = fromMaybe NoMemory (_co_memory opts <|> parseMemoryMaybe (_fc_memory fileCfg))
349 effectiveApiKey = _co_apiKey opts <|> fmap T.unpack (_fc_apiKey fileCfg)
350 effectiveSystem = _co_system opts <|> fmap T.unpack (_fc_system fileCfg)
351 effectiveAllow = _co_allowCommands opts <> maybe [] (map T.unpack) (_fc_allow fileCfg)
352 effectiveAutonomy = _co_autonomy opts
353 <|> parseAutonomyMaybe (_fc_autonomy fileCfg)
354
355 -- Vault (opened before provider so API keys can be fetched from vault)
356 vaultOpt <- resolveVault fileCfg (_co_noVault opts) logger
357
358 -- Provider (may be Nothing if no credentials are configured yet)
359 manager <- HTTP.newTlsManager
360 mProvider <- if effectiveProvider == Anthropic && _co_oauth opts
361 then Just <$> resolveAnthropicOAuth vaultOpt manager
362 else resolveProvider effectiveProvider effectiveApiKey vaultOpt manager
363
364 -- Model
365 let model = ModelId (T.pack effectiveModel)
366
367 -- System prompt: effective --system flag > SOUL.md > nothing
368 sysPrompt <- case effectiveSystem of
369 Just s -> pure (Just (T.pack s))
370 Nothing -> do
371 let soulPath = fromMaybe "SOUL.md" (_co_soul opts)
372 ident <- loadIdentity soulPath
373 if ident == defaultIdentity
374 then pure Nothing
375 else pure (Just (identitySystemPrompt ident))
376
377 -- Security policy
378 let policy = buildPolicy effectiveAutonomy effectiveAllow
379
380 -- Handles
381 let workspace = WorkspaceRoot "."
382 sh = mkShellHandle logger
383 fh = mkFileHandle workspace
384 nh = mkNetworkHandle manager
385 mh <- resolveMemory effectiveMemory
386
387 -- Tool registry
388 let registry = buildRegistry policy sh workspace fh mh nh
389
390 hSetBuffering stdout LineBuffering
391 case mProvider of
392 Just _ -> _lh_logInfo logger $ "Provider: " <> T.pack (providerToText effectiveProvider)
393 Nothing -> _lh_logInfo logger
394 "No providers configured \x2014 use /provider to get started"
395 _lh_logInfo logger $ "Model: " <> T.pack effectiveModel
396 _lh_logInfo logger $ "Memory: " <> T.pack (memoryToText effectiveMemory)
397 case (_sp_allowedCommands policy, _sp_autonomy policy) of
398 (AllowAll, Full) -> do
399 _lh_logInfo logger "Commands: allow all (unrestricted mode)"
400 _lh_logInfo logger
401 "\x26a0\xfe0f Running in unrestricted mode \x2014 the agent can execute any command without approval."
402 (_, Deny) ->
403 _lh_logInfo logger "Commands: none (deny all)"
404 (AllowList s, _) | Set.null s ->
405 _lh_logInfo logger "Commands: none (deny all)"
406 _ ->
407 _lh_logInfo logger $ "Commands: " <> T.intercalate ", " (map T.pack effectiveAllow)
408
409 -- Channel selection: CLI flag > config file > default (cli)
410 let effectiveChannel = fromMaybe "cli"
411 (_co_channel opts <|> fmap T.unpack (_fc_defaultChannel fileCfg))
412
413 let startWithChannel :: ChannelHandle -> IO ()
414 startWithChannel channel = do
415 putStrLn "PureClaw 0.1.0 \x2014 Haskell-native AI agent runtime"
416 case effectiveChannel of
417 "cli" -> putStrLn "Type your message and press Enter. Ctrl-D to exit."
418 _ -> putStrLn $ "Channel: " <> effectiveChannel
419 putStrLn ""
420 vaultRef <- newIORef vaultOpt
421 providerRef <- newIORef mProvider
422 let env = AgentEnv
423 { _env_provider = providerRef
424 , _env_model = model
425 , _env_channel = channel
426 , _env_logger = logger
427 , _env_systemPrompt = sysPrompt
428 , _env_registry = registry
429 , _env_vault = vaultRef
430 , _env_pluginHandle = mkPluginHandle
431 }
432 runAgentLoop env
433
434 case effectiveChannel of
435 "signal" -> do
436 let sigCfg = resolveSignalConfig fileCfg
437 -- Check that signal-cli is installed
438 signalCliResult <- try @IOException $
439 P.readProcess (P.proc "signal-cli" ["--version"])
440 case signalCliResult of
441 Left _ -> do
442 _lh_logWarn logger "signal-cli is not installed or not in PATH."
443 _lh_logWarn logger "Install it from: https://github.com/AsamK/signal-cli"
444 _lh_logWarn logger " brew install signal-cli (macOS)"
445 _lh_logWarn logger " nix-env -i signal-cli (NixOS)"
446 _lh_logWarn logger "Falling back to CLI channel."
447 startWithChannel mkCLIChannelHandle
448 Right _ -> do
449 _lh_logInfo logger $ "Signal account: " <> _sc_account sigCfg
450 transport <- mkSignalCliTransport (_sc_account sigCfg) logger
451 withSignalChannel sigCfg transport logger startWithChannel
452 "cli" ->
453 startWithChannel mkCLIChannelHandle
454 other -> do
455 _lh_logWarn logger $ "Unknown channel: " <> T.pack other <> ". Using CLI."
456 startWithChannel mkCLIChannelHandle
457
458 -- | Parse a provider type from a text value (used for config file).
459 parseProviderMaybe :: Maybe T.Text -> Maybe ProviderType
460 parseProviderMaybe Nothing = Nothing
461 parseProviderMaybe (Just t) = case T.unpack t of
462 "anthropic" -> Just Anthropic
463 "openai" -> Just OpenAI
464 "openrouter" -> Just OpenRouter
465 "ollama" -> Just Ollama
466 _ -> Nothing
467
468 -- | Parse an autonomy level from a CLI string.
469 parseAutonomyLevel :: ReadM AutonomyLevel
470 parseAutonomyLevel = eitherReader $ \s -> case s of
471 "full" -> Right Full
472 "supervised" -> Right Supervised
473 "deny" -> Right Deny
474 _ -> Left $ "Unknown autonomy level: " <> s <> ". Choose: full, supervised, deny"
475
476 -- | Parse an autonomy level from a text value (used for config file).
477 parseAutonomyMaybe :: Maybe T.Text -> Maybe AutonomyLevel
478 parseAutonomyMaybe Nothing = Nothing
479 parseAutonomyMaybe (Just t) = case t of
480 "full" -> Just Full
481 "supervised" -> Just Supervised
482 "deny" -> Just Deny
483 _ -> Nothing
484
485 -- | Parse a memory backend from a text value (used for config file).
486 parseMemoryMaybe :: Maybe T.Text -> Maybe MemoryBackend
487 parseMemoryMaybe Nothing = Nothing
488 parseMemoryMaybe (Just t) = case T.unpack t of
489 "none" -> Just NoMemory
490 "sqlite" -> Just SQLiteMemory
491 "markdown" -> Just MarkdownMemory
492 _ -> Nothing
493
494 -- | Build the tool registry with all available tools.
495 buildRegistry :: SecurityPolicy -> ShellHandle -> WorkspaceRoot -> FileHandle -> MemoryHandle -> NetworkHandle -> ToolRegistry
496 buildRegistry policy sh workspace fh mh nh =
497 let reg = uncurry registerTool
498 in reg (shellTool policy sh)
499 $ reg (fileReadTool workspace fh)
500 $ reg (fileWriteTool workspace fh)
501 $ reg (gitTool policy sh)
502 $ reg (memoryStoreTool mh)
503 $ reg (memoryRecallTool mh)
504 $ reg (httpRequestTool AllowAll nh)
505 emptyRegistry
506
507 -- | Build a security policy from optional autonomy level and allowed commands.
508 --
509 -- Behavior:
510 -- * @Just Full@ + empty allow list → 'AllowAll' + 'Full' (unrestricted mode)
511 -- * @Just Full@ + allow list → 'AllowList' of those commands + 'Full'
512 -- * @Just Supervised@ + allow list → 'AllowList' + 'Supervised'
513 -- * @Just Deny@ → 'defaultPolicy' ('Deny', empty 'AllowList')
514 -- * @Nothing@ + empty allow list → 'defaultPolicy' (backward compat)
515 -- * @Nothing@ + allow list → 'Full' + 'AllowList' (backward compat)
516 buildPolicy :: Maybe AutonomyLevel -> [String] -> SecurityPolicy
517 buildPolicy (Just Deny) _ = defaultPolicy
518 buildPolicy (Just level) [] = SecurityPolicy
519 { _sp_allowedCommands = AllowAll
520 , _sp_autonomy = level
521 }
522 buildPolicy (Just level) cmds =
523 let cmdNames = Set.fromList (map (CommandName . T.pack) cmds)
524 in SecurityPolicy
525 { _sp_allowedCommands = AllowList cmdNames
526 , _sp_autonomy = level
527 }
528 buildPolicy Nothing [] = defaultPolicy
529 buildPolicy Nothing cmds =
530 let cmdNames = Set.fromList (map (CommandName . T.pack) cmds)
531 in SecurityPolicy
532 { _sp_allowedCommands = AllowList cmdNames
533 , _sp_autonomy = Full
534 }
535
536 -- | Resolve the LLM provider from the provider type.
537 -- Checks CLI flag first, then the vault for the API key.
538 -- Returns 'Nothing' if no credentials are available (the agent loop
539 -- will still start, allowing the user to configure credentials via
540 -- slash commands like /vault setup).
541 resolveProvider :: ProviderType -> Maybe String -> Maybe VaultHandle -> HTTP.Manager -> IO (Maybe SomeProvider)
542 resolveProvider Anthropic keyOpt vaultOpt manager = do
543 mApiKey <- resolveApiKey keyOpt "ANTHROPIC_API_KEY" vaultOpt
544 case mApiKey of
545 Just k -> pure (Just (MkProvider (mkAnthropicProvider manager k)))
546 Nothing -> do
547 -- Fall back to cached OAuth tokens in the vault
548 cachedBs <- tryVaultLookup vaultOpt oauthVaultKey
549 case cachedBs >>= eitherToMaybe . deserializeTokens of
550 Nothing -> pure Nothing
551 Just tokens -> do
552 let cfg = defaultOAuthConfig
553 now <- getCurrentTime
554 t <- if _oat_expiresAt tokens <= now
555 then do
556 putStrLn "OAuth access token expired \x2014 refreshing..."
557 newT <- refreshOAuthToken cfg manager (_oat_refreshToken tokens)
558 saveOAuthTokens vaultOpt newT
559 pure newT
560 else pure tokens
561 handle <- mkOAuthHandle cfg manager t
562 pure (Just (MkProvider (mkAnthropicProviderOAuth manager handle)))
563 resolveProvider OpenAI keyOpt vaultOpt manager = do
564 mApiKey <- resolveApiKey keyOpt "OPENAI_API_KEY" vaultOpt
565 pure (fmap (MkProvider . mkOpenAIProvider manager) mApiKey)
566 resolveProvider OpenRouter keyOpt vaultOpt manager = do
567 mApiKey <- resolveApiKey keyOpt "OPENROUTER_API_KEY" vaultOpt
568 pure (fmap (MkProvider . mkOpenRouterProvider manager) mApiKey)
569 resolveProvider Ollama _ _ manager =
570 pure (Just (MkProvider (mkOllamaProvider manager)))
571
572 -- | Vault key used to cache OAuth tokens between sessions.
573 oauthVaultKey :: T.Text
574 oauthVaultKey = "ANTHROPIC_OAUTH_TOKENS"
575
576 -- | Resolve an Anthropic provider via OAuth 2.0 PKCE.
577 -- Loads cached tokens from the vault if available; runs the full browser
578 -- flow otherwise. Refreshes expired access tokens automatically.
579 resolveAnthropicOAuth :: Maybe VaultHandle -> HTTP.Manager -> IO SomeProvider
580 resolveAnthropicOAuth vaultOpt manager = do
581 let cfg = defaultOAuthConfig
582 cachedBs <- tryVaultLookup vaultOpt oauthVaultKey
583 tokens <- case cachedBs >>= eitherToMaybe . deserializeTokens of
584 Just t -> do
585 now <- getCurrentTime
586 if _oat_expiresAt t <= now
587 then do
588 putStrLn "OAuth access token expired — refreshing..."
589 newT <- refreshOAuthToken cfg manager (_oat_refreshToken t)
590 saveOAuthTokens vaultOpt newT
591 pure newT
592 else pure t
593 Nothing -> do
594 t <- runOAuthFlow cfg manager
595 saveOAuthTokens vaultOpt t
596 pure t
597 handle <- mkOAuthHandle cfg manager tokens
598 pure (MkProvider (mkAnthropicProviderOAuth manager handle))
599
600 -- | Save OAuth tokens to the vault (best-effort; logs on failure).
601 saveOAuthTokens :: Maybe VaultHandle -> OAuthTokens -> IO ()
602 saveOAuthTokens Nothing _ = pure ()
603 saveOAuthTokens (Just vh) tokens = do
604 result <- _vh_put vh oauthVaultKey (serializeTokens tokens)
605 case result of
606 Left err -> putStrLn $ "Warning: could not cache OAuth tokens: " <> show err
607 Right () -> pure ()
608
609 -- | Convert 'Either' to 'Maybe', discarding the error.
610 eitherToMaybe :: Either e a -> Maybe a
611 eitherToMaybe (Left _) = Nothing
612 eitherToMaybe (Right a) = Just a
613
614 -- | Resolve an API key from: CLI flag → vault.
615 -- Returns 'Nothing' if no key is found.
616 resolveApiKey :: Maybe String -> String -> Maybe VaultHandle -> IO (Maybe ApiKey)
617 resolveApiKey (Just key) _ _ = pure (Just (mkApiKey (TE.encodeUtf8 (T.pack key))))
618 resolveApiKey Nothing vaultKeyName vaultOpt = do
619 vaultKey <- tryVaultLookup vaultOpt (T.pack vaultKeyName)
620 case vaultKey of
621 Just bs -> pure (Just (mkApiKey bs))
622 Nothing -> pure Nothing
623
624 -- | Try to look up a key from the vault. Returns 'Nothing' if the vault is
625 -- absent, locked, or does not contain the key.
626 tryVaultLookup :: Maybe VaultHandle -> T.Text -> IO (Maybe ByteString)
627 tryVaultLookup Nothing _ = pure Nothing
628 tryVaultLookup (Just vh) key = do
629 result <- _vh_get vh key
630 case result of
631 Right bs -> pure (Just bs)
632 Left _ -> pure Nothing
633
634 -- | Resolve the memory backend.
635 resolveMemory :: MemoryBackend -> IO MemoryHandle
636 resolveMemory NoMemory = pure mkNoOpMemoryHandle
637 resolveMemory SQLiteMemory = do
638 dir <- getPureclawDir
639 mkSQLiteMemoryHandle (dir ++ "/memory.db")
640 resolveMemory MarkdownMemory = do
641 dir <- getPureclawDir
642 mkMarkdownMemoryHandle (dir ++ "/memory")
643
644 -- | Open the vault if configured. Returns 'Nothing' if @--no-vault@ is set.
645 -- When age keys are configured, uses age public-key encryption.
646 -- Otherwise, falls back to passphrase-based encryption (works out of the box).
647 resolveVault :: FileConfig -> Bool -> LogHandle -> IO (Maybe VaultHandle)
648 resolveVault _ True _ = pure Nothing
649 resolveVault fileCfg False logger =
650 case (_fc_vault_recipient fileCfg, _fc_vault_identity fileCfg) of
651 (Just recipient, Just identity) -> resolveAgeVault fileCfg recipient identity logger
652 _ -> resolvePassphraseVault fileCfg logger
653
654 -- | Resolve vault using age public-key encryption (existing behaviour).
655 resolveAgeVault :: FileConfig -> T.Text -> T.Text -> LogHandle -> IO (Maybe VaultHandle)
656 resolveAgeVault fileCfg recipient identity logger = do
657 encResult <- mkAgeEncryptor
658 case encResult of
659 Left err -> do
660 _lh_logInfo logger $ "Vault disabled (age not available): " <> T.pack (show err)
661 pure Nothing
662 Right enc -> do
663 dir <- getPureclawDir
664 let path = maybe (dir ++ "/vault/vault.age") T.unpack (_fc_vault_path fileCfg)
665 mode = parseUnlockMode (_fc_vault_unlock fileCfg)
666 enc' = ageVaultEncryptor enc recipient identity
667 cfg = VaultConfig
668 { _vc_path = path
669 , _vc_keyType = inferAgeKeyType recipient
670 , _vc_unlock = mode
671 }
672 vault <- openVault cfg enc'
673 exists <- doesFileExist path
674 if exists
675 then do
676 case mode of
677 UnlockStartup -> do
678 result <- _vh_unlock vault
679 case result of
680 Left err -> _lh_logInfo logger $
681 "Vault startup unlock failed (vault will be locked): " <> T.pack (show err)
682 Right () -> _lh_logInfo logger "Vault unlocked."
683 _ -> pure ()
684 pure (Just vault)
685 else do
686 _lh_logInfo logger "No vault found — use `/vault setup` to create one."
687 pure Nothing
688
689 -- | Resolve vault using passphrase-based encryption (default when no age keys configured).
690 -- Prompts for passphrase on stdin at startup (if vault file exists).
691 resolvePassphraseVault :: FileConfig -> LogHandle -> IO (Maybe VaultHandle)
692 resolvePassphraseVault fileCfg logger = do
693 dir <- getPureclawDir
694 let path = maybe (dir ++ "/vault/vault.age") T.unpack (_fc_vault_path fileCfg)
695 cfg = VaultConfig
696 { _vc_path = path
697 , _vc_keyType = "AES-256 (passphrase)"
698 , _vc_unlock = UnlockStartup
699 }
700 let getPass = do
701 putStr "Vault passphrase: "
702 hFlush stdout
703 pass <- bracket_
704 (hSetEcho stdin False)
705 (hSetEcho stdin True >> putStrLn "")
706 getLine
707 pure (TE.encodeUtf8 (T.pack pass))
708 enc <- mkPassphraseVaultEncryptor getPass
709 vault <- openVault cfg enc
710 exists <- doesFileExist path
711 if exists
712 then do
713 result <- _vh_unlock vault
714 case result of
715 Left err -> _lh_logInfo logger $
716 "Vault unlock failed: " <> T.pack (show err)
717 Right () -> _lh_logInfo logger "Vault unlocked."
718 pure (Just vault)
719 else do
720 _lh_logInfo logger "No vault found — use `/vault setup` to create one."
721 pure Nothing
722
723 -- | Infer a human-readable key type from the age recipient prefix.
724 inferAgeKeyType :: T.Text -> T.Text
725 inferAgeKeyType recipient
726 | "age-plugin-yubikey" `T.isPrefixOf` recipient = "YubiKey PIV"
727 | "age1" `T.isPrefixOf` recipient = "X25519"
728 | otherwise = "Unknown"
729
730 -- | Parse vault unlock mode from config text.
731 parseUnlockMode :: Maybe T.Text -> UnlockMode
732 parseUnlockMode Nothing = UnlockOnDemand
733 parseUnlockMode (Just t) = case t of
734 "startup" -> UnlockStartup
735 "on_demand" -> UnlockOnDemand
736 "per_access" -> UnlockPerAccess
737 _ -> UnlockOnDemand
738
739 -- | Resolve Signal channel config from the file config.
740 resolveSignalConfig :: FileConfig -> SignalConfig
741 resolveSignalConfig fileCfg =
742 let sigCfg = _fc_signal fileCfg
743 dmPolicy = sigCfg >>= _fsc_dmPolicy
744 allowFrom = case dmPolicy of
745 Just "open" -> AllowAll
746 _ -> case sigCfg >>= _fsc_allowFrom of
747 Nothing -> AllowAll
748 Just [] -> AllowAll
749 Just users -> AllowList (Set.fromList (map UserId users))
750 in SignalConfig
751 { _sc_account = fromMaybe "+0000000000" (sigCfg >>= _fsc_account)
752 , _sc_textChunkLimit = fromMaybe 6000 (sigCfg >>= _fsc_textChunkLimit)
753 , _sc_allowFrom = allowFrom
754 }