commit 955403b684c48ed0207340fe1b71709f01752aed · anil.recoil.org/ocaml-cookeio

+40 -54

lib/core/cookeio.ml

···

       356
        
         (* IP addresses bypass PSL check per RFC 6265 Section 5.1.3 *)

     

       357
        
         match Ipaddr.of_string cookie_domain with

     

       358
        
         | Ok _ -> Ok () (* IP addresses are not subject to PSL rules *)

     

       359
       -
         | Error _ ->

     

       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 *)

     

       368
        
                 Ok ()

     

       369
        
             | Ok true ->

     

       370
        
                 (* It's a public suffix - only allow if request host matches exactly.

     
···

       500
        
       

     

       501
        
         (** Parse HTTP date by trying all supported formats in sequence *)

     

       502
        
         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))

     

       510
        
       end

     

       511
        
       

     

       512
        
       (** {1 Cookie Parsing} *)

     
···

       605
        
           @see <https://datatracker.ietf.org/doc/html/draft-ietf-httpbis-rfc6265bis#section-5.4.7> RFC 6265bis Section 5.4.7 - SameSite

     

       606
        
           @see <https://developer.chrome.com/docs/privacy-sandbox/chips/> CHIPS - Cookies Having Independent Partitioned State *)

     

       607
        
       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 (

     

       622
        
             Log.warn (fun m ->

     

       623
        
                 m

     

       624
        
                   "Cookie has Partitioned attribute but Secure flag is not set; this \

     

       625
        
                    violates CHIPS requirements");

     

       626
       -
             false)

     

       627
       -
           else true

     

       628
       -
         in

     

       629
       -
         samesite_valid && partitioned_valid

     

       630
        
       

     

       631
        
       (** Build final cookie from name/value and accumulated attributes.

     

       632
        
       

     
···

       896
        
         Buffer.add_string buffer (Printf.sprintf "%s=%s" (name cookie) (value cookie));

     

       897
        
       

     

       898
        
         (* 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 -> ());

     

       906
        
       

     

       907
        
         (* 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 -> ());

     

       917
        
       

     

       918
        
         (* Add Domain *)

     

       919
        
         Buffer.add_string buffer (Printf.sprintf "; Domain=%s" (domain cookie));

     
···

       931
        
         if partitioned cookie then Buffer.add_string buffer "; Partitioned";

     

       932
        
       

     

       933
        
         (* 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 -> ());

     

       0
        
       
     

       939
        
       

     

       940
        
         Buffer.contents buffer

···

       356
        
         (* IP addresses bypass PSL check per RFC 6265 Section 5.1.3 *)

     

       357
        
         match Ipaddr.of_string cookie_domain with

     

       358
        
         | Ok _ -> Ok () (* IP addresses are not subject to PSL rules *)

     

       359
       +
         | Error _ -> (

     

       360
        
             let psl = Lazy.force psl in

     

       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. *)

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       365
        
                 Ok ()

     

       366
        
             | Ok true ->

     

       367
        
                 (* It's a public suffix - only allow if request host matches exactly.

     
···

       497
        
       

     

       498
        
         (** Parse HTTP date by trying all supported formats in sequence *)

     

       499
        
         let parse_http_date 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

     

       0
        
       
     

       0
        
       
     

       505
        
       end

     

       506
        
       

     

       507
        
       (** {1 Cookie Parsing} *)

     
···

       600
        
           @see <https://datatracker.ietf.org/doc/html/draft-ietf-httpbis-rfc6265bis#section-5.4.7> RFC 6265bis Section 5.4.7 - SameSite

     

       601
        
           @see <https://developer.chrome.com/docs/privacy-sandbox/chips/> CHIPS - Cookies Having Independent Partitioned State *)

     

       602
        
       let validate_attributes attrs =

     

       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 ->

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       611
        
             Log.warn (fun m ->

     

       612
        
                 m

     

       613
        
                   "Cookie has Partitioned attribute but Secure flag is not set; this \

     

       614
        
                    violates CHIPS requirements");

     

       615
       +
             false

     

       616
       +
         | _ -> true

     

       0
        
       
     

       0
        
       
     

       617
        
       

     

       618
        
       (** Build final cookie from name/value and accumulated attributes.

     

       619
        
       

     
···

       883
        
         Buffer.add_string buffer (Printf.sprintf "%s=%s" (name cookie) (value cookie));

     

       884
        
       

     

       885
        
         (* Add Max-Age if present *)

     

       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);

     

       893
        
       

     

       894
        
         (* Add Expires if present *)

     

       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);

     

       0
        
       
     

       0
        
       
     

       902
        
       

     

       903
        
         (* Add Domain *)

     

       904
        
         Buffer.add_string buffer (Printf.sprintf "; Domain=%s" (domain cookie));

     
···

       916
        
         if partitioned cookie then Buffer.add_string buffer "; Partitioned";

     

       917
        
       

     

       918
        
         (* Add SameSite *)

     

       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);

     

       925
        
       

     

       926
        
         Buffer.contents buffer

+28 -59

lib/jar/cookeio_jar.ml

···

       43
        
             String.sub domain 1 (String.length domain - 1)

     

       44
        
         | _ -> domain

     

       45
        
       

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       46
        
       (** Check if a string is an IP address (IPv4 or IPv6).

     

       47
        
       

     

       48
        
           Per RFC 6265 Section 5.1.3, domain matching should only apply to hostnames,

     

       49
        
           not IP addresses. IP addresses require exact match only.

     

       50
        
       

     

       51
        
           @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

     

       56
        
       

     

       57
        
       (** Check if a cookie domain matches a request domain.

     

       58
        
       

     
···

       74
        
           @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.1.3> RFC 6265 Section 5.1.3 - Domain Matching

     

       75
        
           @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model (host-only-flag) *)

     

       76
        
       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)

     

       85
        
       

     

       86
        
       (** Check if a cookie path matches a request path.

     

       87
        
       

     
···

       347
        
       

     

       348
        
         (* Combine original and delta cookies, with delta taking precedence *)

     

       349
        
         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

     

       362
        
       

     

       363
        
         (* Filter for applicable cookies, excluding removal cookies and expired cookies *)

     

       364
        
         let applicable =

     
···

       452
        
       

     

       453
        
       let count jar =

     

       454
        
         Eio.Mutex.lock jar.mutex;

     

       455
       -
         (* Combine and deduplicate cookies for count *)

     

       456
        
         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

     

       466
        
         let n = List.length unique in

     

       467
        
         Eio.Mutex.unlock jar.mutex;

     

       468
        
         n

     

       469
        
       

     

       470
        
       let get_all_cookies jar =

     

       471
        
         Eio.Mutex.lock jar.mutex;

     

       472
       -
         (* Combine and deduplicate, with delta taking precedence *)

     

       473
        
         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

     

       483
        
         Eio.Mutex.unlock jar.mutex;

     

       484
        
         unique

     

       485
        
       

     
···

       498
        
       

     

       499
        
         (* Combine and deduplicate cookies *)

     

       500
        
         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

     

       510
        
       

     

       511
        
         List.iter

     

       512
        
           (fun cookie ->

     
···

       552
        
                     |> Option.value ~default:Ptime.epoch

     

       553
        
                   in

     

       554
        
                   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

     

       561
        
                   in

     

       562
        
                   (* Mozilla format: include_subdomains=TRUE means host_only=false *)

     

       563
        
                   let host_only = include_subdomains <> "TRUE" in

···

       43
        
             String.sub domain 1 (String.length domain - 1)

     

       44
        
         | _ -> domain

     

       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
       +
       

     

       61
        
       (** Check if a string is an IP address (IPv4 or IPv6).

     

       62
        
       

     

       63
        
           Per RFC 6265 Section 5.1.3, domain matching should only apply to hostnames,

     

       64
        
           not IP addresses. IP addresses require exact match only.

     

       65
        
       

     

       66
        
           @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.1.3> RFC 6265 Section 5.1.3 - Domain Matching *)

     

       67
       +
       let is_ip_address domain = Result.is_ok (Ipaddr.of_string domain)

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       68
        
       

     

       69
        
       (** Check if a cookie domain matches a request domain.

     

       70
        
       

     
···

       86
        
           @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.1.3> RFC 6265 Section 5.1.3 - Domain Matching

     

       87
        
           @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model (host-only-flag) *)

     

       88
        
       let domain_matches ~host_only 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)

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       92
        
       

     

       93
        
       (** Check if a cookie path matches a request path.

     

       94
        
       

     
···

       354
        
       

     

       355
        
         (* Combine original and delta cookies, with delta taking precedence *)

     

       356
        
         let all_cookies = jar.original_cookies @ jar.delta_cookies in

     

       357
       +
         let unique_cookies = dedup_by_identity all_cookies in

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       358
        
       

     

       359
        
         (* Filter for applicable cookies, excluding removal cookies and expired cookies *)

     

       360
        
         let applicable =

     
···

       448
        
       

     

       449
        
       let count jar =

     

       450
        
         Eio.Mutex.lock jar.mutex;

     

       0
        
       
     

       451
        
         let all_cookies = jar.original_cookies @ jar.delta_cookies in

     

       452
       +
         let unique = dedup_by_identity all_cookies in

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       453
        
         let n = List.length unique in

     

       454
        
         Eio.Mutex.unlock jar.mutex;

     

       455
        
         n

     

       456
        
       

     

       457
        
       let get_all_cookies jar =

     

       458
        
         Eio.Mutex.lock jar.mutex;

     

       0
        
       
     

       459
        
         let all_cookies = jar.original_cookies @ jar.delta_cookies in

     

       460
       +
         let unique = dedup_by_identity all_cookies in

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       461
        
         Eio.Mutex.unlock jar.mutex;

     

       462
        
         unique

     

       463
        
       

     
···

       476
        
       

     

       477
        
         (* Combine and deduplicate cookies *)

     

       478
        
         let all_cookies = jar.original_cookies @ jar.delta_cookies in

     

       479
       +
         let unique = dedup_by_identity all_cookies in

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       480
        
       

     

       481
        
         List.iter

     

       482
        
           (fun cookie ->

     
···

       522
        
                     |> Option.value ~default:Ptime.epoch

     

       523
        
                   in

     

       524
        
                   let expires =

     

       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

     

       0
        
       
     

       530
        
                   in

     

       531
        
                   (* Mozilla format: include_subdomains=TRUE means host_only=false *)

     

       532
        
                   let host_only = include_subdomains <> "TRUE" in