never executed always true always false
1 module PureClaw.Agent.SlashCommands
2 ( -- * Command data types
3 SlashCommand (..)
4 , VaultSubCommand (..)
5 , ProviderSubCommand (..)
6 -- * Command registry — single source of truth
7 , CommandGroup (..)
8 , CommandSpec (..)
9 , allCommandSpecs
10 -- * Parsing (derived from allCommandSpecs)
11 , parseSlashCommand
12 -- * Execution
13 , executeSlashCommand
14 ) where
15
16 import Control.Applicative ((<|>))
17 import Control.Exception
18 import Data.Foldable (asum)
19 import Data.IORef
20 import Data.List qualified as L
21 import Data.Maybe (listToMaybe)
22 import Data.Text (Text)
23 import Data.Text qualified as T
24 import Data.Text.Encoding qualified as TE
25 import Data.Text.IO qualified as TIO
26 import Network.HTTP.Client.TLS qualified as HTTP
27 import System.Directory qualified as Dir
28 import System.FilePath ((</>))
29
30 import PureClaw.Agent.Compaction
31 import PureClaw.Agent.Context
32 import PureClaw.Agent.Env
33 import PureClaw.Auth.AnthropicOAuth
34 import PureClaw.CLI.Config
35 import PureClaw.Handles.Channel
36 import PureClaw.Security.Vault
37 import PureClaw.Security.Vault.Age
38 import PureClaw.Security.Vault.Passphrase
39 import PureClaw.Security.Vault.Plugin
40
41 -- ---------------------------------------------------------------------------
42 -- Command taxonomy
43 -- ---------------------------------------------------------------------------
44
45 -- | Organisational group for display in '/help'.
46 data CommandGroup
47 = GroupSession -- ^ Session and context management
48 | GroupProvider -- ^ Model provider configuration
49 | GroupVault -- ^ Encrypted secrets vault
50 deriving stock (Show, Eq, Ord, Enum, Bounded)
51
52 -- | Human-readable section heading for '/help' output.
53 groupHeading :: CommandGroup -> Text
54 groupHeading GroupSession = "Session"
55 groupHeading GroupProvider = "Provider"
56 groupHeading GroupVault = "Vault"
57
58 -- | Specification for a single slash command.
59 -- 'allCommandSpecs' is the single source of truth: 'parseSlashCommand'
60 -- is derived from '_cs_parse' and '/help' renders from '_cs_syntax' /
61 -- '_cs_description', so the two cannot diverge.
62 data CommandSpec = CommandSpec
63 { _cs_syntax :: Text -- ^ Display syntax, e.g. "/vault add <name>"
64 , _cs_description :: Text -- ^ One-line description shown in '/help'
65 , _cs_group :: CommandGroup -- ^ Organisational group
66 , _cs_parse :: Text -> Maybe SlashCommand
67 -- ^ Try to parse a stripped, original-case input as this command.
68 -- Match is case-insensitive on keywords; argument case is preserved.
69 }
70
71 -- ---------------------------------------------------------------------------
72 -- Vault subcommands
73 -- ---------------------------------------------------------------------------
74
75 -- | Subcommands of the '/vault' family.
76 data VaultSubCommand
77 = VaultSetup -- ^ Interactive vault setup wizard
78 | VaultAdd Text -- ^ Store a named secret
79 | VaultList -- ^ List secret names
80 | VaultDelete Text -- ^ Delete a named secret
81 | VaultLock -- ^ Lock the vault
82 | VaultUnlock -- ^ Unlock the vault
83 | VaultStatus' -- ^ Show vault status
84 | VaultUnknown Text -- ^ Unrecognised subcommand (not in allCommandSpecs)
85 deriving stock (Show, Eq)
86
87 -- | Subcommands of the '/provider' family.
88 data ProviderSubCommand
89 = ProviderList -- ^ List available providers
90 | ProviderConfigure Text -- ^ Configure a specific provider
91 deriving stock (Show, Eq)
92
93 -- ---------------------------------------------------------------------------
94 -- Top-level commands
95 -- ---------------------------------------------------------------------------
96
97 -- | All recognised slash commands.
98 data SlashCommand
99 = CmdHelp -- ^ Show command reference
100 | CmdNew -- ^ Clear conversation, keep configuration
101 | CmdReset -- ^ Full reset including usage counters
102 | CmdStatus -- ^ Show session status
103 | CmdCompact -- ^ Summarise conversation to save context
104 | CmdProvider ProviderSubCommand -- ^ Provider configuration command family
105 | CmdVault VaultSubCommand -- ^ Vault command family
106 deriving stock (Show, Eq)
107
108 -- ---------------------------------------------------------------------------
109 -- Command registry
110 -- ---------------------------------------------------------------------------
111
112 -- | All recognised slash commands, in the order they appear in '/help'.
113 -- This is the authoritative definition: 'parseSlashCommand' is derived
114 -- from '_cs_parse' across this list, and '/help' renders from it.
115 -- To add a command, add a 'CommandSpec' here — parsing and help update
116 -- automatically.
117 allCommandSpecs :: [CommandSpec]
118 allCommandSpecs = sessionCommandSpecs ++ providerCommandSpecs ++ vaultCommandSpecs
119
120 sessionCommandSpecs :: [CommandSpec]
121 sessionCommandSpecs =
122 [ CommandSpec "/help" "Show this command reference" GroupSession (exactP "/help" CmdHelp)
123 , CommandSpec "/status" "Session status (messages, tokens used)" GroupSession (exactP "/status" CmdStatus)
124 , CommandSpec "/new" "Clear conversation, keep configuration" GroupSession (exactP "/new" CmdNew)
125 , CommandSpec "/reset" "Full reset including usage counters" GroupSession (exactP "/reset" CmdReset)
126 , CommandSpec "/compact" "Summarise conversation to save context" GroupSession (exactP "/compact" CmdCompact)
127 ]
128
129 providerCommandSpecs :: [CommandSpec]
130 providerCommandSpecs =
131 [ CommandSpec "/provider [name]" "List or configure a model provider" GroupProvider (providerArgP ProviderList ProviderConfigure)
132 ]
133
134 vaultCommandSpecs :: [CommandSpec]
135 vaultCommandSpecs =
136 [ CommandSpec "/vault setup" "Set up or rekey the encrypted secrets vault" GroupVault (vaultExactP "setup" VaultSetup)
137 , CommandSpec "/vault add <name>" "Store a named secret (prompts for value)" GroupVault (vaultArgP "add" VaultAdd)
138 , CommandSpec "/vault list" "List all stored secret names" GroupVault (vaultExactP "list" VaultList)
139 , CommandSpec "/vault delete <name>" "Delete a named secret" GroupVault (vaultArgP "delete" VaultDelete)
140 , CommandSpec "/vault lock" "Lock the vault" GroupVault (vaultExactP "lock" VaultLock)
141 , CommandSpec "/vault unlock" "Unlock the vault" GroupVault (vaultExactP "unlock" VaultUnlock)
142 , CommandSpec "/vault status" "Show vault state and key type" GroupVault (vaultExactP "status" VaultStatus')
143 ]
144
145 -- ---------------------------------------------------------------------------
146 -- Parsing — derived from allCommandSpecs
147 -- ---------------------------------------------------------------------------
148
149 -- | Parse a user message as a slash command.
150 -- Implemented as 'asum' over '_cs_parse' from 'allCommandSpecs', followed
151 -- by a catch-all for unrecognised @\/vault@ subcommands.
152 -- Returns 'Nothing' only for input that does not begin with @\/@.
153 parseSlashCommand :: Text -> Maybe SlashCommand
154 parseSlashCommand input =
155 let stripped = T.strip input
156 in if "/" `T.isPrefixOf` stripped
157 then asum (map (`_cs_parse` stripped) allCommandSpecs)
158 <|> vaultUnknownFallback stripped
159 else Nothing
160
161 -- | Exact case-insensitive match.
162 exactP :: Text -> SlashCommand -> Text -> Maybe SlashCommand
163 exactP keyword cmd t = if T.toLower t == keyword then Just cmd else Nothing
164
165 -- | Case-insensitive match for "/vault <sub>" with no argument.
166 vaultExactP :: Text -> VaultSubCommand -> Text -> Maybe SlashCommand
167 vaultExactP sub cmd t =
168 if T.toLower t == "/vault " <> sub then Just (CmdVault cmd) else Nothing
169
170 -- | Case-insensitive prefix match for "/vault <sub> [arg]".
171 -- Argument is extracted from the original-case input, preserving its case.
172 vaultArgP :: Text -> (Text -> VaultSubCommand) -> Text -> Maybe SlashCommand
173 vaultArgP sub mkCmd t =
174 let pfx = "/vault " <> sub
175 lower = T.toLower t
176 in if lower == pfx || (pfx <> " ") `T.isPrefixOf` lower
177 then Just (CmdVault (mkCmd (T.strip (T.drop (T.length pfx) t))))
178 else Nothing
179
180 -- | Case-insensitive match for "/provider [name]".
181 -- With no argument, returns the list command. With an argument, returns
182 -- the configure command with the argument preserved in original case.
183 providerArgP :: ProviderSubCommand -> (Text -> ProviderSubCommand) -> Text -> Maybe SlashCommand
184 providerArgP listCmd mkCfgCmd t =
185 let pfx = "/provider"
186 lower = T.toLower t
187 in if lower == pfx
188 then Just (CmdProvider listCmd)
189 else if (pfx <> " ") `T.isPrefixOf` lower
190 then let arg = T.strip (T.drop (T.length pfx) t)
191 in if T.null arg
192 then Just (CmdProvider listCmd)
193 else Just (CmdProvider (mkCfgCmd arg))
194 else Nothing
195
196 -- | Catch-all for any "/vault <X>" not matched by 'allCommandSpecs'.
197 -- Not included in the spec list so it does not appear in '/help'.
198 vaultUnknownFallback :: Text -> Maybe SlashCommand
199 vaultUnknownFallback t =
200 let lower = T.toLower t
201 in if "/vault" `T.isPrefixOf` lower
202 then let rest = T.strip (T.drop (T.length "/vault") lower)
203 sub = fst (T.break (== ' ') rest)
204 in Just (CmdVault (VaultUnknown sub))
205 else Nothing
206
207 -- ---------------------------------------------------------------------------
208 -- Execution
209 -- ---------------------------------------------------------------------------
210
211 -- | Execute a slash command. Returns the (possibly updated) context.
212 executeSlashCommand :: AgentEnv -> SlashCommand -> Context -> IO Context
213
214 executeSlashCommand env CmdHelp ctx = do
215 _ch_send (_env_channel env) (OutgoingMessage (renderHelpText allCommandSpecs))
216 pure ctx
217
218 executeSlashCommand env CmdNew ctx = do
219 _ch_send (_env_channel env) (OutgoingMessage "Session cleared. Starting fresh.")
220 pure (clearMessages ctx)
221
222 executeSlashCommand env CmdReset _ctx = do
223 _ch_send (_env_channel env) (OutgoingMessage "Full reset. Context and usage cleared.")
224 pure (emptyContext (contextSystemPrompt _ctx))
225
226 executeSlashCommand env CmdStatus ctx = do
227 let status = T.intercalate "\n"
228 [ "Session status:"
229 , " Messages: " <> T.pack (show (contextMessageCount ctx))
230 , " Est. context tokens: " <> T.pack (show (contextTokenEstimate ctx))
231 , " Total input tokens: " <> T.pack (show (contextTotalInputTokens ctx))
232 , " Total output tokens: " <> T.pack (show (contextTotalOutputTokens ctx))
233 ]
234 _ch_send (_env_channel env) (OutgoingMessage status)
235 pure ctx
236
237 executeSlashCommand env CmdCompact ctx = do
238 mProvider <- readIORef (_env_provider env)
239 case mProvider of
240 Nothing -> do
241 _ch_send (_env_channel env) (OutgoingMessage "Cannot compact: no provider configured.")
242 pure ctx
243 Just provider -> do
244 (ctx', result) <- compactContext
245 provider
246 (_env_model env)
247 0
248 defaultKeepRecent
249 ctx
250 let msg = case result of
251 NotNeeded -> "Nothing to compact (too few messages)."
252 Compacted o n -> "Compacted: " <> T.pack (show o)
253 <> " messages \x2192 " <> T.pack (show n)
254 CompactionError e -> "Compaction failed: " <> e
255 _ch_send (_env_channel env) (OutgoingMessage msg)
256 pure ctx'
257
258 executeSlashCommand env (CmdProvider sub) ctx = do
259 vaultOpt <- readIORef (_env_vault env)
260 case vaultOpt of
261 Nothing -> do
262 _ch_send (_env_channel env) (OutgoingMessage
263 "Vault not configured. Run /vault setup first to store provider credentials.")
264 pure ctx
265 Just vault ->
266 executeProviderCommand env vault sub ctx
267
268 executeSlashCommand env (CmdVault sub) ctx = do
269 vaultOpt <- readIORef (_env_vault env)
270 case sub of
271 VaultSetup -> do
272 executeVaultSetup env ctx
273 _ -> case vaultOpt of
274 Nothing -> do
275 _ch_send (_env_channel env) (OutgoingMessage
276 "No vault configured. Run /vault setup to create one.")
277 pure ctx
278 Just vault ->
279 executeVaultCommand env vault sub ctx
280
281 -- ---------------------------------------------------------------------------
282 -- Provider subcommand execution
283 -- ---------------------------------------------------------------------------
284
285 -- | Supported provider names and their descriptions.
286 supportedProviders :: [(Text, Text)]
287 supportedProviders =
288 [ ("anthropic", "Anthropic (Claude)")
289 , ("openai", "OpenAI (GPT)")
290 , ("openrouter", "OpenRouter (multi-model gateway)")
291 , ("ollama", "Ollama (local models)")
292 ]
293
294 executeProviderCommand :: AgentEnv -> VaultHandle -> ProviderSubCommand -> Context -> IO Context
295 executeProviderCommand env _vault ProviderList ctx = do
296 let send = _ch_send (_env_channel env) . OutgoingMessage
297 listing = T.intercalate "\n" $
298 "Available providers:"
299 : [ " " <> name <> " \x2014 " <> desc | (name, desc) <- supportedProviders ]
300 ++ ["", "Usage: /provider <name>"]
301 send listing
302 pure ctx
303
304 executeProviderCommand env vault (ProviderConfigure providerName) ctx = do
305 let ch = _env_channel env
306 send = _ch_send ch . OutgoingMessage
307 lowerName = T.toLower (T.strip providerName)
308
309 case lowerName of
310 "anthropic" -> do
311 let options = anthropicAuthOptions env vault
312 optionLines = map (\o -> " [" <> T.pack (show (_ao_number o)) <> "] " <> _ao_name o) options
313 menu = T.intercalate "\n" ("Configure Anthropic provider. Choose auth method:" : optionLines)
314 send menu
315
316 choice <- _ch_prompt ch "Choice: "
317 let selectedOption = listToMaybe [o | o <- options, T.pack (show (_ao_number o)) == T.strip choice]
318
319 case selectedOption of
320 Just opt -> _ao_handler opt env vault ctx
321 Nothing -> do
322 send $ "Invalid choice. Please enter 1 to " <> T.pack (show (length options)) <> "."
323 pure ctx
324
325 _ -> do
326 send $ "Unknown provider: " <> providerName
327 send $ "Supported providers: " <> T.intercalate ", " (map fst supportedProviders)
328 pure ctx
329
330 -- | Auth method options for a provider.
331 data AuthOption = AuthOption
332 { _ao_number :: Int
333 , _ao_name :: Text
334 , _ao_handler :: AgentEnv -> VaultHandle -> Context -> IO Context
335 }
336
337 -- | Available Anthropic auth methods.
338 anthropicAuthOptions :: AgentEnv -> VaultHandle -> [AuthOption]
339 anthropicAuthOptions env vault =
340 [ AuthOption 1 "API Key"
341 (\_ _ ctx -> handleAnthropicApiKey env vault ctx)
342 , AuthOption 2 "OAuth 2.0"
343 (\_ _ ctx -> handleAnthropicOAuth env vault ctx)
344 ]
345
346 -- | Handle Anthropic API Key authentication.
347 handleAnthropicApiKey :: AgentEnv -> VaultHandle -> Context -> IO Context
348 handleAnthropicApiKey env vault ctx = do
349 let ch = _env_channel env
350 send = _ch_send ch . OutgoingMessage
351 apiKeyText <- _ch_promptSecret ch "Anthropic API key: "
352 result <- _vh_put vault "ANTHROPIC_API_KEY" (TE.encodeUtf8 apiKeyText)
353 case result of
354 Left err -> do
355 send ("Error storing API key: " <> T.pack (show err))
356 pure ctx
357 Right () -> do
358 send "Anthropic API key configured successfully."
359 pure ctx
360
361 -- | Handle Anthropic OAuth authentication.
362 handleAnthropicOAuth :: AgentEnv -> VaultHandle -> Context -> IO Context
363 handleAnthropicOAuth env vault ctx = do
364 let ch = _env_channel env
365 send = _ch_send ch . OutgoingMessage
366 send "Starting OAuth flow... (opens browser)"
367 manager <- HTTP.newTlsManager
368 oauthTokens <- runOAuthFlow defaultOAuthConfig manager
369 result <- _vh_put vault "ANTHROPIC_OAUTH_TOKENS" (serializeTokens oauthTokens)
370 case result of
371 Left err -> do
372 send ("Error storing OAuth tokens: " <> T.pack (show err))
373 pure ctx
374 Right () -> do
375 send "Anthropic OAuth configured successfully."
376 send "Tokens cached in vault and will be auto-refreshed."
377 pure ctx
378
379 -- ---------------------------------------------------------------------------
380 -- Vault subcommand execution
381 -- ---------------------------------------------------------------------------
382
383 executeVaultCommand :: AgentEnv -> VaultHandle -> VaultSubCommand -> Context -> IO Context
384 executeVaultCommand env vault sub ctx = do
385 let ch = _env_channel env
386 send = _ch_send ch . OutgoingMessage
387 case sub of
388 VaultSetup ->
389 -- VaultSetup is handled before dispatch; should not reach here.
390 send "Use /vault setup to set up or rekey the vault."
391 >> pure ctx
392
393 VaultAdd name -> do
394 valueResult <- try @IOError (_ch_promptSecret ch ("Value for '" <> name <> "': "))
395 case valueResult of
396 Left e ->
397 send ("Error reading secret: " <> T.pack (show e))
398 Right value -> do
399 result <- _vh_put vault name (TE.encodeUtf8 value)
400 case result of
401 Left err -> send ("Error storing secret: " <> T.pack (show err))
402 Right () -> send ("Secret '" <> name <> "' stored.")
403 pure ctx
404
405 VaultList -> do
406 result <- _vh_list vault
407 case result of
408 Left err -> send ("Error: " <> T.pack (show err))
409 Right [] -> send "Vault is empty."
410 Right names ->
411 send ("Secrets:\n" <> T.unlines (map (" \x2022 " <>) names))
412 pure ctx
413
414 VaultDelete name -> do
415 confirm <- _ch_prompt ch ("Delete secret '" <> name <> "'? [y/N]: ")
416 if T.strip confirm == "y" || T.strip confirm == "Y"
417 then do
418 result <- _vh_delete vault name
419 case result of
420 Left err -> send ("Error: " <> T.pack (show err))
421 Right () -> send ("Secret '" <> name <> "' deleted.")
422 else send "Cancelled."
423 pure ctx
424
425 VaultLock -> do
426 _vh_lock vault
427 send "Vault locked."
428 pure ctx
429
430 VaultUnlock -> do
431 result <- _vh_unlock vault
432 case result of
433 Left err -> send ("Error unlocking vault: " <> T.pack (show err))
434 Right () -> send "Vault unlocked."
435 pure ctx
436
437 VaultStatus' -> do
438 status <- _vh_status vault
439 let lockedText = if _vs_locked status then "Locked" else "Unlocked"
440 msg = T.intercalate "\n"
441 [ "Vault status:"
442 , " State: " <> lockedText
443 , " Secrets: " <> T.pack (show (_vs_secretCount status))
444 , " Key: " <> _vs_keyType status
445 ]
446 send msg
447 pure ctx
448
449 VaultUnknown _ ->
450 send "Unknown vault command. Type /help to see all available commands."
451 >> pure ctx
452
453 -- ---------------------------------------------------------------------------
454 -- Vault setup wizard
455 -- ---------------------------------------------------------------------------
456
457 -- | Interactive vault setup wizard. Detects auth mechanisms, lets the user
458 -- choose, then creates or rekeys the vault.
459 executeVaultSetup :: AgentEnv -> Context -> IO Context
460 executeVaultSetup env ctx = do
461 let ch = _env_channel env
462 send = _ch_send ch . OutgoingMessage
463 ph = _env_pluginHandle env
464
465 -- Step 1: Detect available plugins
466 plugins <- _ph_detect ph
467
468 -- Step 2: Build choice menu
469 let options = buildSetupOptions plugins
470 menu = formatSetupMenu options
471 send menu
472
473 -- Step 3: Read user's choice
474 choiceText <- _ch_prompt ch "Choice: "
475 case parseChoice (length options) (T.strip choiceText) of
476 Nothing -> do
477 send "Invalid choice. Setup cancelled."
478 pure ctx
479 Just idx -> do
480 let chosen = snd (options !! idx)
481 -- Step 4: Create encryptor based on choice
482 encResult <- createEncryptorForChoice ch ph chosen
483 case encResult of
484 Left err -> do
485 send err
486 pure ctx
487 Right (newEnc, keyLabel, mRecipient, mIdentity) -> do
488 -- Step 5: Init or rekey
489 vaultOpt <- readIORef (_env_vault env)
490 case vaultOpt of
491 Nothing -> do
492 -- No vault handle at all: create from scratch
493 setupResult <- firstTimeSetup env newEnc keyLabel
494 case setupResult of
495 Left err -> send err
496 Right () -> do
497 send ("Vault created with " <> keyLabel <> " encryption.")
498 updateConfigAfterSetup mRecipient mIdentity keyLabel
499 Just vault -> do
500 -- Vault handle exists — but the file may not.
501 -- Try init: if it succeeds, this is first-time setup.
502 -- If VaultAlreadyExists, we need to rekey.
503 initResult <- _vh_init vault
504 case initResult of
505 Right () -> do
506 -- First-time init succeeded (file didn't exist)
507 send ("Vault created with " <> keyLabel <> " encryption.")
508 updateConfigAfterSetup mRecipient mIdentity keyLabel
509 Left VaultAlreadyExists -> do
510 -- Vault exists — rekey it
511 let confirmFn msg = do
512 send msg
513 answer <- _ch_prompt ch "Proceed? [y/N]: "
514 pure (T.strip answer == "y" || T.strip answer == "Y")
515 rekeyResult <- _vh_rekey vault newEnc keyLabel confirmFn
516 case rekeyResult of
517 Left (VaultCorrupted "rekey cancelled by user") ->
518 send "Rekey cancelled."
519 Left err ->
520 send ("Rekey failed: " <> T.pack (show err))
521 Right () -> do
522 send ("Vault rekeyed to " <> keyLabel <> ".")
523 updateConfigAfterSetup mRecipient mIdentity keyLabel
524 Left err ->
525 send ("Vault init failed: " <> T.pack (show err))
526 pure ctx
527
528 -- | A setup option: either passphrase or a detected plugin.
529 data SetupOption
530 = SetupPassphrase
531 | SetupPlugin AgePlugin
532 deriving stock (Show, Eq)
533
534 -- | Build the list of available setup options.
535 -- Passphrase is always first.
536 buildSetupOptions :: [AgePlugin] -> [(Text, SetupOption)]
537 buildSetupOptions plugins =
538 ("Passphrase", SetupPassphrase)
539 : [(labelFor p, SetupPlugin p) | p <- plugins]
540 where
541 labelFor p = _ap_label p <> " (" <> _ap_name p <> ")"
542
543 -- | Format the setup menu for display.
544 formatSetupMenu :: [(Text, SetupOption)] -> Text
545 formatSetupMenu options =
546 T.intercalate "\n" $
547 "Choose your vault authentication method:"
548 : [T.pack (show i) <> ". " <> label | (i, (label, _)) <- zip [(1::Int)..] options]
549
550 -- | Parse a numeric choice (1-based) to a 0-based index.
551 parseChoice :: Int -> Text -> Maybe Int
552 parseChoice maxN t =
553 case reads (T.unpack t) of
554 [(n, "")] | n >= 1 && n <= maxN -> Just (n - 1)
555 _ -> Nothing
556
557 -- | Create an encryptor based on the user's setup choice.
558 -- Returns (encryptor, key label, maybe recipient, maybe identity path).
559 createEncryptorForChoice
560 :: ChannelHandle
561 -> PluginHandle
562 -> SetupOption
563 -> IO (Either Text (VaultEncryptor, Text, Maybe Text, Maybe Text))
564 createEncryptorForChoice ch _ph SetupPassphrase = do
565 passResult <- try @IOError (_ch_promptSecret ch "Passphrase: ")
566 case passResult of
567 Left e ->
568 pure (Left ("Error reading passphrase: " <> T.pack (show e)))
569 Right passphrase -> do
570 enc <- mkPassphraseVaultEncryptor (pure (TE.encodeUtf8 passphrase))
571 pure (Right (enc, "passphrase", Nothing, Nothing))
572 createEncryptorForChoice ch _ph (SetupPlugin plugin) = do
573 pureclawDir <- getPureclawDir
574 let vaultDir = pureclawDir </> "vault"
575 identityFile = vaultDir </> T.unpack (_ap_name plugin) <> "-identity.txt"
576 identityFileT = T.pack identityFile
577 cmd = T.pack (_ap_binary plugin) <> " --generate --pin-policy never --touch-policy never > " <> identityFileT
578 Dir.createDirectoryIfMissing True vaultDir
579 _ch_send ch (OutgoingMessage (T.intercalate "\n"
580 [ "Run this in another terminal to generate a " <> _ap_label plugin <> " identity:"
581 , ""
582 , " " <> cmd
583 , ""
584 , "The plugin will prompt you for a PIN and touch confirmation."
585 , "Press Enter here when done (or 'q' to cancel)."
586 ]))
587 answer <- T.strip <$> _ch_prompt ch ""
588 if answer == "q" || answer == "Q"
589 then pure (Left "Setup cancelled.")
590 else do
591 exists <- Dir.doesFileExist identityFile
592 if not exists
593 then pure (Left ("Identity file not found: " <> identityFileT))
594 else do
595 contents <- TIO.readFile identityFile
596 let outputLines = T.lines contents
597 -- age-plugin-yubikey uses "# Recipient: age1..."
598 -- other plugins may use "# public key: age1..."
599 findRecipient = L.find (\l ->
600 let stripped = T.strip (T.dropWhile (== '#') (T.strip l))
601 in T.isPrefixOf "Recipient:" stripped
602 || T.isPrefixOf "public key:" stripped) outputLines
603 case findRecipient of
604 Nothing ->
605 pure (Left "No recipient found in identity file. Expected a '# Recipient: age1...' line.")
606 Just rLine -> do
607 -- Extract value after the label (Recipient: or public key:)
608 let afterHash = T.strip (T.dropWhile (== '#') (T.strip rLine))
609 recipient = T.strip (T.drop 1 (T.dropWhile (/= ':') afterHash))
610 ageResult <- mkAgeEncryptor
611 case ageResult of
612 Left err ->
613 pure (Left ("age error: " <> T.pack (show err)))
614 Right ageEnc -> do
615 let enc = ageVaultEncryptor ageEnc recipient identityFileT
616 pure (Right (enc, _ap_label plugin, Just recipient, Just identityFileT))
617
618 -- | First-time vault setup: create directory, open vault, init, write to IORef.
619 firstTimeSetup :: AgentEnv -> VaultEncryptor -> Text -> IO (Either Text ())
620 firstTimeSetup env enc keyLabel = do
621 pureclawDir <- getPureclawDir
622 let vaultDir = pureclawDir </> "vault"
623 Dir.createDirectoryIfMissing True vaultDir
624 let vaultPath = vaultDir </> "vault.age"
625 cfg = VaultConfig
626 { _vc_path = vaultPath
627 , _vc_keyType = keyLabel
628 , _vc_unlock = UnlockOnDemand
629 }
630 vault <- openVault cfg enc
631 initResult <- _vh_init vault
632 case initResult of
633 Left VaultAlreadyExists ->
634 pure (Left "A vault file already exists. Use /vault setup to rekey.")
635 Left err ->
636 pure (Left ("Vault creation failed: " <> T.pack (show err)))
637 Right () -> do
638 writeIORef (_env_vault env) (Just vault)
639 pure (Right ())
640
641 -- | Update the config file after a successful setup/rekey.
642 updateConfigAfterSetup :: Maybe Text -> Maybe Text -> Text -> IO ()
643 updateConfigAfterSetup mRecipient mIdentity _keyLabel = do
644 pureclawDir <- getPureclawDir
645 Dir.createDirectoryIfMissing True pureclawDir
646 let configPath = pureclawDir </> "config.toml"
647 vaultPath = Just (T.pack (pureclawDir </> "vault" </> "vault.age"))
648 unlockMode = Just "on_demand"
649 updateVaultConfig configPath vaultPath mRecipient mIdentity unlockMode
650
651 -- ---------------------------------------------------------------------------
652 -- Help rendering — derived from allCommandSpecs
653 -- ---------------------------------------------------------------------------
654
655 -- | Render the full command reference from 'allCommandSpecs'.
656 renderHelpText :: [CommandSpec] -> Text
657 renderHelpText specs =
658 T.intercalate "\n"
659 ("Slash commands:" : concatMap renderGroup [minBound .. maxBound])
660 where
661 renderGroup g =
662 let gs = filter ((== g) . _cs_group) specs
663 in if null gs
664 then []
665 else "" : (" " <> groupHeading g <> ":") : map renderSpec gs
666
667 renderSpec spec =
668 " " <> padTo 26 (_cs_syntax spec) <> _cs_description spec
669
670 padTo n t = t <> T.replicate (max 1 (n - T.length t)) " "