anil.recoil.org
A batteries included HTTP/1.1 client in OCaml
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6open Eio
7open Cmdliner
8
9(* Command-line options *)
10let http_method =
11 let methods = [
12 ("GET", `GET);
13 ("POST", `POST);
14 ("PUT", `PUT);
15 ("DELETE", `DELETE);
16 ("HEAD", `HEAD);
17 ("OPTIONS", `OPTIONS);
18 ("PATCH", `PATCH);
19 ] in
20 let doc = "HTTP method to use" in
21 let env_info = Cmdliner.Cmd.Env.info "OCURL_METHOD" in
22 Arg.(value & opt (enum methods) `GET & info ["X"; "request"] ~env:env_info ~docv:"METHOD" ~doc)
23
24let urls =
25 let doc = "URL(s) to fetch" in
26 Arg.(non_empty & pos_all string [] & info [] ~docv:"URL" ~doc)
27
28let headers =
29 let doc = "Add custom HTTP header (can be used multiple times)" in
30 Arg.(value & opt_all string [] & info ["H"; "header"] ~docv:"HEADER" ~doc)
31
32let data =
33 let doc = "HTTP POST/PUT data" in
34 Arg.(value & opt (some string) None & info ["d"; "data"] ~docv:"DATA" ~doc)
35
36let json_data =
37 let doc = "HTTP POST/PUT JSON data" in
38 Arg.(value & opt (some string) None & info ["json"] ~docv:"JSON" ~doc)
39
40let output_file =
41 let doc = "Write output to file instead of stdout" in
42 Arg.(value & opt (some string) None & info ["o"; "output"] ~docv:"FILE" ~doc)
43
44let include_headers =
45 let doc = "Include response headers in output" in
46 Arg.(value & flag & info ["i"; "include"] ~doc)
47
48let head =
49 let doc = "Show only response headers (no body)" in
50 Arg.(value & flag & info ["I"; "head"] ~doc)
51
52let auth =
53 let doc = "Basic authentication in USER:PASSWORD format" in
54 Arg.(value & opt (some string) None & info ["u"; "user"] ~docv:"USER:PASS" ~doc)
55
56let allow_insecure_auth =
57 let doc = "Allow basic authentication over HTTP (insecure, for testing only)" in
58 Arg.(value & flag & info ["allow-insecure-auth"] ~doc)
59
60let show_progress =
61 let doc = "Show progress bar for downloads" in
62 Arg.(value & flag & info ["progress-bar"] ~doc)
63
64(* Logging setup *)
65(* Setup logging using Logs_cli for standard logging options *)
66let setup_log app_name =
67 let setup style_renderer level verbose_http_ws =
68 Fmt_tty.setup_std_outputs ?style_renderer ();
69 Logs.set_level level;
70 Logs.set_reporter (Logs_fmt.reporter ());
71 (* Extract value from with_source wrapper *)
72 Requests.Cmd.setup_log_sources ~verbose_http:verbose_http_ws.Requests.Cmd.value level
73 in
74 Term.(const setup $ Fmt_cli.style_renderer () $ Logs_cli.level () $
75 Requests.Cmd.verbose_http_term app_name)
76
77(* Parse authentication *)
78let parse_auth auth_str =
79 match String.split_on_char ':' auth_str with
80 | [user; pass] -> Some (user, pass)
81 | _ -> None
82
83(* Parse headers *)
84let parse_header header_str =
85 match String.split_on_char ':' header_str with
86 | [] -> None
87 | [name] -> Some (String.trim name, "")
88 | name :: rest ->
89 Some (String.trim name, String.trim (String.concat ":" rest))
90
91(* Pretty print response *)
92let pp_response ppf response =
93 let status = Requests.Response.status response in
94 let status_code = Requests.Response.status_code response in
95 let headers = Requests.Response.headers response in
96
97 (* Color code status *)
98 let status_style =
99 if Requests.Status.is_success status then Fmt.(styled `Green)
100 else if Requests.Status.is_client_error status then Fmt.(styled `Yellow)
101 else if Requests.Status.is_server_error status then Fmt.(styled `Red)
102 else Fmt.(styled `Blue)
103 in
104
105 (* Print status line *)
106 Fmt.pf ppf "@[<v>HTTP/1.1 %d %a@]@."
107 status_code
108 (status_style Fmt.string) (Requests.Status.reason_phrase status);
109
110 (* Print headers *)
111 let header_list = Requests.Headers.to_list headers in
112 List.iter (fun (k, v) ->
113 Fmt.pf ppf "@[<h>%a: %s@]@."
114 Fmt.(styled `Cyan string) k v
115 ) header_list;
116
117 Fmt.pf ppf "@."
118
119(* Normalize URL to ensure it has a scheme, defaulting to http:// *)
120let normalize_url url_str =
121 let uri = Uri.of_string url_str in
122 match Uri.scheme uri with
123 | Some _ -> url_str (* Already has a scheme *)
124 | None ->
125 (* No scheme - prepend http:// *)
126 "http://" ^ url_str
127
128(* Process a single URL and return result *)
129let process_url env req method_ headers body include_headers head output url_str =
130 let url_str = normalize_url url_str in
131 let quiet = match Logs.level () with Some (Logs.Error | Logs.Warning) -> true | _ -> false in
132 let uri = Uri.of_string url_str in
133
134 if not quiet then begin
135 let method_str = Requests.Method.to_string (method_ :> Requests.Method.t) in
136 Fmt.pr "@[<v>%a %a@]@."
137 Fmt.(styled `Bold string) method_str
138 Fmt.(styled `Underline Uri.pp) uri;
139 end;
140 try
141 (* Make request *)
142 let response =
143 match method_ with
144 | `GET -> Requests.get req ~headers url_str
145 | `POST -> Requests.post req ~headers ?body url_str
146 | `PUT -> Requests.put req ~headers ?body url_str
147 | `DELETE -> Requests.delete req ~headers url_str
148 | `HEAD -> Requests.head req ~headers url_str
149 | `OPTIONS -> Requests.options req ~headers url_str
150 | `PATCH -> Requests.patch req ~headers ?body url_str
151 in
152
153 (* Print response headers if requested *)
154 if (include_headers || head) && not quiet then
155 pp_response Fmt.stdout response;
156
157 (* If head flag is set, skip body processing *)
158 if head then
159 Ok (url_str, response)
160 else begin
161 (* Handle output *)
162 let body_flow = Requests.Response.body response in
163
164 begin match output with
165 | Some file -> begin
166 let filename =
167 if List.length [url_str] > 1 then begin
168 let base = Filename.remove_extension file in
169 let ext = Filename.extension file in
170 let url_hash =
171 let full_hash = Digest.string url_str |> Digest.to_hex in
172 String.sub full_hash (String.length full_hash - 8) 8 in
173 Printf.sprintf "%s-%s%s" base url_hash ext
174 end else file
175 in
176 let () =
177 Eio.Path.with_open_out ~create:(`Or_truncate 0o644)
178 Eio.Path.(env#fs / filename) @@ fun sink ->
179 Eio.Flow.copy body_flow sink in
180 let () = if not quiet then
181 Fmt.pr "[%s] Saved to %s@." url_str filename else () in
182 Ok (url_str, response)
183 end
184 | None ->
185 (* Write to stdout *)
186 let buf = Buffer.create 1024 in
187 Eio.Flow.copy body_flow (Eio.Flow.buffer_sink buf);
188 let body_str = Buffer.contents buf in
189
190 (* Pretty-print JSON if applicable *)
191 if String.length body_str > 0 &&
192 (body_str.[0] = '{' || body_str.[0] = '[') then
193 try
194 match Jsont_bytesrw.decode_string' Jsont.json body_str with
195 | Ok json ->
196 (match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Jsont.json json with
197 | Ok pretty ->
198 if not quiet then Fmt.pr "[%s]:@." url_str;
199 print_string pretty
200 | Error _ ->
201 if not quiet then Fmt.pr "[%s]:@." url_str;
202 print_string body_str)
203 | Error _ ->
204 if not quiet then Fmt.pr "[%s]:@." url_str;
205 print_string body_str
206 with _ ->
207 if not quiet then Fmt.pr "[%s]:@." url_str;
208 print_string body_str
209 else begin
210 if not quiet then Fmt.pr "[%s]:@." url_str;
211 print_string body_str
212 end;
213
214 if not quiet && Requests.Response.ok response then
215 Logs.app (fun m -> m "✓ Success for %s" url_str);
216
217 Ok (url_str, response)
218 end
219 end
220 with
221 | exn ->
222 Logs.err (fun m -> m "Request failed for %s: %a" url_str Eio.Exn.pp exn);
223 Error (url_str, exn)
224
225(* Main function using Requests with concurrent fetching *)
226let run_request env sw persist_cookies verify_tls timeout follow_redirects max_redirects
227 method_ urls headers data json_data output include_headers head
228 auth allow_insecure_auth _show_progress () =
229
230 (* Log levels are already set by setup_log via Logs_cli *)
231
232 (* Create XDG paths *)
233 let xdg = Xdge.create env#fs "ocurl" in
234
235 (* Create requests instance with configuration *)
236 let timeout_obj = Option.map (fun t -> Requests.Timeout.create ~total:t ()) timeout in
237 let req = Requests.create ~sw ~xdg ~persist_cookies ~verify_tls
238 ~follow_redirects ~max_redirects ~allow_insecure_auth ?timeout:timeout_obj env in
239
240 (* Set authentication if provided *)
241 let req = match Option.bind auth parse_auth with
242 | Some (user, pass) ->
243 Requests.set_auth req (Requests.Auth.basic ~username:user ~password:pass)
244 | None ->
245 (if Option.is_some auth then
246 Logs.warn (fun m -> m "Invalid auth format, ignoring"));
247 req
248 in
249
250 (* Build headers from command line *)
251 let cmd_headers = List.fold_left (fun hdrs header_str ->
252 match parse_header header_str with
253 | Some (k, v) -> Requests.Headers.add_string k v hdrs
254 | None -> hdrs
255 ) Requests.Headers.empty headers in
256
257 (* Prepare body based on data/json options *)
258 let body = match json_data, data with
259 | Some json_str, _ ->
260 (* Use of_string with JSON mime type for raw JSON string *)
261 Some (Requests.Body.of_string Requests.Mime.json json_str)
262 | None, Some d -> Some (Requests.Body.text d)
263 | None, None -> None
264 in
265
266 (* Process URLs concurrently or sequentially based on count *)
267 match urls with
268 | [] -> ()
269 | [single_url] ->
270 (* Single URL - process directly *)
271 let _ = process_url env req method_ cmd_headers body include_headers head output single_url in
272 ()
273 | multiple_urls ->
274 (* Multiple URLs - process concurrently *)
275 let verbose = Logs.level () = Some Logs.Debug || Logs.level () = Some Logs.Info in
276 if verbose then
277 Fmt.pr "@[<v>Processing %d URLs concurrently...@]@." (List.length multiple_urls);
278
279 (* Create promises for each URL *)
280 let results =
281 List.map (fun url_str ->
282 let promise, resolver = Eio.Promise.create () in
283 (* Fork a fiber for each URL *)
284 Fiber.fork ~sw (fun () ->
285 let result = process_url env req method_ cmd_headers body include_headers head output url_str in
286 Eio.Promise.resolve resolver result
287 );
288 promise
289 ) multiple_urls
290 in
291
292 (* Wait for all promises to complete *)
293 let completed_results = List.map Eio.Promise.await results in
294
295 (* Report summary *)
296 let quiet = match Logs.level () with Some (Logs.Error | Logs.Warning) -> true | _ -> false in
297 if not quiet then begin
298 let successes = List.filter Result.is_ok completed_results |> List.length in
299 let failures = List.filter Result.is_error completed_results |> List.length in
300 Fmt.pr "@[<v>@.Summary: %d successful, %d failed out of %d total@]@."
301 successes failures (List.length completed_results);
302
303 (* Print failed URLs *)
304 if failures > 0 then begin
305 Fmt.pr "@[<v>Failed URLs:@]@.";
306 List.iter (function
307 | Error (url, _) -> Fmt.pr " - %s@." url
308 | Ok _ -> ()
309 ) completed_results
310 end
311 end
312
313(* Main entry point *)
314let main method_ urls headers data json_data output include_headers head
315 auth allow_insecure_auth show_progress persist_cookies_ws verify_tls_ws
316 timeout_ws follow_redirects_ws max_redirects_ws () =
317
318 (* Extract values from with_source wrappers *)
319 let persist_cookies = persist_cookies_ws.Requests.Cmd.value in
320 let verify_tls = verify_tls_ws.Requests.Cmd.value in
321 let timeout = timeout_ws.Requests.Cmd.value in
322 let follow_redirects = follow_redirects_ws.Requests.Cmd.value in
323 let max_redirects = max_redirects_ws.Requests.Cmd.value in
324
325 Eio_main.run @@ fun env ->
326 Mirage_crypto_rng_unix.use_default ();
327 Switch.run @@ fun sw ->
328
329 run_request env sw persist_cookies verify_tls timeout follow_redirects max_redirects
330 method_ urls headers data json_data output include_headers head auth
331 allow_insecure_auth show_progress ()
332
333(* Command-line interface *)
334let cmd =
335 let doc = "OCaml HTTP client with concurrent fetching using the Requests library" in
336 let man = [
337 `S Manpage.s_description;
338 `P "$(tname) is a command-line HTTP client written in OCaml that uses the \
339 Requests library with stateful request management. It supports various HTTP methods, \
340 custom headers, authentication, cookies, and JSON data. When multiple URLs are provided, \
341 they are fetched concurrently using Eio fibers for maximum performance.";
342 `S Manpage.s_examples;
343 `P "Fetch a URL:";
344 `Pre " $(tname) https://api.github.com";
345 `P "Fetch multiple URLs concurrently:";
346 `Pre " $(tname) https://api.github.com https://httpbin.org/get https://example.com";
347 `P "Show only response headers (like HEAD request):";
348 `Pre " $(tname) -I https://api.github.com";
349 `P "Include response headers with body:";
350 `Pre " $(tname) -i https://api.github.com";
351 `P "POST JSON data:";
352 `Pre " $(tname) -X POST --json '{\"key\":\"value\"}' https://httpbin.org/post";
353 `P "Download file:";
354 `Pre " $(tname) -o file.zip https://example.com/file.zip";
355 `P "Download multiple files concurrently:";
356 `Pre " $(tname) -o output.json https://api1.example.com https://api2.example.com https://api3.example.com";
357 `P "Basic authentication:";
358 `Pre " $(tname) -u user:pass https://httpbin.org/basic-auth/user/pass";
359 `P "Custom headers:";
360 `Pre " $(tname) -H 'Accept: application/json' -H 'X-Api-Key: secret' https://api.example.com";
361 `P "With persistent cookies:";
362 `Pre " $(tname) --persist-cookies https://example.com";
363 `P "Disable TLS verification (insecure):";
364 `Pre " $(tname) --no-verify-tls https://self-signed.example.com";
365 `S "LOGGING OPTIONS";
366 `P "Control logging verbosity using standard options:";
367 `P "Enable verbose logging (can be repeated):";
368 `Pre " $(tname) -v https://api.github.com # info level";
369 `Pre " $(tname) -vv https://api.github.com # debug level (application-level)";
370 `P "Enable HTTP protocol-level verbose logging:";
371 `Pre " $(tname) -vv --verbose-http https://api.github.com # includes TLS/TCP details";
372 `P "Suppress output:";
373 `Pre " $(tname) -q https://api.github.com # warnings and errors only";
374 `P "Set specific log level:";
375 `Pre " $(tname) --verbosity=info https://api.github.com";
376 `Pre " $(tname) --verbosity=debug https://api.github.com";
377 `Pre " $(tname) --verbosity=error https://api.github.com";
378 `P "Available verbosity levels: quiet, error, warning, info, debug";
379 `P "The logging system provides detailed information about:";
380 `P "- HTTP requests and responses (use -v or -vv for application-level logs)";
381 `P "- Authentication and cookie handling";
382 `P "- Retry attempts and backoff calculations";
383 `P "- TLS/TCP connection details (use --verbose-http with -vv for protocol-level logs)";
384 ] in
385
386 (* Build the term with Requests configuration options *)
387 let app_name = "ocurl" in
388 let combined_term =
389 Term.(const main $ http_method $ urls $ headers $ data $ json_data $
390 output_file $ include_headers $ head $ auth $
391 allow_insecure_auth $ show_progress $
392 Requests.Cmd.persist_cookies_term app_name $
393 Requests.Cmd.verify_tls_term app_name $
394 Requests.Cmd.timeout_term app_name $
395 Requests.Cmd.follow_redirects_term app_name $
396 Requests.Cmd.max_redirects_term app_name $
397 setup_log app_name)
398 in
399
400 let info = Cmd.info "ocurl" ~version:"2.0.0" ~doc ~man in
401 Cmd.v info combined_term
402
403let () = exit (Cmd.eval cmd)