My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** OCaml HTTP client library with streaming support *)
2
3let src = Logs.Src.create "requests" ~doc:"HTTP Client Library"
4module Log = (val Logs.src_log src : Logs.LOG)
5
6module Method = Method
7module Mime = Mime
8module Headers = Headers
9module Auth = Auth
10module Timeout = Timeout
11module Body = Body
12module Response = Response
13module One = One
14module Status = Status
15module Error = Error
16module Retry = Retry
17
18(* Note: RNG initialization should be done by the application using
19 Mirage_crypto_rng_unix.initialize before calling Eio_main.run.
20 We don't call use_default() here as it spawns background threads
21 that are incompatible with Eio's structured concurrency. *)
22
23(* Main API - Session functionality with connection pooling *)
24
25type ('clock, 'net) t = {
26 sw : Eio.Switch.t;
27 clock : 'clock;
28 net : 'net;
29 http_pool : ('clock, 'net) Conpool.t;
30 https_pool : ('clock, 'net) Conpool.t;
31 cookie_jar : Cookeio.jar;
32 cookie_mutex : Eio.Mutex.t;
33 default_headers : Headers.t;
34 auth : Auth.t option;
35 timeout : Timeout.t;
36 follow_redirects : bool;
37 max_redirects : int;
38 verify_tls : bool;
39 tls_config : Tls.Config.client option;
40 retry : Retry.config option;
41 persist_cookies : bool;
42 xdg : Xdge.t option;
43
44 (* Statistics - mutable for tracking across all derived sessions *)
45 mutable requests_made : int;
46 mutable total_time : float;
47 mutable retries_count : int;
48}
49
50let create
51 ~sw
52 ?http_pool
53 ?https_pool
54 ?cookie_jar
55 ?(default_headers = Headers.empty)
56 ?auth
57 ?(timeout = Timeout.default)
58 ?(follow_redirects = true)
59 ?(max_redirects = 10)
60 ?(verify_tls = true)
61 ?tls_config
62 ?(max_connections_per_host = 10)
63 ?(connection_idle_timeout = 60.0)
64 ?(connection_lifetime = 300.0)
65 ?retry
66 ?(persist_cookies = false)
67 ?xdg
68 env =
69
70 let clock = env#clock in
71 let net = env#net in
72
73 let xdg = match xdg, persist_cookies with
74 | Some x, _ -> Some x
75 | None, true -> Some (Xdge.create env#fs "requests")
76 | None, false -> None
77 in
78
79 (* Create TLS config for HTTPS pool if needed *)
80 let tls_config = match tls_config, verify_tls with
81 | Some cfg, _ -> Some cfg
82 | None, true ->
83 (* Use CA certificates for verification *)
84 (match Ca_certs.authenticator () with
85 | Ok authenticator ->
86 (match Tls.Config.client ~authenticator () with
87 | Ok cfg -> Some cfg
88 | Error (`Msg msg) ->
89 Log.warn (fun m -> m "Failed to create TLS config: %s" msg);
90 None)
91 | Error (`Msg msg) ->
92 Log.warn (fun m -> m "Failed to load CA certificates: %s" msg);
93 None)
94 | None, false -> None
95 in
96
97 (* Create connection pools if not provided *)
98 let pool_config = Conpool.Config.make
99 ~max_connections_per_endpoint:max_connections_per_host
100 ~max_idle_time:connection_idle_timeout
101 ~max_connection_lifetime:connection_lifetime
102 ()
103 in
104
105 (* HTTP pool - plain TCP connections *)
106 let http_pool = match http_pool with
107 | Some p -> p
108 | None ->
109 Conpool.create ~sw ~net ~clock ~config:pool_config ()
110 in
111
112 (* HTTPS pool - TLS-wrapped connections *)
113 let https_pool = match https_pool with
114 | Some p -> p
115 | None ->
116 let https_tls_config = Option.map (fun cfg ->
117 Conpool.Tls_config.make ~config:cfg ()
118 ) tls_config in
119 Conpool.create ~sw ~net ~clock ?tls:https_tls_config ~config:pool_config ()
120 in
121
122 Log.info (fun m -> m "Created Requests session with connection pools (max_per_host=%d, TLS=%b)"
123 max_connections_per_host (Option.is_some tls_config));
124
125 let cookie_jar = match cookie_jar, persist_cookies, xdg with
126 | Some jar, _, _ -> jar
127 | None, true, Some xdg_ctx ->
128 let data_dir = Xdge.data_dir xdg_ctx in
129 let cookie_file = Eio.Path.(data_dir / "cookies.txt") in
130 Cookeio.load cookie_file
131 | None, _, _ ->
132 Cookeio.create ()
133 in
134
135 {
136 sw;
137 clock;
138 net;
139 http_pool;
140 https_pool;
141 cookie_jar;
142 cookie_mutex = Eio.Mutex.create ();
143 default_headers;
144 auth;
145 timeout;
146 follow_redirects;
147 max_redirects;
148 verify_tls;
149 tls_config;
150 retry;
151 persist_cookies;
152 xdg;
153 requests_made = 0;
154 total_time = 0.0;
155 retries_count = 0;
156 }
157
158let set_default_header t key value =
159 { t with default_headers = Headers.set key value t.default_headers }
160
161let remove_default_header t key =
162 { t with default_headers = Headers.remove key t.default_headers }
163
164let set_auth t auth =
165 Log.debug (fun m -> m "Setting authentication method");
166 { t with auth = Some auth }
167
168let clear_auth t =
169 Log.debug (fun m -> m "Clearing authentication");
170 { t with auth = None }
171
172let set_timeout t timeout =
173 Log.debug (fun m -> m "Setting timeout: %a" Timeout.pp timeout);
174 { t with timeout }
175
176let set_retry t config =
177 Log.debug (fun m -> m "Setting retry config: max_retries=%d" config.Retry.max_retries);
178 { t with retry = Some config }
179
180let cookies t = t.cookie_jar
181let clear_cookies t = Cookeio.clear t.cookie_jar
182
183(* Internal request function using connection pools *)
184let make_request_internal t ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =
185 let start_time = Unix.gettimeofday () in
186 let method_str = Method.to_string method_ in
187
188 Log.info (fun m -> m "Making %s request to %s" method_str url);
189
190 (* Parse URL *)
191 let uri = Uri.of_string url in
192 let domain = Option.value ~default:"" (Uri.host uri) in
193 let path = Uri.path uri in
194 let is_secure = Uri.scheme uri = Some "https" in
195
196 (* Merge headers *)
197 let headers = match headers with
198 | Some h -> Headers.merge t.default_headers h
199 | None -> t.default_headers
200 in
201
202 (* Use provided auth or default *)
203 let auth = match auth with
204 | Some a -> Some a
205 | None -> t.auth
206 in
207
208 (* Apply auth *)
209 let headers = match auth with
210 | Some a ->
211 Log.debug (fun m -> m "Applying authentication");
212 Auth.apply a headers
213 | None -> headers
214 in
215
216 (* Add content type from body *)
217 let headers = match body with
218 | Some b -> (match Body.content_type b with
219 | Some mime -> Headers.content_type mime headers
220 | None -> headers)
221 | None -> headers
222 in
223
224 (* Get cookies for this URL *)
225 let headers =
226 Eio.Mutex.use_ro t.cookie_mutex (fun () ->
227 let cookies = Cookeio.get_cookies t.cookie_jar ~domain ~path ~is_secure in
228 match cookies with
229 | [] -> headers
230 | cookies ->
231 Log.debug (fun m -> m "Adding %d cookies for %s%s" (List.length cookies) domain path);
232 let cookie_header = Cookeio.make_cookie_header cookies in
233 Headers.set "Cookie" cookie_header headers
234 )
235 in
236
237 (* Convert body to string for sending *)
238 let request_body_str = match body with
239 | None -> ""
240 | Some b -> Body.Private.to_string b
241 in
242
243 let response =
244
245 (* Execute request with redirect handling *)
246 let rec make_with_redirects url_to_fetch redirects_left =
247 let uri_to_fetch = Uri.of_string url_to_fetch in
248
249 (* Parse the redirect URL to get correct host and port *)
250 let redirect_host = match Uri.host uri_to_fetch with
251 | Some h -> h
252 | None -> failwith "Redirect URL must contain a host"
253 in
254 let redirect_port = match Uri.scheme uri_to_fetch, Uri.port uri_to_fetch with
255 | Some "https", None -> 443
256 | Some "https", Some p -> p
257 | Some "http", None -> 80
258 | Some "http", Some p -> p
259 | _, Some p -> p
260 | _ -> 80
261 in
262
263 (* Create endpoint for this specific URL *)
264 let redirect_endpoint = Conpool.Endpoint.make ~host:redirect_host ~port:redirect_port in
265
266 (* Determine if we need TLS based on this URL's scheme *)
267 let redirect_is_https = match Uri.scheme uri_to_fetch with
268 | Some "https" -> true
269 | _ -> false
270 in
271
272 (* Choose the appropriate connection pool for this URL *)
273 let redirect_pool = if redirect_is_https then t.https_pool else t.http_pool in
274
275 let make_request_fn () =
276 Conpool.with_connection redirect_pool redirect_endpoint (fun flow ->
277 (* Flow is already TLS-wrapped if from https_pool, plain TCP if from http_pool *)
278 (* Use our low-level HTTP client *)
279 Http_client.make_request ~method_:method_str ~uri:uri_to_fetch
280 ~headers ~body_str:request_body_str flow
281 )
282 in
283
284 (* Apply timeout if specified *)
285 let status, resp_headers, response_body_str =
286 let timeout_val = Option.value timeout ~default:t.timeout in
287 match Timeout.total timeout_val with
288 | Some seconds ->
289 Log.debug (fun m -> m "Setting timeout: %.2f seconds" seconds);
290 Eio.Time.with_timeout_exn t.clock seconds make_request_fn
291 | None -> make_request_fn ()
292 in
293
294 Log.info (fun m -> m "Received response: status=%d" status);
295
296 (* Handle redirects if enabled *)
297 let follow = Option.value follow_redirects ~default:t.follow_redirects in
298 let max_redir = Option.value max_redirects ~default:t.max_redirects in
299
300 if follow && (status >= 300 && status < 400) then begin
301 if redirects_left <= 0 then begin
302 Log.err (fun m -> m "Too many redirects (%d) for %s" max_redir url);
303 raise (Error.TooManyRedirects { url; count = max_redir; max = max_redir })
304 end;
305
306 match Headers.get "location" resp_headers with
307 | None ->
308 Log.debug (fun m -> m "Redirect response missing Location header");
309 (status, resp_headers, response_body_str, url_to_fetch)
310 | Some location ->
311 Log.info (fun m -> m "Following redirect to %s (%d remaining)" location redirects_left);
312 make_with_redirects location (redirects_left - 1)
313 end else
314 (status, resp_headers, response_body_str, url_to_fetch)
315 in
316
317 let max_redir = Option.value max_redirects ~default:t.max_redirects in
318 let final_status, final_headers, final_body_str, final_url =
319 make_with_redirects url max_redir
320 in
321
322 let elapsed = Unix.gettimeofday () -. start_time in
323 Log.info (fun m -> m "Request completed in %.3f seconds" elapsed);
324
325 (* Create a flow from the body string *)
326 let body_flow = Eio.Flow.string_source final_body_str in
327
328 Response.Private.make
329 ~sw:t.sw
330 ~status:final_status
331 ~headers:final_headers
332 ~body:body_flow
333 ~url:final_url
334 ~elapsed
335 in
336
337 (* Extract and store cookies from response *)
338 let () =
339 Eio.Mutex.use_rw ~protect:true t.cookie_mutex (fun () ->
340 match Response.headers response |> Headers.get_all "Set-Cookie" with
341 | [] -> ()
342 | cookie_headers ->
343 Log.debug (fun m -> m "Received %d Set-Cookie headers" (List.length cookie_headers));
344 List.iter (fun cookie_str ->
345 match Cookeio.parse_set_cookie ~domain ~path cookie_str with
346 | Some cookie ->
347 Log.debug (fun m -> m "Storing cookie");
348 Cookeio.add_cookie t.cookie_jar cookie
349 | None ->
350 Log.warn (fun m -> m "Failed to parse cookie: %s" cookie_str)
351 ) cookie_headers
352 )
353 in
354
355 (* Update statistics *)
356 t.requests_made <- t.requests_made + 1;
357 t.total_time <- t.total_time +. (Unix.gettimeofday () -. start_time);
358 Log.info (fun m -> m "Request completed with status %d" (Response.status_code response));
359
360 response
361
362(* Public request function - executes synchronously *)
363let request t ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =
364 make_request_internal t ?headers ?body ?auth ?timeout
365 ?follow_redirects ?max_redirects ~method_ url
366
367(* Convenience methods *)
368let get t ?headers ?auth ?timeout ?params url =
369 let url = match params with
370 | Some p ->
371 let uri = Uri.of_string url in
372 let uri = List.fold_left (fun u (k, v) -> Uri.add_query_param' u (k, v)) uri p in
373 Uri.to_string uri
374 | None -> url
375 in
376 request t ?headers ?auth ?timeout ~method_:`GET url
377
378let post t ?headers ?body ?auth ?timeout url =
379 request t ?headers ?body ?auth ?timeout ~method_:`POST url
380
381let put t ?headers ?body ?auth ?timeout url =
382 request t ?headers ?body ?auth ?timeout ~method_:`PUT url
383
384let patch t ?headers ?body ?auth ?timeout url =
385 request t ?headers ?body ?auth ?timeout ~method_:`PATCH url
386
387let delete t ?headers ?auth ?timeout url =
388 request t ?headers ?auth ?timeout ~method_:`DELETE url
389
390let head t ?headers ?auth ?timeout url =
391 request t ?headers ?auth ?timeout ~method_:`HEAD url
392
393let options t ?headers ?auth ?timeout url =
394 request t ?headers ?auth ?timeout ~method_:`OPTIONS url
395
396(* Cmdliner integration module *)
397module Cmd = struct
398 open Cmdliner
399
400 type config = {
401 xdg : Xdge.t * Xdge.Cmd.t;
402 persist_cookies : bool;
403 verify_tls : bool;
404 timeout : float option;
405 max_retries : int;
406 retry_backoff : float;
407 follow_redirects : bool;
408 max_redirects : int;
409 user_agent : string option;
410 }
411
412 let create config env sw =
413 let xdg, _xdg_cmd = config.xdg in
414 let retry = if config.max_retries > 0 then
415 Some (Retry.create_config
416 ~max_retries:config.max_retries
417 ~backoff_factor:config.retry_backoff ())
418 else None in
419
420 let timeout = match config.timeout with
421 | Some t -> Timeout.create ~total:t ()
422 | None -> Timeout.default in
423
424 let req = create ~sw
425 ~xdg
426 ~persist_cookies:config.persist_cookies
427 ~verify_tls:config.verify_tls
428 ~timeout
429 ?retry
430 ~follow_redirects:config.follow_redirects
431 ~max_redirects:config.max_redirects
432 env in
433
434 (* Set user agent if provided *)
435 let req = match config.user_agent with
436 | Some ua -> set_default_header req "User-Agent" ua
437 | None -> req
438 in
439
440 req
441
442 (* Individual terms - parameterized by app_name *)
443
444 let persist_cookies_term app_name =
445 let doc = "Persist cookies to disk between sessions" in
446 let env_name = String.uppercase_ascii app_name ^ "_PERSIST_COOKIES" in
447 let env_info = Cmdliner.Cmd.Env.info env_name in
448 Arg.(value & flag & info ["persist-cookies"] ~env:env_info ~doc)
449
450 let verify_tls_term app_name =
451 let doc = "Skip TLS certificate verification (insecure)" in
452 let env_name = String.uppercase_ascii app_name ^ "_NO_VERIFY_TLS" in
453 let env_info = Cmdliner.Cmd.Env.info env_name in
454 Term.(const (fun no_verify -> not no_verify) $
455 Arg.(value & flag & info ["no-verify-tls"] ~env:env_info ~doc))
456
457 let timeout_term app_name =
458 let doc = "Request timeout in seconds" in
459 let env_name = String.uppercase_ascii app_name ^ "_TIMEOUT" in
460 let env_info = Cmdliner.Cmd.Env.info env_name in
461 Arg.(value & opt (some float) None & info ["timeout"] ~env:env_info ~docv:"SECONDS" ~doc)
462
463 let retries_term app_name =
464 let doc = "Maximum number of request retries" in
465 let env_name = String.uppercase_ascii app_name ^ "_MAX_RETRIES" in
466 let env_info = Cmdliner.Cmd.Env.info env_name in
467 Arg.(value & opt int 3 & info ["max-retries"] ~env:env_info ~docv:"N" ~doc)
468
469 let retry_backoff_term app_name =
470 let doc = "Retry backoff factor for exponential delay" in
471 let env_name = String.uppercase_ascii app_name ^ "_RETRY_BACKOFF" in
472 let env_info = Cmdliner.Cmd.Env.info env_name in
473 Arg.(value & opt float 0.3 & info ["retry-backoff"] ~env:env_info ~docv:"FACTOR" ~doc)
474
475 let follow_redirects_term app_name =
476 let doc = "Don't follow HTTP redirects" in
477 let env_name = String.uppercase_ascii app_name ^ "_NO_FOLLOW_REDIRECTS" in
478 let env_info = Cmdliner.Cmd.Env.info env_name in
479 Term.(const (fun no_follow -> not no_follow) $
480 Arg.(value & flag & info ["no-follow-redirects"] ~env:env_info ~doc))
481
482 let max_redirects_term app_name =
483 let doc = "Maximum number of redirects to follow" in
484 let env_name = String.uppercase_ascii app_name ^ "_MAX_REDIRECTS" in
485 let env_info = Cmdliner.Cmd.Env.info env_name in
486 Arg.(value & opt int 10 & info ["max-redirects"] ~env:env_info ~docv:"N" ~doc)
487
488 let user_agent_term app_name =
489 let doc = "User-Agent header to send with requests" in
490 let env_name = String.uppercase_ascii app_name ^ "_USER_AGENT" in
491 let env_info = Cmdliner.Cmd.Env.info env_name in
492 Arg.(value & opt (some string) None & info ["user-agent"] ~env:env_info ~docv:"STRING" ~doc)
493
494 (* Combined terms *)
495
496 let config_term app_name fs =
497 let xdg_term = Xdge.Cmd.term app_name fs
498 ~dirs:[`Config; `Data; `Cache] () in
499 Term.(const (fun xdg persist verify timeout retries backoff follow max_redir ua ->
500 { xdg; persist_cookies = persist; verify_tls = verify;
501 timeout; max_retries = retries; retry_backoff = backoff;
502 follow_redirects = follow; max_redirects = max_redir;
503 user_agent = ua })
504 $ xdg_term
505 $ persist_cookies_term app_name
506 $ verify_tls_term app_name
507 $ timeout_term app_name
508 $ retries_term app_name
509 $ retry_backoff_term app_name
510 $ follow_redirects_term app_name
511 $ max_redirects_term app_name
512 $ user_agent_term app_name)
513
514 let requests_term app_name eio_env sw =
515 let config_t = config_term app_name eio_env#fs in
516 Term.(const (fun config -> create config eio_env sw) $ config_t)
517
518 let minimal_term app_name fs =
519 let xdg_term = Xdge.Cmd.term app_name fs
520 ~dirs:[`Data; `Cache] () in
521 Term.(const (fun (xdg, _xdg_cmd) persist -> (xdg, persist))
522 $ xdg_term
523 $ persist_cookies_term app_name)
524
525 let env_docs app_name =
526 let app_upper = String.uppercase_ascii app_name in
527 Printf.sprintf
528 "## ENVIRONMENT\n\n\
529 The following environment variables affect %s:\n\n\
530 **%s_CONFIG_DIR**\n\
531 : Override configuration directory location\n\n\
532 **%s_DATA_DIR**\n\
533 : Override data directory location (for cookies)\n\n\
534 **%s_CACHE_DIR**\n\
535 : Override cache directory location\n\n\
536 **XDG_CONFIG_HOME**\n\
537 : Base directory for user configuration files (default: ~/.config)\n\n\
538 **XDG_DATA_HOME**\n\
539 : Base directory for user data files (default: ~/.local/share)\n\n\
540 **XDG_CACHE_HOME**\n\
541 : Base directory for user cache files (default: ~/.cache)\n\n\
542 **%s_PERSIST_COOKIES**\n\
543 : Set to '1' to persist cookies by default\n\n\
544 **%s_NO_VERIFY_TLS**\n\
545 : Set to '1' to disable TLS verification (insecure)\n\n\
546 **%s_TIMEOUT**\n\
547 : Default request timeout in seconds\n\n\
548 **%s_MAX_RETRIES**\n\
549 : Maximum number of retries (default: 3)\n\n\
550 **%s_RETRY_BACKOFF**\n\
551 : Retry backoff factor (default: 0.3)\n\n\
552 **%s_NO_FOLLOW_REDIRECTS**\n\
553 : Set to '1' to disable redirect following\n\n\
554 **%s_MAX_REDIRECTS**\n\
555 : Maximum redirects to follow (default: 10)\n\n\
556 **%s_USER_AGENT**\n\
557 : User-Agent header to send with requests\
558 "
559 app_name app_upper app_upper app_upper
560 app_upper app_upper app_upper app_upper
561 app_upper app_upper app_upper app_upper
562
563 let pp_config ppf config =
564 let _xdg, xdg_cmd = config.xdg in
565 Format.fprintf ppf "@[<v>Configuration:@,\
566 @[<v 2>XDG:@,%a@]@,\
567 persist_cookies: %b@,\
568 verify_tls: %b@,\
569 timeout: %a@,\
570 max_retries: %d@,\
571 retry_backoff: %.2f@,\
572 follow_redirects: %b@,\
573 max_redirects: %d@,\
574 user_agent: %a@]"
575 Xdge.Cmd.pp xdg_cmd
576 config.persist_cookies
577 config.verify_tls
578 (Format.pp_print_option Format.pp_print_float) config.timeout
579 config.max_retries
580 config.retry_backoff
581 config.follow_redirects
582 config.max_redirects
583 (Format.pp_print_option Format.pp_print_string) config.user_agent
584end