···
+
let src = Logs.Src.create "cookeio" ~doc:"Cookie management"
+
module Log = (val Logs.src_log src : Logs.LOG)
+
type same_site = [ `Strict | `Lax | `None ]
+
(** Cookie same-site policy *)
+
expires : Ptime.t option;
+
same_site : same_site option;
+
creation_time : Ptime.t;
+
type jar = { mutable cookies : t list; mutex : Eio.Mutex.t }
+
(** Cookie jar for storing and managing cookies *)
+
(** {1 Cookie Accessors} *)
+
let domain cookie = cookie.domain
+
let path cookie = cookie.path
+
let name cookie = cookie.name
+
let value cookie = cookie.value
+
let secure cookie = cookie.secure
+
let http_only cookie = cookie.http_only
+
let expires cookie = cookie.expires
+
let same_site cookie = cookie.same_site
+
let creation_time cookie = cookie.creation_time
+
let last_access cookie = cookie.last_access
+
let make ~domain ~path ~name ~value ?(secure = false) ?(http_only = false)
+
?expires ?same_site ~creation_time ~last_access () =
+
{ domain; path; name; value; secure; http_only; expires; same_site; creation_time; last_access }
+
(** {1 Cookie Jar Creation} *)
+
Log.debug (fun m -> m "Creating new empty cookie jar");
+
{ cookies = []; mutex = Eio.Mutex.create () }
+
(** {1 Cookie Matching Helpers} *)
+
let domain_matches cookie_domain request_domain =
+
(* Cookie domain .example.com matches example.com and sub.example.com *)
+
if String.starts_with ~prefix:"." cookie_domain then
+
let domain_suffix = String.sub cookie_domain 1 (String.length cookie_domain - 1) in
+
request_domain = domain_suffix
+
|| String.ends_with ~suffix:("." ^ domain_suffix) request_domain
+
else cookie_domain = request_domain
+
let path_matches cookie_path request_path =
+
(* Cookie path /foo matches /foo, /foo/, /foo/bar *)
+
String.starts_with ~prefix:cookie_path request_path
+
let is_expired cookie clock =
+
match cookie.expires with
+
| None -> false (* Session cookie *)
+
Ptime.of_float_s (Eio.Time.now clock)
+
|> Option.value ~default:Ptime.epoch
+
Ptime.compare now exp_time > 0
+
(** {1 Cookie Parsing} *)
+
let parse_cookie_attribute attr attr_value cookie =
+
let attr_lower = String.lowercase_ascii attr in
+
| "domain" -> make ~domain:attr_value ~path:(path cookie) ~name:(name cookie)
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
+
?expires:(expires cookie) ?same_site:(same_site cookie)
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
+
| "path" -> make ~domain:(domain cookie) ~path:attr_value ~name:(name cookie)
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
+
?expires:(expires cookie) ?same_site:(same_site cookie)
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
+
let time, _tz_offset, _tz_string =
+
Ptime.of_rfc3339 attr_value |> Result.get_ok
+
make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
+
~expires:time ?same_site:(same_site cookie)
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
+
Log.debug (fun m -> m "Failed to parse expires: %s" attr_value);
+
let seconds = int_of_string attr_value in
+
let now = Unix.time () in
+
let expires = Ptime.of_float_s (now +. float_of_int seconds) in
+
make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
+
?expires ?same_site:(same_site cookie)
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
+
| "secure" -> make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
+
~value:(value cookie) ~secure:true ~http_only:(http_only cookie)
+
?expires:(expires cookie) ?same_site:(same_site cookie)
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
+
| "httponly" -> make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:true
+
?expires:(expires cookie) ?same_site:(same_site cookie)
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
+
match String.lowercase_ascii attr_value with
+
| "strict" -> Some `Strict
+
make ~domain:(domain cookie) ~path:(path cookie) ~name:(name cookie)
+
~value:(value cookie) ~secure:(secure cookie) ~http_only:(http_only cookie)
+
?expires:(expires cookie) ?same_site:same_site_val
+
~creation_time:(creation_time cookie) ~last_access:(last_access cookie) ()
+
let rec parse_set_cookie ~domain:request_domain ~path:request_path header_value =
+
Log.debug (fun m -> m "Parsing Set-Cookie: %s" header_value);
+
(* Split into attributes *)
+
let parts = String.split_on_char ';' header_value |> List.map String.trim in
+
| name_value :: attrs -> (
+
match String.index_opt name_value '=' with
+
let name = String.sub name_value 0 eq_pos |> String.trim in
+
String.sub name_value (eq_pos + 1)
+
(String.length name_value - eq_pos - 1)
+
Ptime.of_float_s (Unix.time ()) |> Option.value ~default:Ptime.epoch
+
make ~domain:request_domain ~path:request_path ~name ~value:cookie_value ~secure:false ~http_only:false
+
?expires:None ?same_site:None ~creation_time:now ~last_access:now ()
+
match String.index_opt attr '=' with
+
| None -> parse_cookie_attribute attr "" cookie
+
let attr_name = String.sub attr 0 eq |> String.trim in
+
String.sub attr (eq + 1) (String.length attr - eq - 1)
+
parse_cookie_attribute attr_name attr_value cookie)
+
Log.debug (fun m -> m "Parsed cookie: %a" pp cookie);
+
and make_cookie_header cookies =
+
|> List.map (fun c -> Printf.sprintf "%s=%s" (name c) (value c))
+
(** {1 Pretty Printing} *)
+
and pp_same_site ppf = function
+
| `Strict -> Format.pp_print_string ppf "Strict"
+
| `Lax -> Format.pp_print_string ppf "Lax"
+
| `None -> Format.pp_print_string ppf "None"
+
"@[<hov 2>{ name=%S;@ value=%S;@ domain=%S;@ path=%S;@ secure=%b;@ \
+
http_only=%b;@ expires=%a;@ same_site=%a }@]"
+
(name cookie) (value cookie) (domain cookie) (path cookie) (secure cookie)
+
(Format.pp_print_option Ptime.pp)
+
(Format.pp_print_option pp_same_site)
+
Eio.Mutex.lock jar.mutex;
+
let cookies = jar.cookies in
+
Eio.Mutex.unlock jar.mutex;
+
Format.fprintf ppf "@[<v>CookieJar with %d cookies:@," (List.length cookies);
+
List.iter (fun cookie -> Format.fprintf ppf " %a@," pp cookie) cookies;
+
Format.fprintf ppf "@]"
+
(** {1 Cookie Management} *)
+
let add_cookie jar cookie =
+
m "Adding cookie: %s=%s for domain %s" (name cookie) (value cookie)
+
Eio.Mutex.lock jar.mutex;
+
(* Remove existing cookie with same name, domain, and path *)
+
(name c = name cookie && domain c = domain cookie
+
&& path c = path cookie))
+
jar.cookies <- cookie :: jar.cookies;
+
Eio.Mutex.unlock jar.mutex
+
let get_cookies jar ~domain:request_domain ~path:request_path ~is_secure =
+
m "Getting cookies for domain=%s path=%s secure=%b" request_domain request_path is_secure);
+
Eio.Mutex.lock jar.mutex;
+
domain_matches (domain cookie) request_domain
+
&& path_matches (path cookie) request_path
+
&& ((not (secure cookie)) || is_secure))
+
(* Update last access time *)
+
Ptime.of_float_s (Unix.time ()) |> Option.value ~default:Ptime.epoch
+
if List.memq c applicable then
+
make ~domain:(domain c) ~path:(path c) ~name:(name c) ~value:(value c)
+
~secure:(secure c) ~http_only:(http_only c) ?expires:(expires c)
+
?same_site:(same_site c) ~creation_time:(creation_time c) ~last_access:now ()
+
jar.cookies <- updated;
+
Eio.Mutex.unlock jar.mutex;
+
Log.debug (fun m -> m "Found %d applicable cookies" (List.length applicable));
+
Log.info (fun m -> m "Clearing all cookies");
+
Eio.Mutex.lock jar.mutex;
+
Eio.Mutex.unlock jar.mutex
+
let clear_expired jar ~clock =
+
Eio.Mutex.lock jar.mutex;
+
let before_count = List.length jar.cookies in
+
jar.cookies <- List.filter (fun c -> not (is_expired c clock)) jar.cookies;
+
let removed = before_count - List.length jar.cookies in
+
Eio.Mutex.unlock jar.mutex;
+
Log.info (fun m -> m "Cleared %d expired cookies" removed)
+
let clear_session_cookies jar =
+
Eio.Mutex.lock jar.mutex;
+
let before_count = List.length jar.cookies in
+
jar.cookies <- List.filter (fun c -> expires c <> None) jar.cookies;
+
let removed = before_count - List.length jar.cookies in
+
Eio.Mutex.unlock jar.mutex;
+
Log.info (fun m -> m "Cleared %d session cookies" removed)
+
Eio.Mutex.lock jar.mutex;
+
let n = List.length jar.cookies in
+
Eio.Mutex.unlock jar.mutex;
+
let get_all_cookies jar =
+
Eio.Mutex.lock jar.mutex;
+
let cookies = jar.cookies in
+
Eio.Mutex.unlock jar.mutex;
+
Eio.Mutex.lock jar.mutex;
+
let empty = jar.cookies = [] in
+
Eio.Mutex.unlock jar.mutex;
+
(** {1 Mozilla Format} *)
+
let to_mozilla_format_internal jar =
+
let buffer = Buffer.create 1024 in
+
Buffer.add_string buffer "# Netscape HTTP Cookie File\n";
+
Buffer.add_string buffer "# This is a generated file! Do not edit.\n\n";
+
let include_subdomains =
+
if String.starts_with ~prefix:"." (domain cookie) then "TRUE" else "FALSE"
+
let secure_flag = if secure cookie then "TRUE" else "FALSE" in
+
match expires cookie with
+
| None -> "0" (* Session cookie *)
+
let epoch = Ptime.to_float_s t |> int_of_float |> string_of_int in
+
Buffer.add_string buffer
+
(Printf.sprintf "%s\t%s\t%s\t%s\t%s\t%s\t%s\n" (domain cookie)
+
include_subdomains (path cookie) secure_flag expires_str (name cookie)
+
let to_mozilla_format jar =
+
Eio.Mutex.lock jar.mutex;
+
let result = to_mozilla_format_internal jar in
+
Eio.Mutex.unlock jar.mutex;
+
let from_mozilla_format content =
+
Log.debug (fun m -> m "Parsing Mozilla format cookies");
+
let lines = String.split_on_char '\n' content in
+
let line = String.trim line in
+
if line <> "" && not (String.starts_with ~prefix:"#" line) then
+
match String.split_on_char '\t' line with
+
| [ domain; _include_subdomains; path; secure; expires; name; value ] ->
+
Ptime.of_float_s (Unix.time ())
+
|> Option.value ~default:Ptime.epoch
+
let exp_int = try int_of_string expires with _ -> 0 in
+
if exp_int = 0 then None
+
else Ptime.of_float_s (float_of_int exp_int)
+
make ~domain ~path ~name ~value
+
~secure:(secure = "TRUE") ~http_only:false
+
?expires ?same_site:None
+
~creation_time:now ~last_access:now ()
+
Log.debug (fun m -> m "Loaded cookie: %s=%s" name value)
+
| _ -> Log.warn (fun m -> m "Invalid cookie line: %s" line))
+
Log.info (fun m -> m "Loaded %d cookies" (List.length jar.cookies));
+
(** {1 File Operations} *)
+
Log.info (fun m -> m "Loading cookies from %a" Eio.Path.pp path);
+
let content = Eio.Path.load path in
+
from_mozilla_format content
+
Log.info (fun m -> m "Cookie file not found, creating empty jar");
+
Log.err (fun m -> m "Failed to load cookies: %s" (Printexc.to_string exn));
+
m "Saving %d cookies to %a" (List.length jar.cookies) Eio.Path.pp path);
+
let content = to_mozilla_format jar in
+
Eio.Path.save ~create:(`Or_truncate 0o600) path content;
+
Log.debug (fun m -> m "Cookies saved successfully")
+
Log.err (fun m -> m "Failed to save cookies: %s" (Printexc.to_string exn))
anil.recoil.org