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