···224224 let buf_read = Http_read.of_flow flow ~max_size:max_int in
225225226226 try
227227- let status = Http_read.status_line buf_read in
227227+ let (_version, status) = Http_read.status_line buf_read in
228228229229 Log.debug (fun m -> m "Received response status %d while waiting for 100 Continue" status);
230230
+180
lib/link.ml
···11+(*---------------------------------------------------------------------------
22+ Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
33+ SPDX-License-Identifier: ISC
44+ ---------------------------------------------------------------------------*)
55+66+(** HTTP Link header parsing per RFC 8288
77+88+ This module parses Link headers for pagination, API discovery, and
99+ relationship navigation. Per Recommendation #19.
1010+1111+ Link header example:
1212+ {[
1313+ Link: <https://api.example.com/users?page=2>; rel="next",
1414+ <https://api.example.com/users?page=5>; rel="last"
1515+ ]}
1616+*)
1717+1818+let src = Logs.Src.create "requests.link" ~doc:"HTTP Link header parsing"
1919+module Log = (val Logs.src_log src : Logs.LOG)
2020+2121+(** A parsed Link header entry *)
2222+type t = {
2323+ uri : string; (** The target URI *)
2424+ rel : string option; (** The relation type (e.g., "next", "prev", "last") *)
2525+ title : string option; (** Human-readable title *)
2626+ media_type : string option; (** Media type hint *)
2727+ hreflang : string option; (** Language hint *)
2828+ params : (string * string) list; (** Additional parameters *)
2929+}
3030+3131+let make ~uri ?rel ?title ?media_type ?hreflang ?(params=[]) () =
3232+ { uri; rel; title; media_type; hreflang; params }
3333+3434+let uri t = t.uri
3535+let rel t = t.rel
3636+let title t = t.title
3737+let media_type t = t.media_type
3838+let hreflang t = t.hreflang
3939+let params t = t.params
4040+4141+(** Parse a single link value from a Link header segment.
4242+ Format: <uri>; param1=value1; param2="value2" *)
4343+let parse_link_value str =
4444+ let str = String.trim str in
4545+4646+ (* Find the URI in angle brackets *)
4747+ if String.length str = 0 || str.[0] <> '<' then begin
4848+ Log.debug (fun m -> m "Invalid link value, missing '<': %s" str);
4949+ None
5050+ end else begin
5151+ match String.index_opt str '>' with
5252+ | None ->
5353+ Log.debug (fun m -> m "Invalid link value, missing '>': %s" str);
5454+ None
5555+ | Some close_idx ->
5656+ let uri = String.sub str 1 (close_idx - 1) in
5757+ let params_str =
5858+ if close_idx + 1 < String.length str then
5959+ String.sub str (close_idx + 1) (String.length str - close_idx - 1)
6060+ else ""
6161+ in
6262+6363+ (* Parse parameters *)
6464+ let params = String.split_on_char ';' params_str in
6565+ let parsed_params = List.filter_map (fun param ->
6666+ let param = String.trim param in
6767+ if param = "" then None
6868+ else begin
6969+ match String.index_opt param '=' with
7070+ | None -> None
7171+ | Some eq_idx ->
7272+ let key = String.trim (String.sub param 0 eq_idx) in
7373+ let value_raw = String.trim (String.sub param (eq_idx + 1) (String.length param - eq_idx - 1)) in
7474+ (* Remove quotes if present *)
7575+ let value =
7676+ if String.length value_raw >= 2 &&
7777+ value_raw.[0] = '"' &&
7878+ value_raw.[String.length value_raw - 1] = '"' then
7979+ String.sub value_raw 1 (String.length value_raw - 2)
8080+ else
8181+ value_raw
8282+ in
8383+ Some (String.lowercase_ascii key, value)
8484+ end
8585+ ) params in
8686+8787+ (* Extract known parameters *)
8888+ let rel = List.assoc_opt "rel" parsed_params in
8989+ let title = List.assoc_opt "title" parsed_params in
9090+ let media_type = List.assoc_opt "type" parsed_params in
9191+ let hreflang = List.assoc_opt "hreflang" parsed_params in
9292+9393+ (* Keep other params *)
9494+ let other_params = List.filter (fun (k, _) ->
9595+ not (List.mem k ["rel"; "title"; "type"; "hreflang"])
9696+ ) parsed_params in
9797+9898+ Log.debug (fun m -> m "Parsed link: uri=%s rel=%s"
9999+ uri (Option.value rel ~default:"<none>"));
100100+101101+ Some { uri; rel; title; media_type; hreflang; params = other_params }
102102+ end
103103+104104+(** Parse a complete Link header value (may contain multiple links) *)
105105+let parse header_value =
106106+ Log.debug (fun m -> m "Parsing Link header: %s" header_value);
107107+108108+ (* Split on commas, but be careful of commas inside quotes *)
109109+ let rec split_links str acc current in_quotes =
110110+ if String.length str = 0 then
111111+ let final = String.trim current in
112112+ if final = "" then List.rev acc else List.rev (final :: acc)
113113+ else
114114+ let c = str.[0] in
115115+ let rest = String.sub str 1 (String.length str - 1) in
116116+ if c = '"' then
117117+ split_links rest acc (current ^ String.make 1 c) (not in_quotes)
118118+ else if c = ',' && not in_quotes then
119119+ let trimmed = String.trim current in
120120+ if trimmed = "" then
121121+ split_links rest acc "" false
122122+ else
123123+ split_links rest (trimmed :: acc) "" false
124124+ else
125125+ split_links rest acc (current ^ String.make 1 c) in_quotes
126126+ in
127127+128128+ let link_strs = split_links header_value [] "" false in
129129+ List.filter_map parse_link_value link_strs
130130+131131+(** Parse Link header from response headers *)
132132+let from_headers headers =
133133+ match Headers.get "link" headers with
134134+ | None -> []
135135+ | Some value -> parse value
136136+137137+(** Find a link by relation type *)
138138+let find_rel rel links =
139139+ List.find_opt (fun l -> l.rel = Some rel) links
140140+141141+(** Find all links with a specific relation type *)
142142+let filter_rel rel links =
143143+ List.filter (fun l -> l.rel = Some rel) links
144144+145145+(** Get pagination links from headers.
146146+ Returns (first, prev, next, last) where each is optional. *)
147147+let pagination headers =
148148+ let links = from_headers headers in
149149+ let first = find_rel "first" links |> Option.map uri in
150150+ let prev = find_rel "prev" links |> Option.map uri in
151151+ let next = find_rel "next" links |> Option.map uri in
152152+ let last = find_rel "last" links |> Option.map uri in
153153+ (first, prev, next, last)
154154+155155+(** Check if there are more pages (next link exists) *)
156156+let has_next headers =
157157+ let links = from_headers headers in
158158+ Option.is_some (find_rel "next" links)
159159+160160+(** Get the next page URL if available *)
161161+let next_url headers =
162162+ let links = from_headers headers in
163163+ find_rel "next" links |> Option.map uri
164164+165165+(** Get the previous page URL if available *)
166166+let prev_url headers =
167167+ let links = from_headers headers in
168168+ find_rel "prev" links |> Option.map uri
169169+170170+(** Pretty-print a link *)
171171+let pp ppf link =
172172+ Format.fprintf ppf "<%s>" link.uri;
173173+ Option.iter (fun r -> Format.fprintf ppf "; rel=\"%s\"" r) link.rel;
174174+ Option.iter (fun t -> Format.fprintf ppf "; title=\"%s\"" t) link.title;
175175+ Option.iter (fun t -> Format.fprintf ppf "; type=\"%s\"" t) link.media_type;
176176+ Option.iter (fun h -> Format.fprintf ppf "; hreflang=\"%s\"" h) link.hreflang;
177177+ List.iter (fun (k, v) -> Format.fprintf ppf "; %s=\"%s\"" k v) link.params
178178+179179+let to_string link =
180180+ Format.asprintf "%a" pp link
+117
lib/link.mli
···11+(*---------------------------------------------------------------------------
22+ Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
33+ SPDX-License-Identifier: ISC
44+ ---------------------------------------------------------------------------*)
55+66+(** HTTP Link header parsing per RFC 8288
77+88+ This module parses Link headers commonly used for:
99+ - API pagination (rel="next", "prev", "first", "last")
1010+ - Resource discovery
1111+ - Relationship navigation
1212+1313+ Per Recommendation #19: Parse Link headers for pagination support.
1414+1515+ {2 Example: Following Pagination}
1616+ {[
1717+ let rec fetch_all_pages session url acc =
1818+ let response = Requests.get session url in
1919+ let data = Response.body response |> Eio.Flow.read_all in
2020+ let acc = data :: acc in
2121+ match Link.next_url (Response.headers response) with
2222+ | Some next -> fetch_all_pages session next acc
2323+ | None -> List.rev acc
2424+ ]}
2525+2626+ {2 Example: Getting All Pagination URLs}
2727+ {[
2828+ let response = Requests.get session "https://api.example.com/items" in
2929+ let (first, prev, next, last) = Link.pagination (Response.headers response) in
3030+ match next with
3131+ | Some url -> Printf.printf "Next page: %s\n" url
3232+ | None -> print_endline "No more pages"
3333+ ]}
3434+*)
3535+3636+(** A parsed Link header entry *)
3737+type t
3838+3939+(** {1 Constructors} *)
4040+4141+val make :
4242+ uri:string ->
4343+ ?rel:string ->
4444+ ?title:string ->
4545+ ?media_type:string ->
4646+ ?hreflang:string ->
4747+ ?params:(string * string) list ->
4848+ unit -> t
4949+(** Create a link value *)
5050+5151+(** {1 Accessors} *)
5252+5353+val uri : t -> string
5454+(** The target URI *)
5555+5656+val rel : t -> string option
5757+(** The relation type (e.g., "next", "prev", "last", "self") *)
5858+5959+val title : t -> string option
6060+(** Human-readable title *)
6161+6262+val media_type : t -> string option
6363+(** Media type hint (from "type" parameter) *)
6464+6565+val hreflang : t -> string option
6666+(** Language hint *)
6767+6868+val params : t -> (string * string) list
6969+(** Additional parameters not covered by standard accessors *)
7070+7171+(** {1 Parsing} *)
7272+7373+val parse : string -> t list
7474+(** Parse a Link header value into a list of links.
7575+ Handles multiple comma-separated links. *)
7676+7777+val from_headers : Headers.t -> t list
7878+(** Extract and parse Link header from response headers.
7979+ Returns empty list if no Link header present. *)
8080+8181+(** {1 Finding Links} *)
8282+8383+val find_rel : string -> t list -> t option
8484+(** Find the first link with a specific relation type *)
8585+8686+val filter_rel : string -> t list -> t list
8787+(** Find all links with a specific relation type *)
8888+8989+(** {1 Pagination Helpers} *)
9090+9191+val pagination : Headers.t -> string option * string option * string option * string option
9292+(** [pagination headers] extracts pagination links.
9393+ Returns [(first, prev, next, last)] where each is optional.
9494+9595+ Looks for links with rel="first", rel="prev", rel="next", rel="last". *)
9696+9797+val has_next : Headers.t -> bool
9898+(** Check if there are more pages (next link exists) *)
9999+100100+val next_url : Headers.t -> string option
101101+(** Get the next page URL if available *)
102102+103103+val prev_url : Headers.t -> string option
104104+(** Get the previous page URL if available *)
105105+106106+(** {1 Formatting} *)
107107+108108+val pp : Format.formatter -> t -> unit
109109+(** Pretty-print a link in Link header format *)
110110+111111+val to_string : t -> string
112112+(** Convert link to string representation *)
113113+114114+(** {1 Logging} *)
115115+116116+val src : Logs.Src.t
117117+(** Log source for link parsing operations *)
+145-18
lib/requests.ml
···2525module Response_limits = Response_limits
2626module Expect_continue = Expect_continue
2727module Version = Version
2828+module Link = Link
2929+module Timing = Timing
28302931(** Minimum TLS version configuration.
3032 Per Recommendation #6: Allow enforcing minimum TLS version. *)
···6365 xdg : Xdge.t option;
6466 auto_decompress : bool;
6567 expect_100_continue : Expect_continue.t; (** 100-continue configuration *)
6868+ base_url : string option; (** Per Recommendation #11: Base URL for relative paths *)
6969+ xsrf_cookie_name : string option; (** Per Recommendation #24: XSRF cookie name *)
7070+ xsrf_header_name : string; (** Per Recommendation #24: XSRF header name *)
66716772 (* Statistics - mutable but NOTE: when sessions are derived via record update
6873 syntax ({t with field = value}), these are copied not shared. Each derived
···95100 ?(auto_decompress = true)
96101 ?(expect_100_continue = true)
97102 ?(expect_100_continue_threshold = 1_048_576L) (* 1MB *)
103103+ ?base_url
104104+ ?(xsrf_cookie_name = Some "XSRF-TOKEN") (* Per Recommendation #24 *)
105105+ ?(xsrf_header_name = "X-XSRF-TOKEN")
98106 env =
99107100108 let clock = env#clock in
···188196 ()
189197 in
190198199199+ (* Normalize base_url: remove trailing slash for consistent path joining *)
200200+ let base_url = Option.map (fun url ->
201201+ if String.length url > 0 && url.[String.length url - 1] = '/' then
202202+ String.sub url 0 (String.length url - 1)
203203+ else url
204204+ ) base_url in
205205+191206 T {
192207 sw;
193208 clock;
···208223 xdg;
209224 auto_decompress;
210225 expect_100_continue = expect_100_config;
226226+ base_url;
227227+ xsrf_cookie_name;
228228+ xsrf_header_name;
211229 requests_made = 0;
212230 total_time = 0.0;
213231 retries_count = 0;
···282300 | None ->
283301 uri (* Relative URLs are OK - they will be resolved against current URL *)
284302303303+(** {1 URL Resolution and Path Templating}
304304+305305+ Per Recommendation #11: Base URL support with RFC 3986 resolution.
306306+ Per Recommendation #29: Path parameter templating. *)
307307+308308+(** Check if a URL is relative (no scheme) *)
309309+let is_relative_url url =
310310+ let uri = Uri.of_string url in
311311+ Option.is_none (Uri.scheme uri)
312312+313313+(** Resolve a URL against a base URL per RFC 3986 Section 5.
314314+ If the URL is already absolute, return it unchanged.
315315+ If base_url is None, return the original URL. *)
316316+let resolve_url ?base_url url =
317317+ match base_url with
318318+ | None -> url
319319+ | Some base ->
320320+ if is_relative_url url then begin
321321+ let base_uri = Uri.of_string base in
322322+ let rel_uri = Uri.of_string url in
323323+ let scheme = Uri.scheme base_uri |> Option.value ~default:"https" in
324324+ let resolved = Uri.resolve scheme base_uri rel_uri in
325325+ Log.debug (fun m -> m "Resolved relative URL %s against base %s -> %s"
326326+ url base (Uri.to_string resolved));
327327+ Uri.to_string resolved
328328+ end else
329329+ url (* Already absolute *)
330330+331331+(** Substitute path parameters in a URL template.
332332+ Per Recommendation #29 and RFC 6570 (simplified).
333333+ Template: "/users/{id}/posts/{post_id}"
334334+ Params: [("id", "123"); ("post_id", "456")]
335335+ Result: "/users/123/posts/456"
336336+ Values are automatically URL-encoded. *)
337337+let substitute_path_params url params =
338338+ List.fold_left (fun url (key, value) ->
339339+ let pattern = "{" ^ key ^ "}" in
340340+ let encoded_value = Uri.pct_encode value in
341341+ let rec replace s =
342342+ match String.split_on_char '{' s with
343343+ | [] -> ""
344344+ | [single] -> single
345345+ | before :: rest ->
346346+ let rest_str = String.concat "{" rest in
347347+ if String.length rest_str >= String.length key + 1 &&
348348+ String.sub rest_str 0 (String.length key) = key &&
349349+ rest_str.[String.length key] = '}' then
350350+ before ^ encoded_value ^ String.sub rest_str (String.length key + 1)
351351+ (String.length rest_str - String.length key - 1)
352352+ else
353353+ before ^ "{" ^ replace rest_str
354354+ in
355355+ if String.length pattern > 0 then replace url else url
356356+ ) url params
357357+358358+(** {1 XSRF Token Handling}
359359+360360+ Per Recommendation #24: Automatically inject XSRF tokens from cookies. *)
361361+362362+(** Extract XSRF token from cookies and add to headers if:
363363+ 1. xsrf_cookie_name is configured
364364+ 2. The cookie exists
365365+ 3. The request is same-origin (security) *)
366366+let apply_xsrf_token ~cookie_jar ~clock ~xsrf_cookie_name ~xsrf_header_name ~url headers =
367367+ match xsrf_cookie_name with
368368+ | None -> headers (* XSRF handling disabled *)
369369+ | Some cookie_name ->
370370+ let uri = Uri.of_string url in
371371+ let domain = Uri.host uri |> Option.value ~default:"" in
372372+ let path = Uri.path uri in
373373+ let is_secure = Uri.scheme uri = Some "https" in
374374+375375+ (* Get cookies for this domain *)
376376+ let cookies = Cookeio_jar.get_cookies cookie_jar ~clock
377377+ ~domain ~path ~is_secure in
378378+379379+ (* Find the XSRF token cookie *)
380380+ let xsrf_value = List.find_map (fun cookie ->
381381+ if Cookeio.name cookie = cookie_name then
382382+ Some (Cookeio.value cookie)
383383+ else
384384+ None
385385+ ) cookies in
386386+387387+ match xsrf_value with
388388+ | Some token ->
389389+ Log.debug (fun m -> m "Adding XSRF token header: %s" xsrf_header_name);
390390+ Headers.set xsrf_header_name token headers
391391+ | None -> headers
392392+285393(* Internal request function using connection pools *)
286286-let make_request_internal (T t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =
394394+let make_request_internal (T t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects
395395+ ?(path_params=[]) ~method_ url =
287396 let start_time = Unix.gettimeofday () in
288397 let method_str = Method.to_string method_ in
398398+399399+ (* Per Recommendation #29: Substitute path parameters first *)
400400+ let url = if path_params = [] then url else substitute_path_params url path_params in
401401+402402+ (* Per Recommendation #11: Resolve relative URLs against base_url *)
403403+ let url = resolve_url ?base_url:t.base_url url in
289404290405 Log.info (fun m -> m "Making %s request to %s" method_str url);
291406···302417 else
303418 headers
304419 in
420420+421421+ (* Per Recommendation #24: Apply XSRF token from cookies *)
422422+ let headers = Eio.Mutex.use_ro t.cookie_mutex (fun () ->
423423+ apply_xsrf_token
424424+ ~cookie_jar:t.cookie_jar
425425+ ~clock:t.clock
426426+ ~xsrf_cookie_name:t.xsrf_cookie_name
427427+ ~xsrf_header_name:t.xsrf_header_name
428428+ ~url
429429+ headers
430430+ ) in
305431306432 (* Use provided auth or default *)
307433 let auth = match auth with
···585711 response
586712587713(* Public request function - executes synchronously with retry support *)
588588-let request (T t as wrapped_t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =
714714+let request (T t as wrapped_t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects
715715+ ?(path_params=[]) ~method_ url =
589716 (* Helper to wrap response with Digest auth handling *)
590717 let with_digest_handling response =
591718 handle_digest_auth wrapped_t ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~method_ ~url response
···594721 | None ->
595722 (* No retry configured, execute directly *)
596723 let response = make_request_internal wrapped_t ?headers ?body ?auth ?timeout
597597- ?follow_redirects ?max_redirects ~method_ url in
724724+ ?follow_redirects ?max_redirects ~path_params ~method_ url in
598725 with_digest_handling response
599726 | Some retry_config ->
600727 (* Wrap in retry logic *)
···613740614741 try
615742 let response = make_request_internal wrapped_t ?headers ?body ?auth ?timeout
616616- ?follow_redirects ?max_redirects ~method_ url in
743743+ ?follow_redirects ?max_redirects ~path_params ~method_ url in
617744 (* Handle Digest auth challenge if applicable *)
618745 let response = with_digest_handling response in
619746 let status = Response.status_code response in
···651778 attempt_with_status_retry 1
652779653780(* Convenience methods *)
654654-let get t ?headers ?auth ?timeout ?params url =
781781+let get t ?headers ?auth ?timeout ?params ?(path_params=[]) url =
655782 let url = match params with
656783 | Some p ->
657784 let uri = Uri.of_string url in
···659786 Uri.to_string uri
660787 | None -> url
661788 in
662662- request t ?headers ?auth ?timeout ~method_:`GET url
789789+ request t ?headers ?auth ?timeout ~path_params ~method_:`GET url
663790664664-let post t ?headers ?body ?auth ?timeout url =
665665- request t ?headers ?body ?auth ?timeout ~method_:`POST url
791791+let post t ?headers ?body ?auth ?timeout ?(path_params=[]) url =
792792+ request t ?headers ?body ?auth ?timeout ~path_params ~method_:`POST url
666793667667-let put t ?headers ?body ?auth ?timeout url =
668668- request t ?headers ?body ?auth ?timeout ~method_:`PUT url
794794+let put t ?headers ?body ?auth ?timeout ?(path_params=[]) url =
795795+ request t ?headers ?body ?auth ?timeout ~path_params ~method_:`PUT url
669796670670-let patch t ?headers ?body ?auth ?timeout url =
671671- request t ?headers ?body ?auth ?timeout ~method_:`PATCH url
797797+let patch t ?headers ?body ?auth ?timeout ?(path_params=[]) url =
798798+ request t ?headers ?body ?auth ?timeout ~path_params ~method_:`PATCH url
672799673673-let delete t ?headers ?auth ?timeout url =
674674- request t ?headers ?auth ?timeout ~method_:`DELETE url
800800+let delete t ?headers ?auth ?timeout ?(path_params=[]) url =
801801+ request t ?headers ?auth ?timeout ~path_params ~method_:`DELETE url
675802676676-let head t ?headers ?auth ?timeout url =
677677- request t ?headers ?auth ?timeout ~method_:`HEAD url
803803+let head t ?headers ?auth ?timeout ?(path_params=[]) url =
804804+ request t ?headers ?auth ?timeout ~path_params ~method_:`HEAD url
678805679679-let options t ?headers ?auth ?timeout url =
680680- request t ?headers ?auth ?timeout ~method_:`OPTIONS url
806806+let options t ?headers ?auth ?timeout ?(path_params=[]) url =
807807+ request t ?headers ?auth ?timeout ~path_params ~method_:`OPTIONS url
681808682809(* Cmdliner integration module *)
683810module Cmd = struct
+26-2
lib/requests.mli
···240240 ?auto_decompress:bool ->
241241 ?expect_100_continue:bool ->
242242 ?expect_100_continue_threshold:int64 ->
243243+ ?base_url:string ->
244244+ ?xsrf_cookie_name:string option ->
245245+ ?xsrf_header_name:string ->
243246 < clock: _ Eio.Time.clock; net: _ Eio.Net.t; fs: Eio.Fs.dir_ty Eio.Path.t; .. > ->
244247 t
245248(** Create a new requests instance with persistent state and connection pooling.
···266269 @param auto_decompress Whether to automatically decompress gzip/deflate responses (default: true)
267270 @param expect_100_continue Whether to use HTTP 100-continue for large uploads (default: true)
268271 @param expect_100_continue_threshold Body size threshold to trigger 100-continue in bytes (default: 1MB)
272272+ @param base_url Base URL for relative paths (per Recommendation #11). Relative URLs are resolved against this.
273273+ @param xsrf_cookie_name Cookie name to extract XSRF token from (default: Some "XSRF-TOKEN", per Recommendation #24). Set to None to disable.
274274+ @param xsrf_header_name Header name to inject XSRF token into (default: "X-XSRF-TOKEN")
269275270276 {b Note:} HTTP caching has been disabled for simplicity. See CACHEIO.md for integration notes
271277 if you need to restore caching functionality in the future.
···377383 ?timeout:Timeout.t ->
378384 ?follow_redirects:bool ->
379385 ?max_redirects:int ->
386386+ ?path_params:(string * string) list ->
380387 method_:Method.t ->
381388 string ->
382389 Response.t
383383-(** Make a concurrent HTTP request *)
390390+(** Make a concurrent HTTP request.
391391+ @param path_params List of (key, value) pairs for URL template substitution (per Recommendation #29).
392392+ Example: [request ~path_params:[("id", "123")] ~method_:`GET "/users/{id}"] *)
384393385394val get :
386395 t ->
···388397 ?auth:Auth.t ->
389398 ?timeout:Timeout.t ->
390399 ?params:(string * string) list ->
400400+ ?path_params:(string * string) list ->
391401 string ->
392402 Response.t
393393-(** Concurrent GET request *)
403403+(** Concurrent GET request.
404404+ @param params Query parameters to append to URL
405405+ @param path_params Path template substitutions (e.g., ["/users/{id}"] with [("id", "123")]) *)
394406395407val post :
396408 t ->
···398410 ?body:Body.t ->
399411 ?auth:Auth.t ->
400412 ?timeout:Timeout.t ->
413413+ ?path_params:(string * string) list ->
401414 string ->
402415 Response.t
403416(** Concurrent POST request *)
···408421 ?body:Body.t ->
409422 ?auth:Auth.t ->
410423 ?timeout:Timeout.t ->
424424+ ?path_params:(string * string) list ->
411425 string ->
412426 Response.t
413427(** Concurrent PUT request *)
···418432 ?body:Body.t ->
419433 ?auth:Auth.t ->
420434 ?timeout:Timeout.t ->
435435+ ?path_params:(string * string) list ->
421436 string ->
422437 Response.t
423438(** Concurrent PATCH request *)
···427442 ?headers:Headers.t ->
428443 ?auth:Auth.t ->
429444 ?timeout:Timeout.t ->
445445+ ?path_params:(string * string) list ->
430446 string ->
431447 Response.t
432448(** Concurrent DELETE request *)
···436452 ?headers:Headers.t ->
437453 ?auth:Auth.t ->
438454 ?timeout:Timeout.t ->
455455+ ?path_params:(string * string) list ->
439456 string ->
440457 Response.t
441458(** Concurrent HEAD request *)
···445462 ?headers:Headers.t ->
446463 ?auth:Auth.t ->
447464 ?timeout:Timeout.t ->
465465+ ?path_params:(string * string) list ->
448466 string ->
449467 Response.t
450468(** Concurrent OPTIONS request *)
···713731714732(** HTTP 100-Continue configuration for large uploads *)
715733module Expect_continue = Expect_continue
734734+735735+(** HTTP Link header parsing (RFC 8288) for pagination and API discovery *)
736736+module Link = Link
737737+738738+(** HTTP request timing metrics for performance analysis *)
739739+module Timing = Timing
716740717741(** {2 Logging} *)
718742
+48-2
lib/retry.ml
···66let src = Logs.Src.create "requests.retry" ~doc:"HTTP Request Retry Logic"
77module Log = (val Logs.src_log src : Logs.LOG)
8899+(** Custom retry predicate for responses.
1010+ Per Recommendation #14: Allow user-defined retry logic.
1111+ The predicate receives (method, status, headers) and returns true to retry.
1212+ This runs in addition to the built-in status_forcelist check. *)
1313+type response_predicate = Method.t -> int -> Headers.t -> bool
1414+1515+(** Custom retry predicate for exceptions.
1616+ Returns true if the exception should trigger a retry. *)
1717+type exception_predicate = exn -> bool
1818+919type config = {
1020 max_retries : int;
1121 backoff_factor : float;
···1424 allowed_methods : Method.t list;
1525 respect_retry_after : bool;
1626 jitter : bool;
2727+ retry_response : response_predicate option; (** Per Recommendation #14 *)
2828+ retry_exception : exception_predicate option; (** Per Recommendation #14 *)
1729}
18301931let default_config = {
···2436 allowed_methods = [`GET; `HEAD; `PUT; `DELETE; `OPTIONS; `TRACE];
2537 respect_retry_after = true;
2638 jitter = true;
3939+ retry_response = None;
4040+ retry_exception = None;
2741}
28422943let create_config
···3448 ?(allowed_methods = [`GET; `HEAD; `PUT; `DELETE; `OPTIONS; `TRACE])
3549 ?(respect_retry_after = true)
3650 ?(jitter = true)
5151+ ?retry_response
5252+ ?retry_exception
3753 () =
3838- Log.debug (fun m -> m "Creating retry config: max_retries=%d backoff_factor=%.2f"
3939- max_retries backoff_factor);
5454+ Log.debug (fun m -> m "Creating retry config: max_retries=%d backoff_factor=%.2f custom_predicates=%b"
5555+ max_retries backoff_factor (Option.is_some retry_response || Option.is_some retry_exception));
4056 {
4157 max_retries;
4258 backoff_factor;
···4561 allowed_methods;
4662 respect_retry_after;
4763 jitter;
6464+ retry_response;
6565+ retry_exception;
4866 }
49676868+(** Check if a response should be retried based on built-in rules only.
6969+ Use [should_retry_response] for full custom predicate support. *)
5070let should_retry ~config ~method_ ~status =
5171 let should =
5272 List.mem method_ config.allowed_methods &&
···5575 Log.debug (fun m -> m "Should retry? method=%s status=%d -> %b"
5676 (Method.to_string method_) status should);
5777 should
7878+7979+(** Check if a response should be retried, including custom predicates.
8080+ Per Recommendation #14: User-defined retry logic.
8181+ Returns true if either built-in rules or custom predicate says to retry. *)
8282+let should_retry_response ~config ~method_ ~status ~headers =
8383+ (* Check built-in rules first *)
8484+ let builtin_should_retry =
8585+ List.mem method_ config.allowed_methods &&
8686+ List.mem status config.status_forcelist
8787+ in
8888+ (* Check custom predicate if provided *)
8989+ let custom_should_retry = match config.retry_response with
9090+ | Some predicate -> predicate method_ status headers
9191+ | None -> false
9292+ in
9393+ let should = builtin_should_retry || custom_should_retry in
9494+ Log.debug (fun m -> m "Should retry response? method=%s status=%d builtin=%b custom=%b -> %b"
9595+ (Method.to_string method_) status builtin_should_retry custom_should_retry should);
9696+ should
9797+9898+(** Check if an exception should trigger a retry, including custom predicates.
9999+ Per Recommendation #14: User-defined retry logic. *)
100100+let should_retry_exn ~config exn =
101101+ match config.retry_exception with
102102+ | Some predicate -> predicate exn
103103+ | None -> false
5810459105let calculate_backoff ~config ~attempt =
60106 let base_delay = config.backoff_factor *. (2.0 ** float_of_int attempt) in
+66-3
lib/retry.mli
···33 SPDX-License-Identifier: ISC
44 ---------------------------------------------------------------------------*)
5566-(** HTTP request retry logic with exponential backoff *)
66+(** HTTP request retry logic with exponential backoff
77+88+ This module provides configurable retry logic for HTTP requests,
99+ including exponential backoff, custom retry predicates, and
1010+ Retry-After header support.
1111+1212+ {2 Custom Retry Predicates}
1313+1414+ Per Recommendation #14: You can define custom predicates to control
1515+ retry behavior beyond the built-in status code and method checks.
1616+1717+ {b Example: Retry on specific error responses}
1818+ {[
1919+ let retry_on_rate_limit method_ status headers =
2020+ status = 429 && Headers.get "x-retry-allowed" headers = Some "true"
2121+ in
2222+ let config = Retry.create_config
2323+ ~retry_response:retry_on_rate_limit
2424+ ()
2525+ ]}
2626+2727+ {b Example: Retry on custom exceptions}
2828+ {[
2929+ let retry_on_network_error = function
3030+ | Unix.Unix_error (Unix.ECONNRESET, _, _) -> true
3131+ | Unix.Unix_error (Unix.ETIMEDOUT, _, _) -> true
3232+ | _ -> false
3333+ in
3434+ let config = Retry.create_config
3535+ ~retry_exception:retry_on_network_error
3636+ ()
3737+ ]}
3838+*)
739840open Eio
9411042(** Log source for retry operations *)
1143val src : Logs.Src.t
12444545+(** {1 Custom Retry Predicates}
4646+4747+ Per Recommendation #14: Allow user-defined retry logic. *)
4848+4949+(** Custom retry predicate for responses.
5050+ Receives (method, status, headers) and returns true to retry.
5151+ This runs in addition to the built-in status_forcelist check. *)
5252+type response_predicate = Method.t -> int -> Headers.t -> bool
5353+5454+(** Custom retry predicate for exceptions.
5555+ Returns true if the exception should trigger a retry. *)
5656+type exception_predicate = exn -> bool
5757+5858+(** {1 Configuration} *)
5959+1360(** Retry configuration *)
1461type config = {
1562 max_retries : int; (** Maximum number of retry attempts *)
···1966 allowed_methods : Method.t list; (** Methods safe to retry *)
2067 respect_retry_after : bool; (** Honor Retry-After response header *)
2168 jitter : bool; (** Add randomness to prevent thundering herd *)
6969+ retry_response : response_predicate option; (** Custom response retry predicate *)
7070+ retry_exception : exception_predicate option; (** Custom exception retry predicate *)
2271}
23722473(** Default retry configuration *)
2574val default_config : config
26752727-(** Create a custom retry configuration *)
7676+(** Create a custom retry configuration.
7777+ @param retry_response Custom predicate for response-based retry decisions
7878+ @param retry_exception Custom predicate for exception-based retry decisions *)
2879val create_config :
2980 ?max_retries:int ->
3081 ?backoff_factor:float ->
···3384 ?allowed_methods:Method.t list ->
3485 ?respect_retry_after:bool ->
3586 ?jitter:bool ->
8787+ ?retry_response:response_predicate ->
8888+ ?retry_exception:exception_predicate ->
3689 unit -> config
37903838-(** Check if a request should be retried *)
9191+(** {1 Retry Decision Functions} *)
9292+9393+(** Check if a request should be retried based on built-in rules only.
9494+ For full custom predicate support, use [should_retry_response]. *)
3995val should_retry : config:config -> method_:Method.t -> status:int -> bool
9696+9797+(** Check if a response should be retried, including custom predicates.
9898+ Returns true if either built-in rules or custom predicate says to retry. *)
9999+val should_retry_response : config:config -> method_:Method.t -> status:int -> headers:Headers.t -> bool
100100+101101+(** Check if an exception should trigger a retry using custom predicates. *)
102102+val should_retry_exn : config:config -> exn -> bool
4010341104(** Calculate backoff delay for a given attempt *)
42105val calculate_backoff : config:config -> attempt:int -> float
+177
lib/timing.ml
···11+(*---------------------------------------------------------------------------
22+ Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
33+ SPDX-License-Identifier: ISC
44+ ---------------------------------------------------------------------------*)
55+66+(** HTTP request timing metrics
77+88+ Per Recommendation #12: Detailed timing breakdown for requests,
99+ similar to curl's --write-out timing variables.
1010+1111+ Timing phases:
1212+ {[
1313+ |--DNS--|--Connect--|--TLS--|--Request--|--Wait--|--Content--|
1414+ ^ ^ ^ ^ ^ ^
1515+ namelookup connect ssl_handsh send ttfb total
1616+ ]}
1717+*)
1818+1919+let src = Logs.Src.create "requests.timing" ~doc:"HTTP request timing"
2020+module Log = (val Logs.src_log src : Logs.LOG)
2121+2222+(** Timing metrics for a single request *)
2323+type t = {
2424+ dns_lookup : float option; (** Time for DNS resolution *)
2525+ tcp_connect : float option; (** Time to establish TCP connection *)
2626+ tls_handshake : float option; (** Time for TLS handshake (HTTPS only) *)
2727+ request_sent : float option; (** Time to send request *)
2828+ time_to_first_byte : float option; (** Time from request sent to first byte received *)
2929+ content_transfer : float option; (** Time to transfer response body *)
3030+ total : float; (** Total request time *)
3131+}
3232+3333+let empty = {
3434+ dns_lookup = None;
3535+ tcp_connect = None;
3636+ tls_handshake = None;
3737+ request_sent = None;
3838+ time_to_first_byte = None;
3939+ content_transfer = None;
4040+ total = 0.0;
4141+}
4242+4343+let make
4444+ ?dns_lookup
4545+ ?tcp_connect
4646+ ?tls_handshake
4747+ ?request_sent
4848+ ?time_to_first_byte
4949+ ?content_transfer
5050+ ~total
5151+ () =
5252+ { dns_lookup; tcp_connect; tls_handshake; request_sent;
5353+ time_to_first_byte; content_transfer; total }
5454+5555+let dns_lookup t = t.dns_lookup
5656+let tcp_connect t = t.tcp_connect
5757+let tls_handshake t = t.tls_handshake
5858+let request_sent t = t.request_sent
5959+let time_to_first_byte t = t.time_to_first_byte
6060+let content_transfer t = t.content_transfer
6161+let total t = t.total
6262+6363+(** Connection setup time (DNS + TCP + TLS) *)
6464+let connection_time t =
6565+ let dns = Option.value t.dns_lookup ~default:0.0 in
6666+ let tcp = Option.value t.tcp_connect ~default:0.0 in
6767+ let tls = Option.value t.tls_handshake ~default:0.0 in
6868+ Some (dns +. tcp +. tls)
6969+7070+(** Server processing time (TTFB - request send time) *)
7171+let server_time t =
7272+ match t.time_to_first_byte, t.request_sent with
7373+ | Some ttfb, Some send -> Some (ttfb -. send)
7474+ | _ -> None
7575+7676+(** Pretty-print timing in human readable format *)
7777+let pp ppf t =
7878+ let pp_opt ppf = function
7979+ | Some v -> Format.fprintf ppf "%.3fms" (v *. 1000.0)
8080+ | None -> Format.fprintf ppf "-"
8181+ in
8282+ Format.fprintf ppf "@[<v>Timing:@,\
8383+ DNS lookup: %a@,\
8484+ TCP connect: %a@,\
8585+ TLS handshake: %a@,\
8686+ Request sent: %a@,\
8787+ Time to 1st byte: %a@,\
8888+ Content transfer: %a@,\
8989+ Total: %.3fms@]"
9090+ pp_opt t.dns_lookup
9191+ pp_opt t.tcp_connect
9292+ pp_opt t.tls_handshake
9393+ pp_opt t.request_sent
9494+ pp_opt t.time_to_first_byte
9595+ pp_opt t.content_transfer
9696+ (t.total *. 1000.0)
9797+9898+let to_string t =
9999+ Format.asprintf "%a" pp t
100100+101101+(** Convert to JSON-like association list for logging/debugging *)
102102+let to_assoc t =
103103+ let add_opt name = function
104104+ | Some v -> [(name, v)]
105105+ | None -> []
106106+ in
107107+ add_opt "dns_lookup" t.dns_lookup @
108108+ add_opt "tcp_connect" t.tcp_connect @
109109+ add_opt "tls_handshake" t.tls_handshake @
110110+ add_opt "request_sent" t.request_sent @
111111+ add_opt "time_to_first_byte" t.time_to_first_byte @
112112+ add_opt "content_transfer" t.content_transfer @
113113+ [("total", t.total)]
114114+115115+(** {1 Timer for Collecting Metrics}
116116+117117+ Use this during request execution to collect timing data. *)
118118+119119+type timer = {
120120+ start : float;
121121+ mutable dns_end : float option;
122122+ mutable connect_end : float option;
123123+ mutable tls_end : float option;
124124+ mutable send_end : float option;
125125+ mutable ttfb : float option;
126126+ mutable transfer_end : float option;
127127+}
128128+129129+let start () =
130130+ { start = Unix.gettimeofday ();
131131+ dns_end = None;
132132+ connect_end = None;
133133+ tls_end = None;
134134+ send_end = None;
135135+ ttfb = None;
136136+ transfer_end = None;
137137+ }
138138+139139+let mark_dns timer =
140140+ timer.dns_end <- Some (Unix.gettimeofday ())
141141+142142+let mark_connect timer =
143143+ timer.connect_end <- Some (Unix.gettimeofday ())
144144+145145+let mark_tls timer =
146146+ timer.tls_end <- Some (Unix.gettimeofday ())
147147+148148+let mark_send timer =
149149+ timer.send_end <- Some (Unix.gettimeofday ())
150150+151151+let mark_ttfb timer =
152152+ timer.ttfb <- Some (Unix.gettimeofday ())
153153+154154+let mark_transfer_end timer =
155155+ timer.transfer_end <- Some (Unix.gettimeofday ())
156156+157157+let finish timer =
158158+ let now = Unix.gettimeofday () in
159159+ let total = now -. timer.start in
160160+161161+ let calc_phase start_time end_time =
162162+ Option.map (fun e -> e -. Option.value start_time ~default:timer.start) end_time
163163+ in
164164+165165+ {
166166+ dns_lookup = calc_phase (Some timer.start) timer.dns_end;
167167+ tcp_connect = calc_phase timer.dns_end timer.connect_end;
168168+ tls_handshake = calc_phase timer.connect_end timer.tls_end;
169169+ request_sent = calc_phase (if Option.is_some timer.tls_end then timer.tls_end else timer.connect_end) timer.send_end;
170170+ time_to_first_byte = calc_phase timer.send_end timer.ttfb;
171171+ content_transfer = calc_phase timer.ttfb timer.transfer_end;
172172+ total;
173173+ }
174174+175175+(** Log timing metrics *)
176176+let log_timing ?(level=Logs.Debug) t =
177177+ Log.msg level (fun m -> m "%a" pp t)
+151
lib/timing.mli
···11+(*---------------------------------------------------------------------------
22+ Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
33+ SPDX-License-Identifier: ISC
44+ ---------------------------------------------------------------------------*)
55+66+(** HTTP request timing metrics
77+88+ Per Recommendation #12: Detailed timing breakdown for requests,
99+ similar to curl's --write-out timing variables.
1010+1111+ {2 Timing Phases}
1212+1313+ {[
1414+ |--DNS--|--Connect--|--TLS--|--Request--|--Wait--|--Content--|
1515+ ^ ^ ^ ^ ^ ^
1616+ namelookup connect ssl_handsh send ttfb total
1717+ ]}
1818+1919+ {2 Example Usage}
2020+2121+ {[
2222+ (* Start timing *)
2323+ let timer = Timing.start () in
2424+2525+ (* DNS resolution *)
2626+ let addrs = Eio.Net.getaddrinfo_stream net host in
2727+ Timing.mark_dns timer;
2828+2929+ (* TCP connect *)
3030+ let flow = Eio.Net.connect ~sw net addr in
3131+ Timing.mark_connect timer;
3232+3333+ (* TLS handshake (for HTTPS) *)
3434+ let tls_flow = Tls_eio.client_of_flow tls_cfg flow in
3535+ Timing.mark_tls timer;
3636+3737+ (* Send request *)
3838+ send_request tls_flow request;
3939+ Timing.mark_send timer;
4040+4141+ (* First byte received *)
4242+ Timing.mark_ttfb timer;
4343+4444+ (* Complete transfer *)
4545+ Timing.mark_transfer_end timer;
4646+4747+ (* Get timing metrics *)
4848+ let metrics = Timing.finish timer in
4949+ Printf.printf "Total: %.3fms\n" (Timing.total metrics *. 1000.0)
5050+ ]}
5151+*)
5252+5353+(** {1 Timing Metrics} *)
5454+5555+type t
5656+(** Timing metrics for a completed request *)
5757+5858+val empty : t
5959+(** Empty timing with all phases unknown *)
6060+6161+val make :
6262+ ?dns_lookup:float ->
6363+ ?tcp_connect:float ->
6464+ ?tls_handshake:float ->
6565+ ?request_sent:float ->
6666+ ?time_to_first_byte:float ->
6767+ ?content_transfer:float ->
6868+ total:float ->
6969+ unit -> t
7070+(** Create timing metrics manually *)
7171+7272+(** {2 Accessors} *)
7373+7474+val dns_lookup : t -> float option
7575+(** Time for DNS resolution in seconds *)
7676+7777+val tcp_connect : t -> float option
7878+(** Time to establish TCP connection in seconds *)
7979+8080+val tls_handshake : t -> float option
8181+(** Time for TLS handshake in seconds (HTTPS only) *)
8282+8383+val request_sent : t -> float option
8484+(** Time to send request in seconds *)
8585+8686+val time_to_first_byte : t -> float option
8787+(** Time from request sent to first response byte in seconds *)
8888+8989+val content_transfer : t -> float option
9090+(** Time to transfer response body in seconds *)
9191+9292+val total : t -> float
9393+(** Total request time in seconds *)
9494+9595+(** {2 Computed Metrics} *)
9696+9797+val connection_time : t -> float option
9898+(** Total connection setup time (DNS + TCP + TLS) *)
9999+100100+val server_time : t -> float option
101101+(** Server processing time (TTFB - request send time) *)
102102+103103+(** {2 Formatting} *)
104104+105105+val pp : Format.formatter -> t -> unit
106106+(** Pretty-print timing in human readable format *)
107107+108108+val to_string : t -> string
109109+(** Convert to string representation *)
110110+111111+val to_assoc : t -> (string * float) list
112112+(** Convert to association list for logging/serialization *)
113113+114114+(** {1 Timer for Collecting Metrics}
115115+116116+ Use this during request execution to collect timing data incrementally. *)
117117+118118+type timer
119119+(** Mutable timer for collecting metrics during request execution *)
120120+121121+val start : unit -> timer
122122+(** Start a new timer *)
123123+124124+val mark_dns : timer -> unit
125125+(** Mark DNS resolution complete *)
126126+127127+val mark_connect : timer -> unit
128128+(** Mark TCP connection established *)
129129+130130+val mark_tls : timer -> unit
131131+(** Mark TLS handshake complete *)
132132+133133+val mark_send : timer -> unit
134134+(** Mark request fully sent *)
135135+136136+val mark_ttfb : timer -> unit
137137+(** Mark first response byte received *)
138138+139139+val mark_transfer_end : timer -> unit
140140+(** Mark response body transfer complete *)
141141+142142+val finish : timer -> t
143143+(** Stop timer and compute final timing metrics *)
144144+145145+(** {1 Logging} *)
146146+147147+val src : Logs.Src.t
148148+(** Log source for timing operations *)
149149+150150+val log_timing : ?level:Logs.level -> t -> unit
151151+(** Log timing metrics at specified level (default: Debug) *)