never executed always true always false
1 module PureClaw.Agent.SlashCommands
2 ( -- * Command data types
3 SlashCommand (..)
4 , VaultSubCommand (..)
5 , ProviderSubCommand (..)
6 , ChannelSubCommand (..)
7 , TranscriptSubCommand (..)
8 , HarnessSubCommand (..)
9 , AgentSubCommand (..)
10 -- * Known harnesses
11 , knownHarnesses
12 -- * Agent name tab completion helper
13 , agentNameMatches
14 -- * Command registry — single source of truth
15 , CommandGroup (..)
16 , CommandSpec (..)
17 , allCommandSpecs
18 -- * Parsing (derived from allCommandSpecs)
19 , parseSlashCommand
20 -- * Execution
21 , executeSlashCommand
22 -- * Discovery
23 , discoverHarnesses
24 , discoverHarnessesIn
25 ) where
26
27 import Control.Applicative ((<|>))
28 import Control.Exception
29 import Control.Monad
30 import Data.Foldable (asum)
31 import Data.IORef
32 import Data.Map.Strict qualified as Map
33 import Data.List qualified as L
34 import Data.Maybe qualified
35 import Data.Text (Text)
36 import Data.Text qualified as T
37 import Data.Text.Encoding qualified as TE
38 import Data.Text.IO qualified as TIO
39 import Network.HTTP.Client.TLS qualified as HTTP
40 import System.Directory qualified as Dir
41 import System.FilePath ((</>))
42
43 import Data.ByteString.Lazy qualified as BL
44 import System.Exit
45 import System.IO (Handle, hGetLine)
46 import System.Process.Typed qualified as P
47
48 import PureClaw.Agent.AgentDef qualified as AgentDef
49 import PureClaw.Agent.Compaction
50 import PureClaw.Agent.Context
51 import PureClaw.Agent.Env
52 import PureClaw.Auth.AnthropicOAuth
53 import PureClaw.CLI.Config
54 import PureClaw.Core.Types
55 import PureClaw.Handles.Channel
56 import PureClaw.Handles.Harness
57 import PureClaw.Handles.Log
58 import PureClaw.Handles.Transcript
59 import PureClaw.Harness.ClaudeCode
60 import PureClaw.Harness.Tmux
61 import Data.Text.Read qualified as TR
62 import PureClaw.Providers.Class
63 import PureClaw.Providers.Ollama
64 import PureClaw.Security.Policy
65 import PureClaw.Security.Vault
66 import PureClaw.Security.Vault.Age
67 import PureClaw.Security.Vault.Passphrase
68 import PureClaw.Security.Vault.Plugin
69 import PureClaw.Transcript.Types
70
71 -- ---------------------------------------------------------------------------
72 -- Command taxonomy
73 -- ---------------------------------------------------------------------------
74
75 -- | Organisational group for display in '/help'.
76 data CommandGroup
77 = GroupSession -- ^ Session and context management
78 | GroupProvider -- ^ Model provider configuration
79 | GroupChannel -- ^ Chat channel configuration
80 | GroupVault -- ^ Encrypted secrets vault
81 | GroupTranscript -- ^ Transcript / permanent log
82 | GroupHarness -- ^ Harness management (tmux-based AI CLI tools)
83 | GroupAgent -- ^ Agent management (bootstrap file collections)
84 deriving stock (Show, Eq, Ord, Enum, Bounded)
85
86 -- | Human-readable section heading for '/help' output.
87 groupHeading :: CommandGroup -> Text
88 groupHeading GroupSession = "Session"
89 groupHeading GroupProvider = "Provider"
90 groupHeading GroupChannel = "Channel"
91 groupHeading GroupVault = "Vault"
92 groupHeading GroupTranscript = "Transcript"
93 groupHeading GroupHarness = "Harness"
94 groupHeading GroupAgent = "Agent"
95
96 -- | Specification for a single slash command.
97 -- 'allCommandSpecs' is the single source of truth: 'parseSlashCommand'
98 -- is derived from '_cs_parse' and '/help' renders from '_cs_syntax' /
99 -- '_cs_description', so the two cannot diverge.
100 data CommandSpec = CommandSpec
101 { _cs_syntax :: Text -- ^ Display syntax, e.g. "/vault add <name>"
102 , _cs_description :: Text -- ^ One-line description shown in '/help'
103 , _cs_group :: CommandGroup -- ^ Organisational group
104 , _cs_parse :: Text -> Maybe SlashCommand
105 -- ^ Try to parse a stripped, original-case input as this command.
106 -- Match is case-insensitive on keywords; argument case is preserved.
107 }
108
109 -- ---------------------------------------------------------------------------
110 -- Vault subcommands
111 -- ---------------------------------------------------------------------------
112
113 -- | Subcommands of the '/vault' family.
114 data VaultSubCommand
115 = VaultSetup -- ^ Interactive vault setup wizard
116 | VaultAdd Text -- ^ Store a named secret
117 | VaultList -- ^ List secret names
118 | VaultDelete Text -- ^ Delete a named secret
119 | VaultLock -- ^ Lock the vault
120 | VaultUnlock -- ^ Unlock the vault
121 | VaultStatus' -- ^ Show vault status
122 | VaultUnknown Text -- ^ Unrecognised subcommand (not in allCommandSpecs)
123 deriving stock (Show, Eq)
124
125 -- | Subcommands of the '/provider' family.
126 data ProviderSubCommand
127 = ProviderList -- ^ List available providers
128 | ProviderConfigure Text -- ^ Configure a specific provider
129 deriving stock (Show, Eq)
130
131 -- | Subcommands of the '/channel' family.
132 data ChannelSubCommand
133 = ChannelList -- ^ Show current channel + available options
134 | ChannelSetup Text -- ^ Interactive setup for a specific channel
135 | ChannelUnknown Text -- ^ Unrecognised subcommand
136 deriving stock (Show, Eq)
137
138 -- | Subcommands of the '/transcript' family.
139 data TranscriptSubCommand
140 = TranscriptRecent (Maybe Int) -- ^ Show last N entries (default 20)
141 | TranscriptSearch Text -- ^ Filter by source name
142 | TranscriptPath -- ^ Show log file path
143 | TranscriptUnknown Text -- ^ Unrecognised subcommand
144 deriving stock (Show, Eq)
145
146 -- | Subcommands of the '/harness' family.
147 data HarnessSubCommand
148 = HarnessStart Text (Maybe Text) Bool -- ^ Start a named harness, optional working directory, unsafe mode
149 | HarnessStop Text -- ^ Stop a named harness
150 | HarnessList -- ^ List running harnesses
151 | HarnessAttach -- ^ Show tmux attach command
152 | HarnessUnknown Text -- ^ Unrecognised subcommand
153 deriving stock (Show, Eq)
154
155 -- | Subcommands of the '/agent' family.
156 data AgentSubCommand
157 = AgentList -- ^ List discovered agents
158 | AgentInfo (Maybe Text) -- ^ Show info for a named agent (or the current one when 'Nothing')
159 | AgentStart Text -- ^ Switch to a named agent (placeholder in WU1)
160 | AgentUnknown Text -- ^ Unrecognised subcommand
161 deriving stock (Show, Eq)
162
163 -- ---------------------------------------------------------------------------
164 -- Top-level commands
165 -- ---------------------------------------------------------------------------
166
167 -- | All recognised slash commands.
168 data SlashCommand
169 = CmdHelp -- ^ Show command reference
170 | CmdNew -- ^ Clear conversation, keep configuration
171 | CmdReset -- ^ Full reset including usage counters
172 | CmdStatus -- ^ Show session status
173 | CmdCompact -- ^ Summarise conversation to save context
174 | CmdTarget (Maybe Text) -- ^ Show or switch message target
175 | CmdTargetList -- ^ List available targets (models + harnesses)
176 | CmdProvider ProviderSubCommand -- ^ Provider configuration command family
177 | CmdVault VaultSubCommand -- ^ Vault command family
178 | CmdChannel ChannelSubCommand -- ^ Channel configuration
179 | CmdTranscript TranscriptSubCommand -- ^ Transcript query commands
180 | CmdHarness HarnessSubCommand -- ^ Harness management commands
181 | CmdAgent AgentSubCommand -- ^ Agent management commands
182 | CmdMsg Text Text -- ^ Send a message to a specific target (name, message)
183 deriving stock (Show, Eq)
184
185 -- ---------------------------------------------------------------------------
186 -- Command registry
187 -- ---------------------------------------------------------------------------
188
189 -- | All recognised slash commands, in the order they appear in '/help'.
190 -- This is the authoritative definition: 'parseSlashCommand' is derived
191 -- from '_cs_parse' across this list, and '/help' renders from it.
192 -- To add a command, add a 'CommandSpec' here — parsing and help update
193 -- automatically.
194 allCommandSpecs :: [CommandSpec]
195 allCommandSpecs = sessionCommandSpecs ++ providerCommandSpecs ++ channelCommandSpecs ++ vaultCommandSpecs ++ transcriptCommandSpecs ++ harnessCommandSpecs ++ agentCommandSpecs ++ msgCommandSpecs
196
197 sessionCommandSpecs :: [CommandSpec]
198 sessionCommandSpecs =
199 [ CommandSpec "/help" "Show this command reference" GroupSession (exactP "/help" CmdHelp)
200 , CommandSpec "/status" "Session status (messages, tokens used)" GroupSession (exactP "/status" CmdStatus)
201 , CommandSpec "/new" "Clear conversation, keep configuration" GroupSession (exactP "/new" CmdNew)
202 , CommandSpec "/reset" "Full reset including usage counters" GroupSession (exactP "/reset" CmdReset)
203 , CommandSpec "/compact" "Summarise conversation to save context" GroupSession (exactP "/compact" CmdCompact)
204 ]
205
206 providerCommandSpecs :: [CommandSpec]
207 providerCommandSpecs =
208 [ CommandSpec "/provider [name]" "List or configure a model provider" GroupProvider (providerArgP ProviderList ProviderConfigure)
209 , CommandSpec "/target list" "List available targets (models + harnesses)" GroupProvider (exactP "/target list" CmdTargetList)
210 , CommandSpec "/target [name]" "Show or switch the message target" GroupProvider targetArgP
211 ]
212
213 channelCommandSpecs :: [CommandSpec]
214 channelCommandSpecs =
215 [ CommandSpec "/channel" "Show current channel and available options" GroupChannel (channelArgP ChannelList ChannelSetup)
216 , CommandSpec "/channel signal" "Set up Signal messenger integration" GroupChannel (channelExactP "signal" (ChannelSetup "signal"))
217 , CommandSpec "/channel telegram" "Set up Telegram bot integration" GroupChannel (channelExactP "telegram" (ChannelSetup "telegram"))
218 ]
219
220 vaultCommandSpecs :: [CommandSpec]
221 vaultCommandSpecs =
222 [ CommandSpec "/vault setup" "Set up or rekey the encrypted secrets vault" GroupVault (vaultExactP "setup" VaultSetup)
223 , CommandSpec "/vault add <name>" "Store a named secret (prompts for value)" GroupVault (vaultArgP "add" VaultAdd)
224 , CommandSpec "/vault list" "List all stored secret names" GroupVault (vaultExactP "list" VaultList)
225 , CommandSpec "/vault delete <name>" "Delete a named secret" GroupVault (vaultArgP "delete" VaultDelete)
226 , CommandSpec "/vault lock" "Lock the vault" GroupVault (vaultExactP "lock" VaultLock)
227 , CommandSpec "/vault unlock" "Unlock the vault" GroupVault (vaultExactP "unlock" VaultUnlock)
228 , CommandSpec "/vault status" "Show vault state and key type" GroupVault (vaultExactP "status" VaultStatus')
229 ]
230
231 transcriptCommandSpecs :: [CommandSpec]
232 transcriptCommandSpecs =
233 [ CommandSpec "/transcript [N]" "Show last N entries (default 20)" GroupTranscript transcriptRecentP
234 , CommandSpec "/transcript search <source>" "Filter by source name" GroupTranscript (transcriptArgP "search" TranscriptSearch)
235 , CommandSpec "/transcript path" "Show the JSONL file path" GroupTranscript (transcriptExactP "path" TranscriptPath)
236 ]
237
238 harnessCommandSpecs :: [CommandSpec]
239 harnessCommandSpecs =
240 [ CommandSpec "/harness start <name> [dir] [--unsafe]" "Start a harness (--unsafe skips permission checks)" GroupHarness harnessStartP
241 , CommandSpec "/harness stop <name>" "Stop a running harness" GroupHarness (harnessArgP "stop" HarnessStop)
242 , CommandSpec "/harness list" "List running harnesses" GroupHarness (harnessExactP "list" HarnessList)
243 , CommandSpec "/harness attach" "Show tmux attach command" GroupHarness (harnessExactP "attach" HarnessAttach)
244 ]
245
246 agentCommandSpecs :: [CommandSpec]
247 agentCommandSpecs =
248 [ CommandSpec "/agent list" "List discovered agents in ~/.pureclaw/agents/" GroupAgent (agentExactP "list" AgentList)
249 , CommandSpec "/agent info [<name>]" "Show files and frontmatter for an agent" GroupAgent agentInfoP
250 , CommandSpec "/agent start <name>" "Switch to a named agent" GroupAgent agentStartP
251 ]
252
253 -- | Case-insensitive exact match for "/agent <sub>" with no argument.
254 agentExactP :: Text -> AgentSubCommand -> Text -> Maybe SlashCommand
255 agentExactP sub cmd t =
256 if T.toLower t == "/agent " <> sub then Just (CmdAgent cmd) else Nothing
257
258 -- | Parse "/agent info [<name>]". With no argument, yields @AgentInfo Nothing@.
259 agentInfoP :: Text -> Maybe SlashCommand
260 agentInfoP t =
261 let pfx = "/agent info"
262 lower = T.toLower t
263 in if lower == pfx
264 then Just (CmdAgent (AgentInfo Nothing))
265 else if (pfx <> " ") `T.isPrefixOf` lower
266 then let arg = T.strip (T.drop (T.length pfx) t)
267 in if T.null arg
268 then Just (CmdAgent (AgentInfo Nothing))
269 else Just (CmdAgent (AgentInfo (Just arg)))
270 else Nothing
271
272 -- | Parse "/agent start <name>". The name is required; a bare "/agent start"
273 -- falls through to the unknown fallback ("start").
274 agentStartP :: Text -> Maybe SlashCommand
275 agentStartP t =
276 let pfx = "/agent start"
277 lower = T.toLower t
278 in if (pfx <> " ") `T.isPrefixOf` lower
279 then let arg = T.strip (T.drop (T.length pfx) t)
280 in if T.null arg
281 then Nothing
282 else Just (CmdAgent (AgentStart arg))
283 else Nothing
284
285 -- | Catch-all for any "/agent <X>" not matched by 'allCommandSpecs'.
286 agentUnknownFallback :: Text -> Maybe SlashCommand
287 agentUnknownFallback t =
288 let lower = T.toLower t
289 in if "/agent" `T.isPrefixOf` lower
290 then let rest = T.strip (T.drop (T.length "/agent") lower)
291 sub = fst (T.break (== ' ') rest)
292 in Just (CmdAgent (AgentUnknown sub))
293 else Nothing
294
295 msgCommandSpecs :: [CommandSpec]
296 msgCommandSpecs =
297 [ CommandSpec "/msg <target> <message>" "Send a message to a specific harness/model" GroupHarness msgArgP
298 ]
299
300 -- | Parse "/msg <target> <message>". The first word after /msg is the target,
301 -- the rest is the message body. Both are required.
302 msgArgP :: Text -> Maybe SlashCommand
303 msgArgP t =
304 let pfx = "/msg"
305 lower = T.toLower t
306 in if (pfx <> " ") `T.isPrefixOf` lower
307 then let rest = T.strip (T.drop (T.length pfx) t)
308 (target, body) = T.break (== ' ') rest
309 in if T.null target || T.null (T.strip body)
310 then Nothing
311 else Just (CmdMsg target (T.strip body))
312 else Nothing
313
314 -- ---------------------------------------------------------------------------
315 -- Parsing — derived from allCommandSpecs
316 -- ---------------------------------------------------------------------------
317
318 -- | Parse a user message as a slash command.
319 -- Implemented as 'asum' over '_cs_parse' from 'allCommandSpecs', followed
320 -- by a catch-all for unrecognised @\/vault@ subcommands.
321 -- Returns 'Nothing' only for input that does not begin with @\/@.
322 parseSlashCommand :: Text -> Maybe SlashCommand
323 parseSlashCommand input =
324 let stripped = T.strip input
325 in if "/" `T.isPrefixOf` stripped
326 then asum (map (`_cs_parse` stripped) allCommandSpecs)
327 <|> channelUnknownFallback stripped
328 <|> vaultUnknownFallback stripped
329 <|> transcriptUnknownFallback stripped
330 <|> harnessUnknownFallback stripped
331 <|> agentUnknownFallback stripped
332 else Nothing
333
334 -- | Exact case-insensitive match.
335 exactP :: Text -> SlashCommand -> Text -> Maybe SlashCommand
336 exactP keyword cmd t = if T.toLower t == keyword then Just cmd else Nothing
337
338 -- | Case-insensitive match for "/vault <sub>" with no argument.
339 vaultExactP :: Text -> VaultSubCommand -> Text -> Maybe SlashCommand
340 vaultExactP sub cmd t =
341 if T.toLower t == "/vault " <> sub then Just (CmdVault cmd) else Nothing
342
343 -- | Case-insensitive prefix match for "/vault <sub> [arg]".
344 -- Argument is extracted from the original-case input, preserving its case.
345 vaultArgP :: Text -> (Text -> VaultSubCommand) -> Text -> Maybe SlashCommand
346 vaultArgP sub mkCmd t =
347 let pfx = "/vault " <> sub
348 lower = T.toLower t
349 in if lower == pfx || (pfx <> " ") `T.isPrefixOf` lower
350 then Just (CmdVault (mkCmd (T.strip (T.drop (T.length pfx) t))))
351 else Nothing
352
353 -- | Case-insensitive match for "/provider [name]".
354 -- With no argument, returns the list command. With an argument, returns
355 -- the configure command with the argument preserved in original case.
356 providerArgP :: ProviderSubCommand -> (Text -> ProviderSubCommand) -> Text -> Maybe SlashCommand
357 providerArgP listCmd mkCfgCmd t =
358 let pfx = "/provider"
359 lower = T.toLower t
360 in if lower == pfx
361 then Just (CmdProvider listCmd)
362 else if (pfx <> " ") `T.isPrefixOf` lower
363 then let arg = T.strip (T.drop (T.length pfx) t)
364 in if T.null arg
365 then Just (CmdProvider listCmd)
366 else Just (CmdProvider (mkCfgCmd arg))
367 else Nothing
368
369 -- | Case-insensitive match for "/target" with optional argument.
370 targetArgP :: Text -> Maybe SlashCommand
371 targetArgP t =
372 let pfx = "/target"
373 lower = T.toLower t
374 in if lower == pfx
375 then Just (CmdTarget Nothing)
376 else if (pfx <> " ") `T.isPrefixOf` lower
377 then let arg = T.strip (T.drop (T.length pfx) t)
378 in Just (CmdTarget (if T.null arg then Nothing else Just arg))
379 else Nothing
380
381 -- | Case-insensitive match for "/channel" with optional argument.
382 channelArgP :: ChannelSubCommand -> (Text -> ChannelSubCommand) -> Text -> Maybe SlashCommand
383 channelArgP listCmd mkSetupCmd t =
384 let pfx = "/channel"
385 lower = T.toLower t
386 in if lower == pfx
387 then Just (CmdChannel listCmd)
388 else if (pfx <> " ") `T.isPrefixOf` lower
389 then let arg = T.strip (T.drop (T.length pfx) t)
390 in if T.null arg
391 then Just (CmdChannel listCmd)
392 else Just (CmdChannel (mkSetupCmd (T.toLower arg)))
393 else Nothing
394
395 -- | Case-insensitive exact match for "/channel <sub>".
396 channelExactP :: Text -> ChannelSubCommand -> Text -> Maybe SlashCommand
397 channelExactP sub cmd t =
398 if T.toLower t == "/channel " <> sub then Just (CmdChannel cmd) else Nothing
399
400 -- | Catch-all for any "/channel <X>" not matched by 'allCommandSpecs'.
401 channelUnknownFallback :: Text -> Maybe SlashCommand
402 channelUnknownFallback t =
403 let lower = T.toLower t
404 in if "/channel" `T.isPrefixOf` lower
405 then let rest = T.strip (T.drop (T.length "/channel") lower)
406 sub = fst (T.break (== ' ') rest)
407 in Just (CmdChannel (ChannelUnknown sub))
408 else Nothing
409
410 -- | Catch-all for any "/vault <X>" not matched by 'allCommandSpecs'.
411 -- Not included in the spec list so it does not appear in '/help'.
412 vaultUnknownFallback :: Text -> Maybe SlashCommand
413 vaultUnknownFallback t =
414 let lower = T.toLower t
415 in if "/vault" `T.isPrefixOf` lower
416 then let rest = T.strip (T.drop (T.length "/vault") lower)
417 sub = fst (T.break (== ' ') rest)
418 in Just (CmdVault (VaultUnknown sub))
419 else Nothing
420
421 -- | Parse "/transcript" with optional numeric argument.
422 -- "/transcript" -> TranscriptRecent Nothing
423 -- "/transcript 50" -> TranscriptRecent (Just 50)
424 transcriptRecentP :: Text -> Maybe SlashCommand
425 transcriptRecentP t =
426 let pfx = "/transcript"
427 lower = T.toLower t
428 in if lower == pfx
429 then Just (CmdTranscript (TranscriptRecent Nothing))
430 else if (pfx <> " ") `T.isPrefixOf` lower
431 then let arg = T.strip (T.drop (T.length pfx) t)
432 in if T.null arg
433 then Just (CmdTranscript (TranscriptRecent Nothing))
434 else case reads (T.unpack arg) of
435 [(n, "")] -> Just (CmdTranscript (TranscriptRecent (Just n)))
436 _ -> Nothing
437 else Nothing
438
439 -- | Case-insensitive exact match for "/transcript <sub>".
440 transcriptExactP :: Text -> TranscriptSubCommand -> Text -> Maybe SlashCommand
441 transcriptExactP sub cmd t =
442 if T.toLower t == "/transcript " <> sub then Just (CmdTranscript cmd) else Nothing
443
444 -- | Case-insensitive prefix match for "/transcript <sub> <arg>".
445 transcriptArgP :: Text -> (Text -> TranscriptSubCommand) -> Text -> Maybe SlashCommand
446 transcriptArgP sub mkCmd t =
447 let pfx = "/transcript " <> sub
448 lower = T.toLower t
449 in if (pfx <> " ") `T.isPrefixOf` lower
450 then let arg = T.strip (T.drop (T.length pfx) t)
451 in if T.null arg
452 then Nothing
453 else Just (CmdTranscript (mkCmd arg))
454 else Nothing
455
456 -- | Catch-all for any "/transcript <X>" not matched by 'allCommandSpecs'.
457 transcriptUnknownFallback :: Text -> Maybe SlashCommand
458 transcriptUnknownFallback t =
459 let lower = T.toLower t
460 in if "/transcript" `T.isPrefixOf` lower
461 then let rest = T.strip (T.drop (T.length "/transcript") lower)
462 sub = fst (T.break (== ' ') rest)
463 in Just (CmdTranscript (TranscriptUnknown sub))
464 else Nothing
465
466 -- | Case-insensitive exact match for "/harness <sub>".
467 harnessExactP :: Text -> HarnessSubCommand -> Text -> Maybe SlashCommand
468 harnessExactP sub cmd t =
469 if T.toLower t == "/harness " <> sub then Just (CmdHarness cmd) else Nothing
470
471 -- | Parse "/harness start <name> [dir] [--unsafe]".
472 -- The first word after "start" is the harness name. Remaining words are
473 -- split into an optional directory (any non-flag token) and the
474 -- @--unsafe@ flag.
475 harnessStartP :: Text -> Maybe SlashCommand
476 harnessStartP t =
477 let pfx = "/harness start"
478 lower = T.toLower t
479 in if (pfx <> " ") `T.isPrefixOf` lower
480 then let rest = T.strip (T.drop (T.length pfx) t)
481 (name, afterName) = T.break (== ' ') rest
482 in if T.null name
483 then Nothing
484 else let tokens = T.words (T.strip afterName)
485 skipPerms = "--unsafe" `elem` map T.toLower tokens
486 positional = filter (\tok -> T.toLower tok /= "--unsafe") tokens
487 dir = case positional of
488 (d : _) -> Just d
489 [] -> Nothing
490 in Just (CmdHarness (HarnessStart name dir skipPerms))
491 else Nothing
492
493 -- | Case-insensitive prefix match for "/harness <sub> <arg>".
494 harnessArgP :: Text -> (Text -> HarnessSubCommand) -> Text -> Maybe SlashCommand
495 harnessArgP sub mkCmd t =
496 let pfx = "/harness " <> sub
497 lower = T.toLower t
498 in if (pfx <> " ") `T.isPrefixOf` lower
499 then let arg = T.strip (T.drop (T.length pfx) t)
500 in if T.null arg
501 then Nothing
502 else Just (CmdHarness (mkCmd arg))
503 else Nothing
504
505 -- | Catch-all for any "/harness <X>" not matched by 'allCommandSpecs'.
506 harnessUnknownFallback :: Text -> Maybe SlashCommand
507 harnessUnknownFallback t =
508 let lower = T.toLower t
509 in if "/harness" `T.isPrefixOf` lower
510 then let rest = T.strip (T.drop (T.length "/harness") lower)
511 sub = fst (T.break (== ' ') rest)
512 in Just (CmdHarness (HarnessUnknown sub))
513 else Nothing
514
515 -- ---------------------------------------------------------------------------
516 -- Execution
517 -- ---------------------------------------------------------------------------
518
519 -- | Execute a slash command. Returns the (possibly updated) context.
520 executeSlashCommand :: AgentEnv -> SlashCommand -> Context -> IO Context
521
522 executeSlashCommand env CmdHelp ctx = do
523 _ch_send (_env_channel env) (OutgoingMessage (renderHelpText allCommandSpecs))
524 pure ctx
525
526 executeSlashCommand env CmdNew ctx = do
527 _ch_send (_env_channel env) (OutgoingMessage "Session cleared. Starting fresh.")
528 pure (clearMessages ctx)
529
530 executeSlashCommand env CmdReset _ctx = do
531 _ch_send (_env_channel env) (OutgoingMessage "Full reset. Context and usage cleared.")
532 pure (emptyContext (contextSystemPrompt _ctx))
533
534 executeSlashCommand env CmdStatus ctx = do
535 model <- readIORef (_env_model env)
536 target <- readIORef (_env_target env)
537 mProvider <- readIORef (_env_provider env)
538 mVault <- readIORef (_env_vault env)
539 mTranscript <- readIORef (_env_transcript env)
540 harnesses <- readIORef (_env_harnesses env)
541 let targetLine = case target of
542 TargetProvider -> " Target: model: " <> unModelId model
543 TargetHarness name -> " Target: harness: " <> name
544 providerLine = case mProvider of
545 Nothing -> " Provider: (not configured)"
546 Just _ -> " Provider: configured"
547 vaultLine = case mVault of
548 Nothing -> " Vault: (not configured)"
549 Just _ -> " Vault: configured"
550 transcriptLine = case mTranscript of
551 Nothing -> " Transcript: disabled"
552 Just _ -> " Transcript: enabled"
553 harnessLine = if Map.null harnesses
554 then " Harnesses: (none)"
555 else " Harnesses: " <> T.intercalate ", "
556 [n <> " (" <> _hh_name h <> ")" | (n, h) <- Map.toList harnesses]
557 policyLine = " Policy: " <> T.pack (show (_sp_autonomy (_env_policy env)))
558 status = T.intercalate "\n"
559 [ "Session status:"
560 , targetLine
561 , providerLine
562 , policyLine
563 , vaultLine
564 , transcriptLine
565 , harnessLine
566 , ""
567 , " Messages: " <> T.pack (show (contextMessageCount ctx))
568 , " Est. context tokens: " <> T.pack (show (contextTokenEstimate ctx))
569 , " Total input tokens: " <> T.pack (show (contextTotalInputTokens ctx))
570 , " Total output tokens: " <> T.pack (show (contextTotalOutputTokens ctx))
571 ]
572 _ch_send (_env_channel env) (OutgoingMessage status)
573 pure ctx
574
575 executeSlashCommand env (CmdTarget Nothing) ctx = do
576 target <- readIORef (_env_target env)
577 model <- readIORef (_env_model env)
578 let desc = case target of
579 TargetProvider -> "model: " <> unModelId model
580 TargetHarness name -> "harness: " <> name
581 _ch_send (_env_channel env) (OutgoingMessage ("Current target: " <> desc))
582 pure ctx
583
584 executeSlashCommand env (CmdTarget (Just name)) ctx = do
585 let send = _ch_send (_env_channel env) . OutgoingMessage
586 harnesses <- readIORef (_env_harnesses env)
587 if Map.member name harnesses
588 then do
589 writeIORef (_env_target env) (TargetHarness name)
590 send $ "Target switched to harness: " <> name
591 else do
592 writeIORef (_env_target env) TargetProvider
593 writeIORef (_env_model env) (ModelId name)
594 -- Persist to config.toml
595 pureclawDir <- getPureclawDir
596 let configPath = pureclawDir </> "config.toml"
597 existing <- loadFileConfig configPath
598 Dir.createDirectoryIfMissing True pureclawDir
599 writeFileConfig configPath (existing { _fc_model = Just name })
600 send $ "Target switched to model: " <> name
601 pure ctx
602
603 executeSlashCommand env CmdTargetList ctx = do
604 let send = _ch_send (_env_channel env) . OutgoingMessage
605 -- List running harnesses
606 harnesses <- readIORef (_env_harnesses env)
607 let harnessLines = if Map.null harnesses
608 then [" (none running)"]
609 else map (" " <>) (Map.keys harnesses)
610 -- List models from provider
611 mProvider <- readIORef (_env_provider env)
612 modelLines <- case mProvider of
613 Nothing -> pure [" (no provider configured)"]
614 Just provider -> do
615 models <- listModels provider
616 pure $ if null models
617 then [" (none available)"]
618 else map (\m -> " " <> unModelId m) models
619 send $ T.intercalate "\n" $
620 ["Harnesses:"] ++ harnessLines ++ ["", "Models:"] ++ modelLines
621 pure ctx
622
623 executeSlashCommand env CmdCompact ctx = do
624 mProvider <- readIORef (_env_provider env)
625 case mProvider of
626 Nothing -> do
627 _ch_send (_env_channel env) (OutgoingMessage "Cannot compact: no provider configured.")
628 pure ctx
629 Just provider -> do
630 model <- readIORef (_env_model env)
631 (ctx', result) <- compactContext
632 provider
633 model
634 0
635 defaultKeepRecent
636 ctx
637 let msg = case result of
638 NotNeeded -> "Nothing to compact (too few messages)."
639 Compacted o n -> "Compacted: " <> T.pack (show o)
640 <> " messages \x2192 " <> T.pack (show n)
641 CompactionError e -> "Compaction failed: " <> e
642 _ch_send (_env_channel env) (OutgoingMessage msg)
643 pure ctx'
644
645 executeSlashCommand env (CmdProvider sub) ctx = do
646 vaultOpt <- readIORef (_env_vault env)
647 case vaultOpt of
648 Nothing -> do
649 _ch_send (_env_channel env) (OutgoingMessage
650 "Vault not configured. Run /vault setup first to store provider credentials.")
651 pure ctx
652 Just vault ->
653 executeProviderCommand env vault sub ctx
654
655 executeSlashCommand env (CmdChannel sub) ctx = do
656 executeChannelCommand env sub ctx
657
658 executeSlashCommand env (CmdTranscript sub) ctx = do
659 executeTranscriptCommand env sub ctx
660
661 executeSlashCommand env (CmdMsg target body) ctx = do
662 let send = _ch_send (_env_channel env) . OutgoingMessage
663 harnesses <- readIORef (_env_harnesses env)
664 case Map.lookup target harnesses of
665 Nothing -> do
666 send ("No running harness named '" <> target
667 <> "'. Use /harness list to see running harnesses.")
668 pure ctx
669 Just hh -> do
670 _lh_logInfo (_env_logger env) $ "Msg to harness: " <> target
671 _hh_send hh (TE.encodeUtf8 body)
672 output <- _hh_receive hh
673 let response = sanitizeHarnessOutput (TE.decodeUtf8 output)
674 unless (T.null (T.strip response)) $
675 send (prefixHarnessOutput target response)
676 pure ctx
677
678 executeSlashCommand env (CmdHarness sub) ctx = do
679 executeHarnessCommand env sub ctx
680
681 executeSlashCommand env (CmdAgent sub) ctx = do
682 executeAgentCommand env sub ctx
683
684 executeSlashCommand env (CmdVault sub) ctx = do
685 vaultOpt <- readIORef (_env_vault env)
686 case sub of
687 VaultSetup -> do
688 executeVaultSetup env ctx
689 _ -> case vaultOpt of
690 Nothing -> do
691 _ch_send (_env_channel env) (OutgoingMessage
692 "No vault configured. Run /vault setup to create one.")
693 pure ctx
694 Just vault ->
695 executeVaultCommand env vault sub ctx
696
697 -- ---------------------------------------------------------------------------
698 -- Provider subcommand execution
699 -- ---------------------------------------------------------------------------
700
701 -- | Supported provider names and their descriptions.
702 supportedProviders :: [(Text, Text)]
703 supportedProviders =
704 [ ("anthropic", "Anthropic (Claude)")
705 , ("openai", "OpenAI (GPT)")
706 , ("openrouter", "OpenRouter (multi-model gateway)")
707 , ("ollama", "Ollama (local models)")
708 ]
709
710 executeProviderCommand :: AgentEnv -> VaultHandle -> ProviderSubCommand -> Context -> IO Context
711 executeProviderCommand env _vault ProviderList ctx = do
712 let send = _ch_send (_env_channel env) . OutgoingMessage
713 mProvider <- readIORef (_env_provider env)
714 model <- readIORef (_env_model env)
715 let activeIndicator = case mProvider of
716 Nothing -> "(not configured)"
717 Just _ -> "active, model: " <> unModelId model
718 listing = T.intercalate "\n" $
719 [ "Provider: " <> activeIndicator
720 , ""
721 , "Available providers:"
722 ]
723 ++ [ " " <> name <> " \x2014 " <> desc | (name, desc) <- supportedProviders ]
724 ++ ["", "Usage: /provider <name>"]
725 send listing
726 pure ctx
727
728 executeProviderCommand env vault (ProviderConfigure providerName) ctx = do
729 let ch = _env_channel env
730 send = _ch_send ch . OutgoingMessage
731 lowerName = T.toLower (T.strip providerName)
732
733 case lowerName of
734 "anthropic" -> do
735 let options = anthropicAuthOptions env vault
736 optionLines = map (\o -> " [" <> T.pack (show (_ao_number o)) <> "] " <> _ao_name o) options
737 menu = T.intercalate "\n" ("Configure Anthropic provider. Choose auth method:" : optionLines)
738 send menu
739
740 choice <- _ch_prompt ch "Choice: "
741 let selectedOption = Data.Maybe.listToMaybe [o | o <- options, T.pack (show (_ao_number o)) == T.strip choice]
742
743 case selectedOption of
744 Just opt -> _ao_handler opt env vault ctx
745 Nothing -> do
746 send $ "Invalid choice. Please enter 1 to " <> T.pack (show (length options)) <> "."
747 pure ctx
748
749 "ollama" -> handleOllamaConfigure env vault ctx
750
751 _ -> do
752 send $ "Unknown provider: " <> providerName
753 send $ "Supported providers: " <> T.intercalate ", " (map fst supportedProviders)
754 pure ctx
755
756 -- | Auth method options for a provider.
757 data AuthOption = AuthOption
758 { _ao_number :: Int
759 , _ao_name :: Text
760 , _ao_handler :: AgentEnv -> VaultHandle -> Context -> IO Context
761 }
762
763 -- | Available Anthropic auth methods.
764 anthropicAuthOptions :: AgentEnv -> VaultHandle -> [AuthOption]
765 anthropicAuthOptions env vault =
766 [ AuthOption 1 "API Key"
767 (\_ _ ctx -> handleAnthropicApiKey env vault ctx)
768 , AuthOption 2 "OAuth 2.0"
769 (\_ _ ctx -> handleAnthropicOAuth env vault ctx)
770 ]
771
772 -- | Handle Anthropic API Key authentication.
773 handleAnthropicApiKey :: AgentEnv -> VaultHandle -> Context -> IO Context
774 handleAnthropicApiKey env vault ctx = do
775 let ch = _env_channel env
776 send = _ch_send ch . OutgoingMessage
777 apiKeyText <- _ch_promptSecret ch "Anthropic API key: "
778 result <- _vh_put vault "ANTHROPIC_API_KEY" (TE.encodeUtf8 apiKeyText)
779 case result of
780 Left err -> do
781 send ("Error storing API key: " <> T.pack (show err))
782 pure ctx
783 Right () -> do
784 send "Anthropic API key configured successfully."
785 pure ctx
786
787 -- | Handle Anthropic OAuth authentication.
788 handleAnthropicOAuth :: AgentEnv -> VaultHandle -> Context -> IO Context
789 handleAnthropicOAuth env vault ctx = do
790 let ch = _env_channel env
791 send = _ch_send ch . OutgoingMessage
792 send "Starting OAuth flow... (opens browser)"
793 manager <- HTTP.newTlsManager
794 oauthTokens <- runOAuthFlow defaultOAuthConfig manager
795 result <- _vh_put vault "ANTHROPIC_OAUTH_TOKENS" (serializeTokens oauthTokens)
796 case result of
797 Left err -> do
798 send ("Error storing OAuth tokens: " <> T.pack (show err))
799 pure ctx
800 Right () -> do
801 send "Anthropic OAuth configured successfully."
802 send "Tokens cached in vault and will be auto-refreshed."
803 pure ctx
804
805 -- | Handle Ollama provider configuration.
806 -- Prompts for base URL (default: http://localhost:11434) and model name.
807 -- Stores provider, model, and base_url in config.toml (not the vault,
808 -- since none of these are sensitive credentials).
809 handleOllamaConfigure :: AgentEnv -> VaultHandle -> Context -> IO Context
810 handleOllamaConfigure env _vault ctx = do
811 let ch = _env_channel env
812 send = _ch_send ch . OutgoingMessage
813 urlInput <- _ch_prompt ch "Ollama base URL (default: http://localhost:11434): "
814 let baseUrl = let stripped = T.strip urlInput
815 in if T.null stripped then "http://localhost:11434" else stripped
816 modelName <- _ch_prompt ch "Model name (e.g. llama3, mistral): "
817 let model = T.strip modelName
818 if T.null model
819 then do
820 send "Model name is required."
821 pure ctx
822 else do
823 pureclawDir <- getPureclawDir
824 let configPath = pureclawDir </> "config.toml"
825 existing <- loadFileConfig configPath
826 let updated = existing
827 { _fc_provider = Just "ollama"
828 , _fc_model = Just model
829 , _fc_baseUrl = if baseUrl == "http://localhost:11434"
830 then Nothing -- don't store the default
831 else Just baseUrl
832 }
833 Dir.createDirectoryIfMissing True pureclawDir
834 writeFileConfig configPath updated
835 -- Hot-swap provider and model in the running session
836 manager <- HTTP.newTlsManager
837 let ollamaProvider = if baseUrl == "http://localhost:11434"
838 then mkOllamaProvider manager
839 else mkOllamaProviderWithUrl manager (T.unpack baseUrl)
840 writeIORef (_env_provider env) (Just (MkProvider ollamaProvider))
841 writeIORef (_env_model env) (ModelId model)
842 send $ "Ollama configured successfully. Model: " <> model <> ", URL: " <> baseUrl
843 pure ctx
844
845 -- ---------------------------------------------------------------------------
846 -- Vault subcommand execution
847 -- ---------------------------------------------------------------------------
848
849 executeVaultCommand :: AgentEnv -> VaultHandle -> VaultSubCommand -> Context -> IO Context
850 executeVaultCommand env vault sub ctx = do
851 let ch = _env_channel env
852 send = _ch_send ch . OutgoingMessage
853 case sub of
854 VaultSetup ->
855 -- VaultSetup is handled before dispatch; should not reach here.
856 send "Use /vault setup to set up or rekey the vault."
857 >> pure ctx
858
859 VaultAdd name -> do
860 valueResult <- try @IOError (_ch_promptSecret ch ("Value for '" <> name <> "': "))
861 case valueResult of
862 Left e ->
863 send ("Error reading secret: " <> T.pack (show e))
864 Right value -> do
865 result <- _vh_put vault name (TE.encodeUtf8 value)
866 case result of
867 Left err -> send ("Error storing secret: " <> T.pack (show err))
868 Right () -> send ("Secret '" <> name <> "' stored.")
869 pure ctx
870
871 VaultList -> do
872 result <- _vh_list vault
873 case result of
874 Left err -> send ("Error: " <> T.pack (show err))
875 Right [] -> send "Vault is empty."
876 Right names ->
877 send ("Secrets:\n" <> T.unlines (map (" \x2022 " <>) names))
878 pure ctx
879
880 VaultDelete name -> do
881 confirm <- _ch_prompt ch ("Delete secret '" <> name <> "'? [y/N]: ")
882 if T.strip confirm == "y" || T.strip confirm == "Y"
883 then do
884 result <- _vh_delete vault name
885 case result of
886 Left err -> send ("Error: " <> T.pack (show err))
887 Right () -> send ("Secret '" <> name <> "' deleted.")
888 else send "Cancelled."
889 pure ctx
890
891 VaultLock -> do
892 _vh_lock vault
893 send "Vault locked."
894 pure ctx
895
896 VaultUnlock -> do
897 result <- _vh_unlock vault
898 case result of
899 Left err -> send ("Error unlocking vault: " <> T.pack (show err))
900 Right () -> send "Vault unlocked."
901 pure ctx
902
903 VaultStatus' -> do
904 status <- _vh_status vault
905 let lockedText = if _vs_locked status then "Locked" else "Unlocked"
906 msg = T.intercalate "\n"
907 [ "Vault status:"
908 , " State: " <> lockedText
909 , " Secrets: " <> T.pack (show (_vs_secretCount status))
910 , " Key: " <> _vs_keyType status
911 ]
912 send msg
913 pure ctx
914
915 VaultUnknown unknownSub
916 | T.null unknownSub -> do
917 -- Bare /vault: show status + available subcommands
918 mVault <- readIORef (_env_vault env)
919 let vaultStatus = case mVault of
920 Nothing -> "Vault: not configured"
921 Just _ -> "Vault: configured"
922 subcommands = T.intercalate "\n"
923 [ vaultStatus
924 , ""
925 , "Available commands:"
926 , " /vault setup — Set up or rekey the vault"
927 , " /vault add <name> — Store a named secret"
928 , " /vault list — List stored secret names"
929 , " /vault delete <name> — Delete a secret"
930 , " /vault lock — Lock the vault"
931 , " /vault unlock — Unlock the vault"
932 , " /vault status — Show vault state and key type"
933 ]
934 send subcommands
935 pure ctx
936 | otherwise ->
937 send ("Unknown vault command: " <> unknownSub <> ". Type /vault to see available commands.")
938 >> pure ctx
939
940 -- ---------------------------------------------------------------------------
941 -- Vault setup wizard
942 -- ---------------------------------------------------------------------------
943
944 -- | Interactive vault setup wizard. Detects auth mechanisms, lets the user
945 -- choose, then creates or rekeys the vault.
946 executeVaultSetup :: AgentEnv -> Context -> IO Context
947 executeVaultSetup env ctx = do
948 let ch = _env_channel env
949 send = _ch_send ch . OutgoingMessage
950 ph = _env_pluginHandle env
951
952 -- Step 1: Detect available plugins
953 plugins <- _ph_detect ph
954
955 -- Step 2: Build choice menu
956 let options = buildSetupOptions plugins
957 menu = formatSetupMenu options
958 send menu
959
960 -- Step 3: Read user's choice
961 choiceText <- _ch_prompt ch "Choice: "
962 case parseChoice (length options) (T.strip choiceText) of
963 Nothing -> do
964 send "Invalid choice. Setup cancelled."
965 pure ctx
966 Just idx -> do
967 let chosen = snd (options !! idx)
968 -- Step 4: Create encryptor based on choice
969 encResult <- createEncryptorForChoice ch ph chosen
970 case encResult of
971 Left err -> do
972 send err
973 pure ctx
974 Right (newEnc, keyLabel, mRecipient, mIdentity) -> do
975 -- Step 5: Init or rekey
976 vaultOpt <- readIORef (_env_vault env)
977 case vaultOpt of
978 Nothing -> do
979 -- No vault handle at all: create from scratch
980 setupResult <- firstTimeSetup env newEnc keyLabel
981 case setupResult of
982 Left err -> send err
983 Right () -> do
984 send ("Vault created with " <> keyLabel <> " encryption.")
985 updateConfigAfterSetup mRecipient mIdentity keyLabel
986 Just vault -> do
987 -- Vault handle exists — but the file may not.
988 -- Try init: if it succeeds, this is first-time setup.
989 -- If VaultAlreadyExists, we need to rekey.
990 initResult <- _vh_init vault
991 case initResult of
992 Right () -> do
993 -- First-time init succeeded (file didn't exist)
994 send ("Vault created with " <> keyLabel <> " encryption.")
995 updateConfigAfterSetup mRecipient mIdentity keyLabel
996 Left VaultAlreadyExists -> do
997 -- Vault exists — rekey it
998 let confirmFn msg = do
999 send msg
1000 answer <- _ch_prompt ch "Proceed? [y/N]: "
1001 pure (T.strip answer == "y" || T.strip answer == "Y")
1002 rekeyResult <- _vh_rekey vault newEnc keyLabel confirmFn
1003 case rekeyResult of
1004 Left (VaultCorrupted "rekey cancelled by user") ->
1005 send "Rekey cancelled."
1006 Left err ->
1007 send ("Rekey failed: " <> T.pack (show err))
1008 Right () -> do
1009 send ("Vault rekeyed to " <> keyLabel <> ".")
1010 updateConfigAfterSetup mRecipient mIdentity keyLabel
1011 Left err ->
1012 send ("Vault init failed: " <> T.pack (show err))
1013 pure ctx
1014
1015 -- | A setup option: either passphrase or a detected plugin.
1016 data SetupOption
1017 = SetupPassphrase
1018 | SetupPlugin AgePlugin
1019 deriving stock (Show, Eq)
1020
1021 -- | Build the list of available setup options.
1022 -- Passphrase is always first.
1023 buildSetupOptions :: [AgePlugin] -> [(Text, SetupOption)]
1024 buildSetupOptions plugins =
1025 ("Passphrase", SetupPassphrase)
1026 : [(labelFor p, SetupPlugin p) | p <- plugins]
1027 where
1028 labelFor p = _ap_label p <> " (" <> _ap_name p <> ")"
1029
1030 -- | Format the setup menu for display.
1031 formatSetupMenu :: [(Text, SetupOption)] -> Text
1032 formatSetupMenu options =
1033 T.intercalate "\n" $
1034 "Choose your vault authentication method:"
1035 : [T.pack (show i) <> ". " <> label | (i, (label, _)) <- zip [(1::Int)..] options]
1036
1037 -- | Parse a numeric choice (1-based) to a 0-based index.
1038 parseChoice :: Int -> Text -> Maybe Int
1039 parseChoice maxN t =
1040 case reads (T.unpack t) of
1041 [(n, "")] | n >= 1 && n <= maxN -> Just (n - 1)
1042 _ -> Nothing
1043
1044 -- | Create an encryptor based on the user's setup choice.
1045 -- Returns (encryptor, key label, maybe recipient, maybe identity path).
1046 createEncryptorForChoice
1047 :: ChannelHandle
1048 -> PluginHandle
1049 -> SetupOption
1050 -> IO (Either Text (VaultEncryptor, Text, Maybe Text, Maybe Text))
1051 createEncryptorForChoice ch _ph SetupPassphrase = do
1052 passResult <- try @IOError (_ch_promptSecret ch "Passphrase: ")
1053 case passResult of
1054 Left e ->
1055 pure (Left ("Error reading passphrase: " <> T.pack (show e)))
1056 Right passphrase -> do
1057 enc <- mkPassphraseVaultEncryptor (pure (TE.encodeUtf8 passphrase))
1058 pure (Right (enc, "passphrase", Nothing, Nothing))
1059 createEncryptorForChoice ch _ph (SetupPlugin plugin) = do
1060 pureclawDir <- getPureclawDir
1061 let vaultDir = pureclawDir </> "vault"
1062 identityFile = vaultDir </> T.unpack (_ap_name plugin) <> "-identity.txt"
1063 identityFileT = T.pack identityFile
1064 cmd = T.pack (_ap_binary plugin) <> " --generate --pin-policy never --touch-policy never > " <> identityFileT
1065 Dir.createDirectoryIfMissing True vaultDir
1066 _ch_send ch (OutgoingMessage (T.intercalate "\n"
1067 [ "Run this in another terminal to generate a " <> _ap_label plugin <> " identity:"
1068 , ""
1069 , " " <> cmd
1070 , ""
1071 , "The plugin will prompt you for a PIN and touch confirmation."
1072 , "Press Enter here when done (or 'q' to cancel)."
1073 ]))
1074 answer <- T.strip <$> _ch_prompt ch ""
1075 if answer == "q" || answer == "Q"
1076 then pure (Left "Setup cancelled.")
1077 else do
1078 exists <- Dir.doesFileExist identityFile
1079 if not exists
1080 then pure (Left ("Identity file not found: " <> identityFileT))
1081 else do
1082 contents <- TIO.readFile identityFile
1083 let outputLines = T.lines contents
1084 -- age-plugin-yubikey uses "# Recipient: age1..."
1085 -- other plugins may use "# public key: age1..."
1086 findRecipient = L.find (\l ->
1087 let stripped = T.strip (T.dropWhile (== '#') (T.strip l))
1088 in T.isPrefixOf "Recipient:" stripped
1089 || T.isPrefixOf "public key:" stripped) outputLines
1090 case findRecipient of
1091 Nothing ->
1092 pure (Left "No recipient found in identity file. Expected a '# Recipient: age1...' line.")
1093 Just rLine -> do
1094 -- Extract value after the label (Recipient: or public key:)
1095 let afterHash = T.strip (T.dropWhile (== '#') (T.strip rLine))
1096 recipient = T.strip (T.drop 1 (T.dropWhile (/= ':') afterHash))
1097 ageResult <- mkAgeEncryptor
1098 case ageResult of
1099 Left err ->
1100 pure (Left ("age error: " <> T.pack (show err)))
1101 Right ageEnc -> do
1102 let enc = ageVaultEncryptor ageEnc recipient identityFileT
1103 pure (Right (enc, _ap_label plugin, Just recipient, Just identityFileT))
1104
1105 -- | First-time vault setup: create directory, open vault, init, write to IORef.
1106 firstTimeSetup :: AgentEnv -> VaultEncryptor -> Text -> IO (Either Text ())
1107 firstTimeSetup env enc keyLabel = do
1108 pureclawDir <- getPureclawDir
1109 let vaultDir = pureclawDir </> "vault"
1110 Dir.createDirectoryIfMissing True vaultDir
1111 let vaultPath = vaultDir </> "vault.age"
1112 cfg = VaultConfig
1113 { _vc_path = vaultPath
1114 , _vc_keyType = keyLabel
1115 , _vc_unlock = UnlockOnDemand
1116 }
1117 vault <- openVault cfg enc
1118 initResult <- _vh_init vault
1119 case initResult of
1120 Left VaultAlreadyExists ->
1121 pure (Left "A vault file already exists. Use /vault setup to rekey.")
1122 Left err ->
1123 pure (Left ("Vault creation failed: " <> T.pack (show err)))
1124 Right () -> do
1125 writeIORef (_env_vault env) (Just vault)
1126 pure (Right ())
1127
1128 -- | Update the config file after a successful setup/rekey.
1129 updateConfigAfterSetup :: Maybe Text -> Maybe Text -> Text -> IO ()
1130 updateConfigAfterSetup mRecipient mIdentity _keyLabel = do
1131 pureclawDir <- getPureclawDir
1132 Dir.createDirectoryIfMissing True pureclawDir
1133 let configPath = pureclawDir </> "config.toml"
1134 vaultPath = Set (T.pack (pureclawDir </> "vault" </> "vault.age"))
1135 unlockMode = Set "on_demand"
1136 recipientUpd = maybe Clear Set mRecipient
1137 identityUpd = maybe Clear Set mIdentity
1138 updateVaultConfig configPath vaultPath recipientUpd identityUpd unlockMode
1139
1140 -- ---------------------------------------------------------------------------
1141 -- Channel subcommand execution
1142 -- ---------------------------------------------------------------------------
1143
1144 executeChannelCommand :: AgentEnv -> ChannelSubCommand -> Context -> IO Context
1145 executeChannelCommand env ChannelList ctx = do
1146 let send = _ch_send (_env_channel env) . OutgoingMessage
1147 -- Read current config to show status
1148 fileCfg <- loadConfig
1149 let currentChannel = maybe "cli" T.unpack (_fc_defaultChannel fileCfg)
1150 signalConfigured = case _fc_signal fileCfg of
1151 Just sig -> case _fsc_account sig of
1152 Just acct -> " (account: " <> acct <> ")"
1153 Nothing -> " (not configured)"
1154 Nothing -> " (not configured)"
1155 send $ T.intercalate "\n"
1156 [ "Chat channels:"
1157 , ""
1158 , " cli \x2014 Terminal stdin/stdout" <> if currentChannel == "cli" then " [active]" else ""
1159 , " signal \x2014 Signal messenger" <> signalConfigured <> if currentChannel == "signal" then " [active]" else ""
1160 , " telegram \x2014 Telegram bot (coming soon)"
1161 , ""
1162 , "Set up a channel: /channel signal"
1163 , "Switch channel: Set default_channel in config, then restart"
1164 ]
1165 pure ctx
1166
1167 executeChannelCommand env (ChannelSetup channelName) ctx = do
1168 let send = _ch_send (_env_channel env) . OutgoingMessage
1169 case channelName of
1170 "signal" -> executeSignalSetup env ctx
1171 "telegram" -> do
1172 send "Telegram setup is not yet implemented. Coming soon!"
1173 pure ctx
1174 other -> do
1175 send $ "Unknown channel: " <> other <> ". Available: signal, telegram"
1176 pure ctx
1177
1178 executeChannelCommand env (ChannelUnknown sub) ctx = do
1179 _ch_send (_env_channel env) (OutgoingMessage
1180 ("Unknown channel command: " <> sub <> ". Type /channel for available options."))
1181 pure ctx
1182
1183 -- ---------------------------------------------------------------------------
1184 -- Transcript subcommand execution
1185 -- ---------------------------------------------------------------------------
1186
1187 executeTranscriptCommand :: AgentEnv -> TranscriptSubCommand -> Context -> IO Context
1188 executeTranscriptCommand env sub ctx = do
1189 let send = _ch_send (_env_channel env) . OutgoingMessage
1190 mTh <- readIORef (_env_transcript env)
1191 case mTh of
1192 Nothing -> do
1193 send "No transcript configured. Start with --transcript to enable logging."
1194 pure ctx
1195 Just th -> case sub of
1196 TranscriptRecent mN -> do
1197 let n = Data.Maybe.fromMaybe 20 mN
1198 tf = emptyFilter { _tf_limit = Just n }
1199 entries <- _th_query th tf
1200 if null entries
1201 then send "No entries found."
1202 else send (T.intercalate "\n" (map formatEntry entries))
1203 pure ctx
1204
1205 TranscriptSearch query -> do
1206 -- Search matches either harness or model name
1207 allEntries <- _th_query th emptyFilter
1208 let matches e = _te_harness e == Just query || _te_model e == Just query
1209 entries = filter matches allEntries
1210 if null entries
1211 then send ("No entries found matching: " <> query)
1212 else send (T.intercalate "\n" (map formatEntry entries))
1213 pure ctx
1214
1215 TranscriptPath -> do
1216 path <- _th_getPath th
1217 send (T.pack path)
1218 pure ctx
1219
1220 TranscriptUnknown subcmd -> do
1221 send ("Unknown transcript command: " <> subcmd <> ". Try /help for available commands.")
1222 pure ctx
1223
1224 -- | Format a transcript entry as a one-line summary.
1225 -- Example: "[2026-04-04T15:30:00Z] ollama/llama3 Request (42ms)"
1226 formatEntry :: TranscriptEntry -> Text
1227 formatEntry entry =
1228 let ts = T.pack (show (_te_timestamp entry))
1229 endpoint = case (_te_harness entry, _te_model entry) of
1230 (Just h, Just m) -> h <> "/" <> m
1231 (Just h, Nothing) -> h
1232 (Nothing, Just m) -> m
1233 (Nothing, Nothing) -> "unknown"
1234 dir = T.pack (show (_te_direction entry))
1235 dur = case _te_durationMs entry of
1236 Just ms -> " (" <> T.pack (show ms) <> "ms)"
1237 Nothing -> ""
1238 in "[" <> ts <> "] " <> endpoint <> " " <> dir <> dur
1239
1240 -- ---------------------------------------------------------------------------
1241 -- Harness commands
1242 -- ---------------------------------------------------------------------------
1243
1244 executeHarnessCommand :: AgentEnv -> HarnessSubCommand -> Context -> IO Context
1245 executeHarnessCommand env sub ctx = do
1246 let send = _ch_send (_env_channel env) . OutgoingMessage
1247 case sub of
1248 HarnessStart name mDir skipPerms -> do
1249 mTh <- readIORef (_env_transcript env)
1250 let th = Data.Maybe.fromMaybe mkNoOpTranscriptHandle mTh
1251 logger = _env_logger env
1252 -- Log diagnostic info before attempting start
1253 let logInfo = _lh_logInfo logger
1254 logError = _lh_logError logger
1255 mTmuxPath <- findTmux
1256 logInfo $ "Harness start: tmux path = " <> T.pack (show mTmuxPath)
1257 mClaudePath <- Dir.findExecutable "claude"
1258 logInfo $ "Harness start: claude path = " <> T.pack (show mClaudePath)
1259 logInfo $ "Harness start: policy autonomy = " <> T.pack (show (_sp_autonomy (_env_policy env)))
1260 -- Resolve optional working directory
1261 resolvedDir <- resolveHarnessDir mDir
1262 -- Assign a window index and build the unique harness key
1263 windowIdx <- readIORef (_env_nextWindowIdx env)
1264 let canonical = Data.Maybe.fromMaybe name (resolveHarnessName name)
1265 harnessKey = canonical <> "-" <> T.pack (show windowIdx)
1266 result <- startHarnessByName (_env_policy env) th windowIdx name resolvedDir skipPerms
1267 case result of
1268 Left err -> do
1269 let detail = case err of
1270 HarnessTmuxNotAvailable tmuxDetail ->
1271 tmuxDetail <> "\n tmux path resolved: " <> T.pack (show mTmuxPath)
1272 HarnessBinaryNotFound bin ->
1273 "binary '" <> bin <> "' not found on PATH"
1274 <> "\n claude path resolved: " <> T.pack (show mClaudePath)
1275 HarnessNotAuthorized cmdErr ->
1276 "command not authorized: " <> T.pack (show cmdErr)
1277 <> "\n policy autonomy: " <> T.pack (show (_sp_autonomy (_env_policy env)))
1278 send ("Failed to start harness '" <> name <> "':\n " <> detail)
1279 logError $ "Harness start failed: " <> T.pack (show err)
1280 pure ctx
1281 Right hh -> do
1282 -- Label the tmux window so discovery can reconstruct on restart
1283 renameWindow "pureclaw" windowIdx harnessKey
1284 modifyIORef' (_env_nextWindowIdx env) (+ 1)
1285 modifyIORef' (_env_harnesses env) (Map.insert harnessKey hh)
1286 send ("Harness '" <> harnessKey <> "' started (window " <> T.pack (show windowIdx) <> "). Attach with: tmux attach -t pureclaw")
1287 pure ctx
1288
1289 HarnessStop name -> do
1290 harnesses <- readIORef (_env_harnesses env)
1291 case Map.lookup name harnesses of
1292 Nothing -> do
1293 send ("No running harness named '" <> name <> "'.")
1294 pure ctx
1295 Just hh -> do
1296 _hh_stop hh
1297 modifyIORef' (_env_harnesses env) (Map.delete name)
1298 send ("Harness '" <> name <> "' stopped.")
1299 pure ctx
1300
1301 HarnessList -> do
1302 harnesses <- readIORef (_env_harnesses env)
1303 let running = if Map.null harnesses
1304 then [" (none)"]
1305 else map (\(n, hh) -> " " <> n <> " (" <> _hh_name hh <> ")")
1306 (Map.toList harnesses)
1307 available = map (\(n, aliases, desc) ->
1308 " " <> n <> " (aliases: " <> T.intercalate ", " aliases <> ") — " <> desc)
1309 knownHarnesses
1310 send (T.intercalate "\n" $
1311 ["Running:"] <> running <> ["", "Available:"] <> available)
1312 pure ctx
1313
1314 HarnessAttach -> do
1315 send "tmux attach -t pureclaw"
1316 pure ctx
1317
1318 HarnessUnknown subcmd
1319 | T.null subcmd -> do
1320 -- Bare /harness: show status + available subcommands
1321 harnesses <- readIORef (_env_harnesses env)
1322 let runningSection = if Map.null harnesses
1323 then [" (none running)"]
1324 else map (\(n, hh) -> " " <> n <> " (" <> _hh_name hh <> ")")
1325 (Map.toList harnesses)
1326 availSection = map (\(n, aliases, desc) ->
1327 " " <> n <> " (aliases: " <> T.intercalate ", " aliases <> ") — " <> desc)
1328 knownHarnesses
1329 output = T.intercalate "\n" $
1330 ["Running:"] <> runningSection <>
1331 ["", "Available:"] <> availSection <>
1332 ["", "Commands:"
1333 , " /harness start <name> [dir] [--unsafe]"
1334 , " /harness stop <name> — Stop a harness"
1335 , " /harness list — List harnesses"
1336 , " /harness attach — Show tmux attach command"
1337 ]
1338 send output
1339 pure ctx
1340 | otherwise -> do
1341 send ("Unknown harness command: " <> subcmd <> ". Type /harness to see available commands.")
1342 pure ctx
1343
1344 -- ---------------------------------------------------------------------------
1345 -- Agent subcommand execution
1346 -- ---------------------------------------------------------------------------
1347
1348 -- | Directory that holds per-agent bootstrap subdirectories.
1349 -- Derives from 'getPureclawDir' so it honours @HOME@ in tests.
1350 getAgentsDir :: IO FilePath
1351 getAgentsDir = do
1352 pureclawDir <- getPureclawDir
1353 pure (pureclawDir </> "agents")
1354
1355 -- | Execute a '/agent' subcommand. In WU1 the environment does not yet
1356 -- carry a currently-selected agent, so '/agent info' without an argument
1357 -- always reports that no agent is selected, and '/agent start' returns a
1358 -- placeholder message pending session support in WU2.
1359 executeAgentCommand :: AgentEnv -> AgentSubCommand -> Context -> IO Context
1360 executeAgentCommand env sub ctx = do
1361 let send = _ch_send (_env_channel env) . OutgoingMessage
1362 lg = _env_logger env
1363 case sub of
1364 AgentList -> do
1365 agentsDir <- getAgentsDir
1366 defs <- AgentDef.discoverAgents lg agentsDir
1367 if null defs
1368 then do
1369 send "No agents found. Create one at ~/.pureclaw/agents/<name>/"
1370 pure ctx
1371 else do
1372 let names = [AgentDef.unAgentName (AgentDef._ad_name d) | d <- defs]
1373 send (T.intercalate "\n"
1374 ("Agents:" : map (" " <>) (L.sort names)))
1375 pure ctx
1376
1377 AgentInfo Nothing -> do
1378 send "No agent selected. Use --agent <name>."
1379 pure ctx
1380
1381 AgentInfo (Just name) -> do
1382 agentsDir <- getAgentsDir
1383 case AgentDef.mkAgentName name of
1384 Left _ -> do
1385 send ("Agent \"" <> name <> "\" not found. invalid agent name.")
1386 pure ctx
1387 Right validName -> do
1388 mDef <- AgentDef.loadAgent agentsDir validName
1389 case mDef of
1390 Nothing -> do
1391 defs <- AgentDef.discoverAgents lg agentsDir
1392 let names = L.sort
1393 [AgentDef.unAgentName (AgentDef._ad_name d) | d <- defs]
1394 avail = if null names
1395 then "(none)"
1396 else T.intercalate ", " names
1397 send ("Agent \"" <> name <> "\" not found. Available agents: " <> avail)
1398 pure ctx
1399 Just def -> do
1400 files <- listAgentFiles (AgentDef._ad_dir def)
1401 let cfg = AgentDef._ad_config def
1402 cfgLines =
1403 [ " model: " <> fromMaybeT "(unset)" (AgentDef._ac_model cfg)
1404 , " tool_profile: " <> fromMaybeT "(unset)" (AgentDef._ac_toolProfile cfg)
1405 , " workspace: " <> fromMaybeT "(default)" (AgentDef._ac_workspace cfg)
1406 ]
1407 output = T.intercalate "\n" $
1408 [ "Agent: " <> AgentDef.unAgentName (AgentDef._ad_name def)
1409 , " dir: " <> T.pack (AgentDef._ad_dir def)
1410 , "Files:"
1411 ] <>
1412 (if null files
1413 then [" (none)"]
1414 else map (" " <>) files) <>
1415 [ "Config:" ] <> cfgLines
1416 send output
1417 pure ctx
1418
1419 AgentStart name -> do
1420 agentsDir <- getAgentsDir
1421 case AgentDef.mkAgentName name of
1422 Left _ -> do
1423 send ("invalid agent name: \"" <> name <> "\".")
1424 pure ctx
1425 Right validName -> do
1426 mDef <- AgentDef.loadAgent agentsDir validName
1427 case mDef of
1428 Nothing -> do
1429 send ("Agent \"" <> name <> "\" not found.")
1430 pure ctx
1431 Just _ -> do
1432 send "Agent start will be fully wired up in a later session (requires Session support)."
1433 pure ctx
1434
1435 AgentUnknown subcmd
1436 | T.null subcmd -> do
1437 send (T.intercalate "\n"
1438 [ "Agent commands:"
1439 , " /agent list"
1440 , " /agent info [<name>]"
1441 , " /agent start <name>"
1442 ])
1443 pure ctx
1444 | otherwise -> do
1445 send ("Unknown agent command: " <> subcmd <> ". Type /agent to see available commands.")
1446 pure ctx
1447
1448 -- | List the known bootstrap @.md@ files present in an agent directory, in
1449 -- the same order used by 'composeAgentPrompt'.
1450 listAgentFiles :: FilePath -> IO [Text]
1451 listAgentFiles dir = do
1452 let candidates =
1453 [ "SOUL.md", "USER.md", "AGENTS.md", "MEMORY.md"
1454 , "IDENTITY.md", "TOOLS.md", "BOOTSTRAP.md"
1455 ]
1456 present <- filterM (Dir.doesFileExist . (dir </>)) candidates
1457 pure (map T.pack present)
1458
1459 fromMaybeT :: Text -> Maybe Text -> Text
1460 fromMaybeT def Nothing = def
1461 fromMaybeT _ (Just t) = t
1462
1463 -- | Filter a list of agent names by a case-insensitive prefix. Exported as
1464 -- a pure helper so the tab completer can present matching names for
1465 -- @/agent info@ and @/agent start@ without needing IO. When the prefix is
1466 -- empty, all candidates are returned.
1467 agentNameMatches :: [Text] -> Text -> [Text]
1468 agentNameMatches candidates prefix =
1469 let lowerPfx = T.toLower prefix
1470 in filter (\c -> lowerPfx `T.isPrefixOf` T.toLower c) candidates
1471
1472 -- | Known harnesses: (canonical name, aliases, description).
1473 knownHarnesses :: [(Text, [Text], Text)]
1474 knownHarnesses =
1475 [ ("claude-code", ["claude", "cc"], "Anthropic Claude Code CLI")
1476 ]
1477
1478 -- | Start a harness by name or alias.
1479 startHarnessByName
1480 :: SecurityPolicy
1481 -> TranscriptHandle
1482 -> Int -- ^ tmux window index
1483 -> Text
1484 -> Maybe FilePath -- ^ optional working directory
1485 -> Bool -- ^ skip permission checks
1486 -> IO (Either HarnessError HarnessHandle)
1487 startHarnessByName policy th windowIdx name mWorkDir skipPerms =
1488 case resolveHarnessName name of
1489 Just "claude-code" ->
1490 let extraArgs = ["--dangerously-skip-permissions" | skipPerms]
1491 in mkClaudeCodeHarness policy th windowIdx mWorkDir extraArgs
1492 _ -> pure (Left (HarnessBinaryNotFound name))
1493
1494 -- | Resolve an optional directory argument for harness start.
1495 -- Relative paths are interpreted relative to @$HOME@; absolute paths are used as-is.
1496 resolveHarnessDir :: Maybe Text -> IO (Maybe FilePath)
1497 resolveHarnessDir Nothing = pure Nothing
1498 resolveHarnessDir (Just dir) = do
1499 let path = T.unpack dir
1500 if isAbsolutePath path
1501 then pure (Just path)
1502 else do
1503 home <- Dir.getHomeDirectory
1504 pure (Just (home </> path))
1505 where
1506 isAbsolutePath ('/':_) = True
1507 isAbsolutePath _ = False
1508
1509 -- | Resolve a name or alias to the canonical harness name.
1510 resolveHarnessName :: Text -> Maybe Text
1511 resolveHarnessName input =
1512 let lower = T.toLower input
1513 in case [canonical | (canonical, aliases, _) <- knownHarnesses
1514 , lower == canonical || lower `elem` aliases] of
1515 (c : _) -> Just c
1516 [] -> Nothing
1517
1518 -- ---------------------------------------------------------------------------
1519 -- Harness discovery
1520 -- ---------------------------------------------------------------------------
1521
1522 -- | Discover running harnesses by querying tmux window names.
1523 -- Returns the reconstructed harness map and the next window index to use.
1524 --
1525 -- Window names matching @\<canonical\>-\<N\>@ (e.g. @claude-code-0@) are
1526 -- recognised as harness windows. The handle is reconstructed so
1527 -- send\/receive\/stop work against the existing tmux window.
1528 discoverHarnesses
1529 :: TranscriptHandle
1530 -> IO (Map.Map Text HarnessHandle, Int)
1531 discoverHarnesses = discoverHarnessesIn "pureclaw"
1532
1533 -- | Like 'discoverHarnesses' but queries a specific tmux session name.
1534 -- Useful for testing with an isolated session.
1535 discoverHarnessesIn
1536 :: Text -- ^ tmux session name
1537 -> TranscriptHandle
1538 -> IO (Map.Map Text HarnessHandle, Int)
1539 discoverHarnessesIn session th = do
1540 windows <- listSessionWindows session
1541 let discovered =
1542 [ (name, idx, canonical)
1543 | (idx, name) <- windows
1544 , Just (canonical, winIdx) <- [parseHarnessWindowName name]
1545 , winIdx == idx -- sanity: name encodes the same index
1546 ]
1547 handles <- mapM (\(name, idx, canonical) -> do
1548 hh <- mkHandle canonical idx
1549 pure (name, hh)) discovered
1550 let harnessMap = Map.fromList handles
1551 nextIdx = if null discovered
1552 then 0
1553 else maximum [idx | (_, idx, _) <- discovered] + 1
1554 pure (harnessMap, nextIdx)
1555 where
1556 mkHandle :: Text -> Int -> IO HarnessHandle
1557 mkHandle canonical idx = case canonical of
1558 "claude-code" -> mkDiscoveredClaudeCodeHandle th idx
1559 -- Future harness types go here
1560 _ -> mkDiscoveredClaudeCodeHandle th idx -- fallback
1561
1562 -- | Parse a window name like "claude-code-0" into (canonical, index).
1563 parseHarnessWindowName :: Text -> Maybe (Text, Int)
1564 parseHarnessWindowName name =
1565 -- Try each known canonical name as a prefix
1566 let candidates =
1567 [ (canonical, T.drop (T.length canonical + 1) name)
1568 | (canonical, _, _) <- knownHarnesses
1569 , (canonical <> "-") `T.isPrefixOf` name
1570 ]
1571 in case candidates of
1572 [(canonical, suffix)] ->
1573 case TR.decimal suffix of
1574 Right (n, rest) | T.null rest -> Just (canonical, n)
1575 _ -> Nothing
1576 _ -> Nothing
1577
1578 -- ---------------------------------------------------------------------------
1579 -- Signal setup wizard
1580 -- ---------------------------------------------------------------------------
1581
1582 -- | Interactive Signal setup. Checks signal-cli, offers link or register,
1583 -- walks through the flow, writes config.
1584 executeSignalSetup :: AgentEnv -> Context -> IO Context
1585 executeSignalSetup env ctx = do
1586 let ch = _env_channel env
1587 send = _ch_send ch . OutgoingMessage
1588
1589 -- Step 1: Check signal-cli is installed
1590 signalCliCheck <- try @IOException $
1591 P.readProcess (P.proc "signal-cli" ["--version"])
1592 case signalCliCheck of
1593 Left _ -> do
1594 send $ T.intercalate "\n"
1595 [ "signal-cli is not installed."
1596 , ""
1597 , "Install it first:"
1598 , " macOS: brew install signal-cli"
1599 , " Nix: nix-env -i signal-cli"
1600 , " Other: https://github.com/AsamK/signal-cli"
1601 , ""
1602 , "Then run /channel signal again."
1603 ]
1604 pure ctx
1605 Right (exitCode, versionOut, _) -> do
1606 let version = T.strip (TE.decodeUtf8 (BL.toStrict versionOut))
1607 case exitCode of
1608 ExitSuccess ->
1609 send $ "Found signal-cli " <> version
1610 _ ->
1611 send "Found signal-cli (version unknown)"
1612
1613 -- Step 2: Offer link or register
1614 send $ T.intercalate "\n"
1615 [ ""
1616 , "How would you like to connect?"
1617 , " [1] Link to an existing Signal account (adds PureClaw as secondary device)"
1618 , " [2] Register with a phone number (becomes primary device for that number)"
1619 , ""
1620 , "Note: Option 2 will take over the number from any existing Signal registration."
1621 ]
1622
1623 choice <- T.strip <$> _ch_prompt ch "Choice [1]: "
1624 let effectiveChoice = if T.null choice then "1" else choice
1625
1626 case effectiveChoice of
1627 "1" -> signalLinkFlow env ctx
1628 "2" -> signalRegisterFlow env ctx
1629 _ -> do
1630 send "Invalid choice. Setup cancelled."
1631 pure ctx
1632
1633 -- | Link to an existing Signal account by scanning a QR code.
1634 -- signal-cli link outputs the sgnl:// URI, then blocks until the user
1635 -- scans it. We need to stream the output to show the URI immediately.
1636 signalLinkFlow :: AgentEnv -> Context -> IO Context
1637 signalLinkFlow env ctx = do
1638 let ch = _env_channel env
1639 send = _ch_send ch . OutgoingMessage
1640
1641 send "Generating link... (this may take a moment)"
1642
1643 let procConfig = P.setStdout P.createPipe
1644 $ P.setStderr P.createPipe
1645 $ P.proc "signal-cli" ["link", "-n", "PureClaw"]
1646 startResult <- try @IOException $ P.startProcess procConfig
1647 case startResult of
1648 Left err -> do
1649 send $ "Failed to start signal-cli: " <> T.pack (show err)
1650 pure ctx
1651 Right process -> do
1652 let stdoutH = P.getStdout process
1653 stderrH = P.getStderr process
1654 -- signal-cli outputs the URI to stderr, then blocks waiting for scan.
1655 -- Read stderr lines until we find the sgnl:// URI.
1656 linkUri <- readUntilLink stderrH stdoutH
1657 case linkUri of
1658 Nothing -> do
1659 -- Process may have exited with error
1660 exitCode <- P.waitExitCode process
1661 send $ "signal-cli link failed (exit " <> T.pack (show exitCode) <> ")"
1662 pure ctx
1663 Just uri -> do
1664 send $ T.intercalate "\n"
1665 [ "Open Signal on your phone:"
1666 , " Settings \x2192 Linked Devices \x2192 Link New Device"
1667 , ""
1668 , "Scan this link (or paste into a QR code generator):"
1669 , ""
1670 , " " <> uri
1671 , ""
1672 , "Waiting for you to scan... (this will complete automatically)"
1673 ]
1674 -- Now wait for signal-cli to finish (user scans the code)
1675 exitCode <- P.waitExitCode process
1676 case exitCode of
1677 ExitSuccess -> do
1678 send "Linked successfully!"
1679 detectAndWriteSignalConfig env ctx
1680 _ -> do
1681 send "Link failed or was cancelled."
1682 pure ctx
1683 where
1684 -- Read lines from both handles looking for a sgnl:// URI.
1685 -- signal-cli typically puts it on stderr.
1686 readUntilLink :: Handle -> Handle -> IO (Maybe Text)
1687 readUntilLink stderrH stdoutH = go (50 :: Int) -- max 50 lines to prevent infinite loop
1688 where
1689 go 0 = pure Nothing
1690 go n = do
1691 lineResult <- try @IOException (hGetLine stderrH)
1692 case lineResult of
1693 Left _ -> do
1694 -- stderr closed, try stdout
1695 outResult <- try @IOException (hGetLine stdoutH)
1696 case outResult of
1697 Left _ -> pure Nothing
1698 Right line ->
1699 let t = T.pack line
1700 in if "sgnl://" `T.isInfixOf` t
1701 then pure (Just (T.strip t))
1702 else go (n - 1)
1703 Right line ->
1704 let t = T.pack line
1705 in if "sgnl://" `T.isInfixOf` t
1706 then pure (Just (T.strip t))
1707 else go (n - 1)
1708
1709 -- | Register a new phone number.
1710 signalRegisterFlow :: AgentEnv -> Context -> IO Context
1711 signalRegisterFlow env ctx = do
1712 let ch = _env_channel env
1713 send = _ch_send ch . OutgoingMessage
1714
1715 phoneNumber <- T.strip <$> _ch_prompt ch "Phone number (E.164 format, e.g. +15555550123): "
1716 if T.null phoneNumber || not ("+" `T.isPrefixOf` phoneNumber)
1717 then do
1718 send "Invalid phone number. Must start with + (E.164 format)."
1719 pure ctx
1720 else do
1721 -- Try register without captcha first, handle captcha if required
1722 signalRegister env ch phoneNumber Nothing ctx
1723
1724 -- | Attempt signal-cli register, handling captcha if required.
1725 signalRegister :: AgentEnv -> ChannelHandle -> Text -> Maybe Text -> Context -> IO Context
1726 signalRegister env ch phoneNumber mCaptcha ctx = do
1727 let send = _ch_send ch . OutgoingMessage
1728 args = ["-u", T.unpack phoneNumber, "register"]
1729 ++ maybe [] (\c -> ["--captcha", T.unpack c]) mCaptcha
1730 send $ "Sending verification SMS to " <> phoneNumber <> "..."
1731 regResult <- try @IOException $
1732 P.readProcess (P.proc "signal-cli" args)
1733 case regResult of
1734 Left err -> do
1735 send $ "Registration failed: " <> T.pack (show err)
1736 pure ctx
1737 Right (exitCode, _, errOut) -> do
1738 let errText = T.strip (TE.decodeUtf8 (BL.toStrict errOut))
1739 case exitCode of
1740 ExitSuccess -> signalVerify env ch phoneNumber ctx
1741 _ | "captcha" `T.isInfixOf` T.toLower errText -> do
1742 send $ T.intercalate "\n"
1743 [ "Signal requires a captcha before sending the SMS."
1744 , ""
1745 , "1. Open this URL in a browser:"
1746 , " https://signalcaptchas.org/registration/generate.html"
1747 , "2. Solve the captcha"
1748 , "3. Open DevTools (F12), go to Network tab"
1749 , "4. Click \"Open Signal\" \x2014 find the signalcaptcha:// URL in the Network tab"
1750 , "5. Copy and paste the full URL here (starts with signalcaptcha://)"
1751 ]
1752 captchaInput <- T.strip <$> _ch_prompt ch "Captcha token: "
1753 let token = T.strip (T.replace "signalcaptcha://" "" captchaInput)
1754 if T.null token
1755 then do
1756 send "No captcha provided. Setup cancelled."
1757 pure ctx
1758 else signalRegister env ch phoneNumber (Just token) ctx
1759 _ -> do
1760 send $ "Registration failed: " <> errText
1761 pure ctx
1762
1763 -- | Verify a phone number after registration SMS was sent.
1764 signalVerify :: AgentEnv -> ChannelHandle -> Text -> Context -> IO Context
1765 signalVerify env ch phoneNumber ctx = do
1766 let send = _ch_send ch . OutgoingMessage
1767 send "Verification code sent! Check your SMS."
1768 code <- T.strip <$> _ch_prompt ch "Verification code: "
1769 verifyResult <- try @IOException $
1770 P.readProcess (P.proc "signal-cli"
1771 ["-u", T.unpack phoneNumber, "verify", T.unpack code])
1772 case verifyResult of
1773 Left err -> do
1774 send $ "Verification failed: " <> T.pack (show err)
1775 pure ctx
1776 Right (verifyExit, _, verifyErr) -> case verifyExit of
1777 ExitSuccess -> do
1778 send "Phone number verified!"
1779 writeSignalConfig env phoneNumber ctx
1780 _ -> do
1781 send $ "Verification failed: " <> T.strip (TE.decodeUtf8 (BL.toStrict verifyErr))
1782 pure ctx
1783
1784 -- | Detect the linked account number and write Signal config.
1785 detectAndWriteSignalConfig :: AgentEnv -> Context -> IO Context
1786 detectAndWriteSignalConfig env ctx = do
1787 let send = _ch_send (_env_channel env) . OutgoingMessage
1788 -- signal-cli stores account info; try to list accounts
1789 acctResult <- try @IOException $
1790 P.readProcess (P.proc "signal-cli" ["listAccounts"])
1791 case acctResult of
1792 Left _ -> do
1793 -- Can't detect — ask user
1794 phoneNumber <- T.strip <$> _ch_prompt (_env_channel env)
1795 "What phone number was linked? (E.164 format): "
1796 writeSignalConfig env phoneNumber ctx
1797 Right (_, out, _) -> do
1798 let outText = T.strip (TE.decodeUtf8 (BL.toStrict out))
1799 -- Look for a line starting with + (phone number)
1800 phones = filter ("+" `T.isPrefixOf`) (map T.strip (T.lines outText))
1801 case phones of
1802 (phone:_) -> do
1803 send $ "Detected account: " <> phone
1804 writeSignalConfig env phone ctx
1805 [] -> do
1806 phoneNumber <- T.strip <$> _ch_prompt (_env_channel env)
1807 "Could not detect account. Phone number (E.164 format): "
1808 writeSignalConfig env phoneNumber ctx
1809
1810 -- | Write Signal config to config.toml and confirm.
1811 writeSignalConfig :: AgentEnv -> Text -> Context -> IO Context
1812 writeSignalConfig env phoneNumber ctx = do
1813 let send = _ch_send (_env_channel env) . OutgoingMessage
1814 pureclawDir <- getPureclawDir
1815 Dir.createDirectoryIfMissing True pureclawDir
1816 let configPath = pureclawDir </> "config.toml"
1817
1818 -- Load existing config, add signal settings
1819 existing <- loadFileConfig configPath
1820 let updated = existing
1821 { _fc_defaultChannel = Just "signal"
1822 , _fc_signal = Just FileSignalConfig
1823 { _fsc_account = Just phoneNumber
1824 , _fsc_dmPolicy = Just "open"
1825 , _fsc_allowFrom = Nothing
1826 , _fsc_textChunkLimit = Nothing -- use default 6000
1827 }
1828 }
1829 writeFileConfig configPath updated
1830
1831 send $ T.intercalate "\n"
1832 [ ""
1833 , "Signal configured!"
1834 , " Account: " <> phoneNumber
1835 , " DM policy: open (accepts messages from anyone)"
1836 , " Default channel: signal"
1837 , ""
1838 , "To start chatting:"
1839 , " 1. Restart PureClaw (or run: pureclaw --channel signal)"
1840 , " 2. Open Signal on your phone"
1841 , " 3. Send a message to " <> phoneNumber
1842 , ""
1843 , "To restrict access later, edit ~/.pureclaw/config.toml:"
1844 , " [signal]"
1845 , " dm_policy = \"allowlist\""
1846 , " allow_from = [\"<your-uuid>\"]"
1847 , ""
1848 , "Your UUID will appear in the logs on first message."
1849 ]
1850 pure ctx
1851
1852 -- ---------------------------------------------------------------------------
1853 -- Help rendering — derived from allCommandSpecs
1854 -- ---------------------------------------------------------------------------
1855
1856 -- | Render the full command reference from 'allCommandSpecs'.
1857 renderHelpText :: [CommandSpec] -> Text
1858 renderHelpText specs =
1859 T.intercalate "\n"
1860 ("Slash commands:" : concatMap renderGroup [minBound .. maxBound])
1861 where
1862 renderGroup g =
1863 let gs = filter ((== g) . _cs_group) specs
1864 in if null gs
1865 then []
1866 else "" : (" " <> groupHeading g <> ":") : map renderSpec gs
1867
1868 renderSpec spec =
1869 " " <> padTo 26 (_cs_syntax spec) <> _cs_description spec
1870
1871 padTo n t = t <> T.replicate (max 1 (n - T.length t)) " "