···
-
let src = Logs.Src.create "requests.cookie_jar" ~doc:"HTTP Cookie Jar"
-
module Log = (val Logs.src_log src : Logs.LOG)
-
(** Cookie same-site policy *)
-
type same_site = [`Strict | `Lax | `None]
-
expires : Ptime.t option;
-
same_site : same_site option;
-
creation_time : Ptime.t;
-
(** Cookie jar for storing and managing cookies *)
-
mutable cookies : cookie list;
-
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 = String.sub cookie_domain 1 (String.length cookie_domain - 1) in
-
request_domain = domain ||
-
String.ends_with ~suffix:("." ^ domain) request_domain
-
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 *)
-
let now = Ptime.of_float_s (Eio.Time.now clock) |> Option.value ~default:(Ptime.epoch) in
-
Ptime.compare now exp_time > 0
-
(** {1 Cookie Parsing} *)
-
let parse_cookie_attribute ~url:_ attr value cookie =
-
let attr_lower = String.lowercase_ascii attr in
-
| "domain" -> { cookie with domain = value }
-
| "path" -> { cookie with path = value }
-
(* Parse various date formats *)
-
let time, _tz_offset, _tz_string = Ptime.of_rfc3339 value |> Result.get_ok in
-
{ cookie with expires = Some time }
-
Log.debug (fun m -> m "Failed to parse expires: %s" value);
-
let seconds = int_of_string value in
-
let now = Unix.time () in
-
let expires = Ptime.of_float_s (now +. float_of_int seconds) in
-
{ cookie with expires }
-
| "secure" -> { cookie with secure = true }
-
| "httponly" -> { cookie with http_only = true }
-
let same_site = match String.lowercase_ascii value with
-
| "strict" -> Some `Strict
-
{ cookie with same_site }
-
let rec parse_set_cookie ~url value =
-
Log.debug (fun m -> m "Parsing Set-Cookie: %s" value);
-
let uri = Uri.of_string url in
-
let default_domain = Uri.host_with_default ~default:"localhost" uri in
-
let p = Uri.path uri in
-
let last_slash = String.rindex_opt p '/' in
-
| Some i -> String.sub p 0 (i + 1)
-
(* Split into attributes *)
-
let parts = String.split_on_char ';' 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
-
let value = String.sub name_value (eq_pos + 1)
-
(String.length name_value - eq_pos - 1) |> String.trim in
-
let now = Ptime.of_float_s (Unix.time ()) |> Option.value ~default:Ptime.epoch in
-
domain = default_domain;
-
let cookie = List.fold_left (fun cookie attr ->
-
match String.index_opt attr '=' with
-
| None -> parse_cookie_attribute ~url attr "" cookie
-
let attr_name = String.sub attr 0 eq |> String.trim in
-
let attr_value = String.sub attr (eq + 1)
-
(String.length attr - eq - 1) |> String.trim in
-
parse_cookie_attribute ~url attr_name attr_value cookie
-
Log.debug (fun m -> m "Parsed cookie: %a" pp_cookie cookie);
-
and make_cookie_header cookies =
-
|> List.map (fun c -> Printf.sprintf "%s=%s" c.name c.value)
-
(** {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"
-
and pp_cookie ppf cookie =
-
Format.fprintf ppf "@[<hov 2>{ name=%S;@ value=%S;@ domain=%S;@ path=%S;@ \
-
secure=%b;@ http_only=%b;@ expires=%a;@ same_site=%a }@]"
-
(Format.pp_print_option Ptime.pp) cookie.expires
-
(Format.pp_print_option pp_same_site) cookie.same_site
-
Eio.Mutex.lock t.mutex;
-
let cookies = t.cookies in
-
Eio.Mutex.unlock t.mutex;
-
Format.fprintf ppf "@[<v>CookieJar with %d cookies:@," (List.length cookies);
-
List.iter (fun cookie ->
-
Format.fprintf ppf " %a@," pp_cookie cookie
-
Format.fprintf ppf "@]"
-
(** {1 Cookie Management} *)
-
let add_cookie t cookie =
-
Log.debug (fun m -> m "Adding cookie: %s=%s for domain %s"
-
cookie.name cookie.value cookie.domain);
-
Eio.Mutex.lock t.mutex;
-
(* Remove existing cookie with same name, domain, and path *)
-
t.cookies <- List.filter (fun c ->
-
not (c.name = cookie.name && c.domain = cookie.domain && c.path = cookie.path)
-
t.cookies <- cookie :: t.cookies;
-
Eio.Mutex.unlock t.mutex
-
let extract_from_headers t ~url headers =
-
Log.debug (fun m -> m "Extracting cookies from headers for URL: %s" url);
-
let set_cookie_values = Headers.get_multi "set-cookie" headers in
-
List.iter (fun value ->
-
match parse_set_cookie ~url value with
-
| Some cookie -> add_cookie t cookie
-
| None -> Log.warn (fun m -> m "Failed to parse Set-Cookie header: %s" value)
-
let get_cookies t ~url =
-
let uri = Uri.of_string url in
-
let domain = Uri.host_with_default ~default:"localhost" uri in
-
let path = Uri.path uri in
-
let is_secure = Uri.scheme uri = Some "https" in
-
Log.debug (fun m -> m "Getting cookies for domain=%s path=%s secure=%b"
-
domain path is_secure);
-
Eio.Mutex.lock t.mutex;
-
let applicable = List.filter (fun cookie ->
-
domain_matches cookie.domain domain &&
-
path_matches cookie.path path &&
-
(not cookie.secure || is_secure)
-
(* Update last access time *)
-
let now = Ptime.of_float_s (Unix.time ()) |> Option.value ~default:Ptime.epoch in
-
let updated = List.map (fun c ->
-
if List.memq c applicable then
-
{ c with last_access = now }
-
Eio.Mutex.unlock t.mutex;
-
Log.debug (fun m -> m "Found %d applicable cookies" (List.length applicable));
-
let add_to_headers t ~url headers =
-
let cookies = get_cookies t ~url in
-
if cookies = [] then headers
-
let cookie_header = make_cookie_header cookies in
-
Log.debug (fun m -> m "Adding Cookie header: %s" cookie_header);
-
Headers.add "cookie" cookie_header headers
-
Log.info (fun m -> m "Clearing all cookies");
-
Eio.Mutex.lock t.mutex;
-
Eio.Mutex.unlock t.mutex
-
let clear_expired t ~clock =
-
Eio.Mutex.lock t.mutex;
-
let before_count = List.length t.cookies in
-
t.cookies <- List.filter (fun c -> not (is_expired c clock)) t.cookies;
-
let removed = before_count - List.length t.cookies in
-
Eio.Mutex.unlock t.mutex;
-
Log.info (fun m -> m "Cleared %d expired cookies" removed)
-
let clear_session_cookies t =
-
Eio.Mutex.lock t.mutex;
-
let before_count = List.length t.cookies in
-
t.cookies <- List.filter (fun c -> c.expires <> None) t.cookies;
-
let removed = before_count - List.length t.cookies in
-
Eio.Mutex.unlock t.mutex;
-
Log.info (fun m -> m "Cleared %d session cookies" removed)
-
Eio.Mutex.lock t.mutex;
-
let n = List.length t.cookies in
-
Eio.Mutex.unlock t.mutex;
-
(** {1 Mozilla Format} *)
-
let to_mozilla_format_internal t =
-
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";
-
List.iter (fun cookie ->
-
let include_subdomains =
-
if String.starts_with ~prefix:"." cookie.domain then "TRUE" else "FALSE" in
-
let secure = if cookie.secure then "TRUE" else "FALSE" in
-
let expires = match cookie.expires 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"
-
let to_mozilla_format t =
-
Eio.Mutex.lock t.mutex;
-
let result = to_mozilla_format_internal t in
-
Eio.Mutex.unlock t.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] ->
-
let now = Ptime.of_float_s (Unix.time ()) |> Option.value ~default:Ptime.epoch in
-
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)
-
secure = (secure = "TRUE");
-
http_only = false; (* Not stored in Mozilla format *)
-
same_site = None; (* Not stored in Mozilla format *)
-
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} *)
-
(** Get cookie file path - uses XDG data directory or provided path *)
-
let get_cookie_file ?xdg ?path () =
-
(* Use XDG data directory for cookies *)
-
let data_dir = Xdge.data_dir xdg_ctx in
-
Eio.Path.(data_dir / "cookies.txt")
-
failwith "Cookie_jar: either xdg or path must be provided"
-
let load ?xdg ?path () =
-
let cookie_file = get_cookie_file ?xdg ?path () in
-
Log.info (fun m -> m "Loading cookies from %a" Eio.Path.pp cookie_file);
-
let content = Eio.Path.load cookie_file 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));
-
let save ?xdg ?path t =
-
let cookie_file = get_cookie_file ?xdg ?path () in
-
Log.info (fun m -> m "Saving %d cookies to %a" (List.length t.cookies) Eio.Path.pp cookie_file);
-
let content = to_mozilla_format t in
-
Eio.Path.save ~create:(`Or_truncate 0o600) cookie_file 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