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 modelRef <- newIORef model
424 let env = AgentEnv
425 { _env_provider = providerRef
426 , _env_model = modelRef
427 , _env_channel = channel
428 , _env_logger = logger
429 , _env_systemPrompt = sysPrompt
430 , _env_registry = registry
431 , _env_vault = vaultRef
432 , _env_pluginHandle = mkPluginHandle
433 }
434 runAgentLoop env
435
436 case effectiveChannel of
437 "signal" -> do
438 let sigCfg = resolveSignalConfig fileCfg
439 -- Check that signal-cli is installed
440 signalCliResult <- try @IOException $
441 P.readProcess (P.proc "signal-cli" ["--version"])
442 case signalCliResult of
443 Left _ -> do
444 _lh_logWarn logger "signal-cli is not installed or not in PATH."
445 _lh_logWarn logger "Install it from: https://github.com/AsamK/signal-cli"
446 _lh_logWarn logger " brew install signal-cli (macOS)"
447 _lh_logWarn logger " nix-env -i signal-cli (NixOS)"
448 _lh_logWarn logger "Falling back to CLI channel."
449 mkCLIChannelHandle >>= startWithChannel
450 Right _ -> do
451 _lh_logInfo logger $ "Signal account: " <> _sc_account sigCfg
452 transport <- mkSignalCliTransport (_sc_account sigCfg) logger
453 withSignalChannel sigCfg transport logger startWithChannel
454 "cli" ->
455 mkCLIChannelHandle >>= startWithChannel
456 other -> do
457 _lh_logWarn logger $ "Unknown channel: " <> T.pack other <> ". Using CLI."
458 mkCLIChannelHandle >>= startWithChannel
459
460 -- | Parse a provider type from a text value (used for config file).
461 parseProviderMaybe :: Maybe T.Text -> Maybe ProviderType
462 parseProviderMaybe Nothing = Nothing
463 parseProviderMaybe (Just t) = case T.unpack t of
464 "anthropic" -> Just Anthropic
465 "openai" -> Just OpenAI
466 "openrouter" -> Just OpenRouter
467 "ollama" -> Just Ollama
468 _ -> Nothing
469
470 -- | Parse an autonomy level from a CLI string.
471 parseAutonomyLevel :: ReadM AutonomyLevel
472 parseAutonomyLevel = eitherReader $ \s -> case s of
473 "full" -> Right Full
474 "supervised" -> Right Supervised
475 "deny" -> Right Deny
476 _ -> Left $ "Unknown autonomy level: " <> s <> ". Choose: full, supervised, deny"
477
478 -- | Parse an autonomy level from a text value (used for config file).
479 parseAutonomyMaybe :: Maybe T.Text -> Maybe AutonomyLevel
480 parseAutonomyMaybe Nothing = Nothing
481 parseAutonomyMaybe (Just t) = case t of
482 "full" -> Just Full
483 "supervised" -> Just Supervised
484 "deny" -> Just Deny
485 _ -> Nothing
486
487 -- | Parse a memory backend from a text value (used for config file).
488 parseMemoryMaybe :: Maybe T.Text -> Maybe MemoryBackend
489 parseMemoryMaybe Nothing = Nothing
490 parseMemoryMaybe (Just t) = case T.unpack t of
491 "none" -> Just NoMemory
492 "sqlite" -> Just SQLiteMemory
493 "markdown" -> Just MarkdownMemory
494 _ -> Nothing
495
496 -- | Build the tool registry with all available tools.
497 buildRegistry :: SecurityPolicy -> ShellHandle -> WorkspaceRoot -> FileHandle -> MemoryHandle -> NetworkHandle -> ToolRegistry
498 buildRegistry policy sh workspace fh mh nh =
499 let reg = uncurry registerTool
500 in reg (shellTool policy sh)
501 $ reg (fileReadTool workspace fh)
502 $ reg (fileWriteTool workspace fh)
503 $ reg (gitTool policy sh)
504 $ reg (memoryStoreTool mh)
505 $ reg (memoryRecallTool mh)
506 $ reg (httpRequestTool AllowAll nh)
507 emptyRegistry
508
509 -- | Build a security policy from optional autonomy level and allowed commands.
510 --
511 -- Behavior:
512 -- * @Just Full@ + empty allow list → 'AllowAll' + 'Full' (unrestricted mode)
513 -- * @Just Full@ + allow list → 'AllowList' of those commands + 'Full'
514 -- * @Just Supervised@ + allow list → 'AllowList' + 'Supervised'
515 -- * @Just Deny@ → 'defaultPolicy' ('Deny', empty 'AllowList')
516 -- * @Nothing@ + empty allow list → 'defaultPolicy' (backward compat)
517 -- * @Nothing@ + allow list → 'Full' + 'AllowList' (backward compat)
518 buildPolicy :: Maybe AutonomyLevel -> [String] -> SecurityPolicy
519 buildPolicy (Just Deny) _ = defaultPolicy
520 buildPolicy (Just level) [] = SecurityPolicy
521 { _sp_allowedCommands = AllowAll
522 , _sp_autonomy = level
523 }
524 buildPolicy (Just level) cmds =
525 let cmdNames = Set.fromList (map (CommandName . T.pack) cmds)
526 in SecurityPolicy
527 { _sp_allowedCommands = AllowList cmdNames
528 , _sp_autonomy = level
529 }
530 buildPolicy Nothing [] = defaultPolicy
531 buildPolicy Nothing cmds =
532 let cmdNames = Set.fromList (map (CommandName . T.pack) cmds)
533 in SecurityPolicy
534 { _sp_allowedCommands = AllowList cmdNames
535 , _sp_autonomy = Full
536 }
537
538 -- | Resolve the LLM provider from the provider type.
539 -- Checks CLI flag first, then the vault for the API key.
540 -- Returns 'Nothing' if no credentials are available (the agent loop
541 -- will still start, allowing the user to configure credentials via
542 -- slash commands like /vault setup).
543 resolveProvider :: ProviderType -> Maybe String -> Maybe VaultHandle -> HTTP.Manager -> IO (Maybe SomeProvider)
544 resolveProvider Anthropic keyOpt vaultOpt manager = do
545 mApiKey <- resolveApiKey keyOpt "ANTHROPIC_API_KEY" vaultOpt
546 case mApiKey of
547 Just k -> pure (Just (MkProvider (mkAnthropicProvider manager k)))
548 Nothing -> do
549 -- Fall back to cached OAuth tokens in the vault
550 cachedBs <- tryVaultLookup vaultOpt oauthVaultKey
551 case cachedBs >>= eitherToMaybe . deserializeTokens of
552 Nothing -> pure Nothing
553 Just tokens -> do
554 let cfg = defaultOAuthConfig
555 now <- getCurrentTime
556 t <- if _oat_expiresAt tokens <= now
557 then do
558 putStrLn "OAuth access token expired \x2014 refreshing..."
559 newT <- refreshOAuthToken cfg manager (_oat_refreshToken tokens)
560 saveOAuthTokens vaultOpt newT
561 pure newT
562 else pure tokens
563 handle <- mkOAuthHandle cfg manager t
564 pure (Just (MkProvider (mkAnthropicProviderOAuth manager handle)))
565 resolveProvider OpenAI keyOpt vaultOpt manager = do
566 mApiKey <- resolveApiKey keyOpt "OPENAI_API_KEY" vaultOpt
567 pure (fmap (MkProvider . mkOpenAIProvider manager) mApiKey)
568 resolveProvider OpenRouter keyOpt vaultOpt manager = do
569 mApiKey <- resolveApiKey keyOpt "OPENROUTER_API_KEY" vaultOpt
570 pure (fmap (MkProvider . mkOpenRouterProvider manager) mApiKey)
571 resolveProvider Ollama _ _ manager =
572 pure (Just (MkProvider (mkOllamaProvider manager)))
573
574 -- | Vault key used to cache OAuth tokens between sessions.
575 oauthVaultKey :: T.Text
576 oauthVaultKey = "ANTHROPIC_OAUTH_TOKENS"
577
578 -- | Resolve an Anthropic provider via OAuth 2.0 PKCE.
579 -- Loads cached tokens from the vault if available; runs the full browser
580 -- flow otherwise. Refreshes expired access tokens automatically.
581 resolveAnthropicOAuth :: Maybe VaultHandle -> HTTP.Manager -> IO SomeProvider
582 resolveAnthropicOAuth vaultOpt manager = do
583 let cfg = defaultOAuthConfig
584 cachedBs <- tryVaultLookup vaultOpt oauthVaultKey
585 tokens <- case cachedBs >>= eitherToMaybe . deserializeTokens of
586 Just t -> do
587 now <- getCurrentTime
588 if _oat_expiresAt t <= now
589 then do
590 putStrLn "OAuth access token expired — refreshing..."
591 newT <- refreshOAuthToken cfg manager (_oat_refreshToken t)
592 saveOAuthTokens vaultOpt newT
593 pure newT
594 else pure t
595 Nothing -> do
596 t <- runOAuthFlow cfg manager
597 saveOAuthTokens vaultOpt t
598 pure t
599 handle <- mkOAuthHandle cfg manager tokens
600 pure (MkProvider (mkAnthropicProviderOAuth manager handle))
601
602 -- | Save OAuth tokens to the vault (best-effort; logs on failure).
603 saveOAuthTokens :: Maybe VaultHandle -> OAuthTokens -> IO ()
604 saveOAuthTokens Nothing _ = pure ()
605 saveOAuthTokens (Just vh) tokens = do
606 result <- _vh_put vh oauthVaultKey (serializeTokens tokens)
607 case result of
608 Left err -> putStrLn $ "Warning: could not cache OAuth tokens: " <> show err
609 Right () -> pure ()
610
611 -- | Convert 'Either' to 'Maybe', discarding the error.
612 eitherToMaybe :: Either e a -> Maybe a
613 eitherToMaybe (Left _) = Nothing
614 eitherToMaybe (Right a) = Just a
615
616 -- | Resolve an API key from: CLI flag → vault.
617 -- Returns 'Nothing' if no key is found.
618 resolveApiKey :: Maybe String -> String -> Maybe VaultHandle -> IO (Maybe ApiKey)
619 resolveApiKey (Just key) _ _ = pure (Just (mkApiKey (TE.encodeUtf8 (T.pack key))))
620 resolveApiKey Nothing vaultKeyName vaultOpt = do
621 vaultKey <- tryVaultLookup vaultOpt (T.pack vaultKeyName)
622 case vaultKey of
623 Just bs -> pure (Just (mkApiKey bs))
624 Nothing -> pure Nothing
625
626 -- | Try to look up a key from the vault. Returns 'Nothing' if the vault is
627 -- absent, locked, or does not contain the key.
628 tryVaultLookup :: Maybe VaultHandle -> T.Text -> IO (Maybe ByteString)
629 tryVaultLookup Nothing _ = pure Nothing
630 tryVaultLookup (Just vh) key = do
631 result <- _vh_get vh key
632 case result of
633 Right bs -> pure (Just bs)
634 Left _ -> pure Nothing
635
636 -- | Resolve the memory backend.
637 resolveMemory :: MemoryBackend -> IO MemoryHandle
638 resolveMemory NoMemory = pure mkNoOpMemoryHandle
639 resolveMemory SQLiteMemory = do
640 dir <- getPureclawDir
641 mkSQLiteMemoryHandle (dir ++ "/memory.db")
642 resolveMemory MarkdownMemory = do
643 dir <- getPureclawDir
644 mkMarkdownMemoryHandle (dir ++ "/memory")
645
646 -- | Open the vault if configured. Returns 'Nothing' if @--no-vault@ is set.
647 -- When age keys are configured, uses age public-key encryption.
648 -- Otherwise, falls back to passphrase-based encryption (works out of the box).
649 resolveVault :: FileConfig -> Bool -> LogHandle -> IO (Maybe VaultHandle)
650 resolveVault _ True _ = pure Nothing
651 resolveVault fileCfg False logger =
652 case (_fc_vault_recipient fileCfg, _fc_vault_identity fileCfg) of
653 (Just recipient, Just identity) -> resolveAgeVault fileCfg recipient identity logger
654 _ -> resolvePassphraseVault fileCfg logger
655
656 -- | Resolve vault using age public-key encryption (existing behaviour).
657 resolveAgeVault :: FileConfig -> T.Text -> T.Text -> LogHandle -> IO (Maybe VaultHandle)
658 resolveAgeVault fileCfg recipient identity logger = do
659 encResult <- mkAgeEncryptor
660 case encResult of
661 Left err -> do
662 _lh_logInfo logger $ "Vault disabled (age not available): " <> T.pack (show err)
663 pure Nothing
664 Right enc -> do
665 dir <- getPureclawDir
666 let path = maybe (dir ++ "/vault/vault.age") T.unpack (_fc_vault_path fileCfg)
667 mode = parseUnlockMode (_fc_vault_unlock fileCfg)
668 enc' = ageVaultEncryptor enc recipient identity
669 cfg = VaultConfig
670 { _vc_path = path
671 , _vc_keyType = inferAgeKeyType recipient
672 , _vc_unlock = mode
673 }
674 vault <- openVault cfg enc'
675 exists <- doesFileExist path
676 if exists
677 then do
678 case mode of
679 UnlockStartup -> do
680 result <- _vh_unlock vault
681 case result of
682 Left err -> _lh_logInfo logger $
683 "Vault startup unlock failed (vault will be locked): " <> T.pack (show err)
684 Right () -> _lh_logInfo logger "Vault unlocked."
685 _ -> pure ()
686 pure (Just vault)
687 else do
688 _lh_logInfo logger "No vault found — use `/vault setup` to create one."
689 pure Nothing
690
691 -- | Resolve vault using passphrase-based encryption (default when no age keys configured).
692 -- Prompts for passphrase on stdin at startup (if vault file exists).
693 resolvePassphraseVault :: FileConfig -> LogHandle -> IO (Maybe VaultHandle)
694 resolvePassphraseVault fileCfg logger = do
695 dir <- getPureclawDir
696 let path = maybe (dir ++ "/vault/vault.age") T.unpack (_fc_vault_path fileCfg)
697 cfg = VaultConfig
698 { _vc_path = path
699 , _vc_keyType = "AES-256 (passphrase)"
700 , _vc_unlock = UnlockStartup
701 }
702 let getPass = do
703 putStr "Vault passphrase: "
704 hFlush stdout
705 pass <- bracket_
706 (hSetEcho stdin False)
707 (hSetEcho stdin True >> putStrLn "")
708 getLine
709 pure (TE.encodeUtf8 (T.pack pass))
710 enc <- mkPassphraseVaultEncryptor getPass
711 vault <- openVault cfg enc
712 exists <- doesFileExist path
713 if exists
714 then do
715 result <- _vh_unlock vault
716 case result of
717 Left err -> _lh_logInfo logger $
718 "Vault unlock failed: " <> T.pack (show err)
719 Right () -> _lh_logInfo logger "Vault unlocked."
720 pure (Just vault)
721 else do
722 _lh_logInfo logger "No vault found — use `/vault setup` to create one."
723 pure Nothing
724
725 -- | Infer a human-readable key type from the age recipient prefix.
726 inferAgeKeyType :: T.Text -> T.Text
727 inferAgeKeyType recipient
728 | "age-plugin-yubikey" `T.isPrefixOf` recipient = "YubiKey PIV"
729 | "age1" `T.isPrefixOf` recipient = "X25519"
730 | otherwise = "Unknown"
731
732 -- | Parse vault unlock mode from config text.
733 parseUnlockMode :: Maybe T.Text -> UnlockMode
734 parseUnlockMode Nothing = UnlockOnDemand
735 parseUnlockMode (Just t) = case t of
736 "startup" -> UnlockStartup
737 "on_demand" -> UnlockOnDemand
738 "per_access" -> UnlockPerAccess
739 _ -> UnlockOnDemand
740
741 -- | Resolve Signal channel config from the file config.
742 resolveSignalConfig :: FileConfig -> SignalConfig
743 resolveSignalConfig fileCfg =
744 let sigCfg = _fc_signal fileCfg
745 dmPolicy = sigCfg >>= _fsc_dmPolicy
746 allowFrom = case dmPolicy of
747 Just "open" -> AllowAll
748 _ -> case sigCfg >>= _fsc_allowFrom of
749 Nothing -> AllowAll
750 Just [] -> AllowAll
751 Just users -> AllowList (Set.fromList (map UserId users))
752 in SignalConfig
753 { _sc_account = fromMaybe "+0000000000" (sigCfg >>= _fsc_account)
754 , _sc_textChunkLimit = fromMaybe 6000 (sigCfg >>= _fsc_textChunkLimit)
755 , _sc_allowFrom = allowFrom
756 }