···
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) ()
87
+
let time, _tz_offset, _tz_string =
88
+
Ptime.of_rfc3339 attr_value |> Result.get_ok
90
+
make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
91
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
92
+
~expires:time ?same_site:(same_site cookie)
93
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
95
+
Log.debug (fun m -> m "Failed to parse expires: %s" attr_value);
99
+
let seconds = int_of_string attr_value in
100
+
let now = Unix.time () in
101
+
let expires = Ptime.of_float_s (now +. float_of_int seconds) in
102
+
make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
103
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
104
+
?expires ?same_site:(same_site cookie)
105
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
107
+
| "secure" -> make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
108
+
~value:(value cookie) ~secure:true ~http_only:(http_only cookie)
109
+
?expires:(expires cookie) ?same_site:(same_site cookie)
110
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
111
+
| "httponly" -> make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
112
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:true
113
+
?expires:(expires cookie) ?same_site:(same_site cookie)
114
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
116
+
let same_site_val =
117
+
match String.lowercase_ascii attr_value with
118
+
| "strict" -> Some `Strict
119
+
| "lax" -> Some `Lax
120
+
| "none" -> Some `None
123
+
make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
124
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
125
+
?expires:(expires cookie) ?same_site:same_site_val
126
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
129
+
let rec parse_set_cookie ~domain:request_domain ~path:request_path header_value =
130
+
Log.debug (fun m -> m "Parsing Set-Cookie: %s" header_value);
132
+
(* Split into attributes *)
133
+
let parts = String.split_on_char ';' header_value |> List.map String.trim in
137
+
| name_value :: attrs -> (
138
+
(* Parse name=value *)
139
+
match String.index_opt name_value '=' with
142
+
let name = String.sub name_value 0 eq_pos |> String.trim in
144
+
String.sub name_value (eq_pos + 1)
145
+
(String.length name_value - eq_pos - 1)
150
+
Ptime.of_float_s (Unix.time ()) |> Option.value ~default:Ptime.epoch
153
+
make ~domain:request_domain ~path:request_path ~name ~value:cookie_value ~secure:false ~http_only:false
154
+
?expires:None ?same_site:None ~creation_time:now ~last_access:now ()
157
+
(* Parse attributes *)
160
+
(fun cookie attr ->
161
+
match String.index_opt attr '=' with
162
+
| None -> parse_cookie_attribute attr "" cookie
164
+
let attr_name = String.sub attr 0 eq |> String.trim in
166
+
String.sub attr (eq + 1) (String.length attr - eq - 1)
169
+
parse_cookie_attribute attr_name attr_value cookie)
173
+
Log.debug (fun m -> m "Parsed cookie: %a" pp cookie);
176
+
and make_cookie_header cookies =
178
+
|> List.map (fun c -> Printf.sprintf "%s=%s" (name c) (value c))
179
+
|> String.concat "; "
181
+
(** {1 Pretty Printing} *)
183
+
and pp_same_site ppf = function
184
+
| `Strict -> Format.pp_print_string ppf "Strict"
185
+
| `Lax -> Format.pp_print_string ppf "Lax"
186
+
| `None -> Format.pp_print_string ppf "None"
188
+
and pp ppf cookie =
190
+
"@[<hov 2>{ name=%S;@ value=%S;@ domain=%S;@ path=%S;@ secure=%b;@ \
191
+
http_only=%b;@ expires=%a;@ same_site=%a }@]"
192
+
(name cookie) (value cookie) (domain cookie) (path cookie) (secure cookie)
194
+
(Format.pp_print_option Ptime.pp)
196
+
(Format.pp_print_option pp_same_site)
199
+
let pp_jar ppf jar =
200
+
Eio.Mutex.lock jar.mutex;
201
+
let cookies = jar.cookies in
202
+
Eio.Mutex.unlock jar.mutex;
204
+
Format.fprintf ppf "@[<v>CookieJar with %d cookies:@," (List.length cookies);
205
+
List.iter (fun cookie -> Format.fprintf ppf " %a@," pp cookie) cookies;
206
+
Format.fprintf ppf "@]"
208
+
(** {1 Cookie Management} *)
210
+
let add_cookie jar cookie =
211
+
Log.debug (fun m ->
212
+
m "Adding cookie: %s=%s for domain %s" (name cookie) (value cookie)
215
+
Eio.Mutex.lock jar.mutex;
216
+
(* Remove existing cookie with same name, domain, and path *)
221
+
(name c = name cookie && domain c = domain cookie
222
+
&& path c = path cookie))
224
+
jar.cookies <- cookie :: jar.cookies;
225
+
Eio.Mutex.unlock jar.mutex
227
+
let get_cookies jar ~domain:request_domain ~path:request_path ~is_secure =
228
+
Log.debug (fun m ->
229
+
m "Getting cookies for domain=%s path=%s secure=%b" request_domain request_path is_secure);
231
+
Eio.Mutex.lock jar.mutex;
235
+
domain_matches (domain cookie) request_domain
236
+
&& path_matches (path cookie) request_path
237
+
&& ((not (secure cookie)) || is_secure))
241
+
(* Update last access time *)
243
+
Ptime.of_float_s (Unix.time ()) |> Option.value ~default:Ptime.epoch
248
+
if List.memq c applicable then
249
+
make ~domain:(domain c) ~path:(path c) ~name:(name c) ~value:(value c)
250
+
~secure:(secure c) ~http_only:(http_only c) ?expires:(expires c)
251
+
?same_site:(same_site c) ~creation_time:(creation_time c) ~last_access:now ()
255
+
jar.cookies <- updated;
256
+
Eio.Mutex.unlock jar.mutex;
258
+
Log.debug (fun m -> m "Found %d applicable cookies" (List.length applicable));
262
+
Log.info (fun m -> m "Clearing all cookies");
263
+
Eio.Mutex.lock jar.mutex;
265
+
Eio.Mutex.unlock jar.mutex
267
+
let clear_expired jar ~clock =
268
+
Eio.Mutex.lock jar.mutex;
269
+
let before_count = List.length jar.cookies in
270
+
jar.cookies <- List.filter (fun c -> not (is_expired c clock)) jar.cookies;
271
+
let removed = before_count - List.length jar.cookies in
272
+
Eio.Mutex.unlock jar.mutex;
273
+
Log.info (fun m -> m "Cleared %d expired cookies" removed)
275
+
let clear_session_cookies jar =
276
+
Eio.Mutex.lock jar.mutex;
277
+
let before_count = List.length jar.cookies in
278
+
jar.cookies <- List.filter (fun c -> expires c <> None) jar.cookies;
279
+
let removed = before_count - List.length jar.cookies in
280
+
Eio.Mutex.unlock jar.mutex;
281
+
Log.info (fun m -> m "Cleared %d session cookies" removed)
284
+
Eio.Mutex.lock jar.mutex;
285
+
let n = List.length jar.cookies in
286
+
Eio.Mutex.unlock jar.mutex;
289
+
let get_all_cookies jar =
290
+
Eio.Mutex.lock jar.mutex;
291
+
let cookies = jar.cookies in
292
+
Eio.Mutex.unlock jar.mutex;
296
+
Eio.Mutex.lock jar.mutex;
297
+
let empty = jar.cookies = [] in
298
+
Eio.Mutex.unlock jar.mutex;
301
+
(** {1 Mozilla Format} *)
303
+
let to_mozilla_format_internal jar =
304
+
let buffer = Buffer.create 1024 in
305
+
Buffer.add_string buffer "# Netscape HTTP Cookie File\n";
306
+
Buffer.add_string buffer "# This is a generated file! Do not edit.\n\n";
310
+
let include_subdomains =
311
+
if String.starts_with ~prefix:"." (domain cookie) then "TRUE" else "FALSE"
313
+
let secure_flag = if secure cookie then "TRUE" else "FALSE" in
315
+
match expires cookie with
316
+
| None -> "0" (* Session cookie *)
318
+
let epoch = Ptime.to_float_s t |> int_of_float |> string_of_int in
322
+
Buffer.add_string buffer
323
+
(Printf.sprintf "%s\t%s\t%s\t%s\t%s\t%s\t%s\n" (domain cookie)
324
+
include_subdomains (path cookie) secure_flag expires_str (name cookie)
328
+
Buffer.contents buffer
330
+
let to_mozilla_format jar =
331
+
Eio.Mutex.lock jar.mutex;
332
+
let result = to_mozilla_format_internal jar in
333
+
Eio.Mutex.unlock jar.mutex;
336
+
let from_mozilla_format content =
337
+
Log.debug (fun m -> m "Parsing Mozilla format cookies");
338
+
let jar = create () in
340
+
let lines = String.split_on_char '\n' content in
343
+
let line = String.trim line in
344
+
if line <> "" && not (String.starts_with ~prefix:"#" line) then
345
+
match String.split_on_char '\t' line with
346
+
| [ domain; _include_subdomains; path; secure; expires; name; value ] ->
348
+
Ptime.of_float_s (Unix.time ())
349
+
|> Option.value ~default:Ptime.epoch
352
+
let exp_int = try int_of_string expires with _ -> 0 in
353
+
if exp_int = 0 then None
354
+
else Ptime.of_float_s (float_of_int exp_int)
358
+
make ~domain ~path ~name ~value
359
+
~secure:(secure = "TRUE") ~http_only:false
360
+
?expires ?same_site:None
361
+
~creation_time:now ~last_access:now ()
363
+
add_cookie jar cookie;
364
+
Log.debug (fun m -> m "Loaded cookie: %s=%s" name value)
365
+
| _ -> Log.warn (fun m -> m "Invalid cookie line: %s" line))
368
+
Log.info (fun m -> m "Loaded %d cookies" (List.length jar.cookies));
371
+
(** {1 File Operations} *)
374
+
Log.info (fun m -> m "Loading cookies from %a" Eio.Path.pp path);
377
+
let content = Eio.Path.load path in
378
+
from_mozilla_format content
381
+
Log.info (fun m -> m "Cookie file not found, creating empty jar");
384
+
Log.err (fun m -> m "Failed to load cookies: %s" (Printexc.to_string exn));
387
+
let save path jar =
389
+
m "Saving %d cookies to %a" (List.length jar.cookies) Eio.Path.pp path);
391
+
let content = to_mozilla_format jar in
394
+
Eio.Path.save ~create:(`Or_truncate 0o600) path content;
395
+
Log.debug (fun m -> m "Cookies saved successfully")
397
+
Log.err (fun m -> m "Failed to save cookies: %s" (Printexc.to_string exn))
anil.recoil.org