never executed always true always false
1 module PureClaw.Agent.SlashCommands
2 ( -- * Command data types
3 SlashCommand (..)
4 , VaultSubCommand (..)
5 , ProviderSubCommand (..)
6 , ChannelSubCommand (..)
7 -- * Command registry — single source of truth
8 , CommandGroup (..)
9 , CommandSpec (..)
10 , allCommandSpecs
11 -- * Parsing (derived from allCommandSpecs)
12 , parseSlashCommand
13 -- * Execution
14 , executeSlashCommand
15 ) where
16
17 import Control.Applicative ((<|>))
18 import Control.Exception
19 import Data.Foldable (asum)
20 import Data.IORef
21 import Data.List qualified as L
22 import Data.Maybe (listToMaybe)
23 import Data.Text (Text)
24 import Data.Text qualified as T
25 import Data.Text.Encoding qualified as TE
26 import Data.Text.IO qualified as TIO
27 import Network.HTTP.Client.TLS qualified as HTTP
28 import System.Directory qualified as Dir
29 import System.FilePath ((</>))
30
31 import Data.ByteString.Lazy qualified as BL
32 import System.Exit
33 import System.IO (Handle, hGetLine)
34 import System.Process.Typed qualified as P
35
36 import PureClaw.Agent.Compaction
37 import PureClaw.Agent.Context
38 import PureClaw.Agent.Env
39 import PureClaw.Auth.AnthropicOAuth
40 import PureClaw.CLI.Config
41 import PureClaw.Handles.Channel
42 import PureClaw.Security.Vault
43 import PureClaw.Security.Vault.Age
44 import PureClaw.Security.Vault.Passphrase
45 import PureClaw.Security.Vault.Plugin
46
47 -- ---------------------------------------------------------------------------
48 -- Command taxonomy
49 -- ---------------------------------------------------------------------------
50
51 -- | Organisational group for display in '/help'.
52 data CommandGroup
53 = GroupSession -- ^ Session and context management
54 | GroupProvider -- ^ Model provider configuration
55 | GroupChannel -- ^ Chat channel configuration
56 | GroupVault -- ^ Encrypted secrets vault
57 deriving stock (Show, Eq, Ord, Enum, Bounded)
58
59 -- | Human-readable section heading for '/help' output.
60 groupHeading :: CommandGroup -> Text
61 groupHeading GroupSession = "Session"
62 groupHeading GroupProvider = "Provider"
63 groupHeading GroupChannel = "Channel"
64 groupHeading GroupVault = "Vault"
65
66 -- | Specification for a single slash command.
67 -- 'allCommandSpecs' is the single source of truth: 'parseSlashCommand'
68 -- is derived from '_cs_parse' and '/help' renders from '_cs_syntax' /
69 -- '_cs_description', so the two cannot diverge.
70 data CommandSpec = CommandSpec
71 { _cs_syntax :: Text -- ^ Display syntax, e.g. "/vault add <name>"
72 , _cs_description :: Text -- ^ One-line description shown in '/help'
73 , _cs_group :: CommandGroup -- ^ Organisational group
74 , _cs_parse :: Text -> Maybe SlashCommand
75 -- ^ Try to parse a stripped, original-case input as this command.
76 -- Match is case-insensitive on keywords; argument case is preserved.
77 }
78
79 -- ---------------------------------------------------------------------------
80 -- Vault subcommands
81 -- ---------------------------------------------------------------------------
82
83 -- | Subcommands of the '/vault' family.
84 data VaultSubCommand
85 = VaultSetup -- ^ Interactive vault setup wizard
86 | VaultAdd Text -- ^ Store a named secret
87 | VaultList -- ^ List secret names
88 | VaultDelete Text -- ^ Delete a named secret
89 | VaultLock -- ^ Lock the vault
90 | VaultUnlock -- ^ Unlock the vault
91 | VaultStatus' -- ^ Show vault status
92 | VaultUnknown Text -- ^ Unrecognised subcommand (not in allCommandSpecs)
93 deriving stock (Show, Eq)
94
95 -- | Subcommands of the '/provider' family.
96 data ProviderSubCommand
97 = ProviderList -- ^ List available providers
98 | ProviderConfigure Text -- ^ Configure a specific provider
99 deriving stock (Show, Eq)
100
101 -- | Subcommands of the '/channel' family.
102 data ChannelSubCommand
103 = ChannelList -- ^ Show current channel + available options
104 | ChannelSetup Text -- ^ Interactive setup for a specific channel
105 | ChannelUnknown Text -- ^ Unrecognised subcommand
106 deriving stock (Show, Eq)
107
108 -- ---------------------------------------------------------------------------
109 -- Top-level commands
110 -- ---------------------------------------------------------------------------
111
112 -- | All recognised slash commands.
113 data SlashCommand
114 = CmdHelp -- ^ Show command reference
115 | CmdNew -- ^ Clear conversation, keep configuration
116 | CmdReset -- ^ Full reset including usage counters
117 | CmdStatus -- ^ Show session status
118 | CmdCompact -- ^ Summarise conversation to save context
119 | CmdProvider ProviderSubCommand -- ^ Provider configuration command family
120 | CmdVault VaultSubCommand -- ^ Vault command family
121 | CmdChannel ChannelSubCommand -- ^ Channel configuration
122 deriving stock (Show, Eq)
123
124 -- ---------------------------------------------------------------------------
125 -- Command registry
126 -- ---------------------------------------------------------------------------
127
128 -- | All recognised slash commands, in the order they appear in '/help'.
129 -- This is the authoritative definition: 'parseSlashCommand' is derived
130 -- from '_cs_parse' across this list, and '/help' renders from it.
131 -- To add a command, add a 'CommandSpec' here — parsing and help update
132 -- automatically.
133 allCommandSpecs :: [CommandSpec]
134 allCommandSpecs = sessionCommandSpecs ++ providerCommandSpecs ++ channelCommandSpecs ++ vaultCommandSpecs
135
136 sessionCommandSpecs :: [CommandSpec]
137 sessionCommandSpecs =
138 [ CommandSpec "/help" "Show this command reference" GroupSession (exactP "/help" CmdHelp)
139 , CommandSpec "/status" "Session status (messages, tokens used)" GroupSession (exactP "/status" CmdStatus)
140 , CommandSpec "/new" "Clear conversation, keep configuration" GroupSession (exactP "/new" CmdNew)
141 , CommandSpec "/reset" "Full reset including usage counters" GroupSession (exactP "/reset" CmdReset)
142 , CommandSpec "/compact" "Summarise conversation to save context" GroupSession (exactP "/compact" CmdCompact)
143 ]
144
145 providerCommandSpecs :: [CommandSpec]
146 providerCommandSpecs =
147 [ CommandSpec "/provider [name]" "List or configure a model provider" GroupProvider (providerArgP ProviderList ProviderConfigure)
148 ]
149
150 channelCommandSpecs :: [CommandSpec]
151 channelCommandSpecs =
152 [ CommandSpec "/channel" "Show current channel and available options" GroupChannel (channelArgP ChannelList ChannelSetup)
153 , CommandSpec "/channel signal" "Set up Signal messenger integration" GroupChannel (channelExactP "signal" (ChannelSetup "signal"))
154 , CommandSpec "/channel telegram" "Set up Telegram bot integration" GroupChannel (channelExactP "telegram" (ChannelSetup "telegram"))
155 ]
156
157 vaultCommandSpecs :: [CommandSpec]
158 vaultCommandSpecs =
159 [ CommandSpec "/vault setup" "Set up or rekey the encrypted secrets vault" GroupVault (vaultExactP "setup" VaultSetup)
160 , CommandSpec "/vault add <name>" "Store a named secret (prompts for value)" GroupVault (vaultArgP "add" VaultAdd)
161 , CommandSpec "/vault list" "List all stored secret names" GroupVault (vaultExactP "list" VaultList)
162 , CommandSpec "/vault delete <name>" "Delete a named secret" GroupVault (vaultArgP "delete" VaultDelete)
163 , CommandSpec "/vault lock" "Lock the vault" GroupVault (vaultExactP "lock" VaultLock)
164 , CommandSpec "/vault unlock" "Unlock the vault" GroupVault (vaultExactP "unlock" VaultUnlock)
165 , CommandSpec "/vault status" "Show vault state and key type" GroupVault (vaultExactP "status" VaultStatus')
166 ]
167
168 -- ---------------------------------------------------------------------------
169 -- Parsing — derived from allCommandSpecs
170 -- ---------------------------------------------------------------------------
171
172 -- | Parse a user message as a slash command.
173 -- Implemented as 'asum' over '_cs_parse' from 'allCommandSpecs', followed
174 -- by a catch-all for unrecognised @\/vault@ subcommands.
175 -- Returns 'Nothing' only for input that does not begin with @\/@.
176 parseSlashCommand :: Text -> Maybe SlashCommand
177 parseSlashCommand input =
178 let stripped = T.strip input
179 in if "/" `T.isPrefixOf` stripped
180 then asum (map (`_cs_parse` stripped) allCommandSpecs)
181 <|> channelUnknownFallback stripped
182 <|> vaultUnknownFallback stripped
183 else Nothing
184
185 -- | Exact case-insensitive match.
186 exactP :: Text -> SlashCommand -> Text -> Maybe SlashCommand
187 exactP keyword cmd t = if T.toLower t == keyword then Just cmd else Nothing
188
189 -- | Case-insensitive match for "/vault <sub>" with no argument.
190 vaultExactP :: Text -> VaultSubCommand -> Text -> Maybe SlashCommand
191 vaultExactP sub cmd t =
192 if T.toLower t == "/vault " <> sub then Just (CmdVault cmd) else Nothing
193
194 -- | Case-insensitive prefix match for "/vault <sub> [arg]".
195 -- Argument is extracted from the original-case input, preserving its case.
196 vaultArgP :: Text -> (Text -> VaultSubCommand) -> Text -> Maybe SlashCommand
197 vaultArgP sub mkCmd t =
198 let pfx = "/vault " <> sub
199 lower = T.toLower t
200 in if lower == pfx || (pfx <> " ") `T.isPrefixOf` lower
201 then Just (CmdVault (mkCmd (T.strip (T.drop (T.length pfx) t))))
202 else Nothing
203
204 -- | Case-insensitive match for "/provider [name]".
205 -- With no argument, returns the list command. With an argument, returns
206 -- the configure command with the argument preserved in original case.
207 providerArgP :: ProviderSubCommand -> (Text -> ProviderSubCommand) -> Text -> Maybe SlashCommand
208 providerArgP listCmd mkCfgCmd t =
209 let pfx = "/provider"
210 lower = T.toLower t
211 in if lower == pfx
212 then Just (CmdProvider listCmd)
213 else if (pfx <> " ") `T.isPrefixOf` lower
214 then let arg = T.strip (T.drop (T.length pfx) t)
215 in if T.null arg
216 then Just (CmdProvider listCmd)
217 else Just (CmdProvider (mkCfgCmd arg))
218 else Nothing
219
220 -- | Case-insensitive match for "/channel" with optional argument.
221 channelArgP :: ChannelSubCommand -> (Text -> ChannelSubCommand) -> Text -> Maybe SlashCommand
222 channelArgP listCmd mkSetupCmd t =
223 let pfx = "/channel"
224 lower = T.toLower t
225 in if lower == pfx
226 then Just (CmdChannel listCmd)
227 else if (pfx <> " ") `T.isPrefixOf` lower
228 then let arg = T.strip (T.drop (T.length pfx) t)
229 in if T.null arg
230 then Just (CmdChannel listCmd)
231 else Just (CmdChannel (mkSetupCmd (T.toLower arg)))
232 else Nothing
233
234 -- | Case-insensitive exact match for "/channel <sub>".
235 channelExactP :: Text -> ChannelSubCommand -> Text -> Maybe SlashCommand
236 channelExactP sub cmd t =
237 if T.toLower t == "/channel " <> sub then Just (CmdChannel cmd) else Nothing
238
239 -- | Catch-all for any "/channel <X>" not matched by 'allCommandSpecs'.
240 channelUnknownFallback :: Text -> Maybe SlashCommand
241 channelUnknownFallback t =
242 let lower = T.toLower t
243 in if "/channel" `T.isPrefixOf` lower
244 then let rest = T.strip (T.drop (T.length "/channel") lower)
245 sub = fst (T.break (== ' ') rest)
246 in Just (CmdChannel (ChannelUnknown sub))
247 else Nothing
248
249 -- | Catch-all for any "/vault <X>" not matched by 'allCommandSpecs'.
250 -- Not included in the spec list so it does not appear in '/help'.
251 vaultUnknownFallback :: Text -> Maybe SlashCommand
252 vaultUnknownFallback t =
253 let lower = T.toLower t
254 in if "/vault" `T.isPrefixOf` lower
255 then let rest = T.strip (T.drop (T.length "/vault") lower)
256 sub = fst (T.break (== ' ') rest)
257 in Just (CmdVault (VaultUnknown sub))
258 else Nothing
259
260 -- ---------------------------------------------------------------------------
261 -- Execution
262 -- ---------------------------------------------------------------------------
263
264 -- | Execute a slash command. Returns the (possibly updated) context.
265 executeSlashCommand :: AgentEnv -> SlashCommand -> Context -> IO Context
266
267 executeSlashCommand env CmdHelp ctx = do
268 _ch_send (_env_channel env) (OutgoingMessage (renderHelpText allCommandSpecs))
269 pure ctx
270
271 executeSlashCommand env CmdNew ctx = do
272 _ch_send (_env_channel env) (OutgoingMessage "Session cleared. Starting fresh.")
273 pure (clearMessages ctx)
274
275 executeSlashCommand env CmdReset _ctx = do
276 _ch_send (_env_channel env) (OutgoingMessage "Full reset. Context and usage cleared.")
277 pure (emptyContext (contextSystemPrompt _ctx))
278
279 executeSlashCommand env CmdStatus ctx = do
280 let status = T.intercalate "\n"
281 [ "Session status:"
282 , " Messages: " <> T.pack (show (contextMessageCount ctx))
283 , " Est. context tokens: " <> T.pack (show (contextTokenEstimate ctx))
284 , " Total input tokens: " <> T.pack (show (contextTotalInputTokens ctx))
285 , " Total output tokens: " <> T.pack (show (contextTotalOutputTokens ctx))
286 ]
287 _ch_send (_env_channel env) (OutgoingMessage status)
288 pure ctx
289
290 executeSlashCommand env CmdCompact ctx = do
291 mProvider <- readIORef (_env_provider env)
292 case mProvider of
293 Nothing -> do
294 _ch_send (_env_channel env) (OutgoingMessage "Cannot compact: no provider configured.")
295 pure ctx
296 Just provider -> do
297 (ctx', result) <- compactContext
298 provider
299 (_env_model env)
300 0
301 defaultKeepRecent
302 ctx
303 let msg = case result of
304 NotNeeded -> "Nothing to compact (too few messages)."
305 Compacted o n -> "Compacted: " <> T.pack (show o)
306 <> " messages \x2192 " <> T.pack (show n)
307 CompactionError e -> "Compaction failed: " <> e
308 _ch_send (_env_channel env) (OutgoingMessage msg)
309 pure ctx'
310
311 executeSlashCommand env (CmdProvider sub) ctx = do
312 vaultOpt <- readIORef (_env_vault env)
313 case vaultOpt of
314 Nothing -> do
315 _ch_send (_env_channel env) (OutgoingMessage
316 "Vault not configured. Run /vault setup first to store provider credentials.")
317 pure ctx
318 Just vault ->
319 executeProviderCommand env vault sub ctx
320
321 executeSlashCommand env (CmdChannel sub) ctx = do
322 executeChannelCommand env sub ctx
323
324 executeSlashCommand env (CmdVault sub) ctx = do
325 vaultOpt <- readIORef (_env_vault env)
326 case sub of
327 VaultSetup -> do
328 executeVaultSetup env ctx
329 _ -> case vaultOpt of
330 Nothing -> do
331 _ch_send (_env_channel env) (OutgoingMessage
332 "No vault configured. Run /vault setup to create one.")
333 pure ctx
334 Just vault ->
335 executeVaultCommand env vault sub ctx
336
337 -- ---------------------------------------------------------------------------
338 -- Provider subcommand execution
339 -- ---------------------------------------------------------------------------
340
341 -- | Supported provider names and their descriptions.
342 supportedProviders :: [(Text, Text)]
343 supportedProviders =
344 [ ("anthropic", "Anthropic (Claude)")
345 , ("openai", "OpenAI (GPT)")
346 , ("openrouter", "OpenRouter (multi-model gateway)")
347 , ("ollama", "Ollama (local models)")
348 ]
349
350 executeProviderCommand :: AgentEnv -> VaultHandle -> ProviderSubCommand -> Context -> IO Context
351 executeProviderCommand env _vault ProviderList ctx = do
352 let send = _ch_send (_env_channel env) . OutgoingMessage
353 listing = T.intercalate "\n" $
354 "Available providers:"
355 : [ " " <> name <> " \x2014 " <> desc | (name, desc) <- supportedProviders ]
356 ++ ["", "Usage: /provider <name>"]
357 send listing
358 pure ctx
359
360 executeProviderCommand env vault (ProviderConfigure providerName) ctx = do
361 let ch = _env_channel env
362 send = _ch_send ch . OutgoingMessage
363 lowerName = T.toLower (T.strip providerName)
364
365 case lowerName of
366 "anthropic" -> do
367 let options = anthropicAuthOptions env vault
368 optionLines = map (\o -> " [" <> T.pack (show (_ao_number o)) <> "] " <> _ao_name o) options
369 menu = T.intercalate "\n" ("Configure Anthropic provider. Choose auth method:" : optionLines)
370 send menu
371
372 choice <- _ch_prompt ch "Choice: "
373 let selectedOption = listToMaybe [o | o <- options, T.pack (show (_ao_number o)) == T.strip choice]
374
375 case selectedOption of
376 Just opt -> _ao_handler opt env vault ctx
377 Nothing -> do
378 send $ "Invalid choice. Please enter 1 to " <> T.pack (show (length options)) <> "."
379 pure ctx
380
381 _ -> do
382 send $ "Unknown provider: " <> providerName
383 send $ "Supported providers: " <> T.intercalate ", " (map fst supportedProviders)
384 pure ctx
385
386 -- | Auth method options for a provider.
387 data AuthOption = AuthOption
388 { _ao_number :: Int
389 , _ao_name :: Text
390 , _ao_handler :: AgentEnv -> VaultHandle -> Context -> IO Context
391 }
392
393 -- | Available Anthropic auth methods.
394 anthropicAuthOptions :: AgentEnv -> VaultHandle -> [AuthOption]
395 anthropicAuthOptions env vault =
396 [ AuthOption 1 "API Key"
397 (\_ _ ctx -> handleAnthropicApiKey env vault ctx)
398 , AuthOption 2 "OAuth 2.0"
399 (\_ _ ctx -> handleAnthropicOAuth env vault ctx)
400 ]
401
402 -- | Handle Anthropic API Key authentication.
403 handleAnthropicApiKey :: AgentEnv -> VaultHandle -> Context -> IO Context
404 handleAnthropicApiKey env vault ctx = do
405 let ch = _env_channel env
406 send = _ch_send ch . OutgoingMessage
407 apiKeyText <- _ch_promptSecret ch "Anthropic API key: "
408 result <- _vh_put vault "ANTHROPIC_API_KEY" (TE.encodeUtf8 apiKeyText)
409 case result of
410 Left err -> do
411 send ("Error storing API key: " <> T.pack (show err))
412 pure ctx
413 Right () -> do
414 send "Anthropic API key configured successfully."
415 pure ctx
416
417 -- | Handle Anthropic OAuth authentication.
418 handleAnthropicOAuth :: AgentEnv -> VaultHandle -> Context -> IO Context
419 handleAnthropicOAuth env vault ctx = do
420 let ch = _env_channel env
421 send = _ch_send ch . OutgoingMessage
422 send "Starting OAuth flow... (opens browser)"
423 manager <- HTTP.newTlsManager
424 oauthTokens <- runOAuthFlow defaultOAuthConfig manager
425 result <- _vh_put vault "ANTHROPIC_OAUTH_TOKENS" (serializeTokens oauthTokens)
426 case result of
427 Left err -> do
428 send ("Error storing OAuth tokens: " <> T.pack (show err))
429 pure ctx
430 Right () -> do
431 send "Anthropic OAuth configured successfully."
432 send "Tokens cached in vault and will be auto-refreshed."
433 pure ctx
434
435 -- ---------------------------------------------------------------------------
436 -- Vault subcommand execution
437 -- ---------------------------------------------------------------------------
438
439 executeVaultCommand :: AgentEnv -> VaultHandle -> VaultSubCommand -> Context -> IO Context
440 executeVaultCommand env vault sub ctx = do
441 let ch = _env_channel env
442 send = _ch_send ch . OutgoingMessage
443 case sub of
444 VaultSetup ->
445 -- VaultSetup is handled before dispatch; should not reach here.
446 send "Use /vault setup to set up or rekey the vault."
447 >> pure ctx
448
449 VaultAdd name -> do
450 valueResult <- try @IOError (_ch_promptSecret ch ("Value for '" <> name <> "': "))
451 case valueResult of
452 Left e ->
453 send ("Error reading secret: " <> T.pack (show e))
454 Right value -> do
455 result <- _vh_put vault name (TE.encodeUtf8 value)
456 case result of
457 Left err -> send ("Error storing secret: " <> T.pack (show err))
458 Right () -> send ("Secret '" <> name <> "' stored.")
459 pure ctx
460
461 VaultList -> do
462 result <- _vh_list vault
463 case result of
464 Left err -> send ("Error: " <> T.pack (show err))
465 Right [] -> send "Vault is empty."
466 Right names ->
467 send ("Secrets:\n" <> T.unlines (map (" \x2022 " <>) names))
468 pure ctx
469
470 VaultDelete name -> do
471 confirm <- _ch_prompt ch ("Delete secret '" <> name <> "'? [y/N]: ")
472 if T.strip confirm == "y" || T.strip confirm == "Y"
473 then do
474 result <- _vh_delete vault name
475 case result of
476 Left err -> send ("Error: " <> T.pack (show err))
477 Right () -> send ("Secret '" <> name <> "' deleted.")
478 else send "Cancelled."
479 pure ctx
480
481 VaultLock -> do
482 _vh_lock vault
483 send "Vault locked."
484 pure ctx
485
486 VaultUnlock -> do
487 result <- _vh_unlock vault
488 case result of
489 Left err -> send ("Error unlocking vault: " <> T.pack (show err))
490 Right () -> send "Vault unlocked."
491 pure ctx
492
493 VaultStatus' -> do
494 status <- _vh_status vault
495 let lockedText = if _vs_locked status then "Locked" else "Unlocked"
496 msg = T.intercalate "\n"
497 [ "Vault status:"
498 , " State: " <> lockedText
499 , " Secrets: " <> T.pack (show (_vs_secretCount status))
500 , " Key: " <> _vs_keyType status
501 ]
502 send msg
503 pure ctx
504
505 VaultUnknown _ ->
506 send "Unknown vault command. Type /help to see all available commands."
507 >> pure ctx
508
509 -- ---------------------------------------------------------------------------
510 -- Vault setup wizard
511 -- ---------------------------------------------------------------------------
512
513 -- | Interactive vault setup wizard. Detects auth mechanisms, lets the user
514 -- choose, then creates or rekeys the vault.
515 executeVaultSetup :: AgentEnv -> Context -> IO Context
516 executeVaultSetup env ctx = do
517 let ch = _env_channel env
518 send = _ch_send ch . OutgoingMessage
519 ph = _env_pluginHandle env
520
521 -- Step 1: Detect available plugins
522 plugins <- _ph_detect ph
523
524 -- Step 2: Build choice menu
525 let options = buildSetupOptions plugins
526 menu = formatSetupMenu options
527 send menu
528
529 -- Step 3: Read user's choice
530 choiceText <- _ch_prompt ch "Choice: "
531 case parseChoice (length options) (T.strip choiceText) of
532 Nothing -> do
533 send "Invalid choice. Setup cancelled."
534 pure ctx
535 Just idx -> do
536 let chosen = snd (options !! idx)
537 -- Step 4: Create encryptor based on choice
538 encResult <- createEncryptorForChoice ch ph chosen
539 case encResult of
540 Left err -> do
541 send err
542 pure ctx
543 Right (newEnc, keyLabel, mRecipient, mIdentity) -> do
544 -- Step 5: Init or rekey
545 vaultOpt <- readIORef (_env_vault env)
546 case vaultOpt of
547 Nothing -> do
548 -- No vault handle at all: create from scratch
549 setupResult <- firstTimeSetup env newEnc keyLabel
550 case setupResult of
551 Left err -> send err
552 Right () -> do
553 send ("Vault created with " <> keyLabel <> " encryption.")
554 updateConfigAfterSetup mRecipient mIdentity keyLabel
555 Just vault -> do
556 -- Vault handle exists — but the file may not.
557 -- Try init: if it succeeds, this is first-time setup.
558 -- If VaultAlreadyExists, we need to rekey.
559 initResult <- _vh_init vault
560 case initResult of
561 Right () -> do
562 -- First-time init succeeded (file didn't exist)
563 send ("Vault created with " <> keyLabel <> " encryption.")
564 updateConfigAfterSetup mRecipient mIdentity keyLabel
565 Left VaultAlreadyExists -> do
566 -- Vault exists — rekey it
567 let confirmFn msg = do
568 send msg
569 answer <- _ch_prompt ch "Proceed? [y/N]: "
570 pure (T.strip answer == "y" || T.strip answer == "Y")
571 rekeyResult <- _vh_rekey vault newEnc keyLabel confirmFn
572 case rekeyResult of
573 Left (VaultCorrupted "rekey cancelled by user") ->
574 send "Rekey cancelled."
575 Left err ->
576 send ("Rekey failed: " <> T.pack (show err))
577 Right () -> do
578 send ("Vault rekeyed to " <> keyLabel <> ".")
579 updateConfigAfterSetup mRecipient mIdentity keyLabel
580 Left err ->
581 send ("Vault init failed: " <> T.pack (show err))
582 pure ctx
583
584 -- | A setup option: either passphrase or a detected plugin.
585 data SetupOption
586 = SetupPassphrase
587 | SetupPlugin AgePlugin
588 deriving stock (Show, Eq)
589
590 -- | Build the list of available setup options.
591 -- Passphrase is always first.
592 buildSetupOptions :: [AgePlugin] -> [(Text, SetupOption)]
593 buildSetupOptions plugins =
594 ("Passphrase", SetupPassphrase)
595 : [(labelFor p, SetupPlugin p) | p <- plugins]
596 where
597 labelFor p = _ap_label p <> " (" <> _ap_name p <> ")"
598
599 -- | Format the setup menu for display.
600 formatSetupMenu :: [(Text, SetupOption)] -> Text
601 formatSetupMenu options =
602 T.intercalate "\n" $
603 "Choose your vault authentication method:"
604 : [T.pack (show i) <> ". " <> label | (i, (label, _)) <- zip [(1::Int)..] options]
605
606 -- | Parse a numeric choice (1-based) to a 0-based index.
607 parseChoice :: Int -> Text -> Maybe Int
608 parseChoice maxN t =
609 case reads (T.unpack t) of
610 [(n, "")] | n >= 1 && n <= maxN -> Just (n - 1)
611 _ -> Nothing
612
613 -- | Create an encryptor based on the user's setup choice.
614 -- Returns (encryptor, key label, maybe recipient, maybe identity path).
615 createEncryptorForChoice
616 :: ChannelHandle
617 -> PluginHandle
618 -> SetupOption
619 -> IO (Either Text (VaultEncryptor, Text, Maybe Text, Maybe Text))
620 createEncryptorForChoice ch _ph SetupPassphrase = do
621 passResult <- try @IOError (_ch_promptSecret ch "Passphrase: ")
622 case passResult of
623 Left e ->
624 pure (Left ("Error reading passphrase: " <> T.pack (show e)))
625 Right passphrase -> do
626 enc <- mkPassphraseVaultEncryptor (pure (TE.encodeUtf8 passphrase))
627 pure (Right (enc, "passphrase", Nothing, Nothing))
628 createEncryptorForChoice ch _ph (SetupPlugin plugin) = do
629 pureclawDir <- getPureclawDir
630 let vaultDir = pureclawDir </> "vault"
631 identityFile = vaultDir </> T.unpack (_ap_name plugin) <> "-identity.txt"
632 identityFileT = T.pack identityFile
633 cmd = T.pack (_ap_binary plugin) <> " --generate --pin-policy never --touch-policy never > " <> identityFileT
634 Dir.createDirectoryIfMissing True vaultDir
635 _ch_send ch (OutgoingMessage (T.intercalate "\n"
636 [ "Run this in another terminal to generate a " <> _ap_label plugin <> " identity:"
637 , ""
638 , " " <> cmd
639 , ""
640 , "The plugin will prompt you for a PIN and touch confirmation."
641 , "Press Enter here when done (or 'q' to cancel)."
642 ]))
643 answer <- T.strip <$> _ch_prompt ch ""
644 if answer == "q" || answer == "Q"
645 then pure (Left "Setup cancelled.")
646 else do
647 exists <- Dir.doesFileExist identityFile
648 if not exists
649 then pure (Left ("Identity file not found: " <> identityFileT))
650 else do
651 contents <- TIO.readFile identityFile
652 let outputLines = T.lines contents
653 -- age-plugin-yubikey uses "# Recipient: age1..."
654 -- other plugins may use "# public key: age1..."
655 findRecipient = L.find (\l ->
656 let stripped = T.strip (T.dropWhile (== '#') (T.strip l))
657 in T.isPrefixOf "Recipient:" stripped
658 || T.isPrefixOf "public key:" stripped) outputLines
659 case findRecipient of
660 Nothing ->
661 pure (Left "No recipient found in identity file. Expected a '# Recipient: age1...' line.")
662 Just rLine -> do
663 -- Extract value after the label (Recipient: or public key:)
664 let afterHash = T.strip (T.dropWhile (== '#') (T.strip rLine))
665 recipient = T.strip (T.drop 1 (T.dropWhile (/= ':') afterHash))
666 ageResult <- mkAgeEncryptor
667 case ageResult of
668 Left err ->
669 pure (Left ("age error: " <> T.pack (show err)))
670 Right ageEnc -> do
671 let enc = ageVaultEncryptor ageEnc recipient identityFileT
672 pure (Right (enc, _ap_label plugin, Just recipient, Just identityFileT))
673
674 -- | First-time vault setup: create directory, open vault, init, write to IORef.
675 firstTimeSetup :: AgentEnv -> VaultEncryptor -> Text -> IO (Either Text ())
676 firstTimeSetup env enc keyLabel = do
677 pureclawDir <- getPureclawDir
678 let vaultDir = pureclawDir </> "vault"
679 Dir.createDirectoryIfMissing True vaultDir
680 let vaultPath = vaultDir </> "vault.age"
681 cfg = VaultConfig
682 { _vc_path = vaultPath
683 , _vc_keyType = keyLabel
684 , _vc_unlock = UnlockOnDemand
685 }
686 vault <- openVault cfg enc
687 initResult <- _vh_init vault
688 case initResult of
689 Left VaultAlreadyExists ->
690 pure (Left "A vault file already exists. Use /vault setup to rekey.")
691 Left err ->
692 pure (Left ("Vault creation failed: " <> T.pack (show err)))
693 Right () -> do
694 writeIORef (_env_vault env) (Just vault)
695 pure (Right ())
696
697 -- | Update the config file after a successful setup/rekey.
698 updateConfigAfterSetup :: Maybe Text -> Maybe Text -> Text -> IO ()
699 updateConfigAfterSetup mRecipient mIdentity _keyLabel = do
700 pureclawDir <- getPureclawDir
701 Dir.createDirectoryIfMissing True pureclawDir
702 let configPath = pureclawDir </> "config.toml"
703 vaultPath = Set (T.pack (pureclawDir </> "vault" </> "vault.age"))
704 unlockMode = Set "on_demand"
705 recipientUpd = maybe Clear Set mRecipient
706 identityUpd = maybe Clear Set mIdentity
707 updateVaultConfig configPath vaultPath recipientUpd identityUpd unlockMode
708
709 -- ---------------------------------------------------------------------------
710 -- Channel subcommand execution
711 -- ---------------------------------------------------------------------------
712
713 executeChannelCommand :: AgentEnv -> ChannelSubCommand -> Context -> IO Context
714 executeChannelCommand env ChannelList ctx = do
715 let send = _ch_send (_env_channel env) . OutgoingMessage
716 -- Read current config to show status
717 fileCfg <- loadConfig
718 let currentChannel = maybe "cli" T.unpack (_fc_defaultChannel fileCfg)
719 signalConfigured = case _fc_signal fileCfg of
720 Just sig -> case _fsc_account sig of
721 Just acct -> " (account: " <> acct <> ")"
722 Nothing -> " (not configured)"
723 Nothing -> " (not configured)"
724 send $ T.intercalate "\n"
725 [ "Chat channels:"
726 , ""
727 , " cli \x2014 Terminal stdin/stdout" <> if currentChannel == "cli" then " [active]" else ""
728 , " signal \x2014 Signal messenger" <> signalConfigured <> if currentChannel == "signal" then " [active]" else ""
729 , " telegram \x2014 Telegram bot (coming soon)"
730 , ""
731 , "Set up a channel: /channel signal"
732 , "Switch channel: Set default_channel in config, then restart"
733 ]
734 pure ctx
735
736 executeChannelCommand env (ChannelSetup channelName) ctx = do
737 let send = _ch_send (_env_channel env) . OutgoingMessage
738 case channelName of
739 "signal" -> executeSignalSetup env ctx
740 "telegram" -> do
741 send "Telegram setup is not yet implemented. Coming soon!"
742 pure ctx
743 other -> do
744 send $ "Unknown channel: " <> other <> ". Available: signal, telegram"
745 pure ctx
746
747 executeChannelCommand env (ChannelUnknown sub) ctx = do
748 _ch_send (_env_channel env) (OutgoingMessage
749 ("Unknown channel command: " <> sub <> ". Type /channel for available options."))
750 pure ctx
751
752 -- ---------------------------------------------------------------------------
753 -- Signal setup wizard
754 -- ---------------------------------------------------------------------------
755
756 -- | Interactive Signal setup. Checks signal-cli, offers link or register,
757 -- walks through the flow, writes config.
758 executeSignalSetup :: AgentEnv -> Context -> IO Context
759 executeSignalSetup env ctx = do
760 let ch = _env_channel env
761 send = _ch_send ch . OutgoingMessage
762
763 -- Step 1: Check signal-cli is installed
764 signalCliCheck <- try @IOException $
765 P.readProcess (P.proc "signal-cli" ["--version"])
766 case signalCliCheck of
767 Left _ -> do
768 send $ T.intercalate "\n"
769 [ "signal-cli is not installed."
770 , ""
771 , "Install it first:"
772 , " macOS: brew install signal-cli"
773 , " Nix: nix-env -i signal-cli"
774 , " Other: https://github.com/AsamK/signal-cli"
775 , ""
776 , "Then run /channel signal again."
777 ]
778 pure ctx
779 Right (exitCode, versionOut, _) -> do
780 let version = T.strip (TE.decodeUtf8 (BL.toStrict versionOut))
781 case exitCode of
782 ExitSuccess ->
783 send $ "Found signal-cli " <> version
784 _ ->
785 send "Found signal-cli (version unknown)"
786
787 -- Step 2: Offer link or register
788 send $ T.intercalate "\n"
789 [ ""
790 , "How would you like to connect?"
791 , " [1] Link to an existing Signal account (adds PureClaw as secondary device)"
792 , " [2] Register with a phone number (becomes primary device for that number)"
793 , ""
794 , "Note: Option 2 will take over the number from any existing Signal registration."
795 ]
796
797 choice <- T.strip <$> _ch_prompt ch "Choice [1]: "
798 let effectiveChoice = if T.null choice then "1" else choice
799
800 case effectiveChoice of
801 "1" -> signalLinkFlow env ctx
802 "2" -> signalRegisterFlow env ctx
803 _ -> do
804 send "Invalid choice. Setup cancelled."
805 pure ctx
806
807 -- | Link to an existing Signal account by scanning a QR code.
808 -- signal-cli link outputs the sgnl:// URI, then blocks until the user
809 -- scans it. We need to stream the output to show the URI immediately.
810 signalLinkFlow :: AgentEnv -> Context -> IO Context
811 signalLinkFlow env ctx = do
812 let ch = _env_channel env
813 send = _ch_send ch . OutgoingMessage
814
815 send "Generating link... (this may take a moment)"
816
817 let procConfig = P.setStdout P.createPipe
818 $ P.setStderr P.createPipe
819 $ P.proc "signal-cli" ["link", "-n", "PureClaw"]
820 startResult <- try @IOException $ P.startProcess procConfig
821 case startResult of
822 Left err -> do
823 send $ "Failed to start signal-cli: " <> T.pack (show err)
824 pure ctx
825 Right process -> do
826 let stdoutH = P.getStdout process
827 stderrH = P.getStderr process
828 -- signal-cli outputs the URI to stderr, then blocks waiting for scan.
829 -- Read stderr lines until we find the sgnl:// URI.
830 linkUri <- readUntilLink stderrH stdoutH
831 case linkUri of
832 Nothing -> do
833 -- Process may have exited with error
834 exitCode <- P.waitExitCode process
835 send $ "signal-cli link failed (exit " <> T.pack (show exitCode) <> ")"
836 pure ctx
837 Just uri -> do
838 send $ T.intercalate "\n"
839 [ "Open Signal on your phone:"
840 , " Settings \x2192 Linked Devices \x2192 Link New Device"
841 , ""
842 , "Scan this link (or paste into a QR code generator):"
843 , ""
844 , " " <> uri
845 , ""
846 , "Waiting for you to scan... (this will complete automatically)"
847 ]
848 -- Now wait for signal-cli to finish (user scans the code)
849 exitCode <- P.waitExitCode process
850 case exitCode of
851 ExitSuccess -> do
852 send "Linked successfully!"
853 detectAndWriteSignalConfig env ctx
854 _ -> do
855 send "Link failed or was cancelled."
856 pure ctx
857 where
858 -- Read lines from both handles looking for a sgnl:// URI.
859 -- signal-cli typically puts it on stderr.
860 readUntilLink :: Handle -> Handle -> IO (Maybe Text)
861 readUntilLink stderrH stdoutH = go (50 :: Int) -- max 50 lines to prevent infinite loop
862 where
863 go 0 = pure Nothing
864 go n = do
865 lineResult <- try @IOException (hGetLine stderrH)
866 case lineResult of
867 Left _ -> do
868 -- stderr closed, try stdout
869 outResult <- try @IOException (hGetLine stdoutH)
870 case outResult of
871 Left _ -> pure Nothing
872 Right line ->
873 let t = T.pack line
874 in if "sgnl://" `T.isInfixOf` t
875 then pure (Just (T.strip t))
876 else go (n - 1)
877 Right line ->
878 let t = T.pack line
879 in if "sgnl://" `T.isInfixOf` t
880 then pure (Just (T.strip t))
881 else go (n - 1)
882
883 -- | Register a new phone number.
884 signalRegisterFlow :: AgentEnv -> Context -> IO Context
885 signalRegisterFlow env ctx = do
886 let ch = _env_channel env
887 send = _ch_send ch . OutgoingMessage
888
889 phoneNumber <- T.strip <$> _ch_prompt ch "Phone number (E.164 format, e.g. +15555550123): "
890 if T.null phoneNumber || not ("+" `T.isPrefixOf` phoneNumber)
891 then do
892 send "Invalid phone number. Must start with + (E.164 format)."
893 pure ctx
894 else do
895 -- Try register without captcha first, handle captcha if required
896 signalRegister env ch phoneNumber Nothing ctx
897
898 -- | Attempt signal-cli register, handling captcha if required.
899 signalRegister :: AgentEnv -> ChannelHandle -> Text -> Maybe Text -> Context -> IO Context
900 signalRegister env ch phoneNumber mCaptcha ctx = do
901 let send = _ch_send ch . OutgoingMessage
902 args = ["-u", T.unpack phoneNumber, "register"]
903 ++ maybe [] (\c -> ["--captcha", T.unpack c]) mCaptcha
904 send $ "Sending verification SMS to " <> phoneNumber <> "..."
905 regResult <- try @IOException $
906 P.readProcess (P.proc "signal-cli" args)
907 case regResult of
908 Left err -> do
909 send $ "Registration failed: " <> T.pack (show err)
910 pure ctx
911 Right (exitCode, _, errOut) -> do
912 let errText = T.strip (TE.decodeUtf8 (BL.toStrict errOut))
913 case exitCode of
914 ExitSuccess -> signalVerify env ch phoneNumber ctx
915 _ | "captcha" `T.isInfixOf` T.toLower errText -> do
916 send $ T.intercalate "\n"
917 [ "Signal requires a captcha before sending the SMS."
918 , ""
919 , "1. Open this URL in a browser:"
920 , " https://signalcaptchas.org/registration/generate.html"
921 , "2. Solve the captcha"
922 , "3. Open DevTools (F12), go to Network tab"
923 , "4. Click \"Open Signal\" \x2014 find the signalcaptcha:// URL in the Network tab"
924 , "5. Copy and paste the full URL here (starts with signalcaptcha://)"
925 ]
926 captchaInput <- T.strip <$> _ch_prompt ch "Captcha token: "
927 let token = T.strip (T.replace "signalcaptcha://" "" captchaInput)
928 if T.null token
929 then do
930 send "No captcha provided. Setup cancelled."
931 pure ctx
932 else signalRegister env ch phoneNumber (Just token) ctx
933 _ -> do
934 send $ "Registration failed: " <> errText
935 pure ctx
936
937 -- | Verify a phone number after registration SMS was sent.
938 signalVerify :: AgentEnv -> ChannelHandle -> Text -> Context -> IO Context
939 signalVerify env ch phoneNumber ctx = do
940 let send = _ch_send ch . OutgoingMessage
941 send "Verification code sent! Check your SMS."
942 code <- T.strip <$> _ch_prompt ch "Verification code: "
943 verifyResult <- try @IOException $
944 P.readProcess (P.proc "signal-cli"
945 ["-u", T.unpack phoneNumber, "verify", T.unpack code])
946 case verifyResult of
947 Left err -> do
948 send $ "Verification failed: " <> T.pack (show err)
949 pure ctx
950 Right (verifyExit, _, verifyErr) -> case verifyExit of
951 ExitSuccess -> do
952 send "Phone number verified!"
953 writeSignalConfig env phoneNumber ctx
954 _ -> do
955 send $ "Verification failed: " <> T.strip (TE.decodeUtf8 (BL.toStrict verifyErr))
956 pure ctx
957
958 -- | Detect the linked account number and write Signal config.
959 detectAndWriteSignalConfig :: AgentEnv -> Context -> IO Context
960 detectAndWriteSignalConfig env ctx = do
961 let send = _ch_send (_env_channel env) . OutgoingMessage
962 -- signal-cli stores account info; try to list accounts
963 acctResult <- try @IOException $
964 P.readProcess (P.proc "signal-cli" ["listAccounts"])
965 case acctResult of
966 Left _ -> do
967 -- Can't detect — ask user
968 phoneNumber <- T.strip <$> _ch_prompt (_env_channel env)
969 "What phone number was linked? (E.164 format): "
970 writeSignalConfig env phoneNumber ctx
971 Right (_, out, _) -> do
972 let outText = T.strip (TE.decodeUtf8 (BL.toStrict out))
973 -- Look for a line starting with + (phone number)
974 phones = filter ("+" `T.isPrefixOf`) (map T.strip (T.lines outText))
975 case phones of
976 (phone:_) -> do
977 send $ "Detected account: " <> phone
978 writeSignalConfig env phone ctx
979 [] -> do
980 phoneNumber <- T.strip <$> _ch_prompt (_env_channel env)
981 "Could not detect account. Phone number (E.164 format): "
982 writeSignalConfig env phoneNumber ctx
983
984 -- | Write Signal config to config.toml and confirm.
985 writeSignalConfig :: AgentEnv -> Text -> Context -> IO Context
986 writeSignalConfig env phoneNumber ctx = do
987 let send = _ch_send (_env_channel env) . OutgoingMessage
988 pureclawDir <- getPureclawDir
989 Dir.createDirectoryIfMissing True pureclawDir
990 let configPath = pureclawDir </> "config.toml"
991
992 -- Load existing config, add signal settings
993 existing <- loadFileConfig configPath
994 let updated = existing
995 { _fc_defaultChannel = Just "signal"
996 , _fc_signal = Just FileSignalConfig
997 { _fsc_account = Just phoneNumber
998 , _fsc_dmPolicy = Just "open"
999 , _fsc_allowFrom = Nothing
1000 , _fsc_textChunkLimit = Nothing -- use default 6000
1001 }
1002 }
1003 writeFileConfig configPath updated
1004
1005 send $ T.intercalate "\n"
1006 [ ""
1007 , "Signal configured!"
1008 , " Account: " <> phoneNumber
1009 , " DM policy: open (accepts messages from anyone)"
1010 , " Default channel: signal"
1011 , ""
1012 , "To start chatting:"
1013 , " 1. Restart PureClaw (or run: pureclaw --channel signal)"
1014 , " 2. Open Signal on your phone"
1015 , " 3. Send a message to " <> phoneNumber
1016 , ""
1017 , "To restrict access later, edit ~/.pureclaw/config.toml:"
1018 , " [signal]"
1019 , " dm_policy = \"allowlist\""
1020 , " allow_from = [\"<your-uuid>\"]"
1021 , ""
1022 , "Your UUID will appear in the logs on first message."
1023 ]
1024 pure ctx
1025
1026 -- ---------------------------------------------------------------------------
1027 -- Help rendering — derived from allCommandSpecs
1028 -- ---------------------------------------------------------------------------
1029
1030 -- | Render the full command reference from 'allCommandSpecs'.
1031 renderHelpText :: [CommandSpec] -> Text
1032 renderHelpText specs =
1033 T.intercalate "\n"
1034 ("Slash commands:" : concatMap renderGroup [minBound .. maxBound])
1035 where
1036 renderGroup g =
1037 let gs = filter ((== g) . _cs_group) specs
1038 in if null gs
1039 then []
1040 else "" : (" " <> groupHeading g <> ":") : map renderSpec gs
1041
1042 renderSpec spec =
1043 " " <> padTo 26 (_cs_syntax spec) <> _cs_description spec
1044
1045 padTo n t = t <> T.replicate (max 1 (n - T.length t)) " "