never executed always true always false
1 module PureClaw.Agent.SlashCommands
2 ( -- * Command data types
3 SlashCommand (..)
4 , VaultSubCommand (..)
5 -- * Command registry — single source of truth
6 , CommandGroup (..)
7 , CommandSpec (..)
8 , allCommandSpecs
9 -- * Parsing (derived from allCommandSpecs)
10 , parseSlashCommand
11 -- * Execution
12 , executeSlashCommand
13 ) where
14
15 import Control.Applicative ((<|>))
16 import Control.Exception
17 import Data.Foldable (asum)
18 import Data.Text (Text)
19 import Data.Text qualified as T
20 import Data.Text.Encoding qualified as TE
21
22 import PureClaw.Agent.Compaction
23 import PureClaw.Agent.Context
24 import PureClaw.Agent.Env
25 import PureClaw.Handles.Channel
26 import PureClaw.Security.Vault
27 import PureClaw.Security.Vault.Age
28
29 -- ---------------------------------------------------------------------------
30 -- Command taxonomy
31 -- ---------------------------------------------------------------------------
32
33 -- | Organisational group for display in '/help'.
34 data CommandGroup
35 = GroupSession -- ^ Session and context management
36 | GroupVault -- ^ Encrypted secrets vault
37 deriving stock (Show, Eq, Ord, Enum, Bounded)
38
39 -- | Human-readable section heading for '/help' output.
40 groupHeading :: CommandGroup -> Text
41 groupHeading GroupSession = "Session"
42 groupHeading GroupVault = "Vault"
43
44 -- | Specification for a single slash command.
45 -- 'allCommandSpecs' is the single source of truth: 'parseSlashCommand'
46 -- is derived from '_cs_parse' and '/help' renders from '_cs_syntax' /
47 -- '_cs_description', so the two cannot diverge.
48 data CommandSpec = CommandSpec
49 { _cs_syntax :: Text -- ^ Display syntax, e.g. "/vault add <name>"
50 , _cs_description :: Text -- ^ One-line description shown in '/help'
51 , _cs_group :: CommandGroup -- ^ Organisational group
52 , _cs_parse :: Text -> Maybe SlashCommand
53 -- ^ Try to parse a stripped, original-case input as this command.
54 -- Match is case-insensitive on keywords; argument case is preserved.
55 }
56
57 -- ---------------------------------------------------------------------------
58 -- Vault subcommands
59 -- ---------------------------------------------------------------------------
60
61 -- | Subcommands of the '/vault' family.
62 data VaultSubCommand
63 = VaultInit -- ^ Initialise the vault file on disk
64 | VaultAdd Text -- ^ Store a named secret
65 | VaultList -- ^ List secret names
66 | VaultDelete Text -- ^ Delete a named secret
67 | VaultLock -- ^ Lock the vault
68 | VaultUnlock -- ^ Unlock the vault
69 | VaultStatus' -- ^ Show vault status
70 | VaultUnknown Text -- ^ Unrecognised subcommand (not in allCommandSpecs)
71 deriving stock (Show, Eq)
72
73 -- ---------------------------------------------------------------------------
74 -- Top-level commands
75 -- ---------------------------------------------------------------------------
76
77 -- | All recognised slash commands.
78 data SlashCommand
79 = CmdHelp -- ^ Show command reference
80 | CmdNew -- ^ Clear conversation, keep configuration
81 | CmdReset -- ^ Full reset including usage counters
82 | CmdStatus -- ^ Show session status
83 | CmdCompact -- ^ Summarise conversation to save context
84 | CmdVault VaultSubCommand -- ^ Vault command family
85 deriving stock (Show, Eq)
86
87 -- ---------------------------------------------------------------------------
88 -- Command registry
89 -- ---------------------------------------------------------------------------
90
91 -- | All recognised slash commands, in the order they appear in '/help'.
92 -- This is the authoritative definition: 'parseSlashCommand' is derived
93 -- from '_cs_parse' across this list, and '/help' renders from it.
94 -- To add a command, add a 'CommandSpec' here — parsing and help update
95 -- automatically.
96 allCommandSpecs :: [CommandSpec]
97 allCommandSpecs = sessionCommandSpecs ++ vaultCommandSpecs
98
99 sessionCommandSpecs :: [CommandSpec]
100 sessionCommandSpecs =
101 [ CommandSpec "/help" "Show this command reference" GroupSession (exactP "/help" CmdHelp)
102 , CommandSpec "/status" "Session status (messages, tokens used)" GroupSession (exactP "/status" CmdStatus)
103 , CommandSpec "/new" "Clear conversation, keep configuration" GroupSession (exactP "/new" CmdNew)
104 , CommandSpec "/reset" "Full reset including usage counters" GroupSession (exactP "/reset" CmdReset)
105 , CommandSpec "/compact" "Summarise conversation to save context" GroupSession (exactP "/compact" CmdCompact)
106 ]
107
108 vaultCommandSpecs :: [CommandSpec]
109 vaultCommandSpecs =
110 [ CommandSpec "/vault init" "Initialise the encrypted secrets vault" GroupVault (vaultExactP "init" VaultInit)
111 , CommandSpec "/vault add <name>" "Store a named secret (prompts for value)" GroupVault (vaultArgP "add" VaultAdd)
112 , CommandSpec "/vault list" "List all stored secret names" GroupVault (vaultExactP "list" VaultList)
113 , CommandSpec "/vault delete <name>" "Delete a named secret" GroupVault (vaultArgP "delete" VaultDelete)
114 , CommandSpec "/vault lock" "Lock the vault" GroupVault (vaultExactP "lock" VaultLock)
115 , CommandSpec "/vault unlock" "Unlock the vault" GroupVault (vaultExactP "unlock" VaultUnlock)
116 , CommandSpec "/vault status" "Show vault state and key type" GroupVault (vaultExactP "status" VaultStatus')
117 ]
118
119 -- ---------------------------------------------------------------------------
120 -- Parsing — derived from allCommandSpecs
121 -- ---------------------------------------------------------------------------
122
123 -- | Parse a user message as a slash command.
124 -- Implemented as 'asum' over '_cs_parse' from 'allCommandSpecs', followed
125 -- by a catch-all for unrecognised @\/vault@ subcommands.
126 -- Returns 'Nothing' only for input that does not begin with @\/@.
127 parseSlashCommand :: Text -> Maybe SlashCommand
128 parseSlashCommand input =
129 let stripped = T.strip input
130 in if "/" `T.isPrefixOf` stripped
131 then asum (map (`_cs_parse` stripped) allCommandSpecs)
132 <|> vaultUnknownFallback stripped
133 else Nothing
134
135 -- | Exact case-insensitive match.
136 exactP :: Text -> SlashCommand -> Text -> Maybe SlashCommand
137 exactP keyword cmd t = if T.toLower t == keyword then Just cmd else Nothing
138
139 -- | Case-insensitive match for "/vault <sub>" with no argument.
140 vaultExactP :: Text -> VaultSubCommand -> Text -> Maybe SlashCommand
141 vaultExactP sub cmd t =
142 if T.toLower t == "/vault " <> sub then Just (CmdVault cmd) else Nothing
143
144 -- | Case-insensitive prefix match for "/vault <sub> [arg]".
145 -- Argument is extracted from the original-case input, preserving its case.
146 vaultArgP :: Text -> (Text -> VaultSubCommand) -> Text -> Maybe SlashCommand
147 vaultArgP sub mkCmd t =
148 let pfx = "/vault " <> sub
149 lower = T.toLower t
150 in if lower == pfx || (pfx <> " ") `T.isPrefixOf` lower
151 then Just (CmdVault (mkCmd (T.strip (T.drop (T.length pfx) t))))
152 else Nothing
153
154 -- | Catch-all for any "/vault <X>" not matched by 'allCommandSpecs'.
155 -- Not included in the spec list so it does not appear in '/help'.
156 vaultUnknownFallback :: Text -> Maybe SlashCommand
157 vaultUnknownFallback t =
158 let lower = T.toLower t
159 in if "/vault" `T.isPrefixOf` lower
160 then let rest = T.strip (T.drop (T.length "/vault") lower)
161 sub = fst (T.break (== ' ') rest)
162 in Just (CmdVault (VaultUnknown sub))
163 else Nothing
164
165 -- ---------------------------------------------------------------------------
166 -- Execution
167 -- ---------------------------------------------------------------------------
168
169 -- | Execute a slash command. Returns the (possibly updated) context.
170 executeSlashCommand :: AgentEnv -> SlashCommand -> Context -> IO Context
171
172 executeSlashCommand env CmdHelp ctx = do
173 _ch_send (_env_channel env) (OutgoingMessage (renderHelpText allCommandSpecs))
174 pure ctx
175
176 executeSlashCommand env CmdNew ctx = do
177 _ch_send (_env_channel env) (OutgoingMessage "Session cleared. Starting fresh.")
178 pure (clearMessages ctx)
179
180 executeSlashCommand env CmdReset _ctx = do
181 _ch_send (_env_channel env) (OutgoingMessage "Full reset. Context and usage cleared.")
182 pure (emptyContext (contextSystemPrompt _ctx))
183
184 executeSlashCommand env CmdStatus ctx = do
185 let status = T.intercalate "\n"
186 [ "Session status:"
187 , " Messages: " <> T.pack (show (contextMessageCount ctx))
188 , " Est. context tokens: " <> T.pack (show (contextTokenEstimate ctx))
189 , " Total input tokens: " <> T.pack (show (contextTotalInputTokens ctx))
190 , " Total output tokens: " <> T.pack (show (contextTotalOutputTokens ctx))
191 ]
192 _ch_send (_env_channel env) (OutgoingMessage status)
193 pure ctx
194
195 executeSlashCommand env CmdCompact ctx = do
196 (ctx', result) <- compactContext
197 (_env_provider env)
198 (_env_model env)
199 0
200 defaultKeepRecent
201 ctx
202 let msg = case result of
203 NotNeeded -> "Nothing to compact (too few messages)."
204 Compacted o n -> "Compacted: " <> T.pack (show o)
205 <> " messages \x2192 " <> T.pack (show n)
206 CompactionError e -> "Compaction failed: " <> e
207 _ch_send (_env_channel env) (OutgoingMessage msg)
208 pure ctx'
209
210 executeSlashCommand env (CmdVault sub) ctx =
211 case _env_vault env of
212 Nothing -> do
213 let msg = case sub of
214 VaultInit -> T.intercalate "\n"
215 [ "Vault not configured. To use the vault, add to ~/.pureclaw/config.toml:"
216 , ""
217 , " vault_recipient = \"age1...\" # your age public key (from: age-keygen)"
218 , " vault_identity = \"~/.age/key.txt\" # path to your age private key"
219 , ""
220 , "Then run /vault init to create the vault file."
221 ]
222 _ -> "No vault configured. Add vault settings to ~/.pureclaw/config.toml."
223 _ch_send (_env_channel env) (OutgoingMessage msg)
224 pure ctx
225 Just vault ->
226 executeVaultCommand env vault sub ctx
227
228 -- ---------------------------------------------------------------------------
229 -- Vault subcommand execution
230 -- ---------------------------------------------------------------------------
231
232 executeVaultCommand :: AgentEnv -> VaultHandle -> VaultSubCommand -> Context -> IO Context
233 executeVaultCommand env vault sub ctx = do
234 let ch = _env_channel env
235 send = _ch_send ch . OutgoingMessage
236 case sub of
237 VaultInit -> do
238 result <- _vh_init vault
239 case result of
240 Left VaultAlreadyExists ->
241 send "Vault already exists. Use /vault status to inspect."
242 Left err ->
243 send ("Vault init failed: " <> T.pack (show err))
244 Right () ->
245 send "Vault initialized successfully."
246 pure ctx
247
248 VaultAdd name -> do
249 send ("Enter value for '" <> name <> "' (input will not be echoed):")
250 valueResult <- try @IOError (_ch_readSecret ch)
251 case valueResult of
252 Left e ->
253 send ("Error reading secret: " <> T.pack (show e))
254 Right value -> do
255 result <- _vh_put vault name (TE.encodeUtf8 value)
256 case result of
257 Left err -> send ("Error storing secret: " <> T.pack (show err))
258 Right () -> send ("Secret '" <> name <> "' stored.")
259 pure ctx
260
261 VaultList -> do
262 result <- _vh_list vault
263 case result of
264 Left err -> send ("Error: " <> T.pack (show err))
265 Right [] -> send "Vault is empty."
266 Right names ->
267 send ("Secrets:\n" <> T.unlines (map (" \x2022 " <>) names))
268 pure ctx
269
270 VaultDelete name -> do
271 send ("Delete secret '" <> name <> "'? [y/N]:")
272 confirmMsg <- _ch_receive ch
273 let confirm = T.strip (_im_content confirmMsg)
274 if confirm == "y" || confirm == "Y"
275 then do
276 result <- _vh_delete vault name
277 case result of
278 Left err -> send ("Error: " <> T.pack (show err))
279 Right () -> send ("Secret '" <> name <> "' deleted.")
280 else send "Cancelled."
281 pure ctx
282
283 VaultLock -> do
284 _vh_lock vault
285 send "Vault locked."
286 pure ctx
287
288 VaultUnlock -> do
289 result <- _vh_unlock vault
290 case result of
291 Left err -> send ("Error unlocking vault: " <> T.pack (show err))
292 Right () -> send "Vault unlocked."
293 pure ctx
294
295 VaultStatus' -> do
296 status <- _vh_status vault
297 let lockedText = if _vs_locked status then "Locked" else "Unlocked"
298 msg = T.intercalate "\n"
299 [ "Vault status:"
300 , " State: " <> lockedText
301 , " Secrets: " <> T.pack (show (_vs_secretCount status))
302 , " Key: " <> _vs_keyType status
303 ]
304 send msg
305 pure ctx
306
307 VaultUnknown _ ->
308 send "Unknown vault command. Type /help to see all available commands."
309 >> pure ctx
310
311 -- ---------------------------------------------------------------------------
312 -- Help rendering — derived from allCommandSpecs
313 -- ---------------------------------------------------------------------------
314
315 -- | Render the full command reference from 'allCommandSpecs'.
316 renderHelpText :: [CommandSpec] -> Text
317 renderHelpText specs =
318 T.intercalate "\n"
319 ("Slash commands:" : concatMap renderGroup [minBound .. maxBound])
320 where
321 renderGroup g =
322 let gs = filter ((== g) . _cs_group) specs
323 in if null gs
324 then []
325 else "" : (" " <> groupHeading g <> ":") : map renderSpec gs
326
327 renderSpec spec =
328 " " <> padTo 26 (_cs_syntax spec) <> _cs_description spec
329
330 padTo n t = t <> T.replicate (max 1 (n - T.length t)) " "