anil.recoil.org
A batteries included HTTP/1.1 client in OCaml
init
+5124
+4
bin/dune
+4
bin/dune
+380
bin/ocurl.ml
+380
bin/ocurl.ml
···
1
+
open Eio
2
+
open Cmdliner
3
+
4
+
(* Command-line options *)
5
+
let http_method =
6
+
let methods = [
7
+
("GET", `GET);
8
+
("POST", `POST);
9
+
("PUT", `PUT);
10
+
("DELETE", `DELETE);
11
+
("HEAD", `HEAD);
12
+
("OPTIONS", `OPTIONS);
13
+
("PATCH", `PATCH);
14
+
] in
15
+
let doc = "HTTP method to use" in
16
+
let env_info = Cmdliner.Cmd.Env.info "OCURL_METHOD" in
17
+
Arg.(value & opt (enum methods) `GET & info ["X"; "request"] ~env:env_info ~docv:"METHOD" ~doc)
18
+
19
+
let urls =
20
+
let doc = "URL(s) to fetch" in
21
+
Arg.(non_empty & pos_all string [] & info [] ~docv:"URL" ~doc)
22
+
23
+
let headers =
24
+
let doc = "Add custom HTTP header (can be used multiple times)" in
25
+
Arg.(value & opt_all string [] & info ["H"; "header"] ~docv:"HEADER" ~doc)
26
+
27
+
let data =
28
+
let doc = "HTTP POST/PUT data" in
29
+
Arg.(value & opt (some string) None & info ["d"; "data"] ~docv:"DATA" ~doc)
30
+
31
+
let json_data =
32
+
let doc = "HTTP POST/PUT JSON data" in
33
+
Arg.(value & opt (some string) None & info ["json"] ~docv:"JSON" ~doc)
34
+
35
+
let output_file =
36
+
let doc = "Write output to file instead of stdout" in
37
+
Arg.(value & opt (some string) None & info ["o"; "output"] ~docv:"FILE" ~doc)
38
+
39
+
let include_headers =
40
+
let doc = "Include response headers in output" in
41
+
Arg.(value & flag & info ["i"; "include"] ~doc)
42
+
43
+
let head =
44
+
let doc = "Show only response headers (no body)" in
45
+
Arg.(value & flag & info ["I"; "head"] ~doc)
46
+
47
+
let auth =
48
+
let doc = "Basic authentication in USER:PASSWORD format" in
49
+
Arg.(value & opt (some string) None & info ["u"; "user"] ~docv:"USER:PASS" ~doc)
50
+
51
+
let show_progress =
52
+
let doc = "Show progress bar for downloads" in
53
+
Arg.(value & flag & info ["progress-bar"] ~doc)
54
+
55
+
(* Logging setup *)
56
+
(* Setup logging using Logs_cli for standard logging options *)
57
+
let setup_log app_name =
58
+
let setup style_renderer level verbose_http =
59
+
Fmt_tty.setup_std_outputs ?style_renderer ();
60
+
Logs.set_level level;
61
+
Logs.set_reporter (Logs_fmt.reporter ());
62
+
Requests.Cmd.setup_log_sources ~verbose_http level
63
+
in
64
+
Term.(const setup $ Fmt_cli.style_renderer () $ Logs_cli.level () $
65
+
Requests.Cmd.verbose_http_term app_name)
66
+
67
+
(* Parse authentication *)
68
+
let parse_auth auth_str =
69
+
match String.split_on_char ':' auth_str with
70
+
| [user; pass] -> Some (user, pass)
71
+
| _ -> None
72
+
73
+
(* Parse headers *)
74
+
let parse_header header_str =
75
+
match String.split_on_char ':' header_str with
76
+
| [] -> None
77
+
| [name] -> Some (String.trim name, "")
78
+
| name :: rest ->
79
+
Some (String.trim name, String.trim (String.concat ":" rest))
80
+
81
+
(* Pretty print response *)
82
+
let pp_response ppf response =
83
+
let status = Requests.Response.status response in
84
+
let status_code = Requests.Response.status_code response in
85
+
let headers = Requests.Response.headers response in
86
+
87
+
(* Color code status *)
88
+
let status_style =
89
+
if Requests.Status.is_success status then Fmt.(styled `Green)
90
+
else if Requests.Status.is_client_error status then Fmt.(styled `Yellow)
91
+
else if Requests.Status.is_server_error status then Fmt.(styled `Red)
92
+
else Fmt.(styled `Blue)
93
+
in
94
+
95
+
(* Print status line *)
96
+
Fmt.pf ppf "@[<v>HTTP/1.1 %d %a@]@."
97
+
status_code
98
+
(status_style Fmt.string) (Requests.Status.reason_phrase status);
99
+
100
+
(* Print headers *)
101
+
let header_list = Requests.Headers.to_list headers in
102
+
List.iter (fun (k, v) ->
103
+
Fmt.pf ppf "@[<h>%a: %s@]@."
104
+
Fmt.(styled `Cyan string) k v
105
+
) header_list;
106
+
107
+
Fmt.pf ppf "@."
108
+
109
+
(* Process a single URL and return result *)
110
+
let process_url env req method_ headers body include_headers head output url_str =
111
+
let quiet = match Logs.level () with Some (Logs.Error | Logs.Warning) -> true | _ -> false in
112
+
let uri = Uri.of_string url_str in
113
+
114
+
if not quiet then begin
115
+
let method_str = Requests.Method.to_string (method_ :> Requests.Method.t) in
116
+
Fmt.pr "@[<v>%a %a@]@."
117
+
Fmt.(styled `Bold string) method_str
118
+
Fmt.(styled `Underline Uri.pp) uri;
119
+
end;
120
+
try
121
+
(* Make request *)
122
+
let response =
123
+
match method_ with
124
+
| `GET -> Requests.get req ~headers url_str
125
+
| `POST -> Requests.post req ~headers ?body url_str
126
+
| `PUT -> Requests.put req ~headers ?body url_str
127
+
| `DELETE -> Requests.delete req ~headers url_str
128
+
| `HEAD -> Requests.head req ~headers url_str
129
+
| `OPTIONS -> Requests.options req ~headers url_str
130
+
| `PATCH -> Requests.patch req ~headers ?body url_str
131
+
in
132
+
133
+
(* Print response headers if requested *)
134
+
if (include_headers || head) && not quiet then
135
+
pp_response Fmt.stdout response;
136
+
137
+
(* If head flag is set, skip body processing *)
138
+
if head then
139
+
Ok (url_str, response)
140
+
else begin
141
+
(* Handle output *)
142
+
let body_flow = Requests.Response.body response in
143
+
144
+
begin match output with
145
+
| Some file -> begin
146
+
let filename =
147
+
if List.length [url_str] > 1 then begin
148
+
let base = Filename.remove_extension file in
149
+
let ext = Filename.extension file in
150
+
let url_hash =
151
+
let full_hash = Digest.string url_str |> Digest.to_hex in
152
+
String.sub full_hash (String.length full_hash - 8) 8 in
153
+
Printf.sprintf "%s-%s%s" base url_hash ext
154
+
end else file
155
+
in
156
+
let () =
157
+
Eio.Path.with_open_out ~create:(`Or_truncate 0o644)
158
+
Eio.Path.(env#fs / filename) @@ fun sink ->
159
+
Eio.Flow.copy body_flow sink in
160
+
let () = if not quiet then
161
+
Fmt.pr "[%s] Saved to %s@." url_str filename else () in
162
+
Ok (url_str, response)
163
+
end
164
+
| None ->
165
+
(* Write to stdout *)
166
+
let buf = Buffer.create 1024 in
167
+
Eio.Flow.copy body_flow (Eio.Flow.buffer_sink buf);
168
+
let body_str = Buffer.contents buf in
169
+
170
+
(* Pretty-print JSON if applicable *)
171
+
if String.length body_str > 0 &&
172
+
(body_str.[0] = '{' || body_str.[0] = '[') then
173
+
try
174
+
match Jsont_bytesrw.decode_string' Jsont.json body_str with
175
+
| Ok json ->
176
+
(match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Jsont.json json with
177
+
| Ok pretty ->
178
+
if not quiet then Fmt.pr "[%s]:@." url_str;
179
+
print_string pretty
180
+
| Error _ ->
181
+
if not quiet then Fmt.pr "[%s]:@." url_str;
182
+
print_string body_str)
183
+
| Error _ ->
184
+
if not quiet then Fmt.pr "[%s]:@." url_str;
185
+
print_string body_str
186
+
with _ ->
187
+
if not quiet then Fmt.pr "[%s]:@." url_str;
188
+
print_string body_str
189
+
else begin
190
+
if not quiet then Fmt.pr "[%s]:@." url_str;
191
+
print_string body_str
192
+
end;
193
+
194
+
if not quiet && Requests.Response.ok response then
195
+
Logs.app (fun m -> m "✓ Success for %s" url_str);
196
+
197
+
Ok (url_str, response)
198
+
end
199
+
end
200
+
with
201
+
| exn ->
202
+
if not quiet then
203
+
Logs.err (fun m -> m "Request failed for %s: %s" url_str (Printexc.to_string exn));
204
+
Error (url_str, exn)
205
+
206
+
(* Main function using Requests with concurrent fetching *)
207
+
let run_request env sw persist_cookies verify_tls timeout follow_redirects max_redirects
208
+
method_ urls headers data json_data output include_headers head
209
+
auth _show_progress () =
210
+
211
+
(* Log levels are already set by setup_log via Logs_cli *)
212
+
213
+
(* Create XDG paths *)
214
+
let xdg = Xdge.create env#fs "ocurl" in
215
+
216
+
(* Create requests instance with configuration *)
217
+
let timeout_obj = Option.map (fun t -> Requests.Timeout.create ~total:t ()) timeout in
218
+
let req = Requests.create ~sw ~xdg ~persist_cookies ~verify_tls
219
+
~follow_redirects ~max_redirects ?timeout:timeout_obj env in
220
+
221
+
(* Set authentication if provided *)
222
+
let req = match auth with
223
+
| Some auth_str ->
224
+
(match parse_auth auth_str with
225
+
| Some (user, pass) ->
226
+
Requests.set_auth req
227
+
(Requests.Auth.basic ~username:user ~password:pass)
228
+
| None ->
229
+
Logs.warn (fun m -> m "Invalid auth format, ignoring");
230
+
req)
231
+
| None -> req
232
+
in
233
+
234
+
(* Build headers from command line *)
235
+
let cmd_headers = List.fold_left (fun hdrs header_str ->
236
+
match parse_header header_str with
237
+
| Some (k, v) -> Requests.Headers.add k v hdrs
238
+
| None -> hdrs
239
+
) Requests.Headers.empty headers in
240
+
241
+
(* Prepare body based on data/json options *)
242
+
let body = match json_data, data with
243
+
| Some json_str, _ ->
244
+
(* Use of_string with JSON mime type for raw JSON string *)
245
+
Some (Requests.Body.of_string Requests.Mime.json json_str)
246
+
| None, Some d -> Some (Requests.Body.text d)
247
+
| None, None -> None
248
+
in
249
+
250
+
(* Process URLs concurrently or sequentially based on count *)
251
+
match urls with
252
+
| [] -> ()
253
+
| [single_url] ->
254
+
(* Single URL - process directly *)
255
+
let _ = process_url env req method_ cmd_headers body include_headers head output single_url in
256
+
()
257
+
| multiple_urls ->
258
+
(* Multiple URLs - process concurrently *)
259
+
let verbose = Logs.level () = Some Logs.Debug || Logs.level () = Some Logs.Info in
260
+
if verbose then
261
+
Fmt.pr "@[<v>Processing %d URLs concurrently...@]@." (List.length multiple_urls);
262
+
263
+
(* Create promises for each URL *)
264
+
let results =
265
+
List.map (fun url_str ->
266
+
let promise, resolver = Eio.Promise.create () in
267
+
(* Fork a fiber for each URL *)
268
+
Fiber.fork ~sw (fun () ->
269
+
let result = process_url env req method_ cmd_headers body include_headers head output url_str in
270
+
Eio.Promise.resolve resolver result
271
+
);
272
+
promise
273
+
) multiple_urls
274
+
in
275
+
276
+
(* Wait for all promises to complete *)
277
+
let completed_results = List.map Eio.Promise.await results in
278
+
279
+
(* Report summary *)
280
+
let quiet = match Logs.level () with Some (Logs.Error | Logs.Warning) -> true | _ -> false in
281
+
if not quiet then begin
282
+
let successes = List.filter Result.is_ok completed_results |> List.length in
283
+
let failures = List.filter Result.is_error completed_results |> List.length in
284
+
Fmt.pr "@[<v>@.Summary: %d successful, %d failed out of %d total@]@."
285
+
successes failures (List.length completed_results);
286
+
287
+
(* Print failed URLs *)
288
+
if failures > 0 then begin
289
+
Fmt.pr "@[<v>Failed URLs:@]@.";
290
+
List.iter (function
291
+
| Error (url, _) -> Fmt.pr " - %s@." url
292
+
| Ok _ -> ()
293
+
) completed_results
294
+
end
295
+
end
296
+
297
+
(* Main entry point *)
298
+
let main method_ urls headers data json_data output include_headers head
299
+
auth show_progress persist_cookies verify_tls
300
+
timeout follow_redirects max_redirects () =
301
+
302
+
Eio_main.run @@ fun env ->
303
+
Mirage_crypto_rng_unix.use_default ();
304
+
Switch.run @@ fun sw ->
305
+
306
+
run_request env sw persist_cookies verify_tls timeout follow_redirects max_redirects
307
+
method_ urls headers data json_data output include_headers head auth
308
+
show_progress ()
309
+
310
+
(* Command-line interface *)
311
+
let cmd =
312
+
let doc = "OCaml HTTP client with concurrent fetching using the Requests library" in
313
+
let man = [
314
+
`S Manpage.s_description;
315
+
`P "$(tname) is a command-line HTTP client written in OCaml that uses the \
316
+
Requests library with stateful request management. It supports various HTTP methods, \
317
+
custom headers, authentication, cookies, and JSON data. When multiple URLs are provided, \
318
+
they are fetched concurrently using Eio fibers for maximum performance.";
319
+
`S Manpage.s_examples;
320
+
`P "Fetch a URL:";
321
+
`Pre " $(tname) https://api.github.com";
322
+
`P "Fetch multiple URLs concurrently:";
323
+
`Pre " $(tname) https://api.github.com https://httpbin.org/get https://example.com";
324
+
`P "Show only response headers (like HEAD request):";
325
+
`Pre " $(tname) -I https://api.github.com";
326
+
`P "Include response headers with body:";
327
+
`Pre " $(tname) -i https://api.github.com";
328
+
`P "POST JSON data:";
329
+
`Pre " $(tname) -X POST --json '{\"key\":\"value\"}' https://httpbin.org/post";
330
+
`P "Download file:";
331
+
`Pre " $(tname) -o file.zip https://example.com/file.zip";
332
+
`P "Download multiple files concurrently:";
333
+
`Pre " $(tname) -o output.json https://api1.example.com https://api2.example.com https://api3.example.com";
334
+
`P "Basic authentication:";
335
+
`Pre " $(tname) -u user:pass https://httpbin.org/basic-auth/user/pass";
336
+
`P "Custom headers:";
337
+
`Pre " $(tname) -H 'Accept: application/json' -H 'X-Api-Key: secret' https://api.example.com";
338
+
`P "With persistent cookies:";
339
+
`Pre " $(tname) --persist-cookies https://example.com";
340
+
`P "Disable TLS verification (insecure):";
341
+
`Pre " $(tname) --no-verify-tls https://self-signed.example.com";
342
+
`S "LOGGING OPTIONS";
343
+
`P "Control logging verbosity using standard options:";
344
+
`P "Enable verbose logging (can be repeated):";
345
+
`Pre " $(tname) -v https://api.github.com # info level";
346
+
`Pre " $(tname) -vv https://api.github.com # debug level (application-level)";
347
+
`P "Enable HTTP protocol-level verbose logging:";
348
+
`Pre " $(tname) -vv --verbose-http https://api.github.com # includes TLS/TCP details";
349
+
`P "Suppress output:";
350
+
`Pre " $(tname) -q https://api.github.com # warnings and errors only";
351
+
`P "Set specific log level:";
352
+
`Pre " $(tname) --verbosity=info https://api.github.com";
353
+
`Pre " $(tname) --verbosity=debug https://api.github.com";
354
+
`Pre " $(tname) --verbosity=error https://api.github.com";
355
+
`P "Available verbosity levels: quiet, error, warning, info, debug";
356
+
`P "The logging system provides detailed information about:";
357
+
`P "- HTTP requests and responses (use -v or -vv for application-level logs)";
358
+
`P "- Authentication and cookie handling";
359
+
`P "- Retry attempts and backoff calculations";
360
+
`P "- TLS/TCP connection details (use --verbose-http with -vv for protocol-level logs)";
361
+
] in
362
+
363
+
(* Build the term with Requests configuration options *)
364
+
let app_name = "ocurl" in
365
+
let combined_term =
366
+
Term.(const main $ http_method $ urls $ headers $ data $ json_data $
367
+
output_file $ include_headers $ head $ auth $
368
+
show_progress $
369
+
Requests.Cmd.persist_cookies_term app_name $
370
+
Requests.Cmd.verify_tls_term app_name $
371
+
Requests.Cmd.timeout_term app_name $
372
+
Requests.Cmd.follow_redirects_term app_name $
373
+
Requests.Cmd.max_redirects_term app_name $
374
+
setup_log app_name)
375
+
in
376
+
377
+
let info = Cmd.info "ocurl" ~version:"2.0.0" ~doc ~man in
378
+
Cmd.v info combined_term
379
+
380
+
let () = exit (Cmd.eval cmd)
+30
dune-project
+30
dune-project
···
1
+
(lang dune 3.0)
2
+
(name requests)
3
+
4
+
(generate_opam_files true)
5
+
6
+
(source
7
+
(github username/requests))
8
+
9
+
(authors "Your Name")
10
+
11
+
(maintainers "Your Name")
12
+
13
+
(license MIT)
14
+
15
+
(package
16
+
(name requests)
17
+
(synopsis "Clean Eio-style HTTPS client library for OCaml")
18
+
(description "A modern HTTP(S) client library for OCaml with Eio support, providing a clean API for making web requests with automatic TLS/CA certificate handling")
19
+
(depends
20
+
ocaml
21
+
(dune (>= 3.0))
22
+
eio
23
+
cohttp-eio
24
+
tls-eio
25
+
ca-certs
26
+
mirage-crypto-rng-eio
27
+
uri
28
+
digestif
29
+
base64
30
+
logs))
+150
examples/session_example.ml
+150
examples/session_example.ml
···
1
+
open Eio
2
+
open Requests
3
+
4
+
let () =
5
+
Eio_main.run @@ fun env ->
6
+
Mirage_crypto_rng_unix.use_default ();
7
+
Switch.run @@ fun sw ->
8
+
9
+
(* Example 1: Basic session usage with cookies *)
10
+
Printf.printf "\n=== Example 1: Basic Session with Cookies ===\n";
11
+
let session = Session.create ~sw env in
12
+
13
+
(* First request sets a cookie *)
14
+
let resp1 = Session.get session "https://httpbin.org/cookies/set?session_id=abc123" in
15
+
Printf.printf "Set cookie response: %d\n" (Response.status resp1);
16
+
17
+
(* Second request automatically includes the cookie *)
18
+
let resp2 = Session.get session "https://httpbin.org/cookies" in
19
+
let body2 = Response.body resp2 |> Buf_read.take_all in
20
+
Printf.printf "Cookies seen by server: %s\n" body2;
21
+
22
+
(* Example 2: Session with default headers and auth *)
23
+
Printf.printf "\n=== Example 2: Session with Default Configuration ===\n";
24
+
let github_session = Session.create ~sw env in
25
+
26
+
(* Set default headers that apply to all requests *)
27
+
Session.set_default_header github_session "User-Agent" "OCaml-Requests-Example/1.0";
28
+
Session.set_default_header github_session "Accept" "application/vnd.github.v3+json";
29
+
30
+
(* Set authentication (if you have a token) *)
31
+
(* Session.set_auth github_session (Auth.bearer "your_github_token"); *)
32
+
33
+
(* All requests will use these defaults *)
34
+
let user = Session.get github_session "https://api.github.com/users/ocaml" in
35
+
Printf.printf "GitHub user status: %d\n" (Response.status user);
36
+
37
+
(* Example 3: Session with retry logic *)
38
+
Printf.printf "\n=== Example 3: Session with Retry Logic ===\n";
39
+
let retry_config = Retry.create_config
40
+
~max_retries:3
41
+
~backoff_factor:0.5
42
+
~status_forcelist:[429; 500; 502; 503; 504]
43
+
() in
44
+
45
+
let robust_session = Session.create ~sw ~retry:retry_config env in
46
+
Session.set_timeout robust_session (Timeout.create ~total:30.0 ());
47
+
48
+
(* This request will automatically retry on failures *)
49
+
let result = Session.get robust_session "https://httpbin.org/status/503" in
50
+
Printf.printf "Request status (might retry): %d\n" (Response.status result);
51
+
52
+
(* Example 4: Persistent cookies *)
53
+
Printf.printf "\n=== Example 4: Persistent Cookies ===\n";
54
+
let persistent_session = Session.create ~sw
55
+
~persist_cookies:true
56
+
~app_name:"ocaml_example"
57
+
env in
58
+
59
+
(* Login and save cookies *)
60
+
let _login = Session.post persistent_session
61
+
~form:["username", "demo"; "password", "demo"]
62
+
"https://httpbin.org/post" in
63
+
64
+
(* Cookies will be saved to ~/.config/ocaml_example/cookies.txt *)
65
+
Session.save_cookies persistent_session;
66
+
Printf.printf "Cookies saved to disk\n";
67
+
68
+
(* Example 5: Concurrent requests with the same session *)
69
+
Printf.printf "\n=== Example 5: Concurrent Requests ===\n";
70
+
let urls = [
71
+
"https://httpbin.org/delay/1";
72
+
"https://httpbin.org/delay/1";
73
+
"https://httpbin.org/delay/1";
74
+
] in
75
+
76
+
let start_time = Unix.gettimeofday () in
77
+
let responses = Session.map_concurrent session ~max_concurrent:3
78
+
~f:(fun sess url ->
79
+
let resp = Session.get sess url in
80
+
Response.status resp
81
+
) urls in
82
+
83
+
let elapsed = Unix.gettimeofday () -. start_time in
84
+
Printf.printf "Concurrent requests completed in %.2fs\n" elapsed;
85
+
List.iter (Printf.printf "Status: %d\n") responses;
86
+
87
+
(* Example 6: Prepared requests *)
88
+
Printf.printf "\n=== Example 6: Prepared Requests ===\n";
89
+
let prepared = Session.Prepared.create
90
+
~session
91
+
~method_:Method.POST
92
+
"https://httpbin.org/post" in
93
+
94
+
(* Inspect and modify the prepared request *)
95
+
let prepared = Session.Prepared.set_header prepared "X-Custom" "Header" in
96
+
let prepared = Session.Prepared.set_body prepared (Body.text "Hello, World!") in
97
+
98
+
Format.printf "Prepared request:@.%a@." Session.Prepared.pp prepared;
99
+
100
+
(* Send when ready *)
101
+
let resp = Session.Prepared.send prepared in
102
+
Printf.printf "Prepared request sent, status: %d\n" (Response.status resp);
103
+
104
+
(* Example 7: Hooks *)
105
+
Printf.printf "\n=== Example 7: Request/Response Hooks ===\n";
106
+
let hook_session = Session.create ~sw env in
107
+
108
+
(* Add a request hook to log all requests *)
109
+
Session.Hooks.add_request_hook hook_session (fun headers method_ url ->
110
+
Printf.printf "-> Request: %s %s\n" (Method.to_string method_) url;
111
+
headers
112
+
);
113
+
114
+
(* Add a response hook to log all responses *)
115
+
Session.Hooks.add_response_hook hook_session (fun response ->
116
+
Printf.printf "<- Response: %d\n" (Response.status response)
117
+
);
118
+
119
+
(* All requests will trigger hooks *)
120
+
let _ = Session.get hook_session "https://httpbin.org/get" in
121
+
let _ = Session.post hook_session "https://httpbin.org/post" in
122
+
123
+
(* Example 8: Session statistics *)
124
+
Printf.printf "\n=== Example 8: Session Statistics ===\n";
125
+
let stats = Session.stats session in
126
+
Printf.printf "Total requests: %d\n" stats#requests_made;
127
+
Printf.printf "Total time: %.3fs\n" stats#total_time;
128
+
Printf.printf "Average time per request: %.3fs\n"
129
+
(stats#total_time /. float_of_int stats#requests_made);
130
+
131
+
(* Pretty print session info *)
132
+
Format.printf "@.Session info:@.%a@." Session.pp session;
133
+
134
+
(* Example 9: Download file *)
135
+
Printf.printf "\n=== Example 9: Download File ===\n";
136
+
let download_session = Session.create ~sw env in
137
+
let temp_file = Path.(env#fs / "/tmp/example_download.json") in
138
+
139
+
Session.download_file download_session
140
+
~on_progress:(fun ~received ~total ->
141
+
match total with
142
+
| Some t -> Printf.printf "Downloaded %Ld/%Ld bytes\r%!" received t
143
+
| None -> Printf.printf "Downloaded %Ld bytes\r%!" received
144
+
)
145
+
"https://httpbin.org/json"
146
+
temp_file;
147
+
148
+
Printf.printf "\nFile downloaded to /tmp/example_download.json\n";
149
+
150
+
Printf.printf "\n=== All examples completed successfully! ===\n"
+36
lib/auth.ml
+36
lib/auth.ml
···
1
+
let src = Logs.Src.create "requests.auth" ~doc:"HTTP Authentication"
2
+
module Log = (val Logs.src_log src : Logs.LOG)
3
+
4
+
type t =
5
+
| None
6
+
| Basic of { username : string; password : string }
7
+
| Bearer of { token : string }
8
+
| Digest of { username : string; password : string }
9
+
| Custom of (Headers.t -> Headers.t)
10
+
11
+
let none = None
12
+
13
+
let basic ~username ~password = Basic { username; password }
14
+
15
+
let bearer ~token = Bearer { token }
16
+
17
+
let digest ~username ~password = Digest { username; password }
18
+
19
+
let custom f = Custom f
20
+
21
+
let apply auth headers =
22
+
match auth with
23
+
| None -> headers
24
+
| Basic { username; password } ->
25
+
Log.debug (fun m -> m "Applying basic authentication for user: %s" username);
26
+
Headers.basic ~username ~password headers
27
+
| Bearer { token } ->
28
+
Log.debug (fun m -> m "Applying bearer token authentication");
29
+
Headers.bearer token headers
30
+
| Digest { username; password = _ } ->
31
+
Log.debug (fun m -> m "Digest auth configured for user: %s (requires server challenge)" username);
32
+
(* Digest auth requires server challenge first, handled elsewhere *)
33
+
headers
34
+
| Custom f ->
35
+
Log.debug (fun m -> m "Applying custom authentication handler");
36
+
f headers
+25
lib/auth.mli
+25
lib/auth.mli
···
1
+
(** Authentication mechanisms *)
2
+
3
+
(** Log source for authentication operations *)
4
+
val src : Logs.Src.t
5
+
6
+
type t
7
+
(** Abstract authentication type *)
8
+
9
+
val none : t
10
+
(** No authentication *)
11
+
12
+
val basic : username:string -> password:string -> t
13
+
(** HTTP Basic authentication *)
14
+
15
+
val bearer : token:string -> t
16
+
(** Bearer token authentication (e.g., OAuth 2.0) *)
17
+
18
+
val digest : username:string -> password:string -> t
19
+
(** HTTP Digest authentication *)
20
+
21
+
val custom : (Headers.t -> Headers.t) -> t
22
+
(** Custom authentication handler *)
23
+
24
+
val apply : t -> Headers.t -> Headers.t
25
+
(** Apply authentication to headers *)
+276
lib/body.ml
+276
lib/body.ml
···
1
+
let src = Logs.Src.create "requests.body" ~doc:"HTTP Request/Response Body"
2
+
module Log = (val Logs.src_log src : Logs.LOG)
3
+
4
+
type 'a part = {
5
+
name : string;
6
+
filename : string option;
7
+
content_type : Mime.t;
8
+
content : [`String of string | `Stream of Eio.Flow.source_ty Eio.Resource.t | `File of 'a Eio.Path.t];
9
+
}
10
+
11
+
type t =
12
+
| Empty
13
+
| String of { content : string; mime : Mime.t }
14
+
| Stream of { source : Eio.Flow.source_ty Eio.Resource.t; mime : Mime.t; length : int64 option }
15
+
| File : { file : 'a Eio.Path.t; mime : Mime.t } -> t
16
+
| Multipart : { parts : 'a part list; boundary : string } -> t
17
+
18
+
let empty = Empty
19
+
20
+
let of_string mime content =
21
+
String { content; mime }
22
+
23
+
let of_stream ?length mime source =
24
+
Stream { source; mime; length }
25
+
26
+
let of_file ?mime file =
27
+
let mime = match mime with
28
+
| Some m -> m
29
+
| None ->
30
+
(* Guess MIME type from filename if available *)
31
+
let path = Eio.Path.native_exn file in
32
+
let guessed =
33
+
if String.ends_with ~suffix:".json" path then Mime.json
34
+
else if String.ends_with ~suffix:".html" path then Mime.html
35
+
else if String.ends_with ~suffix:".xml" path then Mime.xml
36
+
else if String.ends_with ~suffix:".txt" path then Mime.text
37
+
else Mime.octet_stream
38
+
in
39
+
Log.debug (fun m -> m "Guessed MIME type %s for file %s" (Mime.to_string guessed) path);
40
+
guessed
41
+
in
42
+
Log.debug (fun m -> m "Creating file body from %s with MIME type %s"
43
+
(Eio.Path.native_exn file) (Mime.to_string mime));
44
+
File { file; mime }
45
+
46
+
(* For simple JSON encoding, we just take a Jsont.json value and encode it *)
47
+
let json (json_value : Jsont.json) =
48
+
let content = match Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json json_value with
49
+
| Ok s -> s
50
+
| Error e ->
51
+
let msg = Jsont.Error.to_string e in
52
+
failwith (Printf.sprintf "Failed to encode JSON: %s" msg)
53
+
in
54
+
String { content; mime = Mime.json }
55
+
56
+
(* JSON streaming using jsont - we encode the value to string and stream it *)
57
+
module Json_stream_source = struct
58
+
type t = {
59
+
mutable content : string;
60
+
mutable offset : int;
61
+
}
62
+
63
+
let single_read t dst =
64
+
if t.offset >= String.length t.content then
65
+
raise End_of_file
66
+
else begin
67
+
let available = String.length t.content - t.offset in
68
+
let to_copy = min (Cstruct.length dst) available in
69
+
Cstruct.blit_from_string t.content t.offset dst 0 to_copy;
70
+
t.offset <- t.offset + to_copy;
71
+
to_copy
72
+
end
73
+
74
+
let read_methods = []
75
+
end
76
+
77
+
let json_stream_source_create json_value =
78
+
(* Encode the entire JSON value to string with minified format *)
79
+
let content = match Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json json_value with
80
+
| Ok s -> s
81
+
| Error e ->
82
+
let msg = Jsont.Error.to_string e in
83
+
failwith (Printf.sprintf "Failed to encode JSON stream: %s" msg)
84
+
in
85
+
let t = { Json_stream_source.content; offset = 0 } in
86
+
let ops = Eio.Flow.Pi.source (module Json_stream_source) in
87
+
Eio.Resource.T (t, ops)
88
+
89
+
let json_stream json_value =
90
+
let source = json_stream_source_create json_value in
91
+
Stream { source; mime = Mime.json; length = None }
92
+
93
+
let text content =
94
+
String { content; mime = Mime.text }
95
+
96
+
let form params =
97
+
let encode_param (k, v) =
98
+
Printf.sprintf "%s=%s"
99
+
(Uri.pct_encode ~component:`Query_value k)
100
+
(Uri.pct_encode ~component:`Query_value v)
101
+
in
102
+
let content = String.concat "&" (List.map encode_param params) in
103
+
String { content; mime = Mime.form }
104
+
105
+
let generate_boundary () =
106
+
let random_bytes = Mirage_crypto_rng.generate 16 in
107
+
let random_part =
108
+
Cstruct.to_hex_string (Cstruct.of_string random_bytes)
109
+
in
110
+
Printf.sprintf "----WebKitFormBoundary%s" random_part
111
+
112
+
let multipart parts =
113
+
let boundary = generate_boundary () in
114
+
Multipart { parts; boundary }
115
+
116
+
let content_type = function
117
+
| Empty -> None
118
+
| String { mime; _ } -> Some mime
119
+
| Stream { mime; _ } -> Some mime
120
+
| File { mime; _ } -> Some mime
121
+
| Multipart { boundary; _ } ->
122
+
let mime = Mime.make "multipart" "form-data" in
123
+
Some (Mime.with_charset boundary mime)
124
+
125
+
let content_length = function
126
+
| Empty -> Some 0L
127
+
| String { content; _ } -> Some (Int64.of_int (String.length content))
128
+
| Stream { length; _ } -> length
129
+
| File { file; _ } ->
130
+
(* Try to get file size *)
131
+
(try
132
+
let stat = Eio.Path.stat ~follow:true file in
133
+
Some (Optint.Int63.to_int64 stat.size)
134
+
with _ -> None)
135
+
| Multipart _ ->
136
+
(* Complex to calculate, handled during sending *)
137
+
None
138
+
139
+
(* Strings_source - A flow source that streams from a doubly-linked list of strings/flows *)
140
+
module Strings_source = struct
141
+
type element =
142
+
| String of string
143
+
| Flow of Eio.Flow.source_ty Eio.Resource.t
144
+
145
+
type t = {
146
+
dllist : element Lwt_dllist.t;
147
+
mutable current_element : element option;
148
+
mutable string_offset : int;
149
+
}
150
+
151
+
let rec single_read t dst =
152
+
match t.current_element with
153
+
| None ->
154
+
(* Try to get the first element from the list *)
155
+
if Lwt_dllist.is_empty t.dllist then
156
+
raise End_of_file
157
+
else begin
158
+
t.current_element <- Some (Lwt_dllist.take_l t.dllist);
159
+
single_read t dst
160
+
end
161
+
| Some (String s) when t.string_offset >= String.length s ->
162
+
(* Current string exhausted, move to next element *)
163
+
t.current_element <- None;
164
+
t.string_offset <- 0;
165
+
single_read t dst
166
+
| Some (String s) ->
167
+
(* Read from current string *)
168
+
let available = String.length s - t.string_offset in
169
+
let to_read = min (Cstruct.length dst) available in
170
+
Cstruct.blit_from_string s t.string_offset dst 0 to_read;
171
+
t.string_offset <- t.string_offset + to_read;
172
+
to_read
173
+
| Some (Flow flow) ->
174
+
(* Read from flow *)
175
+
(try
176
+
let n = Eio.Flow.single_read flow dst in
177
+
if n = 0 then begin
178
+
(* Flow exhausted, move to next element *)
179
+
t.current_element <- None;
180
+
single_read t dst
181
+
end else n
182
+
with End_of_file ->
183
+
t.current_element <- None;
184
+
single_read t dst)
185
+
186
+
let read_methods = [] (* No special read methods *)
187
+
188
+
let create () = {
189
+
dllist = Lwt_dllist.create ();
190
+
current_element = None;
191
+
string_offset = 0;
192
+
}
193
+
194
+
let add_string t s =
195
+
ignore (Lwt_dllist.add_r (String s) t.dllist)
196
+
197
+
let add_flow t flow =
198
+
ignore (Lwt_dllist.add_r (Flow flow) t.dllist)
199
+
end
200
+
201
+
let strings_source_create () =
202
+
let t = Strings_source.create () in
203
+
let ops = Eio.Flow.Pi.source (module Strings_source) in
204
+
(t, Eio.Resource.T (t, ops))
205
+
206
+
let to_cohttp_body ~sw = function
207
+
| Empty -> None
208
+
| String { content; _ } -> Some (Cohttp_eio.Body.of_string content)
209
+
| Stream { source; _ } -> Some source
210
+
| File { file; _ } ->
211
+
(* Open file and stream it directly without loading into memory *)
212
+
let flow = Eio.Path.open_in ~sw file in
213
+
Some (flow :> Eio.Flow.source_ty Eio.Resource.t)
214
+
| Multipart { parts; boundary } ->
215
+
(* Create a single strings_source with dllist for streaming *)
216
+
let source, flow = strings_source_create () in
217
+
218
+
List.iter (fun part ->
219
+
(* Add boundary *)
220
+
Strings_source.add_string source "--";
221
+
Strings_source.add_string source boundary;
222
+
Strings_source.add_string source "\r\n";
223
+
224
+
(* Add Content-Disposition header *)
225
+
Strings_source.add_string source "Content-Disposition: form-data; name=\"";
226
+
Strings_source.add_string source part.name;
227
+
Strings_source.add_string source "\"";
228
+
(match part.filename with
229
+
| Some f ->
230
+
Strings_source.add_string source "; filename=\"";
231
+
Strings_source.add_string source f;
232
+
Strings_source.add_string source "\""
233
+
| None -> ());
234
+
Strings_source.add_string source "\r\n";
235
+
236
+
(* Add Content-Type header *)
237
+
Strings_source.add_string source "Content-Type: ";
238
+
Strings_source.add_string source (Mime.to_string part.content_type);
239
+
Strings_source.add_string source "\r\n\r\n";
240
+
241
+
(* Add content *)
242
+
(match part.content with
243
+
| `String s ->
244
+
Strings_source.add_string source s
245
+
| `File file ->
246
+
(* Open file and add as flow *)
247
+
let file_flow = Eio.Path.open_in ~sw file in
248
+
Strings_source.add_flow source (file_flow :> Eio.Flow.source_ty Eio.Resource.t)
249
+
| `Stream stream ->
250
+
(* Add stream directly *)
251
+
Strings_source.add_flow source stream);
252
+
253
+
(* Add trailing newline *)
254
+
Strings_source.add_string source "\r\n"
255
+
) parts;
256
+
257
+
(* Add final boundary *)
258
+
Strings_source.add_string source "--";
259
+
Strings_source.add_string source boundary;
260
+
Strings_source.add_string source "--\r\n";
261
+
262
+
Some flow
263
+
264
+
(* Private module *)
265
+
module Private = struct
266
+
let to_cohttp_body = to_cohttp_body
267
+
268
+
let to_string = function
269
+
| Empty -> ""
270
+
| String { content; _ } -> content
271
+
| Stream _ -> failwith "Cannot convert streaming body to string for connection pooling (body must be materialized first)"
272
+
| File _ -> failwith "Cannot convert file body to string for connection pooling (file must be read first)"
273
+
| Multipart _ -> failwith "Cannot convert multipart body to string for connection pooling (must be encoded first)"
274
+
275
+
let _ = to_string (* Use to avoid warning *)
276
+
end
+149
lib/body.mli
+149
lib/body.mli
···
1
+
(** HTTP request body construction
2
+
3
+
This module provides various ways to construct HTTP request bodies,
4
+
including strings, files, streams, forms, and multipart data.
5
+
6
+
{2 Examples}
7
+
8
+
{[
9
+
(* Simple text body *)
10
+
let body = Body.text "Hello, World!"
11
+
12
+
(* JSON body *)
13
+
let body = Body.json {|{"name": "Alice", "age": 30}|}
14
+
15
+
(* Form data *)
16
+
let body = Body.form [
17
+
("username", "alice");
18
+
("password", "secret")
19
+
]
20
+
21
+
(* File upload *)
22
+
let body = Body.of_file ~mime:Mime.pdf (Eio.Path.(fs / "document.pdf"))
23
+
24
+
(* Multipart form with file *)
25
+
let body = Body.multipart [
26
+
{ name = "field"; filename = None;
27
+
content_type = Mime.text_plain;
28
+
content = `String "value" };
29
+
{ name = "file"; filename = Some "photo.jpg";
30
+
content_type = Mime.jpeg;
31
+
content = `File (Eio.Path.(fs / "photo.jpg")) }
32
+
]
33
+
]}
34
+
*)
35
+
36
+
(** Log source for body operations *)
37
+
val src : Logs.Src.t
38
+
39
+
type t
40
+
(** Abstract body type representing HTTP request body content. *)
41
+
42
+
(** {1 Basic Constructors} *)
43
+
44
+
val empty : t
45
+
(** [empty] creates an empty body (no content). *)
46
+
47
+
val of_string : Mime.t -> string -> t
48
+
(** [of_string mime content] creates a body from a string with the specified MIME type.
49
+
Example: [of_string Mime.json {|{"key": "value"}|}] *)
50
+
51
+
val of_stream : ?length:int64 -> Mime.t -> Eio.Flow.source_ty Eio.Resource.t -> t
52
+
(** [of_stream ?length mime stream] creates a streaming body. If [length] is provided,
53
+
it will be used for the Content-Length header, otherwise chunked encoding is used. *)
54
+
55
+
val of_file : ?mime:Mime.t -> _ Eio.Path.t -> t
56
+
(** [of_file ?mime path] creates a body from a file. The MIME type is inferred from
57
+
the file extension if not provided. *)
58
+
59
+
(** {1 Convenience Constructors} *)
60
+
61
+
val json : Jsont.json -> t
62
+
(** [json value] creates a JSON body from a Jsont.json value.
63
+
The value is encoded to a JSON string with Content-Type: application/json.
64
+
65
+
Example:
66
+
{[
67
+
let body = Body.json (Jsont.Object ([
68
+
("status", Jsont.String "success");
69
+
("count", Jsont.Number 42.);
70
+
("items", Jsont.Array ([Jsont.String "first"; Jsont.String "second"], Jsont.Meta.none))
71
+
], Jsont.Meta.none))
72
+
]}
73
+
*)
74
+
75
+
val json_stream : Jsont.json -> t
76
+
(** [json_stream json_value] creates a streaming JSON body from a Jsont.json value.
77
+
The JSON value will be encoded to a minified JSON string and streamed.
78
+
79
+
Example:
80
+
{[
81
+
let large_data = Jsont.Object ([
82
+
("users", Jsont.Array ([...], Jsont.Meta.none))
83
+
], Jsont.Meta.none) in
84
+
let body = Body.json_stream large_data
85
+
]}
86
+
*)
87
+
88
+
val text : string -> t
89
+
(** [text str] creates a plain text body with Content-Type: text/plain. *)
90
+
91
+
val form : (string * string) list -> t
92
+
(** [form fields] creates a URL-encoded form body with Content-Type: application/x-www-form-urlencoded.
93
+
Example: [form [("username", "alice"); ("password", "secret")]] *)
94
+
95
+
(** {1 Multipart Support} *)
96
+
97
+
type 'a part = {
98
+
name : string; (** Form field name *)
99
+
filename : string option; (** Optional filename for file uploads *)
100
+
content_type : Mime.t; (** MIME type of this part *)
101
+
content : [
102
+
| `String of string (** String content *)
103
+
| `Stream of Eio.Flow.source_ty Eio.Resource.t (** Streaming content *)
104
+
| `File of 'a Eio.Path.t (** File content *)
105
+
];
106
+
}
107
+
(** A single part in a multipart body. *)
108
+
109
+
val multipart : _ part list -> t
110
+
(** [multipart parts] creates a multipart/form-data body from a list of parts.
111
+
This is commonly used for file uploads and complex form submissions.
112
+
113
+
Example:
114
+
{[
115
+
let body = Body.multipart [
116
+
{ name = "username"; filename = None;
117
+
content_type = Mime.text_plain;
118
+
content = `String "alice" };
119
+
{ name = "avatar"; filename = Some "photo.jpg";
120
+
content_type = Mime.jpeg;
121
+
content = `File (Eio.Path.(fs / "photo.jpg")) }
122
+
]
123
+
]}
124
+
*)
125
+
126
+
(** {1 Properties} *)
127
+
128
+
val content_type : t -> Mime.t option
129
+
(** [content_type body] returns the MIME type of the body, if set. *)
130
+
131
+
val content_length : t -> int64 option
132
+
(** [content_length body] returns the content length in bytes, if known.
133
+
Returns [None] for streaming bodies without a predetermined length. *)
134
+
135
+
(** {1 Private API} *)
136
+
137
+
(** Internal functions exposed for use by other modules in the library.
138
+
These are not part of the public API and may change between versions. *)
139
+
module Private : sig
140
+
val to_cohttp_body : sw:Eio.Switch.t -> t -> Cohttp_eio.Body.t option
141
+
(** [to_cohttp_body ~sw body] converts the body to cohttp-eio format.
142
+
Uses the switch to manage resources like file handles.
143
+
This function is used internally by the Client module. *)
144
+
145
+
val to_string : t -> string
146
+
(** [to_string body] converts the body to a string for HTTP/1.1 requests.
147
+
Only works for materialized bodies (String type).
148
+
Raises Failure for streaming/file/multipart bodies. *)
149
+
end
+291
lib/digest_auth.ml
+291
lib/digest_auth.ml
···
1
+
(** RFC 2617 HTTP Digest Authentication implementation *)
2
+
3
+
module Log = (val Logs.src_log (Logs.Src.create "requests.digest_auth" ~doc:"HTTP Digest Authentication") : Logs.LOG)
4
+
5
+
(** Digest auth challenge parameters from WWW-Authenticate header *)
6
+
type challenge = {
7
+
realm : string;
8
+
domain : string option;
9
+
nonce : string;
10
+
opaque : string option;
11
+
stale : bool;
12
+
algorithm : [`MD5 | `MD5_sess | `SHA256 | `SHA256_sess];
13
+
qop : [`Auth | `Auth_int] list option; (* quality of protection *)
14
+
charset : string option;
15
+
userhash : bool;
16
+
}
17
+
18
+
(** Client's chosen parameters for response *)
19
+
type client_data = {
20
+
username : string;
21
+
password : string;
22
+
nc : int; (* nonce count *)
23
+
cnonce : string; (* client nonce *)
24
+
qop_chosen : [`Auth | `Auth_int] option;
25
+
}
26
+
27
+
(** Parse WWW-Authenticate header for Digest challenge *)
28
+
let parse_challenge header_value =
29
+
(* Remove "Digest " prefix if present *)
30
+
let value =
31
+
if String.starts_with ~prefix:"Digest " header_value then
32
+
String.sub header_value 7 (String.length header_value - 7)
33
+
else header_value
34
+
in
35
+
36
+
(* Parse comma-separated key=value pairs *)
37
+
let parse_params str =
38
+
let rec parse_one pos acc =
39
+
if pos >= String.length str then acc
40
+
else
41
+
(* Skip whitespace *)
42
+
let pos = ref pos in
43
+
while !pos < String.length str && str.[!pos] = ' ' do incr pos done;
44
+
if !pos >= String.length str then acc
45
+
else
46
+
(* Find key *)
47
+
let key_start = !pos in
48
+
while !pos < String.length str && str.[!pos] <> '=' do incr pos done;
49
+
if !pos >= String.length str then acc
50
+
else
51
+
let key = String.trim (String.sub str key_start (!pos - key_start)) in
52
+
incr pos; (* Skip '=' *)
53
+
54
+
(* Parse value - may be quoted *)
55
+
let value, next_pos =
56
+
if !pos < String.length str && str.[!pos] = '"' then begin
57
+
(* Quoted value *)
58
+
incr pos;
59
+
let value_start = !pos in
60
+
while !pos < String.length str && str.[!pos] <> '"' do
61
+
if str.[!pos] = '\\' && !pos + 1 < String.length str then
62
+
pos := !pos + 2 (* Skip escaped character *)
63
+
else
64
+
incr pos
65
+
done;
66
+
let value = String.sub str value_start (!pos - value_start) in
67
+
if !pos < String.length str then incr pos; (* Skip closing quote *)
68
+
(* Skip to next comma *)
69
+
while !pos < String.length str && str.[!pos] <> ',' do incr pos done;
70
+
if !pos < String.length str then incr pos; (* Skip comma *)
71
+
(value, !pos)
72
+
end else begin
73
+
(* Unquoted value *)
74
+
let value_start = !pos in
75
+
while !pos < String.length str && str.[!pos] <> ',' do incr pos done;
76
+
let value = String.trim (String.sub str value_start (!pos - value_start)) in
77
+
if !pos < String.length str then incr pos; (* Skip comma *)
78
+
(value, !pos)
79
+
end
80
+
in
81
+
parse_one next_pos ((key, value) :: acc)
82
+
in
83
+
List.rev (parse_one 0 [])
84
+
in
85
+
86
+
let params = parse_params value in
87
+
88
+
(* Extract required and optional parameters *)
89
+
let get_param name = List.assoc_opt name params in
90
+
let get_param_req name =
91
+
match get_param name with
92
+
| Some v -> v
93
+
| None -> failwith (Printf.sprintf "Missing required Digest parameter: %s" name)
94
+
in
95
+
96
+
try
97
+
let realm = get_param_req "realm" in
98
+
let nonce = get_param_req "nonce" in
99
+
100
+
let algorithm = match get_param "algorithm" with
101
+
| Some "MD5" | None -> `MD5
102
+
| Some "MD5-sess" -> `MD5_sess
103
+
| Some "SHA-256" -> `SHA256
104
+
| Some "SHA-256-sess" -> `SHA256_sess
105
+
| Some a ->
106
+
Log.warn (fun m -> m "Unknown digest algorithm: %s, using MD5" a);
107
+
`MD5
108
+
in
109
+
110
+
let qop = match get_param "qop" with
111
+
| None -> None
112
+
| Some qop_str ->
113
+
let qops = String.split_on_char ',' qop_str |> List.map String.trim in
114
+
Some (List.filter_map (function
115
+
| "auth" -> Some `Auth
116
+
| "auth-int" -> Some `Auth_int
117
+
| _ -> None
118
+
) qops)
119
+
in
120
+
121
+
Some {
122
+
realm;
123
+
domain = get_param "domain";
124
+
nonce;
125
+
opaque = get_param "opaque";
126
+
stale = (match get_param "stale" with
127
+
| Some "true" | Some "TRUE" -> true
128
+
| _ -> false);
129
+
algorithm;
130
+
qop;
131
+
charset = get_param "charset";
132
+
userhash = (match get_param "userhash" with
133
+
| Some "true" | Some "TRUE" -> true
134
+
| _ -> false);
135
+
}
136
+
with
137
+
| Failure msg ->
138
+
Log.warn (fun m -> m "Failed to parse Digest challenge: %s" msg);
139
+
None
140
+
| Not_found -> None
141
+
142
+
(** Generate client nonce *)
143
+
let generate_cnonce () =
144
+
let rand_bytes = Mirage_crypto_rng.generate 16 in
145
+
Base64.encode_string rand_bytes
146
+
147
+
(** Hash function based on algorithm *)
148
+
let hash_function = function
149
+
| `MD5 | `MD5_sess ->
150
+
fun s -> Digestif.MD5.(to_hex (digest_string s))
151
+
| `SHA256 | `SHA256_sess ->
152
+
fun s -> Digestif.SHA256.(to_hex (digest_string s))
153
+
154
+
(** Calculate H(A1) according to RFC 2617 *)
155
+
let calculate_ha1 ~algorithm ~username ~realm ~password ~nonce ~cnonce =
156
+
let hash = hash_function algorithm in
157
+
match algorithm with
158
+
| `MD5 | `SHA256 ->
159
+
hash (Printf.sprintf "%s:%s:%s" username realm password)
160
+
| `MD5_sess | `SHA256_sess ->
161
+
let ha1_base = hash (Printf.sprintf "%s:%s:%s" username realm password) in
162
+
hash (Printf.sprintf "%s:%s:%s" ha1_base nonce cnonce)
163
+
164
+
(** Calculate H(A2) according to RFC 2617 *)
165
+
let calculate_ha2 ~algorithm ~meth ~uri ~qop ~body =
166
+
let hash = hash_function algorithm in
167
+
let method_str = match meth with
168
+
| `GET -> "GET" | `POST -> "POST" | `PUT -> "PUT"
169
+
| `DELETE -> "DELETE" | `HEAD -> "HEAD" | `OPTIONS -> "OPTIONS"
170
+
| `PATCH -> "PATCH" | `TRACE -> "TRACE" | `CONNECT -> "CONNECT"
171
+
| `Other s -> s
172
+
in
173
+
match qop with
174
+
| None | Some `Auth ->
175
+
hash (Printf.sprintf "%s:%s" method_str (Uri.path_and_query uri))
176
+
| Some `Auth_int ->
177
+
(* For auth-int, include hash of entity body *)
178
+
let body_hash = match body with
179
+
| None -> hash ""
180
+
| Some b -> hash b
181
+
in
182
+
hash (Printf.sprintf "%s:%s:%s" method_str (Uri.path_and_query uri) body_hash)
183
+
184
+
(** Calculate the response hash *)
185
+
let calculate_response ~ha1 ~ha2 ~nonce ~nc ~cnonce ~qop =
186
+
let hash = hash_function `MD5 in (* Response always uses the same hash as HA1 *)
187
+
match qop with
188
+
| None ->
189
+
hash (Printf.sprintf "%s:%s:%s" ha1 nonce ha2)
190
+
| Some qop_value ->
191
+
let qop_str = match qop_value with
192
+
| `Auth -> "auth"
193
+
| `Auth_int -> "auth-int"
194
+
in
195
+
let nc_str = Printf.sprintf "%08x" nc in
196
+
hash (Printf.sprintf "%s:%s:%s:%s:%s:%s" ha1 nonce nc_str cnonce qop_str ha2)
197
+
198
+
(** Generate Authorization header value for Digest auth *)
199
+
let generate_auth_header ~challenge ~client_data ~meth ~uri ~body =
200
+
let { username; password; nc; cnonce; qop_chosen } = client_data in
201
+
let { realm; nonce; opaque; algorithm; _ } = challenge in
202
+
203
+
(* Calculate hashes *)
204
+
let ha1 = calculate_ha1 ~algorithm ~username ~realm ~password ~nonce ~cnonce in
205
+
let ha2 = calculate_ha2 ~algorithm ~meth ~uri ~qop:qop_chosen ~body in
206
+
let response = calculate_response ~ha1 ~ha2 ~nonce ~nc ~cnonce ~qop:qop_chosen in
207
+
208
+
(* Build Authorization header *)
209
+
let params = [
210
+
("username", Printf.sprintf "\"%s\"" username);
211
+
("realm", Printf.sprintf "\"%s\"" realm);
212
+
("nonce", Printf.sprintf "\"%s\"" nonce);
213
+
("uri", Printf.sprintf "\"%s\"" (Uri.path_and_query uri));
214
+
("response", Printf.sprintf "\"%s\"" response);
215
+
] in
216
+
217
+
let params = match algorithm with
218
+
| `MD5 -> params (* MD5 is default, don't need to specify *)
219
+
| `MD5_sess -> ("algorithm", "MD5-sess") :: params
220
+
| `SHA256 -> ("algorithm", "SHA-256") :: params
221
+
| `SHA256_sess -> ("algorithm", "SHA-256-sess") :: params
222
+
in
223
+
224
+
let params = match opaque with
225
+
| Some o -> ("opaque", Printf.sprintf "\"%s\"" o) :: params
226
+
| None -> params
227
+
in
228
+
229
+
let params = match qop_chosen with
230
+
| None -> params
231
+
| Some qop ->
232
+
let qop_str = match qop with `Auth -> "auth" | `Auth_int -> "auth-int" in
233
+
let nc_str = Printf.sprintf "%08x" nc in
234
+
("qop", qop_str) ::
235
+
("nc", nc_str) ::
236
+
("cnonce", Printf.sprintf "\"%s\"" cnonce) ::
237
+
params
238
+
in
239
+
240
+
"Digest " ^ String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) params)
241
+
242
+
(** Nonce counter storage - in production should be persistent *)
243
+
module NonceCounter = struct
244
+
let table = Hashtbl.create 16
245
+
246
+
let get_and_increment ~nonce =
247
+
let current = try Hashtbl.find table nonce with Not_found -> 0 in
248
+
Hashtbl.replace table nonce (current + 1);
249
+
current + 1
250
+
251
+
let reset ~nonce =
252
+
Hashtbl.remove table nonce
253
+
end
254
+
255
+
(** Apply Digest authentication to a request *)
256
+
let apply_digest_auth ~username ~password ~meth ~uri ~headers ~body ~challenge_header =
257
+
match parse_challenge challenge_header with
258
+
| None ->
259
+
Log.warn (fun m -> m "Failed to parse Digest challenge");
260
+
headers
261
+
| Some challenge ->
262
+
(* Choose QOP if server offers options *)
263
+
let qop_chosen = match challenge.qop with
264
+
| None -> None
265
+
| Some qops ->
266
+
(* Prefer auth over auth-int for simplicity *)
267
+
if List.mem `Auth qops then Some `Auth
268
+
else if List.mem `Auth_int qops then Some `Auth_int
269
+
else None
270
+
in
271
+
272
+
(* Get or generate client nonce *)
273
+
let cnonce = generate_cnonce () in
274
+
275
+
(* Get and increment nonce counter *)
276
+
let nc = NonceCounter.get_and_increment ~nonce:challenge.nonce in
277
+
278
+
let client_data = { username; password; nc; cnonce; qop_chosen } in
279
+
let auth_value = generate_auth_header ~challenge ~client_data ~meth ~uri ~body in
280
+
281
+
Cohttp.Header.add headers "Authorization" auth_value
282
+
283
+
(** Check if a response requires digest auth *)
284
+
let is_digest_challenge response =
285
+
let status = Cohttp.Response.status response in
286
+
match Cohttp.Code.code_of_status status with
287
+
| 401 ->
288
+
(match Cohttp.Header.get (Cohttp.Response.headers response) "www-authenticate" with
289
+
| Some header when String.starts_with ~prefix:"Digest" header -> Some header
290
+
| _ -> None)
291
+
| _ -> None
+29
lib/dune
+29
lib/dune
···
1
+
(library
2
+
(public_name requests)
3
+
(name requests)
4
+
(modules :standard \ digest_auth)
5
+
(libraries
6
+
eio
7
+
eio.unix
8
+
cohttp
9
+
cohttp-eio
10
+
uri
11
+
jsont
12
+
jsont.bytesrw
13
+
base64
14
+
cookeio
15
+
cookeio.jar
16
+
xdge
17
+
logs
18
+
ptime
19
+
cmdliner
20
+
mirage-crypto
21
+
mirage-crypto-rng
22
+
mirage-crypto-rng.unix
23
+
tls
24
+
tls-eio
25
+
ca-certs
26
+
domain-name
27
+
cstruct
28
+
optint
29
+
conpool))
+174
lib/error.ml
+174
lib/error.ml
···
1
+
(** Centralized error handling for the Requests library *)
2
+
3
+
let src = Logs.Src.create "requests.error" ~doc:"HTTP Request Errors"
4
+
module Log = (val Logs.src_log src : Logs.LOG)
5
+
6
+
(** {1 Exception Types} *)
7
+
8
+
exception Timeout
9
+
exception TooManyRedirects of { url: string; count: int; max: int }
10
+
exception ConnectionError of string
11
+
exception HTTPError of {
12
+
url: string;
13
+
status: int;
14
+
reason: string;
15
+
body: string option;
16
+
headers: Headers.t
17
+
}
18
+
exception AuthenticationError of string
19
+
exception SSLError of string
20
+
exception ProxyError of string
21
+
exception EncodingError of string
22
+
exception InvalidURL of string
23
+
exception InvalidRequest of string
24
+
25
+
(** {1 Error Type} *)
26
+
27
+
type t = [
28
+
| `Timeout
29
+
| `TooManyRedirects of string * int * int (* url, count, max *)
30
+
| `ConnectionError of string
31
+
| `HTTPError of string * int * string * string option * Headers.t (* url, status, reason, body, headers *)
32
+
| `AuthenticationError of string
33
+
| `SSLError of string
34
+
| `ProxyError of string
35
+
| `EncodingError of string
36
+
| `InvalidURL of string
37
+
| `InvalidRequest of string
38
+
| `UnknownError of string
39
+
]
40
+
41
+
(** {1 Conversion Functions} *)
42
+
43
+
let of_exn = function
44
+
| Timeout -> Some `Timeout
45
+
| TooManyRedirects { url; count; max } ->
46
+
Some (`TooManyRedirects (url, count, max))
47
+
| ConnectionError msg -> Some (`ConnectionError msg)
48
+
| HTTPError { url; status; reason; body; headers } ->
49
+
Some (`HTTPError (url, status, reason, body, headers))
50
+
| AuthenticationError msg -> Some (`AuthenticationError msg)
51
+
| SSLError msg -> Some (`SSLError msg)
52
+
| ProxyError msg -> Some (`ProxyError msg)
53
+
| EncodingError msg -> Some (`EncodingError msg)
54
+
| InvalidURL msg -> Some (`InvalidURL msg)
55
+
| InvalidRequest msg -> Some (`InvalidRequest msg)
56
+
| _ -> None
57
+
58
+
let to_exn = function
59
+
| `Timeout -> Timeout
60
+
| `TooManyRedirects (url, count, max) ->
61
+
TooManyRedirects { url; count; max }
62
+
| `ConnectionError msg -> ConnectionError msg
63
+
| `HTTPError (url, status, reason, body, headers) ->
64
+
HTTPError { url; status; reason; body; headers }
65
+
| `AuthenticationError msg -> AuthenticationError msg
66
+
| `SSLError msg -> SSLError msg
67
+
| `ProxyError msg -> ProxyError msg
68
+
| `EncodingError msg -> EncodingError msg
69
+
| `InvalidURL msg -> InvalidURL msg
70
+
| `InvalidRequest msg -> InvalidRequest msg
71
+
| `UnknownError msg -> Failure msg
72
+
73
+
let raise error = Stdlib.raise (to_exn error)
74
+
75
+
(** {1 Combinators} *)
76
+
77
+
let catch f =
78
+
try Ok (f ())
79
+
with
80
+
| exn ->
81
+
match of_exn exn with
82
+
| Some err -> Error err
83
+
| None -> Error (`UnknownError (Printexc.to_string exn))
84
+
85
+
let catch_async f = catch f (* In Eio, regular catch works for async too *)
86
+
87
+
let map f = function
88
+
| Ok x -> Ok (f x)
89
+
| Error e -> Error e
90
+
91
+
let bind f = function
92
+
| Ok x -> f x
93
+
| Error e -> Error e
94
+
95
+
let both a b =
96
+
match a, b with
97
+
| Ok x, Ok y -> Ok (x, y)
98
+
| Error e, _ -> Error e
99
+
| _, Error e -> Error e
100
+
101
+
let get_exn = function
102
+
| Ok x -> x
103
+
| Error e -> raise e
104
+
105
+
let get_or ~default = function
106
+
| Ok x -> x
107
+
| Error _ -> default
108
+
109
+
let is_retryable = function
110
+
| `Timeout -> true
111
+
| `ConnectionError _ -> true
112
+
| `HTTPError (_, status, _, _, _) -> Status.is_retryable (Status.of_int status)
113
+
| `SSLError _ -> true
114
+
| `ProxyError _ -> true
115
+
| _ -> false
116
+
117
+
let is_client_error = function
118
+
| `HTTPError (_, status, _, _, _) -> Status.is_client_error (Status.of_int status)
119
+
| `AuthenticationError _
120
+
| `InvalidURL _
121
+
| `InvalidRequest _ -> true
122
+
| _ -> false
123
+
124
+
let is_server_error = function
125
+
| `HTTPError (_, status, _, _, _) -> Status.is_server_error (Status.of_int status)
126
+
| _ -> false
127
+
128
+
129
+
(** {1 Pretty Printing} *)
130
+
131
+
let pp ppf = function
132
+
| `Timeout ->
133
+
Format.fprintf ppf "@[<2>Request Timeout:@ The request timed out@]"
134
+
| `TooManyRedirects (url, count, max) ->
135
+
Format.fprintf ppf "@[<2>Too Many Redirects:@ Exceeded maximum redirects (%d/%d) for URL: %s@]"
136
+
count max url
137
+
| `ConnectionError msg ->
138
+
Format.fprintf ppf "@[<2>Connection Error:@ %s@]" msg
139
+
| `HTTPError (url, status, reason, body, _headers) ->
140
+
Format.fprintf ppf "@[<v>@[<2>HTTP Error %d (%s):@ URL: %s@]" status reason url;
141
+
Option.iter (fun b ->
142
+
Format.fprintf ppf "@,@[<2>Response Body:@ %s@]" b
143
+
) body;
144
+
Format.fprintf ppf "@]"
145
+
| `AuthenticationError msg ->
146
+
Format.fprintf ppf "@[<2>Authentication Error:@ %s@]" msg
147
+
| `SSLError msg ->
148
+
Format.fprintf ppf "@[<2>SSL/TLS Error:@ %s@]" msg
149
+
| `ProxyError msg ->
150
+
Format.fprintf ppf "@[<2>Proxy Error:@ %s@]" msg
151
+
| `EncodingError msg ->
152
+
Format.fprintf ppf "@[<2>Encoding Error:@ %s@]" msg
153
+
| `InvalidURL msg ->
154
+
Format.fprintf ppf "@[<2>Invalid URL:@ %s@]" msg
155
+
| `InvalidRequest msg ->
156
+
Format.fprintf ppf "@[<2>Invalid Request:@ %s@]" msg
157
+
| `UnknownError msg ->
158
+
Format.fprintf ppf "@[<2>Unknown Error:@ %s@]" msg
159
+
160
+
let pp_exn ppf exn =
161
+
match of_exn exn with
162
+
| Some err -> pp ppf err
163
+
| None -> Format.fprintf ppf "%s" (Printexc.to_string exn)
164
+
165
+
let to_string error =
166
+
Format.asprintf "%a" pp error
167
+
168
+
(** {1 Syntax Module} *)
169
+
170
+
module Syntax = struct
171
+
let ( let* ) x f = bind f x
172
+
let ( let+ ) x f = map f x
173
+
let ( and* ) = both
174
+
end
+127
lib/error.mli
+127
lib/error.mli
···
1
+
(** Centralized error handling for the Requests library *)
2
+
3
+
(** Log source for error reporting *)
4
+
val src : Logs.Src.t
5
+
6
+
(** {1 Exception Types} *)
7
+
8
+
(** Raised when a request times out *)
9
+
exception Timeout
10
+
11
+
(** Raised when too many redirects are encountered *)
12
+
exception TooManyRedirects of { url: string; count: int; max: int }
13
+
14
+
(** Raised when a connection error occurs *)
15
+
exception ConnectionError of string
16
+
17
+
(** Raised when an HTTP error response is received *)
18
+
exception HTTPError of {
19
+
url: string;
20
+
status: int;
21
+
reason: string;
22
+
body: string option;
23
+
headers: Headers.t
24
+
}
25
+
26
+
(** Raised when authentication fails *)
27
+
exception AuthenticationError of string
28
+
29
+
(** Raised when there's an SSL/TLS error *)
30
+
exception SSLError of string
31
+
32
+
(** Raised when proxy connection fails *)
33
+
exception ProxyError of string
34
+
35
+
(** Raised when content encoding/decoding fails *)
36
+
exception EncodingError of string
37
+
38
+
(** Raised when an invalid URL is provided *)
39
+
exception InvalidURL of string
40
+
41
+
(** Raised when request is invalid *)
42
+
exception InvalidRequest of string
43
+
44
+
(** {1 Error Type} *)
45
+
46
+
(** Unified error type for result-based error handling *)
47
+
type t = [
48
+
| `Timeout
49
+
| `TooManyRedirects of string * int * int (* url, count, max *)
50
+
| `ConnectionError of string
51
+
| `HTTPError of string * int * string * string option * Headers.t (* url, status, reason, body, headers *)
52
+
| `AuthenticationError of string
53
+
| `SSLError of string
54
+
| `ProxyError of string
55
+
| `EncodingError of string
56
+
| `InvalidURL of string
57
+
| `InvalidRequest of string
58
+
| `UnknownError of string
59
+
]
60
+
61
+
(** {1 Conversion Functions} *)
62
+
63
+
(** Convert an exception to an error type *)
64
+
val of_exn : exn -> t option
65
+
66
+
(** Convert an error type to an exception *)
67
+
val to_exn : t -> exn
68
+
69
+
(** Raise an error as an exception *)
70
+
val raise : t -> 'a
71
+
72
+
(** {1 Combinators} *)
73
+
74
+
(** Wrap a function that may raise exceptions into a result type *)
75
+
val catch : (unit -> 'a) -> ('a, t) result
76
+
77
+
(** Wrap an async function that may raise exceptions *)
78
+
val catch_async : (unit -> 'a) -> ('a, t) result
79
+
80
+
(** Map over the success case of a result *)
81
+
val map : ('a -> 'b) -> ('a, t) result -> ('b, t) result
82
+
83
+
(** Bind for result types with error *)
84
+
val bind : ('a -> ('b, t) result) -> ('a, t) result -> ('b, t) result
85
+
86
+
(** Applicative operator for combining results *)
87
+
val both : ('a, t) result -> ('b, t) result -> ('a * 'b, t) result
88
+
89
+
(** Get value or raise the error *)
90
+
val get_exn : ('a, t) result -> 'a
91
+
92
+
(** Get value or use default *)
93
+
val get_or : default:'a -> ('a, t) result -> 'a
94
+
95
+
(** Check if error is retryable *)
96
+
val is_retryable : t -> bool
97
+
98
+
(** Check if error is a client error (4xx) *)
99
+
val is_client_error : t -> bool
100
+
101
+
(** Check if error is a server error (5xx) *)
102
+
val is_server_error : t -> bool
103
+
104
+
(** {1 Pretty Printing} *)
105
+
106
+
(** Pretty printer for errors *)
107
+
val pp : Format.formatter -> t -> unit
108
+
109
+
(** Pretty printer for exceptions (falls back to Printexc if not a known exception) *)
110
+
val pp_exn : Format.formatter -> exn -> unit
111
+
112
+
(** Convert error to string *)
113
+
val to_string : t -> string
114
+
115
+
(** {1 Syntax Module} *)
116
+
117
+
(** Syntax module for let-operators *)
118
+
module Syntax : sig
119
+
(** Bind operator for result types *)
120
+
val ( let* ) : ('a, t) result -> ('a -> ('b, t) result) -> ('b, t) result
121
+
122
+
(** Map operator for result types *)
123
+
val ( let+ ) : ('a, t) result -> ('a -> 'b) -> ('b, t) result
124
+
125
+
(** Both operator for combining results *)
126
+
val ( and* ) : ('a, t) result -> ('b, t) result -> ('a * 'b, t) result
127
+
end
+110
lib/headers.ml
+110
lib/headers.ml
···
1
+
let src = Logs.Src.create "requests.headers" ~doc:"HTTP Headers"
2
+
module Log = (val Logs.src_log src : Logs.LOG)
3
+
4
+
(* Use a map with lowercase keys for case-insensitive lookup *)
5
+
module StringMap = Map.Make(String)
6
+
7
+
type t = (string * string list) StringMap.t
8
+
9
+
let empty = StringMap.empty
10
+
11
+
let normalize_key k = String.lowercase_ascii k
12
+
13
+
let add key value t =
14
+
let nkey = normalize_key key in
15
+
let existing =
16
+
match StringMap.find_opt nkey t with
17
+
| Some (_, values) -> values
18
+
| None -> []
19
+
in
20
+
StringMap.add nkey (key, value :: existing) t
21
+
22
+
let set key value t =
23
+
let nkey = normalize_key key in
24
+
StringMap.add nkey (key, [value]) t
25
+
26
+
let get key t =
27
+
let nkey = normalize_key key in
28
+
match StringMap.find_opt nkey t with
29
+
| Some (_, values) -> List.nth_opt values 0
30
+
| None -> None
31
+
32
+
let get_all key t =
33
+
let nkey = normalize_key key in
34
+
match StringMap.find_opt nkey t with
35
+
| Some (_, values) -> List.rev values
36
+
| None -> []
37
+
38
+
let remove key t =
39
+
let nkey = normalize_key key in
40
+
StringMap.remove nkey t
41
+
42
+
let mem key t =
43
+
let nkey = normalize_key key in
44
+
StringMap.mem nkey t
45
+
46
+
let of_list lst =
47
+
List.fold_left (fun acc (k, v) -> add k v acc) empty lst
48
+
49
+
let to_list t =
50
+
StringMap.fold (fun _ (orig_key, values) acc ->
51
+
List.fold_left (fun acc v -> (orig_key, v) :: acc) acc (List.rev values)
52
+
) t []
53
+
54
+
let merge t1 t2 =
55
+
StringMap.union (fun _ _ v2 -> Some v2) t1 t2
56
+
57
+
(* Common header builders *)
58
+
59
+
let content_type mime t =
60
+
set "Content-Type" (Mime.to_string mime) t
61
+
62
+
let content_length len t =
63
+
set "Content-Length" (Int64.to_string len) t
64
+
65
+
let accept mime t =
66
+
set "Accept" (Mime.to_string mime) t
67
+
68
+
let authorization value t =
69
+
set "Authorization" value t
70
+
71
+
let bearer token t =
72
+
set "Authorization" (Printf.sprintf "Bearer %s" token) t
73
+
74
+
let basic ~username ~password t =
75
+
let credentials = Printf.sprintf "%s:%s" username password in
76
+
let encoded = Base64.encode_exn credentials in
77
+
set "Authorization" (Printf.sprintf "Basic %s" encoded) t
78
+
79
+
let user_agent ua t =
80
+
set "User-Agent" ua t
81
+
82
+
let host h t =
83
+
set "Host" h t
84
+
85
+
let cookie name value t =
86
+
add "Cookie" (Printf.sprintf "%s=%s" name value) t
87
+
88
+
let range ~start ?end_ () t =
89
+
let range_value = match end_ with
90
+
| None -> Printf.sprintf "bytes=%Ld-" start
91
+
| Some e -> Printf.sprintf "bytes=%Ld-%Ld" start e
92
+
in
93
+
set "Range" range_value t
94
+
95
+
(* Additional helper for getting multiple header values *)
96
+
let get_multi key t = get_all key t
97
+
98
+
(* Pretty printer for headers *)
99
+
let pp ppf t =
100
+
Format.fprintf ppf "@[<v>Headers:@,";
101
+
let headers = to_list t in
102
+
List.iter (fun (k, v) ->
103
+
Format.fprintf ppf " %s: %s@," k v
104
+
) headers;
105
+
Format.fprintf ppf "@]"
106
+
107
+
let pp_brief ppf t =
108
+
let headers = to_list t in
109
+
let count = List.length headers in
110
+
Format.fprintf ppf "Headers(%d entries)" count
+114
lib/headers.mli
+114
lib/headers.mli
···
1
+
(** HTTP headers management with case-insensitive keys
2
+
3
+
This module provides an efficient implementation of HTTP headers with
4
+
case-insensitive header names as per RFC 7230. Headers can have multiple
5
+
values for the same key (e.g., multiple Set-Cookie headers).
6
+
7
+
{2 Examples}
8
+
9
+
{[
10
+
let headers =
11
+
Headers.empty
12
+
|> Headers.content_type Mime.json
13
+
|> Headers.bearer "token123"
14
+
|> Headers.set "X-Custom" "value"
15
+
]}
16
+
*)
17
+
18
+
(** Log source for header operations *)
19
+
val src : Logs.Src.t
20
+
21
+
type t
22
+
(** Abstract header collection type. Headers are stored with case-insensitive
23
+
keys and maintain insertion order. *)
24
+
25
+
(** {1 Creation and Conversion} *)
26
+
27
+
val empty : t
28
+
(** [empty] creates an empty header collection. *)
29
+
30
+
val of_list : (string * string) list -> t
31
+
(** [of_list pairs] creates headers from an association list.
32
+
Later entries override earlier ones for the same key. *)
33
+
34
+
val to_list : t -> (string * string) list
35
+
(** [to_list headers] converts headers to an association list.
36
+
The order of headers is preserved. *)
37
+
38
+
(** {1 Manipulation} *)
39
+
40
+
val add : string -> string -> t -> t
41
+
(** [add name value headers] adds a header value. Multiple values
42
+
for the same header name are allowed (e.g., for Set-Cookie). *)
43
+
44
+
val set : string -> string -> t -> t
45
+
(** [set name value headers] sets a header value, replacing any
46
+
existing values for that header name. *)
47
+
48
+
val get : string -> t -> string option
49
+
(** [get name headers] returns the first value for a header name,
50
+
or [None] if the header doesn't exist. *)
51
+
52
+
val get_all : string -> t -> string list
53
+
(** [get_all name headers] returns all values for a header name.
54
+
Returns an empty list if the header doesn't exist. *)
55
+
56
+
val remove : string -> t -> t
57
+
(** [remove name headers] removes all values for a header name. *)
58
+
59
+
val mem : string -> t -> bool
60
+
(** [mem name headers] checks if a header name exists. *)
61
+
62
+
val merge : t -> t -> t
63
+
(** [merge base override] merges two header collections.
64
+
Headers from [override] replace those in [base]. *)
65
+
66
+
(** {1 Common Header Builders}
67
+
68
+
Convenience functions for setting common HTTP headers.
69
+
*)
70
+
71
+
val content_type : Mime.t -> t -> t
72
+
(** [content_type mime headers] sets the Content-Type header. *)
73
+
74
+
val content_length : int64 -> t -> t
75
+
(** [content_length length headers] sets the Content-Length header. *)
76
+
77
+
val accept : Mime.t -> t -> t
78
+
(** [accept mime headers] sets the Accept header. *)
79
+
80
+
val authorization : string -> t -> t
81
+
(** [authorization value headers] sets the Authorization header with a raw value. *)
82
+
83
+
val bearer : string -> t -> t
84
+
(** [bearer token headers] sets the Authorization header with a Bearer token.
85
+
Example: [bearer "abc123"] sets ["Authorization: Bearer abc123"] *)
86
+
87
+
val basic : username:string -> password:string -> t -> t
88
+
(** [basic ~username ~password headers] sets the Authorization header with
89
+
HTTP Basic authentication (base64-encoded username:password). *)
90
+
91
+
val user_agent : string -> t -> t
92
+
(** [user_agent ua headers] sets the User-Agent header. *)
93
+
94
+
val host : string -> t -> t
95
+
(** [host hostname headers] sets the Host header. *)
96
+
97
+
val cookie : string -> string -> t -> t
98
+
(** [cookie name value headers] adds a cookie to the Cookie header.
99
+
Multiple cookies can be added by calling this function multiple times. *)
100
+
101
+
val range : start:int64 -> ?end_:int64 -> unit -> t -> t
102
+
(** [range ~start ?end_ () headers] sets the Range header for partial content.
103
+
Example: [range ~start:0L ~end_:999L ()] requests the first 1000 bytes. *)
104
+
105
+
(** {1 Aliases} *)
106
+
107
+
val get_multi : string -> t -> string list
108
+
(** [get_multi] is an alias for {!get_all}. *)
109
+
110
+
(** Pretty printer for headers *)
111
+
val pp : Format.formatter -> t -> unit
112
+
113
+
(** Brief pretty printer showing count only *)
114
+
val pp_brief : Format.formatter -> t -> unit
+165
lib/http_client.ml
+165
lib/http_client.ml
···
1
+
(** Low-level HTTP/1.1 client over raw TCP connections for connection pooling *)
2
+
3
+
let src = Logs.Src.create "requests.http_client" ~doc:"Low-level HTTP client"
4
+
module Log = (val Logs.src_log src : Logs.LOG)
5
+
6
+
(** Build HTTP/1.1 request as a string *)
7
+
let build_request ~method_ ~uri ~headers ~body_str =
8
+
let path = Uri.path uri in
9
+
let path = if path = "" then "/" else path in
10
+
let query = Uri.query uri in
11
+
let path_with_query =
12
+
if query = [] then path
13
+
else path ^ "?" ^ (Uri.encoded_of_query query)
14
+
in
15
+
16
+
let host = match Uri.host uri with
17
+
| Some h -> h
18
+
| None -> failwith "URI must have a host"
19
+
in
20
+
21
+
let port = match Uri.port uri with
22
+
| Some p -> ":" ^ string_of_int p
23
+
| None ->
24
+
match Uri.scheme uri with
25
+
| Some "https" -> ":443"
26
+
| Some "http" -> ":80"
27
+
| _ -> ""
28
+
in
29
+
30
+
(* Build request line *)
31
+
let request_line = Printf.sprintf "%s %s HTTP/1.1\r\n" method_ path_with_query in
32
+
33
+
(* Ensure Host header is present *)
34
+
let headers = if not (Headers.mem "host" headers) then
35
+
Headers.add "host" (host ^ port) headers
36
+
else headers in
37
+
38
+
(* Ensure Connection header for keep-alive *)
39
+
let headers = if not (Headers.mem "connection" headers) then
40
+
Headers.add "connection" "keep-alive" headers
41
+
else headers in
42
+
43
+
(* Add Content-Length if we have a body *)
44
+
let headers =
45
+
if body_str <> "" && not (Headers.mem "content-length" headers) then
46
+
let len = String.length body_str in
47
+
Headers.add "content-length" (string_of_int len) headers
48
+
else headers
49
+
in
50
+
51
+
(* Build headers section *)
52
+
let headers_str =
53
+
Headers.to_list headers
54
+
|> List.map (fun (k, v) -> Printf.sprintf "%s: %s\r\n" k v)
55
+
|> String.concat ""
56
+
in
57
+
58
+
request_line ^ headers_str ^ "\r\n" ^ body_str
59
+
60
+
(** Parse HTTP response status line *)
61
+
let parse_status_line line =
62
+
match String.split_on_char ' ' line with
63
+
| "HTTP/1.1" :: code :: _ | "HTTP/1.0" :: code :: _ ->
64
+
(try int_of_string code
65
+
with _ -> failwith ("Invalid status code: " ^ code))
66
+
| _ -> failwith ("Invalid status line: " ^ line)
67
+
68
+
(** Parse HTTP headers from buffer reader *)
69
+
let parse_headers buf_read =
70
+
let rec read_headers acc =
71
+
let line = Eio.Buf_read.line buf_read in
72
+
if line = "" then List.rev acc
73
+
else begin
74
+
match String.index_opt line ':' with
75
+
| None -> read_headers acc
76
+
| Some idx ->
77
+
let name = String.sub line 0 idx |> String.trim |> String.lowercase_ascii in
78
+
let value = String.sub line (idx + 1) (String.length line - idx - 1) |> String.trim in
79
+
read_headers ((name, value) :: acc)
80
+
end
81
+
in
82
+
read_headers [] |> Headers.of_list
83
+
84
+
(** Read body with Content-Length *)
85
+
let read_fixed_body buf_read length =
86
+
let buf = Buffer.create (Int64.to_int length) in
87
+
let rec read_n remaining =
88
+
if remaining > 0L then begin
89
+
let to_read = min 8192 (Int64.to_int remaining) in
90
+
let chunk = Eio.Buf_read.take to_read buf_read in
91
+
Buffer.add_string buf chunk;
92
+
read_n (Int64.sub remaining (Int64.of_int (String.length chunk)))
93
+
end
94
+
in
95
+
read_n length;
96
+
Buffer.contents buf
97
+
98
+
(** Read chunked body *)
99
+
let read_chunked_body buf_read =
100
+
let buf = Buffer.create 4096 in
101
+
let rec read_chunks () =
102
+
let size_line = Eio.Buf_read.line buf_read in
103
+
(* Parse hex chunk size, ignore extensions after ';' *)
104
+
let size_str = match String.index_opt size_line ';' with
105
+
| Some idx -> String.sub size_line 0 idx
106
+
| None -> size_line
107
+
in
108
+
let chunk_size = int_of_string ("0x" ^ size_str) in
109
+
if chunk_size = 0 then begin
110
+
(* Read trailing headers (if any) until empty line *)
111
+
let rec skip_trailers () =
112
+
let line = Eio.Buf_read.line buf_read in
113
+
if line <> "" then skip_trailers ()
114
+
in
115
+
skip_trailers ()
116
+
end else begin
117
+
let chunk = Eio.Buf_read.take chunk_size buf_read in
118
+
Buffer.add_string buf chunk;
119
+
let _crlf = Eio.Buf_read.line buf_read in (* Read trailing CRLF *)
120
+
read_chunks ()
121
+
end
122
+
in
123
+
read_chunks ();
124
+
Buffer.contents buf
125
+
126
+
(** Make HTTP request over a pooled connection *)
127
+
let make_request ~method_ ~uri ~headers ~body_str flow =
128
+
Log.debug (fun m -> m "Making %s request to %s" method_ (Uri.to_string uri));
129
+
130
+
(* Build and send request *)
131
+
let request_str = build_request ~method_ ~uri ~headers ~body_str in
132
+
Eio.Flow.copy_string request_str flow;
133
+
134
+
(* Read and parse response *)
135
+
let buf_read = Eio.Buf_read.of_flow flow ~max_size:max_int in
136
+
137
+
(* Parse status line *)
138
+
let status_line = Eio.Buf_read.line buf_read in
139
+
let status = parse_status_line status_line in
140
+
141
+
Log.debug (fun m -> m "Received response status: %d" status);
142
+
143
+
(* Parse headers *)
144
+
let resp_headers = parse_headers buf_read in
145
+
146
+
(* Determine how to read body *)
147
+
let transfer_encoding = Headers.get "transfer-encoding" resp_headers in
148
+
let content_length = Headers.get "content-length" resp_headers |> Option.map Int64.of_string in
149
+
150
+
let body_str = match transfer_encoding, content_length with
151
+
| Some te, _ when String.lowercase_ascii te |> String.trim = "chunked" ->
152
+
Log.debug (fun m -> m "Reading chunked response body");
153
+
read_chunked_body buf_read
154
+
| _, Some len ->
155
+
Log.debug (fun m -> m "Reading fixed-length response body (%Ld bytes)" len);
156
+
read_fixed_body buf_read len
157
+
| Some other_te, None ->
158
+
Log.warn (fun m -> m "Unsupported transfer-encoding: %s, assuming no body" other_te);
159
+
""
160
+
| None, None ->
161
+
Log.debug (fun m -> m "No body indicated");
162
+
""
163
+
in
164
+
165
+
(status, resp_headers, body_str)
+70
lib/method.ml
+70
lib/method.ml
···
1
+
let src = Logs.Src.create "requests.method" ~doc:"HTTP Methods"
2
+
module Log = (val Logs.src_log src : Logs.LOG)
3
+
4
+
type t = [
5
+
| `GET
6
+
| `POST
7
+
| `PUT
8
+
| `DELETE
9
+
| `HEAD
10
+
| `OPTIONS
11
+
| `PATCH
12
+
| `CONNECT
13
+
| `TRACE
14
+
| `Other of string
15
+
]
16
+
17
+
let to_string = function
18
+
| `GET -> "GET"
19
+
| `POST -> "POST"
20
+
| `PUT -> "PUT"
21
+
| `DELETE -> "DELETE"
22
+
| `HEAD -> "HEAD"
23
+
| `OPTIONS -> "OPTIONS"
24
+
| `PATCH -> "PATCH"
25
+
| `CONNECT -> "CONNECT"
26
+
| `TRACE -> "TRACE"
27
+
| `Other s -> String.uppercase_ascii s
28
+
29
+
let of_string s =
30
+
match String.uppercase_ascii s with
31
+
| "GET" -> `GET
32
+
| "POST" -> `POST
33
+
| "PUT" -> `PUT
34
+
| "DELETE" -> `DELETE
35
+
| "HEAD" -> `HEAD
36
+
| "OPTIONS" -> `OPTIONS
37
+
| "PATCH" -> `PATCH
38
+
| "CONNECT" -> `CONNECT
39
+
| "TRACE" -> `TRACE
40
+
| other -> `Other other
41
+
42
+
let pp ppf m = Format.fprintf ppf "%s" (to_string m)
43
+
44
+
let is_safe = function
45
+
| `GET | `HEAD | `OPTIONS | `TRACE -> true
46
+
| `POST | `PUT | `DELETE | `PATCH | `CONNECT | `Other _ -> false
47
+
48
+
let is_idempotent = function
49
+
| `GET | `HEAD | `PUT | `DELETE | `OPTIONS | `TRACE -> true
50
+
| `POST | `PATCH | `CONNECT | `Other _ -> false
51
+
52
+
let has_request_body = function
53
+
| `POST | `PUT | `PATCH -> true
54
+
| `GET | `HEAD | `DELETE | `OPTIONS | `CONNECT | `TRACE -> false
55
+
| `Other _ -> false (* Conservative default for unknown methods *)
56
+
57
+
let is_cacheable = function
58
+
| `GET | `HEAD -> true
59
+
| `POST -> true (* POST can be cacheable with explicit headers *)
60
+
| `PUT | `DELETE | `PATCH | `OPTIONS | `CONNECT | `TRACE | `Other _ -> false
61
+
62
+
let equal m1 m2 =
63
+
match m1, m2 with
64
+
| `Other s1, `Other s2 -> String.equal (String.uppercase_ascii s1) (String.uppercase_ascii s2)
65
+
| m1, m2 -> m1 = m2
66
+
67
+
let compare m1 m2 =
68
+
match m1, m2 with
69
+
| `Other s1, `Other s2 -> String.compare (String.uppercase_ascii s1) (String.uppercase_ascii s2)
70
+
| m1, m2 -> Stdlib.compare m1 m2
+55
lib/method.mli
+55
lib/method.mli
···
1
+
(** HTTP methods following RFC 7231 *)
2
+
3
+
(** Log source for method operations *)
4
+
val src : Logs.Src.t
5
+
6
+
(** HTTP method type using polymorphic variants for better composability *)
7
+
type t = [
8
+
| `GET (** Retrieve a resource *)
9
+
| `POST (** Submit data to be processed *)
10
+
| `PUT (** Replace a resource *)
11
+
| `DELETE (** Delete a resource *)
12
+
| `HEAD (** Retrieve headers only *)
13
+
| `OPTIONS (** Retrieve allowed methods *)
14
+
| `PATCH (** Partial resource modification *)
15
+
| `CONNECT (** Establish tunnel to server *)
16
+
| `TRACE (** Echo received request *)
17
+
| `Other of string (** Non-standard or extension method *)
18
+
]
19
+
20
+
(** {1 Conversion Functions} *)
21
+
22
+
val to_string : t -> string
23
+
(** Convert method to uppercase string representation *)
24
+
25
+
val of_string : string -> t
26
+
(** Parse method from string (case-insensitive).
27
+
Returns [`Other s] for unrecognized methods. *)
28
+
29
+
val pp : Format.formatter -> t -> unit
30
+
(** Pretty printer for methods *)
31
+
32
+
(** {1 Method Properties} *)
33
+
34
+
val is_safe : t -> bool
35
+
(** Returns true for safe methods (GET, HEAD, OPTIONS, TRACE).
36
+
Safe methods should not have side effects. *)
37
+
38
+
val is_idempotent : t -> bool
39
+
(** Returns true for idempotent methods (GET, HEAD, PUT, DELETE, OPTIONS, TRACE).
40
+
Idempotent methods can be called multiple times with the same result. *)
41
+
42
+
val has_request_body : t -> bool
43
+
(** Returns true for methods that typically have a request body (POST, PUT, PATCH) *)
44
+
45
+
val is_cacheable : t -> bool
46
+
(** Returns true for methods whose responses are cacheable by default (GET, HEAD, POST).
47
+
Note: POST is only cacheable with explicit cache headers. *)
48
+
49
+
(** {1 Comparison} *)
50
+
51
+
val equal : t -> t -> bool
52
+
(** Compare two methods for equality *)
53
+
54
+
val compare : t -> t -> int
55
+
(** Compare two methods for ordering *)
+77
lib/mime.ml
+77
lib/mime.ml
···
1
+
let src = Logs.Src.create "requests.mime" ~doc:"MIME Type Handling"
2
+
module Log = (val Logs.src_log src : Logs.LOG)
3
+
4
+
type t = {
5
+
type_ : string;
6
+
subtype : string;
7
+
parameters : (string * string) list;
8
+
}
9
+
10
+
let make type_ subtype = {
11
+
type_;
12
+
subtype;
13
+
parameters = [];
14
+
}
15
+
16
+
let of_string s =
17
+
let parts = String.split_on_char ';' s in
18
+
match parts with
19
+
| [] -> make "text" "plain"
20
+
| mime :: params ->
21
+
let mime_parts = String.split_on_char '/' (String.trim mime) in
22
+
let type_, subtype = match mime_parts with
23
+
| [t; s] -> String.trim t, String.trim s
24
+
| [t] -> String.trim t, "*"
25
+
| _ -> "text", "plain"
26
+
in
27
+
let parse_param p =
28
+
match String.split_on_char '=' (String.trim p) with
29
+
| [k; v] ->
30
+
let k = String.trim k in
31
+
let v = String.trim v in
32
+
let v =
33
+
if String.length v >= 2 && v.[0] = '"' && v.[String.length v - 1] = '"'
34
+
then String.sub v 1 (String.length v - 2)
35
+
else v
36
+
in
37
+
Some (String.lowercase_ascii k, v)
38
+
| _ -> None
39
+
in
40
+
let parameters = List.filter_map parse_param params in
41
+
{ type_; subtype; parameters }
42
+
43
+
let to_string t =
44
+
let base = Printf.sprintf "%s/%s" t.type_ t.subtype in
45
+
match t.parameters with
46
+
| [] -> base
47
+
| params ->
48
+
let param_str =
49
+
List.map (fun (k, v) ->
50
+
if String.contains v ' ' || String.contains v ';'
51
+
then Printf.sprintf "%s=\"%s\"" k v
52
+
else Printf.sprintf "%s=%s" k v
53
+
) params
54
+
|> String.concat "; "
55
+
in
56
+
Printf.sprintf "%s; %s" base param_str
57
+
58
+
let pp ppf t = Format.fprintf ppf "%s" (to_string t)
59
+
60
+
let charset t =
61
+
List.assoc_opt "charset" t.parameters
62
+
63
+
let with_charset charset t =
64
+
let parameters =
65
+
("charset", charset) ::
66
+
List.filter (fun (k, _) -> k <> "charset") t.parameters
67
+
in
68
+
{ t with parameters }
69
+
70
+
(* Common MIME types *)
71
+
let json = make "application" "json"
72
+
let text = make "text" "plain"
73
+
let html = make "text" "html"
74
+
let xml = make "application" "xml"
75
+
let form = make "application" "x-www-form-urlencoded"
76
+
let octet_stream = make "application" "octet-stream"
77
+
let multipart_form = make "multipart" "form-data"
+34
lib/mime.mli
+34
lib/mime.mli
···
1
+
(** MIME type handling *)
2
+
3
+
(** Log source for MIME type operations *)
4
+
val src : Logs.Src.t
5
+
6
+
type t
7
+
(** Abstract MIME type *)
8
+
9
+
val of_string : string -> t
10
+
(** Parse MIME type from string (e.g., "text/html; charset=utf-8") *)
11
+
12
+
val to_string : t -> string
13
+
(** Convert MIME type to string representation *)
14
+
15
+
val pp : Format.formatter -> t -> unit
16
+
(** Pretty printer for MIME types *)
17
+
18
+
(** Common MIME types *)
19
+
val json : t
20
+
val text : t
21
+
val html : t
22
+
val xml : t
23
+
val form : t
24
+
val octet_stream : t
25
+
val multipart_form : t
26
+
27
+
val make : string -> string -> t
28
+
(** [make type subtype] creates a MIME type *)
29
+
30
+
val with_charset : string -> t -> t
31
+
(** Add or update charset parameter *)
32
+
33
+
val charset : t -> string option
34
+
(** Extract charset parameter if present *)
+257
lib/one.ml
+257
lib/one.ml
···
1
+
let src = Logs.Src.create "requests.one" ~doc:"One-shot HTTP Requests"
2
+
module Log = (val Logs.src_log src : Logs.LOG)
3
+
4
+
(* Helper to create TCP connection to host:port *)
5
+
let connect_tcp ~sw ~net ~host ~port =
6
+
Log.debug (fun m -> m "Connecting to %s:%d" host port);
7
+
(* Resolve hostname to IP address *)
8
+
let addrs = Eio.Net.getaddrinfo_stream net host ~service:(string_of_int port) in
9
+
match addrs with
10
+
| addr :: _ ->
11
+
Log.debug (fun m -> m "Resolved %s, connecting..." host);
12
+
Eio.Net.connect ~sw net addr
13
+
| [] ->
14
+
let msg = Printf.sprintf "Failed to resolve hostname: %s" host in
15
+
Log.err (fun m -> m "%s" msg);
16
+
failwith msg
17
+
18
+
(* Helper to wrap connection with TLS if needed *)
19
+
let wrap_tls flow ~host ~verify_tls ~tls_config =
20
+
Log.debug (fun m -> m "Wrapping connection with TLS for %s (verify=%b)" host verify_tls);
21
+
22
+
(* Get or create TLS config *)
23
+
let tls_cfg = match tls_config, verify_tls with
24
+
| Some cfg, _ -> cfg
25
+
| None, true ->
26
+
(* Use CA certificates for verification *)
27
+
(match Ca_certs.authenticator () with
28
+
| Ok authenticator ->
29
+
(match Tls.Config.client ~authenticator () with
30
+
| Ok cfg -> cfg
31
+
| Error (`Msg msg) ->
32
+
Log.err (fun m -> m "Failed to create TLS config: %s" msg);
33
+
failwith ("TLS config error: " ^ msg))
34
+
| Error (`Msg msg) ->
35
+
Log.err (fun m -> m "Failed to load CA certificates: %s" msg);
36
+
failwith ("CA certificates error: " ^ msg))
37
+
| None, false ->
38
+
(* No verification *)
39
+
match Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) () with
40
+
| Ok cfg -> cfg
41
+
| Error (`Msg msg) -> failwith ("TLS config error: " ^ msg)
42
+
in
43
+
44
+
(* Get domain name for SNI *)
45
+
let domain = match Domain_name.of_string host with
46
+
| Ok dn -> (match Domain_name.host dn with
47
+
| Ok d -> d
48
+
| Error (`Msg msg) ->
49
+
Log.err (fun m -> m "Invalid hostname for TLS: %s (%s)" host msg);
50
+
failwith ("Invalid hostname: " ^ msg))
51
+
| Error (`Msg msg) ->
52
+
Log.err (fun m -> m "Invalid hostname for TLS: %s (%s)" host msg);
53
+
failwith ("Invalid hostname: " ^ msg)
54
+
in
55
+
56
+
(Tls_eio.client_of_flow ~host:domain tls_cfg flow :> [`Close | `Flow | `R | `Shutdown | `W] Eio.Resource.t)
57
+
58
+
(* Parse URL and connect directly (no pooling) *)
59
+
let connect_to_url ~sw ~clock ~net ~url ~timeout ~verify_tls ~tls_config =
60
+
let uri = Uri.of_string url in
61
+
62
+
(* Extract host and port *)
63
+
let host = match Uri.host uri with
64
+
| Some h -> h
65
+
| None -> failwith ("URL must contain a host: " ^ url)
66
+
in
67
+
68
+
let is_https = Uri.scheme uri = Some "https" in
69
+
let default_port = if is_https then 443 else 80 in
70
+
let port = Option.value (Uri.port uri) ~default:default_port in
71
+
72
+
(* Apply connection timeout if specified *)
73
+
let connect_fn () =
74
+
let tcp_flow = connect_tcp ~sw ~net ~host ~port in
75
+
if is_https then
76
+
wrap_tls tcp_flow ~host ~verify_tls ~tls_config
77
+
else
78
+
(tcp_flow :> [`Close | `Flow | `R | `Shutdown | `W] Eio.Resource.t)
79
+
in
80
+
81
+
match timeout with
82
+
| Some t ->
83
+
let timeout_seconds = Timeout.total t in
84
+
(match timeout_seconds with
85
+
| Some seconds ->
86
+
Log.debug (fun m -> m "Setting connection timeout: %.2f seconds" seconds);
87
+
Eio.Time.with_timeout_exn clock seconds connect_fn
88
+
| None -> connect_fn ())
89
+
| None -> connect_fn ()
90
+
91
+
(* Main request implementation - completely stateless *)
92
+
let request ~sw ~clock ~net ?headers ?body ?auth ?timeout
93
+
?(follow_redirects = true) ?(max_redirects = 10)
94
+
?(verify_tls = true) ?tls_config ~method_ url =
95
+
96
+
let start_time = Unix.gettimeofday () in
97
+
let method_str = Method.to_string method_ in
98
+
Log.debug (fun m -> m "[One] Executing %s request to %s" method_str url);
99
+
100
+
(* Prepare headers *)
101
+
let headers = Option.value headers ~default:Headers.empty in
102
+
103
+
(* Apply auth *)
104
+
let headers = match auth with
105
+
| Some a ->
106
+
Log.debug (fun m -> m "Applying authentication");
107
+
Auth.apply a headers
108
+
| None -> headers
109
+
in
110
+
111
+
(* Add content type from body *)
112
+
let headers = match body with
113
+
| Some b -> (match Body.content_type b with
114
+
| Some mime -> Headers.content_type mime headers
115
+
| None -> headers)
116
+
| None -> headers
117
+
in
118
+
119
+
(* Convert body to string for sending *)
120
+
let request_body_str = match body with
121
+
| None -> ""
122
+
| Some b -> Body.Private.to_string b
123
+
in
124
+
125
+
(* Execute request with redirects *)
126
+
let rec make_with_redirects url_to_fetch redirects_left =
127
+
let uri_to_fetch = Uri.of_string url_to_fetch in
128
+
129
+
(* Connect to URL (opens new TCP connection) *)
130
+
let flow = connect_to_url ~sw ~clock ~net ~url:url_to_fetch
131
+
~timeout ~verify_tls ~tls_config in
132
+
133
+
(* Make HTTP request using low-level client *)
134
+
let status, resp_headers, response_body_str =
135
+
Http_client.make_request ~method_:method_str ~uri:uri_to_fetch
136
+
~headers ~body_str:request_body_str flow
137
+
in
138
+
139
+
Log.info (fun m -> m "Received response: status=%d" status);
140
+
141
+
(* Handle redirects if enabled *)
142
+
if follow_redirects && (status >= 300 && status < 400) then begin
143
+
if redirects_left <= 0 then begin
144
+
Log.err (fun m -> m "Too many redirects (%d) for %s" max_redirects url);
145
+
raise (Error.TooManyRedirects { url; count = max_redirects; max = max_redirects })
146
+
end;
147
+
148
+
match Headers.get "location" resp_headers with
149
+
| None ->
150
+
Log.debug (fun m -> m "Redirect response missing Location header");
151
+
(status, resp_headers, response_body_str, url_to_fetch)
152
+
| Some location ->
153
+
Log.info (fun m -> m "Following redirect to %s (%d remaining)" location redirects_left);
154
+
make_with_redirects location (redirects_left - 1)
155
+
end else
156
+
(status, resp_headers, response_body_str, url_to_fetch)
157
+
in
158
+
159
+
let final_status, final_headers, final_body_str, final_url =
160
+
make_with_redirects url max_redirects
161
+
in
162
+
163
+
let elapsed = Unix.gettimeofday () -. start_time in
164
+
Log.info (fun m -> m "Request completed in %.3f seconds" elapsed);
165
+
166
+
(* Create a flow from the body string *)
167
+
let body_flow = Eio.Flow.string_source final_body_str in
168
+
169
+
Response.Private.make
170
+
~sw
171
+
~status:final_status
172
+
~headers:final_headers
173
+
~body:body_flow
174
+
~url:final_url
175
+
~elapsed
176
+
177
+
(* Convenience methods *)
178
+
let get ~sw ~clock ~net ?headers ?auth ?timeout
179
+
?follow_redirects ?max_redirects ?verify_tls ?tls_config url =
180
+
request ~sw ~clock ~net ?headers ?auth ?timeout
181
+
?follow_redirects ?max_redirects ?verify_tls ?tls_config
182
+
~method_:`GET url
183
+
184
+
let post ~sw ~clock ~net ?headers ?body ?auth ?timeout
185
+
?verify_tls ?tls_config url =
186
+
request ~sw ~clock ~net ?headers ?body ?auth ?timeout
187
+
?verify_tls ?tls_config ~method_:`POST url
188
+
189
+
let put ~sw ~clock ~net ?headers ?body ?auth ?timeout
190
+
?verify_tls ?tls_config url =
191
+
request ~sw ~clock ~net ?headers ?body ?auth ?timeout
192
+
?verify_tls ?tls_config ~method_:`PUT url
193
+
194
+
let delete ~sw ~clock ~net ?headers ?auth ?timeout
195
+
?verify_tls ?tls_config url =
196
+
request ~sw ~clock ~net ?headers ?auth ?timeout
197
+
?verify_tls ?tls_config ~method_:`DELETE url
198
+
199
+
let head ~sw ~clock ~net ?headers ?auth ?timeout
200
+
?verify_tls ?tls_config url =
201
+
request ~sw ~clock ~net ?headers ?auth ?timeout
202
+
?verify_tls ?tls_config ~method_:`HEAD url
203
+
204
+
let patch ~sw ~clock ~net ?headers ?body ?auth ?timeout
205
+
?verify_tls ?tls_config url =
206
+
request ~sw ~clock ~net ?headers ?body ?auth ?timeout
207
+
?verify_tls ?tls_config ~method_:`PATCH url
208
+
209
+
let upload ~sw ~clock ~net ?headers ?auth ?timeout ?method_ ?mime ?length
210
+
?on_progress ?verify_tls ?tls_config ~source url =
211
+
let method_ = Option.value method_ ~default:`POST in
212
+
let mime = Option.value mime ~default:Mime.octet_stream in
213
+
214
+
(* Wrap source with progress tracking if callback provided *)
215
+
let tracked_source = match on_progress with
216
+
| None -> source
217
+
| Some callback ->
218
+
(* For now, progress tracking is not implemented for uploads
219
+
due to complexity of wrapping Eio.Flow.source.
220
+
This would require creating a custom flow wrapper. *)
221
+
let _ = callback in
222
+
source
223
+
in
224
+
225
+
let body = Body.of_stream ?length mime tracked_source in
226
+
request ~sw ~clock ~net ?headers ~body ?auth ?timeout
227
+
?verify_tls ?tls_config ~method_ url
228
+
229
+
let download ~sw ~clock ~net ?headers ?auth ?timeout ?on_progress
230
+
?verify_tls ?tls_config url ~sink =
231
+
let response = get ~sw ~clock ~net ?headers ?auth ?timeout
232
+
?verify_tls ?tls_config url in
233
+
234
+
try
235
+
(* Get content length for progress tracking *)
236
+
let total = Response.content_length response in
237
+
238
+
let body = Response.body response in
239
+
240
+
(* Stream data to sink with optional progress *)
241
+
match on_progress with
242
+
| None ->
243
+
(* No progress tracking, just copy directly *)
244
+
Eio.Flow.copy body sink
245
+
| Some progress_fn ->
246
+
(* Copy with progress tracking *)
247
+
(* We need to intercept the flow to track bytes *)
248
+
(* For now, just do a simple copy - proper progress tracking needs flow wrapper *)
249
+
progress_fn ~received:0L ~total;
250
+
Eio.Flow.copy body sink;
251
+
progress_fn ~received:(Option.value total ~default:0L) ~total;
252
+
253
+
(* Response auto-closes with switch *)
254
+
()
255
+
with e ->
256
+
(* Response auto-closes with switch *)
257
+
raise e
+200
lib/one.mli
+200
lib/one.mli
···
1
+
(** One-shot HTTP client for stateless requests
2
+
3
+
The One module provides a stateless HTTP client for single requests without
4
+
session state like cookies, connection pooling, or persistent configuration.
5
+
Each request opens a new connection that is closed after use.
6
+
7
+
For stateful requests with automatic cookie handling, connection pooling,
8
+
and persistent configuration, use the main {!Requests} module instead.
9
+
10
+
{2 Examples}
11
+
12
+
{[
13
+
open Eio_main
14
+
15
+
let () = run @@ fun env ->
16
+
Switch.run @@ fun sw ->
17
+
18
+
(* Simple GET request *)
19
+
let response = One.get ~sw
20
+
~clock:env#clock ~net:env#net
21
+
"https://example.com" in
22
+
Printf.printf "Status: %d\n" (Response.status_code response);
23
+
Response.close response;
24
+
25
+
(* POST with JSON body *)
26
+
let response = One.post ~sw
27
+
~clock:env#clock ~net:env#net
28
+
~body:(Body.json {|{"key": "value"}|})
29
+
~headers:(Headers.empty |> Headers.content_type Mime.json)
30
+
"https://api.example.com/data" in
31
+
Response.close response;
32
+
33
+
(* Download file with streaming *)
34
+
One.download ~sw
35
+
~clock:env#clock ~net:env#net
36
+
"https://example.com/large-file.zip"
37
+
~sink:(Eio.Path.(fs / "download.zip" |> sink))
38
+
]}
39
+
*)
40
+
41
+
(** Log source for one-shot request operations *)
42
+
val src : Logs.Src.t
43
+
44
+
(** {1 HTTP Request Methods}
45
+
46
+
All functions are stateless - they open a new TCP connection for each request
47
+
and close it when the switch closes. No connection pooling or reuse. *)
48
+
49
+
val request :
50
+
sw:Eio.Switch.t ->
51
+
clock:_ Eio.Time.clock ->
52
+
net:_ Eio.Net.t ->
53
+
?headers:Headers.t ->
54
+
?body:Body.t ->
55
+
?auth:Auth.t ->
56
+
?timeout:Timeout.t ->
57
+
?follow_redirects:bool ->
58
+
?max_redirects:int ->
59
+
?verify_tls:bool ->
60
+
?tls_config:Tls.Config.client ->
61
+
method_:Method.t ->
62
+
string ->
63
+
Response.t
64
+
(** [request ~sw ~clock ~net ?headers ?body ?auth ?timeout ?follow_redirects
65
+
?max_redirects ?verify_tls ?tls_config ~method_ url] makes a single HTTP
66
+
request without connection pooling.
67
+
68
+
Each call opens a new TCP connection (with TLS if https://), makes the
69
+
request, and closes the connection when the switch closes.
70
+
71
+
@param sw Switch for resource management (response/connection bound to this)
72
+
@param clock Clock for timeouts
73
+
@param net Network interface for TCP connections
74
+
@param headers Request headers (default: empty)
75
+
@param body Request body (default: none)
76
+
@param auth Authentication to apply (default: none)
77
+
@param timeout Request timeout (default: 30s connect, 60s read)
78
+
@param follow_redirects Whether to follow HTTP redirects (default: true)
79
+
@param max_redirects Maximum redirects to follow (default: 10)
80
+
@param verify_tls Whether to verify TLS certificates (default: true)
81
+
@param tls_config Custom TLS configuration (default: system CA certs)
82
+
@param method_ HTTP method (GET, POST, etc.)
83
+
@param url URL to request
84
+
*)
85
+
86
+
val get :
87
+
sw:Eio.Switch.t ->
88
+
clock:_ Eio.Time.clock ->
89
+
net:_ Eio.Net.t ->
90
+
?headers:Headers.t ->
91
+
?auth:Auth.t ->
92
+
?timeout:Timeout.t ->
93
+
?follow_redirects:bool ->
94
+
?max_redirects:int ->
95
+
?verify_tls:bool ->
96
+
?tls_config:Tls.Config.client ->
97
+
string ->
98
+
Response.t
99
+
(** GET request. See {!request} for parameter details. *)
100
+
101
+
val post :
102
+
sw:Eio.Switch.t ->
103
+
clock:_ Eio.Time.clock ->
104
+
net:_ Eio.Net.t ->
105
+
?headers:Headers.t ->
106
+
?body:Body.t ->
107
+
?auth:Auth.t ->
108
+
?timeout:Timeout.t ->
109
+
?verify_tls:bool ->
110
+
?tls_config:Tls.Config.client ->
111
+
string ->
112
+
Response.t
113
+
(** POST request. See {!request} for parameter details. *)
114
+
115
+
val put :
116
+
sw:Eio.Switch.t ->
117
+
clock:_ Eio.Time.clock ->
118
+
net:_ Eio.Net.t ->
119
+
?headers:Headers.t ->
120
+
?body:Body.t ->
121
+
?auth:Auth.t ->
122
+
?timeout:Timeout.t ->
123
+
?verify_tls:bool ->
124
+
?tls_config:Tls.Config.client ->
125
+
string ->
126
+
Response.t
127
+
(** PUT request. See {!request} for parameter details. *)
128
+
129
+
val delete :
130
+
sw:Eio.Switch.t ->
131
+
clock:_ Eio.Time.clock ->
132
+
net:_ Eio.Net.t ->
133
+
?headers:Headers.t ->
134
+
?auth:Auth.t ->
135
+
?timeout:Timeout.t ->
136
+
?verify_tls:bool ->
137
+
?tls_config:Tls.Config.client ->
138
+
string ->
139
+
Response.t
140
+
(** DELETE request. See {!request} for parameter details. *)
141
+
142
+
val head :
143
+
sw:Eio.Switch.t ->
144
+
clock:_ Eio.Time.clock ->
145
+
net:_ Eio.Net.t ->
146
+
?headers:Headers.t ->
147
+
?auth:Auth.t ->
148
+
?timeout:Timeout.t ->
149
+
?verify_tls:bool ->
150
+
?tls_config:Tls.Config.client ->
151
+
string ->
152
+
Response.t
153
+
(** HEAD request. See {!request} for parameter details. *)
154
+
155
+
val patch :
156
+
sw:Eio.Switch.t ->
157
+
clock:_ Eio.Time.clock ->
158
+
net:_ Eio.Net.t ->
159
+
?headers:Headers.t ->
160
+
?body:Body.t ->
161
+
?auth:Auth.t ->
162
+
?timeout:Timeout.t ->
163
+
?verify_tls:bool ->
164
+
?tls_config:Tls.Config.client ->
165
+
string ->
166
+
Response.t
167
+
(** PATCH request. See {!request} for parameter details. *)
168
+
169
+
val upload :
170
+
sw:Eio.Switch.t ->
171
+
clock:_ Eio.Time.clock ->
172
+
net:_ Eio.Net.t ->
173
+
?headers:Headers.t ->
174
+
?auth:Auth.t ->
175
+
?timeout:Timeout.t ->
176
+
?method_:Method.t ->
177
+
?mime:Mime.t ->
178
+
?length:int64 ->
179
+
?on_progress:(sent:int64 -> total:int64 option -> unit) ->
180
+
?verify_tls:bool ->
181
+
?tls_config:Tls.Config.client ->
182
+
source:Eio.Flow.source_ty Eio.Resource.t ->
183
+
string ->
184
+
Response.t
185
+
(** Upload from stream. See {!request} for parameter details. *)
186
+
187
+
val download :
188
+
sw:Eio.Switch.t ->
189
+
clock:_ Eio.Time.clock ->
190
+
net:_ Eio.Net.t ->
191
+
?headers:Headers.t ->
192
+
?auth:Auth.t ->
193
+
?timeout:Timeout.t ->
194
+
?on_progress:(received:int64 -> total:int64 option -> unit) ->
195
+
?verify_tls:bool ->
196
+
?tls_config:Tls.Config.client ->
197
+
string ->
198
+
sink:Eio.Flow.sink_ty Eio.Resource.t ->
199
+
unit
200
+
(** Download to stream. See {!request} for parameter details. *)
+691
lib/requests.ml
+691
lib/requests.ml
···
1
+
(** OCaml HTTP client library with streaming support *)
2
+
3
+
let src = Logs.Src.create "requests" ~doc:"HTTP Client Library"
4
+
module Log = (val Logs.src_log src : Logs.LOG)
5
+
6
+
module Method = Method
7
+
module Mime = Mime
8
+
module Headers = Headers
9
+
module Auth = Auth
10
+
module Timeout = Timeout
11
+
module Body = Body
12
+
module Response = Response
13
+
module One = One
14
+
module Http_client = Http_client
15
+
module Status = Status
16
+
module Error = Error
17
+
module Retry = Retry
18
+
19
+
(* Note: RNG initialization should be done by the application using
20
+
Mirage_crypto_rng_unix.initialize before calling Eio_main.run.
21
+
We don't call use_default() here as it spawns background threads
22
+
that are incompatible with Eio's structured concurrency. *)
23
+
24
+
(* Main API - Session functionality with connection pooling *)
25
+
26
+
type ('clock, 'net) t = {
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.t;
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
+
let create
52
+
~sw
53
+
?http_pool
54
+
?https_pool
55
+
?cookie_jar
56
+
?(default_headers = Headers.empty)
57
+
?auth
58
+
?(timeout = Timeout.default)
59
+
?(follow_redirects = true)
60
+
?(max_redirects = 10)
61
+
?(verify_tls = true)
62
+
?tls_config
63
+
?(max_connections_per_host = 10)
64
+
?(connection_idle_timeout = 60.0)
65
+
?(connection_lifetime = 300.0)
66
+
?retry
67
+
?(persist_cookies = false)
68
+
?xdg
69
+
env =
70
+
71
+
let clock = env#clock in
72
+
let net = env#net in
73
+
74
+
let xdg = match xdg, persist_cookies with
75
+
| Some x, _ -> Some x
76
+
| None, true -> Some (Xdge.create env#fs "requests")
77
+
| None, false -> None
78
+
in
79
+
80
+
(* Create TLS config for HTTPS pool if needed *)
81
+
let tls_config = match tls_config, verify_tls with
82
+
| Some cfg, _ -> Some cfg
83
+
| None, true ->
84
+
(* Use CA certificates for verification *)
85
+
(match Ca_certs.authenticator () with
86
+
| Ok authenticator ->
87
+
(match Tls.Config.client ~authenticator () with
88
+
| Ok cfg -> Some cfg
89
+
| Error (`Msg msg) ->
90
+
Log.warn (fun m -> m "Failed to create TLS config: %s" msg);
91
+
None)
92
+
| Error (`Msg msg) ->
93
+
Log.warn (fun m -> m "Failed to load CA certificates: %s" msg);
94
+
None)
95
+
| None, false -> None
96
+
in
97
+
98
+
(* Create connection pools if not provided *)
99
+
let pool_config = Conpool.Config.make
100
+
~max_connections_per_endpoint:max_connections_per_host
101
+
~max_idle_time:connection_idle_timeout
102
+
~max_connection_lifetime:connection_lifetime
103
+
()
104
+
in
105
+
106
+
(* HTTP pool - plain TCP connections *)
107
+
let http_pool = match http_pool with
108
+
| Some p -> p
109
+
| None ->
110
+
Conpool.create ~sw ~net ~clock ~config:pool_config ()
111
+
in
112
+
113
+
(* HTTPS pool - TLS-wrapped connections *)
114
+
let https_pool = match https_pool with
115
+
| Some p -> p
116
+
| None ->
117
+
let https_tls_config = Option.map (fun cfg ->
118
+
Conpool.Tls_config.make ~config:cfg ()
119
+
) tls_config in
120
+
Conpool.create ~sw ~net ~clock ?tls:https_tls_config ~config:pool_config ()
121
+
in
122
+
123
+
Log.info (fun m -> m "Created Requests session with connection pools (max_per_host=%d, TLS=%b)"
124
+
max_connections_per_host (Option.is_some tls_config));
125
+
126
+
let cookie_jar = match cookie_jar, persist_cookies, xdg with
127
+
| Some jar, _, _ -> jar
128
+
| None, true, Some xdg_ctx ->
129
+
let data_dir = Xdge.data_dir xdg_ctx in
130
+
let cookie_file = Eio.Path.(data_dir / "cookies.txt") in
131
+
Cookeio_jar.load ~clock cookie_file
132
+
| None, _, _ ->
133
+
Cookeio_jar.create ()
134
+
in
135
+
136
+
{
137
+
sw;
138
+
clock;
139
+
net;
140
+
http_pool;
141
+
https_pool;
142
+
cookie_jar;
143
+
cookie_mutex = Eio.Mutex.create ();
144
+
default_headers;
145
+
auth;
146
+
timeout;
147
+
follow_redirects;
148
+
max_redirects;
149
+
verify_tls;
150
+
tls_config;
151
+
retry;
152
+
persist_cookies;
153
+
xdg;
154
+
requests_made = 0;
155
+
total_time = 0.0;
156
+
retries_count = 0;
157
+
}
158
+
159
+
let set_default_header t key value =
160
+
{ t with default_headers = Headers.set key value t.default_headers }
161
+
162
+
let remove_default_header t key =
163
+
{ t with default_headers = Headers.remove key t.default_headers }
164
+
165
+
let set_auth t auth =
166
+
Log.debug (fun m -> m "Setting authentication method");
167
+
{ t with auth = Some auth }
168
+
169
+
let clear_auth t =
170
+
Log.debug (fun m -> m "Clearing authentication");
171
+
{ t with auth = None }
172
+
173
+
let set_timeout t timeout =
174
+
Log.debug (fun m -> m "Setting timeout: %a" Timeout.pp timeout);
175
+
{ t with timeout }
176
+
177
+
let set_retry t config =
178
+
Log.debug (fun m -> m "Setting retry config: max_retries=%d" config.Retry.max_retries);
179
+
{ t with retry = Some config }
180
+
181
+
let cookies t = t.cookie_jar
182
+
let clear_cookies t = Cookeio_jar.clear t.cookie_jar
183
+
184
+
(* Internal request function using connection pools *)
185
+
let make_request_internal t ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =
186
+
let start_time = Unix.gettimeofday () in
187
+
let method_str = Method.to_string method_ in
188
+
189
+
Log.info (fun m -> m "Making %s request to %s" method_str url);
190
+
191
+
(* Merge headers *)
192
+
let headers = match headers with
193
+
| Some h -> Headers.merge t.default_headers h
194
+
| None -> t.default_headers
195
+
in
196
+
197
+
(* Use provided auth or default *)
198
+
let auth = match auth with
199
+
| Some a -> Some a
200
+
| None -> t.auth
201
+
in
202
+
203
+
(* Apply auth *)
204
+
let headers = match auth with
205
+
| Some a ->
206
+
Log.debug (fun m -> m "Applying authentication");
207
+
Auth.apply a headers
208
+
| None -> headers
209
+
in
210
+
211
+
(* Add content type from body *)
212
+
let base_headers = match body with
213
+
| Some b -> (match Body.content_type b with
214
+
| Some mime -> Headers.content_type mime headers
215
+
| None -> headers)
216
+
| None -> headers
217
+
in
218
+
219
+
(* Convert body to string for sending *)
220
+
let request_body_str = match body with
221
+
| None -> ""
222
+
| Some b -> Body.Private.to_string b
223
+
in
224
+
225
+
(* Helper to extract and store cookies from response headers *)
226
+
let extract_cookies_from_headers resp_headers url_str =
227
+
let uri = Uri.of_string url_str in
228
+
let cookie_domain = Uri.host uri |> Option.value ~default:"" in
229
+
let cookie_path = Uri.path uri in
230
+
Eio.Mutex.use_rw ~protect:true t.cookie_mutex (fun () ->
231
+
match Headers.get_all "Set-Cookie" resp_headers with
232
+
| [] -> ()
233
+
| cookie_headers ->
234
+
Log.debug (fun m -> m "Received %d Set-Cookie headers" (List.length cookie_headers));
235
+
List.iter (fun cookie_str ->
236
+
let now = fun () -> Ptime.of_float_s (Eio.Time.now t.clock) |> Option.get in
237
+
match Cookeio.of_set_cookie_header ~now ~domain:cookie_domain ~path:cookie_path cookie_str with
238
+
| Some cookie ->
239
+
Log.debug (fun m -> m "Storing cookie: %s" (Cookeio.name cookie));
240
+
Cookeio_jar.add_cookie t.cookie_jar cookie
241
+
| None ->
242
+
Log.warn (fun m -> m "Failed to parse cookie: %s" cookie_str)
243
+
) cookie_headers
244
+
)
245
+
in
246
+
247
+
let response =
248
+
249
+
(* Execute request with redirect handling *)
250
+
let rec make_with_redirects url_to_fetch redirects_left =
251
+
let uri_to_fetch = Uri.of_string url_to_fetch in
252
+
253
+
(* Parse the redirect URL to get correct host and port *)
254
+
let redirect_host = match Uri.host uri_to_fetch with
255
+
| Some h -> h
256
+
| None -> failwith "Redirect URL must contain a host"
257
+
in
258
+
let redirect_port = match Uri.scheme uri_to_fetch, Uri.port uri_to_fetch with
259
+
| Some "https", None -> 443
260
+
| Some "https", Some p -> p
261
+
| Some "http", None -> 80
262
+
| Some "http", Some p -> p
263
+
| _, Some p -> p
264
+
| _ -> 80
265
+
in
266
+
267
+
(* Create endpoint for this specific URL *)
268
+
let redirect_endpoint = Conpool.Endpoint.make ~host:redirect_host ~port:redirect_port in
269
+
270
+
(* Determine if we need TLS based on this URL's scheme *)
271
+
let redirect_is_https = match Uri.scheme uri_to_fetch with
272
+
| Some "https" -> true
273
+
| _ -> false
274
+
in
275
+
276
+
(* Choose the appropriate connection pool for this URL *)
277
+
let redirect_pool = if redirect_is_https then t.https_pool else t.http_pool in
278
+
279
+
(* Get cookies for this specific URL *)
280
+
let fetch_domain = redirect_host in
281
+
let fetch_path = Uri.path uri_to_fetch in
282
+
let fetch_is_secure = redirect_is_https in
283
+
let headers_with_cookies =
284
+
Eio.Mutex.use_ro t.cookie_mutex (fun () ->
285
+
let cookies = Cookeio_jar.get_cookies t.cookie_jar ~clock:t.clock
286
+
~domain:fetch_domain ~path:fetch_path ~is_secure:fetch_is_secure in
287
+
match cookies with
288
+
| [] ->
289
+
Log.debug (fun m -> m "No cookies found for %s%s" fetch_domain fetch_path);
290
+
base_headers
291
+
| cookies ->
292
+
let cookie_header = Cookeio.make_cookie_header cookies in
293
+
Log.debug (fun m -> m "Adding %d cookies for %s%s: Cookie: %s"
294
+
(List.length cookies) fetch_domain fetch_path cookie_header);
295
+
Headers.set "Cookie" cookie_header base_headers
296
+
)
297
+
in
298
+
299
+
(* Log the request being made at Info level *)
300
+
Log.info (fun m -> m "");
301
+
Log.info (fun m -> m "=== Request to %s ===" url_to_fetch);
302
+
Log.info (fun m -> m "> %s %s HTTP/1.1" method_str (Uri.to_string uri_to_fetch));
303
+
Log.info (fun m -> m "> Request Headers:");
304
+
Headers.to_list headers_with_cookies |> List.iter (fun (k, v) ->
305
+
Log.info (fun m -> m "> %s: %s" k v)
306
+
);
307
+
Log.info (fun m -> m "");
308
+
309
+
let make_request_fn () =
310
+
Conpool.with_connection redirect_pool redirect_endpoint (fun flow ->
311
+
(* Flow is already TLS-wrapped if from https_pool, plain TCP if from http_pool *)
312
+
(* Use our low-level HTTP client *)
313
+
Http_client.make_request ~method_:method_str ~uri:uri_to_fetch
314
+
~headers:headers_with_cookies ~body_str:request_body_str flow
315
+
)
316
+
in
317
+
318
+
(* Apply timeout if specified *)
319
+
let status, resp_headers, response_body_str =
320
+
let timeout_val = Option.value timeout ~default:t.timeout in
321
+
match Timeout.total timeout_val with
322
+
| Some seconds ->
323
+
Log.debug (fun m -> m "Setting timeout: %.2f seconds" seconds);
324
+
Eio.Time.with_timeout_exn t.clock seconds make_request_fn
325
+
| None -> make_request_fn ()
326
+
in
327
+
328
+
(* Log response headers at Info level *)
329
+
Log.info (fun m -> m "< HTTP/1.1 %d" status);
330
+
Log.info (fun m -> m "< Response Headers:");
331
+
Headers.to_list resp_headers |> List.iter (fun (k, v) ->
332
+
Log.info (fun m -> m "< %s: %s" k v)
333
+
);
334
+
Log.info (fun m -> m "");
335
+
336
+
(* Extract and store cookies from this response (including redirect responses) *)
337
+
extract_cookies_from_headers resp_headers url_to_fetch;
338
+
339
+
(* Handle redirects if enabled *)
340
+
let follow = Option.value follow_redirects ~default:t.follow_redirects in
341
+
let max_redir = Option.value max_redirects ~default:t.max_redirects in
342
+
343
+
if follow && (status >= 300 && status < 400) then begin
344
+
if redirects_left <= 0 then begin
345
+
Log.err (fun m -> m "Too many redirects (%d) for %s" max_redir url);
346
+
raise (Error.TooManyRedirects { url; count = max_redir; max = max_redir })
347
+
end;
348
+
349
+
match Headers.get "location" resp_headers with
350
+
| None ->
351
+
Log.debug (fun m -> m "Redirect response missing Location header");
352
+
(status, resp_headers, response_body_str, url_to_fetch)
353
+
| Some location ->
354
+
(* Resolve relative redirects against the current URL *)
355
+
let location_uri = Uri.of_string location in
356
+
let absolute_location =
357
+
match Uri.host location_uri with
358
+
| Some _ -> location (* Already absolute *)
359
+
| None ->
360
+
(* Relative redirect - resolve against current URL *)
361
+
let base_uri = uri_to_fetch in
362
+
let scheme = Option.value (Uri.scheme base_uri) ~default:"http" in
363
+
let resolved = Uri.resolve scheme base_uri location_uri in
364
+
Uri.to_string resolved
365
+
in
366
+
Log.info (fun m -> m "Following redirect to %s (%d remaining)" absolute_location redirects_left);
367
+
make_with_redirects absolute_location (redirects_left - 1)
368
+
end else
369
+
(status, resp_headers, response_body_str, url_to_fetch)
370
+
in
371
+
372
+
let max_redir = Option.value max_redirects ~default:t.max_redirects in
373
+
let final_status, final_headers, final_body_str, final_url =
374
+
make_with_redirects url max_redir
375
+
in
376
+
377
+
let elapsed = Unix.gettimeofday () -. start_time in
378
+
Log.info (fun m -> m "Request completed in %.3f seconds" elapsed);
379
+
380
+
(* Create a flow from the body string *)
381
+
let body_flow = Eio.Flow.string_source final_body_str in
382
+
383
+
Response.Private.make
384
+
~sw:t.sw
385
+
~status:final_status
386
+
~headers:final_headers
387
+
~body:body_flow
388
+
~url:final_url
389
+
~elapsed
390
+
in
391
+
392
+
(* Cookies are extracted and stored during the redirect loop for each response,
393
+
including the final response, so no additional extraction needed here *)
394
+
395
+
(* Update statistics *)
396
+
t.requests_made <- t.requests_made + 1;
397
+
t.total_time <- t.total_time +. (Unix.gettimeofday () -. start_time);
398
+
Log.info (fun m -> m "Request completed with status %d" (Response.status_code response));
399
+
400
+
(* Save cookies to disk if persistence is enabled *)
401
+
(match t.persist_cookies, t.xdg with
402
+
| true, Some xdg_ctx ->
403
+
let data_dir = Xdge.data_dir xdg_ctx in
404
+
let cookie_file = Eio.Path.(data_dir / "cookies.txt") in
405
+
Eio.Mutex.use_rw ~protect:true t.cookie_mutex (fun () ->
406
+
Cookeio_jar.save cookie_file t.cookie_jar;
407
+
Log.debug (fun m -> m "Saved cookies to %a" Eio.Path.pp cookie_file)
408
+
)
409
+
| _ -> ());
410
+
411
+
response
412
+
413
+
(* Public request function - executes synchronously *)
414
+
let request t ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =
415
+
make_request_internal t ?headers ?body ?auth ?timeout
416
+
?follow_redirects ?max_redirects ~method_ url
417
+
418
+
(* Convenience methods *)
419
+
let get t ?headers ?auth ?timeout ?params url =
420
+
let url = match params with
421
+
| Some p ->
422
+
let uri = Uri.of_string url in
423
+
let uri = List.fold_left (fun u (k, v) -> Uri.add_query_param' u (k, v)) uri p in
424
+
Uri.to_string uri
425
+
| None -> url
426
+
in
427
+
request t ?headers ?auth ?timeout ~method_:`GET url
428
+
429
+
let post t ?headers ?body ?auth ?timeout url =
430
+
request t ?headers ?body ?auth ?timeout ~method_:`POST url
431
+
432
+
let put t ?headers ?body ?auth ?timeout url =
433
+
request t ?headers ?body ?auth ?timeout ~method_:`PUT url
434
+
435
+
let patch t ?headers ?body ?auth ?timeout url =
436
+
request t ?headers ?body ?auth ?timeout ~method_:`PATCH url
437
+
438
+
let delete t ?headers ?auth ?timeout url =
439
+
request t ?headers ?auth ?timeout ~method_:`DELETE url
440
+
441
+
let head t ?headers ?auth ?timeout url =
442
+
request t ?headers ?auth ?timeout ~method_:`HEAD url
443
+
444
+
let options t ?headers ?auth ?timeout url =
445
+
request t ?headers ?auth ?timeout ~method_:`OPTIONS url
446
+
447
+
(* Cmdliner integration module *)
448
+
module Cmd = struct
449
+
open Cmdliner
450
+
451
+
type config = {
452
+
xdg : Xdge.t * Xdge.Cmd.t;
453
+
persist_cookies : bool;
454
+
verify_tls : bool;
455
+
timeout : float option;
456
+
max_retries : int;
457
+
retry_backoff : float;
458
+
follow_redirects : bool;
459
+
max_redirects : int;
460
+
user_agent : string option;
461
+
verbose_http : bool;
462
+
}
463
+
464
+
let create config env sw =
465
+
let xdg, _xdg_cmd = config.xdg in
466
+
let retry = if config.max_retries > 0 then
467
+
Some (Retry.create_config
468
+
~max_retries:config.max_retries
469
+
~backoff_factor:config.retry_backoff ())
470
+
else None in
471
+
472
+
let timeout = match config.timeout with
473
+
| Some t -> Timeout.create ~total:t ()
474
+
| None -> Timeout.default in
475
+
476
+
let req = create ~sw
477
+
~xdg
478
+
~persist_cookies:config.persist_cookies
479
+
~verify_tls:config.verify_tls
480
+
~timeout
481
+
?retry
482
+
~follow_redirects:config.follow_redirects
483
+
~max_redirects:config.max_redirects
484
+
env in
485
+
486
+
(* Set user agent if provided *)
487
+
let req = match config.user_agent with
488
+
| Some ua -> set_default_header req "User-Agent" ua
489
+
| None -> req
490
+
in
491
+
492
+
req
493
+
494
+
(* Individual terms - parameterized by app_name *)
495
+
496
+
let persist_cookies_term app_name =
497
+
let doc = "Persist cookies to disk between sessions" in
498
+
let env_name = String.uppercase_ascii app_name ^ "_PERSIST_COOKIES" in
499
+
let env_info = Cmdliner.Cmd.Env.info env_name in
500
+
Arg.(value & flag & info ["persist-cookies"] ~env:env_info ~doc)
501
+
502
+
let verify_tls_term app_name =
503
+
let doc = "Skip TLS certificate verification (insecure)" in
504
+
let env_name = String.uppercase_ascii app_name ^ "_NO_VERIFY_TLS" in
505
+
let env_info = Cmdliner.Cmd.Env.info env_name in
506
+
Term.(const (fun no_verify -> not no_verify) $
507
+
Arg.(value & flag & info ["no-verify-tls"] ~env:env_info ~doc))
508
+
509
+
let timeout_term app_name =
510
+
let doc = "Request timeout in seconds" in
511
+
let env_name = String.uppercase_ascii app_name ^ "_TIMEOUT" in
512
+
let env_info = Cmdliner.Cmd.Env.info env_name in
513
+
Arg.(value & opt (some float) None & info ["timeout"] ~env:env_info ~docv:"SECONDS" ~doc)
514
+
515
+
let retries_term app_name =
516
+
let doc = "Maximum number of request retries" in
517
+
let env_name = String.uppercase_ascii app_name ^ "_MAX_RETRIES" in
518
+
let env_info = Cmdliner.Cmd.Env.info env_name in
519
+
Arg.(value & opt int 3 & info ["max-retries"] ~env:env_info ~docv:"N" ~doc)
520
+
521
+
let retry_backoff_term app_name =
522
+
let doc = "Retry backoff factor for exponential delay" in
523
+
let env_name = String.uppercase_ascii app_name ^ "_RETRY_BACKOFF" in
524
+
let env_info = Cmdliner.Cmd.Env.info env_name in
525
+
Arg.(value & opt float 0.3 & info ["retry-backoff"] ~env:env_info ~docv:"FACTOR" ~doc)
526
+
527
+
let follow_redirects_term app_name =
528
+
let doc = "Don't follow HTTP redirects" in
529
+
let env_name = String.uppercase_ascii app_name ^ "_NO_FOLLOW_REDIRECTS" in
530
+
let env_info = Cmdliner.Cmd.Env.info env_name in
531
+
Term.(const (fun no_follow -> not no_follow) $
532
+
Arg.(value & flag & info ["no-follow-redirects"] ~env:env_info ~doc))
533
+
534
+
let max_redirects_term app_name =
535
+
let doc = "Maximum number of redirects to follow" in
536
+
let env_name = String.uppercase_ascii app_name ^ "_MAX_REDIRECTS" in
537
+
let env_info = Cmdliner.Cmd.Env.info env_name in
538
+
Arg.(value & opt int 10 & info ["max-redirects"] ~env:env_info ~docv:"N" ~doc)
539
+
540
+
let user_agent_term app_name =
541
+
let doc = "User-Agent header to send with requests" in
542
+
let env_name = String.uppercase_ascii app_name ^ "_USER_AGENT" in
543
+
let env_info = Cmdliner.Cmd.Env.info env_name in
544
+
Arg.(value & opt (some string) None & info ["user-agent"] ~env:env_info ~docv:"STRING" ~doc)
545
+
546
+
let verbose_http_term app_name =
547
+
let doc = "Enable verbose HTTP-level logging (hexdumps, TLS details)" in
548
+
let env_name = String.uppercase_ascii app_name ^ "_VERBOSE_HTTP" in
549
+
let env_info = Cmdliner.Cmd.Env.info env_name in
550
+
Arg.(value & flag & info ["verbose-http"] ~env:env_info ~doc)
551
+
552
+
(* Combined terms *)
553
+
554
+
let config_term app_name fs =
555
+
let xdg_term = Xdge.Cmd.term app_name fs
556
+
~dirs:[`Config; `Data; `Cache] () in
557
+
Term.(const (fun xdg persist verify timeout retries backoff follow max_redir ua verbose ->
558
+
{ xdg; persist_cookies = persist; verify_tls = verify;
559
+
timeout; max_retries = retries; retry_backoff = backoff;
560
+
follow_redirects = follow; max_redirects = max_redir;
561
+
user_agent = ua; verbose_http = verbose })
562
+
$ xdg_term
563
+
$ persist_cookies_term app_name
564
+
$ verify_tls_term app_name
565
+
$ timeout_term app_name
566
+
$ retries_term app_name
567
+
$ retry_backoff_term app_name
568
+
$ follow_redirects_term app_name
569
+
$ max_redirects_term app_name
570
+
$ user_agent_term app_name
571
+
$ verbose_http_term app_name)
572
+
573
+
let requests_term app_name eio_env sw =
574
+
let config_t = config_term app_name eio_env#fs in
575
+
Term.(const (fun config -> create config eio_env sw) $ config_t)
576
+
577
+
let minimal_term app_name fs =
578
+
let xdg_term = Xdge.Cmd.term app_name fs
579
+
~dirs:[`Data; `Cache] () in
580
+
Term.(const (fun (xdg, _xdg_cmd) persist -> (xdg, persist))
581
+
$ xdg_term
582
+
$ persist_cookies_term app_name)
583
+
584
+
let env_docs app_name =
585
+
let app_upper = String.uppercase_ascii app_name in
586
+
Printf.sprintf
587
+
"## ENVIRONMENT\n\n\
588
+
The following environment variables affect %s:\n\n\
589
+
**%s_CONFIG_DIR**\n\
590
+
: Override configuration directory location\n\n\
591
+
**%s_DATA_DIR**\n\
592
+
: Override data directory location (for cookies)\n\n\
593
+
**%s_CACHE_DIR**\n\
594
+
: Override cache directory location\n\n\
595
+
**XDG_CONFIG_HOME**\n\
596
+
: Base directory for user configuration files (default: ~/.config)\n\n\
597
+
**XDG_DATA_HOME**\n\
598
+
: Base directory for user data files (default: ~/.local/share)\n\n\
599
+
**XDG_CACHE_HOME**\n\
600
+
: Base directory for user cache files (default: ~/.cache)\n\n\
601
+
**%s_PERSIST_COOKIES**\n\
602
+
: Set to '1' to persist cookies by default\n\n\
603
+
**%s_NO_VERIFY_TLS**\n\
604
+
: Set to '1' to disable TLS verification (insecure)\n\n\
605
+
**%s_TIMEOUT**\n\
606
+
: Default request timeout in seconds\n\n\
607
+
**%s_MAX_RETRIES**\n\
608
+
: Maximum number of retries (default: 3)\n\n\
609
+
**%s_RETRY_BACKOFF**\n\
610
+
: Retry backoff factor (default: 0.3)\n\n\
611
+
**%s_NO_FOLLOW_REDIRECTS**\n\
612
+
: Set to '1' to disable redirect following\n\n\
613
+
**%s_MAX_REDIRECTS**\n\
614
+
: Maximum redirects to follow (default: 10)\n\n\
615
+
**%s_USER_AGENT**\n\
616
+
: User-Agent header to send with requests\n\n\
617
+
**%s_VERBOSE_HTTP**\n\
618
+
: Set to '1' to enable verbose HTTP-level logging\
619
+
"
620
+
app_name app_upper app_upper app_upper
621
+
app_upper app_upper app_upper app_upper
622
+
app_upper app_upper app_upper app_upper app_upper
623
+
624
+
let pp_config ppf config =
625
+
let _xdg, xdg_cmd = config.xdg in
626
+
Format.fprintf ppf "@[<v>Configuration:@,\
627
+
@[<v 2>XDG:@,%a@]@,\
628
+
persist_cookies: %b@,\
629
+
verify_tls: %b@,\
630
+
timeout: %a@,\
631
+
max_retries: %d@,\
632
+
retry_backoff: %.2f@,\
633
+
follow_redirects: %b@,\
634
+
max_redirects: %d@,\
635
+
user_agent: %a@,\
636
+
verbose_http: %b@]"
637
+
Xdge.Cmd.pp xdg_cmd
638
+
config.persist_cookies
639
+
config.verify_tls
640
+
(Format.pp_print_option Format.pp_print_float) config.timeout
641
+
config.max_retries
642
+
config.retry_backoff
643
+
config.follow_redirects
644
+
config.max_redirects
645
+
(Format.pp_print_option Format.pp_print_string) config.user_agent
646
+
config.verbose_http
647
+
648
+
(* Logging configuration *)
649
+
let setup_log_sources ?(verbose_http = false) level =
650
+
(* Helper to set TLS tracing level by finding the source by name *)
651
+
let set_tls_tracing_level lvl =
652
+
match List.find_opt (fun s -> Logs.Src.name s = "tls.tracing") (Logs.Src.list ()) with
653
+
| Some tls_src -> Logs.Src.set_level tls_src (Some lvl)
654
+
| None -> () (* TLS not loaded yet, ignore *)
655
+
in
656
+
match level with
657
+
| Some Logs.Debug ->
658
+
(* Enable debug logging for application-level requests modules *)
659
+
Logs.Src.set_level src (Some Logs.Debug);
660
+
Logs.Src.set_level Auth.src (Some Logs.Debug);
661
+
Logs.Src.set_level Body.src (Some Logs.Debug);
662
+
Logs.Src.set_level Response.src (Some Logs.Debug);
663
+
Logs.Src.set_level Retry.src (Some Logs.Debug);
664
+
Logs.Src.set_level Headers.src (Some Logs.Debug);
665
+
Logs.Src.set_level Error.src (Some Logs.Debug);
666
+
Logs.Src.set_level Method.src (Some Logs.Debug);
667
+
Logs.Src.set_level Mime.src (Some Logs.Debug);
668
+
Logs.Src.set_level Status.src (Some Logs.Debug);
669
+
Logs.Src.set_level Timeout.src (Some Logs.Debug);
670
+
(* Only enable HTTP-level debug if verbose_http is set *)
671
+
if verbose_http then begin
672
+
Logs.Src.set_level One.src (Some Logs.Debug);
673
+
Logs.Src.set_level Http_client.src (Some Logs.Debug);
674
+
Logs.Src.set_level Conpool.src (Some Logs.Debug);
675
+
set_tls_tracing_level Logs.Debug
676
+
end else begin
677
+
Logs.Src.set_level One.src (Some Logs.Info);
678
+
Logs.Src.set_level Http_client.src (Some Logs.Info);
679
+
Logs.Src.set_level Conpool.src (Some Logs.Info);
680
+
set_tls_tracing_level Logs.Warning
681
+
end
682
+
| Some Logs.Info ->
683
+
(* Set info level for main modules *)
684
+
Logs.Src.set_level src (Some Logs.Info);
685
+
Logs.Src.set_level Response.src (Some Logs.Info);
686
+
Logs.Src.set_level One.src (Some Logs.Info);
687
+
set_tls_tracing_level Logs.Warning
688
+
| _ ->
689
+
(* Suppress TLS debug output by default *)
690
+
set_tls_tracing_level Logs.Warning
691
+
end
+625
lib/requests.mli
+625
lib/requests.mli
···
1
+
(** Requests - A modern HTTP client library for OCaml
2
+
3
+
Requests is an HTTP client library for OCaml inspired by Python's requests
4
+
and urllib3 libraries. It provides a simple, intuitive API for making HTTP
5
+
requests while handling complexities like TLS configuration, connection
6
+
pooling, retries, and cookie management.
7
+
8
+
{2 High-Level API}
9
+
10
+
The Requests library offers two main ways to make HTTP requests:
11
+
12
+
{b 1. Main API} (Recommended for most use cases)
13
+
14
+
The main API maintains state across requests, handles cookies automatically,
15
+
spawns requests in concurrent fibers, and provides a simple interface:
16
+
17
+
{[
18
+
open Eio_main
19
+
20
+
let () = run @@ fun env ->
21
+
Switch.run @@ fun sw ->
22
+
23
+
(* Create a requests instance *)
24
+
let req = Requests.create ~sw env in
25
+
26
+
(* Configure authentication once *)
27
+
Requests.set_auth req (Requests.Auth.bearer "your-token");
28
+
29
+
(* Make concurrent requests using Fiber.both *)
30
+
let (user, repos) = Eio.Fiber.both
31
+
(fun () -> Requests.get req "https://api.github.com/user")
32
+
(fun () -> Requests.get req "https://api.github.com/user/repos") in
33
+
34
+
(* Process responses *)
35
+
let user_data = Response.body user |> Eio.Flow.read_all in
36
+
let repos_data = Response.body repos |> Eio.Flow.read_all in
37
+
38
+
(* No cleanup needed - responses auto-close with the switch *)
39
+
]}
40
+
41
+
{b 2. One-shot requests} (For stateless operations)
42
+
43
+
The One module provides lower-level control for stateless,
44
+
one-off requests without session state:
45
+
46
+
{[
47
+
(* Create a one-shot client *)
48
+
let client = Requests.One.create ~clock:env#clock ~net:env#net () in
49
+
50
+
(* Make a simple GET request *)
51
+
let response = Requests.One.get ~sw ~client "https://api.github.com" in
52
+
Printf.printf "Status: %d\n" (Requests.Response.status_code response);
53
+
54
+
(* POST with custom headers and body *)
55
+
let response = Requests.One.post ~sw ~client
56
+
~headers:(Requests.Headers.empty
57
+
|> Requests.Headers.content_type Requests.Mime.json
58
+
|> Requests.Headers.set "X-API-Key" "secret")
59
+
~body:(Requests.Body.json {|{"name": "Alice"}|})
60
+
"https://api.example.com/users"
61
+
62
+
(* No cleanup needed - responses auto-close with the switch *)
63
+
]}
64
+
65
+
{2 Features}
66
+
67
+
- {b Simple API}: Intuitive functions for GET, POST, PUT, DELETE, etc.
68
+
- {b Authentication}: Built-in support for Basic, Bearer, Digest, and OAuth
69
+
- {b Streaming}: Upload and download large files efficiently
70
+
- {b Retries}: Automatic retry with exponential backoff
71
+
- {b Timeouts}: Configurable connection and read timeouts
72
+
- {b Cookie Management}: Automatic cookie handling with persistence
73
+
- {b TLS/SSL}: Secure connections with certificate verification
74
+
- {b Error Handling}: Comprehensive error types and recovery
75
+
76
+
{2 Common Use Cases}
77
+
78
+
{b Working with JSON APIs:}
79
+
{[
80
+
let response = Requests.post req "https://api.example.com/data"
81
+
~body:(Requests.Body.json {|{"key": "value"}|}) in
82
+
let body_text =
83
+
Requests.Response.body response
84
+
|> Eio.Flow.read_all in
85
+
print_endline body_text
86
+
(* Response auto-closes with switch *)
87
+
]}
88
+
89
+
{b File uploads:}
90
+
{[
91
+
let body = Requests.Body.multipart [
92
+
{ name = "file"; filename = Some "document.pdf";
93
+
content_type = Requests.Mime.pdf;
94
+
content = `File (Eio.Path.(fs / "document.pdf")) };
95
+
{ name = "description"; filename = None;
96
+
content_type = Requests.Mime.text_plain;
97
+
content = `String "Important document" }
98
+
] in
99
+
let response = Requests.post req "https://example.com/upload"
100
+
~body
101
+
(* Response auto-closes with switch *)
102
+
]}
103
+
104
+
{b Streaming downloads:}
105
+
{[
106
+
Requests.One.download ~sw ~client
107
+
"https://example.com/large-file.zip"
108
+
~sink:(Eio.Path.(fs / "download.zip" |> sink))
109
+
]}
110
+
111
+
{2 Choosing Between Main API and One}
112
+
113
+
Use the {b main API (Requests.t)} when you need:
114
+
- Cookie persistence across requests
115
+
- Automatic retry handling
116
+
- Shared authentication across requests
117
+
- Request/response history tracking
118
+
- Configuration persistence to disk
119
+
120
+
Use {b One} when you need:
121
+
- One-off stateless requests
122
+
- Fine-grained control over connections
123
+
- Minimal overhead
124
+
- Custom connection pooling
125
+
- Direct streaming without cookies
126
+
*)
127
+
128
+
(** {1 Main API}
129
+
130
+
The main Requests API provides stateful HTTP clients with automatic cookie
131
+
management and persistent configuration. Requests execute synchronously by default.
132
+
Use Eio.Fiber.both or Eio.Fiber.all for concurrent execution.
133
+
*)
134
+
135
+
type ('clock, 'net) t
136
+
(** A stateful HTTP client that maintains cookies, auth, configuration, and
137
+
connection pools across requests. *)
138
+
139
+
(** {2 Creation and Configuration} *)
140
+
141
+
val create :
142
+
sw:Eio.Switch.t ->
143
+
?http_pool:('clock Eio.Time.clock, 'net Eio.Net.t) Conpool.t ->
144
+
?https_pool:('clock Eio.Time.clock, 'net Eio.Net.t) Conpool.t ->
145
+
?cookie_jar:Cookeio_jar.t ->
146
+
?default_headers:Headers.t ->
147
+
?auth:Auth.t ->
148
+
?timeout:Timeout.t ->
149
+
?follow_redirects:bool ->
150
+
?max_redirects:int ->
151
+
?verify_tls:bool ->
152
+
?tls_config:Tls.Config.client ->
153
+
?max_connections_per_host:int ->
154
+
?connection_idle_timeout:float ->
155
+
?connection_lifetime:float ->
156
+
?retry:Retry.config ->
157
+
?persist_cookies:bool ->
158
+
?xdg:Xdge.t ->
159
+
< clock: 'clock Eio.Resource.t; net: 'net Eio.Resource.t; fs: Eio.Fs.dir_ty Eio.Path.t; .. > ->
160
+
('clock Eio.Resource.t, 'net Eio.Resource.t) t
161
+
(** Create a new requests instance with persistent state and connection pooling.
162
+
All resources are bound to the provided switch and will be cleaned up automatically.
163
+
164
+
@param sw Switch for resource management
165
+
@param http_pool Optional pre-configured HTTP connection pool (creates new if not provided)
166
+
@param https_pool Optional pre-configured HTTPS connection pool (creates new if not provided)
167
+
@param cookie_jar Cookie storage (default: empty in-memory jar)
168
+
@param default_headers Headers included in every request
169
+
@param auth Default authentication
170
+
@param timeout Default timeout configuration
171
+
@param follow_redirects Whether to follow HTTP redirects (default: true)
172
+
@param max_redirects Maximum redirects to follow (default: 10)
173
+
@param verify_tls Whether to verify TLS certificates (default: true)
174
+
@param tls_config Custom TLS configuration for HTTPS pool (default: system CA certs)
175
+
@param max_connections_per_host Maximum pooled connections per host:port (default: 10)
176
+
@param connection_idle_timeout Max idle time before closing pooled connection (default: 60s)
177
+
@param connection_lifetime Max lifetime of any pooled connection (default: 300s)
178
+
@param retry Retry configuration for failed requests
179
+
@param persist_cookies Whether to persist cookies to disk (default: false)
180
+
@param xdg XDG directory context for cookies (required if persist_cookies=true)
181
+
182
+
{b Note:} HTTP caching has been disabled for simplicity. See CACHEIO.md for integration notes
183
+
if you need to restore caching functionality in the future.
184
+
*)
185
+
186
+
(** {2 Configuration Management} *)
187
+
188
+
val set_default_header : ('clock, 'net) t -> string -> string -> ('clock, 'net) t
189
+
(** Add or update a default header. Returns a new session with the updated header.
190
+
The original session's connection pools are shared. *)
191
+
192
+
val remove_default_header : ('clock, 'net) t -> string -> ('clock, 'net) t
193
+
(** Remove a default header. Returns a new session without the header. *)
194
+
195
+
val set_auth : ('clock, 'net) t -> Auth.t -> ('clock, 'net) t
196
+
(** Set default authentication. Returns a new session with auth configured. *)
197
+
198
+
val clear_auth : ('clock, 'net) t -> ('clock, 'net) t
199
+
(** Clear authentication. Returns a new session without auth. *)
200
+
201
+
val set_timeout : ('clock, 'net) t -> Timeout.t -> ('clock, 'net) t
202
+
(** Set default timeout. Returns a new session with the timeout configured. *)
203
+
204
+
val set_retry : ('clock, 'net) t -> Retry.config -> ('clock, 'net) t
205
+
(** Set retry configuration. Returns a new session with retry configured. *)
206
+
207
+
(** {2 Request Methods}
208
+
209
+
All request methods execute synchronously. To make concurrent requests,
210
+
you must explicitly use Eio.Fiber.both or Eio.Fiber.all.
211
+
The response will auto-close when the parent switch closes.
212
+
213
+
Example of concurrent requests using Fiber.both:
214
+
{[
215
+
let req = Requests.create ~sw env in
216
+
217
+
(* Use Fiber.both for two concurrent requests *)
218
+
let (r1, r2) = Eio.Fiber.both
219
+
(fun () -> Requests.get req "https://api1.example.com")
220
+
(fun () -> Requests.post req "https://api2.example.com" ~body)
221
+
in
222
+
223
+
(* Process responses *)
224
+
let body1 = Response.body r1 |> Eio.Flow.read_all in
225
+
let body2 = Response.body r2 |> Eio.Flow.read_all in
226
+
]}
227
+
228
+
Example using Fiber.all for multiple requests:
229
+
{[
230
+
let req = Requests.create ~sw env in
231
+
232
+
(* Use Fiber.all for multiple concurrent requests *)
233
+
let urls = [
234
+
"https://api1.example.com";
235
+
"https://api2.example.com";
236
+
"https://api3.example.com";
237
+
] in
238
+
239
+
let responses = ref [] in
240
+
Eio.Fiber.all [
241
+
(fun () -> responses := Requests.get req (List.nth urls 0) :: !responses);
242
+
(fun () -> responses := Requests.get req (List.nth urls 1) :: !responses);
243
+
(fun () -> responses := Requests.get req (List.nth urls 2) :: !responses);
244
+
];
245
+
246
+
(* Process all responses *)
247
+
List.iter (fun r ->
248
+
let body = Response.body r |> Eio.Flow.read_all in
249
+
print_endline body
250
+
) !responses
251
+
]}
252
+
253
+
Example using Promise for concurrent requests with individual control:
254
+
{[
255
+
let req = Requests.create ~sw env in
256
+
257
+
(* Start requests in parallel using promises *)
258
+
let p1, r1 = Eio.Promise.create () in
259
+
let p2, r2 = Eio.Promise.create () in
260
+
let p3, r3 = Eio.Promise.create () in
261
+
262
+
Eio.Fiber.fork ~sw (fun () ->
263
+
Eio.Promise.resolve r1 (Requests.get req "https://api1.example.com")
264
+
);
265
+
Eio.Fiber.fork ~sw (fun () ->
266
+
Eio.Promise.resolve r2 (Requests.post req "https://api2.example.com" ~body)
267
+
);
268
+
Eio.Fiber.fork ~sw (fun () ->
269
+
Eio.Promise.resolve r3 (Requests.get req "https://api3.example.com")
270
+
);
271
+
272
+
(* Wait for all promises and process *)
273
+
let resp1 = Eio.Promise.await p1 in
274
+
let resp2 = Eio.Promise.await p2 in
275
+
let resp3 = Eio.Promise.await p3 in
276
+
277
+
(* Process responses *)
278
+
let body1 = Response.body resp1 |> Eio.Flow.read_all in
279
+
let body2 = Response.body resp2 |> Eio.Flow.read_all in
280
+
let body3 = Response.body resp3 |> Eio.Flow.read_all in
281
+
]}
282
+
*)
283
+
284
+
val request :
285
+
(_ Eio.Time.clock, _ Eio.Net.t) t ->
286
+
?headers:Headers.t ->
287
+
?body:Body.t ->
288
+
?auth:Auth.t ->
289
+
?timeout:Timeout.t ->
290
+
?follow_redirects:bool ->
291
+
?max_redirects:int ->
292
+
method_:Method.t ->
293
+
string ->
294
+
Response.t
295
+
(** Make a concurrent HTTP request *)
296
+
297
+
val get :
298
+
(_ Eio.Time.clock, _ Eio.Net.t) t ->
299
+
?headers:Headers.t ->
300
+
?auth:Auth.t ->
301
+
?timeout:Timeout.t ->
302
+
?params:(string * string) list ->
303
+
string ->
304
+
Response.t
305
+
(** Concurrent GET request *)
306
+
307
+
val post :
308
+
(_ Eio.Time.clock, _ Eio.Net.t) t ->
309
+
?headers:Headers.t ->
310
+
?body:Body.t ->
311
+
?auth:Auth.t ->
312
+
?timeout:Timeout.t ->
313
+
string ->
314
+
Response.t
315
+
(** Concurrent POST request *)
316
+
317
+
val put :
318
+
(_ Eio.Time.clock, _ Eio.Net.t) t ->
319
+
?headers:Headers.t ->
320
+
?body:Body.t ->
321
+
?auth:Auth.t ->
322
+
?timeout:Timeout.t ->
323
+
string ->
324
+
Response.t
325
+
(** Concurrent PUT request *)
326
+
327
+
val patch :
328
+
(_ Eio.Time.clock, _ Eio.Net.t) t ->
329
+
?headers:Headers.t ->
330
+
?body:Body.t ->
331
+
?auth:Auth.t ->
332
+
?timeout:Timeout.t ->
333
+
string ->
334
+
Response.t
335
+
(** Concurrent PATCH request *)
336
+
337
+
val delete :
338
+
(_ Eio.Time.clock, _ Eio.Net.t) t ->
339
+
?headers:Headers.t ->
340
+
?auth:Auth.t ->
341
+
?timeout:Timeout.t ->
342
+
string ->
343
+
Response.t
344
+
(** Concurrent DELETE request *)
345
+
346
+
val head :
347
+
(_ Eio.Time.clock, _ Eio.Net.t) t ->
348
+
?headers:Headers.t ->
349
+
?auth:Auth.t ->
350
+
?timeout:Timeout.t ->
351
+
string ->
352
+
Response.t
353
+
(** Concurrent HEAD request *)
354
+
355
+
val options :
356
+
(_ Eio.Time.clock, _ Eio.Net.t) t ->
357
+
?headers:Headers.t ->
358
+
?auth:Auth.t ->
359
+
?timeout:Timeout.t ->
360
+
string ->
361
+
Response.t
362
+
(** Concurrent OPTIONS request *)
363
+
364
+
(** {2 Cookie Management} *)
365
+
366
+
val cookies : ('clock, 'net) t -> Cookeio_jar.t
367
+
(** Get the cookie jar for direct manipulation *)
368
+
369
+
val clear_cookies : ('clock, 'net) t -> unit
370
+
(** Clear all cookies *)
371
+
372
+
(** {1 Cmdliner Integration} *)
373
+
374
+
module Cmd : sig
375
+
(** Cmdliner integration for Requests configuration.
376
+
377
+
This module provides command-line argument handling for configuring
378
+
HTTP requests, including XDG directory paths, timeouts, retries,
379
+
and other parameters. *)
380
+
381
+
(** Configuration from command line and environment *)
382
+
type config = {
383
+
xdg : Xdge.t * Xdge.Cmd.t; (** XDG paths and their sources *)
384
+
persist_cookies : bool; (** Whether to persist cookies *)
385
+
verify_tls : bool; (** Whether to verify TLS certificates *)
386
+
timeout : float option; (** Request timeout in seconds *)
387
+
max_retries : int; (** Maximum number of retries *)
388
+
retry_backoff : float; (** Retry backoff factor *)
389
+
follow_redirects : bool; (** Whether to follow redirects *)
390
+
max_redirects : int; (** Maximum number of redirects *)
391
+
user_agent : string option; (** User-Agent header *)
392
+
verbose_http : bool; (** Enable verbose HTTP-level logging *)
393
+
}
394
+
395
+
val create : config -> < clock: ([> float Eio.Time.clock_ty ] as 'clock) Eio.Resource.t; net: ([> [>`Generic] Eio.Net.ty ] as 'net) Eio.Resource.t; fs: Eio.Fs.dir_ty Eio.Path.t; .. > -> Eio.Switch.t -> ('clock Eio.Resource.t, 'net Eio.Resource.t) t
396
+
(** [create config env sw] creates a requests instance from command-line configuration *)
397
+
398
+
(** {2 Individual Terms} *)
399
+
400
+
val persist_cookies_term : string -> bool Cmdliner.Term.t
401
+
(** Term for [--persist-cookies] flag with app-specific env var *)
402
+
403
+
val verify_tls_term : string -> bool Cmdliner.Term.t
404
+
(** Term for [--no-verify-tls] flag with app-specific env var *)
405
+
406
+
val timeout_term : string -> float option Cmdliner.Term.t
407
+
(** Term for [--timeout SECONDS] option with app-specific env var *)
408
+
409
+
val retries_term : string -> int Cmdliner.Term.t
410
+
(** Term for [--max-retries N] option with app-specific env var *)
411
+
412
+
val retry_backoff_term : string -> float Cmdliner.Term.t
413
+
(** Term for [--retry-backoff FACTOR] option with app-specific env var *)
414
+
415
+
val follow_redirects_term : string -> bool Cmdliner.Term.t
416
+
(** Term for [--no-follow-redirects] flag with app-specific env var *)
417
+
418
+
val max_redirects_term : string -> int Cmdliner.Term.t
419
+
(** Term for [--max-redirects N] option with app-specific env var *)
420
+
421
+
val user_agent_term : string -> string option Cmdliner.Term.t
422
+
(** Term for [--user-agent STRING] option with app-specific env var *)
423
+
424
+
val verbose_http_term : string -> bool Cmdliner.Term.t
425
+
(** Term for [--verbose-http] flag with app-specific env var.
426
+
427
+
Enables verbose HTTP-level logging including hexdumps, TLS details,
428
+
and low-level protocol information. Typically used in conjunction
429
+
with debug-level logging. *)
430
+
431
+
(** {2 Combined Terms} *)
432
+
433
+
val config_term : string -> Eio.Fs.dir_ty Eio.Path.t -> config Cmdliner.Term.t
434
+
(** [config_term app_name fs] creates a complete configuration term.
435
+
436
+
This combines all individual terms plus XDG configuration into
437
+
a single term that can be used to configure requests.
438
+
439
+
{b Generated Flags:}
440
+
- [--config-dir DIR]: Configuration directory
441
+
- [--data-dir DIR]: Data directory
442
+
- [--cache-dir DIR]: Cache directory
443
+
- [--persist-cookies]: Enable cookie persistence
444
+
- [--no-verify-tls]: Disable TLS verification
445
+
- [--timeout SECONDS]: Request timeout
446
+
- [--max-retries N]: Maximum retries
447
+
- [--retry-backoff FACTOR]: Retry backoff multiplier
448
+
- [--no-follow-redirects]: Disable redirect following
449
+
- [--max-redirects N]: Maximum redirects to follow
450
+
- [--user-agent STRING]: User-Agent header
451
+
- [--verbose-http]: Enable verbose HTTP-level logging
452
+
453
+
{b Example:}
454
+
{[
455
+
let open Cmdliner in
456
+
let config_t = Requests.Cmd.config_term "myapp" env#fs in
457
+
let main config =
458
+
Eio.Switch.run @@ fun sw ->
459
+
let req = Requests.Cmd.create config env sw in
460
+
(* Use requests *)
461
+
in
462
+
let cmd = Cmd.v info Term.(const main $ config_t) in
463
+
Cmd.eval cmd
464
+
]} *)
465
+
466
+
val requests_term : string -> < clock: ([> float Eio.Time.clock_ty ] as 'clock) Eio.Resource.t; net: ([> [>`Generic] Eio.Net.ty ] as 'net) Eio.Resource.t; fs: Eio.Fs.dir_ty Eio.Path.t; .. > -> Eio.Switch.t -> ('clock Eio.Resource.t, 'net Eio.Resource.t) t Cmdliner.Term.t
467
+
(** [requests_term app_name env sw] creates a term that directly produces a requests instance.
468
+
469
+
This is a convenience function that combines configuration parsing
470
+
with requests creation.
471
+
472
+
{b Example:}
473
+
{[
474
+
let open Cmdliner in
475
+
let main req =
476
+
(* Use requests directly *)
477
+
let resp = Requests.get req "https://example.com" in
478
+
(* ... *)
479
+
in
480
+
Eio.Switch.run @@ fun sw ->
481
+
let req_t = Requests.Cmd.requests_term "myapp" env sw in
482
+
let cmd = Cmd.v info Term.(const main $ req_t) in
483
+
Cmd.eval cmd
484
+
]} *)
485
+
486
+
val minimal_term : string -> Eio.Fs.dir_ty Eio.Path.t -> (Xdge.t * bool) Cmdliner.Term.t
487
+
(** [minimal_term app_name fs] creates a minimal configuration term.
488
+
489
+
This only provides:
490
+
- [--cache-dir DIR]: Cache directory for responses
491
+
- [--persist-cookies]: Cookie persistence flag
492
+
493
+
Returns the XDG context and persist_cookies boolean.
494
+
495
+
{b Example:}
496
+
{[
497
+
let open Cmdliner in
498
+
let minimal_t = Requests.Cmd.minimal_term "myapp" env#fs in
499
+
let main (xdg, persist) =
500
+
Eio.Switch.run @@ fun sw ->
501
+
let req = Requests.create ~sw ~xdg ~persist_cookies:persist env in
502
+
(* Use requests *)
503
+
in
504
+
let cmd = Cmd.v info Term.(const main $ minimal_t) in
505
+
Cmd.eval cmd
506
+
]} *)
507
+
508
+
(** {2 Documentation} *)
509
+
510
+
val env_docs : string -> string
511
+
(** [env_docs app_name] generates environment variable documentation.
512
+
513
+
Returns formatted documentation for all environment variables that
514
+
affect requests configuration, including XDG variables.
515
+
516
+
{b Included Variables:}
517
+
- [${APP_NAME}_CONFIG_DIR]: Configuration directory
518
+
- [${APP_NAME}_DATA_DIR]: Data directory
519
+
- [${APP_NAME}_CACHE_DIR]: Cache directory
520
+
- [${APP_NAME}_STATE_DIR]: State directory
521
+
- [XDG_CONFIG_HOME], [XDG_DATA_HOME], [XDG_CACHE_HOME], [XDG_STATE_HOME]
522
+
- [HTTP_PROXY], [HTTPS_PROXY], [NO_PROXY] (when proxy support is added)
523
+
524
+
{b Example:}
525
+
{[
526
+
let env_info = Cmdliner.Cmd.Env.info
527
+
~docs:Cmdliner.Manpage.s_environment
528
+
~doc:(Requests.Cmd.env_docs "myapp")
529
+
()
530
+
]} *)
531
+
532
+
val pp_config : Format.formatter -> config -> unit
533
+
(** Pretty print configuration for debugging *)
534
+
535
+
(** {2 Logging Configuration} *)
536
+
537
+
val setup_log_sources : ?verbose_http:bool -> Logs.level option -> unit
538
+
(** [setup_log_sources ~verbose_http level] configures Requests library log sources.
539
+
540
+
This helper function configures all Requests logging sources based on
541
+
the specified log level and verbose_http flag. It's designed to work
542
+
with Logs_cli and provides fine-grained control over HTTP-level logging.
543
+
544
+
{b Log Level Behavior:}
545
+
- [Some Debug]: Enables debug logging for all application-level modules
546
+
(Auth, Body, Response, Retry, Headers, Error, Method, Mime, Status, Timeout).
547
+
If [verbose_http] is true, also enables debug logging for protocol-level
548
+
modules (One, Http_client, Conpool, and TLS tracing). If [verbose_http]
549
+
is false, TLS tracing is set to Warning level to suppress hexdumps.
550
+
- [Some Info]: Enables info logging for main modules (src, Response, One).
551
+
TLS tracing is set to Warning level.
552
+
- [None] or other levels: TLS tracing is set to Warning level to suppress
553
+
verbose protocol output.
554
+
555
+
{b Example with Logs_cli:}
556
+
{[
557
+
let setup_logging =
558
+
let open Cmdliner.Term in
559
+
const (fun style level verbose_http ->
560
+
Fmt_tty.setup_std_outputs ?style_renderer:style ();
561
+
Logs.set_level level;
562
+
Logs.set_reporter (Logs_fmt.reporter ());
563
+
Requests.Cmd.setup_log_sources ~verbose_http level)
564
+
$ Fmt_cli.style_renderer ()
565
+
$ Logs_cli.level ()
566
+
$ Requests.Cmd.verbose_http_term "myapp"
567
+
]} *)
568
+
end
569
+
570
+
(** Retry policies and backoff strategies *)
571
+
module Retry = Retry
572
+
573
+
(** {1 One-Shot API}
574
+
575
+
The One module provides direct control over HTTP requests without
576
+
session state. Use this for stateless operations or when you need
577
+
fine-grained control.
578
+
*)
579
+
580
+
(** One-shot HTTP client for stateless requests *)
581
+
module One = One
582
+
583
+
(** Low-level HTTP client over pooled connections *)
584
+
module Http_client = Http_client
585
+
586
+
(** {1 Core Types}
587
+
588
+
These modules define the fundamental types used throughout the library.
589
+
*)
590
+
591
+
(** HTTP response handling *)
592
+
module Response = Response
593
+
594
+
(** Request body construction and encoding *)
595
+
module Body = Body
596
+
597
+
(** HTTP headers manipulation *)
598
+
module Headers = Headers
599
+
600
+
(** Authentication schemes (Basic, Bearer, OAuth, etc.) *)
601
+
module Auth = Auth
602
+
603
+
(** Error types and exception handling *)
604
+
module Error = Error
605
+
606
+
(** {1 Supporting Types} *)
607
+
608
+
(** HTTP status codes and reason phrases *)
609
+
module Status = Status
610
+
611
+
(** HTTP request methods (GET, POST, etc.) *)
612
+
module Method = Method
613
+
614
+
(** MIME types for content negotiation *)
615
+
module Mime = Mime
616
+
617
+
(** Timeout configuration for requests *)
618
+
module Timeout = Timeout
619
+
620
+
(** {2 Logging} *)
621
+
622
+
(** Log source for the requests library.
623
+
Use [Logs.Src.set_level src] to control logging verbosity.
624
+
Example: [Logs.Src.set_level Requests.src (Some Logs.Debug)] *)
625
+
val src : Logs.Src.t
+85
lib/response.ml
+85
lib/response.ml
···
1
+
let src = Logs.Src.create "requests.response" ~doc:"HTTP Response"
2
+
module Log = (val Logs.src_log src : Logs.LOG)
3
+
4
+
type t = {
5
+
status : int;
6
+
headers : Headers.t;
7
+
body : Eio.Flow.source_ty Eio.Resource.t;
8
+
url : string;
9
+
elapsed : float;
10
+
mutable closed : bool;
11
+
}
12
+
13
+
let make ~sw ~status ~headers ~body ~url ~elapsed =
14
+
Log.debug (fun m -> m "Creating response: status=%d url=%s elapsed=%.3fs" status url elapsed);
15
+
let response = { status; headers; body; url; elapsed; closed = false } in
16
+
17
+
(* Register cleanup with switch *)
18
+
Eio.Switch.on_release sw (fun () ->
19
+
if not response.closed then begin
20
+
Log.debug (fun m -> m "Auto-closing response for %s via switch" url);
21
+
response.closed <- true;
22
+
(* TODO Body cleanup is handled by the underlying HTTP library but test this *)
23
+
end
24
+
);
25
+
26
+
response
27
+
28
+
let status t = Status.of_int t.status
29
+
30
+
let status_code t = t.status
31
+
32
+
let ok t = Status.is_success (Status.of_int t.status)
33
+
34
+
let headers t = t.headers
35
+
36
+
let header name t = Headers.get name t.headers
37
+
38
+
let content_type t =
39
+
match Headers.get "content-type" t.headers with
40
+
| None -> None
41
+
| Some ct -> Some (Mime.of_string ct)
42
+
43
+
let content_length t =
44
+
match Headers.get "content-length" t.headers with
45
+
| None -> None
46
+
| Some len ->
47
+
try Some (Int64.of_string len)
48
+
with _ -> None
49
+
50
+
let location t = Headers.get "location" t.headers
51
+
52
+
let url t = t.url
53
+
54
+
let elapsed t = t.elapsed
55
+
56
+
let body t =
57
+
if t.closed then
58
+
failwith "Response has been closed"
59
+
else
60
+
t.body
61
+
62
+
63
+
(* Pretty printers *)
64
+
let pp ppf t =
65
+
Format.fprintf ppf "@[<v>Response:@,\
66
+
status: %a@,\
67
+
url: %s@,\
68
+
elapsed: %.3fs@,\
69
+
headers: @[%a@]@]"
70
+
Status.pp (Status.of_int t.status) t.url t.elapsed
71
+
Headers.pp_brief t.headers
72
+
73
+
let pp_detailed ppf t =
74
+
Format.fprintf ppf "@[<v>Response:@,\
75
+
status: %a@,\
76
+
url: %s@,\
77
+
elapsed: %.3fs@,\
78
+
@[%a@]@]"
79
+
Status.pp_hum (Status.of_int t.status) t.url t.elapsed
80
+
Headers.pp t.headers
81
+
82
+
(* Private module *)
83
+
module Private = struct
84
+
let make = make
85
+
end
+129
lib/response.mli
+129
lib/response.mli
···
1
+
(** HTTP response handling
2
+
3
+
This module represents HTTP responses and provides functions to access
4
+
status codes, headers, and response bodies. Responses support streaming
5
+
to efficiently handle large payloads.
6
+
7
+
{2 Examples}
8
+
9
+
{[
10
+
(* Check response status *)
11
+
if Response.ok response then
12
+
Printf.printf "Success!\n"
13
+
else
14
+
Printf.printf "Error: %d\n" (Response.status_code response);
15
+
16
+
(* Access headers *)
17
+
match Response.content_type response with
18
+
| Some mime -> Printf.printf "Type: %s\n" (Mime.to_string mime)
19
+
| None -> ()
20
+
21
+
(* Stream response body *)
22
+
let body = Response.body response in
23
+
Eio.Flow.copy body (Eio.Flow.buffer_sink buffer)
24
+
25
+
(* Response automatically closes when the switch is released *)
26
+
]}
27
+
28
+
{b Note}: Responses are automatically closed when the switch they were
29
+
created with is released. Manual cleanup is not necessary.
30
+
*)
31
+
32
+
open Eio
33
+
34
+
(** Log source for response operations *)
35
+
val src : Logs.Src.t
36
+
37
+
type t
38
+
(** Abstract response type representing an HTTP response. *)
39
+
40
+
val make : sw:Eio.Switch.t -> status:int -> headers:Headers.t ->
41
+
body:Eio.Flow.source_ty Eio.Resource.t -> url:string -> elapsed:float -> t
42
+
(** [make ~sw ~status ~headers ~body ~url ~elapsed] creates a response.
43
+
Internal function primarily used for caching. *)
44
+
45
+
(** {1 Status Information} *)
46
+
47
+
val status : t -> Status.t
48
+
(** [status response] returns the HTTP status as a {!Status.t} value. *)
49
+
50
+
val status_code : t -> int
51
+
(** [status_code response] returns the HTTP status code as an integer (e.g., 200, 404). *)
52
+
53
+
val ok : t -> bool
54
+
(** [ok response] returns [true] if the status code is in the 2xx success range.
55
+
This is an alias for {!Status.is_success}. *)
56
+
57
+
(** {1 Header Access} *)
58
+
59
+
val headers : t -> Headers.t
60
+
(** [headers response] returns all response headers. *)
61
+
62
+
val header : string -> t -> string option
63
+
(** [header name response] returns the value of a specific header, or [None] if not present.
64
+
Header names are case-insensitive. *)
65
+
66
+
val content_type : t -> Mime.t option
67
+
(** [content_type response] returns the parsed Content-Type header as a MIME type,
68
+
or [None] if the header is not present or cannot be parsed. *)
69
+
70
+
val content_length : t -> int64 option
71
+
(** [content_length response] returns the Content-Length in bytes,
72
+
or [None] if not specified or chunked encoding is used. *)
73
+
74
+
val location : t -> string option
75
+
(** [location response] returns the Location header value, typically used in redirects.
76
+
Returns [None] if the header is not present. *)
77
+
78
+
(** {1 Response Metadata} *)
79
+
80
+
val url : t -> string
81
+
(** [url response] returns the final URL after following any redirects.
82
+
This may differ from the originally requested URL. *)
83
+
84
+
val elapsed : t -> float
85
+
(** [elapsed response] returns the time taken for the request in seconds,
86
+
including connection establishment, sending the request, and receiving headers. *)
87
+
88
+
(** {1 Response Body} *)
89
+
90
+
val body : t -> Flow.source_ty Resource.t
91
+
(** [body response] returns the response body as an Eio flow for streaming.
92
+
This allows efficient processing of large responses without loading them
93
+
entirely into memory.
94
+
95
+
Example:
96
+
{[
97
+
let body = Response.body response in
98
+
let buffer = Buffer.create 4096 in
99
+
Eio.Flow.copy body (Eio.Flow.buffer_sink buffer);
100
+
Buffer.contents buffer
101
+
]}
102
+
*)
103
+
104
+
105
+
(** {1 Pretty Printing} *)
106
+
107
+
val pp : Format.formatter -> t -> unit
108
+
(** Pretty print a response summary *)
109
+
110
+
val pp_detailed : Format.formatter -> t -> unit
111
+
(** Pretty print a response with full headers *)
112
+
113
+
(** {1 Private API} *)
114
+
115
+
(** Internal functions exposed for use by other modules in the library.
116
+
These are not part of the public API and may change between versions. *)
117
+
module Private : sig
118
+
val make :
119
+
sw:Eio.Switch.t ->
120
+
status:int ->
121
+
headers:Headers.t ->
122
+
body:Flow.source_ty Resource.t ->
123
+
url:string ->
124
+
elapsed:float ->
125
+
t
126
+
(** [make ~sw ~status ~headers ~body ~url ~elapsed] constructs a response.
127
+
The response will be automatically closed when the switch is released.
128
+
This function is used internally by the Client module. *)
129
+
end
+142
lib/retry.ml
+142
lib/retry.ml
···
1
+
let src = Logs.Src.create "requests.retry" ~doc:"HTTP Request Retry Logic"
2
+
module Log = (val Logs.src_log src : Logs.LOG)
3
+
4
+
type config = {
5
+
max_retries : int;
6
+
backoff_factor : float;
7
+
backoff_max : float;
8
+
status_forcelist : int list;
9
+
allowed_methods : Method.t list;
10
+
respect_retry_after : bool;
11
+
jitter : bool;
12
+
}
13
+
14
+
let default_config = {
15
+
max_retries = 3;
16
+
backoff_factor = 0.3;
17
+
backoff_max = 120.0;
18
+
status_forcelist = [408; 429; 500; 502; 503; 504];
19
+
allowed_methods = [`GET; `HEAD; `PUT; `DELETE; `OPTIONS; `TRACE];
20
+
respect_retry_after = true;
21
+
jitter = true;
22
+
}
23
+
24
+
let create_config
25
+
?(max_retries = 3)
26
+
?(backoff_factor = 0.3)
27
+
?(backoff_max = 120.0)
28
+
?(status_forcelist = [408; 429; 500; 502; 503; 504])
29
+
?(allowed_methods = [`GET; `HEAD; `PUT; `DELETE; `OPTIONS; `TRACE])
30
+
?(respect_retry_after = true)
31
+
?(jitter = true)
32
+
() =
33
+
Log.debug (fun m -> m "Creating retry config: max_retries=%d backoff_factor=%.2f"
34
+
max_retries backoff_factor);
35
+
{
36
+
max_retries;
37
+
backoff_factor;
38
+
backoff_max;
39
+
status_forcelist;
40
+
allowed_methods;
41
+
respect_retry_after;
42
+
jitter;
43
+
}
44
+
45
+
let should_retry ~config ~method_ ~status =
46
+
let should =
47
+
List.mem method_ config.allowed_methods &&
48
+
List.mem status config.status_forcelist
49
+
in
50
+
Log.debug (fun m -> m "Should retry? method=%s status=%d -> %b"
51
+
(Method.to_string method_) status should);
52
+
should
53
+
54
+
let calculate_backoff ~config ~attempt =
55
+
let base_delay = config.backoff_factor *. (2.0 ** float_of_int attempt) in
56
+
let delay =
57
+
if config.jitter then
58
+
(* Add random jitter between 0 and base_delay *)
59
+
base_delay +. Random.float base_delay
60
+
else
61
+
base_delay
62
+
in
63
+
let final_delay = min delay config.backoff_max in
64
+
Log.debug (fun m -> m "Backoff calculation: attempt=%d base=%.2f jitter=%b -> %.2f seconds"
65
+
attempt base_delay config.jitter final_delay);
66
+
final_delay
67
+
68
+
let parse_retry_after value =
69
+
Log.debug (fun m -> m "Parsing Retry-After header: %s" value);
70
+
71
+
(* First try to parse as integer (delay in seconds) *)
72
+
match int_of_string_opt value with
73
+
| Some seconds ->
74
+
Log.debug (fun m -> m "Retry-After is %d seconds" seconds);
75
+
Some (float_of_int seconds)
76
+
| None ->
77
+
(* Try to parse as HTTP date *)
78
+
(* This is simplified - real implementation would use a proper HTTP date parser *)
79
+
try
80
+
let time, _tz_offset, _tz_string = Ptime.of_rfc3339 value |> Result.get_ok in
81
+
let now = Unix.time () in
82
+
let target = Ptime.to_float_s time in
83
+
let delay = max 0.0 (target -. now) in
84
+
Log.debug (fun m -> m "Retry-After is HTTP date, delay=%.2f seconds" delay);
85
+
Some delay
86
+
with _ ->
87
+
Log.warn (fun m -> m "Failed to parse Retry-After header: %s" value);
88
+
None
89
+
90
+
let with_retry ~sw:_ ~clock ~config ~f ~should_retry_exn =
91
+
let rec attempt_with_retry attempt =
92
+
Log.info (fun m -> m "Attempt %d/%d" attempt (config.max_retries + 1));
93
+
94
+
match f () with
95
+
| result ->
96
+
if attempt > 1 then
97
+
Log.info (fun m -> m "Request succeeded after %d attempts" attempt);
98
+
result
99
+
| exception exn when attempt <= config.max_retries && should_retry_exn exn ->
100
+
let delay = calculate_backoff ~config ~attempt in
101
+
102
+
Log.warn (fun m -> m "Request failed (attempt %d/%d): %s. Retrying in %.2f seconds..."
103
+
attempt (config.max_retries + 1) (Printexc.to_string exn) delay);
104
+
105
+
(* Sleep for the backoff duration *)
106
+
Eio.Time.sleep clock delay;
107
+
108
+
attempt_with_retry (attempt + 1)
109
+
| exception exn ->
110
+
if attempt > config.max_retries then
111
+
Log.err (fun m -> m "Request failed after %d attempts: %s"
112
+
attempt (Printexc.to_string exn))
113
+
else
114
+
Log.err (fun m -> m "Request failed and won't be retried: %s"
115
+
(Printexc.to_string exn));
116
+
raise exn
117
+
in
118
+
attempt_with_retry 1
119
+
120
+
let pp_config ppf config =
121
+
Format.fprintf ppf "@[<v>Retry Configuration:@,\
122
+
@[<v 2>\
123
+
max_retries: %d@,\
124
+
backoff_factor: %.2f@,\
125
+
backoff_max: %.1f seconds@,\
126
+
status_forcelist: [%a]@,\
127
+
allowed_methods: [%a]@,\
128
+
respect_retry_after: %b@,\
129
+
jitter: %b\
130
+
@]@]"
131
+
config.max_retries
132
+
config.backoff_factor
133
+
config.backoff_max
134
+
Format.(pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ", ") pp_print_int) config.status_forcelist
135
+
Format.(pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ", ")
136
+
(fun ppf m -> pp_print_string ppf (Method.to_string m))) config.allowed_methods
137
+
config.respect_retry_after
138
+
config.jitter
139
+
140
+
let log_retry ~attempt ~delay ~reason =
141
+
Log.info (fun m -> m "Retry attempt %d scheduled in %.2f seconds. Reason: %s"
142
+
attempt delay reason)
+55
lib/retry.mli
+55
lib/retry.mli
···
1
+
(** HTTP request retry logic with exponential backoff *)
2
+
3
+
open Eio
4
+
5
+
(** Log source for retry operations *)
6
+
val src : Logs.Src.t
7
+
8
+
(** Retry configuration *)
9
+
type config = {
10
+
max_retries : int; (** Maximum number of retry attempts *)
11
+
backoff_factor : float; (** Exponential backoff multiplier *)
12
+
backoff_max : float; (** Maximum backoff time in seconds *)
13
+
status_forcelist : int list; (** HTTP status codes to retry *)
14
+
allowed_methods : Method.t list; (** Methods safe to retry *)
15
+
respect_retry_after : bool; (** Honor Retry-After response header *)
16
+
jitter : bool; (** Add randomness to prevent thundering herd *)
17
+
}
18
+
19
+
(** Default retry configuration *)
20
+
val default_config : config
21
+
22
+
(** Create a custom retry configuration *)
23
+
val create_config :
24
+
?max_retries:int ->
25
+
?backoff_factor:float ->
26
+
?backoff_max:float ->
27
+
?status_forcelist:int list ->
28
+
?allowed_methods:Method.t list ->
29
+
?respect_retry_after:bool ->
30
+
?jitter:bool ->
31
+
unit -> config
32
+
33
+
(** Check if a request should be retried *)
34
+
val should_retry : config:config -> method_:Method.t -> status:int -> bool
35
+
36
+
(** Calculate backoff delay for a given attempt *)
37
+
val calculate_backoff : config:config -> attempt:int -> float
38
+
39
+
(** Parse Retry-After header value (seconds or HTTP date) *)
40
+
val parse_retry_after : string -> float option
41
+
42
+
(** Execute a request with retry logic *)
43
+
val with_retry :
44
+
sw:Switch.t ->
45
+
clock:_ Time.clock ->
46
+
config:config ->
47
+
f:(unit -> 'a) ->
48
+
should_retry_exn:(exn -> bool) ->
49
+
'a
50
+
51
+
(** Pretty print retry configuration *)
52
+
val pp_config : Format.formatter -> config -> unit
53
+
54
+
(** Log retry attempt information *)
55
+
val log_retry : attempt:int -> delay:float -> reason:string -> unit
+365
lib/status.ml
+365
lib/status.ml
···
1
+
(** HTTP status codes following RFC 7231 and extensions *)
2
+
3
+
let src = Logs.Src.create "requests.status" ~doc:"HTTP Status Codes"
4
+
module Log = (val Logs.src_log src : Logs.LOG)
5
+
6
+
type informational = [
7
+
| `Continue
8
+
| `Switching_protocols
9
+
| `Processing
10
+
| `Early_hints
11
+
]
12
+
13
+
type success = [
14
+
| `OK
15
+
| `Created
16
+
| `Accepted
17
+
| `Non_authoritative_information
18
+
| `No_content
19
+
| `Reset_content
20
+
| `Partial_content
21
+
| `Multi_status
22
+
| `Already_reported
23
+
| `Im_used
24
+
]
25
+
26
+
type redirection = [
27
+
| `Multiple_choices
28
+
| `Moved_permanently
29
+
| `Found
30
+
| `See_other
31
+
| `Not_modified
32
+
| `Use_proxy
33
+
| `Temporary_redirect
34
+
| `Permanent_redirect
35
+
]
36
+
37
+
type client_error = [
38
+
| `Bad_request
39
+
| `Unauthorized
40
+
| `Payment_required
41
+
| `Forbidden
42
+
| `Not_found
43
+
| `Method_not_allowed
44
+
| `Not_acceptable
45
+
| `Proxy_authentication_required
46
+
| `Request_timeout
47
+
| `Conflict
48
+
| `Gone
49
+
| `Length_required
50
+
| `Precondition_failed
51
+
| `Payload_too_large
52
+
| `Uri_too_long
53
+
| `Unsupported_media_type
54
+
| `Range_not_satisfiable
55
+
| `Expectation_failed
56
+
| `I_m_a_teapot
57
+
| `Misdirected_request
58
+
| `Unprocessable_entity
59
+
| `Locked
60
+
| `Failed_dependency
61
+
| `Too_early
62
+
| `Upgrade_required
63
+
| `Precondition_required
64
+
| `Too_many_requests
65
+
| `Request_header_fields_too_large
66
+
| `Unavailable_for_legal_reasons
67
+
]
68
+
69
+
type server_error = [
70
+
| `Internal_server_error
71
+
| `Not_implemented
72
+
| `Bad_gateway
73
+
| `Service_unavailable
74
+
| `Gateway_timeout
75
+
| `Http_version_not_supported
76
+
| `Variant_also_negotiates
77
+
| `Insufficient_storage
78
+
| `Loop_detected
79
+
| `Not_extended
80
+
| `Network_authentication_required
81
+
]
82
+
83
+
type standard = [
84
+
| informational
85
+
| success
86
+
| redirection
87
+
| client_error
88
+
| server_error
89
+
]
90
+
91
+
type t = [
92
+
| `Code of int
93
+
| standard
94
+
]
95
+
96
+
let to_int = function
97
+
(* Informational *)
98
+
| `Continue -> 100
99
+
| `Switching_protocols -> 101
100
+
| `Processing -> 102
101
+
| `Early_hints -> 103
102
+
(* Success *)
103
+
| `OK -> 200
104
+
| `Created -> 201
105
+
| `Accepted -> 202
106
+
| `Non_authoritative_information -> 203
107
+
| `No_content -> 204
108
+
| `Reset_content -> 205
109
+
| `Partial_content -> 206
110
+
| `Multi_status -> 207
111
+
| `Already_reported -> 208
112
+
| `Im_used -> 226
113
+
(* Redirection *)
114
+
| `Multiple_choices -> 300
115
+
| `Moved_permanently -> 301
116
+
| `Found -> 302
117
+
| `See_other -> 303
118
+
| `Not_modified -> 304
119
+
| `Use_proxy -> 305
120
+
| `Temporary_redirect -> 307
121
+
| `Permanent_redirect -> 308
122
+
(* Client Error *)
123
+
| `Bad_request -> 400
124
+
| `Unauthorized -> 401
125
+
| `Payment_required -> 402
126
+
| `Forbidden -> 403
127
+
| `Not_found -> 404
128
+
| `Method_not_allowed -> 405
129
+
| `Not_acceptable -> 406
130
+
| `Proxy_authentication_required -> 407
131
+
| `Request_timeout -> 408
132
+
| `Conflict -> 409
133
+
| `Gone -> 410
134
+
| `Length_required -> 411
135
+
| `Precondition_failed -> 412
136
+
| `Payload_too_large -> 413
137
+
| `Uri_too_long -> 414
138
+
| `Unsupported_media_type -> 415
139
+
| `Range_not_satisfiable -> 416
140
+
| `Expectation_failed -> 417
141
+
| `I_m_a_teapot -> 418
142
+
| `Misdirected_request -> 421
143
+
| `Unprocessable_entity -> 422
144
+
| `Locked -> 423
145
+
| `Failed_dependency -> 424
146
+
| `Too_early -> 425
147
+
| `Upgrade_required -> 426
148
+
| `Precondition_required -> 428
149
+
| `Too_many_requests -> 429
150
+
| `Request_header_fields_too_large -> 431
151
+
| `Unavailable_for_legal_reasons -> 451
152
+
(* Server Error *)
153
+
| `Internal_server_error -> 500
154
+
| `Not_implemented -> 501
155
+
| `Bad_gateway -> 502
156
+
| `Service_unavailable -> 503
157
+
| `Gateway_timeout -> 504
158
+
| `Http_version_not_supported -> 505
159
+
| `Variant_also_negotiates -> 506
160
+
| `Insufficient_storage -> 507
161
+
| `Loop_detected -> 508
162
+
| `Not_extended -> 510
163
+
| `Network_authentication_required -> 511
164
+
(* Custom code *)
165
+
| `Code c -> c
166
+
167
+
let of_int = function
168
+
(* Informational *)
169
+
| 100 -> `Continue
170
+
| 101 -> `Switching_protocols
171
+
| 102 -> `Processing
172
+
| 103 -> `Early_hints
173
+
(* Success *)
174
+
| 200 -> `OK
175
+
| 201 -> `Created
176
+
| 202 -> `Accepted
177
+
| 203 -> `Non_authoritative_information
178
+
| 204 -> `No_content
179
+
| 205 -> `Reset_content
180
+
| 206 -> `Partial_content
181
+
| 207 -> `Multi_status
182
+
| 208 -> `Already_reported
183
+
| 226 -> `Im_used
184
+
(* Redirection *)
185
+
| 300 -> `Multiple_choices
186
+
| 301 -> `Moved_permanently
187
+
| 302 -> `Found
188
+
| 303 -> `See_other
189
+
| 304 -> `Not_modified
190
+
| 305 -> `Use_proxy
191
+
| 307 -> `Temporary_redirect
192
+
| 308 -> `Permanent_redirect
193
+
(* Client Error *)
194
+
| 400 -> `Bad_request
195
+
| 401 -> `Unauthorized
196
+
| 402 -> `Payment_required
197
+
| 403 -> `Forbidden
198
+
| 404 -> `Not_found
199
+
| 405 -> `Method_not_allowed
200
+
| 406 -> `Not_acceptable
201
+
| 407 -> `Proxy_authentication_required
202
+
| 408 -> `Request_timeout
203
+
| 409 -> `Conflict
204
+
| 410 -> `Gone
205
+
| 411 -> `Length_required
206
+
| 412 -> `Precondition_failed
207
+
| 413 -> `Payload_too_large
208
+
| 414 -> `Uri_too_long
209
+
| 415 -> `Unsupported_media_type
210
+
| 416 -> `Range_not_satisfiable
211
+
| 417 -> `Expectation_failed
212
+
| 418 -> `I_m_a_teapot
213
+
| 421 -> `Misdirected_request
214
+
| 422 -> `Unprocessable_entity
215
+
| 423 -> `Locked
216
+
| 424 -> `Failed_dependency
217
+
| 425 -> `Too_early
218
+
| 426 -> `Upgrade_required
219
+
| 428 -> `Precondition_required
220
+
| 429 -> `Too_many_requests
221
+
| 431 -> `Request_header_fields_too_large
222
+
| 451 -> `Unavailable_for_legal_reasons
223
+
(* Server Error *)
224
+
| 500 -> `Internal_server_error
225
+
| 501 -> `Not_implemented
226
+
| 502 -> `Bad_gateway
227
+
| 503 -> `Service_unavailable
228
+
| 504 -> `Gateway_timeout
229
+
| 505 -> `Http_version_not_supported
230
+
| 506 -> `Variant_also_negotiates
231
+
| 507 -> `Insufficient_storage
232
+
| 508 -> `Loop_detected
233
+
| 510 -> `Not_extended
234
+
| 511 -> `Network_authentication_required
235
+
(* Unknown code *)
236
+
| c -> `Code c
237
+
238
+
let to_string t = string_of_int (to_int t)
239
+
240
+
let reason_phrase t =
241
+
match t with
242
+
(* Informational *)
243
+
| `Continue -> "Continue"
244
+
| `Switching_protocols -> "Switching Protocols"
245
+
| `Processing -> "Processing"
246
+
| `Early_hints -> "Early Hints"
247
+
(* Success *)
248
+
| `OK -> "OK"
249
+
| `Created -> "Created"
250
+
| `Accepted -> "Accepted"
251
+
| `Non_authoritative_information -> "Non-Authoritative Information"
252
+
| `No_content -> "No Content"
253
+
| `Reset_content -> "Reset Content"
254
+
| `Partial_content -> "Partial Content"
255
+
| `Multi_status -> "Multi-Status"
256
+
| `Already_reported -> "Already Reported"
257
+
| `Im_used -> "IM Used"
258
+
(* Redirection *)
259
+
| `Multiple_choices -> "Multiple Choices"
260
+
| `Moved_permanently -> "Moved Permanently"
261
+
| `Found -> "Found"
262
+
| `See_other -> "See Other"
263
+
| `Not_modified -> "Not Modified"
264
+
| `Use_proxy -> "Use Proxy"
265
+
| `Temporary_redirect -> "Temporary Redirect"
266
+
| `Permanent_redirect -> "Permanent Redirect"
267
+
(* Client Error *)
268
+
| `Bad_request -> "Bad Request"
269
+
| `Unauthorized -> "Unauthorized"
270
+
| `Payment_required -> "Payment Required"
271
+
| `Forbidden -> "Forbidden"
272
+
| `Not_found -> "Not Found"
273
+
| `Method_not_allowed -> "Method Not Allowed"
274
+
| `Not_acceptable -> "Not Acceptable"
275
+
| `Proxy_authentication_required -> "Proxy Authentication Required"
276
+
| `Request_timeout -> "Request Timeout"
277
+
| `Conflict -> "Conflict"
278
+
| `Gone -> "Gone"
279
+
| `Length_required -> "Length Required"
280
+
| `Precondition_failed -> "Precondition Failed"
281
+
| `Payload_too_large -> "Payload Too Large"
282
+
| `Uri_too_long -> "URI Too Long"
283
+
| `Unsupported_media_type -> "Unsupported Media Type"
284
+
| `Range_not_satisfiable -> "Range Not Satisfiable"
285
+
| `Expectation_failed -> "Expectation Failed"
286
+
| `I_m_a_teapot -> "I'm a teapot"
287
+
| `Misdirected_request -> "Misdirected Request"
288
+
| `Unprocessable_entity -> "Unprocessable Entity"
289
+
| `Locked -> "Locked"
290
+
| `Failed_dependency -> "Failed Dependency"
291
+
| `Too_early -> "Too Early"
292
+
| `Upgrade_required -> "Upgrade Required"
293
+
| `Precondition_required -> "Precondition Required"
294
+
| `Too_many_requests -> "Too Many Requests"
295
+
| `Request_header_fields_too_large -> "Request Header Fields Too Large"
296
+
| `Unavailable_for_legal_reasons -> "Unavailable For Legal Reasons"
297
+
(* Server Error *)
298
+
| `Internal_server_error -> "Internal Server Error"
299
+
| `Not_implemented -> "Not Implemented"
300
+
| `Bad_gateway -> "Bad Gateway"
301
+
| `Service_unavailable -> "Service Unavailable"
302
+
| `Gateway_timeout -> "Gateway Timeout"
303
+
| `Http_version_not_supported -> "HTTP Version Not Supported"
304
+
| `Variant_also_negotiates -> "Variant Also Negotiates"
305
+
| `Insufficient_storage -> "Insufficient Storage"
306
+
| `Loop_detected -> "Loop Detected"
307
+
| `Not_extended -> "Not Extended"
308
+
| `Network_authentication_required -> "Network Authentication Required"
309
+
(* Custom code - provide generic reason based on category *)
310
+
| `Code c ->
311
+
if c >= 100 && c < 200 then "Informational"
312
+
else if c >= 200 && c < 300 then "Success"
313
+
else if c >= 300 && c < 400 then "Redirection"
314
+
else if c >= 400 && c < 500 then "Client Error"
315
+
else if c >= 500 && c < 600 then "Server Error"
316
+
else "Unknown"
317
+
318
+
(* Classification functions *)
319
+
let is_informational t =
320
+
let code = to_int t in
321
+
code >= 100 && code < 200
322
+
323
+
let is_success t =
324
+
let code = to_int t in
325
+
code >= 200 && code < 300
326
+
327
+
let is_redirection t =
328
+
let code = to_int t in
329
+
code >= 300 && code < 400
330
+
331
+
let is_client_error t =
332
+
let code = to_int t in
333
+
code >= 400 && code < 500
334
+
335
+
let is_server_error t =
336
+
let code = to_int t in
337
+
code >= 500 && code < 600
338
+
339
+
let is_error t =
340
+
let code = to_int t in
341
+
code >= 400 && code < 600
342
+
343
+
(* Retry policy functions *)
344
+
let is_retryable t =
345
+
match t with
346
+
| `Request_timeout
347
+
| `Too_many_requests
348
+
| `Bad_gateway
349
+
| `Service_unavailable
350
+
| `Gateway_timeout -> true
351
+
| _ -> is_server_error t (* All 5xx errors are generally retryable *)
352
+
353
+
let should_retry_on_different_host t =
354
+
match t with
355
+
| `Bad_gateway
356
+
| `Service_unavailable
357
+
| `Gateway_timeout -> true
358
+
| _ -> false
359
+
360
+
(* Pretty printing *)
361
+
let pp ppf t =
362
+
Format.fprintf ppf "%d" (to_int t)
363
+
364
+
let pp_hum ppf t =
365
+
Format.fprintf ppf "%d %s" (to_int t) (reason_phrase t)
+164
lib/status.mli
+164
lib/status.mli
···
1
+
(** HTTP status codes following RFC 7231 and extensions *)
2
+
3
+
(** Log source for status code operations *)
4
+
val src : Logs.Src.t
5
+
6
+
(** {1 Status Categories} *)
7
+
8
+
type informational = [
9
+
| `Continue (** 100 - Client should continue with request *)
10
+
| `Switching_protocols (** 101 - Server is switching protocols *)
11
+
| `Processing (** 102 - Server has received and is processing the request *)
12
+
| `Early_hints (** 103 - Used to return some response headers before final HTTP message *)
13
+
]
14
+
(** 1xx Informational responses *)
15
+
16
+
type success = [
17
+
| `OK (** 200 - Standard response for successful HTTP requests *)
18
+
| `Created (** 201 - Request has been fulfilled; new resource created *)
19
+
| `Accepted (** 202 - Request accepted, processing pending *)
20
+
| `Non_authoritative_information (** 203 - Request processed, information may be from another source *)
21
+
| `No_content (** 204 - Request processed, no content returned *)
22
+
| `Reset_content (** 205 - Request processed, no content returned, reset document view *)
23
+
| `Partial_content (** 206 - Partial resource return due to request header *)
24
+
| `Multi_status (** 207 - XML, can contain multiple separate responses *)
25
+
| `Already_reported (** 208 - Results previously returned *)
26
+
| `Im_used (** 226 - Request fulfilled, response is instance-manipulations *)
27
+
]
28
+
(** 2xx Success responses *)
29
+
30
+
type redirection = [
31
+
| `Multiple_choices (** 300 - Multiple options for the resource delivered *)
32
+
| `Moved_permanently (** 301 - This and all future requests directed to the given URI *)
33
+
| `Found (** 302 - Temporary response to request found via alternative URI *)
34
+
| `See_other (** 303 - Response to request found via alternative URI *)
35
+
| `Not_modified (** 304 - Resource has not been modified since last requested *)
36
+
| `Use_proxy (** 305 - Content located elsewhere, retrieve from there (deprecated) *)
37
+
| `Temporary_redirect (** 307 - Connect again to different URI as provided *)
38
+
| `Permanent_redirect (** 308 - Connect again to a different URI using the same method *)
39
+
]
40
+
(** 3xx Redirection messages *)
41
+
42
+
type client_error = [
43
+
| `Bad_request (** 400 - Request cannot be fulfilled due to bad syntax *)
44
+
| `Unauthorized (** 401 - Authentication is possible but has failed *)
45
+
| `Payment_required (** 402 - Payment required, reserved for future use *)
46
+
| `Forbidden (** 403 - Server refuses to respond to request *)
47
+
| `Not_found (** 404 - Requested resource could not be found *)
48
+
| `Method_not_allowed (** 405 - Request method not supported by that resource *)
49
+
| `Not_acceptable (** 406 - Content not acceptable according to the Accept headers *)
50
+
| `Proxy_authentication_required (** 407 - Client must first authenticate itself with the proxy *)
51
+
| `Request_timeout (** 408 - Server timed out waiting for the request *)
52
+
| `Conflict (** 409 - Request could not be processed because of conflict *)
53
+
| `Gone (** 410 - Resource is no longer available and will not be available again *)
54
+
| `Length_required (** 411 - Request did not specify the length of its content *)
55
+
| `Precondition_failed (** 412 - Server does not meet request preconditions *)
56
+
| `Payload_too_large (** 413 - Request is larger than the server is willing or able to process *)
57
+
| `Uri_too_long (** 414 - URI provided was too long for the server to process *)
58
+
| `Unsupported_media_type (** 415 - Server does not support media type *)
59
+
| `Range_not_satisfiable (** 416 - Client has asked for unprovidable portion of the file *)
60
+
| `Expectation_failed (** 417 - Server cannot meet requirements of Expect request-header field *)
61
+
| `I_m_a_teapot (** 418 - I'm a teapot (RFC 2324) *)
62
+
| `Misdirected_request (** 421 - Request was directed at a server that is not able to produce a response *)
63
+
| `Unprocessable_entity (** 422 - Request unable to be followed due to semantic errors *)
64
+
| `Locked (** 423 - Resource that is being accessed is locked *)
65
+
| `Failed_dependency (** 424 - Request failed due to failure of a previous request *)
66
+
| `Too_early (** 425 - Server is unwilling to risk processing a request that might be replayed *)
67
+
| `Upgrade_required (** 426 - Client should switch to a different protocol *)
68
+
| `Precondition_required (** 428 - Origin server requires the request to be conditional *)
69
+
| `Too_many_requests (** 429 - User has sent too many requests in a given amount of time *)
70
+
| `Request_header_fields_too_large (** 431 - Server is unwilling to process the request *)
71
+
| `Unavailable_for_legal_reasons (** 451 - Resource unavailable for legal reasons *)
72
+
]
73
+
(** 4xx Client error responses *)
74
+
75
+
type server_error = [
76
+
| `Internal_server_error (** 500 - Generic error message *)
77
+
| `Not_implemented (** 501 - Server does not recognise method or lacks ability to fulfill *)
78
+
| `Bad_gateway (** 502 - Server received an invalid response from upstream server *)
79
+
| `Service_unavailable (** 503 - Server is currently unavailable *)
80
+
| `Gateway_timeout (** 504 - Gateway did not receive response from upstream server *)
81
+
| `Http_version_not_supported (** 505 - Server does not support the HTTP protocol version *)
82
+
| `Variant_also_negotiates (** 506 - Content negotiation for the request results in a circular reference *)
83
+
| `Insufficient_storage (** 507 - Server is unable to store the representation *)
84
+
| `Loop_detected (** 508 - Server detected an infinite loop while processing the request *)
85
+
| `Not_extended (** 510 - Further extensions to the request are required *)
86
+
| `Network_authentication_required (** 511 - Client needs to authenticate to gain network access *)
87
+
]
88
+
(** 5xx Server error responses *)
89
+
90
+
type standard = [
91
+
| informational
92
+
| success
93
+
| redirection
94
+
| client_error
95
+
| server_error
96
+
]
97
+
(** All standard HTTP status codes *)
98
+
99
+
type t = [
100
+
| `Code of int (** Any status code as an integer *)
101
+
| standard
102
+
]
103
+
(** HTTP status type *)
104
+
105
+
(** {1 Conversion Functions} *)
106
+
107
+
val to_int : t -> int
108
+
(** Convert status to its integer code *)
109
+
110
+
val of_int : int -> t
111
+
(** Convert an integer to a status *)
112
+
113
+
val to_string : t -> string
114
+
(** Get the string representation of a status code (e.g., "200", "404") *)
115
+
116
+
val reason_phrase : t -> string
117
+
(** Get the standard reason phrase for a status code (e.g., "OK", "Not Found") *)
118
+
119
+
(** {1 Classification Functions} *)
120
+
121
+
val is_informational : t -> bool
122
+
(** Check if status code is informational (1xx) *)
123
+
124
+
val is_success : t -> bool
125
+
(** Check if status code indicates success (2xx) *)
126
+
127
+
val is_redirection : t -> bool
128
+
(** Check if status code indicates redirection (3xx) *)
129
+
130
+
val is_client_error : t -> bool
131
+
(** Check if status code indicates client error (4xx) *)
132
+
133
+
val is_server_error : t -> bool
134
+
(** Check if status code indicates server error (5xx) *)
135
+
136
+
val is_error : t -> bool
137
+
(** Check if status code indicates any error (4xx or 5xx) *)
138
+
139
+
(** {1 Retry Policy} *)
140
+
141
+
val is_retryable : t -> bool
142
+
(** Check if a status code suggests the request could be retried.
143
+
Returns true for:
144
+
- 408 Request Timeout
145
+
- 429 Too Many Requests
146
+
- 502 Bad Gateway
147
+
- 503 Service Unavailable
148
+
- 504 Gateway Timeout
149
+
- Any 5xx errors *)
150
+
151
+
val should_retry_on_different_host : t -> bool
152
+
(** Check if a status code suggests retrying on a different host might help.
153
+
Returns true for:
154
+
- 502 Bad Gateway
155
+
- 503 Service Unavailable
156
+
- 504 Gateway Timeout *)
157
+
158
+
(** {1 Pretty Printing} *)
159
+
160
+
val pp : Format.formatter -> t -> unit
161
+
(** Pretty printer for status codes *)
162
+
163
+
val pp_hum : Format.formatter -> t -> unit
164
+
(** Human-readable pretty printer that includes both code and reason phrase *)
+48
lib/timeout.ml
+48
lib/timeout.ml
···
1
+
let src = Logs.Src.create "requests.timeout" ~doc:"HTTP Request Timeouts"
2
+
module Log = (val Logs.src_log src : Logs.LOG)
3
+
4
+
type t = {
5
+
connect : float option;
6
+
read : float option;
7
+
total : float option;
8
+
}
9
+
10
+
let none = {
11
+
connect = None;
12
+
read = None;
13
+
total = None;
14
+
}
15
+
16
+
let create ?connect ?read ?total () = {
17
+
connect;
18
+
read;
19
+
total;
20
+
}
21
+
22
+
let default = {
23
+
connect = Some 10.0;
24
+
read = Some 30.0;
25
+
total = None;
26
+
}
27
+
28
+
let connect t = t.connect
29
+
let read t = t.read
30
+
let total t = t.total
31
+
32
+
let pp ppf t =
33
+
let items = [] in
34
+
let items = match t.connect with
35
+
| Some c -> (Printf.sprintf "connect:%.1fs" c) :: items
36
+
| None -> items
37
+
in
38
+
let items = match t.read with
39
+
| Some r -> (Printf.sprintf "read:%.1fs" r) :: items
40
+
| None -> items
41
+
in
42
+
let items = match t.total with
43
+
| Some tot -> (Printf.sprintf "total:%.1fs" tot) :: items
44
+
| None -> items
45
+
in
46
+
match items with
47
+
| [] -> Format.fprintf ppf "no timeouts"
48
+
| _ -> Format.fprintf ppf "%s" (String.concat ", " (List.rev items))
+28
lib/timeout.mli
+28
lib/timeout.mli
···
1
+
(** Timeout configuration *)
2
+
3
+
(** Log source for timeout operations *)
4
+
val src : Logs.Src.t
5
+
6
+
type t
7
+
(** Timeout configuration *)
8
+
9
+
val none : t
10
+
(** No timeouts *)
11
+
12
+
val create : ?connect:float -> ?read:float -> ?total:float -> unit -> t
13
+
(** Create timeout configuration with optional connect, read, and total timeouts in seconds *)
14
+
15
+
val default : t
16
+
(** Sensible defaults: 10s connect, 30s read, no total limit *)
17
+
18
+
val connect : t -> float option
19
+
(** Get connection timeout *)
20
+
21
+
val read : t -> float option
22
+
(** Get read timeout *)
23
+
24
+
val total : t -> float option
25
+
(** Get total request timeout *)
26
+
27
+
val pp : Format.formatter -> t -> unit
28
+
(** Pretty printer for timeout configuration *)
+39
requests.opam
+39
requests.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Clean Eio-style HTTPS client library for OCaml"
4
+
description:
5
+
"A modern HTTP(S) client library for OCaml with Eio support, providing a clean API for making web requests with automatic TLS/CA certificate handling"
6
+
maintainer: ["Your Name"]
7
+
authors: ["Your Name"]
8
+
license: "MIT"
9
+
homepage: "https://github.com/username/requests"
10
+
bug-reports: "https://github.com/username/requests/issues"
11
+
depends: [
12
+
"ocaml"
13
+
"dune" {>= "3.0" & >= "3.0"}
14
+
"eio"
15
+
"cohttp-eio"
16
+
"tls-eio"
17
+
"ca-certs"
18
+
"mirage-crypto-rng-eio"
19
+
"uri"
20
+
"digestif"
21
+
"base64"
22
+
"logs"
23
+
"odoc" {with-doc}
24
+
]
25
+
build: [
26
+
["dune" "subst"] {dev}
27
+
[
28
+
"dune"
29
+
"build"
30
+
"-p"
31
+
name
32
+
"-j"
33
+
jobs
34
+
"@install"
35
+
"@runtest" {with-test}
36
+
"@doc" {with-doc}
37
+
]
38
+
]
39
+
dev-repo: "git+https://github.com/username/requests.git"