···
1
-
let src = Logs.Src.create "cookeio" ~doc:"Cookie management"
3
-
module Log = (val Logs.src_log src : Logs.LOG)
5
-
module SameSite = struct
6
-
type t = [ `Strict | `Lax | `None ]
10
-
let pp ppf = function
11
-
| `Strict -> Format.pp_print_string ppf "Strict"
12
-
| `Lax -> Format.pp_print_string ppf "Lax"
13
-
| `None -> Format.pp_print_string ppf "None"
16
-
module Expiration = struct
17
-
type t = [ `Session | `DateTime of Ptime.t ]
21
-
| `Session, `Session -> true
22
-
| `DateTime t1, `DateTime t2 -> Ptime.equal t1 t2
25
-
let pp ppf = function
26
-
| `Session -> Format.pp_print_string ppf "Session"
27
-
| `DateTime t -> Format.fprintf ppf "DateTime(%a)" Ptime.pp t
38
-
expires : Expiration.t option;
39
-
max_age : Ptime.Span.t option;
40
-
same_site : SameSite.t option;
41
-
creation_time : Ptime.t;
42
-
last_access : Ptime.t;
47
-
mutable original_cookies : t list; (* from client *)
48
-
mutable delta_cookies : t list; (* to send back *)
49
-
mutex : Eio.Mutex.t;
51
-
(** Cookie jar for storing and managing cookies *)
53
-
(** {1 Cookie Accessors} *)
55
-
let domain cookie = cookie.domain
56
-
let path cookie = cookie.path
57
-
let name cookie = cookie.name
58
-
let value cookie = cookie.value
60
-
let value_trimmed cookie =
61
-
let v = cookie.value in
62
-
let len = String.length v in
65
-
match (v.[0], v.[len - 1]) with
66
-
| '"', '"' -> String.sub v 1 (len - 2)
69
-
let secure cookie = cookie.secure
70
-
let http_only cookie = cookie.http_only
71
-
let partitioned cookie = cookie.partitioned
72
-
let expires cookie = cookie.expires
73
-
let max_age cookie = cookie.max_age
74
-
let same_site cookie = cookie.same_site
75
-
let creation_time cookie = cookie.creation_time
76
-
let last_access cookie = cookie.last_access
78
-
let make ~domain ~path ~name ~value ?(secure = false) ?(http_only = false)
79
-
?expires ?max_age ?same_site ?(partitioned = false) ~creation_time
96
-
(** {1 Cookie Jar Creation} *)
99
-
Log.debug (fun m -> m "Creating new empty cookie jar");
100
-
{ original_cookies = []; delta_cookies = []; mutex = Eio.Mutex.create () }
102
-
(** {1 Cookie Matching Helpers} *)
104
-
let cookie_identity_matches c1 c2 =
105
-
name c1 = name c2 && domain c1 = domain c2 && path c1 = path c2
107
-
let normalize_domain domain =
108
-
(* Strip leading dot per RFC 6265 *)
109
-
match String.starts_with ~prefix:"." domain with
110
-
| true when String.length domain > 1 ->
111
-
String.sub domain 1 (String.length domain - 1)
114
-
let domain_matches cookie_domain request_domain =
115
-
(* Cookie domains are stored without leading dots per RFC 6265.
116
-
A cookie with domain "example.com" should match both "example.com" (exact)
117
-
and "sub.example.com" (subdomain). *)
118
-
request_domain = cookie_domain
119
-
|| String.ends_with ~suffix:("." ^ cookie_domain) request_domain
121
-
let path_matches cookie_path request_path =
122
-
(* Cookie path /foo matches /foo, /foo/, /foo/bar *)
123
-
String.starts_with ~prefix:cookie_path request_path
125
-
(** {1 HTTP Date Parsing} *)
126
-
let is_expired cookie clock =
127
-
match cookie.expires with
128
-
| None -> false (* No expiration *)
129
-
| Some `Session -> false (* Session cookie - not expired until browser closes *)
130
-
| Some (`DateTime exp_time) ->
132
-
Ptime.of_float_s (Eio.Time.now clock)
133
-
|> Option.value ~default:Ptime.epoch
135
-
Ptime.compare now exp_time > 0
137
-
module DateParser = struct
138
-
(** Month name to number mapping (case-insensitive) *)
139
-
let month_of_string s =
140
-
match String.lowercase_ascii s with
155
-
(** Normalize abbreviated years:
156
-
- Years 69-99 get 1900 added (e.g., 95 → 1995)
157
-
- Years 0-68 get 2000 added (e.g., 25 → 2025)
158
-
- Years >= 100 are returned as-is *)
159
-
let normalize_year year =
160
-
if year >= 0 && year <= 68 then year + 2000
161
-
else if year >= 69 && year <= 99 then year + 1900
164
-
(** Parse FMT1: "Wed, 21 Oct 2015 07:28:00 GMT" (RFC 1123) *)
167
-
Scanf.sscanf s "%s %d %s %d %d:%d:%d %s"
168
-
(fun _wday day mon year hour min sec tz ->
169
-
(* Check timezone is GMT (case-insensitive) *)
170
-
if String.lowercase_ascii tz <> "gmt" then None
172
-
match month_of_string mon with
175
-
let year = normalize_year year in
176
-
Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
179
-
(** Parse FMT2: "Wednesday, 21-Oct-15 07:28:00 GMT" (RFC 850) *)
182
-
Scanf.sscanf s "%[^,], %d-%3s-%d %d:%d:%d %s"
183
-
(fun _wday day mon year hour min sec tz ->
184
-
(* Check timezone is GMT (case-insensitive) *)
185
-
if String.lowercase_ascii tz <> "gmt" then None
187
-
match month_of_string mon with
190
-
let year = normalize_year year in
191
-
Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
194
-
(** Parse FMT3: "Wed Oct 21 07:28:00 2015" (asctime) *)
197
-
Scanf.sscanf s "%s %s %d %d:%d:%d %d"
198
-
(fun _wday mon day hour min sec year ->
199
-
match month_of_string mon with
202
-
let year = normalize_year year in
203
-
Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
206
-
(** Parse FMT4: "Wed, 21-Oct-2015 07:28:00 GMT" (variant) *)
209
-
Scanf.sscanf s "%s %d-%3s-%d %d:%d:%d %s"
210
-
(fun _wday day mon year hour min sec tz ->
211
-
(* Check timezone is GMT (case-insensitive) *)
212
-
if String.lowercase_ascii tz <> "gmt" then None
214
-
match month_of_string mon with
217
-
let year = normalize_year year in
218
-
Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
221
-
(** Parse HTTP date by trying all supported formats in sequence *)
222
-
let parse_http_date s =
223
-
match parse_fmt1 s with
226
-
match parse_fmt2 s with
229
-
match parse_fmt3 s with Some t -> Some t | None -> parse_fmt4 s))
232
-
(** {1 Cookie Parsing} *)
234
-
type cookie_attributes = {
235
-
mutable domain : string option;
236
-
mutable path : string option;
237
-
mutable secure : bool;
238
-
mutable http_only : bool;
239
-
mutable partitioned : bool;
240
-
mutable expires : Expiration.t option;
241
-
mutable max_age : Ptime.Span.t option;
242
-
mutable same_site : SameSite.t option;
244
-
(** Accumulated attributes from parsing Set-Cookie header *)
246
-
(** Create empty attribute accumulator *)
247
-
let empty_attributes () =
253
-
partitioned = false;
259
-
(** Parse a single attribute and update the accumulator in-place *)
260
-
let parse_attribute clock attrs attr_name attr_value =
261
-
let attr_lower = String.lowercase_ascii attr_name in
262
-
match attr_lower with
263
-
| "domain" -> attrs.domain <- Some (normalize_domain attr_value)
264
-
| "path" -> attrs.path <- Some attr_value
266
-
(* Special case: Expires=0 means session cookie *)
267
-
if attr_value = "0" then attrs.expires <- Some `Session
269
-
match Ptime.of_rfc3339 attr_value with
270
-
| Ok (time, _, _) -> attrs.expires <- Some (`DateTime time)
271
-
| Error (`RFC3339 (_, err)) -> (
272
-
(* Try HTTP date format as fallback *)
273
-
match DateParser.parse_http_date attr_value with
274
-
| Some time -> attrs.expires <- Some (`DateTime time)
277
-
m "Failed to parse expires attribute '%s': %a" attr_value
278
-
Ptime.pp_rfc3339_error err)))
280
-
match int_of_string_opt attr_value with
282
-
(* Handle negative values as 0 per RFC 6265 *)
283
-
let seconds = max 0 seconds in
284
-
let now = Eio.Time.now clock in
285
-
(* Store the max-age as a Ptime.Span *)
286
-
attrs.max_age <- Some (Ptime.Span.of_int_s seconds);
287
-
(* Also compute and store expires as DateTime *)
288
-
let expires = Ptime.of_float_s (now +. float_of_int seconds) in
289
-
(match expires with
290
-
| Some time -> attrs.expires <- Some (`DateTime time)
292
-
Log.debug (fun m -> m "Parsed Max-Age: %d seconds" seconds)
295
-
m "Failed to parse max-age attribute '%s'" attr_value))
296
-
| "secure" -> attrs.secure <- true
297
-
| "httponly" -> attrs.http_only <- true
298
-
| "partitioned" -> attrs.partitioned <- true
300
-
match String.lowercase_ascii attr_value with
301
-
| "strict" -> attrs.same_site <- Some `Strict
302
-
| "lax" -> attrs.same_site <- Some `Lax
303
-
| "none" -> attrs.same_site <- Some `None
306
-
m "Invalid samesite value '%s', ignoring" attr_value))
308
-
Log.debug (fun m -> m "Unknown cookie attribute '%s', ignoring" attr_name)
310
-
(** Validate cookie attributes and log warnings for invalid combinations *)
311
-
let validate_attributes attrs =
312
-
(* SameSite=None requires Secure flag *)
313
-
let samesite_valid =
314
-
match attrs.same_site with
315
-
| Some `None when not attrs.secure ->
318
-
"Cookie has SameSite=None but Secure flag is not set; this \
319
-
violates RFC requirements");
323
-
(* Partitioned requires Secure flag *)
324
-
let partitioned_valid =
325
-
if attrs.partitioned && not attrs.secure then (
328
-
"Cookie has Partitioned attribute but Secure flag is not set; \
329
-
this violates CHIPS requirements");
333
-
samesite_valid && partitioned_valid
335
-
(** Build final cookie from name/value and accumulated attributes *)
336
-
let build_cookie ~request_domain ~request_path ~name ~value attrs ~now =
338
-
normalize_domain (Option.value attrs.domain ~default:request_domain)
340
-
let path = Option.value attrs.path ~default:request_path in
341
-
make ~domain ~path ~name ~value ~secure:attrs.secure
342
-
~http_only:attrs.http_only ?expires:attrs.expires ?max_age:attrs.max_age
343
-
?same_site:attrs.same_site ~partitioned:attrs.partitioned
344
-
~creation_time:now ~last_access:now ()
346
-
let rec parse_set_cookie ~clock ~domain:request_domain ~path:request_path
348
-
Log.debug (fun m -> m "Parsing Set-Cookie: %s" header_value);
350
-
(* Split into attributes *)
351
-
let parts = String.split_on_char ';' header_value |> List.map String.trim in
355
-
| name_value :: attrs -> (
356
-
(* Parse name=value *)
357
-
match String.index_opt name_value '=' with
360
-
let name = String.sub name_value 0 eq_pos |> String.trim in
362
-
String.sub name_value (eq_pos + 1)
363
-
(String.length name_value - eq_pos - 1)
368
-
Ptime.of_float_s (Eio.Time.now clock)
369
-
|> Option.value ~default:Ptime.epoch
372
-
(* Parse all attributes into mutable accumulator *)
373
-
let accumulated_attrs = empty_attributes () in
376
-
match String.index_opt attr '=' with
378
-
(* Attribute without value (e.g., Secure, HttpOnly) *)
379
-
parse_attribute clock accumulated_attrs attr ""
381
-
let attr_name = String.sub attr 0 eq |> String.trim in
383
-
String.sub attr (eq + 1) (String.length attr - eq - 1)
386
-
parse_attribute clock accumulated_attrs attr_name attr_value)
389
-
(* Validate attributes *)
390
-
if not (validate_attributes accumulated_attrs) then (
391
-
Log.warn (fun m -> m "Cookie validation failed, rejecting cookie");
395
-
build_cookie ~request_domain ~request_path ~name
396
-
~value:cookie_value accumulated_attrs ~now
398
-
Log.debug (fun m -> m "Parsed cookie: %a" pp cookie);
401
-
and of_cookie_header ~clock ~domain ~path header_value =
402
-
Log.debug (fun m -> m "Parsing Cookie header: %s" header_value);
404
-
(* Split on semicolons *)
405
-
let parts = String.split_on_char ';' header_value |> List.map String.trim in
407
-
(* Filter out empty parts *)
408
-
let parts = List.filter (fun s -> String.length s > 0) parts in
410
-
(* Parse each name=value pair *)
413
-
match String.index_opt name_value '=' with
415
-
Error (Printf.sprintf "Cookie missing '=' separator: %s" name_value)
417
-
let cookie_name = String.sub name_value 0 eq_pos |> String.trim in
418
-
if String.length cookie_name = 0 then
419
-
Error "Cookie has empty name"
422
-
String.sub name_value (eq_pos + 1)
423
-
(String.length name_value - eq_pos - 1)
427
-
Ptime.of_float_s (Eio.Time.now clock)
428
-
|> Option.value ~default:Ptime.epoch
430
-
(* Create cookie with defaults from Cookie header context *)
432
-
make ~domain ~path ~name:cookie_name ~value:cookie_value
433
-
~secure:false ~http_only:false ~partitioned:false ~creation_time:now
434
-
~last_access:now ()
439
-
and make_cookie_header cookies =
441
-
|> List.map (fun c -> Printf.sprintf "%s=%s" (name c) (value c))
442
-
|> String.concat "; "
444
-
and make_set_cookie_header cookie =
445
-
let buffer = Buffer.create 128 in
446
-
Buffer.add_string buffer (Printf.sprintf "%s=%s" (name cookie) (value cookie));
448
-
(* Add Max-Age if present *)
449
-
(match max_age cookie with
451
-
match Ptime.Span.to_int_s span with
453
-
Buffer.add_string buffer (Printf.sprintf "; Max-Age=%d" seconds)
457
-
(* Add Expires if present *)
458
-
(match expires cookie with
460
-
(* Session cookies can be indicated with Expires=0 or a past date *)
461
-
Buffer.add_string buffer "; Expires=0"
462
-
| Some (`DateTime exp_time) ->
463
-
(* Format as HTTP date *)
464
-
let exp_str = Ptime.to_rfc3339 ~tz_offset_s:0 exp_time in
465
-
Buffer.add_string buffer (Printf.sprintf "; Expires=%s" exp_str)
469
-
Buffer.add_string buffer (Printf.sprintf "; Domain=%s" (domain cookie));
472
-
Buffer.add_string buffer (Printf.sprintf "; Path=%s" (path cookie));
474
-
(* Add Secure flag *)
475
-
if secure cookie then Buffer.add_string buffer "; Secure";
477
-
(* Add HttpOnly flag *)
478
-
if http_only cookie then Buffer.add_string buffer "; HttpOnly";
480
-
(* Add Partitioned flag *)
481
-
if partitioned cookie then Buffer.add_string buffer "; Partitioned";
484
-
(match same_site cookie with
485
-
| Some `Strict -> Buffer.add_string buffer "; SameSite=Strict"
486
-
| Some `Lax -> Buffer.add_string buffer "; SameSite=Lax"
487
-
| Some `None -> Buffer.add_string buffer "; SameSite=None"
490
-
Buffer.contents buffer
492
-
(** {1 Pretty Printing} *)
494
-
and pp ppf cookie =
496
-
"@[<hov 2>{ name=%S;@ value=%S;@ domain=%S;@ path=%S;@ secure=%b;@ \
497
-
http_only=%b;@ partitioned=%b;@ expires=%a;@ max_age=%a;@ same_site=%a }@]"
498
-
(name cookie) (value cookie) (domain cookie) (path cookie) (secure cookie)
499
-
(http_only cookie) (partitioned cookie)
500
-
(Format.pp_print_option Expiration.pp)
502
-
(Format.pp_print_option Ptime.Span.pp)
504
-
(Format.pp_print_option SameSite.pp)
507
-
let pp_jar ppf jar =
508
-
Eio.Mutex.lock jar.mutex;
509
-
let original = jar.original_cookies in
510
-
let delta = jar.delta_cookies in
511
-
Eio.Mutex.unlock jar.mutex;
513
-
let all_cookies = original @ delta in
514
-
Format.fprintf ppf "@[<v>CookieJar with %d cookies (%d original, %d delta):@,"
515
-
(List.length all_cookies) (List.length original) (List.length delta);
516
-
List.iter (fun cookie -> Format.fprintf ppf " %a@," pp cookie) all_cookies;
517
-
Format.fprintf ppf "@]"
519
-
(** {1 Cookie Management} *)
521
-
let add_cookie jar cookie =
522
-
Log.debug (fun m ->
523
-
m "Adding cookie to delta: %s=%s for domain %s" (name cookie)
524
-
(value cookie) (domain cookie));
526
-
Eio.Mutex.lock jar.mutex;
527
-
(* Remove existing cookie with same identity from delta *)
528
-
jar.delta_cookies <-
530
-
(fun c -> not (cookie_identity_matches c cookie))
532
-
jar.delta_cookies <- cookie :: jar.delta_cookies;
533
-
Eio.Mutex.unlock jar.mutex
535
-
let add_original jar cookie =
536
-
Log.debug (fun m ->
537
-
m "Adding original cookie: %s=%s for domain %s" (name cookie)
538
-
(value cookie) (domain cookie));
540
-
Eio.Mutex.lock jar.mutex;
541
-
(* Remove existing cookie with same identity from original *)
542
-
jar.original_cookies <-
544
-
(fun c -> not (cookie_identity_matches c cookie))
545
-
jar.original_cookies;
546
-
jar.original_cookies <- cookie :: jar.original_cookies;
547
-
Eio.Mutex.unlock jar.mutex
550
-
Eio.Mutex.lock jar.mutex;
551
-
let result = jar.delta_cookies in
552
-
Eio.Mutex.unlock jar.mutex;
553
-
Log.debug (fun m -> m "Returning %d delta cookies" (List.length result));
556
-
let make_removal_cookie cookie ~clock =
558
-
Ptime.of_float_s (Eio.Time.now clock) |> Option.value ~default:Ptime.epoch
560
-
(* Create a cookie with Max-Age=0 and past expiration (1 year ago) *)
562
-
Ptime.sub_span now (Ptime.Span.of_int_s (365 * 24 * 60 * 60))
563
-
|> Option.value ~default:Ptime.epoch
565
-
make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie) ~value:""
566
-
~secure:(secure cookie) ~http_only:(http_only cookie)
567
-
~expires:(`DateTime past_expiry) ~max_age:(Ptime.Span.of_int_s 0)
568
-
?same_site:(same_site cookie) ~partitioned:(partitioned cookie)
569
-
~creation_time:now ~last_access:now ()
571
-
let remove jar ~clock cookie =
572
-
Log.debug (fun m ->
573
-
m "Removing cookie: %s=%s for domain %s" (name cookie) (value cookie)
576
-
Eio.Mutex.lock jar.mutex;
577
-
(* Check if this cookie exists in original_cookies *)
579
-
List.exists (fun c -> cookie_identity_matches c cookie) jar.original_cookies
582
-
if in_original then (
583
-
(* Create a removal cookie and add it to delta *)
584
-
let removal = make_removal_cookie cookie ~clock in
585
-
jar.delta_cookies <-
587
-
(fun c -> not (cookie_identity_matches c removal))
589
-
jar.delta_cookies <- removal :: jar.delta_cookies;
590
-
Log.debug (fun m -> m "Created removal cookie in delta for original cookie"))
592
-
(* Just remove from delta if it exists there *)
593
-
jar.delta_cookies <-
595
-
(fun c -> not (cookie_identity_matches c cookie))
597
-
Log.debug (fun m -> m "Removed cookie from delta"));
599
-
Eio.Mutex.unlock jar.mutex
601
-
let get_cookies jar ~clock ~domain:request_domain ~path:request_path ~is_secure
603
-
Log.debug (fun m ->
604
-
m "Getting cookies for domain=%s path=%s secure=%b" request_domain
605
-
request_path is_secure);
607
-
Eio.Mutex.lock jar.mutex;
609
-
(* Combine original and delta cookies, with delta taking precedence *)
610
-
let all_cookies = jar.original_cookies @ jar.delta_cookies in
612
-
(* Filter out duplicates, keeping the last occurrence (from delta) *)
613
-
let rec dedup acc = function
614
-
| [] -> List.rev acc
616
-
(* Keep this cookie only if no later cookie has the same identity *)
617
-
let has_duplicate =
618
-
List.exists (fun c2 -> cookie_identity_matches c c2) rest
620
-
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
622
-
let unique_cookies = dedup [] all_cookies in
624
-
(* Filter for applicable cookies, excluding removal cookies (empty value) *)
629
-
(* Exclude removal cookies *)
630
-
&& domain_matches (domain cookie) request_domain
631
-
&& path_matches (path cookie) request_path
632
-
&& ((not (secure cookie)) || is_secure))
636
-
(* Update last access time in both lists *)
638
-
Ptime.of_float_s (Eio.Time.now clock) |> Option.value ~default:Ptime.epoch
640
-
let update_last_access cookies =
643
-
if List.exists (fun a -> cookie_identity_matches a c) applicable then
644
-
make ~domain:(domain c) ~path:(path c) ~name:(name c) ~value:(value c)
645
-
~secure:(secure c) ~http_only:(http_only c) ?expires:(expires c)
646
-
?max_age:(max_age c) ?same_site:(same_site c)
647
-
~creation_time:(creation_time c) ~last_access:now ()
651
-
jar.original_cookies <- update_last_access jar.original_cookies;
652
-
jar.delta_cookies <- update_last_access jar.delta_cookies;
654
-
Eio.Mutex.unlock jar.mutex;
656
-
Log.debug (fun m -> m "Found %d applicable cookies" (List.length applicable));
660
-
Log.info (fun m -> m "Clearing all cookies");
661
-
Eio.Mutex.lock jar.mutex;
662
-
jar.original_cookies <- [];
663
-
jar.delta_cookies <- [];
664
-
Eio.Mutex.unlock jar.mutex
666
-
let clear_expired jar ~clock =
667
-
Eio.Mutex.lock jar.mutex;
669
-
List.length jar.original_cookies + List.length jar.delta_cookies
671
-
jar.original_cookies <-
672
-
List.filter (fun c -> not (is_expired c clock)) jar.original_cookies;
673
-
jar.delta_cookies <-
674
-
List.filter (fun c -> not (is_expired c clock)) jar.delta_cookies;
677
-
- (List.length jar.original_cookies + List.length jar.delta_cookies)
679
-
Eio.Mutex.unlock jar.mutex;
680
-
Log.info (fun m -> m "Cleared %d expired cookies" removed)
682
-
let clear_session_cookies jar =
683
-
Eio.Mutex.lock jar.mutex;
685
-
List.length jar.original_cookies + List.length jar.delta_cookies
687
-
(* Keep only cookies that are NOT session cookies *)
688
-
let is_not_session c =
689
-
match expires c with
690
-
| Some `Session -> false (* This is a session cookie, remove it *)
691
-
| None | Some (`DateTime _) -> true (* Keep these *)
693
-
jar.original_cookies <- List.filter is_not_session jar.original_cookies;
694
-
jar.delta_cookies <- List.filter is_not_session jar.delta_cookies;
697
-
- (List.length jar.original_cookies + List.length jar.delta_cookies)
699
-
Eio.Mutex.unlock jar.mutex;
700
-
Log.info (fun m -> m "Cleared %d session cookies" removed)
703
-
Eio.Mutex.lock jar.mutex;
704
-
(* Combine and deduplicate cookies for count *)
705
-
let all_cookies = jar.original_cookies @ jar.delta_cookies in
706
-
let rec dedup acc = function
707
-
| [] -> List.rev acc
709
-
let has_duplicate =
710
-
List.exists (fun c2 -> cookie_identity_matches c c2) rest
712
-
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
714
-
let unique = dedup [] all_cookies in
715
-
let n = List.length unique in
716
-
Eio.Mutex.unlock jar.mutex;
719
-
let get_all_cookies jar =
720
-
Eio.Mutex.lock jar.mutex;
721
-
(* Combine and deduplicate, with delta taking precedence *)
722
-
let all_cookies = jar.original_cookies @ jar.delta_cookies in
723
-
let rec dedup acc = function
724
-
| [] -> List.rev acc
726
-
let has_duplicate =
727
-
List.exists (fun c2 -> cookie_identity_matches c c2) rest
729
-
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
731
-
let unique = dedup [] all_cookies in
732
-
Eio.Mutex.unlock jar.mutex;
736
-
Eio.Mutex.lock jar.mutex;
737
-
let empty = jar.original_cookies = [] && jar.delta_cookies = [] in
738
-
Eio.Mutex.unlock jar.mutex;
741
-
(** {1 Mozilla Format} *)
743
-
let to_mozilla_format_internal jar =
744
-
let buffer = Buffer.create 1024 in
745
-
Buffer.add_string buffer "# Netscape HTTP Cookie File\n";
746
-
Buffer.add_string buffer "# This is a generated file! Do not edit.\n\n";
748
-
(* Combine and deduplicate cookies *)
749
-
let all_cookies = jar.original_cookies @ jar.delta_cookies in
750
-
let rec dedup acc = function
751
-
| [] -> List.rev acc
753
-
let has_duplicate =
754
-
List.exists (fun c2 -> cookie_identity_matches c c2) rest
756
-
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
758
-
let unique = dedup [] all_cookies in
762
-
let include_subdomains =
763
-
if String.starts_with ~prefix:"." (domain cookie) then "TRUE"
766
-
let secure_flag = if secure cookie then "TRUE" else "FALSE" in
768
-
match expires cookie with
769
-
| None -> "0" (* No expiration *)
770
-
| Some `Session -> "0" (* Session cookie *)
771
-
| Some (`DateTime t) ->
772
-
let epoch = Ptime.to_float_s t |> int_of_float |> string_of_int in
776
-
Buffer.add_string buffer
777
-
(Printf.sprintf "%s\t%s\t%s\t%s\t%s\t%s\t%s\n" (domain cookie)
778
-
include_subdomains (path cookie) secure_flag expires_str
779
-
(name cookie) (value cookie)))
782
-
Buffer.contents buffer
784
-
let to_mozilla_format jar =
785
-
Eio.Mutex.lock jar.mutex;
786
-
let result = to_mozilla_format_internal jar in
787
-
Eio.Mutex.unlock jar.mutex;
790
-
let from_mozilla_format ~clock content =
791
-
Log.debug (fun m -> m "Parsing Mozilla format cookies");
792
-
let jar = create () in
794
-
let lines = String.split_on_char '\n' content in
797
-
let line = String.trim line in
798
-
if line <> "" && not (String.starts_with ~prefix:"#" line) then
799
-
match String.split_on_char '\t' line with
800
-
| [ domain; _include_subdomains; path; secure; expires; name; value ] ->
802
-
Ptime.of_float_s (Eio.Time.now clock)
803
-
|> Option.value ~default:Ptime.epoch
806
-
let exp_int = try int_of_string expires with _ -> 0 in
807
-
if exp_int = 0 then None
809
-
match Ptime.of_float_s (float_of_int exp_int) with
810
-
| Some t -> Some (`DateTime t)
815
-
make ~domain:(normalize_domain domain) ~path ~name ~value
816
-
~secure:(secure = "TRUE") ~http_only:false ?expires ?max_age:None
817
-
?same_site:None ~partitioned:false ~creation_time:now
818
-
~last_access:now ()
820
-
add_original jar cookie;
821
-
Log.debug (fun m -> m "Loaded cookie: %s=%s" name value)
822
-
| _ -> Log.warn (fun m -> m "Invalid cookie line: %s" line))
825
-
Log.info (fun m -> m "Loaded %d cookies" (List.length jar.original_cookies));
828
-
(** {1 File Operations} *)
830
-
let load ~clock path =
831
-
Log.info (fun m -> m "Loading cookies from %a" Eio.Path.pp path);
834
-
let content = Eio.Path.load path in
835
-
from_mozilla_format ~clock content
838
-
Log.info (fun m -> m "Cookie file not found, creating empty jar");
841
-
Log.err (fun m -> m "Failed to load cookies: %s" (Printexc.to_string exn));
844
-
let save path jar =
845
-
Eio.Mutex.lock jar.mutex;
846
-
let total_cookies =
847
-
List.length jar.original_cookies + List.length jar.delta_cookies
849
-
Eio.Mutex.unlock jar.mutex;
850
-
Log.info (fun m -> m "Saving %d cookies to %a" total_cookies Eio.Path.pp path);
852
-
let content = to_mozilla_format jar in
855
-
Eio.Path.save ~create:(`Or_truncate 0o600) path content;
856
-
Log.debug (fun m -> m "Cookies saved successfully")
858
-
Log.err (fun m -> m "Failed to save cookies: %s" (Printexc.to_string exn))
anil.recoil.org