anil.recoil.org
OCaml HTTP cookie handling library with support for Eio-based storage jars
split out the jar
-858
lib/cookeio.ml
-858
lib/cookeio.ml
···
1
-
let src = Logs.Src.create "cookeio" ~doc:"Cookie management"
2
-
3
-
module Log = (val Logs.src_log src : Logs.LOG)
4
-
5
-
module 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"
14
-
end
15
-
16
-
module 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
28
-
end
29
-
30
-
type 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
-
type jar = {
47
-
mutable original_cookies : t list; (* from client *)
48
-
mutable delta_cookies : t list; (* to send back *)
49
-
mutex : Eio.Mutex.t;
50
-
}
51
-
(** Cookie jar for storing and managing cookies *)
52
-
53
-
(** {1 Cookie Accessors} *)
54
-
55
-
let domain cookie = cookie.domain
56
-
let path cookie = cookie.path
57
-
let name cookie = cookie.name
58
-
let value cookie = cookie.value
59
-
60
-
let value_trimmed cookie =
61
-
let v = cookie.value in
62
-
let len = String.length v in
63
-
if len < 2 then v
64
-
else
65
-
match (v.[0], v.[len - 1]) with
66
-
| '"', '"' -> String.sub v 1 (len - 2)
67
-
| _ -> v
68
-
69
-
let secure cookie = cookie.secure
70
-
let http_only cookie = cookie.http_only
71
-
let partitioned cookie = cookie.partitioned
72
-
let expires cookie = cookie.expires
73
-
let max_age cookie = cookie.max_age
74
-
let same_site cookie = cookie.same_site
75
-
let creation_time cookie = cookie.creation_time
76
-
let last_access cookie = cookie.last_access
77
-
78
-
let make ~domain ~path ~name ~value ?(secure = false) ?(http_only = false)
79
-
?expires ?max_age ?same_site ?(partitioned = false) ~creation_time
80
-
~last_access () =
81
-
{
82
-
domain;
83
-
path;
84
-
name;
85
-
value;
86
-
secure;
87
-
http_only;
88
-
partitioned;
89
-
expires;
90
-
max_age;
91
-
same_site;
92
-
creation_time;
93
-
last_access;
94
-
}
95
-
96
-
(** {1 Cookie Jar Creation} *)
97
-
98
-
let create () =
99
-
Log.debug (fun m -> m "Creating new empty cookie jar");
100
-
{ original_cookies = []; delta_cookies = []; mutex = Eio.Mutex.create () }
101
-
102
-
(** {1 Cookie Matching Helpers} *)
103
-
104
-
let cookie_identity_matches c1 c2 =
105
-
name c1 = name c2 && domain c1 = domain c2 && path c1 = path c2
106
-
107
-
let normalize_domain domain =
108
-
(* Strip leading dot per RFC 6265 *)
109
-
match String.starts_with ~prefix:"." domain with
110
-
| true when String.length domain > 1 ->
111
-
String.sub domain 1 (String.length domain - 1)
112
-
| _ -> domain
113
-
114
-
let domain_matches cookie_domain request_domain =
115
-
(* Cookie domains are stored without leading dots per RFC 6265.
116
-
A cookie with domain "example.com" should match both "example.com" (exact)
117
-
and "sub.example.com" (subdomain). *)
118
-
request_domain = cookie_domain
119
-
|| String.ends_with ~suffix:("." ^ cookie_domain) request_domain
120
-
121
-
let path_matches cookie_path request_path =
122
-
(* Cookie path /foo matches /foo, /foo/, /foo/bar *)
123
-
String.starts_with ~prefix:cookie_path request_path
124
-
125
-
(** {1 HTTP Date Parsing} *)
126
-
let is_expired cookie clock =
127
-
match cookie.expires with
128
-
| None -> false (* No expiration *)
129
-
| Some `Session -> false (* Session cookie - not expired until browser closes *)
130
-
| Some (`DateTime exp_time) ->
131
-
let now =
132
-
Ptime.of_float_s (Eio.Time.now clock)
133
-
|> Option.value ~default:Ptime.epoch
134
-
in
135
-
Ptime.compare now exp_time > 0
136
-
137
-
module DateParser = struct
138
-
(** Month name to number mapping (case-insensitive) *)
139
-
let month_of_string s =
140
-
match String.lowercase_ascii s with
141
-
| "jan" -> Some 1
142
-
| "feb" -> Some 2
143
-
| "mar" -> Some 3
144
-
| "apr" -> Some 4
145
-
| "may" -> Some 5
146
-
| "jun" -> Some 6
147
-
| "jul" -> Some 7
148
-
| "aug" -> Some 8
149
-
| "sep" -> Some 9
150
-
| "oct" -> Some 10
151
-
| "nov" -> Some 11
152
-
| "dec" -> Some 12
153
-
| _ -> None
154
-
155
-
(** Normalize abbreviated years:
156
-
- Years 69-99 get 1900 added (e.g., 95 → 1995)
157
-
- Years 0-68 get 2000 added (e.g., 25 → 2025)
158
-
- Years >= 100 are returned as-is *)
159
-
let normalize_year year =
160
-
if year >= 0 && year <= 68 then year + 2000
161
-
else if year >= 69 && year <= 99 then year + 1900
162
-
else year
163
-
164
-
(** Parse FMT1: "Wed, 21 Oct 2015 07:28:00 GMT" (RFC 1123) *)
165
-
let parse_fmt1 s =
166
-
try
167
-
Scanf.sscanf s "%s %d %s %d %d:%d:%d %s"
168
-
(fun _wday day mon year hour min sec tz ->
169
-
(* Check timezone is GMT (case-insensitive) *)
170
-
if String.lowercase_ascii tz <> "gmt" then None
171
-
else
172
-
match month_of_string mon with
173
-
| None -> None
174
-
| Some month ->
175
-
let year = normalize_year year in
176
-
Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
177
-
with _ -> None
178
-
179
-
(** Parse FMT2: "Wednesday, 21-Oct-15 07:28:00 GMT" (RFC 850) *)
180
-
let parse_fmt2 s =
181
-
try
182
-
Scanf.sscanf s "%[^,], %d-%3s-%d %d:%d:%d %s"
183
-
(fun _wday day mon year hour min sec tz ->
184
-
(* Check timezone is GMT (case-insensitive) *)
185
-
if String.lowercase_ascii tz <> "gmt" then None
186
-
else
187
-
match month_of_string mon with
188
-
| None -> None
189
-
| Some month ->
190
-
let year = normalize_year year in
191
-
Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
192
-
with _ -> None
193
-
194
-
(** Parse FMT3: "Wed Oct 21 07:28:00 2015" (asctime) *)
195
-
let parse_fmt3 s =
196
-
try
197
-
Scanf.sscanf s "%s %s %d %d:%d:%d %d"
198
-
(fun _wday mon day hour min sec year ->
199
-
match month_of_string mon with
200
-
| None -> None
201
-
| Some month ->
202
-
let year = normalize_year year in
203
-
Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
204
-
with _ -> None
205
-
206
-
(** Parse FMT4: "Wed, 21-Oct-2015 07:28:00 GMT" (variant) *)
207
-
let parse_fmt4 s =
208
-
try
209
-
Scanf.sscanf s "%s %d-%3s-%d %d:%d:%d %s"
210
-
(fun _wday day mon year hour min sec tz ->
211
-
(* Check timezone is GMT (case-insensitive) *)
212
-
if String.lowercase_ascii tz <> "gmt" then None
213
-
else
214
-
match month_of_string mon with
215
-
| None -> None
216
-
| Some month ->
217
-
let year = normalize_year year in
218
-
Ptime.of_date_time ((year, month, day), ((hour, min, sec), 0)))
219
-
with _ -> None
220
-
221
-
(** Parse HTTP date by trying all supported formats in sequence *)
222
-
let parse_http_date s =
223
-
match parse_fmt1 s with
224
-
| Some t -> Some t
225
-
| None -> (
226
-
match parse_fmt2 s with
227
-
| Some t -> Some t
228
-
| None -> (
229
-
match parse_fmt3 s with Some t -> Some t | None -> parse_fmt4 s))
230
-
end
231
-
232
-
(** {1 Cookie Parsing} *)
233
-
234
-
type cookie_attributes = {
235
-
mutable domain : string option;
236
-
mutable path : string option;
237
-
mutable secure : bool;
238
-
mutable http_only : bool;
239
-
mutable partitioned : bool;
240
-
mutable expires : Expiration.t option;
241
-
mutable max_age : Ptime.Span.t option;
242
-
mutable same_site : SameSite.t option;
243
-
}
244
-
(** Accumulated attributes from parsing Set-Cookie header *)
245
-
246
-
(** Create empty attribute accumulator *)
247
-
let empty_attributes () =
248
-
{
249
-
domain = None;
250
-
path = None;
251
-
secure = false;
252
-
http_only = false;
253
-
partitioned = false;
254
-
expires = None;
255
-
max_age = None;
256
-
same_site = None;
257
-
}
258
-
259
-
(** Parse a single attribute and update the accumulator in-place *)
260
-
let parse_attribute clock attrs attr_name attr_value =
261
-
let attr_lower = String.lowercase_ascii attr_name in
262
-
match attr_lower with
263
-
| "domain" -> attrs.domain <- Some (normalize_domain attr_value)
264
-
| "path" -> attrs.path <- Some attr_value
265
-
| "expires" -> (
266
-
(* Special case: Expires=0 means session cookie *)
267
-
if attr_value = "0" then attrs.expires <- Some `Session
268
-
else
269
-
match Ptime.of_rfc3339 attr_value with
270
-
| Ok (time, _, _) -> attrs.expires <- Some (`DateTime time)
271
-
| Error (`RFC3339 (_, err)) -> (
272
-
(* Try HTTP date format as fallback *)
273
-
match DateParser.parse_http_date attr_value with
274
-
| Some time -> attrs.expires <- Some (`DateTime time)
275
-
| None ->
276
-
Log.warn (fun m ->
277
-
m "Failed to parse expires attribute '%s': %a" attr_value
278
-
Ptime.pp_rfc3339_error err)))
279
-
| "max-age" -> (
280
-
match int_of_string_opt attr_value with
281
-
| Some seconds ->
282
-
(* Handle negative values as 0 per RFC 6265 *)
283
-
let seconds = max 0 seconds in
284
-
let now = Eio.Time.now clock in
285
-
(* Store the max-age as a Ptime.Span *)
286
-
attrs.max_age <- Some (Ptime.Span.of_int_s seconds);
287
-
(* Also compute and store expires as DateTime *)
288
-
let expires = Ptime.of_float_s (now +. float_of_int seconds) in
289
-
(match expires with
290
-
| Some time -> attrs.expires <- Some (`DateTime time)
291
-
| None -> ());
292
-
Log.debug (fun m -> m "Parsed Max-Age: %d seconds" seconds)
293
-
| None ->
294
-
Log.warn (fun m ->
295
-
m "Failed to parse max-age attribute '%s'" attr_value))
296
-
| "secure" -> attrs.secure <- true
297
-
| "httponly" -> attrs.http_only <- true
298
-
| "partitioned" -> attrs.partitioned <- true
299
-
| "samesite" -> (
300
-
match String.lowercase_ascii attr_value with
301
-
| "strict" -> attrs.same_site <- Some `Strict
302
-
| "lax" -> attrs.same_site <- Some `Lax
303
-
| "none" -> attrs.same_site <- Some `None
304
-
| _ ->
305
-
Log.warn (fun m ->
306
-
m "Invalid samesite value '%s', ignoring" attr_value))
307
-
| _ ->
308
-
Log.debug (fun m -> m "Unknown cookie attribute '%s', ignoring" attr_name)
309
-
310
-
(** Validate cookie attributes and log warnings for invalid combinations *)
311
-
let validate_attributes attrs =
312
-
(* SameSite=None requires Secure flag *)
313
-
let samesite_valid =
314
-
match attrs.same_site with
315
-
| Some `None when not attrs.secure ->
316
-
Log.warn (fun m ->
317
-
m
318
-
"Cookie has SameSite=None but Secure flag is not set; this \
319
-
violates RFC requirements");
320
-
false
321
-
| _ -> true
322
-
in
323
-
(* Partitioned requires Secure flag *)
324
-
let partitioned_valid =
325
-
if attrs.partitioned && not attrs.secure then (
326
-
Log.warn (fun m ->
327
-
m
328
-
"Cookie has Partitioned attribute but Secure flag is not set; \
329
-
this violates CHIPS requirements");
330
-
false)
331
-
else true
332
-
in
333
-
samesite_valid && partitioned_valid
334
-
335
-
(** Build final cookie from name/value and accumulated attributes *)
336
-
let build_cookie ~request_domain ~request_path ~name ~value attrs ~now =
337
-
let domain =
338
-
normalize_domain (Option.value attrs.domain ~default:request_domain)
339
-
in
340
-
let path = Option.value attrs.path ~default:request_path in
341
-
make ~domain ~path ~name ~value ~secure:attrs.secure
342
-
~http_only:attrs.http_only ?expires:attrs.expires ?max_age:attrs.max_age
343
-
?same_site:attrs.same_site ~partitioned:attrs.partitioned
344
-
~creation_time:now ~last_access:now ()
345
-
346
-
let rec parse_set_cookie ~clock ~domain:request_domain ~path:request_path
347
-
header_value =
348
-
Log.debug (fun m -> m "Parsing Set-Cookie: %s" header_value);
349
-
350
-
(* Split into attributes *)
351
-
let parts = String.split_on_char ';' header_value |> List.map String.trim in
352
-
353
-
match parts with
354
-
| [] -> None
355
-
| name_value :: attrs -> (
356
-
(* Parse name=value *)
357
-
match String.index_opt name_value '=' with
358
-
| None -> None
359
-
| Some eq_pos ->
360
-
let name = String.sub name_value 0 eq_pos |> String.trim in
361
-
let cookie_value =
362
-
String.sub name_value (eq_pos + 1)
363
-
(String.length name_value - eq_pos - 1)
364
-
|> String.trim
365
-
in
366
-
367
-
let now =
368
-
Ptime.of_float_s (Eio.Time.now clock)
369
-
|> Option.value ~default:Ptime.epoch
370
-
in
371
-
372
-
(* Parse all attributes into mutable accumulator *)
373
-
let accumulated_attrs = empty_attributes () in
374
-
List.iter
375
-
(fun attr ->
376
-
match String.index_opt attr '=' with
377
-
| None ->
378
-
(* Attribute without value (e.g., Secure, HttpOnly) *)
379
-
parse_attribute clock accumulated_attrs attr ""
380
-
| Some eq ->
381
-
let attr_name = String.sub attr 0 eq |> String.trim in
382
-
let attr_value =
383
-
String.sub attr (eq + 1) (String.length attr - eq - 1)
384
-
|> String.trim
385
-
in
386
-
parse_attribute clock accumulated_attrs attr_name attr_value)
387
-
attrs;
388
-
389
-
(* Validate attributes *)
390
-
if not (validate_attributes accumulated_attrs) then (
391
-
Log.warn (fun m -> m "Cookie validation failed, rejecting cookie");
392
-
None)
393
-
else
394
-
let cookie =
395
-
build_cookie ~request_domain ~request_path ~name
396
-
~value:cookie_value accumulated_attrs ~now
397
-
in
398
-
Log.debug (fun m -> m "Parsed cookie: %a" pp cookie);
399
-
Some cookie)
400
-
401
-
and of_cookie_header ~clock ~domain ~path header_value =
402
-
Log.debug (fun m -> m "Parsing Cookie header: %s" header_value);
403
-
404
-
(* Split on semicolons *)
405
-
let parts = String.split_on_char ';' header_value |> List.map String.trim in
406
-
407
-
(* Filter out empty parts *)
408
-
let parts = List.filter (fun s -> String.length s > 0) parts in
409
-
410
-
(* Parse each name=value pair *)
411
-
List.map
412
-
(fun name_value ->
413
-
match String.index_opt name_value '=' with
414
-
| None ->
415
-
Error (Printf.sprintf "Cookie missing '=' separator: %s" name_value)
416
-
| Some eq_pos ->
417
-
let cookie_name = String.sub name_value 0 eq_pos |> String.trim in
418
-
if String.length cookie_name = 0 then
419
-
Error "Cookie has empty name"
420
-
else
421
-
let cookie_value =
422
-
String.sub name_value (eq_pos + 1)
423
-
(String.length name_value - eq_pos - 1)
424
-
|> String.trim
425
-
in
426
-
let now =
427
-
Ptime.of_float_s (Eio.Time.now clock)
428
-
|> Option.value ~default:Ptime.epoch
429
-
in
430
-
(* Create cookie with defaults from Cookie header context *)
431
-
let cookie =
432
-
make ~domain ~path ~name:cookie_name ~value:cookie_value
433
-
~secure:false ~http_only:false ~partitioned:false ~creation_time:now
434
-
~last_access:now ()
435
-
in
436
-
Ok cookie)
437
-
parts
438
-
439
-
and make_cookie_header cookies =
440
-
cookies
441
-
|> List.map (fun c -> Printf.sprintf "%s=%s" (name c) (value c))
442
-
|> String.concat "; "
443
-
444
-
and make_set_cookie_header cookie =
445
-
let buffer = Buffer.create 128 in
446
-
Buffer.add_string buffer (Printf.sprintf "%s=%s" (name cookie) (value cookie));
447
-
448
-
(* Add Max-Age if present *)
449
-
(match max_age cookie with
450
-
| Some span -> (
451
-
match Ptime.Span.to_int_s span with
452
-
| Some seconds ->
453
-
Buffer.add_string buffer (Printf.sprintf "; Max-Age=%d" seconds)
454
-
| None -> ())
455
-
| None -> ());
456
-
457
-
(* Add Expires if present *)
458
-
(match expires cookie with
459
-
| Some `Session ->
460
-
(* Session cookies can be indicated with Expires=0 or a past date *)
461
-
Buffer.add_string buffer "; Expires=0"
462
-
| Some (`DateTime exp_time) ->
463
-
(* Format as HTTP date *)
464
-
let exp_str = Ptime.to_rfc3339 ~tz_offset_s:0 exp_time in
465
-
Buffer.add_string buffer (Printf.sprintf "; Expires=%s" exp_str)
466
-
| None -> ());
467
-
468
-
(* Add Domain *)
469
-
Buffer.add_string buffer (Printf.sprintf "; Domain=%s" (domain cookie));
470
-
471
-
(* Add Path *)
472
-
Buffer.add_string buffer (Printf.sprintf "; Path=%s" (path cookie));
473
-
474
-
(* Add Secure flag *)
475
-
if secure cookie then Buffer.add_string buffer "; Secure";
476
-
477
-
(* Add HttpOnly flag *)
478
-
if http_only cookie then Buffer.add_string buffer "; HttpOnly";
479
-
480
-
(* Add Partitioned flag *)
481
-
if partitioned cookie then Buffer.add_string buffer "; Partitioned";
482
-
483
-
(* Add SameSite *)
484
-
(match same_site cookie with
485
-
| Some `Strict -> Buffer.add_string buffer "; SameSite=Strict"
486
-
| Some `Lax -> Buffer.add_string buffer "; SameSite=Lax"
487
-
| Some `None -> Buffer.add_string buffer "; SameSite=None"
488
-
| None -> ());
489
-
490
-
Buffer.contents buffer
491
-
492
-
(** {1 Pretty Printing} *)
493
-
494
-
and pp ppf cookie =
495
-
Format.fprintf ppf
496
-
"@[<hov 2>{ name=%S;@ value=%S;@ domain=%S;@ path=%S;@ secure=%b;@ \
497
-
http_only=%b;@ partitioned=%b;@ expires=%a;@ max_age=%a;@ same_site=%a }@]"
498
-
(name cookie) (value cookie) (domain cookie) (path cookie) (secure cookie)
499
-
(http_only cookie) (partitioned cookie)
500
-
(Format.pp_print_option Expiration.pp)
501
-
(expires cookie)
502
-
(Format.pp_print_option Ptime.Span.pp)
503
-
(max_age cookie)
504
-
(Format.pp_print_option SameSite.pp)
505
-
(same_site cookie)
506
-
507
-
let pp_jar ppf jar =
508
-
Eio.Mutex.lock jar.mutex;
509
-
let original = jar.original_cookies in
510
-
let delta = jar.delta_cookies in
511
-
Eio.Mutex.unlock jar.mutex;
512
-
513
-
let all_cookies = original @ delta in
514
-
Format.fprintf ppf "@[<v>CookieJar with %d cookies (%d original, %d delta):@,"
515
-
(List.length all_cookies) (List.length original) (List.length delta);
516
-
List.iter (fun cookie -> Format.fprintf ppf " %a@," pp cookie) all_cookies;
517
-
Format.fprintf ppf "@]"
518
-
519
-
(** {1 Cookie Management} *)
520
-
521
-
let add_cookie jar cookie =
522
-
Log.debug (fun m ->
523
-
m "Adding cookie to delta: %s=%s for domain %s" (name cookie)
524
-
(value cookie) (domain cookie));
525
-
526
-
Eio.Mutex.lock jar.mutex;
527
-
(* Remove existing cookie with same identity from delta *)
528
-
jar.delta_cookies <-
529
-
List.filter
530
-
(fun c -> not (cookie_identity_matches c cookie))
531
-
jar.delta_cookies;
532
-
jar.delta_cookies <- cookie :: jar.delta_cookies;
533
-
Eio.Mutex.unlock jar.mutex
534
-
535
-
let add_original jar cookie =
536
-
Log.debug (fun m ->
537
-
m "Adding original cookie: %s=%s for domain %s" (name cookie)
538
-
(value cookie) (domain cookie));
539
-
540
-
Eio.Mutex.lock jar.mutex;
541
-
(* Remove existing cookie with same identity from original *)
542
-
jar.original_cookies <-
543
-
List.filter
544
-
(fun c -> not (cookie_identity_matches c cookie))
545
-
jar.original_cookies;
546
-
jar.original_cookies <- cookie :: jar.original_cookies;
547
-
Eio.Mutex.unlock jar.mutex
548
-
549
-
let delta jar =
550
-
Eio.Mutex.lock jar.mutex;
551
-
let result = jar.delta_cookies in
552
-
Eio.Mutex.unlock jar.mutex;
553
-
Log.debug (fun m -> m "Returning %d delta cookies" (List.length result));
554
-
result
555
-
556
-
let make_removal_cookie cookie ~clock =
557
-
let now =
558
-
Ptime.of_float_s (Eio.Time.now clock) |> Option.value ~default:Ptime.epoch
559
-
in
560
-
(* Create a cookie with Max-Age=0 and past expiration (1 year ago) *)
561
-
let past_expiry =
562
-
Ptime.sub_span now (Ptime.Span.of_int_s (365 * 24 * 60 * 60))
563
-
|> Option.value ~default:Ptime.epoch
564
-
in
565
-
make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie) ~value:""
566
-
~secure:(secure cookie) ~http_only:(http_only cookie)
567
-
~expires:(`DateTime past_expiry) ~max_age:(Ptime.Span.of_int_s 0)
568
-
?same_site:(same_site cookie) ~partitioned:(partitioned cookie)
569
-
~creation_time:now ~last_access:now ()
570
-
571
-
let remove jar ~clock cookie =
572
-
Log.debug (fun m ->
573
-
m "Removing cookie: %s=%s for domain %s" (name cookie) (value cookie)
574
-
(domain cookie));
575
-
576
-
Eio.Mutex.lock jar.mutex;
577
-
(* Check if this cookie exists in original_cookies *)
578
-
let in_original =
579
-
List.exists (fun c -> cookie_identity_matches c cookie) jar.original_cookies
580
-
in
581
-
582
-
if in_original then (
583
-
(* Create a removal cookie and add it to delta *)
584
-
let removal = make_removal_cookie cookie ~clock in
585
-
jar.delta_cookies <-
586
-
List.filter
587
-
(fun c -> not (cookie_identity_matches c removal))
588
-
jar.delta_cookies;
589
-
jar.delta_cookies <- removal :: jar.delta_cookies;
590
-
Log.debug (fun m -> m "Created removal cookie in delta for original cookie"))
591
-
else (
592
-
(* Just remove from delta if it exists there *)
593
-
jar.delta_cookies <-
594
-
List.filter
595
-
(fun c -> not (cookie_identity_matches c cookie))
596
-
jar.delta_cookies;
597
-
Log.debug (fun m -> m "Removed cookie from delta"));
598
-
599
-
Eio.Mutex.unlock jar.mutex
600
-
601
-
let get_cookies jar ~clock ~domain:request_domain ~path:request_path ~is_secure
602
-
=
603
-
Log.debug (fun m ->
604
-
m "Getting cookies for domain=%s path=%s secure=%b" request_domain
605
-
request_path is_secure);
606
-
607
-
Eio.Mutex.lock jar.mutex;
608
-
609
-
(* Combine original and delta cookies, with delta taking precedence *)
610
-
let all_cookies = jar.original_cookies @ jar.delta_cookies in
611
-
612
-
(* Filter out duplicates, keeping the last occurrence (from delta) *)
613
-
let rec dedup acc = function
614
-
| [] -> List.rev acc
615
-
| c :: rest ->
616
-
(* Keep this cookie only if no later cookie has the same identity *)
617
-
let has_duplicate =
618
-
List.exists (fun c2 -> cookie_identity_matches c c2) rest
619
-
in
620
-
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
621
-
in
622
-
let unique_cookies = dedup [] all_cookies in
623
-
624
-
(* Filter for applicable cookies, excluding removal cookies (empty value) *)
625
-
let applicable =
626
-
List.filter
627
-
(fun cookie ->
628
-
value cookie <> ""
629
-
(* Exclude removal cookies *)
630
-
&& domain_matches (domain cookie) request_domain
631
-
&& path_matches (path cookie) request_path
632
-
&& ((not (secure cookie)) || is_secure))
633
-
unique_cookies
634
-
in
635
-
636
-
(* Update last access time in both lists *)
637
-
let now =
638
-
Ptime.of_float_s (Eio.Time.now clock) |> Option.value ~default:Ptime.epoch
639
-
in
640
-
let update_last_access cookies =
641
-
List.map
642
-
(fun c ->
643
-
if List.exists (fun a -> cookie_identity_matches a c) applicable then
644
-
make ~domain:(domain c) ~path:(path c) ~name:(name c) ~value:(value c)
645
-
~secure:(secure c) ~http_only:(http_only c) ?expires:(expires c)
646
-
?max_age:(max_age c) ?same_site:(same_site c)
647
-
~creation_time:(creation_time c) ~last_access:now ()
648
-
else c)
649
-
cookies
650
-
in
651
-
jar.original_cookies <- update_last_access jar.original_cookies;
652
-
jar.delta_cookies <- update_last_access jar.delta_cookies;
653
-
654
-
Eio.Mutex.unlock jar.mutex;
655
-
656
-
Log.debug (fun m -> m "Found %d applicable cookies" (List.length applicable));
657
-
applicable
658
-
659
-
let clear jar =
660
-
Log.info (fun m -> m "Clearing all cookies");
661
-
Eio.Mutex.lock jar.mutex;
662
-
jar.original_cookies <- [];
663
-
jar.delta_cookies <- [];
664
-
Eio.Mutex.unlock jar.mutex
665
-
666
-
let clear_expired jar ~clock =
667
-
Eio.Mutex.lock jar.mutex;
668
-
let before_count =
669
-
List.length jar.original_cookies + List.length jar.delta_cookies
670
-
in
671
-
jar.original_cookies <-
672
-
List.filter (fun c -> not (is_expired c clock)) jar.original_cookies;
673
-
jar.delta_cookies <-
674
-
List.filter (fun c -> not (is_expired c clock)) jar.delta_cookies;
675
-
let removed =
676
-
before_count
677
-
- (List.length jar.original_cookies + List.length jar.delta_cookies)
678
-
in
679
-
Eio.Mutex.unlock jar.mutex;
680
-
Log.info (fun m -> m "Cleared %d expired cookies" removed)
681
-
682
-
let clear_session_cookies jar =
683
-
Eio.Mutex.lock jar.mutex;
684
-
let before_count =
685
-
List.length jar.original_cookies + List.length jar.delta_cookies
686
-
in
687
-
(* Keep only cookies that are NOT session cookies *)
688
-
let is_not_session c =
689
-
match expires c with
690
-
| Some `Session -> false (* This is a session cookie, remove it *)
691
-
| None | Some (`DateTime _) -> true (* Keep these *)
692
-
in
693
-
jar.original_cookies <- List.filter is_not_session jar.original_cookies;
694
-
jar.delta_cookies <- List.filter is_not_session jar.delta_cookies;
695
-
let removed =
696
-
before_count
697
-
- (List.length jar.original_cookies + List.length jar.delta_cookies)
698
-
in
699
-
Eio.Mutex.unlock jar.mutex;
700
-
Log.info (fun m -> m "Cleared %d session cookies" removed)
701
-
702
-
let count jar =
703
-
Eio.Mutex.lock jar.mutex;
704
-
(* Combine and deduplicate cookies for count *)
705
-
let all_cookies = jar.original_cookies @ jar.delta_cookies in
706
-
let rec dedup acc = function
707
-
| [] -> List.rev acc
708
-
| c :: rest ->
709
-
let has_duplicate =
710
-
List.exists (fun c2 -> cookie_identity_matches c c2) rest
711
-
in
712
-
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
713
-
in
714
-
let unique = dedup [] all_cookies in
715
-
let n = List.length unique in
716
-
Eio.Mutex.unlock jar.mutex;
717
-
n
718
-
719
-
let get_all_cookies jar =
720
-
Eio.Mutex.lock jar.mutex;
721
-
(* Combine and deduplicate, with delta taking precedence *)
722
-
let all_cookies = jar.original_cookies @ jar.delta_cookies in
723
-
let rec dedup acc = function
724
-
| [] -> List.rev acc
725
-
| c :: rest ->
726
-
let has_duplicate =
727
-
List.exists (fun c2 -> cookie_identity_matches c c2) rest
728
-
in
729
-
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
730
-
in
731
-
let unique = dedup [] all_cookies in
732
-
Eio.Mutex.unlock jar.mutex;
733
-
unique
734
-
735
-
let is_empty jar =
736
-
Eio.Mutex.lock jar.mutex;
737
-
let empty = jar.original_cookies = [] && jar.delta_cookies = [] in
738
-
Eio.Mutex.unlock jar.mutex;
739
-
empty
740
-
741
-
(** {1 Mozilla Format} *)
742
-
743
-
let to_mozilla_format_internal jar =
744
-
let buffer = Buffer.create 1024 in
745
-
Buffer.add_string buffer "# Netscape HTTP Cookie File\n";
746
-
Buffer.add_string buffer "# This is a generated file! Do not edit.\n\n";
747
-
748
-
(* Combine and deduplicate cookies *)
749
-
let all_cookies = jar.original_cookies @ jar.delta_cookies in
750
-
let rec dedup acc = function
751
-
| [] -> List.rev acc
752
-
| c :: rest ->
753
-
let has_duplicate =
754
-
List.exists (fun c2 -> cookie_identity_matches c c2) rest
755
-
in
756
-
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
757
-
in
758
-
let unique = dedup [] all_cookies in
759
-
760
-
List.iter
761
-
(fun cookie ->
762
-
let include_subdomains =
763
-
if String.starts_with ~prefix:"." (domain cookie) then "TRUE"
764
-
else "FALSE"
765
-
in
766
-
let secure_flag = if secure cookie then "TRUE" else "FALSE" in
767
-
let expires_str =
768
-
match expires cookie with
769
-
| None -> "0" (* No expiration *)
770
-
| Some `Session -> "0" (* Session cookie *)
771
-
| Some (`DateTime t) ->
772
-
let epoch = Ptime.to_float_s t |> int_of_float |> string_of_int in
773
-
epoch
774
-
in
775
-
776
-
Buffer.add_string buffer
777
-
(Printf.sprintf "%s\t%s\t%s\t%s\t%s\t%s\t%s\n" (domain cookie)
778
-
include_subdomains (path cookie) secure_flag expires_str
779
-
(name cookie) (value cookie)))
780
-
unique;
781
-
782
-
Buffer.contents buffer
783
-
784
-
let to_mozilla_format jar =
785
-
Eio.Mutex.lock jar.mutex;
786
-
let result = to_mozilla_format_internal jar in
787
-
Eio.Mutex.unlock jar.mutex;
788
-
result
789
-
790
-
let from_mozilla_format ~clock content =
791
-
Log.debug (fun m -> m "Parsing Mozilla format cookies");
792
-
let jar = create () in
793
-
794
-
let lines = String.split_on_char '\n' content in
795
-
List.iter
796
-
(fun line ->
797
-
let line = String.trim line in
798
-
if line <> "" && not (String.starts_with ~prefix:"#" line) then
799
-
match String.split_on_char '\t' line with
800
-
| [ domain; _include_subdomains; path; secure; expires; name; value ] ->
801
-
let now =
802
-
Ptime.of_float_s (Eio.Time.now clock)
803
-
|> Option.value ~default:Ptime.epoch
804
-
in
805
-
let expires =
806
-
let exp_int = try int_of_string expires with _ -> 0 in
807
-
if exp_int = 0 then None
808
-
else
809
-
match Ptime.of_float_s (float_of_int exp_int) with
810
-
| Some t -> Some (`DateTime t)
811
-
| None -> None
812
-
in
813
-
814
-
let cookie =
815
-
make ~domain:(normalize_domain domain) ~path ~name ~value
816
-
~secure:(secure = "TRUE") ~http_only:false ?expires ?max_age:None
817
-
?same_site:None ~partitioned:false ~creation_time:now
818
-
~last_access:now ()
819
-
in
820
-
add_original jar cookie;
821
-
Log.debug (fun m -> m "Loaded cookie: %s=%s" name value)
822
-
| _ -> Log.warn (fun m -> m "Invalid cookie line: %s" line))
823
-
lines;
824
-
825
-
Log.info (fun m -> m "Loaded %d cookies" (List.length jar.original_cookies));
826
-
jar
827
-
828
-
(** {1 File Operations} *)
829
-
830
-
let load ~clock path =
831
-
Log.info (fun m -> m "Loading cookies from %a" Eio.Path.pp path);
832
-
833
-
try
834
-
let content = Eio.Path.load path in
835
-
from_mozilla_format ~clock content
836
-
with
837
-
| Eio.Io _ ->
838
-
Log.info (fun m -> m "Cookie file not found, creating empty jar");
839
-
create ()
840
-
| exn ->
841
-
Log.err (fun m -> m "Failed to load cookies: %s" (Printexc.to_string exn));
842
-
create ()
843
-
844
-
let save path jar =
845
-
Eio.Mutex.lock jar.mutex;
846
-
let total_cookies =
847
-
List.length jar.original_cookies + List.length jar.delta_cookies
848
-
in
849
-
Eio.Mutex.unlock jar.mutex;
850
-
Log.info (fun m -> m "Saving %d cookies to %a" total_cookies Eio.Path.pp path);
851
-
852
-
let content = to_mozilla_format jar in
853
-
854
-
try
855
-
Eio.Path.save ~create:(`Or_truncate 0o600) path content;
856
-
Log.debug (fun m -> m "Cookies saved successfully")
857
-
with exn ->
858
-
Log.err (fun m -> m "Failed to save cookies: %s" (Printexc.to_string exn))
+9
-108
lib/cookeio.mli
lib/core/cookeio.mli
+9
-108
lib/cookeio.mli
lib/core/cookeio.mli
···
67
67
its scope, security, and lifetime. Cookies with the same [name], [domain],
68
68
and [path] will overwrite each other when added to a cookie jar. *)
69
69
70
-
type jar
71
-
(** Cookie jar for storing and managing cookies.
72
-
73
-
A cookie jar maintains a collection of cookies with automatic cleanup of
74
-
expired entries and enforcement of storage limits. It implements the
75
-
standard browser behavior for cookie storage, including:
76
-
- Automatic removal of expired cookies
77
-
- LRU eviction when storage limits are exceeded
78
-
- Domain and path-based cookie retrieval
79
-
- Mozilla format persistence for cross-tool compatibility *)
80
-
81
70
(** {1 Cookie Accessors} *)
82
71
83
72
val domain : t -> string
···
166
155
Note: If [partitioned] is [true], the cookie must also be [secure]. Invalid
167
156
combinations will result in validation errors. *)
168
157
169
-
(** {1 Cookie Jar Creation and Loading} *)
170
-
171
-
val create : unit -> jar
172
-
(** Create an empty cookie jar *)
173
-
174
-
val load : clock:_ Eio.Time.clock -> Eio.Fs.dir_ty Eio.Path.t -> jar
175
-
(** Load cookies from Mozilla format file.
176
-
177
-
Loads cookies from a file in Mozilla format, using the provided clock to set
178
-
creation and last access times. Returns an empty jar if the file doesn't
179
-
exist or cannot be loaded. *)
180
-
181
-
val save : Eio.Fs.dir_ty Eio.Path.t -> jar -> unit
182
-
(** Save cookies to Mozilla format file *)
183
-
184
-
(** {1 Cookie Jar Management} *)
185
-
186
-
val add_cookie : jar -> t -> unit
187
-
(** Add a cookie to the jar.
188
-
189
-
The cookie is added to the delta, meaning it will appear in Set-Cookie
190
-
headers when calling {!delta}. If a cookie with the same name/domain/path
191
-
exists in the delta, it will be replaced. *)
192
-
193
-
val add_original : jar -> t -> unit
194
-
(** Add an original cookie to the jar.
195
-
196
-
Original cookies are those received from the client (via Cookie header).
197
-
They do not appear in the delta. This method should be used when loading
198
-
cookies from incoming HTTP requests. *)
199
-
200
-
val delta : jar -> t list
201
-
(** Get cookies that need to be sent in Set-Cookie headers.
202
-
203
-
Returns cookies that have been added via {!add_cookie} and removal cookies
204
-
for original cookies that have been removed. Does not include original
205
-
cookies that were added via {!add_original}. *)
206
-
207
-
val remove : jar -> clock:_ Eio.Time.clock -> t -> unit
208
-
(** Remove a cookie from the jar.
209
-
210
-
If an original cookie with the same name/domain/path exists, creates a
211
-
removal cookie (empty value, Max-Age=0, past expiration) that appears in the
212
-
delta. If only a delta cookie exists, simply removes it from the delta. *)
213
-
214
-
val get_cookies :
215
-
jar ->
216
-
clock:_ Eio.Time.clock ->
217
-
domain:string ->
218
-
path:string ->
219
-
is_secure:bool ->
220
-
t list
221
-
(** Get cookies applicable for a URL.
222
-
223
-
Returns all cookies that match the given domain and path, and satisfy the
224
-
secure flag requirement. Combines original and delta cookies, with delta
225
-
taking precedence. Excludes removal cookies (empty value). Also updates the
226
-
last access time of matching cookies using the provided clock. *)
227
-
228
-
val clear : jar -> unit
229
-
(** Clear all cookies *)
230
-
231
-
val clear_expired : jar -> clock:_ Eio.Time.clock -> unit
232
-
(** Clear expired cookies *)
233
-
234
-
val clear_session_cookies : jar -> unit
235
-
(** Clear session cookies (those without expiry) *)
236
-
237
-
val count : jar -> int
238
-
(** Get the number of cookies in the jar *)
239
-
240
-
val get_all_cookies : jar -> t list
241
-
(** Get all cookies in the jar *)
242
-
243
-
val is_empty : jar -> bool
244
-
(** Check if the jar is empty *)
245
-
246
158
(** {1 Cookie Creation and Parsing} *)
247
159
248
-
val parse_set_cookie :
160
+
val of_set_cookie_header :
249
161
clock:_ Eio.Time.clock -> domain:string -> path:string -> string -> t option
250
-
(** Parse Set-Cookie header value into a cookie.
162
+
(** Parse Set-Cookie response header value into a cookie.
163
+
164
+
Set-Cookie headers are sent from server to client and contain the cookie
165
+
name, value, and all attributes.
251
166
252
167
Parses a Set-Cookie header value following RFC specifications:
253
168
- Basic format: [NAME=VALUE; attribute1; attribute2=value2]
···
264
179
- [Partitioned] requires the [Secure] flag to be set
265
180
266
181
Example:
267
-
[parse_set_cookie ~clock ~domain:"example.com" ~path:"/" "session=abc123;
182
+
[of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" "session=abc123;
268
183
Secure; HttpOnly"] *)
269
184
270
185
val of_cookie_header :
···
273
188
path:string ->
274
189
string ->
275
190
(t, string) result list
276
-
(** Parse Cookie header containing semicolon-separated name=value pairs.
191
+
(** Parse Cookie request header containing semicolon-separated name=value pairs.
277
192
278
-
Cookie headers (client→server) contain only name=value pairs without
279
-
attributes: ["name1=value1; name2=value2; name3=value3"]
193
+
Cookie headers are sent from client to server and contain only name=value
194
+
pairs without attributes: ["name1=value1; name2=value2; name3=value3"]
280
195
281
196
Creates cookies with:
282
197
- Provided [domain] and [path] from request context
···
316
231
317
232
val pp : Format.formatter -> t -> unit
318
233
(** Pretty print a cookie *)
319
-
320
-
val pp_jar : Format.formatter -> jar -> unit
321
-
(** Pretty print a cookie jar *)
322
-
323
-
(** {1 Mozilla Format} *)
324
-
325
-
val to_mozilla_format : jar -> string
326
-
(** Write cookies in Mozilla format *)
327
-
328
-
val from_mozilla_format : clock:_ Eio.Time.clock -> string -> jar
329
-
(** Parse Mozilla format cookies.
330
-
331
-
Creates a cookie jar from a string in Mozilla cookie format, using the
332
-
provided clock to set creation and last access times. *)
+470
lib/core/cookeio.ml
+470
lib/core/cookeio.ml
···
1
+
let src = Logs.Src.create "cookeio" ~doc:"Cookie management"
2
+
3
+
module Log = (val Logs.src_log src : Logs.LOG)
4
+
5
+
module 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"
14
+
end
15
+
16
+
module 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
28
+
end
29
+
30
+
type 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
+
48
+
let domain cookie = cookie.domain
49
+
let path cookie = cookie.path
50
+
let name cookie = cookie.name
51
+
let value cookie = cookie.value
52
+
53
+
let 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
+
62
+
let secure cookie = cookie.secure
63
+
let http_only cookie = cookie.http_only
64
+
let partitioned cookie = cookie.partitioned
65
+
let expires cookie = cookie.expires
66
+
let max_age cookie = cookie.max_age
67
+
let same_site cookie = cookie.same_site
68
+
let creation_time cookie = cookie.creation_time
69
+
let last_access cookie = cookie.last_access
70
+
71
+
let 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
+
91
+
let 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
+
100
+
module 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))
193
+
end
194
+
195
+
(** {1 Cookie Parsing} *)
196
+
197
+
type 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 *)
210
+
let 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 *)
223
+
let parse_attribute clock 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 now = Eio.Time.now clock 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.of_float_s (now +. float_of_int 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 *)
274
+
let 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 *)
299
+
let 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
+
311
+
let 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
+
326
+
let of_set_cookie_header ~clock ~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 now =
348
+
Ptime.of_float_s (Eio.Time.now clock)
349
+
|> Option.value ~default:Ptime.epoch
350
+
in
351
+
352
+
(* Parse all attributes into mutable accumulator *)
353
+
let accumulated_attrs = empty_attributes () in
354
+
List.iter
355
+
(fun attr ->
356
+
match String.index_opt attr '=' with
357
+
| None ->
358
+
(* Attribute without value (e.g., Secure, HttpOnly) *)
359
+
parse_attribute clock accumulated_attrs attr ""
360
+
| Some eq ->
361
+
let attr_name = String.sub attr 0 eq |> String.trim in
362
+
let attr_value =
363
+
String.sub attr (eq + 1) (String.length attr - eq - 1)
364
+
|> String.trim
365
+
in
366
+
parse_attribute clock accumulated_attrs attr_name attr_value)
367
+
attrs;
368
+
369
+
(* Validate attributes *)
370
+
if not (validate_attributes accumulated_attrs) then (
371
+
Log.warn (fun m -> m "Cookie validation failed, rejecting cookie");
372
+
None)
373
+
else
374
+
let cookie =
375
+
build_cookie ~request_domain ~request_path ~name
376
+
~value:cookie_value accumulated_attrs ~now
377
+
in
378
+
Log.debug (fun m -> m "Parsed cookie: %a" pp cookie);
379
+
Some cookie)
380
+
381
+
let of_cookie_header ~clock ~domain ~path header_value =
382
+
Log.debug (fun m -> m "Parsing Cookie header: %s" header_value);
383
+
384
+
(* Split on semicolons *)
385
+
let parts = String.split_on_char ';' header_value |> List.map String.trim in
386
+
387
+
(* Filter out empty parts *)
388
+
let parts = List.filter (fun s -> String.length s > 0) parts in
389
+
390
+
(* Parse each name=value pair *)
391
+
List.map
392
+
(fun name_value ->
393
+
match String.index_opt name_value '=' with
394
+
| None ->
395
+
Error (Printf.sprintf "Cookie missing '=' separator: %s" name_value)
396
+
| Some eq_pos ->
397
+
let cookie_name = String.sub name_value 0 eq_pos |> String.trim in
398
+
if String.length cookie_name = 0 then
399
+
Error "Cookie has empty name"
400
+
else
401
+
let cookie_value =
402
+
String.sub name_value (eq_pos + 1)
403
+
(String.length name_value - eq_pos - 1)
404
+
|> String.trim
405
+
in
406
+
let now =
407
+
Ptime.of_float_s (Eio.Time.now clock)
408
+
|> Option.value ~default:Ptime.epoch
409
+
in
410
+
(* Create cookie with defaults from Cookie header context *)
411
+
let cookie =
412
+
make ~domain ~path ~name:cookie_name ~value:cookie_value
413
+
~secure:false ~http_only:false ~partitioned:false ~creation_time:now
414
+
~last_access:now ()
415
+
in
416
+
Ok cookie)
417
+
parts
418
+
419
+
let make_cookie_header cookies =
420
+
cookies
421
+
|> List.map (fun c -> Printf.sprintf "%s=%s" (name c) (value c))
422
+
|> String.concat "; "
423
+
424
+
let make_set_cookie_header cookie =
425
+
let buffer = Buffer.create 128 in
426
+
Buffer.add_string buffer (Printf.sprintf "%s=%s" (name cookie) (value cookie));
427
+
428
+
(* Add Max-Age if present *)
429
+
(match max_age cookie with
430
+
| Some span -> (
431
+
match Ptime.Span.to_int_s span with
432
+
| Some seconds ->
433
+
Buffer.add_string buffer (Printf.sprintf "; Max-Age=%d" seconds)
434
+
| None -> ())
435
+
| None -> ());
436
+
437
+
(* Add Expires if present *)
438
+
(match expires cookie with
439
+
| Some `Session ->
440
+
(* Session cookies can be indicated with Expires=0 or a past date *)
441
+
Buffer.add_string buffer "; Expires=0"
442
+
| Some (`DateTime exp_time) ->
443
+
(* Format as HTTP date *)
444
+
let exp_str = Ptime.to_rfc3339 ~tz_offset_s:0 exp_time in
445
+
Buffer.add_string buffer (Printf.sprintf "; Expires=%s" exp_str)
446
+
| None -> ());
447
+
448
+
(* Add Domain *)
449
+
Buffer.add_string buffer (Printf.sprintf "; Domain=%s" (domain cookie));
450
+
451
+
(* Add Path *)
452
+
Buffer.add_string buffer (Printf.sprintf "; Path=%s" (path cookie));
453
+
454
+
(* Add Secure flag *)
455
+
if secure cookie then Buffer.add_string buffer "; Secure";
456
+
457
+
(* Add HttpOnly flag *)
458
+
if http_only cookie then Buffer.add_string buffer "; HttpOnly";
459
+
460
+
(* Add Partitioned flag *)
461
+
if partitioned cookie then Buffer.add_string buffer "; Partitioned";
462
+
463
+
(* Add SameSite *)
464
+
(match same_site cookie with
465
+
| Some `Strict -> Buffer.add_string buffer "; SameSite=Strict"
466
+
| Some `Lax -> Buffer.add_string buffer "; SameSite=Lax"
467
+
| Some `None -> Buffer.add_string buffer "; SameSite=None"
468
+
| None -> ());
469
+
470
+
Buffer.contents buffer
lib/dune
lib/core/dune
lib/dune
lib/core/dune
+434
lib/jar/cookeio_jar.ml
+434
lib/jar/cookeio_jar.ml
···
1
+
let src = Logs.Src.create "cookie_jar" ~doc:"Cookie jar management"
2
+
3
+
module Log = (val Logs.src_log src : Logs.LOG)
4
+
5
+
type t = {
6
+
mutable original_cookies : Cookeio.t list; (* from client *)
7
+
mutable delta_cookies : Cookeio.t list; (* to send back *)
8
+
mutex : Eio.Mutex.t;
9
+
}
10
+
(** Cookie jar for storing and managing cookies *)
11
+
12
+
(** {1 Cookie Jar Creation} *)
13
+
14
+
let create () =
15
+
Log.debug (fun m -> m "Creating new empty cookie jar");
16
+
{ original_cookies = []; delta_cookies = []; mutex = Eio.Mutex.create () }
17
+
18
+
(** {1 Cookie Matching Helpers} *)
19
+
20
+
let cookie_identity_matches c1 c2 =
21
+
Cookeio.name c1 = Cookeio.name c2
22
+
&& Cookeio.domain c1 = Cookeio.domain c2
23
+
&& Cookeio.path c1 = Cookeio.path c2
24
+
25
+
let normalize_domain domain =
26
+
(* Strip leading dot per RFC 6265 *)
27
+
match String.starts_with ~prefix:"." domain with
28
+
| true when String.length domain > 1 ->
29
+
String.sub domain 1 (String.length domain - 1)
30
+
| _ -> domain
31
+
32
+
let domain_matches cookie_domain request_domain =
33
+
(* Cookie domains are stored without leading dots per RFC 6265.
34
+
A cookie with domain "example.com" should match both "example.com" (exact)
35
+
and "sub.example.com" (subdomain). *)
36
+
request_domain = cookie_domain
37
+
|| String.ends_with ~suffix:("." ^ cookie_domain) request_domain
38
+
39
+
let path_matches cookie_path request_path =
40
+
(* Cookie path /foo matches /foo, /foo/, /foo/bar *)
41
+
String.starts_with ~prefix:cookie_path request_path
42
+
43
+
(** {1 HTTP Date Parsing} *)
44
+
let is_expired cookie clock =
45
+
match Cookeio.expires cookie with
46
+
| None -> false (* No expiration *)
47
+
| Some `Session -> false (* Session cookie - not expired until browser closes *)
48
+
| Some (`DateTime exp_time) ->
49
+
let now =
50
+
Ptime.of_float_s (Eio.Time.now clock)
51
+
|> Option.value ~default:Ptime.epoch
52
+
in
53
+
Ptime.compare now exp_time > 0
54
+
55
+
let pp ppf jar =
56
+
Eio.Mutex.lock jar.mutex;
57
+
let original = jar.original_cookies in
58
+
let delta = jar.delta_cookies in
59
+
Eio.Mutex.unlock jar.mutex;
60
+
61
+
let all_cookies = original @ delta in
62
+
Format.fprintf ppf "@[<v>CookieJar with %d cookies (%d original, %d delta):@,"
63
+
(List.length all_cookies) (List.length original) (List.length delta);
64
+
List.iter
65
+
(fun cookie -> Format.fprintf ppf " %a@," Cookeio.pp cookie)
66
+
all_cookies;
67
+
Format.fprintf ppf "@]"
68
+
69
+
(** {1 Cookie Management} *)
70
+
71
+
let add_cookie jar cookie =
72
+
Log.debug (fun m ->
73
+
m "Adding cookie to delta: %s=%s for domain %s"
74
+
(Cookeio.name cookie)
75
+
(Cookeio.value cookie)
76
+
(Cookeio.domain cookie));
77
+
78
+
Eio.Mutex.lock jar.mutex;
79
+
(* Remove existing cookie with same identity from delta *)
80
+
jar.delta_cookies <-
81
+
List.filter
82
+
(fun c -> not (cookie_identity_matches c cookie))
83
+
jar.delta_cookies;
84
+
jar.delta_cookies <- cookie :: jar.delta_cookies;
85
+
Eio.Mutex.unlock jar.mutex
86
+
87
+
let add_original jar cookie =
88
+
Log.debug (fun m ->
89
+
m "Adding original cookie: %s=%s for domain %s"
90
+
(Cookeio.name cookie)
91
+
(Cookeio.value cookie)
92
+
(Cookeio.domain cookie));
93
+
94
+
Eio.Mutex.lock jar.mutex;
95
+
(* Remove existing cookie with same identity from original *)
96
+
jar.original_cookies <-
97
+
List.filter
98
+
(fun c -> not (cookie_identity_matches c cookie))
99
+
jar.original_cookies;
100
+
jar.original_cookies <- cookie :: jar.original_cookies;
101
+
Eio.Mutex.unlock jar.mutex
102
+
103
+
let delta jar =
104
+
Eio.Mutex.lock jar.mutex;
105
+
let result = jar.delta_cookies in
106
+
Eio.Mutex.unlock jar.mutex;
107
+
Log.debug (fun m -> m "Returning %d delta cookies" (List.length result));
108
+
result
109
+
110
+
let make_removal_cookie cookie ~clock =
111
+
let now =
112
+
Ptime.of_float_s (Eio.Time.now clock) |> Option.value ~default:Ptime.epoch
113
+
in
114
+
(* Create a cookie with Max-Age=0 and past expiration (1 year ago) *)
115
+
let past_expiry =
116
+
Ptime.sub_span now (Ptime.Span.of_int_s (365 * 24 * 60 * 60))
117
+
|> Option.value ~default:Ptime.epoch
118
+
in
119
+
Cookeio.make
120
+
~domain:(Cookeio.domain cookie)
121
+
~path:(Cookeio.path cookie)
122
+
~name:(Cookeio.name cookie)
123
+
~value:""
124
+
~secure:(Cookeio.secure cookie)
125
+
~http_only:(Cookeio.http_only cookie)
126
+
~expires:(`DateTime past_expiry)
127
+
~max_age:(Ptime.Span.of_int_s 0)
128
+
?same_site:(Cookeio.same_site cookie)
129
+
~partitioned:(Cookeio.partitioned cookie)
130
+
~creation_time:now ~last_access:now ()
131
+
132
+
let remove jar ~clock cookie =
133
+
Log.debug (fun m ->
134
+
m "Removing cookie: %s=%s for domain %s"
135
+
(Cookeio.name cookie)
136
+
(Cookeio.value cookie)
137
+
(Cookeio.domain cookie));
138
+
139
+
Eio.Mutex.lock jar.mutex;
140
+
(* Check if this cookie exists in original_cookies *)
141
+
let in_original =
142
+
List.exists (fun c -> cookie_identity_matches c cookie) jar.original_cookies
143
+
in
144
+
145
+
if in_original then (
146
+
(* Create a removal cookie and add it to delta *)
147
+
let removal = make_removal_cookie cookie ~clock in
148
+
jar.delta_cookies <-
149
+
List.filter
150
+
(fun c -> not (cookie_identity_matches c removal))
151
+
jar.delta_cookies;
152
+
jar.delta_cookies <- removal :: jar.delta_cookies;
153
+
Log.debug (fun m -> m "Created removal cookie in delta for original cookie"))
154
+
else (
155
+
(* Just remove from delta if it exists there *)
156
+
jar.delta_cookies <-
157
+
List.filter
158
+
(fun c -> not (cookie_identity_matches c cookie))
159
+
jar.delta_cookies;
160
+
Log.debug (fun m -> m "Removed cookie from delta"));
161
+
162
+
Eio.Mutex.unlock jar.mutex
163
+
164
+
let get_cookies jar ~clock ~domain:request_domain ~path:request_path ~is_secure
165
+
=
166
+
Log.debug (fun m ->
167
+
m "Getting cookies for domain=%s path=%s secure=%b" request_domain
168
+
request_path is_secure);
169
+
170
+
Eio.Mutex.lock jar.mutex;
171
+
172
+
(* Combine original and delta cookies, with delta taking precedence *)
173
+
let all_cookies = jar.original_cookies @ jar.delta_cookies in
174
+
175
+
(* Filter out duplicates, keeping the last occurrence (from delta) *)
176
+
let rec dedup acc = function
177
+
| [] -> List.rev acc
178
+
| c :: rest ->
179
+
(* Keep this cookie only if no later cookie has the same identity *)
180
+
let has_duplicate =
181
+
List.exists (fun c2 -> cookie_identity_matches c c2) rest
182
+
in
183
+
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
184
+
in
185
+
let unique_cookies = dedup [] all_cookies in
186
+
187
+
(* Filter for applicable cookies, excluding removal cookies (empty value) *)
188
+
let applicable =
189
+
List.filter
190
+
(fun cookie ->
191
+
Cookeio.value cookie <> ""
192
+
(* Exclude removal cookies *)
193
+
&& domain_matches (Cookeio.domain cookie) request_domain
194
+
&& path_matches (Cookeio.path cookie) request_path
195
+
&& ((not (Cookeio.secure cookie)) || is_secure))
196
+
unique_cookies
197
+
in
198
+
199
+
(* Update last access time in both lists *)
200
+
let now =
201
+
Ptime.of_float_s (Eio.Time.now clock) |> Option.value ~default:Ptime.epoch
202
+
in
203
+
let update_last_access cookies =
204
+
List.map
205
+
(fun c ->
206
+
if List.exists (fun a -> cookie_identity_matches a c) applicable then
207
+
Cookeio.make
208
+
~domain:(Cookeio.domain c)
209
+
~path:(Cookeio.path c)
210
+
~name:(Cookeio.name c)
211
+
~value:(Cookeio.value c)
212
+
~secure:(Cookeio.secure c)
213
+
~http_only:(Cookeio.http_only c)
214
+
?expires:(Cookeio.expires c)
215
+
?max_age:(Cookeio.max_age c)
216
+
?same_site:(Cookeio.same_site c)
217
+
~partitioned:(Cookeio.partitioned c)
218
+
~creation_time:(Cookeio.creation_time c)
219
+
~last_access:now ()
220
+
else c)
221
+
cookies
222
+
in
223
+
jar.original_cookies <- update_last_access jar.original_cookies;
224
+
jar.delta_cookies <- update_last_access jar.delta_cookies;
225
+
226
+
Eio.Mutex.unlock jar.mutex;
227
+
228
+
Log.debug (fun m -> m "Found %d applicable cookies" (List.length applicable));
229
+
applicable
230
+
231
+
let clear jar =
232
+
Log.info (fun m -> m "Clearing all cookies");
233
+
Eio.Mutex.lock jar.mutex;
234
+
jar.original_cookies <- [];
235
+
jar.delta_cookies <- [];
236
+
Eio.Mutex.unlock jar.mutex
237
+
238
+
let clear_expired jar ~clock =
239
+
Eio.Mutex.lock jar.mutex;
240
+
let before_count =
241
+
List.length jar.original_cookies + List.length jar.delta_cookies
242
+
in
243
+
jar.original_cookies <-
244
+
List.filter (fun c -> not (is_expired c clock)) jar.original_cookies;
245
+
jar.delta_cookies <-
246
+
List.filter (fun c -> not (is_expired c clock)) jar.delta_cookies;
247
+
let removed =
248
+
before_count
249
+
- (List.length jar.original_cookies + List.length jar.delta_cookies)
250
+
in
251
+
Eio.Mutex.unlock jar.mutex;
252
+
Log.info (fun m -> m "Cleared %d expired cookies" removed)
253
+
254
+
let clear_session_cookies jar =
255
+
Eio.Mutex.lock jar.mutex;
256
+
let before_count =
257
+
List.length jar.original_cookies + List.length jar.delta_cookies
258
+
in
259
+
(* Keep only cookies that are NOT session cookies *)
260
+
let is_not_session c =
261
+
match Cookeio.expires c with
262
+
| Some `Session -> false (* This is a session cookie, remove it *)
263
+
| None | Some (`DateTime _) -> true (* Keep these *)
264
+
in
265
+
jar.original_cookies <- List.filter is_not_session jar.original_cookies;
266
+
jar.delta_cookies <- List.filter is_not_session jar.delta_cookies;
267
+
let removed =
268
+
before_count
269
+
- (List.length jar.original_cookies + List.length jar.delta_cookies)
270
+
in
271
+
Eio.Mutex.unlock jar.mutex;
272
+
Log.info (fun m -> m "Cleared %d session cookies" removed)
273
+
274
+
let count jar =
275
+
Eio.Mutex.lock jar.mutex;
276
+
(* Combine and deduplicate cookies for count *)
277
+
let all_cookies = jar.original_cookies @ jar.delta_cookies in
278
+
let rec dedup acc = function
279
+
| [] -> List.rev acc
280
+
| c :: rest ->
281
+
let has_duplicate =
282
+
List.exists (fun c2 -> cookie_identity_matches c c2) rest
283
+
in
284
+
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
285
+
in
286
+
let unique = dedup [] all_cookies in
287
+
let n = List.length unique in
288
+
Eio.Mutex.unlock jar.mutex;
289
+
n
290
+
291
+
let get_all_cookies jar =
292
+
Eio.Mutex.lock jar.mutex;
293
+
(* Combine and deduplicate, with delta taking precedence *)
294
+
let all_cookies = jar.original_cookies @ jar.delta_cookies in
295
+
let rec dedup acc = function
296
+
| [] -> List.rev acc
297
+
| c :: rest ->
298
+
let has_duplicate =
299
+
List.exists (fun c2 -> cookie_identity_matches c c2) rest
300
+
in
301
+
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
302
+
in
303
+
let unique = dedup [] all_cookies in
304
+
Eio.Mutex.unlock jar.mutex;
305
+
unique
306
+
307
+
let is_empty jar =
308
+
Eio.Mutex.lock jar.mutex;
309
+
let empty = jar.original_cookies = [] && jar.delta_cookies = [] in
310
+
Eio.Mutex.unlock jar.mutex;
311
+
empty
312
+
313
+
(** {1 Mozilla Format} *)
314
+
315
+
let to_mozilla_format_internal jar =
316
+
let buffer = Buffer.create 1024 in
317
+
Buffer.add_string buffer "# Netscape HTTP Cookie File\n";
318
+
Buffer.add_string buffer "# This is a generated file! Do not edit.\n\n";
319
+
320
+
(* Combine and deduplicate cookies *)
321
+
let all_cookies = jar.original_cookies @ jar.delta_cookies in
322
+
let rec dedup acc = function
323
+
| [] -> List.rev acc
324
+
| c :: rest ->
325
+
let has_duplicate =
326
+
List.exists (fun c2 -> cookie_identity_matches c c2) rest
327
+
in
328
+
if has_duplicate then dedup acc rest else dedup (c :: acc) rest
329
+
in
330
+
let unique = dedup [] all_cookies in
331
+
332
+
List.iter
333
+
(fun cookie ->
334
+
let include_subdomains =
335
+
if String.starts_with ~prefix:"." (Cookeio.domain cookie) then "TRUE"
336
+
else "FALSE"
337
+
in
338
+
let secure_flag = if Cookeio.secure cookie then "TRUE" else "FALSE" in
339
+
let expires_str =
340
+
match Cookeio.expires cookie with
341
+
| None -> "0" (* No expiration *)
342
+
| Some `Session -> "0" (* Session cookie *)
343
+
| Some (`DateTime t) ->
344
+
let epoch = Ptime.to_float_s t |> int_of_float |> string_of_int in
345
+
epoch
346
+
in
347
+
348
+
Buffer.add_string buffer
349
+
(Printf.sprintf "%s\t%s\t%s\t%s\t%s\t%s\t%s\n"
350
+
(Cookeio.domain cookie)
351
+
include_subdomains
352
+
(Cookeio.path cookie)
353
+
secure_flag expires_str
354
+
(Cookeio.name cookie)
355
+
(Cookeio.value cookie)))
356
+
unique;
357
+
358
+
Buffer.contents buffer
359
+
360
+
let to_mozilla_format jar =
361
+
Eio.Mutex.lock jar.mutex;
362
+
let result = to_mozilla_format_internal jar in
363
+
Eio.Mutex.unlock jar.mutex;
364
+
result
365
+
366
+
let from_mozilla_format ~clock content =
367
+
Log.debug (fun m -> m "Parsing Mozilla format cookies");
368
+
let jar = create () in
369
+
370
+
let lines = String.split_on_char '\n' content in
371
+
List.iter
372
+
(fun line ->
373
+
let line = String.trim line in
374
+
if line <> "" && not (String.starts_with ~prefix:"#" line) then
375
+
match String.split_on_char '\t' line with
376
+
| [ domain; _include_subdomains; path; secure; expires; name; value ] ->
377
+
let now =
378
+
Ptime.of_float_s (Eio.Time.now clock)
379
+
|> Option.value ~default:Ptime.epoch
380
+
in
381
+
let expires =
382
+
let exp_int = try int_of_string expires with _ -> 0 in
383
+
if exp_int = 0 then None
384
+
else
385
+
match Ptime.of_float_s (float_of_int exp_int) with
386
+
| Some t -> Some (`DateTime t)
387
+
| None -> None
388
+
in
389
+
390
+
let cookie =
391
+
Cookeio.make ~domain:(normalize_domain domain) ~path ~name ~value
392
+
~secure:(secure = "TRUE") ~http_only:false ?expires ?max_age:None
393
+
?same_site:None ~partitioned:false ~creation_time:now
394
+
~last_access:now ()
395
+
in
396
+
add_original jar cookie;
397
+
Log.debug (fun m -> m "Loaded cookie: %s=%s" name value)
398
+
| _ -> Log.warn (fun m -> m "Invalid cookie line: %s" line))
399
+
lines;
400
+
401
+
Log.info (fun m -> m "Loaded %d cookies" (List.length jar.original_cookies));
402
+
jar
403
+
404
+
(** {1 File Operations} *)
405
+
406
+
let load ~clock path =
407
+
Log.info (fun m -> m "Loading cookies from %a" Eio.Path.pp path);
408
+
409
+
try
410
+
let content = Eio.Path.load path in
411
+
from_mozilla_format ~clock content
412
+
with
413
+
| Eio.Io _ ->
414
+
Log.info (fun m -> m "Cookie file not found, creating empty jar");
415
+
create ()
416
+
| exn ->
417
+
Log.err (fun m -> m "Failed to load cookies: %s" (Printexc.to_string exn));
418
+
create ()
419
+
420
+
let save path jar =
421
+
Eio.Mutex.lock jar.mutex;
422
+
let total_cookies =
423
+
List.length jar.original_cookies + List.length jar.delta_cookies
424
+
in
425
+
Eio.Mutex.unlock jar.mutex;
426
+
Log.info (fun m -> m "Saving %d cookies to %a" total_cookies Eio.Path.pp path);
427
+
428
+
let content = to_mozilla_format jar in
429
+
430
+
try
431
+
Eio.Path.save ~create:(`Or_truncate 0o600) path content;
432
+
Log.debug (fun m -> m "Cookies saved successfully")
433
+
with exn ->
434
+
Log.err (fun m -> m "Failed to save cookies: %s" (Printexc.to_string exn))
+117
lib/jar/cookeio_jar.mli
+117
lib/jar/cookeio_jar.mli
···
1
+
(** Cookie jar for storing and managing HTTP cookies.
2
+
3
+
This module provides a complete cookie jar implementation following
4
+
established web standards while integrating Eio for efficient asynchronous
5
+
operations.
6
+
7
+
A cookie jar maintains a collection of cookies with automatic cleanup of
8
+
expired entries. It implements the standard browser behavior for cookie
9
+
storage, including:
10
+
- Automatic removal of expired cookies
11
+
- Domain and path-based cookie retrieval
12
+
- Delta tracking for Set-Cookie headers
13
+
- Mozilla format persistence for cross-tool compatibility *)
14
+
15
+
type t
16
+
(** Cookie jar for storing and managing cookies.
17
+
18
+
A cookie jar maintains a collection of cookies with automatic cleanup of
19
+
expired entries and enforcement of storage limits. It implements the
20
+
standard browser behavior for cookie storage, including:
21
+
- Automatic removal of expired cookies
22
+
- LRU eviction when storage limits are exceeded
23
+
- Domain and path-based cookie retrieval
24
+
- Mozilla format persistence for cross-tool compatibility *)
25
+
26
+
(** {1 Cookie Jar Creation and Loading} *)
27
+
28
+
val create : unit -> t
29
+
(** Create an empty cookie jar *)
30
+
31
+
val load : clock:_ Eio.Time.clock -> Eio.Fs.dir_ty Eio.Path.t -> t
32
+
(** Load cookies from Mozilla format file.
33
+
34
+
Loads cookies from a file in Mozilla format, using the provided clock to set
35
+
creation and last access times. Returns an empty jar if the file doesn't
36
+
exist or cannot be loaded. *)
37
+
38
+
val save : Eio.Fs.dir_ty Eio.Path.t -> t -> unit
39
+
(** Save cookies to Mozilla format file *)
40
+
41
+
(** {1 Cookie Jar Management} *)
42
+
43
+
val add_cookie : t -> Cookeio.t -> unit
44
+
(** Add a cookie to the jar.
45
+
46
+
The cookie is added to the delta, meaning it will appear in Set-Cookie
47
+
headers when calling {!delta}. If a cookie with the same name/domain/path
48
+
exists in the delta, it will be replaced. *)
49
+
50
+
val add_original : t -> Cookeio.t -> unit
51
+
(** Add an original cookie to the jar.
52
+
53
+
Original cookies are those received from the client (via Cookie header).
54
+
They do not appear in the delta. This method should be used when loading
55
+
cookies from incoming HTTP requests. *)
56
+
57
+
val delta : t -> Cookeio.t list
58
+
(** Get cookies that need to be sent in Set-Cookie headers.
59
+
60
+
Returns cookies that have been added via {!add_cookie} and removal cookies
61
+
for original cookies that have been removed. Does not include original
62
+
cookies that were added via {!add_original}. *)
63
+
64
+
val remove : t -> clock:_ Eio.Time.clock -> Cookeio.t -> unit
65
+
(** Remove a cookie from the jar.
66
+
67
+
If an original cookie with the same name/domain/path exists, creates a
68
+
removal cookie (empty value, Max-Age=0, past expiration) that appears in the
69
+
delta. If only a delta cookie exists, simply removes it from the delta. *)
70
+
71
+
val get_cookies :
72
+
t ->
73
+
clock:_ Eio.Time.clock ->
74
+
domain:string ->
75
+
path:string ->
76
+
is_secure:bool ->
77
+
Cookeio.t list
78
+
(** Get cookies applicable for a URL.
79
+
80
+
Returns all cookies that match the given domain and path, and satisfy the
81
+
secure flag requirement. Combines original and delta cookies, with delta
82
+
taking precedence. Excludes removal cookies (empty value). Also updates the
83
+
last access time of matching cookies using the provided clock. *)
84
+
85
+
val clear : t -> unit
86
+
(** Clear all cookies *)
87
+
88
+
val clear_expired : t -> clock:_ Eio.Time.clock -> unit
89
+
(** Clear expired cookies *)
90
+
91
+
val clear_session_cookies : t -> unit
92
+
(** Clear session cookies (those without expiry) *)
93
+
94
+
val count : t -> int
95
+
(** Get the number of cookies in the jar *)
96
+
97
+
val get_all_cookies : t -> Cookeio.t list
98
+
(** Get all cookies in the jar *)
99
+
100
+
val is_empty : t -> bool
101
+
(** Check if the jar is empty *)
102
+
103
+
(** {1 Pretty Printing} *)
104
+
105
+
val pp : Format.formatter -> t -> unit
106
+
(** Pretty print a cookie jar *)
107
+
108
+
(** {1 Mozilla Format} *)
109
+
110
+
val to_mozilla_format : t -> string
111
+
(** Write cookies in Mozilla format *)
112
+
113
+
val from_mozilla_format : clock:_ Eio.Time.clock -> string -> t
114
+
(** Parse Mozilla format cookies.
115
+
116
+
Creates a cookie jar from a string in Mozilla cookie format, using the
117
+
provided clock to set creation and last access times. *)
+4
lib/jar/dune
+4
lib/jar/dune
+1
-1
test/dune
+1
-1
test/dune
+44
-43
test/test_cookeio.ml
+44
-43
test/test_cookeio.ml
···
1
1
open Cookeio
2
+
open Cookeio_jar
2
3
3
4
(* Testable helpers for Priority 2 types *)
4
5
let expiration_testable : Cookeio.Expiration.t Alcotest.testable =
···
375
376
(* Parse a Set-Cookie header with Max-Age *)
376
377
let header = "session=abc123; Max-Age=3600; Secure; HttpOnly" in
377
378
let cookie_opt =
378
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
379
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
379
380
in
380
381
381
382
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
···
442
443
"updated last access" (Ptime.of_float_s 4000.0)
443
444
(Some (Cookeio.last_access cookie2))
444
445
445
-
let test_parse_set_cookie_with_expires () =
446
+
let test_of_set_cookie_header_with_expires () =
446
447
Eio_mock.Backend.run @@ fun () ->
447
448
let clock = Eio_mock.Clock.make () in
448
449
···
454
455
"id=xyz789; Expires=2025-10-21T07:28:00Z; Path=/; Domain=.example.com"
455
456
in
456
457
let cookie_opt =
457
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
458
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
458
459
in
459
460
460
461
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
···
489
490
(* This should be rejected: SameSite=None without Secure *)
490
491
let invalid_header = "token=abc; SameSite=None" in
491
492
let cookie_opt =
492
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" invalid_header
493
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" invalid_header
493
494
in
494
495
495
496
Alcotest.(check bool)
···
499
500
(* This should be accepted: SameSite=None with Secure *)
500
501
let valid_header = "token=abc; SameSite=None; Secure" in
501
502
let cookie_opt2 =
502
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" valid_header
503
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" valid_header
503
504
in
504
505
505
506
Alcotest.(check bool)
···
527
528
(* Test parsing ".example.com" stores as "example.com" *)
528
529
let header = "test=value; Domain=.example.com" in
529
530
let cookie_opt =
530
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
531
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
531
532
in
532
533
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
533
534
let cookie = Option.get cookie_opt in
···
561
562
(* Parse a Set-Cookie header with Max-Age *)
562
563
let header = "session=abc123; Max-Age=3600" in
563
564
let cookie_opt =
564
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
565
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
565
566
in
566
567
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
567
568
···
594
595
(* Parse a Set-Cookie header with negative Max-Age *)
595
596
let header = "session=abc123; Max-Age=-100" in
596
597
let cookie_opt =
597
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
598
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
598
599
in
599
600
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
600
601
···
678
679
(* Parse a cookie with Max-Age *)
679
680
let header = "session=xyz; Max-Age=7200; Secure; HttpOnly" in
680
681
let cookie_opt =
681
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
682
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
682
683
in
683
684
Alcotest.(check bool) "cookie parsed" true (Option.is_some cookie_opt);
684
685
let cookie = Option.get cookie_opt in
···
690
691
Eio_mock.Clock.set_time clock 5000.0;
691
692
(* Reset clock to same time *)
692
693
let cookie2_opt =
693
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" set_cookie_header
694
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" set_cookie_header
694
695
in
695
696
Alcotest.(check bool) "cookie re-parsed" true (Option.is_some cookie2_opt);
696
697
let cookie2 = Option.get cookie2_opt in
···
759
760
(* Test FMT1: "Wed, 21 Oct 2015 07:28:00 GMT" (RFC 1123) *)
760
761
let header = "session=abc; Expires=Wed, 21 Oct 2015 07:28:00 GMT" in
761
762
let cookie_opt =
762
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
763
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
763
764
in
764
765
Alcotest.(check bool) "FMT1 cookie parsed" true (Option.is_some cookie_opt);
765
766
···
785
786
(* Test FMT2: "Wednesday, 21-Oct-15 07:28:00 GMT" (RFC 850 with abbreviated year) *)
786
787
let header = "session=abc; Expires=Wednesday, 21-Oct-15 07:28:00 GMT" in
787
788
let cookie_opt =
788
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
789
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
789
790
in
790
791
Alcotest.(check bool) "FMT2 cookie parsed" true (Option.is_some cookie_opt);
791
792
···
812
813
(* Test FMT3: "Wed Oct 21 07:28:00 2015" (asctime) *)
813
814
let header = "session=abc; Expires=Wed Oct 21 07:28:00 2015" in
814
815
let cookie_opt =
815
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
816
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
816
817
in
817
818
Alcotest.(check bool) "FMT3 cookie parsed" true (Option.is_some cookie_opt);
818
819
···
837
838
(* Test FMT4: "Wed, 21-Oct-2015 07:28:00 GMT" (variant) *)
838
839
let header = "session=abc; Expires=Wed, 21-Oct-2015 07:28:00 GMT" in
839
840
let cookie_opt =
840
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
841
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
841
842
in
842
843
Alcotest.(check bool) "FMT4 cookie parsed" true (Option.is_some cookie_opt);
843
844
···
862
863
(* Year 95 should become 1995 *)
863
864
let header = "session=abc; Expires=Wed, 21-Oct-95 07:28:00 GMT" in
864
865
let cookie_opt =
865
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
866
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
866
867
in
867
868
let cookie = Option.get cookie_opt in
868
869
let expected = Ptime.of_date_time ((1995, 10, 21), ((07, 28, 00), 0)) in
···
876
877
(* Year 69 should become 1969 *)
877
878
let header2 = "session=abc; Expires=Wed, 10-Sep-69 20:00:00 GMT" in
878
879
let cookie_opt2 =
879
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header2
880
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header2
880
881
in
881
882
let cookie2 = Option.get cookie_opt2 in
882
883
let expected2 = Ptime.of_date_time ((1969, 9, 10), ((20, 0, 0), 0)) in
···
890
891
(* Year 99 should become 1999 *)
891
892
let header3 = "session=abc; Expires=Thu, 10-Sep-99 20:00:00 GMT" in
892
893
let cookie_opt3 =
893
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header3
894
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header3
894
895
in
895
896
let cookie3 = Option.get cookie_opt3 in
896
897
let expected3 = Ptime.of_date_time ((1999, 9, 10), ((20, 0, 0), 0)) in
···
909
910
(* Year 25 should become 2025 *)
910
911
let header = "session=abc; Expires=Wed, 21-Oct-25 07:28:00 GMT" in
911
912
let cookie_opt =
912
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
913
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
913
914
in
914
915
let cookie = Option.get cookie_opt in
915
916
let expected = Ptime.of_date_time ((2025, 10, 21), ((07, 28, 00), 0)) in
···
923
924
(* Year 0 should become 2000 *)
924
925
let header2 = "session=abc; Expires=Fri, 01-Jan-00 00:00:00 GMT" in
925
926
let cookie_opt2 =
926
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header2
927
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header2
927
928
in
928
929
let cookie2 = Option.get cookie_opt2 in
929
930
let expected2 = Ptime.of_date_time ((2000, 1, 1), ((0, 0, 0), 0)) in
···
937
938
(* Year 68 should become 2068 *)
938
939
let header3 = "session=abc; Expires=Thu, 10-Sep-68 20:00:00 GMT" in
939
940
let cookie_opt3 =
940
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header3
941
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header3
941
942
in
942
943
let cookie3 = Option.get cookie_opt3 in
943
944
let expected3 = Ptime.of_date_time ((2068, 9, 10), ((20, 0, 0), 0)) in
···
956
957
(* Ensure RFC 3339 format still works for backward compatibility *)
957
958
let header = "session=abc; Expires=2025-10-21T07:28:00Z" in
958
959
let cookie_opt =
959
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
960
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
960
961
in
961
962
Alcotest.(check bool)
962
963
"RFC 3339 cookie parsed" true
···
983
984
(* Invalid date format should log a warning but still parse the cookie *)
984
985
let header = "session=abc; Expires=InvalidDate" in
985
986
let cookie_opt =
986
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
987
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
987
988
in
988
989
989
990
(* Cookie should still be parsed, just without expires *)
···
1015
1016
List.iter
1016
1017
(fun (header, description) ->
1017
1018
let cookie_opt =
1018
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
1019
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
1019
1020
in
1020
1021
Alcotest.(check bool)
1021
1022
(description ^ " parsed") true
···
1057
1058
List.iter
1058
1059
(fun (header, description) ->
1059
1060
let cookie_opt =
1060
-
parse_set_cookie ~clock ~domain:"example.com" ~path:"/" header
1061
+
of_set_cookie_header ~clock ~domain:"example.com" ~path:"/" header
1061
1062
in
1062
1063
Alcotest.(check bool)
1063
1064
(description ^ " parsed") true
···
1100
1101
add_original jar cookie;
1101
1102
1102
1103
(* Delta should be empty *)
1103
-
let delta = Cookeio.delta jar in
1104
+
let delta = delta jar in
1104
1105
Alcotest.(check int) "delta is empty" 0 (List.length delta);
1105
1106
1106
1107
(* But the cookie should be in the jar *)
···
1122
1123
add_cookie jar cookie;
1123
1124
1124
1125
(* Delta should contain the cookie *)
1125
-
let delta = Cookeio.delta jar in
1126
+
let delta = delta jar in
1126
1127
Alcotest.(check int) "delta has 1 cookie" 1 (List.length delta);
1127
1128
let delta_cookie = List.hd delta in
1128
1129
Alcotest.(check string) "delta cookie name" "test" (Cookeio.name delta_cookie);
···
1146
1147
add_original jar cookie;
1147
1148
1148
1149
(* Remove the cookie *)
1149
-
Cookeio.remove jar ~clock cookie;
1150
+
remove jar ~clock cookie;
1150
1151
1151
1152
(* Delta should contain a removal cookie *)
1152
-
let delta = Cookeio.delta jar in
1153
+
let delta = delta jar in
1153
1154
Alcotest.(check int) "delta has 1 removal cookie" 1 (List.length delta);
1154
1155
let removal_cookie = List.hd delta in
1155
1156
Alcotest.(check string)
···
1182
1183
add_cookie jar cookie;
1183
1184
1184
1185
(* Remove the cookie *)
1185
-
Cookeio.remove jar ~clock cookie;
1186
+
remove jar ~clock cookie;
1186
1187
1187
1188
(* Delta should be empty *)
1188
-
let delta = Cookeio.delta jar in
1189
+
let delta = delta jar in
1189
1190
Alcotest.(check int)
1190
1191
"delta is empty after removing delta cookie" 0 (List.length delta)
1191
1192
···
1281
1282
add_original jar original;
1282
1283
1283
1284
(* Remove it *)
1284
-
Cookeio.remove jar ~clock original;
1285
+
remove jar ~clock original;
1285
1286
1286
1287
(* Get cookies should return nothing *)
1287
1288
let cookies =
···
1290
1291
Alcotest.(check int) "no cookies returned" 0 (List.length cookies);
1291
1292
1292
1293
(* But delta should have the removal cookie *)
1293
-
let delta = Cookeio.delta jar in
1294
+
let delta = delta jar in
1294
1295
Alcotest.(check int) "delta has removal cookie" 1 (List.length delta)
1295
1296
1296
1297
let test_delta_returns_only_changed_cookies () =
···
1330
1331
add_cookie jar new_cookie;
1331
1332
1332
1333
(* Delta should only contain the new cookie *)
1333
-
let delta = Cookeio.delta jar in
1334
+
let delta = delta jar in
1334
1335
Alcotest.(check int) "delta has 1 cookie" 1 (List.length delta);
1335
1336
let delta_cookie = List.hd delta in
1336
1337
Alcotest.(check string) "delta cookie name" "new" (Cookeio.name delta_cookie)
···
1352
1353
add_original jar cookie;
1353
1354
1354
1355
(* Remove the cookie *)
1355
-
Cookeio.remove jar ~clock cookie;
1356
+
remove jar ~clock cookie;
1356
1357
1357
1358
(* Get the removal cookie *)
1358
-
let delta = Cookeio.delta jar in
1359
+
let delta = delta jar in
1359
1360
let removal = List.hd delta in
1360
1361
1361
1362
(* Check all properties *)
···
1383
1384
let test_partitioned_parsing env =
1384
1385
let clock = Eio.Stdenv.clock env in
1385
1386
1386
-
match parse_set_cookie ~clock ~domain:"widget.com" ~path:"/"
1387
+
match of_set_cookie_header ~clock ~domain:"widget.com" ~path:"/"
1387
1388
"id=123; Partitioned; Secure" with
1388
1389
| Some c ->
1389
1390
Alcotest.(check bool) "partitioned flag" true (partitioned c);
···
1414
1415
let clock = Eio.Stdenv.clock env in
1415
1416
1416
1417
(* Partitioned without Secure should be rejected *)
1417
-
match parse_set_cookie ~clock ~domain:"widget.com" ~path:"/"
1418
+
match of_set_cookie_header ~clock ~domain:"widget.com" ~path:"/"
1418
1419
"id=123; Partitioned" with
1419
1420
| None -> () (* Expected *)
1420
1421
| Some _ -> Alcotest.fail "Should reject Partitioned without Secure"
···
1450
1451
let clock = Eio.Stdenv.clock env in
1451
1452
1452
1453
(* Expires=0 should parse as Session *)
1453
-
match parse_set_cookie ~clock ~domain:"ex.com" ~path:"/"
1454
+
match of_set_cookie_header ~clock ~domain:"ex.com" ~path:"/"
1454
1455
"id=123; Expires=0" with
1455
1456
| Some c ->
1456
1457
Alcotest.(check (option expiration_testable)) "expires=0 is session"
···
1496
1497
] in
1497
1498
1498
1499
List.iter (fun (input, expected_raw, expected_trimmed) ->
1499
-
match parse_set_cookie ~clock ~domain:"ex.com" ~path:"/" input with
1500
+
match of_set_cookie_header ~clock ~domain:"ex.com" ~path:"/" input with
1500
1501
| Some c ->
1501
1502
Alcotest.(check string)
1502
1503
(Printf.sprintf "raw value for %s" input) expected_raw (value c);
···
1509
1510
let test_trimmed_value_not_used_for_equality env =
1510
1511
let clock = Eio.Stdenv.clock env in
1511
1512
1512
-
match parse_set_cookie ~clock ~domain:"ex.com" ~path:"/"
1513
+
match of_set_cookie_header ~clock ~domain:"ex.com" ~path:"/"
1513
1514
"name=\"value\"" with
1514
1515
| Some c1 ->
1515
-
begin match parse_set_cookie ~clock ~domain:"ex.com" ~path:"/"
1516
+
begin match of_set_cookie_header ~clock ~domain:"ex.com" ~path:"/"
1516
1517
"name=value" with
1517
1518
| Some c2 ->
1518
1519
(* Different raw values *)
···
1656
1657
let clock = Eio.Stdenv.clock env in
1657
1658
1658
1659
(* Parse Set-Cookie with both attributes *)
1659
-
match parse_set_cookie ~clock ~domain:"ex.com" ~path:"/"
1660
+
match of_set_cookie_header ~clock ~domain:"ex.com" ~path:"/"
1660
1661
"id=123; Max-Age=3600; Expires=Wed, 21 Oct 2025 07:28:00 GMT" with
1661
1662
| Some c ->
1662
1663
(* Both should be stored *)
···
1708
1709
test_case "Last access time with mock clock" `Quick
1709
1710
test_last_access_time_with_mock_clock;
1710
1711
test_case "Parse Set-Cookie with Expires" `Quick
1711
-
test_parse_set_cookie_with_expires;
1712
+
test_of_set_cookie_header_with_expires;
1712
1713
test_case "SameSite=None validation" `Quick
1713
1714
test_samesite_none_validation;
1714
1715
] );