anil.recoil.org
OCaml HTTP cookie handling library with support for Eio-based storage jars
optimise
+68
-113
+40
-54
lib/core/cookeio.ml
+40
-54
lib/core/cookeio.ml
···
356
356
(* IP addresses bypass PSL check per RFC 6265 Section 5.1.3 *)
357
357
match Ipaddr.of_string cookie_domain with
358
358
| Ok _ -> Ok () (* IP addresses are not subject to PSL rules *)
359
-
| Error _ ->
359
+
| Error _ -> (
360
360
let psl = Lazy.force psl in
361
-
(match Publicsuffix.is_public_suffix psl cookie_domain with
362
-
| Error _ ->
363
-
(* If PSL lookup fails (e.g., invalid domain), allow the cookie.
364
-
Domain name validation is handled separately. *)
365
-
Ok ()
366
-
| Ok false ->
367
-
(* Not a public suffix, allow the cookie *)
361
+
match Publicsuffix.is_public_suffix psl cookie_domain with
362
+
| Error _ | Ok false ->
363
+
(* If PSL lookup fails (e.g., invalid domain) or not a public suffix,
364
+
allow the cookie. Domain name validation is handled separately. *)
368
365
Ok ()
369
366
| Ok true ->
370
367
(* It's a public suffix - only allow if request host matches exactly.
···
500
497
501
498
(** Parse HTTP date by trying all supported formats in sequence *)
502
499
let parse_http_date s =
503
-
match parse_fmt1 s with
504
-
| Some t -> Some t
505
-
| None -> (
506
-
match parse_fmt2 s with
507
-
| Some t -> Some t
508
-
| None -> (
509
-
match parse_fmt3 s with Some t -> Some t | None -> parse_fmt4 s))
500
+
let ( <|> ) a b = match a with Some _ -> a | None -> b () in
501
+
parse_fmt1 s <|> fun () ->
502
+
parse_fmt2 s <|> fun () ->
503
+
parse_fmt3 s <|> fun () ->
504
+
parse_fmt4 s
510
505
end
511
506
512
507
(** {1 Cookie Parsing} *)
···
605
600
@see <https://datatracker.ietf.org/doc/html/draft-ietf-httpbis-rfc6265bis#section-5.4.7> RFC 6265bis Section 5.4.7 - SameSite
606
601
@see <https://developer.chrome.com/docs/privacy-sandbox/chips/> CHIPS - Cookies Having Independent Partitioned State *)
607
602
let validate_attributes attrs =
608
-
(* SameSite=None requires Secure flag *)
609
-
let samesite_valid =
610
-
match attrs.same_site with
611
-
| Some `None when not attrs.secure ->
612
-
Log.warn (fun m ->
613
-
m
614
-
"Cookie has SameSite=None but Secure flag is not set; this \
615
-
violates RFC requirements");
616
-
false
617
-
| _ -> true
618
-
in
619
-
(* Partitioned requires Secure flag *)
620
-
let partitioned_valid =
621
-
if attrs.partitioned && not attrs.secure then (
603
+
match (attrs.same_site, attrs.secure, attrs.partitioned) with
604
+
| Some `None, false, _ ->
605
+
Log.warn (fun m ->
606
+
m
607
+
"Cookie has SameSite=None but Secure flag is not set; this \
608
+
violates RFC requirements");
609
+
false
610
+
| _, false, true ->
622
611
Log.warn (fun m ->
623
612
m
624
613
"Cookie has Partitioned attribute but Secure flag is not set; this \
625
614
violates CHIPS requirements");
626
-
false)
627
-
else true
628
-
in
629
-
samesite_valid && partitioned_valid
615
+
false
616
+
| _ -> true
630
617
631
618
(** Build final cookie from name/value and accumulated attributes.
632
619
···
896
883
Buffer.add_string buffer (Printf.sprintf "%s=%s" (name cookie) (value cookie));
897
884
898
885
(* Add Max-Age if present *)
899
-
(match max_age cookie with
900
-
| Some span -> (
901
-
match Ptime.Span.to_int_s span with
902
-
| Some seconds ->
903
-
Buffer.add_string buffer (Printf.sprintf "; Max-Age=%d" seconds)
904
-
| None -> ())
905
-
| None -> ());
886
+
Option.iter
887
+
(fun span ->
888
+
Option.iter
889
+
(fun seconds ->
890
+
Buffer.add_string buffer (Printf.sprintf "; Max-Age=%d" seconds))
891
+
(Ptime.Span.to_int_s span))
892
+
(max_age cookie);
906
893
907
894
(* Add Expires if present *)
908
-
(match expires cookie with
909
-
| Some `Session ->
910
-
(* Session cookies can be indicated with Expires=0 or a past date *)
911
-
Buffer.add_string buffer "; Expires=0"
912
-
| Some (`DateTime exp_time) ->
913
-
(* Format as HTTP date *)
914
-
let exp_str = Ptime.to_rfc3339 ~tz_offset_s:0 exp_time in
915
-
Buffer.add_string buffer (Printf.sprintf "; Expires=%s" exp_str)
916
-
| None -> ());
895
+
Option.iter
896
+
(function
897
+
| `Session -> Buffer.add_string buffer "; Expires=0"
898
+
| `DateTime exp_time ->
899
+
let exp_str = Ptime.to_rfc3339 ~tz_offset_s:0 exp_time in
900
+
Buffer.add_string buffer (Printf.sprintf "; Expires=%s" exp_str))
901
+
(expires cookie);
917
902
918
903
(* Add Domain *)
919
904
Buffer.add_string buffer (Printf.sprintf "; Domain=%s" (domain cookie));
···
931
916
if partitioned cookie then Buffer.add_string buffer "; Partitioned";
932
917
933
918
(* Add SameSite *)
934
-
(match same_site cookie with
935
-
| Some `Strict -> Buffer.add_string buffer "; SameSite=Strict"
936
-
| Some `Lax -> Buffer.add_string buffer "; SameSite=Lax"
937
-
| Some `None -> Buffer.add_string buffer "; SameSite=None"
938
-
| None -> ());
919
+
Option.iter
920
+
(function
921
+
| `Strict -> Buffer.add_string buffer "; SameSite=Strict"
922
+
| `Lax -> Buffer.add_string buffer "; SameSite=Lax"
923
+
| `None -> Buffer.add_string buffer "; SameSite=None")
924
+
(same_site cookie);
939
925
940
926
Buffer.contents buffer
+28
-59
lib/jar/cookeio_jar.ml
+28
-59
lib/jar/cookeio_jar.ml
···
43
43
String.sub domain 1 (String.length domain - 1)
44
44
| _ -> domain
45
45
46
+
(** Remove duplicate cookies, keeping the last occurrence.
47
+
48
+
Used to deduplicate combined cookie lists where delta cookies should
49
+
take precedence over original cookies. *)
50
+
let dedup_by_identity cookies =
51
+
let rec aux acc = function
52
+
| [] -> List.rev acc
53
+
| c :: rest ->
54
+
let has_duplicate =
55
+
List.exists (fun c2 -> cookie_identity_matches c c2) rest
56
+
in
57
+
if has_duplicate then aux acc rest else aux (c :: acc) rest
58
+
in
59
+
aux [] cookies
60
+
46
61
(** Check if a string is an IP address (IPv4 or IPv6).
47
62
48
63
Per RFC 6265 Section 5.1.3, domain matching should only apply to hostnames,
49
64
not IP addresses. IP addresses require exact match only.
50
65
51
66
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.1.3> RFC 6265 Section 5.1.3 - Domain Matching *)
52
-
let is_ip_address domain =
53
-
match Ipaddr.of_string domain with
54
-
| Ok _ -> true
55
-
| Error _ -> false
67
+
let is_ip_address domain = Result.is_ok (Ipaddr.of_string domain)
56
68
57
69
(** Check if a cookie domain matches a request domain.
58
70
···
74
86
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.1.3> RFC 6265 Section 5.1.3 - Domain Matching
75
87
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model (host-only-flag) *)
76
88
let domain_matches ~host_only cookie_domain request_domain =
77
-
if is_ip_address request_domain then
78
-
(* IP addresses: exact match only per Section 5.1.3 *)
79
-
request_domain = cookie_domain
80
-
else
81
-
(* Hostnames: exact match or subdomain match (if not host_only) *)
82
-
request_domain = cookie_domain
83
-
|| (not host_only
84
-
&& String.ends_with ~suffix:("." ^ cookie_domain) request_domain)
89
+
request_domain = cookie_domain
90
+
|| (not (is_ip_address request_domain || host_only)
91
+
&& String.ends_with ~suffix:("." ^ cookie_domain) request_domain)
85
92
86
93
(** Check if a cookie path matches a request path.
87
94
···
347
354
348
355
(* Combine original and delta cookies, with delta taking precedence *)
349
356
let all_cookies = jar.original_cookies @ jar.delta_cookies in
350
-
351
-
(* Filter out duplicates, keeping the last occurrence (from delta) *)
352
-
let rec dedup acc = function
353
-
| [] -> List.rev acc
354
-
| c :: rest ->
355
-
(* Keep this cookie only if no later cookie has the same identity *)
356
-
let has_duplicate =
357
-
List.exists (fun c2 -> cookie_identity_matches c c2) rest
358
-
in
359
-
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
360
-
in
361
-
let unique_cookies = dedup [] all_cookies in
357
+
let unique_cookies = dedup_by_identity all_cookies in
362
358
363
359
(* Filter for applicable cookies, excluding removal cookies and expired cookies *)
364
360
let applicable =
···
452
448
453
449
let count jar =
454
450
Eio.Mutex.lock jar.mutex;
455
-
(* Combine and deduplicate cookies for count *)
456
451
let all_cookies = jar.original_cookies @ jar.delta_cookies in
457
-
let rec dedup acc = function
458
-
| [] -> List.rev acc
459
-
| c :: rest ->
460
-
let has_duplicate =
461
-
List.exists (fun c2 -> cookie_identity_matches c c2) rest
462
-
in
463
-
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
464
-
in
465
-
let unique = dedup [] all_cookies in
452
+
let unique = dedup_by_identity all_cookies in
466
453
let n = List.length unique in
467
454
Eio.Mutex.unlock jar.mutex;
468
455
n
469
456
470
457
let get_all_cookies jar =
471
458
Eio.Mutex.lock jar.mutex;
472
-
(* Combine and deduplicate, with delta taking precedence *)
473
459
let all_cookies = jar.original_cookies @ jar.delta_cookies in
474
-
let rec dedup acc = function
475
-
| [] -> List.rev acc
476
-
| c :: rest ->
477
-
let has_duplicate =
478
-
List.exists (fun c2 -> cookie_identity_matches c c2) rest
479
-
in
480
-
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
481
-
in
482
-
let unique = dedup [] all_cookies in
460
+
let unique = dedup_by_identity all_cookies in
483
461
Eio.Mutex.unlock jar.mutex;
484
462
unique
485
463
···
498
476
499
477
(* Combine and deduplicate cookies *)
500
478
let all_cookies = jar.original_cookies @ jar.delta_cookies in
501
-
let rec dedup acc = function
502
-
| [] -> List.rev acc
503
-
| c :: rest ->
504
-
let has_duplicate =
505
-
List.exists (fun c2 -> cookie_identity_matches c c2) rest
506
-
in
507
-
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
508
-
in
509
-
let unique = dedup [] all_cookies in
479
+
let unique = dedup_by_identity all_cookies in
510
480
511
481
List.iter
512
482
(fun cookie ->
···
552
522
|> Option.value ~default:Ptime.epoch
553
523
in
554
524
let expires =
555
-
let exp_int = try int_of_string expires with _ -> 0 in
556
-
if exp_int = 0 then None
557
-
else
558
-
match Ptime.of_float_s (float_of_int exp_int) with
559
-
| Some t -> Some (`DateTime t)
560
-
| None -> None
525
+
match int_of_string_opt expires with
526
+
| Some exp_int when exp_int <> 0 ->
527
+
Option.map (fun t -> `DateTime t)
528
+
(Ptime.of_float_s (float_of_int exp_int))
529
+
| _ -> None
561
530
in
562
531
(* Mozilla format: include_subdomains=TRUE means host_only=false *)
563
532
let host_only = include_subdomains <> "TRUE" in