A batteries included HTTP/1.1 client in OCaml

features

+911 -26
+1 -1
lib/http_client.ml
··· 224 224 let buf_read = Http_read.of_flow flow ~max_size:max_int in 225 225 226 226 try 227 - let status = Http_read.status_line buf_read in 227 + let (_version, status) = Http_read.status_line buf_read in 228 228 229 229 Log.debug (fun m -> m "Received response status %d while waiting for 100 Continue" status); 230 230
+180
lib/link.ml
··· 1 + (*--------------------------------------------------------------------------- 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 + SPDX-License-Identifier: ISC 4 + ---------------------------------------------------------------------------*) 5 + 6 + (** HTTP Link header parsing per RFC 8288 7 + 8 + This module parses Link headers for pagination, API discovery, and 9 + relationship navigation. Per Recommendation #19. 10 + 11 + Link header example: 12 + {[ 13 + Link: <https://api.example.com/users?page=2>; rel="next", 14 + <https://api.example.com/users?page=5>; rel="last" 15 + ]} 16 + *) 17 + 18 + let src = Logs.Src.create "requests.link" ~doc:"HTTP Link header parsing" 19 + module Log = (val Logs.src_log src : Logs.LOG) 20 + 21 + (** A parsed Link header entry *) 22 + type t = { 23 + uri : string; (** The target URI *) 24 + rel : string option; (** The relation type (e.g., "next", "prev", "last") *) 25 + title : string option; (** Human-readable title *) 26 + media_type : string option; (** Media type hint *) 27 + hreflang : string option; (** Language hint *) 28 + params : (string * string) list; (** Additional parameters *) 29 + } 30 + 31 + let make ~uri ?rel ?title ?media_type ?hreflang ?(params=[]) () = 32 + { uri; rel; title; media_type; hreflang; params } 33 + 34 + let uri t = t.uri 35 + let rel t = t.rel 36 + let title t = t.title 37 + let media_type t = t.media_type 38 + let hreflang t = t.hreflang 39 + let params t = t.params 40 + 41 + (** Parse a single link value from a Link header segment. 42 + Format: <uri>; param1=value1; param2="value2" *) 43 + let parse_link_value str = 44 + let str = String.trim str in 45 + 46 + (* Find the URI in angle brackets *) 47 + if String.length str = 0 || str.[0] <> '<' then begin 48 + Log.debug (fun m -> m "Invalid link value, missing '<': %s" str); 49 + None 50 + end else begin 51 + match String.index_opt str '>' with 52 + | None -> 53 + Log.debug (fun m -> m "Invalid link value, missing '>': %s" str); 54 + None 55 + | Some close_idx -> 56 + let uri = String.sub str 1 (close_idx - 1) in 57 + let params_str = 58 + if close_idx + 1 < String.length str then 59 + String.sub str (close_idx + 1) (String.length str - close_idx - 1) 60 + else "" 61 + in 62 + 63 + (* Parse parameters *) 64 + let params = String.split_on_char ';' params_str in 65 + let parsed_params = List.filter_map (fun param -> 66 + let param = String.trim param in 67 + if param = "" then None 68 + else begin 69 + match String.index_opt param '=' with 70 + | None -> None 71 + | Some eq_idx -> 72 + let key = String.trim (String.sub param 0 eq_idx) in 73 + let value_raw = String.trim (String.sub param (eq_idx + 1) (String.length param - eq_idx - 1)) in 74 + (* Remove quotes if present *) 75 + let value = 76 + if String.length value_raw >= 2 && 77 + value_raw.[0] = '"' && 78 + value_raw.[String.length value_raw - 1] = '"' then 79 + String.sub value_raw 1 (String.length value_raw - 2) 80 + else 81 + value_raw 82 + in 83 + Some (String.lowercase_ascii key, value) 84 + end 85 + ) params in 86 + 87 + (* Extract known parameters *) 88 + let rel = List.assoc_opt "rel" parsed_params in 89 + let title = List.assoc_opt "title" parsed_params in 90 + let media_type = List.assoc_opt "type" parsed_params in 91 + let hreflang = List.assoc_opt "hreflang" parsed_params in 92 + 93 + (* Keep other params *) 94 + let other_params = List.filter (fun (k, _) -> 95 + not (List.mem k ["rel"; "title"; "type"; "hreflang"]) 96 + ) parsed_params in 97 + 98 + Log.debug (fun m -> m "Parsed link: uri=%s rel=%s" 99 + uri (Option.value rel ~default:"<none>")); 100 + 101 + Some { uri; rel; title; media_type; hreflang; params = other_params } 102 + end 103 + 104 + (** Parse a complete Link header value (may contain multiple links) *) 105 + let parse header_value = 106 + Log.debug (fun m -> m "Parsing Link header: %s" header_value); 107 + 108 + (* Split on commas, but be careful of commas inside quotes *) 109 + let rec split_links str acc current in_quotes = 110 + if String.length str = 0 then 111 + let final = String.trim current in 112 + if final = "" then List.rev acc else List.rev (final :: acc) 113 + else 114 + let c = str.[0] in 115 + let rest = String.sub str 1 (String.length str - 1) in 116 + if c = '"' then 117 + split_links rest acc (current ^ String.make 1 c) (not in_quotes) 118 + else if c = ',' && not in_quotes then 119 + let trimmed = String.trim current in 120 + if trimmed = "" then 121 + split_links rest acc "" false 122 + else 123 + split_links rest (trimmed :: acc) "" false 124 + else 125 + split_links rest acc (current ^ String.make 1 c) in_quotes 126 + in 127 + 128 + let link_strs = split_links header_value [] "" false in 129 + List.filter_map parse_link_value link_strs 130 + 131 + (** Parse Link header from response headers *) 132 + let from_headers headers = 133 + match Headers.get "link" headers with 134 + | None -> [] 135 + | Some value -> parse value 136 + 137 + (** Find a link by relation type *) 138 + let find_rel rel links = 139 + List.find_opt (fun l -> l.rel = Some rel) links 140 + 141 + (** Find all links with a specific relation type *) 142 + let filter_rel rel links = 143 + List.filter (fun l -> l.rel = Some rel) links 144 + 145 + (** Get pagination links from headers. 146 + Returns (first, prev, next, last) where each is optional. *) 147 + let pagination headers = 148 + let links = from_headers headers in 149 + let first = find_rel "first" links |> Option.map uri in 150 + let prev = find_rel "prev" links |> Option.map uri in 151 + let next = find_rel "next" links |> Option.map uri in 152 + let last = find_rel "last" links |> Option.map uri in 153 + (first, prev, next, last) 154 + 155 + (** Check if there are more pages (next link exists) *) 156 + let has_next headers = 157 + let links = from_headers headers in 158 + Option.is_some (find_rel "next" links) 159 + 160 + (** Get the next page URL if available *) 161 + let next_url headers = 162 + let links = from_headers headers in 163 + find_rel "next" links |> Option.map uri 164 + 165 + (** Get the previous page URL if available *) 166 + let prev_url headers = 167 + let links = from_headers headers in 168 + find_rel "prev" links |> Option.map uri 169 + 170 + (** Pretty-print a link *) 171 + let pp ppf link = 172 + Format.fprintf ppf "<%s>" link.uri; 173 + Option.iter (fun r -> Format.fprintf ppf "; rel=\"%s\"" r) link.rel; 174 + Option.iter (fun t -> Format.fprintf ppf "; title=\"%s\"" t) link.title; 175 + Option.iter (fun t -> Format.fprintf ppf "; type=\"%s\"" t) link.media_type; 176 + Option.iter (fun h -> Format.fprintf ppf "; hreflang=\"%s\"" h) link.hreflang; 177 + List.iter (fun (k, v) -> Format.fprintf ppf "; %s=\"%s\"" k v) link.params 178 + 179 + let to_string link = 180 + Format.asprintf "%a" pp link
+117
lib/link.mli
··· 1 + (*--------------------------------------------------------------------------- 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 + SPDX-License-Identifier: ISC 4 + ---------------------------------------------------------------------------*) 5 + 6 + (** HTTP Link header parsing per RFC 8288 7 + 8 + This module parses Link headers commonly used for: 9 + - API pagination (rel="next", "prev", "first", "last") 10 + - Resource discovery 11 + - Relationship navigation 12 + 13 + Per Recommendation #19: Parse Link headers for pagination support. 14 + 15 + {2 Example: Following Pagination} 16 + {[ 17 + let rec fetch_all_pages session url acc = 18 + let response = Requests.get session url in 19 + let data = Response.body response |> Eio.Flow.read_all in 20 + let acc = data :: acc in 21 + match Link.next_url (Response.headers response) with 22 + | Some next -> fetch_all_pages session next acc 23 + | None -> List.rev acc 24 + ]} 25 + 26 + {2 Example: Getting All Pagination URLs} 27 + {[ 28 + let response = Requests.get session "https://api.example.com/items" in 29 + let (first, prev, next, last) = Link.pagination (Response.headers response) in 30 + match next with 31 + | Some url -> Printf.printf "Next page: %s\n" url 32 + | None -> print_endline "No more pages" 33 + ]} 34 + *) 35 + 36 + (** A parsed Link header entry *) 37 + type t 38 + 39 + (** {1 Constructors} *) 40 + 41 + val make : 42 + uri:string -> 43 + ?rel:string -> 44 + ?title:string -> 45 + ?media_type:string -> 46 + ?hreflang:string -> 47 + ?params:(string * string) list -> 48 + unit -> t 49 + (** Create a link value *) 50 + 51 + (** {1 Accessors} *) 52 + 53 + val uri : t -> string 54 + (** The target URI *) 55 + 56 + val rel : t -> string option 57 + (** The relation type (e.g., "next", "prev", "last", "self") *) 58 + 59 + val title : t -> string option 60 + (** Human-readable title *) 61 + 62 + val media_type : t -> string option 63 + (** Media type hint (from "type" parameter) *) 64 + 65 + val hreflang : t -> string option 66 + (** Language hint *) 67 + 68 + val params : t -> (string * string) list 69 + (** Additional parameters not covered by standard accessors *) 70 + 71 + (** {1 Parsing} *) 72 + 73 + val parse : string -> t list 74 + (** Parse a Link header value into a list of links. 75 + Handles multiple comma-separated links. *) 76 + 77 + val from_headers : Headers.t -> t list 78 + (** Extract and parse Link header from response headers. 79 + Returns empty list if no Link header present. *) 80 + 81 + (** {1 Finding Links} *) 82 + 83 + val find_rel : string -> t list -> t option 84 + (** Find the first link with a specific relation type *) 85 + 86 + val filter_rel : string -> t list -> t list 87 + (** Find all links with a specific relation type *) 88 + 89 + (** {1 Pagination Helpers} *) 90 + 91 + val pagination : Headers.t -> string option * string option * string option * string option 92 + (** [pagination headers] extracts pagination links. 93 + Returns [(first, prev, next, last)] where each is optional. 94 + 95 + Looks for links with rel="first", rel="prev", rel="next", rel="last". *) 96 + 97 + val has_next : Headers.t -> bool 98 + (** Check if there are more pages (next link exists) *) 99 + 100 + val next_url : Headers.t -> string option 101 + (** Get the next page URL if available *) 102 + 103 + val prev_url : Headers.t -> string option 104 + (** Get the previous page URL if available *) 105 + 106 + (** {1 Formatting} *) 107 + 108 + val pp : Format.formatter -> t -> unit 109 + (** Pretty-print a link in Link header format *) 110 + 111 + val to_string : t -> string 112 + (** Convert link to string representation *) 113 + 114 + (** {1 Logging} *) 115 + 116 + val src : Logs.Src.t 117 + (** Log source for link parsing operations *)
+145 -18
lib/requests.ml
··· 25 25 module Response_limits = Response_limits 26 26 module Expect_continue = Expect_continue 27 27 module Version = Version 28 + module Link = Link 29 + module Timing = Timing 28 30 29 31 (** Minimum TLS version configuration. 30 32 Per Recommendation #6: Allow enforcing minimum TLS version. *) ··· 63 65 xdg : Xdge.t option; 64 66 auto_decompress : bool; 65 67 expect_100_continue : Expect_continue.t; (** 100-continue configuration *) 68 + base_url : string option; (** Per Recommendation #11: Base URL for relative paths *) 69 + xsrf_cookie_name : string option; (** Per Recommendation #24: XSRF cookie name *) 70 + xsrf_header_name : string; (** Per Recommendation #24: XSRF header name *) 66 71 67 72 (* Statistics - mutable but NOTE: when sessions are derived via record update 68 73 syntax ({t with field = value}), these are copied not shared. Each derived ··· 95 100 ?(auto_decompress = true) 96 101 ?(expect_100_continue = true) 97 102 ?(expect_100_continue_threshold = 1_048_576L) (* 1MB *) 103 + ?base_url 104 + ?(xsrf_cookie_name = Some "XSRF-TOKEN") (* Per Recommendation #24 *) 105 + ?(xsrf_header_name = "X-XSRF-TOKEN") 98 106 env = 99 107 100 108 let clock = env#clock in ··· 188 196 () 189 197 in 190 198 199 + (* Normalize base_url: remove trailing slash for consistent path joining *) 200 + let base_url = Option.map (fun url -> 201 + if String.length url > 0 && url.[String.length url - 1] = '/' then 202 + String.sub url 0 (String.length url - 1) 203 + else url 204 + ) base_url in 205 + 191 206 T { 192 207 sw; 193 208 clock; ··· 208 223 xdg; 209 224 auto_decompress; 210 225 expect_100_continue = expect_100_config; 226 + base_url; 227 + xsrf_cookie_name; 228 + xsrf_header_name; 211 229 requests_made = 0; 212 230 total_time = 0.0; 213 231 retries_count = 0; ··· 282 300 | None -> 283 301 uri (* Relative URLs are OK - they will be resolved against current URL *) 284 302 303 + (** {1 URL Resolution and Path Templating} 304 + 305 + Per Recommendation #11: Base URL support with RFC 3986 resolution. 306 + Per Recommendation #29: Path parameter templating. *) 307 + 308 + (** Check if a URL is relative (no scheme) *) 309 + let is_relative_url url = 310 + let uri = Uri.of_string url in 311 + Option.is_none (Uri.scheme uri) 312 + 313 + (** Resolve a URL against a base URL per RFC 3986 Section 5. 314 + If the URL is already absolute, return it unchanged. 315 + If base_url is None, return the original URL. *) 316 + let resolve_url ?base_url url = 317 + match base_url with 318 + | None -> url 319 + | Some base -> 320 + if is_relative_url url then begin 321 + let base_uri = Uri.of_string base in 322 + let rel_uri = Uri.of_string url in 323 + let scheme = Uri.scheme base_uri |> Option.value ~default:"https" in 324 + let resolved = Uri.resolve scheme base_uri rel_uri in 325 + Log.debug (fun m -> m "Resolved relative URL %s against base %s -> %s" 326 + url base (Uri.to_string resolved)); 327 + Uri.to_string resolved 328 + end else 329 + url (* Already absolute *) 330 + 331 + (** Substitute path parameters in a URL template. 332 + Per Recommendation #29 and RFC 6570 (simplified). 333 + Template: "/users/{id}/posts/{post_id}" 334 + Params: [("id", "123"); ("post_id", "456")] 335 + Result: "/users/123/posts/456" 336 + Values are automatically URL-encoded. *) 337 + let substitute_path_params url params = 338 + List.fold_left (fun url (key, value) -> 339 + let pattern = "{" ^ key ^ "}" in 340 + let encoded_value = Uri.pct_encode value in 341 + let rec replace s = 342 + match String.split_on_char '{' s with 343 + | [] -> "" 344 + | [single] -> single 345 + | before :: rest -> 346 + let rest_str = String.concat "{" rest in 347 + if String.length rest_str >= String.length key + 1 && 348 + String.sub rest_str 0 (String.length key) = key && 349 + rest_str.[String.length key] = '}' then 350 + before ^ encoded_value ^ String.sub rest_str (String.length key + 1) 351 + (String.length rest_str - String.length key - 1) 352 + else 353 + before ^ "{" ^ replace rest_str 354 + in 355 + if String.length pattern > 0 then replace url else url 356 + ) url params 357 + 358 + (** {1 XSRF Token Handling} 359 + 360 + Per Recommendation #24: Automatically inject XSRF tokens from cookies. *) 361 + 362 + (** Extract XSRF token from cookies and add to headers if: 363 + 1. xsrf_cookie_name is configured 364 + 2. The cookie exists 365 + 3. The request is same-origin (security) *) 366 + let apply_xsrf_token ~cookie_jar ~clock ~xsrf_cookie_name ~xsrf_header_name ~url headers = 367 + match xsrf_cookie_name with 368 + | None -> headers (* XSRF handling disabled *) 369 + | Some cookie_name -> 370 + let uri = Uri.of_string url in 371 + let domain = Uri.host uri |> Option.value ~default:"" in 372 + let path = Uri.path uri in 373 + let is_secure = Uri.scheme uri = Some "https" in 374 + 375 + (* Get cookies for this domain *) 376 + let cookies = Cookeio_jar.get_cookies cookie_jar ~clock 377 + ~domain ~path ~is_secure in 378 + 379 + (* Find the XSRF token cookie *) 380 + let xsrf_value = List.find_map (fun cookie -> 381 + if Cookeio.name cookie = cookie_name then 382 + Some (Cookeio.value cookie) 383 + else 384 + None 385 + ) cookies in 386 + 387 + match xsrf_value with 388 + | Some token -> 389 + Log.debug (fun m -> m "Adding XSRF token header: %s" xsrf_header_name); 390 + Headers.set xsrf_header_name token headers 391 + | None -> headers 392 + 285 393 (* Internal request function using connection pools *) 286 - let make_request_internal (T t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url = 394 + let make_request_internal (T t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects 395 + ?(path_params=[]) ~method_ url = 287 396 let start_time = Unix.gettimeofday () in 288 397 let method_str = Method.to_string method_ in 398 + 399 + (* Per Recommendation #29: Substitute path parameters first *) 400 + let url = if path_params = [] then url else substitute_path_params url path_params in 401 + 402 + (* Per Recommendation #11: Resolve relative URLs against base_url *) 403 + let url = resolve_url ?base_url:t.base_url url in 289 404 290 405 Log.info (fun m -> m "Making %s request to %s" method_str url); 291 406 ··· 302 417 else 303 418 headers 304 419 in 420 + 421 + (* Per Recommendation #24: Apply XSRF token from cookies *) 422 + let headers = Eio.Mutex.use_ro t.cookie_mutex (fun () -> 423 + apply_xsrf_token 424 + ~cookie_jar:t.cookie_jar 425 + ~clock:t.clock 426 + ~xsrf_cookie_name:t.xsrf_cookie_name 427 + ~xsrf_header_name:t.xsrf_header_name 428 + ~url 429 + headers 430 + ) in 305 431 306 432 (* Use provided auth or default *) 307 433 let auth = match auth with ··· 585 711 response 586 712 587 713 (* Public request function - executes synchronously with retry support *) 588 - let request (T t as wrapped_t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url = 714 + let request (T t as wrapped_t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects 715 + ?(path_params=[]) ~method_ url = 589 716 (* Helper to wrap response with Digest auth handling *) 590 717 let with_digest_handling response = 591 718 handle_digest_auth wrapped_t ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~method_ ~url response ··· 594 721 | None -> 595 722 (* No retry configured, execute directly *) 596 723 let response = make_request_internal wrapped_t ?headers ?body ?auth ?timeout 597 - ?follow_redirects ?max_redirects ~method_ url in 724 + ?follow_redirects ?max_redirects ~path_params ~method_ url in 598 725 with_digest_handling response 599 726 | Some retry_config -> 600 727 (* Wrap in retry logic *) ··· 613 740 614 741 try 615 742 let response = make_request_internal wrapped_t ?headers ?body ?auth ?timeout 616 - ?follow_redirects ?max_redirects ~method_ url in 743 + ?follow_redirects ?max_redirects ~path_params ~method_ url in 617 744 (* Handle Digest auth challenge if applicable *) 618 745 let response = with_digest_handling response in 619 746 let status = Response.status_code response in ··· 651 778 attempt_with_status_retry 1 652 779 653 780 (* Convenience methods *) 654 - let get t ?headers ?auth ?timeout ?params url = 781 + let get t ?headers ?auth ?timeout ?params ?(path_params=[]) url = 655 782 let url = match params with 656 783 | Some p -> 657 784 let uri = Uri.of_string url in ··· 659 786 Uri.to_string uri 660 787 | None -> url 661 788 in 662 - request t ?headers ?auth ?timeout ~method_:`GET url 789 + request t ?headers ?auth ?timeout ~path_params ~method_:`GET url 663 790 664 - let post t ?headers ?body ?auth ?timeout url = 665 - request t ?headers ?body ?auth ?timeout ~method_:`POST url 791 + let post t ?headers ?body ?auth ?timeout ?(path_params=[]) url = 792 + request t ?headers ?body ?auth ?timeout ~path_params ~method_:`POST url 666 793 667 - let put t ?headers ?body ?auth ?timeout url = 668 - request t ?headers ?body ?auth ?timeout ~method_:`PUT url 794 + let put t ?headers ?body ?auth ?timeout ?(path_params=[]) url = 795 + request t ?headers ?body ?auth ?timeout ~path_params ~method_:`PUT url 669 796 670 - let patch t ?headers ?body ?auth ?timeout url = 671 - request t ?headers ?body ?auth ?timeout ~method_:`PATCH url 797 + let patch t ?headers ?body ?auth ?timeout ?(path_params=[]) url = 798 + request t ?headers ?body ?auth ?timeout ~path_params ~method_:`PATCH url 672 799 673 - let delete t ?headers ?auth ?timeout url = 674 - request t ?headers ?auth ?timeout ~method_:`DELETE url 800 + let delete t ?headers ?auth ?timeout ?(path_params=[]) url = 801 + request t ?headers ?auth ?timeout ~path_params ~method_:`DELETE url 675 802 676 - let head t ?headers ?auth ?timeout url = 677 - request t ?headers ?auth ?timeout ~method_:`HEAD url 803 + let head t ?headers ?auth ?timeout ?(path_params=[]) url = 804 + request t ?headers ?auth ?timeout ~path_params ~method_:`HEAD url 678 805 679 - let options t ?headers ?auth ?timeout url = 680 - request t ?headers ?auth ?timeout ~method_:`OPTIONS url 806 + let options t ?headers ?auth ?timeout ?(path_params=[]) url = 807 + request t ?headers ?auth ?timeout ~path_params ~method_:`OPTIONS url 681 808 682 809 (* Cmdliner integration module *) 683 810 module Cmd = struct
+26 -2
lib/requests.mli
··· 240 240 ?auto_decompress:bool -> 241 241 ?expect_100_continue:bool -> 242 242 ?expect_100_continue_threshold:int64 -> 243 + ?base_url:string -> 244 + ?xsrf_cookie_name:string option -> 245 + ?xsrf_header_name:string -> 243 246 < clock: _ Eio.Time.clock; net: _ Eio.Net.t; fs: Eio.Fs.dir_ty Eio.Path.t; .. > -> 244 247 t 245 248 (** Create a new requests instance with persistent state and connection pooling. ··· 266 269 @param auto_decompress Whether to automatically decompress gzip/deflate responses (default: true) 267 270 @param expect_100_continue Whether to use HTTP 100-continue for large uploads (default: true) 268 271 @param expect_100_continue_threshold Body size threshold to trigger 100-continue in bytes (default: 1MB) 272 + @param base_url Base URL for relative paths (per Recommendation #11). Relative URLs are resolved against this. 273 + @param xsrf_cookie_name Cookie name to extract XSRF token from (default: Some "XSRF-TOKEN", per Recommendation #24). Set to None to disable. 274 + @param xsrf_header_name Header name to inject XSRF token into (default: "X-XSRF-TOKEN") 269 275 270 276 {b Note:} HTTP caching has been disabled for simplicity. See CACHEIO.md for integration notes 271 277 if you need to restore caching functionality in the future. ··· 377 383 ?timeout:Timeout.t -> 378 384 ?follow_redirects:bool -> 379 385 ?max_redirects:int -> 386 + ?path_params:(string * string) list -> 380 387 method_:Method.t -> 381 388 string -> 382 389 Response.t 383 - (** Make a concurrent HTTP request *) 390 + (** Make a concurrent HTTP request. 391 + @param path_params List of (key, value) pairs for URL template substitution (per Recommendation #29). 392 + Example: [request ~path_params:[("id", "123")] ~method_:`GET "/users/{id}"] *) 384 393 385 394 val get : 386 395 t -> ··· 388 397 ?auth:Auth.t -> 389 398 ?timeout:Timeout.t -> 390 399 ?params:(string * string) list -> 400 + ?path_params:(string * string) list -> 391 401 string -> 392 402 Response.t 393 - (** Concurrent GET request *) 403 + (** Concurrent GET request. 404 + @param params Query parameters to append to URL 405 + @param path_params Path template substitutions (e.g., ["/users/{id}"] with [("id", "123")]) *) 394 406 395 407 val post : 396 408 t -> ··· 398 410 ?body:Body.t -> 399 411 ?auth:Auth.t -> 400 412 ?timeout:Timeout.t -> 413 + ?path_params:(string * string) list -> 401 414 string -> 402 415 Response.t 403 416 (** Concurrent POST request *) ··· 408 421 ?body:Body.t -> 409 422 ?auth:Auth.t -> 410 423 ?timeout:Timeout.t -> 424 + ?path_params:(string * string) list -> 411 425 string -> 412 426 Response.t 413 427 (** Concurrent PUT request *) ··· 418 432 ?body:Body.t -> 419 433 ?auth:Auth.t -> 420 434 ?timeout:Timeout.t -> 435 + ?path_params:(string * string) list -> 421 436 string -> 422 437 Response.t 423 438 (** Concurrent PATCH request *) ··· 427 442 ?headers:Headers.t -> 428 443 ?auth:Auth.t -> 429 444 ?timeout:Timeout.t -> 445 + ?path_params:(string * string) list -> 430 446 string -> 431 447 Response.t 432 448 (** Concurrent DELETE request *) ··· 436 452 ?headers:Headers.t -> 437 453 ?auth:Auth.t -> 438 454 ?timeout:Timeout.t -> 455 + ?path_params:(string * string) list -> 439 456 string -> 440 457 Response.t 441 458 (** Concurrent HEAD request *) ··· 445 462 ?headers:Headers.t -> 446 463 ?auth:Auth.t -> 447 464 ?timeout:Timeout.t -> 465 + ?path_params:(string * string) list -> 448 466 string -> 449 467 Response.t 450 468 (** Concurrent OPTIONS request *) ··· 713 731 714 732 (** HTTP 100-Continue configuration for large uploads *) 715 733 module Expect_continue = Expect_continue 734 + 735 + (** HTTP Link header parsing (RFC 8288) for pagination and API discovery *) 736 + module Link = Link 737 + 738 + (** HTTP request timing metrics for performance analysis *) 739 + module Timing = Timing 716 740 717 741 (** {2 Logging} *) 718 742
+48 -2
lib/retry.ml
··· 6 6 let src = Logs.Src.create "requests.retry" ~doc:"HTTP Request Retry Logic" 7 7 module Log = (val Logs.src_log src : Logs.LOG) 8 8 9 + (** Custom retry predicate for responses. 10 + Per Recommendation #14: Allow user-defined retry logic. 11 + The predicate receives (method, status, headers) and returns true to retry. 12 + This runs in addition to the built-in status_forcelist check. *) 13 + type response_predicate = Method.t -> int -> Headers.t -> bool 14 + 15 + (** Custom retry predicate for exceptions. 16 + Returns true if the exception should trigger a retry. *) 17 + type exception_predicate = exn -> bool 18 + 9 19 type config = { 10 20 max_retries : int; 11 21 backoff_factor : float; ··· 14 24 allowed_methods : Method.t list; 15 25 respect_retry_after : bool; 16 26 jitter : bool; 27 + retry_response : response_predicate option; (** Per Recommendation #14 *) 28 + retry_exception : exception_predicate option; (** Per Recommendation #14 *) 17 29 } 18 30 19 31 let default_config = { ··· 24 36 allowed_methods = [`GET; `HEAD; `PUT; `DELETE; `OPTIONS; `TRACE]; 25 37 respect_retry_after = true; 26 38 jitter = true; 39 + retry_response = None; 40 + retry_exception = None; 27 41 } 28 42 29 43 let create_config ··· 34 48 ?(allowed_methods = [`GET; `HEAD; `PUT; `DELETE; `OPTIONS; `TRACE]) 35 49 ?(respect_retry_after = true) 36 50 ?(jitter = true) 51 + ?retry_response 52 + ?retry_exception 37 53 () = 38 - Log.debug (fun m -> m "Creating retry config: max_retries=%d backoff_factor=%.2f" 39 - max_retries backoff_factor); 54 + Log.debug (fun m -> m "Creating retry config: max_retries=%d backoff_factor=%.2f custom_predicates=%b" 55 + max_retries backoff_factor (Option.is_some retry_response || Option.is_some retry_exception)); 40 56 { 41 57 max_retries; 42 58 backoff_factor; ··· 45 61 allowed_methods; 46 62 respect_retry_after; 47 63 jitter; 64 + retry_response; 65 + retry_exception; 48 66 } 49 67 68 + (** Check if a response should be retried based on built-in rules only. 69 + Use [should_retry_response] for full custom predicate support. *) 50 70 let should_retry ~config ~method_ ~status = 51 71 let should = 52 72 List.mem method_ config.allowed_methods && ··· 55 75 Log.debug (fun m -> m "Should retry? method=%s status=%d -> %b" 56 76 (Method.to_string method_) status should); 57 77 should 78 + 79 + (** Check if a response should be retried, including custom predicates. 80 + Per Recommendation #14: User-defined retry logic. 81 + Returns true if either built-in rules or custom predicate says to retry. *) 82 + let should_retry_response ~config ~method_ ~status ~headers = 83 + (* Check built-in rules first *) 84 + let builtin_should_retry = 85 + List.mem method_ config.allowed_methods && 86 + List.mem status config.status_forcelist 87 + in 88 + (* Check custom predicate if provided *) 89 + let custom_should_retry = match config.retry_response with 90 + | Some predicate -> predicate method_ status headers 91 + | None -> false 92 + in 93 + let should = builtin_should_retry || custom_should_retry in 94 + Log.debug (fun m -> m "Should retry response? method=%s status=%d builtin=%b custom=%b -> %b" 95 + (Method.to_string method_) status builtin_should_retry custom_should_retry should); 96 + should 97 + 98 + (** Check if an exception should trigger a retry, including custom predicates. 99 + Per Recommendation #14: User-defined retry logic. *) 100 + let should_retry_exn ~config exn = 101 + match config.retry_exception with 102 + | Some predicate -> predicate exn 103 + | None -> false 58 104 59 105 let calculate_backoff ~config ~attempt = 60 106 let base_delay = config.backoff_factor *. (2.0 ** float_of_int attempt) in
+66 -3
lib/retry.mli
··· 3 3 SPDX-License-Identifier: ISC 4 4 ---------------------------------------------------------------------------*) 5 5 6 - (** HTTP request retry logic with exponential backoff *) 6 + (** HTTP request retry logic with exponential backoff 7 + 8 + This module provides configurable retry logic for HTTP requests, 9 + including exponential backoff, custom retry predicates, and 10 + Retry-After header support. 11 + 12 + {2 Custom Retry Predicates} 13 + 14 + Per Recommendation #14: You can define custom predicates to control 15 + retry behavior beyond the built-in status code and method checks. 16 + 17 + {b Example: Retry on specific error responses} 18 + {[ 19 + let retry_on_rate_limit method_ status headers = 20 + status = 429 && Headers.get "x-retry-allowed" headers = Some "true" 21 + in 22 + let config = Retry.create_config 23 + ~retry_response:retry_on_rate_limit 24 + () 25 + ]} 26 + 27 + {b Example: Retry on custom exceptions} 28 + {[ 29 + let retry_on_network_error = function 30 + | Unix.Unix_error (Unix.ECONNRESET, _, _) -> true 31 + | Unix.Unix_error (Unix.ETIMEDOUT, _, _) -> true 32 + | _ -> false 33 + in 34 + let config = Retry.create_config 35 + ~retry_exception:retry_on_network_error 36 + () 37 + ]} 38 + *) 7 39 8 40 open Eio 9 41 10 42 (** Log source for retry operations *) 11 43 val src : Logs.Src.t 12 44 45 + (** {1 Custom Retry Predicates} 46 + 47 + Per Recommendation #14: Allow user-defined retry logic. *) 48 + 49 + (** Custom retry predicate for responses. 50 + Receives (method, status, headers) and returns true to retry. 51 + This runs in addition to the built-in status_forcelist check. *) 52 + type response_predicate = Method.t -> int -> Headers.t -> bool 53 + 54 + (** Custom retry predicate for exceptions. 55 + Returns true if the exception should trigger a retry. *) 56 + type exception_predicate = exn -> bool 57 + 58 + (** {1 Configuration} *) 59 + 13 60 (** Retry configuration *) 14 61 type config = { 15 62 max_retries : int; (** Maximum number of retry attempts *) ··· 19 66 allowed_methods : Method.t list; (** Methods safe to retry *) 20 67 respect_retry_after : bool; (** Honor Retry-After response header *) 21 68 jitter : bool; (** Add randomness to prevent thundering herd *) 69 + retry_response : response_predicate option; (** Custom response retry predicate *) 70 + retry_exception : exception_predicate option; (** Custom exception retry predicate *) 22 71 } 23 72 24 73 (** Default retry configuration *) 25 74 val default_config : config 26 75 27 - (** Create a custom retry configuration *) 76 + (** Create a custom retry configuration. 77 + @param retry_response Custom predicate for response-based retry decisions 78 + @param retry_exception Custom predicate for exception-based retry decisions *) 28 79 val create_config : 29 80 ?max_retries:int -> 30 81 ?backoff_factor:float -> ··· 33 84 ?allowed_methods:Method.t list -> 34 85 ?respect_retry_after:bool -> 35 86 ?jitter:bool -> 87 + ?retry_response:response_predicate -> 88 + ?retry_exception:exception_predicate -> 36 89 unit -> config 37 90 38 - (** Check if a request should be retried *) 91 + (** {1 Retry Decision Functions} *) 92 + 93 + (** Check if a request should be retried based on built-in rules only. 94 + For full custom predicate support, use [should_retry_response]. *) 39 95 val should_retry : config:config -> method_:Method.t -> status:int -> bool 96 + 97 + (** Check if a response should be retried, including custom predicates. 98 + Returns true if either built-in rules or custom predicate says to retry. *) 99 + val should_retry_response : config:config -> method_:Method.t -> status:int -> headers:Headers.t -> bool 100 + 101 + (** Check if an exception should trigger a retry using custom predicates. *) 102 + val should_retry_exn : config:config -> exn -> bool 40 103 41 104 (** Calculate backoff delay for a given attempt *) 42 105 val calculate_backoff : config:config -> attempt:int -> float
+177
lib/timing.ml
··· 1 + (*--------------------------------------------------------------------------- 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 + SPDX-License-Identifier: ISC 4 + ---------------------------------------------------------------------------*) 5 + 6 + (** HTTP request timing metrics 7 + 8 + Per Recommendation #12: Detailed timing breakdown for requests, 9 + similar to curl's --write-out timing variables. 10 + 11 + Timing phases: 12 + {[ 13 + |--DNS--|--Connect--|--TLS--|--Request--|--Wait--|--Content--| 14 + ^ ^ ^ ^ ^ ^ 15 + namelookup connect ssl_handsh send ttfb total 16 + ]} 17 + *) 18 + 19 + let src = Logs.Src.create "requests.timing" ~doc:"HTTP request timing" 20 + module Log = (val Logs.src_log src : Logs.LOG) 21 + 22 + (** Timing metrics for a single request *) 23 + type t = { 24 + dns_lookup : float option; (** Time for DNS resolution *) 25 + tcp_connect : float option; (** Time to establish TCP connection *) 26 + tls_handshake : float option; (** Time for TLS handshake (HTTPS only) *) 27 + request_sent : float option; (** Time to send request *) 28 + time_to_first_byte : float option; (** Time from request sent to first byte received *) 29 + content_transfer : float option; (** Time to transfer response body *) 30 + total : float; (** Total request time *) 31 + } 32 + 33 + let empty = { 34 + dns_lookup = None; 35 + tcp_connect = None; 36 + tls_handshake = None; 37 + request_sent = None; 38 + time_to_first_byte = None; 39 + content_transfer = None; 40 + total = 0.0; 41 + } 42 + 43 + let make 44 + ?dns_lookup 45 + ?tcp_connect 46 + ?tls_handshake 47 + ?request_sent 48 + ?time_to_first_byte 49 + ?content_transfer 50 + ~total 51 + () = 52 + { dns_lookup; tcp_connect; tls_handshake; request_sent; 53 + time_to_first_byte; content_transfer; total } 54 + 55 + let dns_lookup t = t.dns_lookup 56 + let tcp_connect t = t.tcp_connect 57 + let tls_handshake t = t.tls_handshake 58 + let request_sent t = t.request_sent 59 + let time_to_first_byte t = t.time_to_first_byte 60 + let content_transfer t = t.content_transfer 61 + let total t = t.total 62 + 63 + (** Connection setup time (DNS + TCP + TLS) *) 64 + let connection_time t = 65 + let dns = Option.value t.dns_lookup ~default:0.0 in 66 + let tcp = Option.value t.tcp_connect ~default:0.0 in 67 + let tls = Option.value t.tls_handshake ~default:0.0 in 68 + Some (dns +. tcp +. tls) 69 + 70 + (** Server processing time (TTFB - request send time) *) 71 + let server_time t = 72 + match t.time_to_first_byte, t.request_sent with 73 + | Some ttfb, Some send -> Some (ttfb -. send) 74 + | _ -> None 75 + 76 + (** Pretty-print timing in human readable format *) 77 + let pp ppf t = 78 + let pp_opt ppf = function 79 + | Some v -> Format.fprintf ppf "%.3fms" (v *. 1000.0) 80 + | None -> Format.fprintf ppf "-" 81 + in 82 + Format.fprintf ppf "@[<v>Timing:@,\ 83 + DNS lookup: %a@,\ 84 + TCP connect: %a@,\ 85 + TLS handshake: %a@,\ 86 + Request sent: %a@,\ 87 + Time to 1st byte: %a@,\ 88 + Content transfer: %a@,\ 89 + Total: %.3fms@]" 90 + pp_opt t.dns_lookup 91 + pp_opt t.tcp_connect 92 + pp_opt t.tls_handshake 93 + pp_opt t.request_sent 94 + pp_opt t.time_to_first_byte 95 + pp_opt t.content_transfer 96 + (t.total *. 1000.0) 97 + 98 + let to_string t = 99 + Format.asprintf "%a" pp t 100 + 101 + (** Convert to JSON-like association list for logging/debugging *) 102 + let to_assoc t = 103 + let add_opt name = function 104 + | Some v -> [(name, v)] 105 + | None -> [] 106 + in 107 + add_opt "dns_lookup" t.dns_lookup @ 108 + add_opt "tcp_connect" t.tcp_connect @ 109 + add_opt "tls_handshake" t.tls_handshake @ 110 + add_opt "request_sent" t.request_sent @ 111 + add_opt "time_to_first_byte" t.time_to_first_byte @ 112 + add_opt "content_transfer" t.content_transfer @ 113 + [("total", t.total)] 114 + 115 + (** {1 Timer for Collecting Metrics} 116 + 117 + Use this during request execution to collect timing data. *) 118 + 119 + type timer = { 120 + start : float; 121 + mutable dns_end : float option; 122 + mutable connect_end : float option; 123 + mutable tls_end : float option; 124 + mutable send_end : float option; 125 + mutable ttfb : float option; 126 + mutable transfer_end : float option; 127 + } 128 + 129 + let start () = 130 + { start = Unix.gettimeofday (); 131 + dns_end = None; 132 + connect_end = None; 133 + tls_end = None; 134 + send_end = None; 135 + ttfb = None; 136 + transfer_end = None; 137 + } 138 + 139 + let mark_dns timer = 140 + timer.dns_end <- Some (Unix.gettimeofday ()) 141 + 142 + let mark_connect timer = 143 + timer.connect_end <- Some (Unix.gettimeofday ()) 144 + 145 + let mark_tls timer = 146 + timer.tls_end <- Some (Unix.gettimeofday ()) 147 + 148 + let mark_send timer = 149 + timer.send_end <- Some (Unix.gettimeofday ()) 150 + 151 + let mark_ttfb timer = 152 + timer.ttfb <- Some (Unix.gettimeofday ()) 153 + 154 + let mark_transfer_end timer = 155 + timer.transfer_end <- Some (Unix.gettimeofday ()) 156 + 157 + let finish timer = 158 + let now = Unix.gettimeofday () in 159 + let total = now -. timer.start in 160 + 161 + let calc_phase start_time end_time = 162 + Option.map (fun e -> e -. Option.value start_time ~default:timer.start) end_time 163 + in 164 + 165 + { 166 + dns_lookup = calc_phase (Some timer.start) timer.dns_end; 167 + tcp_connect = calc_phase timer.dns_end timer.connect_end; 168 + tls_handshake = calc_phase timer.connect_end timer.tls_end; 169 + request_sent = calc_phase (if Option.is_some timer.tls_end then timer.tls_end else timer.connect_end) timer.send_end; 170 + time_to_first_byte = calc_phase timer.send_end timer.ttfb; 171 + content_transfer = calc_phase timer.ttfb timer.transfer_end; 172 + total; 173 + } 174 + 175 + (** Log timing metrics *) 176 + let log_timing ?(level=Logs.Debug) t = 177 + Log.msg level (fun m -> m "%a" pp t)
+151
lib/timing.mli
··· 1 + (*--------------------------------------------------------------------------- 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 + SPDX-License-Identifier: ISC 4 + ---------------------------------------------------------------------------*) 5 + 6 + (** HTTP request timing metrics 7 + 8 + Per Recommendation #12: Detailed timing breakdown for requests, 9 + similar to curl's --write-out timing variables. 10 + 11 + {2 Timing Phases} 12 + 13 + {[ 14 + |--DNS--|--Connect--|--TLS--|--Request--|--Wait--|--Content--| 15 + ^ ^ ^ ^ ^ ^ 16 + namelookup connect ssl_handsh send ttfb total 17 + ]} 18 + 19 + {2 Example Usage} 20 + 21 + {[ 22 + (* Start timing *) 23 + let timer = Timing.start () in 24 + 25 + (* DNS resolution *) 26 + let addrs = Eio.Net.getaddrinfo_stream net host in 27 + Timing.mark_dns timer; 28 + 29 + (* TCP connect *) 30 + let flow = Eio.Net.connect ~sw net addr in 31 + Timing.mark_connect timer; 32 + 33 + (* TLS handshake (for HTTPS) *) 34 + let tls_flow = Tls_eio.client_of_flow tls_cfg flow in 35 + Timing.mark_tls timer; 36 + 37 + (* Send request *) 38 + send_request tls_flow request; 39 + Timing.mark_send timer; 40 + 41 + (* First byte received *) 42 + Timing.mark_ttfb timer; 43 + 44 + (* Complete transfer *) 45 + Timing.mark_transfer_end timer; 46 + 47 + (* Get timing metrics *) 48 + let metrics = Timing.finish timer in 49 + Printf.printf "Total: %.3fms\n" (Timing.total metrics *. 1000.0) 50 + ]} 51 + *) 52 + 53 + (** {1 Timing Metrics} *) 54 + 55 + type t 56 + (** Timing metrics for a completed request *) 57 + 58 + val empty : t 59 + (** Empty timing with all phases unknown *) 60 + 61 + val make : 62 + ?dns_lookup:float -> 63 + ?tcp_connect:float -> 64 + ?tls_handshake:float -> 65 + ?request_sent:float -> 66 + ?time_to_first_byte:float -> 67 + ?content_transfer:float -> 68 + total:float -> 69 + unit -> t 70 + (** Create timing metrics manually *) 71 + 72 + (** {2 Accessors} *) 73 + 74 + val dns_lookup : t -> float option 75 + (** Time for DNS resolution in seconds *) 76 + 77 + val tcp_connect : t -> float option 78 + (** Time to establish TCP connection in seconds *) 79 + 80 + val tls_handshake : t -> float option 81 + (** Time for TLS handshake in seconds (HTTPS only) *) 82 + 83 + val request_sent : t -> float option 84 + (** Time to send request in seconds *) 85 + 86 + val time_to_first_byte : t -> float option 87 + (** Time from request sent to first response byte in seconds *) 88 + 89 + val content_transfer : t -> float option 90 + (** Time to transfer response body in seconds *) 91 + 92 + val total : t -> float 93 + (** Total request time in seconds *) 94 + 95 + (** {2 Computed Metrics} *) 96 + 97 + val connection_time : t -> float option 98 + (** Total connection setup time (DNS + TCP + TLS) *) 99 + 100 + val server_time : t -> float option 101 + (** Server processing time (TTFB - request send time) *) 102 + 103 + (** {2 Formatting} *) 104 + 105 + val pp : Format.formatter -> t -> unit 106 + (** Pretty-print timing in human readable format *) 107 + 108 + val to_string : t -> string 109 + (** Convert to string representation *) 110 + 111 + val to_assoc : t -> (string * float) list 112 + (** Convert to association list for logging/serialization *) 113 + 114 + (** {1 Timer for Collecting Metrics} 115 + 116 + Use this during request execution to collect timing data incrementally. *) 117 + 118 + type timer 119 + (** Mutable timer for collecting metrics during request execution *) 120 + 121 + val start : unit -> timer 122 + (** Start a new timer *) 123 + 124 + val mark_dns : timer -> unit 125 + (** Mark DNS resolution complete *) 126 + 127 + val mark_connect : timer -> unit 128 + (** Mark TCP connection established *) 129 + 130 + val mark_tls : timer -> unit 131 + (** Mark TLS handshake complete *) 132 + 133 + val mark_send : timer -> unit 134 + (** Mark request fully sent *) 135 + 136 + val mark_ttfb : timer -> unit 137 + (** Mark first response byte received *) 138 + 139 + val mark_transfer_end : timer -> unit 140 + (** Mark response body transfer complete *) 141 + 142 + val finish : timer -> t 143 + (** Stop timer and compute final timing metrics *) 144 + 145 + (** {1 Logging} *) 146 + 147 + val src : Logs.Src.t 148 + (** Log source for timing operations *) 149 + 150 + val log_timing : ?level:Logs.level -> t -> unit 151 + (** Log timing metrics at specified level (default: Debug) *)