My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1let src = Logs.Src.create "cookeio" ~doc:"Cookie management"
2
3module Log = (val Logs.src_log src : Logs.LOG)
4
5type same_site = [ `Strict | `Lax | `None ]
6(** Cookie same-site policy *)
7
8type t = {
9 domain : string;
10 path : string;
11 name : string;
12 value : string;
13 secure : bool;
14 http_only : bool;
15 expires : Ptime.t option;
16 same_site : same_site option;
17 creation_time : Ptime.t;
18 last_access : Ptime.t;
19}
20(** HTTP Cookie *)
21
22type jar = { mutable cookies : t list; mutex : Eio.Mutex.t }
23(** Cookie jar for storing and managing cookies *)
24
25(** {1 Cookie Accessors} *)
26
27let domain cookie = cookie.domain
28let path cookie = cookie.path
29let name cookie = cookie.name
30let value cookie = cookie.value
31let secure cookie = cookie.secure
32let http_only cookie = cookie.http_only
33let expires cookie = cookie.expires
34let same_site cookie = cookie.same_site
35let creation_time cookie = cookie.creation_time
36let last_access cookie = cookie.last_access
37
38let make ~domain ~path ~name ~value ?(secure = false) ?(http_only = false)
39 ?expires ?same_site ~creation_time ~last_access () =
40 { domain; path; name; value; secure; http_only; expires; same_site; creation_time; last_access }
41
42(** {1 Cookie Jar Creation} *)
43
44let create () =
45 Log.debug (fun m -> m "Creating new empty cookie jar");
46 { cookies = []; mutex = Eio.Mutex.create () }
47
48(** {1 Cookie Matching Helpers} *)
49
50let domain_matches cookie_domain request_domain =
51 (* Cookie domain .example.com matches example.com and sub.example.com *)
52 if String.starts_with ~prefix:"." cookie_domain then
53 let domain_suffix = String.sub cookie_domain 1 (String.length cookie_domain - 1) in
54 request_domain = domain_suffix
55 || String.ends_with ~suffix:("." ^ domain_suffix) request_domain
56 else cookie_domain = request_domain
57
58let path_matches cookie_path request_path =
59 (* Cookie path /foo matches /foo, /foo/, /foo/bar *)
60 String.starts_with ~prefix:cookie_path request_path
61
62let is_expired cookie clock =
63 match cookie.expires with
64 | None -> false (* Session cookie *)
65 | Some exp_time ->
66 let now =
67 Ptime.of_float_s (Eio.Time.now clock)
68 |> Option.value ~default:Ptime.epoch
69 in
70 Ptime.compare now exp_time > 0
71
72(** {1 Cookie Parsing} *)
73
74let parse_cookie_attribute attr attr_value cookie =
75 let attr_lower = String.lowercase_ascii attr in
76 match attr_lower with
77 | "domain" -> make ~domain:attr_value ~path:(path cookie) ~name:(name cookie)
78 ~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
79 ?expires:(expires cookie) ?same_site:(same_site cookie)
80 ~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
81 | "path" -> make ~domain:(domain cookie) ~path:attr_value ~name:(name cookie)
82 ~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
83 ?expires:(expires cookie) ?same_site:(same_site cookie)
84 ~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
85 | "expires" -> (
86 (* Parse various date formats *)
87 try
88 let time, _tz_offset, _tz_string =
89 Ptime.of_rfc3339 attr_value |> Result.get_ok
90 in
91 make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
92 ~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
93 ~expires:time ?same_site:(same_site cookie)
94 ~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
95 with _ ->
96 Log.debug (fun m -> m "Failed to parse expires: %s" attr_value);
97 cookie)
98 | "max-age" -> (
99 try
100 let seconds = int_of_string attr_value in
101 let now = Unix.time () in
102 let expires = Ptime.of_float_s (now +. float_of_int seconds) in
103 make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
104 ~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
105 ?expires ?same_site:(same_site cookie)
106 ~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
107 with _ -> cookie)
108 | "secure" -> make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
109 ~value:(value cookie) ~secure:true ~http_only:(http_only cookie)
110 ?expires:(expires cookie) ?same_site:(same_site cookie)
111 ~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
112 | "httponly" -> make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
113 ~value:(value cookie) ~secure:(secure cookie) ~http_only:true
114 ?expires:(expires cookie) ?same_site:(same_site cookie)
115 ~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
116 | "samesite" ->
117 let same_site_val =
118 match String.lowercase_ascii attr_value with
119 | "strict" -> Some `Strict
120 | "lax" -> Some `Lax
121 | "none" -> Some `None
122 | _ -> None
123 in
124 make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
125 ~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
126 ?expires:(expires cookie) ?same_site:same_site_val
127 ~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
128 | _ -> cookie
129
130let rec parse_set_cookie ~domain:request_domain ~path:request_path header_value =
131 Log.debug (fun m -> m "Parsing Set-Cookie: %s" header_value);
132
133 (* Split into attributes *)
134 let parts = String.split_on_char ';' header_value |> List.map String.trim in
135
136 match parts with
137 | [] -> None
138 | name_value :: attrs -> (
139 (* Parse name=value *)
140 match String.index_opt name_value '=' with
141 | None -> None
142 | Some eq_pos ->
143 let name = String.sub name_value 0 eq_pos |> String.trim in
144 let cookie_value =
145 String.sub name_value (eq_pos + 1)
146 (String.length name_value - eq_pos - 1)
147 |> String.trim
148 in
149
150 let now =
151 Ptime.of_float_s (Unix.time ()) |> Option.value ~default:Ptime.epoch
152 in
153 let base_cookie =
154 make ~domain:request_domain ~path:request_path ~name ~value:cookie_value ~secure:false ~http_only:false
155 ?expires:None ?same_site:None ~creation_time:now ~last_access:now ()
156 in
157
158 (* Parse attributes *)
159 let cookie =
160 List.fold_left
161 (fun cookie attr ->
162 match String.index_opt attr '=' with
163 | None -> parse_cookie_attribute attr "" cookie
164 | Some eq ->
165 let attr_name = String.sub attr 0 eq |> String.trim in
166 let attr_value =
167 String.sub attr (eq + 1) (String.length attr - eq - 1)
168 |> String.trim
169 in
170 parse_cookie_attribute attr_name attr_value cookie)
171 base_cookie attrs
172 in
173
174 Log.debug (fun m -> m "Parsed cookie: %a" pp cookie);
175 Some cookie)
176
177and make_cookie_header cookies =
178 cookies
179 |> List.map (fun c -> Printf.sprintf "%s=%s" (name c) (value c))
180 |> String.concat "; "
181
182(** {1 Pretty Printing} *)
183
184and pp_same_site ppf = function
185 | `Strict -> Format.pp_print_string ppf "Strict"
186 | `Lax -> Format.pp_print_string ppf "Lax"
187 | `None -> Format.pp_print_string ppf "None"
188
189and pp ppf cookie =
190 Format.fprintf ppf
191 "@[<hov 2>{ name=%S;@ value=%S;@ domain=%S;@ path=%S;@ secure=%b;@ \
192 http_only=%b;@ expires=%a;@ same_site=%a }@]"
193 (name cookie) (value cookie) (domain cookie) (path cookie) (secure cookie)
194 (http_only cookie)
195 (Format.pp_print_option Ptime.pp)
196 (expires cookie)
197 (Format.pp_print_option pp_same_site)
198 (same_site cookie)
199
200let pp_jar ppf jar =
201 Eio.Mutex.lock jar.mutex;
202 let cookies = jar.cookies in
203 Eio.Mutex.unlock jar.mutex;
204
205 Format.fprintf ppf "@[<v>CookieJar with %d cookies:@," (List.length cookies);
206 List.iter (fun cookie -> Format.fprintf ppf " %a@," pp cookie) cookies;
207 Format.fprintf ppf "@]"
208
209(** {1 Cookie Management} *)
210
211let add_cookie jar cookie =
212 Log.debug (fun m ->
213 m "Adding cookie: %s=%s for domain %s" (name cookie) (value cookie)
214 (domain cookie));
215
216 Eio.Mutex.lock jar.mutex;
217 (* Remove existing cookie with same name, domain, and path *)
218 jar.cookies <-
219 List.filter
220 (fun c ->
221 not
222 (name c = name cookie && domain c = domain cookie
223 && path c = path cookie))
224 jar.cookies;
225 jar.cookies <- cookie :: jar.cookies;
226 Eio.Mutex.unlock jar.mutex
227
228let get_cookies jar ~domain:request_domain ~path:request_path ~is_secure =
229 Log.debug (fun m ->
230 m "Getting cookies for domain=%s path=%s secure=%b" request_domain request_path is_secure);
231
232 Eio.Mutex.lock jar.mutex;
233 let applicable =
234 List.filter
235 (fun cookie ->
236 domain_matches (domain cookie) request_domain
237 && path_matches (path cookie) request_path
238 && ((not (secure cookie)) || is_secure))
239 jar.cookies
240 in
241
242 (* Update last access time *)
243 let now =
244 Ptime.of_float_s (Unix.time ()) |> Option.value ~default:Ptime.epoch
245 in
246 let updated =
247 List.map
248 (fun c ->
249 if List.memq c applicable then
250 make ~domain:(domain c) ~path:(path c) ~name:(name c) ~value:(value c)
251 ~secure:(secure c) ~http_only:(http_only c) ?expires:(expires c)
252 ?same_site:(same_site c) ~creation_time:(creation_time c) ~last_access:now ()
253 else c)
254 jar.cookies
255 in
256 jar.cookies <- updated;
257 Eio.Mutex.unlock jar.mutex;
258
259 Log.debug (fun m -> m "Found %d applicable cookies" (List.length applicable));
260 applicable
261
262let clear jar =
263 Log.info (fun m -> m "Clearing all cookies");
264 Eio.Mutex.lock jar.mutex;
265 jar.cookies <- [];
266 Eio.Mutex.unlock jar.mutex
267
268let clear_expired jar ~clock =
269 Eio.Mutex.lock jar.mutex;
270 let before_count = List.length jar.cookies in
271 jar.cookies <- List.filter (fun c -> not (is_expired c clock)) jar.cookies;
272 let removed = before_count - List.length jar.cookies in
273 Eio.Mutex.unlock jar.mutex;
274 Log.info (fun m -> m "Cleared %d expired cookies" removed)
275
276let clear_session_cookies jar =
277 Eio.Mutex.lock jar.mutex;
278 let before_count = List.length jar.cookies in
279 jar.cookies <- List.filter (fun c -> expires c <> None) jar.cookies;
280 let removed = before_count - List.length jar.cookies in
281 Eio.Mutex.unlock jar.mutex;
282 Log.info (fun m -> m "Cleared %d session cookies" removed)
283
284let count jar =
285 Eio.Mutex.lock jar.mutex;
286 let n = List.length jar.cookies in
287 Eio.Mutex.unlock jar.mutex;
288 n
289
290let get_all_cookies jar =
291 Eio.Mutex.lock jar.mutex;
292 let cookies = jar.cookies in
293 Eio.Mutex.unlock jar.mutex;
294 cookies
295
296let is_empty jar =
297 Eio.Mutex.lock jar.mutex;
298 let empty = jar.cookies = [] in
299 Eio.Mutex.unlock jar.mutex;
300 empty
301
302(** {1 Mozilla Format} *)
303
304let to_mozilla_format_internal jar =
305 let buffer = Buffer.create 1024 in
306 Buffer.add_string buffer "# Netscape HTTP Cookie File\n";
307 Buffer.add_string buffer "# This is a generated file! Do not edit.\n\n";
308
309 List.iter
310 (fun cookie ->
311 let include_subdomains =
312 if String.starts_with ~prefix:"." (domain cookie) then "TRUE" else "FALSE"
313 in
314 let secure_flag = if secure cookie then "TRUE" else "FALSE" in
315 let expires_str =
316 match expires cookie with
317 | None -> "0" (* Session cookie *)
318 | Some t ->
319 let epoch = Ptime.to_float_s t |> int_of_float |> string_of_int in
320 epoch
321 in
322
323 Buffer.add_string buffer
324 (Printf.sprintf "%s\t%s\t%s\t%s\t%s\t%s\t%s\n" (domain cookie)
325 include_subdomains (path cookie) secure_flag expires_str (name cookie)
326 (value cookie)))
327 jar.cookies;
328
329 Buffer.contents buffer
330
331let to_mozilla_format jar =
332 Eio.Mutex.lock jar.mutex;
333 let result = to_mozilla_format_internal jar in
334 Eio.Mutex.unlock jar.mutex;
335 result
336
337let from_mozilla_format content =
338 Log.debug (fun m -> m "Parsing Mozilla format cookies");
339 let jar = create () in
340
341 let lines = String.split_on_char '\n' content in
342 List.iter
343 (fun line ->
344 let line = String.trim line in
345 if line <> "" && not (String.starts_with ~prefix:"#" line) then
346 match String.split_on_char '\t' line with
347 | [ domain; _include_subdomains; path; secure; expires; name; value ] ->
348 let now =
349 Ptime.of_float_s (Unix.time ())
350 |> Option.value ~default:Ptime.epoch
351 in
352 let expires =
353 let exp_int = try int_of_string expires with _ -> 0 in
354 if exp_int = 0 then None
355 else Ptime.of_float_s (float_of_int exp_int)
356 in
357
358 let cookie =
359 make ~domain ~path ~name ~value
360 ~secure:(secure = "TRUE") ~http_only:false
361 ?expires ?same_site:None
362 ~creation_time:now ~last_access:now ()
363 in
364 add_cookie jar cookie;
365 Log.debug (fun m -> m "Loaded cookie: %s=%s" name value)
366 | _ -> Log.warn (fun m -> m "Invalid cookie line: %s" line))
367 lines;
368
369 Log.info (fun m -> m "Loaded %d cookies" (List.length jar.cookies));
370 jar
371
372(** {1 File Operations} *)
373
374let load path =
375 Log.info (fun m -> m "Loading cookies from %a" Eio.Path.pp path);
376
377 try
378 let content = Eio.Path.load path in
379 from_mozilla_format content
380 with
381 | Eio.Io _ ->
382 Log.info (fun m -> m "Cookie file not found, creating empty jar");
383 create ()
384 | exn ->
385 Log.err (fun m -> m "Failed to load cookies: %s" (Printexc.to_string exn));
386 create ()
387
388let save path jar =
389 Log.info (fun m ->
390 m "Saving %d cookies to %a" (List.length jar.cookies) Eio.Path.pp path);
391
392 let content = to_mozilla_format jar in
393
394 try
395 Eio.Path.save ~create:(`Or_truncate 0o600) path content;
396 Log.debug (fun m -> m "Cookies saved successfully")
397 with exn ->
398 Log.err (fun m -> m "Failed to save cookies: %s" (Printexc.to_string exn))