never executed always true always false
1 module PureClaw.Agent.SlashCommands
2 ( -- * Slash command parsing
3 SlashCommand (..)
4 , VaultSubCommand (..)
5 , parseSlashCommand
6 -- * Slash command execution
7 , executeSlashCommand
8 ) where
9
10 import Control.Exception
11 import Data.Text (Text)
12 import Data.Text qualified as T
13 import Data.Text.Encoding qualified as TE
14
15 import PureClaw.Agent.Compaction
16 import PureClaw.Agent.Context
17 import PureClaw.Agent.Env
18 import PureClaw.Handles.Channel
19 import PureClaw.Security.Vault
20 import PureClaw.Security.Vault.Age
21
22 -- | Vault subcommands recognized by the '/vault' command family.
23 data VaultSubCommand
24 = VaultInit -- ^ Initialize the vault file on disk
25 | VaultAdd Text -- ^ Add a named secret
26 | VaultList -- ^ List secret names
27 | VaultDelete Text -- ^ Delete a named secret
28 | VaultLock -- ^ Lock the vault
29 | VaultUnlock -- ^ Unlock the vault
30 | VaultStatus' -- ^ Show vault status
31 | VaultUnknown Text -- ^ Unrecognized subcommand
32 deriving stock (Show, Eq)
33
34 -- | Recognized slash commands.
35 data SlashCommand
36 = CmdNew -- ^ Start a new session (clear context)
37 | CmdReset -- ^ Full reset (clear context and usage)
38 | CmdStatus -- ^ Show session status
39 | CmdCompact -- ^ Trigger context compaction
40 | CmdVault VaultSubCommand -- ^ Vault command family
41 deriving stock (Show, Eq)
42
43 -- | Parse a user message as a slash command, if it starts with '/'.
44 -- Returns 'Nothing' for non-commands or unrecognized commands.
45 parseSlashCommand :: Text -> Maybe SlashCommand
46 parseSlashCommand input =
47 let stripped = T.strip input
48 lower = T.toLower stripped
49 in case lower of
50 "/new" -> Just CmdNew
51 "/reset" -> Just CmdReset
52 "/status" -> Just CmdStatus
53 "/compact" -> Just CmdCompact
54 _
55 | "/vault" `T.isPrefixOf` lower ->
56 let rest = T.strip (T.drop (T.length "/vault") stripped)
57 in Just (CmdVault (parseVaultSubCommand rest))
58 | otherwise -> Nothing
59
60 -- | Parse the subcommand portion of a '/vault <subcommand> [args]' input.
61 -- The input is the text after '/vault', already stripped.
62 parseVaultSubCommand :: Text -> VaultSubCommand
63 parseVaultSubCommand rest =
64 let (sub, args) = T.break (== ' ') rest
65 arg = T.strip args
66 in case T.toLower sub of
67 "init" -> VaultInit
68 "add" -> VaultAdd arg
69 "list" -> VaultList
70 "delete" -> VaultDelete arg
71 "lock" -> VaultLock
72 "unlock" -> VaultUnlock
73 "status" -> VaultStatus'
74 _ -> VaultUnknown sub
75
76 -- | Execute a slash command against a context.
77 -- Returns the updated context.
78 executeSlashCommand
79 :: AgentEnv
80 -> SlashCommand
81 -> Context
82 -> IO Context
83 executeSlashCommand env CmdNew ctx = do
84 _ch_send (_env_channel env) (OutgoingMessage "Session cleared. Starting fresh.")
85 pure (clearMessages ctx)
86
87 executeSlashCommand env CmdReset _ctx = do
88 _ch_send (_env_channel env) (OutgoingMessage "Full reset. Context and usage cleared.")
89 pure (emptyContext (contextSystemPrompt _ctx))
90
91 executeSlashCommand env CmdStatus ctx = do
92 let tokens = contextTokenEstimate ctx
93 msgs = contextMessageCount ctx
94 inToks = contextTotalInputTokens ctx
95 outToks = contextTotalOutputTokens ctx
96 status = T.intercalate "\n"
97 [ "Session status:"
98 , " Messages: " <> T.pack (show msgs)
99 , " Est. context tokens: " <> T.pack (show tokens)
100 , " Total input tokens: " <> T.pack (show inToks)
101 , " Total output tokens: " <> T.pack (show outToks)
102 ]
103 _ch_send (_env_channel env) (OutgoingMessage status)
104 pure ctx
105
106 executeSlashCommand env CmdCompact ctx = do
107 (ctx', result) <- compactContext
108 (_env_provider env)
109 (_env_model env)
110 0 -- force compaction regardless of threshold
111 defaultKeepRecent
112 ctx
113 let msg = case result of
114 NotNeeded -> "Nothing to compact (too few messages)."
115 Compacted o n -> "Compacted: " <> T.pack (show o)
116 <> " messages → " <> T.pack (show n)
117 CompactionError e -> "Compaction failed: " <> e
118 _ch_send (_env_channel env) (OutgoingMessage msg)
119 pure ctx'
120
121 executeSlashCommand env (CmdVault sub) ctx =
122 case _env_vault env of
123 Nothing -> do
124 _ch_send (_env_channel env)
125 (OutgoingMessage "No vault configured. Add vault settings to ~/.pureclaw/config.toml.")
126 pure ctx
127 Just vault ->
128 executeVaultCommand env vault sub ctx
129
130 -- | Execute a vault subcommand given a 'VaultHandle'.
131 executeVaultCommand
132 :: AgentEnv
133 -> VaultHandle
134 -> VaultSubCommand
135 -> Context
136 -> IO Context
137 executeVaultCommand env vault sub ctx = do
138 let ch = _env_channel env
139 send = _ch_send ch . OutgoingMessage
140 case sub of
141 VaultInit -> do
142 result <- _vh_init vault
143 case result of
144 Left VaultAlreadyExists ->
145 send "Vault already exists. Use /vault status to inspect."
146 Left err ->
147 send ("Vault init failed: " <> T.pack (show err))
148 Right () ->
149 send "Vault initialized successfully."
150 pure ctx
151
152 VaultAdd name -> do
153 send ("Enter value for '" <> name <> "' (input will not be echoed):")
154 valueResult <- try @IOError (_ch_readSecret ch)
155 case valueResult of
156 Left e ->
157 send ("Error reading secret: " <> T.pack (show e))
158 Right value -> do
159 result <- _vh_put vault name (TE.encodeUtf8 value)
160 case result of
161 Left err -> send ("Error storing secret: " <> T.pack (show err))
162 Right () -> send ("Secret '" <> name <> "' stored.")
163 pure ctx
164
165 VaultList -> do
166 result <- _vh_list vault
167 case result of
168 Left err -> send ("Error: " <> T.pack (show err))
169 Right [] -> send "Vault is empty."
170 Right names ->
171 send ("Secrets:\n" <> T.unlines (map (" \x2022 " <>) names))
172 pure ctx
173
174 VaultDelete name -> do
175 send ("Delete secret '" <> name <> "'? [y/N]:")
176 confirmMsg <- _ch_receive ch
177 let confirm = T.strip (_im_content confirmMsg)
178 if confirm == "y" || confirm == "Y"
179 then do
180 result <- _vh_delete vault name
181 case result of
182 Left err -> send ("Error: " <> T.pack (show err))
183 Right () -> send ("Secret '" <> name <> "' deleted.")
184 else send "Cancelled."
185 pure ctx
186
187 VaultLock -> do
188 _vh_lock vault
189 send "Vault locked."
190 pure ctx
191
192 VaultUnlock -> do
193 result <- _vh_unlock vault
194 case result of
195 Left err -> send ("Error unlocking vault: " <> T.pack (show err))
196 Right () -> send "Vault unlocked."
197 pure ctx
198
199 VaultStatus' -> do
200 status <- _vh_status vault
201 let lockedText = if _vs_locked status then "Locked" else "Unlocked"
202 msg = T.intercalate "\n"
203 [ "Vault status:"
204 , " State: " <> lockedText
205 , " Secrets: " <> T.pack (show (_vs_secretCount status))
206 , " Key: " <> _vs_keyType status
207 ]
208 send msg
209 pure ctx
210
211 VaultUnknown _ ->
212 send "Unknown vault command. Available: init, add, list, delete, lock, unlock, status"
213 >> pure ctx