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