OCaml HTTP cookie handling library with support for Eio-based storage jars
anil.recoil.org
1let src = Logs.Src.create "cookeio" ~doc:"Cookie management"
2
3module Log = (val Logs.src_log src : Logs.LOG)
4
5module SameSite = struct
6 type t = [ `Strict | `Lax | `None ]
7
8 let equal = ( = )
9
10 let pp ppf = function
11 | `Strict -> Format.pp_print_string ppf "Strict"
12 | `Lax -> Format.pp_print_string ppf "Lax"
13 | `None -> Format.pp_print_string ppf "None"
14end
15
16module Expiration = struct
17 type t = [ `Session | `DateTime of Ptime.t ]
18
19 let equal e1 e2 =
20 match (e1, e2) with
21 | `Session, `Session -> true
22 | `DateTime t1, `DateTime t2 -> Ptime.equal t1 t2
23 | _ -> false
24
25 let pp ppf = function
26 | `Session -> Format.pp_print_string ppf "Session"
27 | `DateTime t -> Format.fprintf ppf "DateTime(%a)" Ptime.pp t
28end
29
30type t = {
31 domain : string;
32 path : string;
33 name : string;
34 value : string;
35 secure : bool;
36 http_only : bool;
37 partitioned : bool;
38 expires : Expiration.t option;
39 max_age : Ptime.Span.t option;
40 same_site : SameSite.t option;
41 creation_time : Ptime.t;
42 last_access : Ptime.t;
43}
44(** HTTP Cookie *)
45
46(** {1 Cookie Accessors} *)
47
48let domain cookie = cookie.domain
49let path cookie = cookie.path
50let name cookie = cookie.name
51let value cookie = cookie.value
52
53let value_trimmed cookie =
54 let v = cookie.value in
55 let len = String.length v in
56 if len < 2 then v
57 else
58 match (v.[0], v.[len - 1]) with
59 | '"', '"' -> String.sub v 1 (len - 2)
60 | _ -> v
61
62let secure cookie = cookie.secure
63let http_only cookie = cookie.http_only
64let partitioned cookie = cookie.partitioned
65let expires cookie = cookie.expires
66let max_age cookie = cookie.max_age
67let same_site cookie = cookie.same_site
68let creation_time cookie = cookie.creation_time
69let last_access cookie = cookie.last_access
70
71let make ~domain ~path ~name ~value ?(secure = false) ?(http_only = false)
72 ?expires ?max_age ?same_site ?(partitioned = false) ~creation_time
73 ~last_access () =
74 {
75 domain;
76 path;
77 name;
78 value;
79 secure;
80 http_only;
81 partitioned;
82 expires;
83 max_age;
84 same_site;
85 creation_time;
86 last_access;
87 }
88
89(** {1 Cookie Parsing Helpers} *)
90
91let normalize_domain domain =
92 (* Strip leading dot per RFC 6265 *)
93 match String.starts_with ~prefix:"." domain with
94 | true when String.length domain > 1 ->
95 String.sub domain 1 (String.length domain - 1)
96 | _ -> domain
97
98(** {1 HTTP Date Parsing} *)
99
100module DateParser = struct
101 (** Month name to number mapping (case-insensitive) *)
102 let month_of_string s =
103 match String.lowercase_ascii s with
104 | "jan" -> Some 1
105 | "feb" -> Some 2
106 | "mar" -> Some 3
107 | "apr" -> Some 4
108 | "may" -> Some 5
109 | "jun" -> Some 6
110 | "jul" -> Some 7
111 | "aug" -> Some 8
112 | "sep" -> Some 9
113 | "oct" -> Some 10
114 | "nov" -> Some 11
115 | "dec" -> Some 12
116 | _ -> None
117
118 (** Normalize abbreviated years:
119 - Years 69-99 get 1900 added (e.g., 95 → 1995)
120 - Years 0-68 get 2000 added (e.g., 25 → 2025)
121 - Years >= 100 are returned as-is *)
122 let normalize_year year =
123 if year >= 0 && year <= 68 then year + 2000
124 else if year >= 69 && year <= 99 then year + 1900
125 else year
126
127 (** Parse FMT1: "Wed, 21 Oct 2015 07:28:00 GMT" (RFC 1123) *)
128 let parse_fmt1 s =
129 try
130 Scanf.sscanf s "%s %d %s %d %d:%d:%d %s"
131 (fun _wday day mon year hour min sec tz ->
132 (* Check timezone is GMT (case-insensitive) *)
133 if String.lowercase_ascii tz <> "gmt" then None
134 else
135 match month_of_string mon with
136 | None -> None
137 | Some month ->
138 let year = normalize_year year in
139 Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
140 with _ -> None
141
142 (** Parse FMT2: "Wednesday, 21-Oct-15 07:28:00 GMT" (RFC 850) *)
143 let parse_fmt2 s =
144 try
145 Scanf.sscanf s "%[^,], %d-%3s-%d %d:%d:%d %s"
146 (fun _wday day mon year hour min sec tz ->
147 (* Check timezone is GMT (case-insensitive) *)
148 if String.lowercase_ascii tz <> "gmt" then None
149 else
150 match month_of_string mon with
151 | None -> None
152 | Some month ->
153 let year = normalize_year year in
154 Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
155 with _ -> None
156
157 (** Parse FMT3: "Wed Oct 21 07:28:00 2015" (asctime) *)
158 let parse_fmt3 s =
159 try
160 Scanf.sscanf s "%s %s %d %d:%d:%d %d"
161 (fun _wday mon day hour min sec year ->
162 match month_of_string mon with
163 | None -> None
164 | Some month ->
165 let year = normalize_year year in
166 Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
167 with _ -> None
168
169 (** Parse FMT4: "Wed, 21-Oct-2015 07:28:00 GMT" (variant) *)
170 let parse_fmt4 s =
171 try
172 Scanf.sscanf s "%s %d-%3s-%d %d:%d:%d %s"
173 (fun _wday day mon year hour min sec tz ->
174 (* Check timezone is GMT (case-insensitive) *)
175 if String.lowercase_ascii tz <> "gmt" then None
176 else
177 match month_of_string mon with
178 | None -> None
179 | Some month ->
180 let year = normalize_year year in
181 Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
182 with _ -> None
183
184 (** Parse HTTP date by trying all supported formats in sequence *)
185 let parse_http_date s =
186 match parse_fmt1 s with
187 | Some t -> Some t
188 | None -> (
189 match parse_fmt2 s with
190 | Some t -> Some t
191 | None -> (
192 match parse_fmt3 s with Some t -> Some t | None -> parse_fmt4 s))
193end
194
195(** {1 Cookie Parsing} *)
196
197type cookie_attributes = {
198 mutable domain : string option;
199 mutable path : string option;
200 mutable secure : bool;
201 mutable http_only : bool;
202 mutable partitioned : bool;
203 mutable expires : Expiration.t option;
204 mutable max_age : Ptime.Span.t option;
205 mutable same_site : SameSite.t option;
206}
207(** Accumulated attributes from parsing Set-Cookie header *)
208
209(** Create empty attribute accumulator *)
210let empty_attributes () =
211 {
212 domain = None;
213 path = None;
214 secure = false;
215 http_only = false;
216 partitioned = false;
217 expires = None;
218 max_age = None;
219 same_site = None;
220 }
221
222(** Parse a single attribute and update the accumulator in-place *)
223let parse_attribute now attrs attr_name attr_value =
224 let attr_lower = String.lowercase_ascii attr_name in
225 match attr_lower with
226 | "domain" -> attrs.domain <- Some (normalize_domain attr_value)
227 | "path" -> attrs.path <- Some attr_value
228 | "expires" -> (
229 (* Special case: Expires=0 means session cookie *)
230 if attr_value = "0" then attrs.expires <- Some `Session
231 else
232 match Ptime.of_rfc3339 attr_value with
233 | Ok (time, _, _) -> attrs.expires <- Some (`DateTime time)
234 | Error (`RFC3339 (_, err)) -> (
235 (* Try HTTP date format as fallback *)
236 match DateParser.parse_http_date attr_value with
237 | Some time -> attrs.expires <- Some (`DateTime time)
238 | None ->
239 Log.warn (fun m ->
240 m "Failed to parse expires attribute '%s': %a" attr_value
241 Ptime.pp_rfc3339_error err)))
242 | "max-age" -> (
243 match int_of_string_opt attr_value with
244 | Some seconds ->
245 (* Handle negative values as 0 per RFC 6265 *)
246 let seconds = max 0 seconds in
247 let current_time = now () in
248 (* Store the max-age as a Ptime.Span *)
249 attrs.max_age <- Some (Ptime.Span.of_int_s seconds);
250 (* Also compute and store expires as DateTime *)
251 let expires = Ptime.add_span current_time (Ptime.Span.of_int_s seconds) in
252 (match expires with
253 | Some time -> attrs.expires <- Some (`DateTime time)
254 | None -> ());
255 Log.debug (fun m -> m "Parsed Max-Age: %d seconds" seconds)
256 | None ->
257 Log.warn (fun m ->
258 m "Failed to parse max-age attribute '%s'" attr_value))
259 | "secure" -> attrs.secure <- true
260 | "httponly" -> attrs.http_only <- true
261 | "partitioned" -> attrs.partitioned <- true
262 | "samesite" -> (
263 match String.lowercase_ascii attr_value with
264 | "strict" -> attrs.same_site <- Some `Strict
265 | "lax" -> attrs.same_site <- Some `Lax
266 | "none" -> attrs.same_site <- Some `None
267 | _ ->
268 Log.warn (fun m ->
269 m "Invalid samesite value '%s', ignoring" attr_value))
270 | _ ->
271 Log.debug (fun m -> m "Unknown cookie attribute '%s', ignoring" attr_name)
272
273(** Validate cookie attributes and log warnings for invalid combinations *)
274let validate_attributes attrs =
275 (* SameSite=None requires Secure flag *)
276 let samesite_valid =
277 match attrs.same_site with
278 | Some `None when not attrs.secure ->
279 Log.warn (fun m ->
280 m
281 "Cookie has SameSite=None but Secure flag is not set; this \
282 violates RFC requirements");
283 false
284 | _ -> true
285 in
286 (* Partitioned requires Secure flag *)
287 let partitioned_valid =
288 if attrs.partitioned && not attrs.secure then (
289 Log.warn (fun m ->
290 m
291 "Cookie has Partitioned attribute but Secure flag is not set; \
292 this violates CHIPS requirements");
293 false)
294 else true
295 in
296 samesite_valid && partitioned_valid
297
298(** Build final cookie from name/value and accumulated attributes *)
299let build_cookie ~request_domain ~request_path ~name ~value attrs ~now =
300 let domain =
301 normalize_domain (Option.value attrs.domain ~default:request_domain)
302 in
303 let path = Option.value attrs.path ~default:request_path in
304 make ~domain ~path ~name ~value ~secure:attrs.secure
305 ~http_only:attrs.http_only ?expires:attrs.expires ?max_age:attrs.max_age
306 ?same_site:attrs.same_site ~partitioned:attrs.partitioned
307 ~creation_time:now ~last_access:now ()
308
309(** {1 Pretty Printing} *)
310
311let pp ppf cookie =
312 Format.fprintf ppf
313 "@[<hov 2>{ name=%S;@ value=%S;@ domain=%S;@ path=%S;@ secure=%b;@ \
314 http_only=%b;@ partitioned=%b;@ expires=%a;@ max_age=%a;@ same_site=%a }@]"
315 (name cookie) (value cookie) (domain cookie) (path cookie) (secure cookie)
316 (http_only cookie) (partitioned cookie)
317 (Format.pp_print_option Expiration.pp)
318 (expires cookie)
319 (Format.pp_print_option Ptime.Span.pp)
320 (max_age cookie)
321 (Format.pp_print_option SameSite.pp)
322 (same_site cookie)
323
324(** {1 Cookie Parsing} *)
325
326let of_set_cookie_header ~now ~domain:request_domain ~path:request_path
327 header_value =
328 Log.debug (fun m -> m "Parsing Set-Cookie: %s" header_value);
329
330 (* Split into attributes *)
331 let parts = String.split_on_char ';' header_value |> List.map String.trim in
332
333 match parts with
334 | [] -> None
335 | name_value :: attrs -> (
336 (* Parse name=value *)
337 match String.index_opt name_value '=' with
338 | None -> None
339 | Some eq_pos ->
340 let name = String.sub name_value 0 eq_pos |> String.trim in
341 let cookie_value =
342 String.sub name_value (eq_pos + 1)
343 (String.length name_value - eq_pos - 1)
344 |> String.trim
345 in
346
347 let current_time = now () in
348
349 (* Parse all attributes into mutable accumulator *)
350 let accumulated_attrs = empty_attributes () in
351 List.iter
352 (fun attr ->
353 match String.index_opt attr '=' with
354 | None ->
355 (* Attribute without value (e.g., Secure, HttpOnly) *)
356 parse_attribute now accumulated_attrs attr ""
357 | Some eq ->
358 let attr_name = String.sub attr 0 eq |> String.trim in
359 let attr_value =
360 String.sub attr (eq + 1) (String.length attr - eq - 1)
361 |> String.trim
362 in
363 parse_attribute now accumulated_attrs attr_name attr_value)
364 attrs;
365
366 (* Validate attributes *)
367 if not (validate_attributes accumulated_attrs) then (
368 Log.warn (fun m -> m "Cookie validation failed, rejecting cookie");
369 None)
370 else
371 let cookie =
372 build_cookie ~request_domain ~request_path ~name
373 ~value:cookie_value accumulated_attrs ~now:current_time
374 in
375 Log.debug (fun m -> m "Parsed cookie: %a" pp cookie);
376 Some cookie)
377
378let of_cookie_header ~now ~domain ~path header_value =
379 Log.debug (fun m -> m "Parsing Cookie header: %s" header_value);
380
381 (* Split on semicolons *)
382 let parts = String.split_on_char ';' header_value |> List.map String.trim in
383
384 (* Filter out empty parts *)
385 let parts = List.filter (fun s -> String.length s > 0) parts in
386
387 (* Parse each name=value pair *)
388 List.map
389 (fun name_value ->
390 match String.index_opt name_value '=' with
391 | None ->
392 Error (Printf.sprintf "Cookie missing '=' separator: %s" name_value)
393 | Some eq_pos ->
394 let cookie_name = String.sub name_value 0 eq_pos |> String.trim in
395 if String.length cookie_name = 0 then
396 Error "Cookie has empty name"
397 else
398 let cookie_value =
399 String.sub name_value (eq_pos + 1)
400 (String.length name_value - eq_pos - 1)
401 |> String.trim
402 in
403 let current_time = now () in
404 (* Create cookie with defaults from Cookie header context *)
405 let cookie =
406 make ~domain ~path ~name:cookie_name ~value:cookie_value
407 ~secure:false ~http_only:false ~partitioned:false ~creation_time:current_time
408 ~last_access:current_time ()
409 in
410 Ok cookie)
411 parts
412
413let make_cookie_header cookies =
414 cookies
415 |> List.map (fun c -> Printf.sprintf "%s=%s" (name c) (value c))
416 |> String.concat "; "
417
418let make_set_cookie_header cookie =
419 let buffer = Buffer.create 128 in
420 Buffer.add_string buffer (Printf.sprintf "%s=%s" (name cookie) (value cookie));
421
422 (* Add Max-Age if present *)
423 (match max_age cookie with
424 | Some span -> (
425 match Ptime.Span.to_int_s span with
426 | Some seconds ->
427 Buffer.add_string buffer (Printf.sprintf "; Max-Age=%d" seconds)
428 | None -> ())
429 | None -> ());
430
431 (* Add Expires if present *)
432 (match expires cookie with
433 | Some `Session ->
434 (* Session cookies can be indicated with Expires=0 or a past date *)
435 Buffer.add_string buffer "; Expires=0"
436 | Some (`DateTime exp_time) ->
437 (* Format as HTTP date *)
438 let exp_str = Ptime.to_rfc3339 ~tz_offset_s:0 exp_time in
439 Buffer.add_string buffer (Printf.sprintf "; Expires=%s" exp_str)
440 | None -> ());
441
442 (* Add Domain *)
443 Buffer.add_string buffer (Printf.sprintf "; Domain=%s" (domain cookie));
444
445 (* Add Path *)
446 Buffer.add_string buffer (Printf.sprintf "; Path=%s" (path cookie));
447
448 (* Add Secure flag *)
449 if secure cookie then Buffer.add_string buffer "; Secure";
450
451 (* Add HttpOnly flag *)
452 if http_only cookie then Buffer.add_string buffer "; HttpOnly";
453
454 (* Add Partitioned flag *)
455 if partitioned cookie then Buffer.add_string buffer "; Partitioned";
456
457 (* Add SameSite *)
458 (match same_site cookie with
459 | Some `Strict -> Buffer.add_string buffer "; SameSite=Strict"
460 | Some `Lax -> Buffer.add_string buffer "; SameSite=Lax"
461 | Some `None -> Buffer.add_string buffer "; SameSite=None"
462 | None -> ());
463
464 Buffer.contents buffer