My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1open Ezjsonm
2
3let src = Logs.Src.create "claude.permission" ~doc:"Claude permission system"
4module Log = (val Logs.src_log src : Logs.LOG)
5
6(* Helper for pretty-printing JSON *)
7let pp_json fmt json =
8 Fmt.string fmt (value_to_string json)
9
10(** Permission modes *)
11module Mode = struct
12 type t =
13 | Default
14 | Accept_edits
15 | Plan
16 | Bypass_permissions
17
18 let to_string = function
19 | Default -> "default"
20 | Accept_edits -> "acceptEdits"
21 | Plan -> "plan"
22 | Bypass_permissions -> "bypassPermissions"
23
24 let of_string = function
25 | "default" -> Default
26 | "acceptEdits" -> Accept_edits
27 | "plan" -> Plan
28 | "bypassPermissions" -> Bypass_permissions
29 | s -> raise (Invalid_argument (Printf.sprintf "Mode.of_string: unknown mode %s" s))
30
31 let to_json t = `String (to_string t)
32
33 let of_json = function
34 | `String s -> of_string s
35 | _ -> raise (Invalid_argument "Mode.of_json: expected string")
36
37 let pp fmt t = Fmt.string fmt (to_string t)
38end
39
40(** Permission behaviors *)
41module Behavior = struct
42 type t = Allow | Deny | Ask
43
44 let to_string = function
45 | Allow -> "allow"
46 | Deny -> "deny"
47 | Ask -> "ask"
48
49 let of_string = function
50 | "allow" -> Allow
51 | "deny" -> Deny
52 | "ask" -> Ask
53 | s -> raise (Invalid_argument (Printf.sprintf "Behavior.of_string: unknown behavior %s" s))
54
55 let to_json t = `String (to_string t)
56
57 let of_json = function
58 | `String s -> of_string s
59 | _ -> raise (Invalid_argument "Behavior.of_json: expected string")
60
61 let pp fmt t = Fmt.string fmt (to_string t)
62end
63
64(** Permission rules *)
65module Rule = struct
66 type t = {
67 tool_name : string;
68 rule_content : string option;
69 }
70
71 let create ~tool_name ?rule_content () = { tool_name; rule_content }
72 let tool_name t = t.tool_name
73 let rule_content t = t.rule_content
74
75 let to_json t =
76 let fields = [("tool_name", `String t.tool_name)] in
77 let fields = match t.rule_content with
78 | Some c -> ("rule_content", `String c) :: fields
79 | None -> fields
80 in
81 `O fields
82
83 let of_json = function
84 | `O fields ->
85 let tool_name = get_string (List.assoc "tool_name" fields) in
86 let rule_content =
87 try Some (get_string (List.assoc "rule_content" fields))
88 with Not_found -> None
89 in
90 { tool_name; rule_content }
91 | _ -> raise (Invalid_argument "Rule.of_json: expected object")
92
93 let pp fmt t =
94 Fmt.pf fmt "@[<2>Rule@ { tool_name = %S;@ rule_content = %a }@]"
95 t.tool_name Fmt.(option string) t.rule_content
96end
97
98(** Permission updates *)
99module Update = struct
100 type destination =
101 | User_settings
102 | Project_settings
103 | Local_settings
104 | Session
105
106 let destination_to_string = function
107 | User_settings -> "userSettings"
108 | Project_settings -> "projectSettings"
109 | Local_settings -> "localSettings"
110 | Session -> "session"
111
112 let destination_of_string = function
113 | "userSettings" -> User_settings
114 | "projectSettings" -> Project_settings
115 | "localSettings" -> Local_settings
116 | "session" -> Session
117 | s -> raise (Invalid_argument (Printf.sprintf "destination_of_string: unknown %s" s))
118
119 type update_type =
120 | Add_rules
121 | Replace_rules
122 | Remove_rules
123 | Set_mode
124 | Add_directories
125 | Remove_directories
126
127 let update_type_to_string = function
128 | Add_rules -> "addRules"
129 | Replace_rules -> "replaceRules"
130 | Remove_rules -> "removeRules"
131 | Set_mode -> "setMode"
132 | Add_directories -> "addDirectories"
133 | Remove_directories -> "removeDirectories"
134
135 let update_type_of_string = function
136 | "addRules" -> Add_rules
137 | "replaceRules" -> Replace_rules
138 | "removeRules" -> Remove_rules
139 | "setMode" -> Set_mode
140 | "addDirectories" -> Add_directories
141 | "removeDirectories" -> Remove_directories
142 | s -> raise (Invalid_argument (Printf.sprintf "update_type_of_string: unknown %s" s))
143
144 type t = {
145 update_type : update_type;
146 rules : Rule.t list option;
147 behavior : Behavior.t option;
148 mode : Mode.t option;
149 directories : string list option;
150 destination : destination option;
151 }
152
153 let create ~update_type ?rules ?behavior ?mode ?directories ?destination () =
154 { update_type; rules; behavior; mode; directories; destination }
155
156 let update_type t = t.update_type
157 let rules t = t.rules
158 let behavior t = t.behavior
159 let mode t = t.mode
160 let directories t = t.directories
161 let destination t = t.destination
162
163 let to_json t =
164 let fields = [("type", `String (update_type_to_string t.update_type))] in
165 let fields = match t.rules with
166 | Some rules -> ("rules", `A (List.map Rule.to_json rules)) :: fields
167 | None -> fields
168 in
169 let fields = match t.behavior with
170 | Some b -> ("behavior", Behavior.to_json b) :: fields
171 | None -> fields
172 in
173 let fields = match t.mode with
174 | Some m -> ("mode", Mode.to_json m) :: fields
175 | None -> fields
176 in
177 let fields = match t.directories with
178 | Some dirs -> ("directories", `A (List.map (fun s -> `String s) dirs)) :: fields
179 | None -> fields
180 in
181 let fields = match t.destination with
182 | Some d -> ("destination", `String (destination_to_string d)) :: fields
183 | None -> fields
184 in
185 `O fields
186
187 let of_json = function
188 | `O fields ->
189 let update_type = update_type_of_string (get_string (List.assoc "type" fields)) in
190 let rules =
191 try Some (get_list Rule.of_json (List.assoc "rules" fields))
192 with Not_found -> None
193 in
194 let behavior =
195 try Some (Behavior.of_json (List.assoc "behavior" fields))
196 with Not_found -> None
197 in
198 let mode =
199 try Some (Mode.of_json (List.assoc "mode" fields))
200 with Not_found -> None
201 in
202 let directories =
203 try Some (get_list get_string (List.assoc "directories" fields))
204 with Not_found -> None
205 in
206 let destination =
207 try Some (destination_of_string (get_string (List.assoc "destination" fields)))
208 with Not_found -> None
209 in
210 { update_type; rules; behavior; mode; directories; destination }
211 | _ -> raise (Invalid_argument "Update.of_json: expected object")
212
213 let pp fmt t =
214 Fmt.pf fmt "@[<2>Update@ { type = %s;@ rules = %a;@ behavior = %a;@ \
215 mode = %a;@ directories = %a;@ destination = %a }@]"
216 (update_type_to_string t.update_type)
217 Fmt.(option (list Rule.pp)) t.rules
218 Fmt.(option Behavior.pp) t.behavior
219 Fmt.(option Mode.pp) t.mode
220 Fmt.(option (list string)) t.directories
221 Fmt.(option (fun fmt d -> Fmt.string fmt (destination_to_string d))) t.destination
222end
223
224(** Permission context for callbacks *)
225module Context = struct
226 type t = {
227 suggestions : Update.t list;
228 }
229
230 let create ?(suggestions = []) () = { suggestions }
231 let suggestions t = t.suggestions
232
233 let to_json t =
234 `O [("suggestions", `A (List.map Update.to_json t.suggestions))]
235
236 let of_json = function
237 | `O fields ->
238 let suggestions =
239 try get_list Update.of_json (List.assoc "suggestions" fields)
240 with Not_found -> []
241 in
242 { suggestions }
243 | _ -> raise (Invalid_argument "Context.of_json: expected object")
244
245 let pp fmt t =
246 Fmt.pf fmt "@[<2>Context@ { suggestions = @[<v>%a@] }@]"
247 Fmt.(list ~sep:(any "@,") Update.pp) t.suggestions
248end
249
250(** Permission results *)
251module Result = struct
252 type t =
253 | Allow of {
254 updated_input : value option;
255 updated_permissions : Update.t list option;
256 }
257 | Deny of {
258 message : string;
259 interrupt : bool;
260 }
261
262 let allow ?updated_input ?updated_permissions () =
263 Allow { updated_input; updated_permissions }
264
265 let deny ~message ~interrupt = Deny { message; interrupt }
266
267 let to_json = function
268 | Allow { updated_input; updated_permissions } ->
269 let fields = [("behavior", `String "allow")] in
270 let fields = match updated_input with
271 | Some input -> ("updated_input", input) :: fields
272 | None -> fields
273 in
274 let fields = match updated_permissions with
275 | Some perms -> ("updated_permissions", `A (List.map Update.to_json perms)) :: fields
276 | None -> fields
277 in
278 `O fields
279 | Deny { message; interrupt } ->
280 `O [
281 ("behavior", `String "deny");
282 ("message", `String message);
283 ("interrupt", `Bool interrupt);
284 ]
285
286 let of_json = function
287 | `O fields -> (
288 match List.assoc "behavior" fields with
289 | `String "allow" ->
290 let updated_input = List.assoc_opt "updated_input" fields in
291 let updated_permissions =
292 try Some (get_list Update.of_json (List.assoc "updated_permissions" fields))
293 with Not_found -> None
294 in
295 Allow { updated_input; updated_permissions }
296 | `String "deny" ->
297 let message = get_string (List.assoc "message" fields) in
298 let interrupt = get_bool (List.assoc "interrupt" fields) in
299 Deny { message; interrupt }
300 | _ -> raise (Invalid_argument "Result.of_json: unknown behavior")
301 )
302 | _ -> raise (Invalid_argument "Result.of_json: expected object")
303
304 let pp fmt = function
305 | Allow { updated_input; updated_permissions } ->
306 Fmt.pf fmt "@[<2>Allow@ { updated_input = %a;@ updated_permissions = %a }@]"
307 Fmt.(option pp_json) updated_input
308 Fmt.(option (list Update.pp)) updated_permissions
309 | Deny { message; interrupt } ->
310 Fmt.pf fmt "@[<2>Deny@ { message = %S;@ interrupt = %b }@]" message interrupt
311end
312
313(** Permission callback type *)
314type callback =
315 tool_name:string ->
316 input:value ->
317 context:Context.t ->
318 Result.t
319
320(** Default callbacks *)
321let default_allow_callback ~tool_name:_ ~input:_ ~context:_ =
322 Result.allow ()
323
324let discovery_callback log ~tool_name:_ ~input:_ ~context =
325 List.iter (fun update ->
326 match Update.rules update with
327 | Some rules ->
328 List.iter (fun rule ->
329 log := rule :: !log
330 ) rules
331 | None -> ()
332 ) (Context.suggestions context);
333 Result.allow ()
334
335(** Logging *)
336let log_permission_check ~tool_name ~result =
337 match result with
338 | Result.Allow _ ->
339 Log.info (fun m -> m "Permission granted for tool: %s" tool_name)
340 | Result.Deny { message; _ } ->
341 Log.warn (fun m -> m "Permission denied for tool %s: %s" tool_name message)