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