never executed always true always false
1 module PureClaw.CLI.Commands
2 ( -- * Entry point
3 runCLI
4 -- * Options (exported for testing)
5 , ChatOptions (..)
6 , chatOptionsParser
7 -- * Enums (exported for testing)
8 , ProviderType (..)
9 , MemoryBackend (..)
10 ) where
11
12 import Control.Exception (bracket_)
13 import Data.ByteString (ByteString)
14 import Data.IORef
15 import Data.Maybe
16 import Data.Set qualified as Set
17 import Data.Text qualified as T
18 import Data.Text.Encoding qualified as TE
19 import Data.Time.Clock (getCurrentTime)
20 import Network.HTTP.Client qualified as HTTP
21 import Network.HTTP.Client.TLS qualified as HTTP
22 import Options.Applicative
23 import System.Directory (doesFileExist)
24
25 import System.IO
26
27 import PureClaw.Auth.AnthropicOAuth
28 import PureClaw.CLI.Config
29
30 import PureClaw.Agent.Env
31 import PureClaw.Agent.Identity
32 import PureClaw.Agent.Loop
33 import PureClaw.Channels.CLI
34 import PureClaw.Core.Types
35 import PureClaw.Handles.File
36 import PureClaw.Handles.Log
37 import PureClaw.Handles.Memory
38 import PureClaw.Handles.Network
39 import PureClaw.Handles.Shell
40 import PureClaw.Memory.Markdown
41 import PureClaw.Memory.SQLite
42 import PureClaw.Providers.Anthropic
43 import PureClaw.Providers.Class
44 import PureClaw.Providers.Ollama
45 import PureClaw.Providers.OpenAI
46 import PureClaw.Providers.OpenRouter
47 import PureClaw.Security.Policy
48 import PureClaw.Security.Secrets
49 import PureClaw.Security.Vault
50 import PureClaw.Security.Vault.Age
51 import PureClaw.Security.Vault.Passphrase
52 import PureClaw.Security.Vault.Plugin
53 import PureClaw.Tools.FileRead
54 import PureClaw.Tools.FileWrite
55 import PureClaw.Tools.Git
56 import PureClaw.Tools.HttpRequest
57 import PureClaw.Tools.Memory
58 import PureClaw.Tools.Registry
59 import PureClaw.Tools.Shell
60
61 -- | Supported LLM providers.
62 data ProviderType
63 = Anthropic
64 | OpenAI
65 | OpenRouter
66 | Ollama
67 deriving stock (Show, Eq, Ord, Bounded, Enum)
68
69 -- | Supported memory backends.
70 data MemoryBackend
71 = NoMemory
72 | SQLiteMemory
73 | MarkdownMemory
74 deriving stock (Show, Eq, Ord, Bounded, Enum)
75
76 -- | CLI chat options.
77 -- Fields with defaults use 'Maybe' so config file values can fill in omitted flags.
78 data ChatOptions = ChatOptions
79 { _co_model :: Maybe String
80 , _co_apiKey :: Maybe String
81 , _co_system :: Maybe String
82 , _co_provider :: Maybe ProviderType
83 , _co_allowCommands :: [String]
84 , _co_memory :: Maybe MemoryBackend
85 , _co_soul :: Maybe String
86 , _co_config :: Maybe FilePath
87 , _co_noVault :: Bool
88 , _co_oauth :: Bool
89 }
90 deriving stock (Show, Eq)
91
92 -- | Parser for chat options.
93 chatOptionsParser :: Parser ChatOptions
94 chatOptionsParser = ChatOptions
95 <$> optional (strOption
96 ( long "model"
97 <> short 'm'
98 <> help "Model to use (default: claude-sonnet-4-20250514)"
99 ))
100 <*> optional (strOption
101 ( long "api-key"
102 <> help "API key (default: from config file or env var for chosen provider)"
103 ))
104 <*> optional (strOption
105 ( long "system"
106 <> short 's'
107 <> help "System prompt (overrides SOUL.md)"
108 ))
109 <*> optional (option parseProviderType
110 ( long "provider"
111 <> short 'p'
112 <> help "LLM provider: anthropic, openai, openrouter, ollama (default: anthropic)"
113 ))
114 <*> many (strOption
115 ( long "allow"
116 <> short 'a'
117 <> help "Allow a shell command (repeatable, e.g. --allow git --allow ls)"
118 ))
119 <*> optional (option parseMemoryBackend
120 ( long "memory"
121 <> help "Memory backend: none, sqlite, markdown (default: none)"
122 ))
123 <*> optional (strOption
124 ( long "soul"
125 <> help "Path to SOUL.md identity file (default: ./SOUL.md if it exists)"
126 ))
127 <*> optional (strOption
128 ( long "config"
129 <> short 'c'
130 <> help "Path to config file (default: ~/.pureclaw/config.toml or ~/.config/pureclaw/config.toml)"
131 ))
132 <*> switch
133 ( long "no-vault"
134 <> help "Disable vault even if configured in config file"
135 )
136 <*> switch
137 ( long "oauth"
138 <> help "Authenticate with Anthropic via OAuth (opens browser). Tokens are cached in the vault."
139 )
140
141 -- | Parse a provider type from a CLI string.
142 parseProviderType :: ReadM ProviderType
143 parseProviderType = eitherReader $ \s -> case s of
144 "anthropic" -> Right Anthropic
145 "openai" -> Right OpenAI
146 "openrouter" -> Right OpenRouter
147 "ollama" -> Right Ollama
148 _ -> Left $ "Unknown provider: " <> s <> ". Choose: anthropic, openai, openrouter, ollama"
149
150 -- | Display a provider type as a CLI string.
151 providerToText :: ProviderType -> String
152 providerToText Anthropic = "anthropic"
153 providerToText OpenAI = "openai"
154 providerToText OpenRouter = "openrouter"
155 providerToText Ollama = "ollama"
156
157 -- | Parse a memory backend from a CLI string.
158 parseMemoryBackend :: ReadM MemoryBackend
159 parseMemoryBackend = eitherReader $ \s -> case s of
160 "none" -> Right NoMemory
161 "sqlite" -> Right SQLiteMemory
162 "markdown" -> Right MarkdownMemory
163 _ -> Left $ "Unknown memory backend: " <> s <> ". Choose: none, sqlite, markdown"
164
165 -- | Display a memory backend as a CLI string.
166 memoryToText :: MemoryBackend -> String
167 memoryToText NoMemory = "none"
168 memoryToText SQLiteMemory = "sqlite"
169 memoryToText MarkdownMemory = "markdown"
170
171 -- | Full CLI parser with help and version.
172 cliParserInfo :: ParserInfo ChatOptions
173 cliParserInfo = info (chatOptionsParser <**> helper)
174 ( fullDesc
175 <> progDesc "Interactive AI chat with tool use"
176 <> header "pureclaw — Haskell-native AI agent runtime"
177 )
178
179 -- | Main CLI entry point.
180 runCLI :: IO ()
181 runCLI = do
182 opts <- execParser cliParserInfo
183 runChat opts
184
185 -- | Run an interactive chat session.
186 runChat :: ChatOptions -> IO ()
187 runChat opts = do
188 let logger = mkStderrLogHandle
189
190 -- Load config file: --config flag overrides default search locations
191 fileCfg <- maybe loadConfig loadFileConfig (_co_config opts)
192
193 -- Resolve effective values: CLI flag > config file > default
194 let effectiveProvider = fromMaybe Anthropic (_co_provider opts <|> parseProviderMaybe (_fc_provider fileCfg))
195 effectiveModel = fromMaybe "claude-sonnet-4-20250514" (_co_model opts <|> fmap T.unpack (_fc_model fileCfg))
196 effectiveMemory = fromMaybe NoMemory (_co_memory opts <|> parseMemoryMaybe (_fc_memory fileCfg))
197 effectiveApiKey = _co_apiKey opts <|> fmap T.unpack (_fc_apiKey fileCfg)
198 effectiveSystem = _co_system opts <|> fmap T.unpack (_fc_system fileCfg)
199 effectiveAllow = _co_allowCommands opts <> maybe [] (map T.unpack) (_fc_allow fileCfg)
200
201 -- Vault (opened before provider so API keys can be fetched from vault)
202 vaultOpt <- resolveVault fileCfg (_co_noVault opts) logger
203
204 -- Provider (may be Nothing if no credentials are configured yet)
205 manager <- HTTP.newTlsManager
206 mProvider <- if effectiveProvider == Anthropic && _co_oauth opts
207 then Just <$> resolveAnthropicOAuth vaultOpt manager
208 else resolveProvider effectiveProvider effectiveApiKey vaultOpt manager
209
210 -- Model
211 let model = ModelId (T.pack effectiveModel)
212
213 -- System prompt: effective --system flag > SOUL.md > nothing
214 sysPrompt <- case effectiveSystem of
215 Just s -> pure (Just (T.pack s))
216 Nothing -> do
217 let soulPath = fromMaybe "SOUL.md" (_co_soul opts)
218 ident <- loadIdentity soulPath
219 if ident == defaultIdentity
220 then pure Nothing
221 else pure (Just (identitySystemPrompt ident))
222
223 -- Security policy
224 let policy = buildPolicy effectiveAllow
225
226 -- Handles
227 let channel = mkCLIChannelHandle
228 workspace = WorkspaceRoot "."
229 sh = mkShellHandle logger
230 fh = mkFileHandle workspace
231 nh = mkNetworkHandle manager
232 mh <- resolveMemory effectiveMemory
233
234 -- Tool registry
235 let registry = buildRegistry policy sh workspace fh mh nh
236
237 hSetBuffering stdout LineBuffering
238 case mProvider of
239 Just _ -> _lh_logInfo logger $ "Provider: " <> T.pack (providerToText effectiveProvider)
240 Nothing -> _lh_logInfo logger
241 "No providers configured \x2014 use /provider to get started"
242 _lh_logInfo logger $ "Model: " <> T.pack effectiveModel
243 _lh_logInfo logger $ "Memory: " <> T.pack (memoryToText effectiveMemory)
244 case effectiveAllow of
245 [] -> _lh_logInfo logger "Commands: none (deny all)"
246 cmds -> _lh_logInfo logger $ "Commands: " <> T.intercalate ", " (map T.pack cmds)
247 putStrLn "PureClaw 0.1.0 — Haskell-native AI agent runtime"
248 putStrLn "Type your message and press Enter. Ctrl-D to exit."
249 putStrLn ""
250 vaultRef <- newIORef vaultOpt
251 providerRef <- newIORef mProvider
252 let env = AgentEnv
253 { _env_provider = providerRef
254 , _env_model = model
255 , _env_channel = channel
256 , _env_logger = logger
257 , _env_systemPrompt = sysPrompt
258 , _env_registry = registry
259 , _env_vault = vaultRef
260 , _env_pluginHandle = mkPluginHandle
261 }
262 runAgentLoop env
263
264 -- | Parse a provider type from a text value (used for config file).
265 parseProviderMaybe :: Maybe T.Text -> Maybe ProviderType
266 parseProviderMaybe Nothing = Nothing
267 parseProviderMaybe (Just t) = case T.unpack t of
268 "anthropic" -> Just Anthropic
269 "openai" -> Just OpenAI
270 "openrouter" -> Just OpenRouter
271 "ollama" -> Just Ollama
272 _ -> Nothing
273
274 -- | Parse a memory backend from a text value (used for config file).
275 parseMemoryMaybe :: Maybe T.Text -> Maybe MemoryBackend
276 parseMemoryMaybe Nothing = Nothing
277 parseMemoryMaybe (Just t) = case T.unpack t of
278 "none" -> Just NoMemory
279 "sqlite" -> Just SQLiteMemory
280 "markdown" -> Just MarkdownMemory
281 _ -> Nothing
282
283 -- | Build the tool registry with all available tools.
284 buildRegistry :: SecurityPolicy -> ShellHandle -> WorkspaceRoot -> FileHandle -> MemoryHandle -> NetworkHandle -> ToolRegistry
285 buildRegistry policy sh workspace fh mh nh =
286 let reg = uncurry registerTool
287 in reg (shellTool policy sh)
288 $ reg (fileReadTool workspace fh)
289 $ reg (fileWriteTool workspace fh)
290 $ reg (gitTool policy sh)
291 $ reg (memoryStoreTool mh)
292 $ reg (memoryRecallTool mh)
293 $ reg (httpRequestTool AllowAll nh)
294 emptyRegistry
295
296 -- | Build a security policy from the list of allowed commands.
297 buildPolicy :: [String] -> SecurityPolicy
298 buildPolicy [] = defaultPolicy
299 buildPolicy cmds =
300 let cmdNames = Set.fromList (map (CommandName . T.pack) cmds)
301 in defaultPolicy
302 { _sp_allowedCommands = AllowList cmdNames
303 , _sp_autonomy = Full
304 }
305
306 -- | Resolve the LLM provider from the provider type.
307 -- Checks CLI flag first, then the vault for the API key.
308 -- Returns 'Nothing' if no credentials are available (the agent loop
309 -- will still start, allowing the user to configure credentials via
310 -- slash commands like /vault setup).
311 resolveProvider :: ProviderType -> Maybe String -> Maybe VaultHandle -> HTTP.Manager -> IO (Maybe SomeProvider)
312 resolveProvider Anthropic keyOpt vaultOpt manager = do
313 mApiKey <- resolveApiKey keyOpt "ANTHROPIC_API_KEY" vaultOpt
314 case mApiKey of
315 Just k -> pure (Just (MkProvider (mkAnthropicProvider manager k)))
316 Nothing -> do
317 -- Fall back to cached OAuth tokens in the vault
318 cachedBs <- tryVaultLookup vaultOpt oauthVaultKey
319 case cachedBs >>= eitherToMaybe . deserializeTokens of
320 Nothing -> pure Nothing
321 Just tokens -> do
322 let cfg = defaultOAuthConfig
323 now <- getCurrentTime
324 t <- if _oat_expiresAt tokens <= now
325 then do
326 putStrLn "OAuth access token expired \x2014 refreshing..."
327 newT <- refreshOAuthToken cfg manager (_oat_refreshToken tokens)
328 saveOAuthTokens vaultOpt newT
329 pure newT
330 else pure tokens
331 handle <- mkOAuthHandle cfg manager t
332 pure (Just (MkProvider (mkAnthropicProviderOAuth manager handle)))
333 resolveProvider OpenAI keyOpt vaultOpt manager = do
334 mApiKey <- resolveApiKey keyOpt "OPENAI_API_KEY" vaultOpt
335 pure (fmap (MkProvider . mkOpenAIProvider manager) mApiKey)
336 resolveProvider OpenRouter keyOpt vaultOpt manager = do
337 mApiKey <- resolveApiKey keyOpt "OPENROUTER_API_KEY" vaultOpt
338 pure (fmap (MkProvider . mkOpenRouterProvider manager) mApiKey)
339 resolveProvider Ollama _ _ manager =
340 pure (Just (MkProvider (mkOllamaProvider manager)))
341
342 -- | Vault key used to cache OAuth tokens between sessions.
343 oauthVaultKey :: T.Text
344 oauthVaultKey = "ANTHROPIC_OAUTH_TOKENS"
345
346 -- | Resolve an Anthropic provider via OAuth 2.0 PKCE.
347 -- Loads cached tokens from the vault if available; runs the full browser
348 -- flow otherwise. Refreshes expired access tokens automatically.
349 resolveAnthropicOAuth :: Maybe VaultHandle -> HTTP.Manager -> IO SomeProvider
350 resolveAnthropicOAuth vaultOpt manager = do
351 let cfg = defaultOAuthConfig
352 cachedBs <- tryVaultLookup vaultOpt oauthVaultKey
353 tokens <- case cachedBs >>= eitherToMaybe . deserializeTokens of
354 Just t -> do
355 now <- getCurrentTime
356 if _oat_expiresAt t <= now
357 then do
358 putStrLn "OAuth access token expired — refreshing..."
359 newT <- refreshOAuthToken cfg manager (_oat_refreshToken t)
360 saveOAuthTokens vaultOpt newT
361 pure newT
362 else pure t
363 Nothing -> do
364 t <- runOAuthFlow cfg manager
365 saveOAuthTokens vaultOpt t
366 pure t
367 handle <- mkOAuthHandle cfg manager tokens
368 pure (MkProvider (mkAnthropicProviderOAuth manager handle))
369
370 -- | Save OAuth tokens to the vault (best-effort; logs on failure).
371 saveOAuthTokens :: Maybe VaultHandle -> OAuthTokens -> IO ()
372 saveOAuthTokens Nothing _ = pure ()
373 saveOAuthTokens (Just vh) tokens = do
374 result <- _vh_put vh oauthVaultKey (serializeTokens tokens)
375 case result of
376 Left err -> putStrLn $ "Warning: could not cache OAuth tokens: " <> show err
377 Right () -> pure ()
378
379 -- | Convert 'Either' to 'Maybe', discarding the error.
380 eitherToMaybe :: Either e a -> Maybe a
381 eitherToMaybe (Left _) = Nothing
382 eitherToMaybe (Right a) = Just a
383
384 -- | Resolve an API key from: CLI flag → vault.
385 -- Returns 'Nothing' if no key is found.
386 resolveApiKey :: Maybe String -> String -> Maybe VaultHandle -> IO (Maybe ApiKey)
387 resolveApiKey (Just key) _ _ = pure (Just (mkApiKey (TE.encodeUtf8 (T.pack key))))
388 resolveApiKey Nothing vaultKeyName vaultOpt = do
389 vaultKey <- tryVaultLookup vaultOpt (T.pack vaultKeyName)
390 case vaultKey of
391 Just bs -> pure (Just (mkApiKey bs))
392 Nothing -> pure Nothing
393
394 -- | Try to look up a key from the vault. Returns 'Nothing' if the vault is
395 -- absent, locked, or does not contain the key.
396 tryVaultLookup :: Maybe VaultHandle -> T.Text -> IO (Maybe ByteString)
397 tryVaultLookup Nothing _ = pure Nothing
398 tryVaultLookup (Just vh) key = do
399 result <- _vh_get vh key
400 case result of
401 Right bs -> pure (Just bs)
402 Left _ -> pure Nothing
403
404 -- | Resolve the memory backend.
405 resolveMemory :: MemoryBackend -> IO MemoryHandle
406 resolveMemory NoMemory = pure mkNoOpMemoryHandle
407 resolveMemory SQLiteMemory = do
408 dir <- getPureclawDir
409 mkSQLiteMemoryHandle (dir ++ "/memory.db")
410 resolveMemory MarkdownMemory = do
411 dir <- getPureclawDir
412 mkMarkdownMemoryHandle (dir ++ "/memory")
413
414 -- | Open the vault if configured. Returns 'Nothing' if @--no-vault@ is set.
415 -- When age keys are configured, uses age public-key encryption.
416 -- Otherwise, falls back to passphrase-based encryption (works out of the box).
417 resolveVault :: FileConfig -> Bool -> LogHandle -> IO (Maybe VaultHandle)
418 resolveVault _ True _ = pure Nothing
419 resolveVault fileCfg False logger =
420 case (_fc_vault_recipient fileCfg, _fc_vault_identity fileCfg) of
421 (Just recipient, Just identity) -> resolveAgeVault fileCfg recipient identity logger
422 _ -> resolvePassphraseVault fileCfg logger
423
424 -- | Resolve vault using age public-key encryption (existing behaviour).
425 resolveAgeVault :: FileConfig -> T.Text -> T.Text -> LogHandle -> IO (Maybe VaultHandle)
426 resolveAgeVault fileCfg recipient identity logger = do
427 encResult <- mkAgeEncryptor
428 case encResult of
429 Left err -> do
430 _lh_logInfo logger $ "Vault disabled (age not available): " <> T.pack (show err)
431 pure Nothing
432 Right enc -> do
433 dir <- getPureclawDir
434 let path = maybe (dir ++ "/vault/vault.age") T.unpack (_fc_vault_path fileCfg)
435 mode = parseUnlockMode (_fc_vault_unlock fileCfg)
436 enc' = ageVaultEncryptor enc recipient identity
437 cfg = VaultConfig
438 { _vc_path = path
439 , _vc_keyType = inferAgeKeyType recipient
440 , _vc_unlock = mode
441 }
442 vault <- openVault cfg enc'
443 exists <- doesFileExist path
444 if exists
445 then do
446 case mode of
447 UnlockStartup -> do
448 result <- _vh_unlock vault
449 case result of
450 Left err -> _lh_logInfo logger $
451 "Vault startup unlock failed (vault will be locked): " <> T.pack (show err)
452 Right () -> _lh_logInfo logger "Vault unlocked."
453 _ -> pure ()
454 pure (Just vault)
455 else do
456 _lh_logInfo logger "No vault found — use `/vault setup` to create one."
457 pure Nothing
458
459 -- | Resolve vault using passphrase-based encryption (default when no age keys configured).
460 -- Prompts for passphrase on stdin at startup (if vault file exists).
461 resolvePassphraseVault :: FileConfig -> LogHandle -> IO (Maybe VaultHandle)
462 resolvePassphraseVault fileCfg logger = do
463 dir <- getPureclawDir
464 let path = maybe (dir ++ "/vault/vault.age") T.unpack (_fc_vault_path fileCfg)
465 cfg = VaultConfig
466 { _vc_path = path
467 , _vc_keyType = "AES-256 (passphrase)"
468 , _vc_unlock = UnlockStartup
469 }
470 let getPass = do
471 putStr "Vault passphrase: "
472 hFlush stdout
473 pass <- bracket_
474 (hSetEcho stdin False)
475 (hSetEcho stdin True >> putStrLn "")
476 getLine
477 pure (TE.encodeUtf8 (T.pack pass))
478 enc <- mkPassphraseVaultEncryptor getPass
479 vault <- openVault cfg enc
480 exists <- doesFileExist path
481 if exists
482 then do
483 result <- _vh_unlock vault
484 case result of
485 Left err -> _lh_logInfo logger $
486 "Vault unlock failed: " <> T.pack (show err)
487 Right () -> _lh_logInfo logger "Vault unlocked."
488 pure (Just vault)
489 else do
490 _lh_logInfo logger "No vault found — use `/vault setup` to create one."
491 pure Nothing
492
493 -- | Infer a human-readable key type from the age recipient prefix.
494 inferAgeKeyType :: T.Text -> T.Text
495 inferAgeKeyType recipient
496 | "age-plugin-yubikey" `T.isPrefixOf` recipient = "YubiKey PIV"
497 | "age1" `T.isPrefixOf` recipient = "X25519"
498 | otherwise = "Unknown"
499
500 -- | Parse vault unlock mode from config text.
501 parseUnlockMode :: Maybe T.Text -> UnlockMode
502 parseUnlockMode Nothing = UnlockOnDemand
503 parseUnlockMode (Just t) = case t of
504 "startup" -> UnlockStartup
505 "on_demand" -> UnlockOnDemand
506 "per_access" -> UnlockPerAccess
507 _ -> UnlockOnDemand