OCaml HTTP cookie handling library with support for Eio-based storage jars
anil.recoil.org
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6let src = Logs.Src.create "cookeio" ~doc:"Cookie management"
7
8module Log = (val Logs.src_log src : Logs.LOG)
9
10(** SameSite attribute for cross-site request control.
11
12 The SameSite attribute is defined in the RFC 6265bis draft and controls
13 whether cookies are sent with cross-site requests.
14
15 @see <https://datatracker.ietf.org/doc/html/draft-ietf-httpbis-rfc6265bis#section-5.4.7> RFC 6265bis Section 5.4.7 - The SameSite Attribute *)
16module SameSite = struct
17 type t = [ `Strict | `Lax | `None ]
18
19 let equal = ( = )
20
21 let pp ppf = function
22 | `Strict -> Format.pp_print_string ppf "Strict"
23 | `Lax -> Format.pp_print_string ppf "Lax"
24 | `None -> Format.pp_print_string ppf "None"
25end
26
27(** Cookie expiration type.
28
29 Per {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.3} RFC 6265 Section 5.3},
30 cookies have either a persistent expiry time or are session cookies that
31 expire when the user agent session ends.
32
33 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model *)
34module Expiration = struct
35 type t = [ `Session | `DateTime of Ptime.t ]
36
37 let equal e1 e2 =
38 match (e1, e2) with
39 | `Session, `Session -> true
40 | `DateTime t1, `DateTime t2 -> Ptime.equal t1 t2
41 | _ -> false
42
43 let pp ppf = function
44 | `Session -> Format.pp_print_string ppf "Session"
45 | `DateTime t -> Format.fprintf ppf "DateTime(%a)" Ptime.pp t
46end
47
48type t = {
49 domain : string;
50 path : string;
51 name : string;
52 value : string;
53 secure : bool;
54 http_only : bool;
55 partitioned : bool;
56 host_only : bool;
57 expires : Expiration.t option;
58 max_age : Ptime.Span.t option;
59 same_site : SameSite.t option;
60 creation_time : Ptime.t;
61 last_access : Ptime.t;
62}
63(** HTTP Cookie *)
64
65(** {1 Cookie Accessors} *)
66
67let domain cookie = cookie.domain
68let path cookie = cookie.path
69let name cookie = cookie.name
70let value cookie = cookie.value
71
72let value_trimmed cookie =
73 let v = cookie.value in
74 let len = String.length v in
75 if len < 2 then v
76 else
77 match (v.[0], v.[len - 1]) with
78 | '"', '"' -> String.sub v 1 (len - 2)
79 | _ -> v
80
81let secure cookie = cookie.secure
82let http_only cookie = cookie.http_only
83let partitioned cookie = cookie.partitioned
84let host_only cookie = cookie.host_only
85let expires cookie = cookie.expires
86let max_age cookie = cookie.max_age
87let same_site cookie = cookie.same_site
88let creation_time cookie = cookie.creation_time
89let last_access cookie = cookie.last_access
90
91let make ~domain ~path ~name ~value ?(secure = false) ?(http_only = false)
92 ?expires ?max_age ?same_site ?(partitioned = false) ?(host_only = false)
93 ~creation_time ~last_access () =
94 {
95 domain;
96 path;
97 name;
98 value;
99 secure;
100 http_only;
101 partitioned;
102 host_only;
103 expires;
104 max_age;
105 same_site;
106 creation_time;
107 last_access;
108 }
109
110(** {1 RFC 6265 Validation}
111
112 Validation functions for cookie names, values, and attributes per
113 {{:https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1} RFC 6265 Section 4.1.1}.
114
115 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 - Syntax *)
116module Validate = struct
117 (** Check if a character is a valid RFC 2616 token character.
118
119 Per RFC 6265, cookie-name must be a token as defined in RFC 2616 Section 2.2:
120 token = 1*<any CHAR except CTLs or separators>
121 separators = "(" | ")" | "<" | ">" | "@" | "," | ";" | ":" | "\" |
122 <"> | "/" | "[" | "]" | "?" | "=" | "{" | "}" | SP | HT
123
124 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
125 let is_token_char = function
126 | '\x00' .. '\x1F' | '\x7F' -> false (* CTL characters *)
127 | '(' | ')' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"' | '/' | '['
128 | ']' | '?' | '=' | '{' | '}' | ' ' ->
129 false (* separators - note: HT (0x09) is already covered by CTL range *)
130 | _ -> true
131
132 (** Validate a cookie name per RFC 6265.
133
134 Cookie names must be valid RFC 2616 tokens: one or more characters
135 excluding control characters and separators.
136
137 @param name The cookie name to validate
138 @return [Ok name] if valid, [Error message] with explanation if invalid
139
140 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
141 let cookie_name name =
142 let len = String.length name in
143 if len = 0 then
144 Error "Cookie name is empty; RFC 6265 requires at least one character"
145 else
146 let rec find_invalid i acc =
147 if i >= len then acc
148 else
149 let c = String.unsafe_get name i in
150 if is_token_char c then find_invalid (i + 1) acc
151 else find_invalid (i + 1) (c :: acc)
152 in
153 match find_invalid 0 [] with
154 | [] -> Ok name
155 | invalid_chars ->
156 let chars_str =
157 invalid_chars
158 |> List.rev
159 |> List.map (fun c -> Printf.sprintf "%C" c)
160 |> String.concat ", "
161 in
162 Error
163 (Printf.sprintf
164 "Cookie name %S contains invalid characters: %s. RFC 6265 requires \
165 cookie names to be valid tokens (no control characters, spaces, \
166 or separators like ()[]{}=,;:@\\\"/?<>)"
167 name chars_str)
168
169 (** Check if a character is a valid cookie-octet.
170
171 Per RFC 6265 Section 4.1.1:
172 cookie-octet = %x21 / %x23-2B / %x2D-3A / %x3C-5B / %x5D-7E
173 (US-ASCII excluding CTLs, whitespace, DQUOTE, comma, semicolon, backslash)
174
175 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
176 let is_cookie_octet = function
177 | '\x21' -> true (* ! *)
178 | '\x23' .. '\x2B' -> true (* # $ % & ' ( ) * + *)
179 | '\x2D' .. '\x3A' -> true (* - . / 0-9 : *)
180 | '\x3C' .. '\x5B' -> true (* < = > ? @ A-Z [ *)
181 | '\x5D' .. '\x7E' -> true (* ] ^ _ ` a-z { | } ~ *)
182 | _ -> false
183
184 (** Validate a cookie value per RFC 6265.
185
186 Cookie values must contain only cookie-octets, optionally wrapped in
187 double quotes. Invalid characters include: control characters, space,
188 double quote (except as wrapper), comma, semicolon, and backslash.
189
190 @param value The cookie value to validate
191 @return [Ok value] if valid, [Error message] with explanation if invalid
192
193 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
194 let cookie_value value =
195 (* Handle optional DQUOTE wrapper *)
196 let len = String.length value in
197 let inner_value, inner_len =
198 if len >= 2 && value.[0] = '"' && value.[len - 1] = '"' then
199 (String.sub value 1 (len - 2), len - 2)
200 else (value, len)
201 in
202 let rec find_invalid i acc =
203 if i >= inner_len then acc
204 else
205 let c = String.unsafe_get inner_value i in
206 if is_cookie_octet c then find_invalid (i + 1) acc
207 else find_invalid (i + 1) (c :: acc)
208 in
209 match find_invalid 0 [] with
210 | [] -> Ok value
211 | invalid_chars ->
212 let chars_str =
213 invalid_chars
214 |> List.rev
215 |> List.map (fun c ->
216 match c with
217 | ' ' -> "space (0x20)"
218 | '"' -> "double-quote (0x22)"
219 | ',' -> "comma (0x2C)"
220 | ';' -> "semicolon (0x3B)"
221 | '\\' -> "backslash (0x5C)"
222 | c when Char.code c < 0x20 ->
223 Printf.sprintf "control char (0x%02X)" (Char.code c)
224 | c -> Printf.sprintf "%C (0x%02X)" c (Char.code c))
225 |> String.concat ", "
226 in
227 Error
228 (Printf.sprintf
229 "Cookie value %S contains invalid characters: %s. RFC 6265 cookie \
230 values may only contain printable ASCII excluding space, \
231 double-quote, comma, semicolon, and backslash"
232 value chars_str)
233
234 (** Validate a domain attribute value.
235
236 Domain values must be either:
237 - A valid domain name per RFC 1034 Section 3.5
238 - A valid IPv4 address
239 - A valid IPv6 address
240
241 @param domain The domain value to validate (leading dot is stripped first)
242 @return [Ok domain] if valid, [Error message] with explanation if invalid
243
244 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.2.3> RFC 6265 Section 4.1.2.3
245 @see <https://datatracker.ietf.org/doc/html/rfc1034#section-3.5> RFC 1034 Section 3.5 *)
246 let domain_value domain =
247 (* Strip leading dot per RFC 6265 Section 5.2.3 *)
248 let domain =
249 if String.starts_with ~prefix:"." domain && String.length domain > 1 then
250 String.sub domain 1 (String.length domain - 1)
251 else domain
252 in
253 if String.length domain = 0 then
254 Error "Domain attribute is empty"
255 else
256 (* First check if it's an IP address *)
257 match Ipaddr.of_string domain with
258 | Ok _ -> Ok domain (* Valid IP address *)
259 | Error _ -> (
260 (* Not an IP, validate as domain name using domain-name library *)
261 match Domain_name.of_string domain with
262 | Ok _ -> Ok domain
263 | Error (`Msg msg) ->
264 Error
265 (Printf.sprintf
266 "Domain %S is not a valid domain name: %s. Domain names \
267 must follow RFC 1034: labels must start with a letter, \
268 contain only letters/digits/hyphens, not end with a \
269 hyphen, and be at most 63 characters each"
270 domain msg))
271
272 (** Validate a path attribute value.
273
274 Per RFC 6265 Section 4.1.1, path-value may contain any CHAR except
275 control characters and semicolon.
276
277 @param path The path value to validate
278 @return [Ok path] if valid, [Error message] with explanation if invalid
279
280 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1 *)
281 let path_value path =
282 let len = String.length path in
283 let rec find_invalid i acc =
284 if i >= len then acc
285 else
286 let c = String.unsafe_get path i in
287 match c with
288 | '\x00' .. '\x1F' | '\x7F' | ';' -> find_invalid (i + 1) (c :: acc)
289 | _ -> find_invalid (i + 1) acc
290 in
291 match find_invalid 0 [] with
292 | [] -> Ok path
293 | invalid_chars ->
294 let chars_str =
295 invalid_chars
296 |> List.rev
297 |> List.map (fun c -> Printf.sprintf "0x%02X" (Char.code c))
298 |> String.concat ", "
299 in
300 Error
301 (Printf.sprintf
302 "Path %S contains invalid characters: %s. Paths may not contain \
303 control characters or semicolons"
304 path chars_str)
305
306 (** Validate a Max-Age attribute value.
307
308 Per RFC 6265 Section 4.1.1, max-age-av uses non-zero-digit *DIGIT.
309 However, per Section 5.2.2, user agents should treat values <= 0 as
310 "delete immediately". This function returns [Ok] for any integer since
311 the parsing code handles negative values by converting to 0.
312
313 @param seconds The Max-Age value in seconds
314 @return [Ok seconds] always (negative values are handled in parsing)
315
316 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1.1> RFC 6265 Section 4.1.1
317 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.2.2> RFC 6265 Section 5.2.2 *)
318 let max_age seconds = Ok seconds
319end
320
321(** {1 Public Suffix Validation}
322
323 Per {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.3} RFC 6265 Section 5.3 Step 5},
324 cookies with Domain attributes that are public suffixes must be rejected
325 to prevent domain-wide cookie attacks.
326
327 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model
328 @see <https://publicsuffix.org/list/> Public Suffix List *)
329
330(** Module-level Public Suffix List instance.
331
332 Lazily initialized on first use. The PSL data is compiled into the
333 publicsuffix library at build time from the Mozilla Public Suffix List. *)
334let psl = lazy (Publicsuffix.create ())
335
336(** Validate that a cookie domain is not a public suffix.
337
338 Per RFC 6265 Section 5.3 Step 5, user agents MUST reject cookies where
339 the Domain attribute is a public suffix (e.g., ".com", ".co.uk") unless
340 the request host exactly matches that domain.
341
342 This prevents attackers from setting domain-wide cookies that would affect
343 all sites under a TLD.
344
345 @param request_domain The host from the HTTP request
346 @param cookie_domain The Domain attribute value (already normalized, without leading dot)
347 @return [Ok ()] if the domain is allowed, [Error msg] if it's a public suffix
348
349 Examples:
350 - Request from "www.example.com", Domain=".com" → Error (public suffix)
351 - Request from "www.example.com", Domain=".example.com" → Ok (not public suffix)
352 - Request from "com", Domain=".com" → Ok (request host matches domain exactly)
353
354 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 *)
355let validate_not_public_suffix ~request_domain ~cookie_domain =
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.
371 This allows a server that IS a public suffix (rare but possible with
372 private domains like blogspot.com) to set cookies for itself. *)
373 let request_lower = String.lowercase_ascii request_domain in
374 let cookie_lower = String.lowercase_ascii cookie_domain in
375 if request_lower = cookie_lower then Ok ()
376 else
377 Error
378 (Printf.sprintf
379 "Domain %S is a public suffix; RFC 6265 Section 5.3 prohibits \
380 setting cookies for public suffixes to prevent domain-wide \
381 cookie attacks. The request host %S does not exactly match \
382 the domain."
383 cookie_domain request_domain))
384
385(** {1 Cookie Parsing Helpers} *)
386
387(** Normalize a domain by stripping the leading dot.
388
389 Per {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.2.3} RFC 6265 Section 5.2.3},
390 if the first character of the Domain attribute value is ".", that character
391 is ignored (the domain remains case-insensitive).
392
393 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.2.3> RFC 6265 Section 5.2.3 - The Domain Attribute *)
394let normalize_domain domain =
395 match String.starts_with ~prefix:"." domain with
396 | true when String.length domain > 1 ->
397 String.sub domain 1 (String.length domain - 1)
398 | _ -> domain
399
400(** {1 HTTP Date Parsing}
401
402 Date parsing follows {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.1.1} RFC 6265 Section 5.1.1}
403 which requires parsing dates in various HTTP formats. *)
404
405module DateParser = struct
406 (** Month name to number mapping (case-insensitive).
407
408 Per {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.1.1} RFC 6265 Section 5.1.1},
409 month tokens are matched case-insensitively.
410
411 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.1.1> RFC 6265 Section 5.1.1 - Dates *)
412 let month_of_string s =
413 match String.lowercase_ascii s with
414 | "jan" -> Some 1
415 | "feb" -> Some 2
416 | "mar" -> Some 3
417 | "apr" -> Some 4
418 | "may" -> Some 5
419 | "jun" -> Some 6
420 | "jul" -> Some 7
421 | "aug" -> Some 8
422 | "sep" -> Some 9
423 | "oct" -> Some 10
424 | "nov" -> Some 11
425 | "dec" -> Some 12
426 | _ -> None
427
428 (** Normalize abbreviated years per RFC 6265.
429
430 Per {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.1.1} RFC 6265 Section 5.1.1}:
431 - Years 70-99 get 1900 added (e.g., 95 → 1995)
432 - Years 0-69 get 2000 added (e.g., 25 → 2025)
433 - Years >= 100 are returned as-is
434
435 Note: This implementation treats year 69 as 1969 (adding 1900), which
436 technically differs from the RFC's "70 and less than or equal to 99" rule.
437
438 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.1.1> RFC 6265 Section 5.1.1 - Dates *)
439 let normalize_year year =
440 if year >= 0 && year <= 68 then year + 2000
441 else if year >= 69 && year <= 99 then year + 1900
442 else year
443
444 (** Parse FMT1: "Wed, 21 Oct 2015 07:28:00 GMT" (RFC 1123) *)
445 let parse_fmt1 s =
446 try
447 Scanf.sscanf s "%s %d %s %d %d:%d:%d %s"
448 (fun _wday day mon year hour min sec tz ->
449 (* Check timezone is GMT (case-insensitive) *)
450 if String.lowercase_ascii tz <> "gmt" then None
451 else
452 match month_of_string mon with
453 | None -> None
454 | Some month ->
455 let year = normalize_year year in
456 Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
457 with _ -> None
458
459 (** Parse FMT2: "Wednesday, 21-Oct-15 07:28:00 GMT" (RFC 850) *)
460 let parse_fmt2 s =
461 try
462 Scanf.sscanf s "%[^,], %d-%3s-%d %d:%d:%d %s"
463 (fun _wday day mon year hour min sec tz ->
464 (* Check timezone is GMT (case-insensitive) *)
465 if String.lowercase_ascii tz <> "gmt" then None
466 else
467 match month_of_string mon with
468 | None -> None
469 | Some month ->
470 let year = normalize_year year in
471 Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
472 with _ -> None
473
474 (** Parse FMT3: "Wed Oct 21 07:28:00 2015" (asctime) *)
475 let parse_fmt3 s =
476 try
477 Scanf.sscanf s "%s %s %d %d:%d:%d %d"
478 (fun _wday mon day hour min sec year ->
479 match month_of_string mon with
480 | None -> None
481 | Some month ->
482 let year = normalize_year year in
483 Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
484 with _ -> None
485
486 (** Parse FMT4: "Wed, 21-Oct-2015 07:28:00 GMT" (variant) *)
487 let parse_fmt4 s =
488 try
489 Scanf.sscanf s "%s %d-%3s-%d %d:%d:%d %s"
490 (fun _wday day mon year hour min sec tz ->
491 (* Check timezone is GMT (case-insensitive) *)
492 if String.lowercase_ascii tz <> "gmt" then None
493 else
494 match month_of_string mon with
495 | None -> None
496 | Some month ->
497 let year = normalize_year year in
498 Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
499 with _ -> None
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))
510end
511
512(** {1 Cookie Parsing} *)
513
514type cookie_attributes = {
515 mutable domain : string option;
516 mutable path : string option;
517 mutable secure : bool;
518 mutable http_only : bool;
519 mutable partitioned : bool;
520 mutable expires : Expiration.t option;
521 mutable max_age : Ptime.Span.t option;
522 mutable same_site : SameSite.t option;
523}
524(** Accumulated attributes from parsing Set-Cookie header *)
525
526(** Create empty attribute accumulator *)
527let empty_attributes () =
528 {
529 domain = None;
530 path = None;
531 secure = false;
532 http_only = false;
533 partitioned = false;
534 expires = None;
535 max_age = None;
536 same_site = None;
537 }
538
539(** Parse a single cookie attribute and update the accumulator in-place.
540
541 Attribute parsing follows {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.2} RFC 6265 Section 5.2}
542 which defines the grammar and semantics for each cookie attribute.
543
544 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.2> RFC 6265 Section 5.2 - The Set-Cookie Header *)
545let parse_attribute now attrs attr_name attr_value =
546 let attr_lower = String.lowercase_ascii attr_name in
547 match attr_lower with
548 | "domain" -> attrs.domain <- Some (normalize_domain attr_value)
549 | "path" -> attrs.path <- Some attr_value
550 | "expires" -> (
551 if
552 (* Special case: Expires=0 means session cookie *)
553 attr_value = "0"
554 then attrs.expires <- Some `Session
555 else
556 match Ptime.of_rfc3339 attr_value with
557 | Ok (time, _, _) -> attrs.expires <- Some (`DateTime time)
558 | Error (`RFC3339 (_, err)) -> (
559 (* Try HTTP date format as fallback *)
560 match DateParser.parse_http_date attr_value with
561 | Some time -> attrs.expires <- Some (`DateTime time)
562 | None ->
563 Log.warn (fun m ->
564 m "Failed to parse expires attribute '%s': %a" attr_value
565 Ptime.pp_rfc3339_error err)))
566 | "max-age" -> (
567 match int_of_string_opt attr_value with
568 | Some seconds ->
569 (* Handle negative values as 0 per RFC 6265 *)
570 let seconds = max 0 seconds in
571 let current_time = now () in
572 (* Store the max-age as a Ptime.Span *)
573 attrs.max_age <- Some (Ptime.Span.of_int_s seconds);
574 (* Also compute and store expires as DateTime *)
575 let expires =
576 Ptime.add_span current_time (Ptime.Span.of_int_s seconds)
577 in
578 (match expires with
579 | Some time -> attrs.expires <- Some (`DateTime time)
580 | None -> ());
581 Log.debug (fun m -> m "Parsed Max-Age: %d seconds" seconds)
582 | None ->
583 Log.warn (fun m ->
584 m "Failed to parse max-age attribute '%s'" attr_value))
585 | "secure" -> attrs.secure <- true
586 | "httponly" -> attrs.http_only <- true
587 | "partitioned" -> attrs.partitioned <- true
588 | "samesite" -> (
589 match String.lowercase_ascii attr_value with
590 | "strict" -> attrs.same_site <- Some `Strict
591 | "lax" -> attrs.same_site <- Some `Lax
592 | "none" -> attrs.same_site <- Some `None
593 | _ ->
594 Log.warn (fun m ->
595 m "Invalid samesite value '%s', ignoring" attr_value))
596 | _ ->
597 Log.debug (fun m -> m "Unknown cookie attribute '%s', ignoring" attr_name)
598
599(** Validate cookie attributes and log warnings for invalid combinations.
600
601 Validates:
602 - SameSite=None requires the Secure flag (per RFC 6265bis)
603 - Partitioned requires the Secure flag (per CHIPS specification)
604
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 *)
607let 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
633 Per {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.3} RFC 6265 Section 5.3}:
634 - If Domain attribute is present, host-only-flag = false, domain = attribute value
635 - If Domain attribute is absent, host-only-flag = true, domain = request host
636
637 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.3> RFC 6265 Section 5.3 - Storage Model *)
638let build_cookie ~request_domain ~request_path ~name ~value attrs ~now =
639 let host_only, domain =
640 match attrs.domain with
641 | Some d -> (false, normalize_domain d)
642 | None -> (true, request_domain)
643 in
644 let path = Option.value attrs.path ~default:request_path in
645 make ~domain ~path ~name ~value ~secure:attrs.secure
646 ~http_only:attrs.http_only ?expires:attrs.expires ?max_age:attrs.max_age
647 ?same_site:attrs.same_site ~partitioned:attrs.partitioned ~host_only
648 ~creation_time:now ~last_access:now ()
649
650(** {1 Pretty Printing} *)
651
652let pp ppf cookie =
653 Format.fprintf ppf
654 "@[<hov 2>{ name=%S;@ value=%S;@ domain=%S;@ path=%S;@ secure=%b;@ \
655 http_only=%b;@ partitioned=%b;@ host_only=%b;@ expires=%a;@ max_age=%a;@ \
656 same_site=%a }@]"
657 (name cookie) (value cookie) (domain cookie) (path cookie) (secure cookie)
658 (http_only cookie) (partitioned cookie) (host_only cookie)
659 (Format.pp_print_option Expiration.pp)
660 (expires cookie)
661 (Format.pp_print_option Ptime.Span.pp)
662 (max_age cookie)
663 (Format.pp_print_option SameSite.pp)
664 (same_site cookie)
665
666(** {1 Cookie Parsing} *)
667
668(** Parse a Set-Cookie HTTP response header.
669
670 Parses the header according to {{:https://datatracker.ietf.org/doc/html/rfc6265#section-5.2} RFC 6265 Section 5.2},
671 extracting the cookie name, value, and all attributes. Returns [Error msg] if
672 the cookie is invalid or fails validation, with a descriptive error message.
673
674 @param now Function returning current time for Max-Age computation
675 @param domain The request host (used as default domain)
676 @param path The request path (used as default path)
677 @param header_value The Set-Cookie header value string
678 @return [Ok cookie] if parsing succeeds, [Error msg] with explanation if invalid
679
680 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-5.2> RFC 6265 Section 5.2 - The Set-Cookie Header *)
681let of_set_cookie_header ~now ~domain:request_domain ~path:request_path
682 header_value =
683 Log.debug (fun m -> m "Parsing Set-Cookie: %s" header_value);
684
685 (* Split into attributes *)
686 let parts = String.split_on_char ';' header_value |> List.map String.trim in
687
688 match parts with
689 | [] -> Error "Empty Set-Cookie header"
690 | name_value :: attrs -> (
691 (* Parse name=value *)
692 match String.index_opt name_value '=' with
693 | None ->
694 Error
695 (Printf.sprintf
696 "Set-Cookie header missing '=' separator in name-value pair: %S"
697 name_value)
698 | Some eq_pos -> (
699 let name = String.sub name_value 0 eq_pos |> String.trim in
700 let cookie_value =
701 String.sub name_value (eq_pos + 1)
702 (String.length name_value - eq_pos - 1)
703 |> String.trim
704 in
705
706 (* Validate cookie name per RFC 6265 *)
707 match Validate.cookie_name name with
708 | Error msg -> Error msg
709 | Ok name -> (
710 (* Validate cookie value per RFC 6265 *)
711 match Validate.cookie_value cookie_value with
712 | Error msg -> Error msg
713 | Ok cookie_value ->
714 let current_time = now () in
715
716 (* Parse all attributes into mutable accumulator *)
717 let accumulated_attrs = empty_attributes () in
718 let attr_errors = ref [] in
719 List.iter
720 (fun attr ->
721 match String.index_opt attr '=' with
722 | None ->
723 (* Attribute without value (e.g., Secure, HttpOnly) *)
724 parse_attribute now accumulated_attrs attr ""
725 | Some eq ->
726 let attr_name = String.sub attr 0 eq |> String.trim in
727 let attr_value =
728 String.sub attr (eq + 1)
729 (String.length attr - eq - 1)
730 |> String.trim
731 in
732 (* Validate domain and path attributes *)
733 (match String.lowercase_ascii attr_name with
734 | "domain" -> (
735 match Validate.domain_value attr_value with
736 | Error msg -> attr_errors := msg :: !attr_errors
737 | Ok _ -> ())
738 | "path" -> (
739 match Validate.path_value attr_value with
740 | Error msg -> attr_errors := msg :: !attr_errors
741 | Ok _ -> ())
742 | "max-age" -> (
743 match int_of_string_opt attr_value with
744 | Some seconds -> (
745 match Validate.max_age seconds with
746 | Error msg ->
747 attr_errors := msg :: !attr_errors
748 | Ok _ -> ())
749 | None -> ())
750 | _ -> ());
751 parse_attribute now accumulated_attrs attr_name
752 attr_value)
753 attrs;
754
755 (* Check for attribute validation errors *)
756 if List.length !attr_errors > 0 then
757 Error (String.concat "; " (List.rev !attr_errors))
758 else if not (validate_attributes accumulated_attrs) then
759 Error
760 "Cookie validation failed: SameSite=None requires \
761 Secure flag, and Partitioned requires Secure flag"
762 else
763 (* Public suffix validation per RFC 6265 Section 5.3 Step 5.
764 Only applies when Domain attribute is present. *)
765 let psl_result =
766 match accumulated_attrs.domain with
767 | None ->
768 (* No Domain attribute - cookie is host-only, no PSL check needed *)
769 Ok ()
770 | Some cookie_domain ->
771 let normalized = normalize_domain cookie_domain in
772 validate_not_public_suffix ~request_domain ~cookie_domain:normalized
773 in
774 (match psl_result with
775 | Error msg -> Error msg
776 | Ok () ->
777 let cookie =
778 build_cookie ~request_domain ~request_path ~name
779 ~value:cookie_value accumulated_attrs ~now:current_time
780 in
781 Log.debug (fun m -> m "Parsed cookie: %a" pp cookie);
782 Ok cookie))))
783
784(** Parse a Cookie HTTP request header.
785
786 Parses the header according to {{:https://datatracker.ietf.org/doc/html/rfc6265#section-4.2} RFC 6265 Section 4.2}.
787 The Cookie header contains semicolon-separated name=value pairs.
788
789 Validates cookie names and values per RFC 6265 and detects duplicate
790 cookie names (which is an error per Section 4.2.1).
791
792 Cookies parsed from the Cookie header have [host_only = true] since we
793 cannot determine from the header alone whether they originally had a
794 Domain attribute.
795
796 @param now Function returning current time for timestamps
797 @param domain The request host (assigned to all parsed cookies)
798 @param path The request path (assigned to all parsed cookies)
799 @param header_value The Cookie header value string
800 @return [Ok cookies] if all cookies parse successfully with no duplicates,
801 [Error msg] with explanation if validation fails
802
803 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.2> RFC 6265 Section 4.2 - The Cookie Header *)
804let of_cookie_header ~now ~domain ~path header_value =
805 Log.debug (fun m -> m "Parsing Cookie header: %s" header_value);
806
807 (* Split on semicolons *)
808 let parts = String.split_on_char ';' header_value |> List.map String.trim in
809
810 (* Filter out empty parts *)
811 let parts = List.filter (fun s -> String.length s > 0) parts in
812
813 (* Parse each name=value pair, collecting results *)
814 let results =
815 List.fold_left
816 (fun acc name_value ->
817 match acc with
818 | Error _ -> acc (* Propagate earlier errors *)
819 | Ok (cookies, seen_names) -> (
820 match String.index_opt name_value '=' with
821 | None ->
822 Error
823 (Printf.sprintf "Cookie missing '=' separator: %S" name_value)
824 | Some eq_pos -> (
825 let cookie_name =
826 String.sub name_value 0 eq_pos |> String.trim
827 in
828 (* Validate cookie name per RFC 6265 *)
829 match Validate.cookie_name cookie_name with
830 | Error msg -> Error msg
831 | Ok cookie_name -> (
832 (* Check for duplicate names per RFC 6265 Section 4.2.1 *)
833 if List.mem cookie_name seen_names then
834 Error
835 (Printf.sprintf
836 "Duplicate cookie name %S in Cookie header; RFC \
837 6265 Section 4.2.1 forbids duplicate names"
838 cookie_name)
839 else
840 let cookie_value =
841 String.sub name_value (eq_pos + 1)
842 (String.length name_value - eq_pos - 1)
843 |> String.trim
844 in
845 (* Validate cookie value per RFC 6265 *)
846 match Validate.cookie_value cookie_value with
847 | Error msg -> Error msg
848 | Ok cookie_value ->
849 let current_time = now () in
850 (* Create cookie with defaults from Cookie header context.
851 Cookies from Cookie headers have host_only=true since we don't
852 know if they originally had a Domain attribute. *)
853 let cookie =
854 make ~domain ~path ~name:cookie_name
855 ~value:cookie_value ~secure:false ~http_only:false
856 ~partitioned:false ~host_only:true
857 ~creation_time:current_time
858 ~last_access:current_time ()
859 in
860 Ok (cookie :: cookies, cookie_name :: seen_names)))))
861 (Ok ([], []))
862 parts
863 in
864 match results with
865 | Error msg -> Error msg
866 | Ok (cookies, _) -> Ok (List.rev cookies)
867
868(** Generate a Cookie HTTP request header from a list of cookies.
869
870 Formats cookies according to {{:https://datatracker.ietf.org/doc/html/rfc6265#section-4.2} RFC 6265 Section 4.2}
871 as semicolon-separated name=value pairs.
872
873 @param cookies List of cookies to include
874 @return The Cookie header value string
875
876 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.2> RFC 6265 Section 4.2 - The Cookie Header *)
877let make_cookie_header cookies =
878 cookies
879 |> List.map (fun c -> Printf.sprintf "%s=%s" (name c) (value c))
880 |> String.concat "; "
881
882(** Generate a Set-Cookie HTTP response header from a cookie.
883
884 Formats the cookie according to {{:https://datatracker.ietf.org/doc/html/rfc6265#section-4.1} RFC 6265 Section 4.1}
885 including all attributes.
886
887 Note: The Expires attribute is currently formatted using RFC 3339, which
888 differs from the RFC-recommended rfc1123-date format.
889
890 @param cookie The cookie to serialize
891 @return The Set-Cookie header value string
892
893 @see <https://datatracker.ietf.org/doc/html/rfc6265#section-4.1> RFC 6265 Section 4.1 - The Set-Cookie Header *)
894let make_set_cookie_header cookie =
895 let buffer = Buffer.create 128 in
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));
920
921 (* Add Path *)
922 Buffer.add_string buffer (Printf.sprintf "; Path=%s" (path cookie));
923
924 (* Add Secure flag *)
925 if secure cookie then Buffer.add_string buffer "; Secure";
926
927 (* Add HttpOnly flag *)
928 if http_only cookie then Buffer.add_string buffer "; HttpOnly";
929
930 (* Add Partitioned flag *)
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 -> ());
939
940 Buffer.contents buffer