···
1
+
let src = Logs.Src.create "cookeio" ~doc:"Cookie management"
3
+
module Log = (val Logs.src_log src : Logs.LOG)
5
+
type same_site = [ `Strict | `Lax | `None ]
6
+
(** Cookie same-site policy *)
15
+
expires : Ptime.t option;
16
+
same_site : same_site option;
17
+
creation_time : Ptime.t;
18
+
last_access : Ptime.t;
22
+
type jar = { mutable cookies : t list; mutex : Eio.Mutex.t }
23
+
(** Cookie jar for storing and managing cookies *)
25
+
(** {1 Cookie Accessors} *)
27
+
let domain cookie = cookie.domain
28
+
let path cookie = cookie.path
29
+
let name cookie = cookie.name
30
+
let value cookie = cookie.value
31
+
let secure cookie = cookie.secure
32
+
let http_only cookie = cookie.http_only
33
+
let expires cookie = cookie.expires
34
+
let same_site cookie = cookie.same_site
35
+
let creation_time cookie = cookie.creation_time
36
+
let last_access cookie = cookie.last_access
38
+
let make ~domain ~path ~name ~value ?(secure = false) ?(http_only = false)
39
+
?expires ?same_site ~creation_time ~last_access () =
40
+
{ domain; path; name; value; secure; http_only; expires; same_site; creation_time; last_access }
42
+
(** {1 Cookie Jar Creation} *)
45
+
Log.debug (fun m -> m "Creating new empty cookie jar");
46
+
{ cookies = []; mutex = Eio.Mutex.create () }
48
+
(** {1 Cookie Matching Helpers} *)
50
+
let domain_matches cookie_domain request_domain =
51
+
(* Cookie domain .example.com matches example.com and sub.example.com *)
52
+
if String.starts_with ~prefix:"." cookie_domain then
53
+
let domain_suffix = String.sub cookie_domain 1 (String.length cookie_domain - 1) in
54
+
request_domain = domain_suffix
55
+
|| String.ends_with ~suffix:("." ^ domain_suffix) request_domain
56
+
else cookie_domain = request_domain
58
+
let path_matches cookie_path request_path =
59
+
(* Cookie path /foo matches /foo, /foo/, /foo/bar *)
60
+
String.starts_with ~prefix:cookie_path request_path
62
+
let is_expired cookie clock =
63
+
match cookie.expires with
64
+
| None -> false (* Session cookie *)
67
+
Ptime.of_float_s (Eio.Time.now clock)
68
+
|> Option.value ~default:Ptime.epoch
70
+
Ptime.compare now exp_time > 0
72
+
(** {1 Cookie Parsing} *)
74
+
let parse_cookie_attribute attr attr_value cookie =
75
+
let attr_lower = String.lowercase_ascii attr in
76
+
match attr_lower with
77
+
| "domain" -> make ~domain:attr_value ~path:(path cookie) ~name:(name cookie)
78
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
79
+
?expires:(expires cookie) ?same_site:(same_site cookie)
80
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
81
+
| "path" -> make ~domain:(domain cookie) ~path:attr_value ~name:(name cookie)
82
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
83
+
?expires:(expires cookie) ?same_site:(same_site cookie)
84
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
86
+
(* Parse various date formats *)
88
+
let time, _tz_offset, _tz_string =
89
+
Ptime.of_rfc3339 attr_value |> Result.get_ok
91
+
make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
92
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
93
+
~expires:time ?same_site:(same_site cookie)
94
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
96
+
Log.debug (fun m -> m "Failed to parse expires: %s" attr_value);
100
+
let seconds = int_of_string attr_value in
101
+
let now = Unix.time () in
102
+
let expires = Ptime.of_float_s (now +. float_of_int seconds) in
103
+
make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
104
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
105
+
?expires ?same_site:(same_site cookie)
106
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
108
+
| "secure" -> make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
109
+
~value:(value cookie) ~secure:true ~http_only:(http_only cookie)
110
+
?expires:(expires cookie) ?same_site:(same_site cookie)
111
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
112
+
| "httponly" -> make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
113
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:true
114
+
?expires:(expires cookie) ?same_site:(same_site cookie)
115
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
117
+
let same_site_val =
118
+
match String.lowercase_ascii attr_value with
119
+
| "strict" -> Some `Strict
120
+
| "lax" -> Some `Lax
121
+
| "none" -> Some `None
124
+
make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
125
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
126
+
?expires:(expires cookie) ?same_site:same_site_val
127
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
130
+
let rec parse_set_cookie ~domain:request_domain ~path:request_path header_value =
131
+
Log.debug (fun m -> m "Parsing Set-Cookie: %s" header_value);
133
+
(* Split into attributes *)
134
+
let parts = String.split_on_char ';' header_value |> List.map String.trim in
138
+
| name_value :: attrs -> (
139
+
(* Parse name=value *)
140
+
match String.index_opt name_value '=' with
143
+
let name = String.sub name_value 0 eq_pos |> String.trim in
145
+
String.sub name_value (eq_pos + 1)
146
+
(String.length name_value - eq_pos - 1)
151
+
Ptime.of_float_s (Unix.time ()) |> Option.value ~default:Ptime.epoch
154
+
make ~domain:request_domain ~path:request_path ~name ~value:cookie_value ~secure:false ~http_only:false
155
+
?expires:None ?same_site:None ~creation_time:now ~last_access:now ()
158
+
(* Parse attributes *)
161
+
(fun cookie attr ->
162
+
match String.index_opt attr '=' with
163
+
| None -> parse_cookie_attribute attr "" cookie
165
+
let attr_name = String.sub attr 0 eq |> String.trim in
167
+
String.sub attr (eq + 1) (String.length attr - eq - 1)
170
+
parse_cookie_attribute attr_name attr_value cookie)
174
+
Log.debug (fun m -> m "Parsed cookie: %a" pp cookie);
177
+
and make_cookie_header cookies =
179
+
|> List.map (fun c -> Printf.sprintf "%s=%s" (name c) (value c))
180
+
|> String.concat "; "
182
+
(** {1 Pretty Printing} *)
184
+
and pp_same_site ppf = function
185
+
| `Strict -> Format.pp_print_string ppf "Strict"
186
+
| `Lax -> Format.pp_print_string ppf "Lax"
187
+
| `None -> Format.pp_print_string ppf "None"
189
+
and pp ppf cookie =
191
+
"@[<hov 2>{ name=%S;@ value=%S;@ domain=%S;@ path=%S;@ secure=%b;@ \
192
+
http_only=%b;@ expires=%a;@ same_site=%a }@]"
193
+
(name cookie) (value cookie) (domain cookie) (path cookie) (secure cookie)
195
+
(Format.pp_print_option Ptime.pp)
197
+
(Format.pp_print_option pp_same_site)
200
+
let pp_jar ppf jar =
201
+
Eio.Mutex.lock jar.mutex;
202
+
let cookies = jar.cookies in
203
+
Eio.Mutex.unlock jar.mutex;
205
+
Format.fprintf ppf "@[<v>CookieJar with %d cookies:@," (List.length cookies);
206
+
List.iter (fun cookie -> Format.fprintf ppf " %a@," pp cookie) cookies;
207
+
Format.fprintf ppf "@]"
209
+
(** {1 Cookie Management} *)
211
+
let add_cookie jar cookie =
212
+
Log.debug (fun m ->
213
+
m "Adding cookie: %s=%s for domain %s" (name cookie) (value cookie)
216
+
Eio.Mutex.lock jar.mutex;
217
+
(* Remove existing cookie with same name, domain, and path *)
222
+
(name c = name cookie && domain c = domain cookie
223
+
&& path c = path cookie))
225
+
jar.cookies <- cookie :: jar.cookies;
226
+
Eio.Mutex.unlock jar.mutex
228
+
let get_cookies jar ~domain:request_domain ~path:request_path ~is_secure =
229
+
Log.debug (fun m ->
230
+
m "Getting cookies for domain=%s path=%s secure=%b" request_domain request_path is_secure);
232
+
Eio.Mutex.lock jar.mutex;
236
+
domain_matches (domain cookie) request_domain
237
+
&& path_matches (path cookie) request_path
238
+
&& ((not (secure cookie)) || is_secure))
242
+
(* Update last access time *)
244
+
Ptime.of_float_s (Unix.time ()) |> Option.value ~default:Ptime.epoch
249
+
if List.memq c applicable then
250
+
make ~domain:(domain c) ~path:(path c) ~name:(name c) ~value:(value c)
251
+
~secure:(secure c) ~http_only:(http_only c) ?expires:(expires c)
252
+
?same_site:(same_site c) ~creation_time:(creation_time c) ~last_access:now ()
256
+
jar.cookies <- updated;
257
+
Eio.Mutex.unlock jar.mutex;
259
+
Log.debug (fun m -> m "Found %d applicable cookies" (List.length applicable));
263
+
Log.info (fun m -> m "Clearing all cookies");
264
+
Eio.Mutex.lock jar.mutex;
266
+
Eio.Mutex.unlock jar.mutex
268
+
let clear_expired jar ~clock =
269
+
Eio.Mutex.lock jar.mutex;
270
+
let before_count = List.length jar.cookies in
271
+
jar.cookies <- List.filter (fun c -> not (is_expired c clock)) jar.cookies;
272
+
let removed = before_count - List.length jar.cookies in
273
+
Eio.Mutex.unlock jar.mutex;
274
+
Log.info (fun m -> m "Cleared %d expired cookies" removed)
276
+
let clear_session_cookies jar =
277
+
Eio.Mutex.lock jar.mutex;
278
+
let before_count = List.length jar.cookies in
279
+
jar.cookies <- List.filter (fun c -> expires c <> None) jar.cookies;
280
+
let removed = before_count - List.length jar.cookies in
281
+
Eio.Mutex.unlock jar.mutex;
282
+
Log.info (fun m -> m "Cleared %d session cookies" removed)
285
+
Eio.Mutex.lock jar.mutex;
286
+
let n = List.length jar.cookies in
287
+
Eio.Mutex.unlock jar.mutex;
290
+
let get_all_cookies jar =
291
+
Eio.Mutex.lock jar.mutex;
292
+
let cookies = jar.cookies in
293
+
Eio.Mutex.unlock jar.mutex;
297
+
Eio.Mutex.lock jar.mutex;
298
+
let empty = jar.cookies = [] in
299
+
Eio.Mutex.unlock jar.mutex;
302
+
(** {1 Mozilla Format} *)
304
+
let to_mozilla_format_internal jar =
305
+
let buffer = Buffer.create 1024 in
306
+
Buffer.add_string buffer "# Netscape HTTP Cookie File\n";
307
+
Buffer.add_string buffer "# This is a generated file! Do not edit.\n\n";
311
+
let include_subdomains =
312
+
if String.starts_with ~prefix:"." (domain cookie) then "TRUE" else "FALSE"
314
+
let secure_flag = if secure cookie then "TRUE" else "FALSE" in
316
+
match expires cookie with
317
+
| None -> "0" (* Session cookie *)
319
+
let epoch = Ptime.to_float_s t |> int_of_float |> string_of_int in
323
+
Buffer.add_string buffer
324
+
(Printf.sprintf "%s\t%s\t%s\t%s\t%s\t%s\t%s\n" (domain cookie)
325
+
include_subdomains (path cookie) secure_flag expires_str (name cookie)
329
+
Buffer.contents buffer
331
+
let to_mozilla_format jar =
332
+
Eio.Mutex.lock jar.mutex;
333
+
let result = to_mozilla_format_internal jar in
334
+
Eio.Mutex.unlock jar.mutex;
337
+
let from_mozilla_format content =
338
+
Log.debug (fun m -> m "Parsing Mozilla format cookies");
339
+
let jar = create () in
341
+
let lines = String.split_on_char '\n' content in
344
+
let line = String.trim line in
345
+
if line <> "" && not (String.starts_with ~prefix:"#" line) then
346
+
match String.split_on_char '\t' line with
347
+
| [ domain; _include_subdomains; path; secure; expires; name; value ] ->
349
+
Ptime.of_float_s (Unix.time ())
350
+
|> Option.value ~default:Ptime.epoch
353
+
let exp_int = try int_of_string expires with _ -> 0 in
354
+
if exp_int = 0 then None
355
+
else Ptime.of_float_s (float_of_int exp_int)
359
+
make ~domain ~path ~name ~value
360
+
~secure:(secure = "TRUE") ~http_only:false
361
+
?expires ?same_site:None
362
+
~creation_time:now ~last_access:now ()
364
+
add_cookie jar cookie;
365
+
Log.debug (fun m -> m "Loaded cookie: %s=%s" name value)
366
+
| _ -> Log.warn (fun m -> m "Invalid cookie line: %s" line))
369
+
Log.info (fun m -> m "Loaded %d cookies" (List.length jar.cookies));
372
+
(** {1 File Operations} *)
375
+
Log.info (fun m -> m "Loading cookies from %a" Eio.Path.pp path);
378
+
let content = Eio.Path.load path in
379
+
from_mozilla_format content
382
+
Log.info (fun m -> m "Cookie file not found, creating empty jar");
385
+
Log.err (fun m -> m "Failed to load cookies: %s" (Printexc.to_string exn));
388
+
let save path jar =
390
+
m "Saving %d cookies to %a" (List.length jar.cookies) Eio.Path.pp path);
392
+
let content = to_mozilla_format jar in
395
+
Eio.Path.save ~create:(`Or_truncate 0o600) path content;
396
+
Log.debug (fun m -> m "Cookies saved successfully")
398
+
Log.err (fun m -> m "Failed to save cookies: %s" (Printexc.to_string exn))
anil.recoil.org