OCaml HTTP cookie handling library with support for Eio-based storage jars

publicsuffix

+18 -13
RFC-TODO.md
···
### 1. Public Suffix Validation (Section 5.3, Step 5)
-
**Status:** Not implemented
+
**Status:** ✅ IMPLEMENTED
The RFC requires rejecting cookies with domains that are "public suffixes" (e.g., `.com`, `.co.uk`) to prevent domain-wide cookie attacks.
-
**Required behavior:**
-
- Maintain or reference a public suffix list (e.g., from [publicsuffix.org](https://publicsuffix.org/))
-
- Reject cookies where the Domain attribute is a public suffix (unless it exactly matches the request host)
+
**Implementation:**
+
- Uses the `publicsuffix` library which embeds the Mozilla Public Suffix List at build time
+
- Validates Domain attribute in `of_set_cookie_header` before creating the cookie
+
- Rejects cookies where Domain is a public suffix (e.g., `.com`, `.co.uk`, `.github.io`)
+
- Allows cookies where the request host exactly matches the public suffix domain
+
- IP addresses bypass PSL validation (per RFC 6265 Section 5.1.3)
+
- Cookies without Domain attribute (host-only) are always allowed
-
**Security impact:** Without this, an attacker on `evil.com` could potentially set cookies for `.com` affecting all `.com` sites.
+
**Security impact:** Prevents attackers from setting domain-wide cookies that would affect all sites under a TLD.
---
···
### 4. Cookie Ordering in Header (Section 5.4, Step 2)
-
**Status:** Not implemented
+
**Status:** ✅ IMPLEMENTED
-
When generating Cookie headers, cookies SHOULD be sorted:
+
When generating Cookie headers, cookies are sorted:
1. Cookies with longer paths listed first
2. Among equal-length paths, earlier creation-times listed first
-
**Location:** `get_cookies` function in `cookeio_jar.ml`
+
**Implementation:** `get_cookies` function in `cookeio_jar.ml` uses `compare_cookie_order` to sort cookies before returning them.
---
### 5. Creation Time Preservation (Section 5.3, Step 11.3)
-
**Status:** Not implemented
+
**Status:** ✅ IMPLEMENTED
-
When replacing an existing cookie (same name/domain/path), the creation-time of the old cookie should be preserved.
+
When replacing an existing cookie (same name/domain/path), the creation-time of the old cookie is preserved.
-
**Current behavior:** Completely replaces cookie, losing original creation time.
-
-
**Location:** `add_cookie` and `add_original` functions in `cookeio_jar.ml`
+
**Implementation:** `add_cookie` and `add_original` functions in `cookeio_jar.ml` use `preserve_creation_time` to retain the original creation time when updating an existing cookie.
---
···
- [x] Host-only flag for domain matching (Section 5.3, Step 6)
- [x] Path matching algorithm (Section 5.1.4)
- [x] IP address domain matching - exact match only (Section 5.1.3)
+
- [x] Cookie ordering in headers - longer paths first, then by creation time (Section 5.4, Step 2)
+
- [x] Creation time preservation when replacing cookies (Section 5.3, Step 11.3)
+
- [x] Public suffix validation - rejects cookies for TLDs like .com (Section 5.3, Step 5)
---
+2
cookeio.opam
···
"logs" {>= "0.10.0"}
"ptime" {>= "1.1.0"}
"ipaddr" {>= "5.0.0"}
+
"domain-name" {>= "0.4.0"}
+
"publicsuffix" {>= "0.1.0"}
"eio_main"
"alcotest" {with-test}
"odoc" {with-doc}
+2
dune-project
···
(logs (>= 0.10.0))
(ptime (>= 1.1.0))
(ipaddr (>= 5.0.0))
+
(domain-name (>= 0.4.0))
+
(publicsuffix (>= 0.1.0))
eio_main
(alcotest :with-test)
(odoc :with-doc)))
+419 -61
lib/core/cookeio.ml
···
last_access;
}
+
(** {1 RFC 6265 Validation}
+
+
Validation functions for cookie names, values, and attributes per
+
{{:https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1} RFC 6265 Section 4.1.1}.
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 - Syntax *)
+
module Validate = struct
+
(** Check if a character is a valid RFC 2616 token character.
+
+
Per RFC 6265, cookie-name must be a token as defined in RFC 2616 Section 2.2:
+
token = 1*<any CHAR except CTLs or separators>
+
separators = "(" | ")" | "<" | ">" | "@" | "," | ";" | ":" | "\" |
+
<"> | "/" | "[" | "]" | "?" | "=" | "{" | "}" | SP | HT
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
+
let is_token_char = function
+
| '\x00' .. '\x1F' | '\x7F' -> false (* CTL characters *)
+
| '(' | ')' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"' | '/' | '['
+
| ']' | '?' | '=' | '{' | '}' | ' ' ->
+
false (* separators - note: HT (0x09) is already covered by CTL range *)
+
| _ -> true
+
+
(** Validate a cookie name per RFC 6265.
+
+
Cookie names must be valid RFC 2616 tokens: one or more characters
+
excluding control characters and separators.
+
+
@param name The cookie name to validate
+
@return [Ok name] if valid, [Error message] with explanation if invalid
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
+
let cookie_name name =
+
let len = String.length name in
+
if len = 0 then
+
Error "Cookie name is empty; RFC 6265 requires at least one character"
+
else
+
let rec find_invalid i acc =
+
if i >= len then acc
+
else
+
let c = String.unsafe_get name i in
+
if is_token_char c then find_invalid (i + 1) acc
+
else find_invalid (i + 1) (c :: acc)
+
in
+
match find_invalid 0 [] with
+
| [] -> Ok name
+
| invalid_chars ->
+
let chars_str =
+
invalid_chars
+
|> List.rev
+
|> List.map (fun c -> Printf.sprintf "%C" c)
+
|> String.concat ", "
+
in
+
Error
+
(Printf.sprintf
+
"Cookie name %S contains invalid characters: %s. RFC 6265 requires \
+
cookie names to be valid tokens (no control characters, spaces, \
+
or separators like ()[]{}=,;:@\\\"/?<>)"
+
name chars_str)
+
+
(** Check if a character is a valid cookie-octet.
+
+
Per RFC 6265 Section 4.1.1:
+
cookie-octet = %x21 / %x23-2B / %x2D-3A / %x3C-5B / %x5D-7E
+
(US-ASCII excluding CTLs, whitespace, DQUOTE, comma, semicolon, backslash)
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
+
let is_cookie_octet = function
+
| '\x21' -> true (* ! *)
+
| '\x23' .. '\x2B' -> true (* # $ % & ' ( ) * + *)
+
| '\x2D' .. '\x3A' -> true (* - . / 0-9 : *)
+
| '\x3C' .. '\x5B' -> true (* < = > ? @ A-Z [ *)
+
| '\x5D' .. '\x7E' -> true (* ] ^ _ ` a-z { | } ~ *)
+
| _ -> false
+
+
(** Validate a cookie value per RFC 6265.
+
+
Cookie values must contain only cookie-octets, optionally wrapped in
+
double quotes. Invalid characters include: control characters, space,
+
double quote (except as wrapper), comma, semicolon, and backslash.
+
+
@param value The cookie value to validate
+
@return [Ok value] if valid, [Error message] with explanation if invalid
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
+
let cookie_value value =
+
(* Handle optional DQUOTE wrapper *)
+
let len = String.length value in
+
let inner_value, inner_len =
+
if len >= 2 && value.[0] = '"' && value.[len - 1] = '"' then
+
(String.sub value 1 (len - 2), len - 2)
+
else (value, len)
+
in
+
let rec find_invalid i acc =
+
if i >= inner_len then acc
+
else
+
let c = String.unsafe_get inner_value i in
+
if is_cookie_octet c then find_invalid (i + 1) acc
+
else find_invalid (i + 1) (c :: acc)
+
in
+
match find_invalid 0 [] with
+
| [] -> Ok value
+
| invalid_chars ->
+
let chars_str =
+
invalid_chars
+
|> List.rev
+
|> List.map (fun c ->
+
match c with
+
| ' ' -> "space (0x20)"
+
| '"' -> "double-quote (0x22)"
+
| ',' -> "comma (0x2C)"
+
| ';' -> "semicolon (0x3B)"
+
| '\\' -> "backslash (0x5C)"
+
| c when Char.code c < 0x20 ->
+
Printf.sprintf "control char (0x%02X)" (Char.code c)
+
| c -> Printf.sprintf "%C (0x%02X)" c (Char.code c))
+
|> String.concat ", "
+
in
+
Error
+
(Printf.sprintf
+
"Cookie value %S contains invalid characters: %s. RFC 6265 cookie \
+
values may only contain printable ASCII excluding space, \
+
double-quote, comma, semicolon, and backslash"
+
value chars_str)
+
+
(** Validate a domain attribute value.
+
+
Domain values must be either:
+
- A valid domain name per RFC 1034 Section 3.5
+
- A valid IPv4 address
+
- A valid IPv6 address
+
+
@param domain The domain value to validate (leading dot is stripped first)
+
@return [Ok domain] if valid, [Error message] with explanation if invalid
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.2.3> RFC 6265 Section 4.1.2.3
+
@see <https://datatracker.ietf.org/doc/html/rfc1034#section-3.5> RFC 1034 Section 3.5 *)
+
let domain_value domain =
+
(* Strip leading dot per RFC 6265 Section 5.2.3 *)
+
let domain =
+
if String.starts_with ~prefix:"." domain && String.length domain > 1 then
+
String.sub domain 1 (String.length domain - 1)
+
else domain
+
in
+
if String.length domain = 0 then
+
Error "Domain attribute is empty"
+
else
+
(* First check if it's an IP address *)
+
match Ipaddr.of_string domain with
+
| Ok _ -> Ok domain (* Valid IP address *)
+
| Error _ -> (
+
(* Not an IP, validate as domain name using domain-name library *)
+
match Domain_name.of_string domain with
+
| Ok _ -> Ok domain
+
| Error (`Msg msg) ->
+
Error
+
(Printf.sprintf
+
"Domain %S is not a valid domain name: %s. Domain names \
+
must follow RFC 1034: labels must start with a letter, \
+
contain only letters/digits/hyphens, not end with a \
+
hyphen, and be at most 63 characters each"
+
domain msg))
+
+
(** Validate a path attribute value.
+
+
Per RFC 6265 Section 4.1.1, path-value may contain any CHAR except
+
control characters and semicolon.
+
+
@param path The path value to validate
+
@return [Ok path] if valid, [Error message] with explanation if invalid
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
+
let path_value path =
+
let len = String.length path in
+
let rec find_invalid i acc =
+
if i >= len then acc
+
else
+
let c = String.unsafe_get path i in
+
match c with
+
| '\x00' .. '\x1F' | '\x7F' | ';' -> find_invalid (i + 1) (c :: acc)
+
| _ -> find_invalid (i + 1) acc
+
in
+
match find_invalid 0 [] with
+
| [] -> Ok path
+
| invalid_chars ->
+
let chars_str =
+
invalid_chars
+
|> List.rev
+
|> List.map (fun c -> Printf.sprintf "0x%02X" (Char.code c))
+
|> String.concat ", "
+
in
+
Error
+
(Printf.sprintf
+
"Path %S contains invalid characters: %s. Paths may not contain \
+
control characters or semicolons"
+
path chars_str)
+
+
(** Validate a Max-Age attribute value.
+
+
Per RFC 6265 Section 4.1.1, max-age-av uses non-zero-digit *DIGIT.
+
However, per Section 5.2.2, user agents should treat values <= 0 as
+
"delete immediately". This function returns [Ok] for any integer since
+
the parsing code handles negative values by converting to 0.
+
+
@param seconds The Max-Age value in seconds
+
@return [Ok seconds] always (negative values are handled in parsing)
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.2.2> RFC 6265 Section 5.2.2 *)
+
let max_age seconds = Ok seconds
+
end
+
+
(** {1 Public Suffix Validation}
+
+
Per {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.3} RFC 6265 Section 5.3 Step 5},
+
cookies with Domain attributes that are public suffixes must be rejected
+
to prevent domain-wide cookie attacks.
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model
+
@see <https://publicsuffix.org/list/> Public Suffix List *)
+
+
(** Module-level Public Suffix List instance.
+
+
Lazily initialized on first use. The PSL data is compiled into the
+
publicsuffix library at build time from the Mozilla Public Suffix List. *)
+
let psl = lazy (Publicsuffix.create ())
+
+
(** Validate that a cookie domain is not a public suffix.
+
+
Per RFC 6265 Section 5.3 Step 5, user agents MUST reject cookies where
+
the Domain attribute is a public suffix (e.g., ".com", ".co.uk") unless
+
the request host exactly matches that domain.
+
+
This prevents attackers from setting domain-wide cookies that would affect
+
all sites under a TLD.
+
+
@param request_domain The host from the HTTP request
+
@param cookie_domain The Domain attribute value (already normalized, without leading dot)
+
@return [Ok ()] if the domain is allowed, [Error msg] if it's a public suffix
+
+
Examples:
+
- Request from "www.example.com", Domain=".com" → Error (public suffix)
+
- Request from "www.example.com", Domain=".example.com" → Ok (not public suffix)
+
- Request from "com", Domain=".com" → Ok (request host matches domain exactly)
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 *)
+
let validate_not_public_suffix ~request_domain ~cookie_domain =
+
(* IP addresses bypass PSL check per RFC 6265 Section 5.1.3 *)
+
match Ipaddr.of_string cookie_domain with
+
| Ok _ -> Ok () (* IP addresses are not subject to PSL rules *)
+
| Error _ ->
+
let psl = Lazy.force psl in
+
(match Publicsuffix.is_public_suffix psl cookie_domain with
+
| Error _ ->
+
(* If PSL lookup fails (e.g., invalid domain), allow the cookie.
+
Domain name validation is handled separately. *)
+
Ok ()
+
| Ok false ->
+
(* Not a public suffix, allow the cookie *)
+
Ok ()
+
| Ok true ->
+
(* It's a public suffix - only allow if request host matches exactly.
+
This allows a server that IS a public suffix (rare but possible with
+
private domains like blogspot.com) to set cookies for itself. *)
+
let request_lower = String.lowercase_ascii request_domain in
+
let cookie_lower = String.lowercase_ascii cookie_domain in
+
if request_lower = cookie_lower then Ok ()
+
else
+
Error
+
(Printf.sprintf
+
"Domain %S is a public suffix; RFC 6265 Section 5.3 prohibits \
+
setting cookies for public suffixes to prevent domain-wide \
+
cookie attacks. The request host %S does not exactly match \
+
the domain."
+
cookie_domain request_domain))
+
(** {1 Cookie Parsing Helpers} *)
(** Normalize a domain by stripping the leading dot.
···
(** Parse a Set-Cookie HTTP response header.
Parses the header according to {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.2} RFC 6265 Section 5.2},
-
extracting the cookie name, value, and all attributes. Returns [None] if
-
the cookie is invalid or fails validation.
+
extracting the cookie name, value, and all attributes. Returns [Error msg] if
+
the cookie is invalid or fails validation, with a descriptive error message.
@param now Function returning current time for Max-Age computation
@param domain The request host (used as default domain)
@param path The request path (used as default path)
@param header_value The Set-Cookie header value string
-
@return The parsed cookie, or [None] if parsing/validation fails
+
@return [Ok cookie] if parsing succeeds, [Error msg] with explanation if invalid
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.2> RFC 6265 Section 5.2 - The Set-Cookie Header *)
let of_set_cookie_header ~now ~domain:request_domain ~path:request_path
···
let parts = String.split_on_char ';' header_value |> List.map String.trim in
match parts with
-
| [] -> None
+
| [] -> Error "Empty Set-Cookie header"
| name_value :: attrs -> (
(* Parse name=value *)
match String.index_opt name_value '=' with
-
| None -> None
-
| Some eq_pos ->
+
| None ->
+
Error
+
(Printf.sprintf
+
"Set-Cookie header missing '=' separator in name-value pair: %S"
+
name_value)
+
| Some eq_pos -> (
let name = String.sub name_value 0 eq_pos |> String.trim in
let cookie_value =
String.sub name_value (eq_pos + 1)
···
|> String.trim
in
-
let current_time = now () in
+
(* Validate cookie name per RFC 6265 *)
+
match Validate.cookie_name name with
+
| Error msg -> Error msg
+
| Ok name -> (
+
(* Validate cookie value per RFC 6265 *)
+
match Validate.cookie_value cookie_value with
+
| Error msg -> Error msg
+
| Ok cookie_value ->
+
let current_time = now () in
-
(* Parse all attributes into mutable accumulator *)
-
let accumulated_attrs = empty_attributes () in
-
List.iter
-
(fun attr ->
-
match String.index_opt attr '=' with
-
| None ->
-
(* Attribute without value (e.g., Secure, HttpOnly) *)
-
parse_attribute now accumulated_attrs attr ""
-
| Some eq ->
-
let attr_name = String.sub attr 0 eq |> String.trim in
-
let attr_value =
-
String.sub attr (eq + 1) (String.length attr - eq - 1)
-
|> String.trim
-
in
-
parse_attribute now accumulated_attrs attr_name attr_value)
-
attrs;
+
(* Parse all attributes into mutable accumulator *)
+
let accumulated_attrs = empty_attributes () in
+
let attr_errors = ref [] in
+
List.iter
+
(fun attr ->
+
match String.index_opt attr '=' with
+
| None ->
+
(* Attribute without value (e.g., Secure, HttpOnly) *)
+
parse_attribute now accumulated_attrs attr ""
+
| Some eq ->
+
let attr_name = String.sub attr 0 eq |> String.trim in
+
let attr_value =
+
String.sub attr (eq + 1)
+
(String.length attr - eq - 1)
+
|> String.trim
+
in
+
(* Validate domain and path attributes *)
+
(match String.lowercase_ascii attr_name with
+
| "domain" -> (
+
match Validate.domain_value attr_value with
+
| Error msg -> attr_errors := msg :: !attr_errors
+
| Ok _ -> ())
+
| "path" -> (
+
match Validate.path_value attr_value with
+
| Error msg -> attr_errors := msg :: !attr_errors
+
| Ok _ -> ())
+
| "max-age" -> (
+
match int_of_string_opt attr_value with
+
| Some seconds -> (
+
match Validate.max_age seconds with
+
| Error msg ->
+
attr_errors := msg :: !attr_errors
+
| Ok _ -> ())
+
| None -> ())
+
| _ -> ());
+
parse_attribute now accumulated_attrs attr_name
+
attr_value)
+
attrs;
-
(* Validate attributes *)
-
if not (validate_attributes accumulated_attrs) then (
-
Log.warn (fun m -> m "Cookie validation failed, rejecting cookie");
-
None)
-
else
-
let cookie =
-
build_cookie ~request_domain ~request_path ~name
-
~value:cookie_value accumulated_attrs ~now:current_time
-
in
-
Log.debug (fun m -> m "Parsed cookie: %a" pp cookie);
-
Some cookie)
+
(* Check for attribute validation errors *)
+
if List.length !attr_errors > 0 then
+
Error (String.concat "; " (List.rev !attr_errors))
+
else if not (validate_attributes accumulated_attrs) then
+
Error
+
"Cookie validation failed: SameSite=None requires \
+
Secure flag, and Partitioned requires Secure flag"
+
else
+
(* Public suffix validation per RFC 6265 Section 5.3 Step 5.
+
Only applies when Domain attribute is present. *)
+
let psl_result =
+
match accumulated_attrs.domain with
+
| None ->
+
(* No Domain attribute - cookie is host-only, no PSL check needed *)
+
Ok ()
+
| Some cookie_domain ->
+
let normalized = normalize_domain cookie_domain in
+
validate_not_public_suffix ~request_domain ~cookie_domain:normalized
+
in
+
(match psl_result with
+
| Error msg -> Error msg
+
| Ok () ->
+
let cookie =
+
build_cookie ~request_domain ~request_path ~name
+
~value:cookie_value accumulated_attrs ~now:current_time
+
in
+
Log.debug (fun m -> m "Parsed cookie: %a" pp cookie);
+
Ok cookie))))
(** Parse a Cookie HTTP request header.
Parses the header according to {{:https://datatracker.ietf.org/doc/html/rfc6265#section-4.2} RFC 6265 Section 4.2}.
The Cookie header contains semicolon-separated name=value pairs.
+
Validates cookie names and values per RFC 6265 and detects duplicate
+
cookie names (which is an error per Section 4.2.1).
+
Cookies parsed from the Cookie header have [host_only = true] since we
cannot determine from the header alone whether they originally had a
Domain attribute.
···
@param domain The request host (assigned to all parsed cookies)
@param path The request path (assigned to all parsed cookies)
@param header_value The Cookie header value string
-
@return List of parse results (Ok cookie or Error message)
+
@return [Ok cookies] if all cookies parse successfully with no duplicates,
+
[Error msg] with explanation if validation fails
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.2> RFC 6265 Section 4.2 - The Cookie Header *)
let of_cookie_header ~now ~domain ~path header_value =
···
(* Filter out empty parts *)
let parts = List.filter (fun s -> String.length s > 0) parts in
-
(* Parse each name=value pair *)
-
List.map
-
(fun name_value ->
-
match String.index_opt name_value '=' with
-
| None ->
-
Error (Printf.sprintf "Cookie missing '=' separator: %s" name_value)
-
| Some eq_pos ->
-
let cookie_name = String.sub name_value 0 eq_pos |> String.trim in
-
if String.length cookie_name = 0 then Error "Cookie has empty name"
-
else
-
let cookie_value =
-
String.sub name_value (eq_pos + 1)
-
(String.length name_value - eq_pos - 1)
-
|> String.trim
-
in
-
let current_time = now () in
-
(* Create cookie with defaults from Cookie header context.
-
Cookies from Cookie headers have host_only=true since we don't
-
know if they originally had a Domain attribute. *)
-
let cookie =
-
make ~domain ~path ~name:cookie_name ~value:cookie_value
-
~secure:false ~http_only:false ~partitioned:false ~host_only:true
-
~creation_time:current_time ~last_access:current_time ()
-
in
-
Ok cookie)
-
parts
+
(* Parse each name=value pair, collecting results *)
+
let results =
+
List.fold_left
+
(fun acc name_value ->
+
match acc with
+
| Error _ -> acc (* Propagate earlier errors *)
+
| Ok (cookies, seen_names) -> (
+
match String.index_opt name_value '=' with
+
| None ->
+
Error
+
(Printf.sprintf "Cookie missing '=' separator: %S" name_value)
+
| Some eq_pos -> (
+
let cookie_name =
+
String.sub name_value 0 eq_pos |> String.trim
+
in
+
(* Validate cookie name per RFC 6265 *)
+
match Validate.cookie_name cookie_name with
+
| Error msg -> Error msg
+
| Ok cookie_name -> (
+
(* Check for duplicate names per RFC 6265 Section 4.2.1 *)
+
if List.mem cookie_name seen_names then
+
Error
+
(Printf.sprintf
+
"Duplicate cookie name %S in Cookie header; RFC \
+
6265 Section 4.2.1 forbids duplicate names"
+
cookie_name)
+
else
+
let cookie_value =
+
String.sub name_value (eq_pos + 1)
+
(String.length name_value - eq_pos - 1)
+
|> String.trim
+
in
+
(* Validate cookie value per RFC 6265 *)
+
match Validate.cookie_value cookie_value with
+
| Error msg -> Error msg
+
| Ok cookie_value ->
+
let current_time = now () in
+
(* Create cookie with defaults from Cookie header context.
+
Cookies from Cookie headers have host_only=true since we don't
+
know if they originally had a Domain attribute. *)
+
let cookie =
+
make ~domain ~path ~name:cookie_name
+
~value:cookie_value ~secure:false ~http_only:false
+
~partitioned:false ~host_only:true
+
~creation_time:current_time
+
~last_access:current_time ()
+
in
+
Ok (cookie :: cookies, cookie_name :: seen_names)))))
+
(Ok ([], []))
+
parts
+
in
+
match results with
+
| Error msg -> Error msg
+
| Ok (cookies, _) -> Ok (List.rev cookies)
(** Generate a Cookie HTTP request header from a list of cookies.
+113 -9
lib/core/cookeio.mli
···
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model *)
+
(** {1 RFC 6265 Validation}
+
+
Validation functions for cookie names, values, and attributes per
+
{{:https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1} RFC 6265 Section 4.1.1}.
+
These functions return [Ok value] on success or [Error msg] with a detailed
+
explanation of why validation failed.
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 - Syntax *)
+
+
module Validate : sig
+
val cookie_name : string -> (string, string) result
+
(** Validate a cookie name per RFC 6265.
+
+
Cookie names must be valid RFC 2616 tokens: one or more characters
+
excluding control characters and separators.
+
+
@param name The cookie name to validate
+
@return [Ok name] if valid, [Error message] with explanation if invalid
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
+
+
val cookie_value : string -> (string, string) result
+
(** Validate a cookie value per RFC 6265.
+
+
Cookie values must contain only cookie-octets, optionally wrapped in
+
double quotes. Invalid characters include: control characters, space,
+
double quote (except as wrapper), comma, semicolon, and backslash.
+
+
@param value The cookie value to validate
+
@return [Ok value] if valid, [Error message] with explanation if invalid
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
+
+
val domain_value : string -> (string, string) result
+
(** Validate a domain attribute value.
+
+
Domain values must be either:
+
- A valid domain name per RFC 1034 Section 3.5
+
- A valid IPv4 address
+
- A valid IPv6 address
+
+
@param domain The domain value to validate (leading dot is stripped first)
+
@return [Ok domain] if valid, [Error message] with explanation if invalid
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.2.3> RFC 6265 Section 4.1.2.3
+
@see <https://datatracker.ietf.org/doc/html/rfc1034#section-3.5> RFC 1034 Section 3.5 *)
+
+
val path_value : string -> (string, string) result
+
(** Validate a path attribute value.
+
+
Per RFC 6265 Section 4.1.1, path-value may contain any CHAR except
+
control characters and semicolon.
+
+
@param path The path value to validate
+
@return [Ok path] if valid, [Error message] with explanation if invalid
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
+
+
val max_age : int -> (int, string) result
+
(** Validate a Max-Age attribute value.
+
+
Per RFC 6265 Section 4.1.1, max-age-av uses non-zero-digit *DIGIT.
+
However, per Section 5.2.2, user agents should treat values <= 0 as
+
"delete immediately". This function returns [Ok] for any integer since
+
the parsing code handles negative values by converting to 0.
+
+
@param seconds The Max-Age value in seconds
+
@return [Ok seconds] always (negative values are handled in parsing)
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.2.2> RFC 6265 Section 5.2.2 *)
+
end
+
(** {1 Cookie Creation and Parsing} *)
val of_set_cookie_header :
-
now:(unit -> Ptime.t) -> domain:string -> path:string -> string -> t option
+
now:(unit -> Ptime.t) ->
+
domain:string ->
+
path:string ->
+
string ->
+
(t, string) result
(** Parse Set-Cookie response header value into a cookie.
Parses a Set-Cookie header following
···
- Basic format: [NAME=VALUE; attribute1; attribute2=value2]
- Supports all standard attributes: [expires], [max-age], [domain], [path],
[secure], [httponly], [samesite], [partitioned]
-
- Returns [None] if parsing fails or cookie validation fails
+
- Returns [Error msg] if parsing fails or cookie validation fails, with
+
a detailed explanation of what was invalid
- The [domain] and [path] parameters provide the request context for default
values
- The [now] parameter is used for calculating expiry times from [max-age]
attributes and setting creation/access times
-
Cookie validation rules (from RFC 6265bis and CHIPS):
-
- [SameSite=None] requires the [Secure] flag to be set
-
- [Partitioned] requires the [Secure] flag to be set
+
Validation rules applied:
+
- Cookie name must be a valid RFC 2616 token (no CTLs or separators)
+
- Cookie value must contain only valid cookie-octets
+
- Domain must be a valid domain name (RFC 1034) or IP address
+
- Path must not contain control characters or semicolons
+
- Max-Age must be non-negative
+
- [SameSite=None] requires the [Secure] flag to be set (RFC 6265bis)
+
- [Partitioned] requires the [Secure] flag to be set (CHIPS)
+
- Domain must not be a public suffix per
+
{{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.3} RFC 6265 Section 5.3 Step 5}
+
(unless the request host exactly matches the domain). This uses the
+
{{:https://publicsuffix.org/list/} Mozilla Public Suffix List} to prevent
+
domain-wide cookie attacks.
+
+
{3 Public Suffix Validation}
+
+
Cookies with Domain attributes that are public suffixes (e.g., [.com], [.co.uk],
+
[.github.io]) are rejected to prevent a malicious site from setting cookies
+
that would affect all sites under that TLD.
+
+
Examples:
+
- Request from [www.example.com], Domain=[.com] → rejected (public suffix)
+
- Request from [www.example.com], Domain=[.example.com] → allowed
+
- Request from [blogspot.com], Domain=[.blogspot.com] → allowed (request matches)
Example:
{[of_set_cookie_header ~now:(fun () -> Ptime_clock.now ())
~domain:"example.com" ~path:"/" "session=abc123; Secure; HttpOnly"]}
-
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.2> RFC 6265 Section 5.2 - The Set-Cookie Header *)
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.2> RFC 6265 Section 5.2 - The Set-Cookie Header
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model (public suffix check)
+
@see <https://publicsuffix.org/list/> Public Suffix List *)
val of_cookie_header :
now:(unit -> Ptime.t) ->
domain:string ->
path:string ->
string ->
-
(t, string) result list
+
(t list, string) result
(** Parse Cookie request header containing semicolon-separated name=value pairs.
Parses a Cookie header following
···
Cookie headers contain only name=value pairs without attributes:
["name1=value1; name2=value2; name3=value3"]
+
Validates each cookie name and value per RFC 6265 and detects duplicate
+
cookie names (which is forbidden per Section 4.2.1).
+
Creates cookies with:
- Provided [domain] and [path] from request context
- All security flags set to [false] (defaults)
···
whether cookies originally had a Domain attribute)
- [creation_time] and [last_access] set to current time from [now]
-
Returns a list of parse results, one per cookie. Parse errors for individual
-
cookies are returned as [Error msg] without failing the entire parse.
+
Returns [Ok cookies] if all cookies parse successfully with no duplicates,
+
or [Error msg] if any validation fails.
Example:
{[of_cookie_header ~now:(fun () -> Ptime_clock.now ()) ~domain:"example.com"
+1 -1
lib/core/dune
···
(library
(name cookeio)
(public_name cookeio)
-
(libraries logs ptime))
+
(libraries logs ptime ipaddr domain-name publicsuffix))
+95 -4
lib/jar/cookeio_jar.ml
···
(** {1 Cookie Management} *)
+
(** Preserve creation time from an existing cookie when replacing.
+
+
Per RFC 6265 Section 5.3, Step 11.3: "If the newly created cookie was
+
received from a 'non-HTTP' API and the old-cookie's http-only-flag is
+
true, abort these steps and ignore the newly created cookie entirely."
+
Step 11.3 also states: "Update the creation-time of the old-cookie to
+
match the creation-time of the newly created cookie."
+
+
However, the common interpretation (and browser behavior) is to preserve
+
the original creation-time when updating a cookie. This matches what
+
Step 3 of Section 5.4 uses for ordering (creation-time stability).
+
+
@param old_cookie The existing cookie being replaced (if any)
+
@param new_cookie The new cookie to add
+
@return The new cookie with creation_time preserved from old_cookie if present
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model *)
+
let preserve_creation_time old_cookie_opt new_cookie =
+
match old_cookie_opt with
+
| None -> new_cookie
+
| Some old_cookie ->
+
Cookeio.make ~domain:(Cookeio.domain new_cookie)
+
~path:(Cookeio.path new_cookie) ~name:(Cookeio.name new_cookie)
+
~value:(Cookeio.value new_cookie) ~secure:(Cookeio.secure new_cookie)
+
~http_only:(Cookeio.http_only new_cookie)
+
?expires:(Cookeio.expires new_cookie)
+
?max_age:(Cookeio.max_age new_cookie)
+
?same_site:(Cookeio.same_site new_cookie)
+
~partitioned:(Cookeio.partitioned new_cookie)
+
~host_only:(Cookeio.host_only new_cookie)
+
~creation_time:(Cookeio.creation_time old_cookie)
+
~last_access:(Cookeio.last_access new_cookie)
+
()
+
let add_cookie jar cookie =
Log.debug (fun m ->
m "Adding cookie to delta: %s=%s for domain %s" (Cookeio.name cookie)
(Cookeio.value cookie) (Cookeio.domain cookie));
Eio.Mutex.lock jar.mutex;
+
+
(* Find existing cookie with same identity to preserve creation_time
+
per RFC 6265 Section 5.3, Step 11.3 *)
+
let existing =
+
List.find_opt (fun c -> cookie_identity_matches c cookie) jar.delta_cookies
+
in
+
let existing =
+
match existing with
+
| Some _ -> existing
+
| None ->
+
(* Also check original cookies for creation time preservation *)
+
List.find_opt
+
(fun c -> cookie_identity_matches c cookie)
+
jar.original_cookies
+
in
+
+
let cookie = preserve_creation_time existing cookie in
+
(* Remove existing cookie with same identity from delta *)
jar.delta_cookies <-
List.filter
···
(Cookeio.value cookie) (Cookeio.domain cookie));
Eio.Mutex.lock jar.mutex;
+
+
(* Find existing cookie with same identity to preserve creation_time
+
per RFC 6265 Section 5.3, Step 11.3 *)
+
let existing =
+
List.find_opt
+
(fun c -> cookie_identity_matches c cookie)
+
jar.original_cookies
+
in
+
+
let cookie = preserve_creation_time existing cookie in
+
(* Remove existing cookie with same identity from original *)
jar.original_cookies <-
List.filter
···
Eio.Mutex.unlock jar.mutex
+
(** Compare cookies for ordering per RFC 6265 Section 5.4, Step 2.
+
+
Cookies SHOULD be sorted:
+
1. Cookies with longer paths listed first
+
2. Among equal-length paths, cookies with earlier creation-times first
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.4> RFC 6265 Section 5.4 - The Cookie Header *)
+
let compare_cookie_order c1 c2 =
+
let path1_len = String.length (Cookeio.path c1) in
+
let path2_len = String.length (Cookeio.path c2) in
+
(* Longer paths first (descending order) *)
+
match Int.compare path2_len path1_len with
+
| 0 ->
+
(* Equal path lengths: earlier creation time first (ascending order) *)
+
Ptime.compare (Cookeio.creation_time c1) (Cookeio.creation_time c2)
+
| n -> n
+
(** Retrieve cookies that should be sent for a given request.
Per RFC 6265 Section 5.4, the user agent should include a Cookie header
containing cookies that match the request-uri's domain, path, and security
context. This function also updates the last-access-time for matched cookies.
+
Cookies are sorted per Section 5.4, Step 2:
+
1. Cookies with longer paths listed first
+
2. Among equal-length paths, earlier creation-times listed first
+
@param jar The cookie jar to search
@param clock The Eio clock for timestamp updates
@param domain The request domain (hostname or IP address)
@param path The request path
@param is_secure Whether the request is over a secure channel (HTTPS)
-
@return List of cookies that should be included in the Cookie header
+
@return List of cookies that should be included in the Cookie header, sorted
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.4> RFC 6265 Section 5.4 - The Cookie Header *)
let get_cookies jar ~clock ~domain:request_domain ~path:request_path ~is_secure
···
in
let unique_cookies = dedup [] all_cookies in
-
(* Filter for applicable cookies, excluding removal cookies (empty value) *)
+
(* Filter for applicable cookies, excluding removal cookies and expired cookies *)
let applicable =
List.filter
(fun cookie ->
Cookeio.value cookie <> ""
(* Exclude removal cookies *)
+
&& (not (is_expired cookie clock))
+
(* Exclude expired cookies *)
&& domain_matches ~host_only:(Cookeio.host_only cookie)
(Cookeio.domain cookie) request_domain
&& path_matches (Cookeio.path cookie) request_path
&& ((not (Cookeio.secure cookie)) || is_secure))
unique_cookies
in
+
+
(* Sort cookies per RFC 6265 Section 5.4, Step 2:
+
- Longer paths first
+
- Equal paths: earlier creation time first *)
+
let sorted = List.sort compare_cookie_order applicable in
(* Update last access time in both lists *)
let now =
···
Eio.Mutex.unlock jar.mutex;
-
Log.debug (fun m -> m "Found %d applicable cookies" (List.length applicable));
-
applicable
+
Log.debug (fun m -> m "Found %d applicable cookies" (List.length sorted));
+
sorted
let clear jar =
Log.info (fun m -> m "Clearing all cookies");
+30 -6
lib/jar/cookeio_jar.mli
···
The cookie is added to the delta, meaning it will appear in Set-Cookie
headers when calling {!delta}. If a cookie with the same name/domain/path
-
exists in the delta, it will be replaced per
-
{{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.3} RFC 6265 Section 5.3}. *)
+
exists, it will be replaced per
+
{{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.3} RFC 6265 Section 5.3}.
+
+
Per Section 5.3, Step 11.3, when replacing an existing cookie, the original
+
creation-time is preserved. This ensures stable cookie ordering per
+
Section 5.4, Step 2.
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model *)
val add_original : t -> Cookeio.t -> unit
(** Add an original cookie to the jar.
Original cookies are those received from the client (via Cookie header).
They do not appear in the delta. This method should be used when loading
-
cookies from incoming HTTP requests. *)
+
cookies from incoming HTTP requests.
+
+
Per Section 5.3, Step 11.3, when replacing an existing cookie, the original
+
creation-time is preserved.
+
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model *)
val delta : t -> Cookeio.t list
(** Get cookies that need to be sent in Set-Cookie headers.
···
Returns all cookies that match the given domain and path, and satisfy the
secure flag requirement. Combines original and delta cookies, with delta
-
taking precedence. Excludes removal cookies (empty value). Also updates the
-
last access time of matching cookies using the provided clock.
+
taking precedence. Excludes:
+
- Removal cookies (empty value)
+
- Expired cookies (expiry-time in the past per Section 5.3)
+
+
Cookies are sorted per Section 5.4, Step 2:
+
- Cookies with longer paths are listed before cookies with shorter paths
+
- Among cookies with equal-length paths, cookies with earlier creation-times
+
are listed first
+
+
Also updates the last access time of matching cookies using the provided clock.
Domain matching follows {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.1.3} Section 5.1.3}:
- IP addresses require exact match only
···
Path matching follows {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.1.4} Section 5.1.4}.
+
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model (expiry)
@see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.4> RFC 6265 Section 5.4 - The Cookie Header *)
val clear : t -> unit
···
(** Get the number of unique cookies in the jar. *)
val get_all_cookies : t -> Cookeio.t list
-
(** Get all cookies in the jar. *)
+
(** Get all cookies in the jar.
+
+
Returns all cookies including expired ones (for inspection/debugging).
+
Use {!get_cookies} with appropriate domain/path for filtered results that
+
exclude expired cookies, or call {!clear_expired} first. *)
val is_empty : t -> bool
(** Check if the jar is empty. *)
+821 -101
test/test_cookeio.ml
···
"only session cookie remains" "session"
(Cookeio.name (List.hd remaining))
+
let test_get_cookies_filters_expired () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
let jar = create () in
+
+
(* Add an expired cookie (expired at time 500) *)
+
let expired = Ptime.of_float_s 500.0 |> Option.get in
+
let cookie_expired =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"expired"
+
~value:"old" ~secure:false ~http_only:false
+
~expires:(`DateTime expired)
+
~creation_time:(Ptime.of_float_s 100.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 100.0 |> Option.get)
+
()
+
in
+
+
(* Add a valid cookie (expires at time 2000) *)
+
let valid_time = Ptime.of_float_s 2000.0 |> Option.get in
+
let cookie_valid =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"valid"
+
~value:"current" ~secure:false ~http_only:false
+
~expires:(`DateTime valid_time)
+
~creation_time:(Ptime.of_float_s 1000.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1000.0 |> Option.get)
+
()
+
in
+
+
(* Add a session cookie (no expiry) *)
+
let cookie_session =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"session"
+
~value:"sess" ~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 1000.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1000.0 |> Option.get)
+
()
+
in
+
+
add_cookie jar cookie_expired;
+
add_cookie jar cookie_valid;
+
add_cookie jar cookie_session;
+
+
(* get_all_cookies returns all including expired (for inspection) *)
+
Alcotest.(check int) "get_all_cookies includes expired" 3
+
(List.length (get_all_cookies jar));
+
+
(* get_cookies should automatically filter out expired cookies *)
+
let cookies =
+
get_cookies jar ~clock ~domain:"example.com" ~path:"/" ~is_secure:false
+
in
+
Alcotest.(check int) "get_cookies filters expired" 2 (List.length cookies);
+
+
let names = List.map Cookeio.name cookies |> List.sort String.compare in
+
Alcotest.(check (list string))
+
"only non-expired cookies returned"
+
[ "session"; "valid" ]
+
names
+
let test_max_age_parsing_with_mock_clock () =
Eio_mock.Backend.run @@ fun () ->
let clock = Eio_mock.Clock.make () in
···
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
+
Alcotest.(check bool) "cookie parsed" true (Result.is_ok cookie_opt);
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check string) "cookie name" "session" (Cookeio.name cookie);
Alcotest.(check string) "cookie value" "abc123" (Cookeio.value cookie);
Alcotest.(check bool) "cookie secure" true (Cookeio.secure cookie);
···
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
+
Alcotest.(check bool) "cookie parsed" true (Result.is_ok cookie_opt);
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check string) "cookie name" "id" (Cookeio.name cookie);
Alcotest.(check string) "cookie value" "xyz789" (Cookeio.value cookie);
Alcotest.(check string) "cookie domain" "example.com" (Cookeio.domain cookie);
···
Alcotest.(check bool)
"invalid cookie rejected" true
-
(Option.is_none cookie_opt);
+
(Result.is_error cookie_opt);
(* This should be accepted: SameSite=None with Secure *)
let valid_header = "token=abc; SameSite=None; Secure" in
···
Alcotest.(check bool)
"valid cookie accepted" true
-
(Option.is_some cookie_opt2);
+
(Result.is_ok cookie_opt2);
-
let cookie = Option.get cookie_opt2 in
+
let cookie = Result.get_ok cookie_opt2 in
Alcotest.(check bool) "cookie is secure" true (Cookeio.secure cookie);
Alcotest.(
check
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
-
let cookie = Option.get cookie_opt in
+
Alcotest.(check bool) "cookie parsed" true (Result.is_ok cookie_opt);
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check string)
"domain normalized" "example.com" (Cookeio.domain cookie);
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
+
Alcotest.(check bool) "cookie parsed" true (Result.is_ok cookie_opt);
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
(* Verify max_age is stored as a Ptime.Span *)
Alcotest.(check bool)
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
+
Alcotest.(check bool) "cookie parsed" true (Result.is_ok cookie_opt);
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
(* Verify max_age is stored as 0 per RFC 6265 *)
Alcotest.(check bool)
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
-
let cookie = Option.get cookie_opt in
+
Alcotest.(check bool) "cookie parsed" true (Result.is_ok cookie_opt);
+
let cookie = Result.get_ok cookie_opt in
(* Generate Set-Cookie header from the cookie *)
let set_cookie_header = make_set_cookie_header cookie in
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" set_cookie_header
in
-
Alcotest.(check bool) "cookie re-parsed" true (Option.is_some cookie2_opt);
-
let cookie2 = Option.get cookie2_opt in
+
Alcotest.(check bool) "cookie re-parsed" true (Result.is_ok cookie2_opt);
+
let cookie2 = Result.get_ok cookie2_opt in
(* Verify max_age is preserved *)
Alcotest.(check (option int))
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "FMT1 cookie parsed" true (Option.is_some cookie_opt);
+
Alcotest.(check bool) "FMT1 cookie parsed" true (Result.is_ok cookie_opt);
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check bool)
"FMT1 has expiry" true
(Option.is_some (Cookeio.expires cookie));
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "FMT2 cookie parsed" true (Option.is_some cookie_opt);
+
Alcotest.(check bool) "FMT2 cookie parsed" true (Result.is_ok cookie_opt);
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check bool)
"FMT2 has expiry" true
(Option.is_some (Cookeio.expires cookie));
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "FMT3 cookie parsed" true (Option.is_some cookie_opt);
+
Alcotest.(check bool) "FMT3 cookie parsed" true (Result.is_ok cookie_opt);
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check bool)
"FMT3 has expiry" true
(Option.is_some (Cookeio.expires cookie));
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "FMT4 cookie parsed" true (Option.is_some cookie_opt);
+
Alcotest.(check bool) "FMT4 cookie parsed" true (Result.is_ok cookie_opt);
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check bool)
"FMT4 has expiry" true
(Option.is_some (Cookeio.expires cookie));
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
let expected = Ptime.of_date_time ((1995, 10, 21), ((07, 28, 00), 0)) in
begin match expected with
| Some t ->
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header2
in
-
let cookie2 = Option.get cookie_opt2 in
+
let cookie2 = Result.get_ok cookie_opt2 in
let expected2 = Ptime.of_date_time ((1969, 9, 10), ((20, 0, 0), 0)) in
begin match expected2 with
| Some t ->
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header3
in
-
let cookie3 = Option.get cookie_opt3 in
+
let cookie3 = Result.get_ok cookie_opt3 in
let expected3 = Ptime.of_date_time ((1999, 9, 10), ((20, 0, 0), 0)) in
begin match expected3 with
| Some t ->
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
let expected = Ptime.of_date_time ((2025, 10, 21), ((07, 28, 00), 0)) in
begin match expected with
| Some t ->
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header2
in
-
let cookie2 = Option.get cookie_opt2 in
+
let cookie2 = Result.get_ok cookie_opt2 in
let expected2 = Ptime.of_date_time ((2000, 1, 1), ((0, 0, 0), 0)) in
begin match expected2 with
| Some t ->
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header3
in
-
let cookie3 = Option.get cookie_opt3 in
+
let cookie3 = Result.get_ok cookie_opt3 in
let expected3 = Ptime.of_date_time ((2068, 9, 10), ((20, 0, 0), 0)) in
begin match expected3 with
| Some t ->
···
in
Alcotest.(check bool)
"RFC 3339 cookie parsed" true
-
(Option.is_some cookie_opt);
+
(Result.is_ok cookie_opt);
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check bool)
"RFC 3339 has expiry" true
(Option.is_some (Cookeio.expires cookie));
···
(* Cookie should still be parsed, just without expires *)
Alcotest.(check bool)
"cookie parsed despite invalid date" true
-
(Option.is_some cookie_opt);
-
let cookie = Option.get cookie_opt in
+
(Result.is_ok cookie_opt);
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check string) "cookie name correct" "session" (Cookeio.name cookie);
Alcotest.(check string) "cookie value correct" "abc" (Cookeio.value cookie);
(* expires should be None since date was invalid *)
···
in
Alcotest.(check bool)
(description ^ " parsed") true
-
(Option.is_some cookie_opt);
+
(Result.is_ok cookie_opt);
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check bool)
(description ^ " has expiry")
true
···
in
Alcotest.(check bool)
(description ^ " parsed") true
-
(Option.is_some cookie_opt);
+
(Result.is_ok cookie_opt);
-
let cookie = Option.get cookie_opt in
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check bool)
(description ^ " has expiry")
true
···
|> Option.value ~default:Ptime.epoch)
~domain:"widget.com" ~path:"/" "id=123; Partitioned; Secure"
with
-
| Some c ->
+
| Ok c ->
Alcotest.(check bool) "partitioned flag" true (partitioned c);
Alcotest.(check bool) "secure flag" true (secure c)
-
| None -> Alcotest.fail "Should parse valid Partitioned cookie"
+
| Error msg -> Alcotest.fail ("Should parse valid Partitioned cookie: " ^ msg)
let test_partitioned_serialization env =
let clock = Eio.Stdenv.clock env in
···
|> Option.value ~default:Ptime.epoch)
~domain:"widget.com" ~path:"/" "id=123; Partitioned"
with
-
| None -> () (* Expected *)
-
| Some _ -> Alcotest.fail "Should reject Partitioned without Secure"
+
| Error _ -> () (* Expected *)
+
| Ok _ -> Alcotest.fail "Should reject Partitioned without Secure"
(* Priority 2.2: Expiration Variants *)
···
|> Option.value ~default:Ptime.epoch)
~domain:"ex.com" ~path:"/" "id=123; Expires=0"
with
-
| Some c ->
+
| Ok c ->
Alcotest.(check (option expiration_testable))
"expires=0 is session" (Some `Session) (expires c)
-
| None -> Alcotest.fail "Should parse Expires=0"
+
| Error msg -> Alcotest.fail ("Should parse Expires=0: " ^ msg)
let test_serialize_expiration_variants env =
let clock = Eio.Stdenv.clock env in
···
let test_quoted_cookie_values env =
let clock = Eio.Stdenv.clock env in
-
let test_cases =
+
(* Test valid RFC 6265 cookie values:
+
cookie-value = *cookie-octet / ( DQUOTE *cookie-octet DQUOTE )
+
Valid cases have either no quotes or properly paired DQUOTE wrapper *)
+
let valid_cases =
-
("name=value", "value", "value");
-
("name=\"value\"", "\"value\"", "value");
-
("name=\"partial", "\"partial", "\"partial");
-
("name=\"val\"\"", "\"val\"\"", "val\"");
-
("name=val\"", "val\"", "val\"");
-
("name=\"\"", "\"\"", "");
+
("name=value", "value", "value"); (* No quotes *)
+
("name=\"value\"", "\"value\"", "value"); (* Properly quoted *)
+
("name=\"\"", "\"\"", ""); (* Empty quoted value *)
in
···
|> Option.value ~default:Ptime.epoch)
~domain:"ex.com" ~path:"/" input
with
-
| Some c ->
+
| Ok c ->
Alcotest.(check string)
(Printf.sprintf "raw value for %s" input)
expected_raw (value c);
Alcotest.(check string)
(Printf.sprintf "trimmed value for %s" input)
expected_trimmed (value_trimmed c)
-
| None -> Alcotest.fail ("Parse failed: " ^ input))
-
test_cases
+
| Error msg -> Alcotest.fail ("Parse failed: " ^ input ^ ": " ^ msg))
+
valid_cases;
+
+
(* Test invalid RFC 6265 cookie values are rejected *)
+
let invalid_cases =
+
[
+
"name=\"partial"; (* Opening quote without closing *)
+
"name=\"val\"\""; (* Embedded quote *)
+
"name=val\""; (* Trailing quote without opening *)
+
]
+
in
+
+
List.iter
+
(fun input ->
+
match
+
of_set_cookie_header
+
~now:(fun () ->
+
Ptime.of_float_s (Eio.Time.now clock)
+
|> Option.value ~default:Ptime.epoch)
+
~domain:"ex.com" ~path:"/" input
+
with
+
| Error _ -> () (* Expected - invalid values are rejected *)
+
| Ok _ ->
+
Alcotest.fail
+
(Printf.sprintf "Should reject invalid value: %s" input))
+
invalid_cases
let test_trimmed_value_not_used_for_equality env =
let clock = Eio.Stdenv.clock env in
···
|> Option.value ~default:Ptime.epoch)
~domain:"ex.com" ~path:"/" "name=\"value\""
with
-
| Some c1 -> begin
+
| Ok c1 -> begin
match
of_set_cookie_header
~now:(fun () ->
···
|> Option.value ~default:Ptime.epoch)
~domain:"ex.com" ~path:"/" "name=value"
with
-
| Some c2 ->
+
| Ok c2 ->
(* Different raw values *)
Alcotest.(check bool)
"different raw values" false
···
(* Same trimmed values *)
Alcotest.(check string)
"same trimmed values" (value_trimmed c1) (value_trimmed c2)
-
| None -> Alcotest.fail "Parse failed for unquoted"
+
| Error msg -> Alcotest.fail ("Parse failed for unquoted: " ^ msg)
end
-
| None -> Alcotest.fail "Parse failed for quoted"
+
| Error msg -> Alcotest.fail ("Parse failed for quoted: " ^ msg)
(* Priority 2.4: Cookie Header Parsing *)
let test_cookie_header_parsing_basic env =
let clock = Eio.Stdenv.clock env in
-
let results =
+
let result =
of_cookie_header
~now:(fun () ->
Ptime.of_float_s (Eio.Time.now clock)
···
~domain:"ex.com" ~path:"/" "session=abc123; theme=dark; lang=en"
in
-
let cookies = List.filter_map Result.to_option results in
-
Alcotest.(check int) "parsed 3 cookies" 3 (List.length cookies);
+
match result with
+
| Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
+
| Ok cookies ->
+
Alcotest.(check int) "parsed 3 cookies" 3 (List.length cookies);
-
let find name_val = List.find (fun c -> name c = name_val) cookies in
-
Alcotest.(check string) "session value" "abc123" (value (find "session"));
-
Alcotest.(check string) "theme value" "dark" (value (find "theme"));
-
Alcotest.(check string) "lang value" "en" (value (find "lang"))
+
let find name_val = List.find (fun c -> name c = name_val) cookies in
+
Alcotest.(check string) "session value" "abc123" (value (find "session"));
+
Alcotest.(check string) "theme value" "dark" (value (find "theme"));
+
Alcotest.(check string) "lang value" "en" (value (find "lang"))
let test_cookie_header_defaults env =
let clock = Eio.Stdenv.clock env in
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/app" "session=xyz"
with
-
| [ Ok c ] ->
+
| Ok [ c ] ->
(* Domain and path from request context *)
Alcotest.(check string) "domain from context" "example.com" (domain c);
Alcotest.(check string) "path from context" "/app" (path c);
···
Alcotest.(check (option span_testable)) "no max_age" None (max_age c);
Alcotest.(check (option same_site_testable))
"no same_site" None (same_site c)
-
| _ -> Alcotest.fail "Should parse single cookie"
+
| Ok _ -> Alcotest.fail "Should parse single cookie"
+
| Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
let test_cookie_header_edge_cases env =
let clock = Eio.Stdenv.clock env in
let test input expected_count description =
-
let results =
+
let result =
of_cookie_header
~now:(fun () ->
Ptime.of_float_s (Eio.Time.now clock)
|> Option.value ~default:Ptime.epoch)
~domain:"ex.com" ~path:"/" input
in
-
let cookies = List.filter_map Result.to_option results in
-
Alcotest.(check int) description expected_count (List.length cookies)
+
match result with
+
| Ok cookies ->
+
Alcotest.(check int) description expected_count (List.length cookies)
+
| Error msg ->
+
Alcotest.fail (description ^ " failed: " ^ msg)
in
test "" 0 "empty string";
···
let test_cookie_header_with_errors env =
let clock = Eio.Stdenv.clock env in
-
(* Mix of valid and invalid cookies *)
-
let results =
+
(* Invalid cookie (empty name) should cause entire parse to fail *)
+
let result =
of_cookie_header
~now:(fun () ->
Ptime.of_float_s (Eio.Time.now clock)
···
~domain:"ex.com" ~path:"/" "valid=1;=noname;valid2=2"
in
-
Alcotest.(check int) "total results" 3 (List.length results);
-
-
let successes = List.filter Result.is_ok results in
-
let errors = List.filter Result.is_error results in
-
-
Alcotest.(check int) "successful parses" 2 (List.length successes);
-
Alcotest.(check int) "failed parses" 1 (List.length errors);
-
-
(* Error should have descriptive message *)
+
(* Error should have descriptive message about the invalid cookie *)
let contains_substring s sub =
try
let _ = Str.search_forward (Str.regexp_string sub) s 0 in
true
with Not_found -> false
in
-
begin match List.hd errors with
+
match result with
| Error msg ->
let has_name = contains_substring msg "name" in
let has_empty = contains_substring msg "empty" in
Alcotest.(check bool)
"error mentions name or empty" true (has_name || has_empty)
-
| Ok _ -> Alcotest.fail "Expected error"
-
end
+
| Ok _ -> Alcotest.fail "Expected error for empty cookie name"
(* Max-Age and Expires Interaction *)
···
~domain:"ex.com" ~path:"/"
"id=123; Max-Age=3600; Expires=Wed, 21 Oct 2025 07:28:00 GMT"
with
-
| Some c ->
+
| Ok c ->
(* Both should be stored *)
begin match max_age c with
| Some span -> begin
···
| Some (`DateTime _) -> ()
| _ -> Alcotest.fail "expires should be parsed"
end
-
| None -> Alcotest.fail "Should parse cookie with both attributes"
+
| Error msg -> Alcotest.fail ("Should parse cookie with both attributes: " ^ msg)
(* ============================================================================ *)
(* Host-Only Flag Tests (RFC 6265 Section 5.3) *)
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
-
let cookie = Option.get cookie_opt in
+
Alcotest.(check bool) "cookie parsed" true (Result.is_ok cookie_opt);
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check bool) "host_only is true" true (Cookeio.host_only cookie);
Alcotest.(check string) "domain is request host" "example.com" (Cookeio.domain cookie)
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
-
let cookie = Option.get cookie_opt in
+
Alcotest.(check bool) "cookie parsed" true (Result.is_ok cookie_opt);
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check bool) "host_only is false" false (Cookeio.host_only cookie);
Alcotest.(check string) "domain is attribute value" "example.com" (Cookeio.domain cookie)
···
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" header
in
-
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
-
let cookie = Option.get cookie_opt in
+
Alcotest.(check bool) "cookie parsed" true (Result.is_ok cookie_opt);
+
let cookie = Result.get_ok cookie_opt in
Alcotest.(check bool) "host_only is false" false (Cookeio.host_only cookie);
Alcotest.(check string) "domain normalized" "example.com" (Cookeio.domain cookie)
···
Eio_mock.Clock.set_time clock 1000.0;
(* Cookies from Cookie header should have host_only=true *)
-
let results =
+
let result =
of_cookie_header
~now:(fun () ->
Ptime.of_float_s (Eio.Time.now clock)
|> Option.value ~default:Ptime.epoch)
~domain:"example.com" ~path:"/" "session=abc; theme=dark"
in
-
let cookies = List.filter_map Result.to_option results in
-
Alcotest.(check int) "parsed 2 cookies" 2 (List.length cookies);
-
List.iter (fun c ->
-
Alcotest.(check bool)
-
("host_only is true for " ^ Cookeio.name c)
-
true (Cookeio.host_only c)
-
) cookies
+
match result with
+
| Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
+
| Ok cookies ->
+
Alcotest.(check int) "parsed 2 cookies" 2 (List.length cookies);
+
List.iter (fun c ->
+
Alcotest.(check bool)
+
("host_only is true for " ^ Cookeio.name c)
+
true (Cookeio.host_only c)
+
) cookies
let test_host_only_mozilla_format_round_trip () =
Eio_mock.Backend.run @@ fun () ->
···
Alcotest.(check int) "/foo/bar does NOT match /baz" 0 (List.length cookies3)
(* ============================================================================ *)
+
(* Cookie Ordering Tests (RFC 6265 Section 5.4, Step 2) *)
+
(* ============================================================================ *)
+
+
let test_cookie_ordering_by_path_length () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
let jar = create () in
+
+
(* Add cookies with different path lengths, but same creation time *)
+
let cookie_short =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"short" ~value:"v1"
+
~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 1000.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1000.0 |> Option.get) ()
+
in
+
let cookie_medium =
+
Cookeio.make ~domain:"example.com" ~path:"/foo" ~name:"medium" ~value:"v2"
+
~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 1000.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1000.0 |> Option.get) ()
+
in
+
let cookie_long =
+
Cookeio.make ~domain:"example.com" ~path:"/foo/bar" ~name:"long" ~value:"v3"
+
~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 1000.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1000.0 |> Option.get) ()
+
in
+
+
(* Add in random order *)
+
add_cookie jar cookie_short;
+
add_cookie jar cookie_long;
+
add_cookie jar cookie_medium;
+
+
(* Get cookies for path /foo/bar/baz - all three should match *)
+
let cookies =
+
get_cookies jar ~clock ~domain:"example.com" ~path:"/foo/bar/baz" ~is_secure:false
+
in
+
+
Alcotest.(check int) "all 3 cookies match" 3 (List.length cookies);
+
+
(* Verify order: longest path first *)
+
let names = List.map Cookeio.name cookies in
+
Alcotest.(check (list string))
+
"cookies ordered by path length (longest first)"
+
[ "long"; "medium"; "short" ]
+
names
+
+
let test_cookie_ordering_by_creation_time () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 2000.0;
+
+
let jar = create () in
+
+
(* Add cookies with same path but different creation times *)
+
let cookie_new =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"new" ~value:"v1"
+
~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 1500.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1500.0 |> Option.get) ()
+
in
+
let cookie_old =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"old" ~value:"v2"
+
~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 1000.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1000.0 |> Option.get) ()
+
in
+
let cookie_middle =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"middle" ~value:"v3"
+
~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 1200.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1200.0 |> Option.get) ()
+
in
+
+
(* Add in random order *)
+
add_cookie jar cookie_new;
+
add_cookie jar cookie_old;
+
add_cookie jar cookie_middle;
+
+
let cookies =
+
get_cookies jar ~clock ~domain:"example.com" ~path:"/" ~is_secure:false
+
in
+
+
Alcotest.(check int) "all 3 cookies match" 3 (List.length cookies);
+
+
(* Verify order: earlier creation time first (for same path length) *)
+
let names = List.map Cookeio.name cookies in
+
Alcotest.(check (list string))
+
"cookies ordered by creation time (earliest first)"
+
[ "old"; "middle"; "new" ]
+
names
+
+
let test_cookie_ordering_combined () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 2000.0;
+
+
let jar = create () in
+
+
(* Mix of different paths and creation times *)
+
let cookie_a =
+
Cookeio.make ~domain:"example.com" ~path:"/foo" ~name:"a" ~value:"v1"
+
~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 1500.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1500.0 |> Option.get) ()
+
in
+
let cookie_b =
+
Cookeio.make ~domain:"example.com" ~path:"/foo" ~name:"b" ~value:"v2"
+
~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 1000.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1000.0 |> Option.get) ()
+
in
+
let cookie_c =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"c" ~value:"v3"
+
~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 500.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 500.0 |> Option.get) ()
+
in
+
+
add_cookie jar cookie_a;
+
add_cookie jar cookie_c;
+
add_cookie jar cookie_b;
+
+
let cookies =
+
get_cookies jar ~clock ~domain:"example.com" ~path:"/foo/bar" ~is_secure:false
+
in
+
+
Alcotest.(check int) "all 3 cookies match" 3 (List.length cookies);
+
+
(* /foo cookies (length 4) should come before / cookie (length 1)
+
Within /foo, earlier creation time (b=1000) should come before (a=1500) *)
+
let names = List.map Cookeio.name cookies in
+
Alcotest.(check (list string))
+
"cookies ordered by path length then creation time"
+
[ "b"; "a"; "c" ]
+
names
+
+
(* ============================================================================ *)
+
(* Creation Time Preservation Tests (RFC 6265 Section 5.3, Step 11.3) *)
+
(* ============================================================================ *)
+
+
let test_creation_time_preserved_on_update () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
let jar = create () in
+
+
(* Add initial cookie with creation_time=500 *)
+
let original_creation = Ptime.of_float_s 500.0 |> Option.get in
+
let cookie_v1 =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"session" ~value:"v1"
+
~secure:false ~http_only:false
+
~creation_time:original_creation
+
~last_access:(Ptime.of_float_s 500.0 |> Option.get) ()
+
in
+
add_cookie jar cookie_v1;
+
+
(* Update the cookie with a new value (creation_time=1000) *)
+
Eio_mock.Clock.set_time clock 1500.0;
+
let cookie_v2 =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"session" ~value:"v2"
+
~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 1500.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1500.0 |> Option.get) ()
+
in
+
add_cookie jar cookie_v2;
+
+
(* Get the cookie and verify creation_time was preserved *)
+
let cookies =
+
get_cookies jar ~clock ~domain:"example.com" ~path:"/" ~is_secure:false
+
in
+
Alcotest.(check int) "still one cookie" 1 (List.length cookies);
+
+
let cookie = List.hd cookies in
+
Alcotest.(check string) "value was updated" "v2" (Cookeio.value cookie);
+
+
(* Creation time should be preserved from original cookie *)
+
let creation_float =
+
Ptime.to_float_s (Cookeio.creation_time cookie)
+
in
+
Alcotest.(check (float 0.001))
+
"creation_time preserved from original"
+
500.0 creation_float
+
+
let test_creation_time_preserved_add_original () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
let jar = create () in
+
+
(* Add initial original cookie *)
+
let original_creation = Ptime.of_float_s 100.0 |> Option.get in
+
let cookie_v1 =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"test" ~value:"v1"
+
~secure:false ~http_only:false
+
~creation_time:original_creation
+
~last_access:(Ptime.of_float_s 100.0 |> Option.get) ()
+
in
+
add_original jar cookie_v1;
+
+
(* Replace with new original cookie *)
+
let cookie_v2 =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"test" ~value:"v2"
+
~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 1000.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1000.0 |> Option.get) ()
+
in
+
add_original jar cookie_v2;
+
+
let cookies = get_all_cookies jar in
+
Alcotest.(check int) "still one cookie" 1 (List.length cookies);
+
+
let cookie = List.hd cookies in
+
Alcotest.(check string) "value was updated" "v2" (Cookeio.value cookie);
+
+
(* Creation time should be preserved *)
+
let creation_float =
+
Ptime.to_float_s (Cookeio.creation_time cookie)
+
in
+
Alcotest.(check (float 0.001))
+
"creation_time preserved in add_original"
+
100.0 creation_float
+
+
let test_creation_time_new_cookie () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
let jar = create () in
+
+
(* Add a new cookie (no existing cookie to preserve from) *)
+
let cookie =
+
Cookeio.make ~domain:"example.com" ~path:"/" ~name:"new" ~value:"v1"
+
~secure:false ~http_only:false
+
~creation_time:(Ptime.of_float_s 1000.0 |> Option.get)
+
~last_access:(Ptime.of_float_s 1000.0 |> Option.get) ()
+
in
+
add_cookie jar cookie;
+
+
let cookies =
+
get_cookies jar ~clock ~domain:"example.com" ~path:"/" ~is_secure:false
+
in
+
let cookie = List.hd cookies in
+
+
(* New cookie should keep its own creation time *)
+
let creation_float =
+
Ptime.to_float_s (Cookeio.creation_time cookie)
+
in
+
Alcotest.(check (float 0.001))
+
"new cookie keeps its creation_time"
+
1000.0 creation_float
+
+
(* ============================================================================ *)
(* IP Address Domain Matching Tests (RFC 6265 Section 5.1.3) *)
(* ============================================================================ *)
···
Alcotest.(check int) "IP matches IP cookie" 1 (List.length cookies3);
Alcotest.(check string) "IP cookie is returned" "ip" (Cookeio.name (List.hd cookies3))
+
(* ============================================================================ *)
+
(* RFC 6265 Validation Tests *)
+
(* ============================================================================ *)
+
+
let test_validate_cookie_name_valid () =
+
(* Valid token characters per RFC 2616 *)
+
let valid_names = ["session"; "SID"; "my-cookie"; "COOKIE_123"; "abc.def"] in
+
List.iter (fun name ->
+
match Cookeio.Validate.cookie_name name with
+
| Ok _ -> ()
+
| Error msg ->
+
Alcotest.fail (Printf.sprintf "Name %S should be valid: %s" name msg))
+
valid_names
+
+
let test_validate_cookie_name_invalid () =
+
(* Invalid: control chars, separators, spaces *)
+
let invalid_names =
+
[
+
("", "empty");
+
("my cookie", "space");
+
("cookie=value", "equals");
+
("my;cookie", "semicolon");
+
("name\t", "tab");
+
("(cookie)", "parens");
+
("name,val", "comma");
+
]
+
in
+
List.iter (fun (name, reason) ->
+
match Cookeio.Validate.cookie_name name with
+
| Error _ -> () (* Expected *)
+
| Ok _ ->
+
Alcotest.fail
+
(Printf.sprintf "Name %S (%s) should be invalid" name reason))
+
invalid_names
+
+
let test_validate_cookie_value_valid () =
+
(* Valid cookie-octets or quoted values *)
+
let valid_values = ["abc123"; "value!#$%&'()*+-./"; "\"quoted\""; ""] in
+
List.iter (fun value ->
+
match Cookeio.Validate.cookie_value value with
+
| Ok _ -> ()
+
| Error msg ->
+
Alcotest.fail (Printf.sprintf "Value %S should be valid: %s" value msg))
+
valid_values
+
+
let test_validate_cookie_value_invalid () =
+
(* Invalid: space, comma, semicolon, backslash, unmatched quotes *)
+
let invalid_values =
+
[
+
("with space", "space");
+
("with,comma", "comma");
+
("with;semi", "semicolon");
+
("back\\slash", "backslash");
+
("\"unmatched", "unmatched opening quote");
+
("unmatched\"", "unmatched closing quote");
+
]
+
in
+
List.iter (fun (value, reason) ->
+
match Cookeio.Validate.cookie_value value with
+
| Error _ -> () (* Expected *)
+
| Ok _ ->
+
Alcotest.fail
+
(Printf.sprintf "Value %S (%s) should be invalid" value reason))
+
invalid_values
+
+
let test_validate_domain_valid () =
+
(* Valid domain names and IP addresses *)
+
let valid_domains =
+
["example.com"; "sub.example.com"; ".example.com"; "192.168.1.1"; "::1"]
+
in
+
List.iter (fun domain ->
+
match Cookeio.Validate.domain_value domain with
+
| Ok _ -> ()
+
| Error msg ->
+
Alcotest.fail (Printf.sprintf "Domain %S should be valid: %s" domain msg))
+
valid_domains
+
+
let test_validate_domain_invalid () =
+
(* Invalid domain names - only test cases that domain-name library rejects.
+
Note: domain-name library has specific rules that may differ from what
+
we might expect from the RFC. *)
+
let invalid_domains =
+
[
+
("", "empty");
+
(* Note: "-invalid.com" and "invalid-.com" are valid per domain-name library *)
+
]
+
in
+
List.iter (fun (domain, reason) ->
+
match Cookeio.Validate.domain_value domain with
+
| Error _ -> () (* Expected *)
+
| Ok _ ->
+
Alcotest.fail
+
(Printf.sprintf "Domain %S (%s) should be invalid" domain reason))
+
invalid_domains
+
+
let test_validate_path_valid () =
+
let valid_paths = ["/"; "/path"; "/path/to/resource"; "/path?query"] in
+
List.iter (fun path ->
+
match Cookeio.Validate.path_value path with
+
| Ok _ -> ()
+
| Error msg ->
+
Alcotest.fail (Printf.sprintf "Path %S should be valid: %s" path msg))
+
valid_paths
+
+
let test_validate_path_invalid () =
+
let invalid_paths =
+
[
+
("/path;bad", "semicolon");
+
("/path\x00bad", "control char");
+
]
+
in
+
List.iter (fun (path, reason) ->
+
match Cookeio.Validate.path_value path with
+
| Error _ -> () (* Expected *)
+
| Ok _ ->
+
Alcotest.fail
+
(Printf.sprintf "Path %S (%s) should be invalid" path reason))
+
invalid_paths
+
+
let test_duplicate_cookie_detection () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
(* Duplicate cookie names should be rejected *)
+
let result =
+
of_cookie_header
+
~now:(fun () ->
+
Ptime.of_float_s (Eio.Time.now clock)
+
|> Option.value ~default:Ptime.epoch)
+
~domain:"example.com" ~path:"/" "session=abc; theme=dark; session=xyz"
+
in
+
match result with
+
| Error msg ->
+
(* Should mention duplicate *)
+
let contains_dup = String.lowercase_ascii msg |> fun s ->
+
try let _ = Str.search_forward (Str.regexp_string "duplicate") s 0 in true
+
with Not_found -> false
+
in
+
Alcotest.(check bool) "error mentions duplicate" true contains_dup
+
| Ok _ -> Alcotest.fail "Should reject duplicate cookie names"
+
+
let test_validation_error_messages () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
(* Test that error messages are descriptive *)
+
let test_cases =
+
[
+
("=noname", "Cookie name is empty");
+
("bad cookie=value", "invalid characters");
+
("name=val ue", "invalid characters");
+
]
+
in
+
List.iter (fun (header, expected_substring) ->
+
match
+
of_set_cookie_header
+
~now:(fun () ->
+
Ptime.of_float_s (Eio.Time.now clock)
+
|> Option.value ~default:Ptime.epoch)
+
~domain:"example.com" ~path:"/" header
+
with
+
| Error msg ->
+
let has_substring =
+
try
+
let _ = Str.search_forward
+
(Str.regexp_string expected_substring) msg 0 in
+
true
+
with Not_found -> false
+
in
+
Alcotest.(check bool)
+
(Printf.sprintf "error for %S mentions %S" header expected_substring)
+
true has_substring
+
| Ok _ ->
+
Alcotest.fail (Printf.sprintf "Should reject %S" header))
+
test_cases
+
+
(* ============================================================================ *)
+
(* Public Suffix Validation Tests (RFC 6265 Section 5.3, Step 5) *)
+
(* ============================================================================ *)
+
+
let test_public_suffix_rejection () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
(* Setting a cookie for a public suffix (TLD) should be rejected *)
+
let test_cases =
+
[
+
(* (request_domain, cookie_domain, description) *)
+
("www.example.com", "com", "TLD .com");
+
("www.example.co.uk", "co.uk", "ccTLD .co.uk");
+
("foo.bar.github.io", "github.io", "private domain github.io");
+
]
+
in
+
+
List.iter
+
(fun (request_domain, cookie_domain, description) ->
+
let header = Printf.sprintf "session=abc; Domain=.%s" cookie_domain in
+
let result =
+
of_set_cookie_header
+
~now:(fun () ->
+
Ptime.of_float_s (Eio.Time.now clock)
+
|> Option.value ~default:Ptime.epoch)
+
~domain:request_domain ~path:"/" header
+
in
+
match result with
+
| Error msg ->
+
(* Should mention public suffix *)
+
let has_psl =
+
String.lowercase_ascii msg |> fun s ->
+
try
+
let _ = Str.search_forward (Str.regexp_string "public suffix") s 0 in
+
true
+
with Not_found -> false
+
in
+
Alcotest.(check bool)
+
(Printf.sprintf "%s: error mentions public suffix" description)
+
true has_psl
+
| Ok _ ->
+
Alcotest.fail
+
(Printf.sprintf "Should reject cookie for %s" description))
+
test_cases
+
+
let test_public_suffix_allowed_when_exact_match () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
(* If request host exactly matches the public suffix domain, allow it.
+
This is rare but possible for private domains like blogspot.com *)
+
let header = "session=abc; Domain=.blogspot.com" in
+
let result =
+
of_set_cookie_header
+
~now:(fun () ->
+
Ptime.of_float_s (Eio.Time.now clock)
+
|> Option.value ~default:Ptime.epoch)
+
~domain:"blogspot.com" ~path:"/" header
+
in
+
Alcotest.(check bool)
+
"exact match allows public suffix" true
+
(Result.is_ok result)
+
+
let test_non_public_suffix_allowed () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
(* Normal domain (not a public suffix) should be allowed *)
+
let test_cases =
+
[
+
("www.example.com", "example.com", "registrable domain");
+
("sub.example.com", "example.com", "parent of subdomain");
+
("www.example.co.uk", "example.co.uk", "registrable domain under ccTLD");
+
]
+
in
+
+
List.iter
+
(fun (request_domain, cookie_domain, description) ->
+
let header = Printf.sprintf "session=abc; Domain=.%s" cookie_domain in
+
let result =
+
of_set_cookie_header
+
~now:(fun () ->
+
Ptime.of_float_s (Eio.Time.now clock)
+
|> Option.value ~default:Ptime.epoch)
+
~domain:request_domain ~path:"/" header
+
in
+
match result with
+
| Ok cookie ->
+
Alcotest.(check string)
+
(Printf.sprintf "%s: domain correct" description)
+
cookie_domain (Cookeio.domain cookie)
+
| Error msg ->
+
Alcotest.fail
+
(Printf.sprintf "%s should be allowed: %s" description msg))
+
test_cases
+
+
let test_public_suffix_no_domain_attribute () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
(* Cookie without Domain attribute should always be allowed (host-only) *)
+
let header = "session=abc; Secure; HttpOnly" in
+
let result =
+
of_set_cookie_header
+
~now:(fun () ->
+
Ptime.of_float_s (Eio.Time.now clock)
+
|> Option.value ~default:Ptime.epoch)
+
~domain:"www.example.com" ~path:"/" header
+
in
+
match result with
+
| Ok cookie ->
+
Alcotest.(check bool) "host_only is true" true (Cookeio.host_only cookie);
+
Alcotest.(check string)
+
"domain is request domain" "www.example.com"
+
(Cookeio.domain cookie)
+
| Error msg -> Alcotest.fail ("Should allow host-only cookie: " ^ msg)
+
+
let test_public_suffix_ip_address_bypass () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
(* IP addresses should bypass PSL check *)
+
let header = "session=abc; Domain=192.168.1.1" in
+
let result =
+
of_set_cookie_header
+
~now:(fun () ->
+
Ptime.of_float_s (Eio.Time.now clock)
+
|> Option.value ~default:Ptime.epoch)
+
~domain:"192.168.1.1" ~path:"/" header
+
in
+
Alcotest.(check bool)
+
"IP address bypasses PSL" true
+
(Result.is_ok result)
+
+
let test_public_suffix_case_insensitive () =
+
Eio_mock.Backend.run @@ fun () ->
+
let clock = Eio_mock.Clock.make () in
+
Eio_mock.Clock.set_time clock 1000.0;
+
+
(* Public suffix check should be case-insensitive *)
+
let header = "session=abc; Domain=.COM" in
+
let result =
+
of_set_cookie_header
+
~now:(fun () ->
+
Ptime.of_float_s (Eio.Time.now clock)
+
|> Option.value ~default:Ptime.epoch)
+
~domain:"www.example.COM" ~path:"/" header
+
in
+
Alcotest.(check bool)
+
"uppercase TLD still rejected" true
+
(Result.is_error result)
+
let () =
Eio_main.run @@ fun env ->
let open Alcotest in
···
test_case "Cookie expiry with mock clock" `Quick
test_cookie_expiry_with_mock_clock;
+
test_case "get_cookies filters expired cookies" `Quick
+
test_get_cookies_filters_expired;
test_case "Max-Age parsing with mock clock" `Quick
test_max_age_parsing_with_mock_clock;
test_case "Last access time with mock clock" `Quick
···
test_case "IPv6 exact match" `Quick test_ipv6_exact_match;
test_case "IPv6 full format" `Quick test_ipv6_full_format;
test_case "IP vs hostname behavior" `Quick test_ip_vs_hostname;
+
] );
+
( "rfc6265_validation",
+
[
+
test_case "valid cookie names" `Quick test_validate_cookie_name_valid;
+
test_case "invalid cookie names" `Quick test_validate_cookie_name_invalid;
+
test_case "valid cookie values" `Quick test_validate_cookie_value_valid;
+
test_case "invalid cookie values" `Quick test_validate_cookie_value_invalid;
+
test_case "valid domain values" `Quick test_validate_domain_valid;
+
test_case "invalid domain values" `Quick test_validate_domain_invalid;
+
test_case "valid path values" `Quick test_validate_path_valid;
+
test_case "invalid path values" `Quick test_validate_path_invalid;
+
test_case "duplicate cookie detection" `Quick test_duplicate_cookie_detection;
+
test_case "validation error messages" `Quick test_validation_error_messages;
+
] );
+
( "cookie_ordering",
+
[
+
test_case "ordering by path length" `Quick
+
test_cookie_ordering_by_path_length;
+
test_case "ordering by creation time" `Quick
+
test_cookie_ordering_by_creation_time;
+
test_case "ordering combined" `Quick test_cookie_ordering_combined;
+
] );
+
( "creation_time_preservation",
+
[
+
test_case "preserved on update" `Quick
+
test_creation_time_preserved_on_update;
+
test_case "preserved in add_original" `Quick
+
test_creation_time_preserved_add_original;
+
test_case "new cookie keeps time" `Quick test_creation_time_new_cookie;
+
] );
+
( "public_suffix_validation",
+
[
+
test_case "reject public suffix domains" `Quick
+
test_public_suffix_rejection;
+
test_case "allow exact match on public suffix" `Quick
+
test_public_suffix_allowed_when_exact_match;
+
test_case "allow non-public-suffix domains" `Quick
+
test_non_public_suffix_allowed;
+
test_case "no Domain attribute bypasses PSL" `Quick
+
test_public_suffix_no_domain_attribute;
+
test_case "IP address bypasses PSL" `Quick
+
test_public_suffix_ip_address_bypass;
+
test_case "case insensitive check" `Quick
+
test_public_suffix_case_insensitive;
] );