anil.recoil.org
A batteries included HTTP/1.1 client in OCaml
features
+1
dune-project
+1
dune-project
+176
-4
lib/auth.ml
+176
-4
lib/auth.ml
···
7
7
module Log = (val Logs.src_log src : Logs.LOG)
8
8
9
9
type t =
10
-
| None
10
+
| No_auth
11
11
| Basic of { username : string; password : string }
12
12
| Bearer of { token : string }
13
13
| Digest of { username : string; password : string }
14
14
| Custom of (Headers.t -> Headers.t)
15
15
16
-
let none = None
16
+
(** Digest authentication challenge parsed from WWW-Authenticate header *)
17
+
type digest_challenge = {
18
+
realm : string;
19
+
nonce : string;
20
+
qop : string option;
21
+
algorithm : string; (** MD5, SHA-256, etc. *)
22
+
opaque : string option;
23
+
stale : bool;
24
+
}
25
+
26
+
let none = No_auth
17
27
18
28
let basic ~username ~password = Basic { username; password }
19
29
···
25
35
26
36
let apply auth headers =
27
37
match auth with
28
-
| None -> headers
38
+
| No_auth -> headers
29
39
| Basic { username; password } ->
30
40
Log.debug (fun m -> m "Applying basic authentication for user: %s" username);
31
41
Headers.basic ~username ~password headers
···
38
48
headers
39
49
| Custom f ->
40
50
Log.debug (fun m -> m "Applying custom authentication handler");
41
-
f headers
51
+
f headers
52
+
53
+
(** {1 Digest Authentication Implementation} *)
54
+
55
+
(** Parse WWW-Authenticate header for Digest challenge *)
56
+
let parse_www_authenticate header =
57
+
Log.debug (fun m -> m "Parsing WWW-Authenticate: %s" header);
58
+
let header = String.trim header in
59
+
if not (String.length header >= 7 &&
60
+
String.lowercase_ascii (String.sub header 0 7) = "digest ") then begin
61
+
Log.debug (fun m -> m "Not a Digest challenge");
62
+
None
63
+
end
64
+
else
65
+
let params = String.sub header 7 (String.length header - 7) in
66
+
(* Parse key=value or key="value" pairs, separated by commas *)
67
+
let pairs =
68
+
let rec parse_pairs acc str =
69
+
let str = String.trim str in
70
+
if str = "" then List.rev acc
71
+
else
72
+
match String.index_opt str '=' with
73
+
| None -> List.rev acc
74
+
| Some eq_idx ->
75
+
let key = String.trim (String.sub str 0 eq_idx) in
76
+
let rest = String.sub str (eq_idx + 1) (String.length str - eq_idx - 1) in
77
+
let rest = String.trim rest in
78
+
let value, remaining =
79
+
if String.length rest > 0 && rest.[0] = '"' then
80
+
(* Quoted value *)
81
+
match String.index_from_opt rest 1 '"' with
82
+
| Some end_quote ->
83
+
let v = String.sub rest 1 (end_quote - 1) in
84
+
let rem = String.sub rest (end_quote + 1) (String.length rest - end_quote - 1) in
85
+
let rem = String.trim rem in
86
+
let rem = if String.length rem > 0 && rem.[0] = ',' then
87
+
String.sub rem 1 (String.length rem - 1)
88
+
else rem in
89
+
(v, rem)
90
+
| None -> (rest, "")
91
+
else
92
+
(* Unquoted value *)
93
+
match String.index_opt rest ',' with
94
+
| Some comma ->
95
+
let v = String.trim (String.sub rest 0 comma) in
96
+
let rem = String.sub rest (comma + 1) (String.length rest - comma - 1) in
97
+
(v, rem)
98
+
| None -> (String.trim rest, "")
99
+
in
100
+
parse_pairs ((String.lowercase_ascii key, value) :: acc) remaining
101
+
in
102
+
parse_pairs [] params
103
+
in
104
+
(* Extract required fields *)
105
+
match List.assoc_opt "realm" pairs, List.assoc_opt "nonce" pairs with
106
+
| Some realm, Some nonce ->
107
+
let challenge = {
108
+
realm;
109
+
nonce;
110
+
qop = List.assoc_opt "qop" pairs;
111
+
algorithm = List.assoc_opt "algorithm" pairs |> Option.value ~default:"MD5";
112
+
opaque = List.assoc_opt "opaque" pairs;
113
+
stale = List.assoc_opt "stale" pairs = (Some "true");
114
+
} in
115
+
Log.debug (fun m -> m "Parsed Digest challenge: realm=%s nonce=%s algorithm=%s"
116
+
challenge.realm challenge.nonce challenge.algorithm);
117
+
Option.some challenge
118
+
| _ ->
119
+
Log.warn (fun m -> m "Digest challenge missing required fields (realm/nonce)");
120
+
Option.none
121
+
122
+
(** Hash function based on algorithm *)
123
+
let hash_string ~algorithm s =
124
+
match String.uppercase_ascii algorithm with
125
+
| "SHA-256" | "SHA256" ->
126
+
Digestif.SHA256.(to_hex (digest_string s))
127
+
| "SHA-512-256" ->
128
+
(* SHA-512/256 - use SHA-512 and truncate *)
129
+
let full = Digestif.SHA512.(to_hex (digest_string s)) in
130
+
String.sub full 0 64 (* First 256 bits = 64 hex chars *)
131
+
| _ -> (* Default to MD5 *)
132
+
Digestif.MD5.(to_hex (digest_string s))
133
+
134
+
(** Generate a random client nonce *)
135
+
let generate_cnonce () =
136
+
let bytes = Mirage_crypto_rng.generate 8 in
137
+
(* Convert bytes to hex string *)
138
+
let hex_of_char c =
139
+
let n = Char.code c in
140
+
Printf.sprintf "%02x" n
141
+
in
142
+
String.concat "" (List.init (String.length bytes) (fun i -> hex_of_char bytes.[i]))
143
+
144
+
(** Compute digest response according to RFC 7616 *)
145
+
let compute_digest_response ~username ~password ~method_ ~uri ~challenge ~nc ~cnonce =
146
+
let algorithm = challenge.algorithm in
147
+
(* HA1 = hash(username:realm:password) *)
148
+
let ha1 = hash_string ~algorithm
149
+
(Printf.sprintf "%s:%s:%s" username challenge.realm password) in
150
+
(* HA2 = hash(method:uri) *)
151
+
let ha2 = hash_string ~algorithm
152
+
(Printf.sprintf "%s:%s" method_ uri) in
153
+
(* Response depends on qop *)
154
+
let response = match challenge.qop with
155
+
| Some qop when String.contains qop ',' ||
156
+
String.trim qop = "auth" ||
157
+
String.trim qop = "auth-int" ->
158
+
(* qop present: hash(HA1:nonce:nc:cnonce:qop:HA2) *)
159
+
hash_string ~algorithm
160
+
(Printf.sprintf "%s:%s:%s:%s:auth:%s"
161
+
ha1 challenge.nonce nc cnonce ha2)
162
+
| _ ->
163
+
(* No qop: hash(HA1:nonce:HA2) *)
164
+
hash_string ~algorithm
165
+
(Printf.sprintf "%s:%s:%s" ha1 challenge.nonce ha2)
166
+
in
167
+
Log.debug (fun m -> m "Computed digest response for user %s" username);
168
+
response
169
+
170
+
(** Build the Authorization header value for Digest auth *)
171
+
let build_digest_header ~username ~uri ~challenge ~nc ~cnonce ~response =
172
+
let parts = [
173
+
Printf.sprintf "username=\"%s\"" username;
174
+
Printf.sprintf "realm=\"%s\"" challenge.realm;
175
+
Printf.sprintf "nonce=\"%s\"" challenge.nonce;
176
+
Printf.sprintf "uri=\"%s\"" uri;
177
+
Printf.sprintf "algorithm=%s" challenge.algorithm;
178
+
Printf.sprintf "response=\"%s\"" response;
179
+
] in
180
+
let parts = match challenge.qop with
181
+
| Some _ -> parts @ [
182
+
"qop=auth";
183
+
Printf.sprintf "nc=%s" nc;
184
+
Printf.sprintf "cnonce=\"%s\"" cnonce;
185
+
]
186
+
| None -> parts
187
+
in
188
+
let parts = match challenge.opaque with
189
+
| Some o -> parts @ [Printf.sprintf "opaque=\"%s\"" o]
190
+
| None -> parts
191
+
in
192
+
"Digest " ^ String.concat ", " parts
193
+
194
+
(** Apply Digest authentication given a challenge *)
195
+
let apply_digest ~username ~password ~method_ ~uri ~challenge headers =
196
+
let nc = "00000001" in (* Nonce count - for simplicity we use 1 *)
197
+
let cnonce = generate_cnonce () in
198
+
let response = compute_digest_response
199
+
~username ~password ~method_ ~uri ~challenge ~nc ~cnonce in
200
+
let auth_header = build_digest_header
201
+
~username ~uri ~challenge ~nc ~cnonce ~response in
202
+
Log.debug (fun m -> m "Applied Digest authentication for user %s" username);
203
+
Headers.set "Authorization" auth_header headers
204
+
205
+
(** Check if auth type is Digest *)
206
+
let is_digest = function
207
+
| Digest _ -> true
208
+
| _ -> false
209
+
210
+
(** Get Digest credentials if configured *)
211
+
let get_digest_credentials = function
212
+
| Digest { username; password } -> Some (username, password)
213
+
| _ -> None
+43
-6
lib/auth.mli
+43
-6
lib/auth.mli
···
21
21
(** Bearer token authentication (e.g., OAuth 2.0) *)
22
22
23
23
val digest : username:string -> password:string -> t
24
-
(** HTTP Digest authentication.
24
+
(** HTTP Digest authentication (RFC 7616).
25
+
26
+
Digest authentication is automatically handled: when a request returns
27
+
a 401 response with a WWW-Authenticate: Digest header, the library will
28
+
parse the challenge and retry the request with proper digest credentials.
25
29
26
-
{b Note:} Digest authentication is currently not fully implemented.
27
-
This function accepts credentials but does not perform the challenge-response
28
-
protocol required for Digest auth. For functional authentication, use
29
-
{!basic} or {!bearer} instead. *)
30
+
Supports MD5, SHA-256, and SHA-512-256 algorithms as well as qop=auth. *)
30
31
31
32
val custom : (Headers.t -> Headers.t) -> t
32
33
(** Custom authentication handler *)
33
34
34
35
val apply : t -> Headers.t -> Headers.t
35
-
(** Apply authentication to headers *)
36
+
(** Apply authentication to headers *)
37
+
38
+
(** {1 Digest Authentication Support} *)
39
+
40
+
(** Digest authentication challenge parsed from WWW-Authenticate header *)
41
+
type digest_challenge = {
42
+
realm : string;
43
+
nonce : string;
44
+
qop : string option;
45
+
algorithm : string; (** MD5, SHA-256, etc. *)
46
+
opaque : string option;
47
+
stale : bool;
48
+
}
49
+
50
+
val parse_www_authenticate : string -> digest_challenge option
51
+
(** [parse_www_authenticate header] parses a WWW-Authenticate header value
52
+
and returns the Digest challenge if present. Returns [None] if the header
53
+
is not a Digest challenge or cannot be parsed. *)
54
+
55
+
val apply_digest :
56
+
username:string ->
57
+
password:string ->
58
+
method_:string ->
59
+
uri:string ->
60
+
challenge:digest_challenge ->
61
+
Headers.t ->
62
+
Headers.t
63
+
(** [apply_digest ~username ~password ~method_ ~uri ~challenge headers]
64
+
applies Digest authentication to [headers] using the given credentials
65
+
and server challenge. *)
66
+
67
+
val is_digest : t -> bool
68
+
(** [is_digest auth] returns [true] if [auth] is Digest authentication. *)
69
+
70
+
val get_digest_credentials : t -> (string * string) option
71
+
(** [get_digest_credentials auth] returns [Some (username, password)] if
72
+
[auth] is Digest authentication, [None] otherwise. *)
+5
-1
lib/dune
+5
-1
lib/dune
+125
lib/http_client.ml
+125
lib/http_client.ml
···
8
8
let src = Logs.Src.create "requests.http_client" ~doc:"Low-level HTTP client"
9
9
module Log = (val Logs.src_log src : Logs.LOG)
10
10
11
+
(** Decompression support using the decompress library *)
12
+
13
+
(** Decompress gzip-encoded data *)
14
+
let decompress_gzip data =
15
+
Log.debug (fun m -> m "Decompressing gzip data (%d bytes)" (String.length data));
16
+
let i = De.bigstring_create De.io_buffer_size in
17
+
let o = De.bigstring_create De.io_buffer_size in
18
+
let r = Buffer.create (String.length data * 2) in
19
+
let p = ref 0 in
20
+
let refill buf =
21
+
let len = min (String.length data - !p) De.io_buffer_size in
22
+
Bigstringaf.blit_from_string data ~src_off:!p buf ~dst_off:0 ~len;
23
+
p := !p + len;
24
+
len
25
+
in
26
+
let flush buf len =
27
+
let str = Bigstringaf.substring buf ~off:0 ~len in
28
+
Buffer.add_string r str
29
+
in
30
+
match Gz.Higher.uncompress ~refill ~flush i o with
31
+
| Ok _ ->
32
+
let result = Buffer.contents r in
33
+
Log.debug (fun m -> m "Gzip decompression succeeded: %d -> %d bytes"
34
+
(String.length data) (String.length result));
35
+
Ok result
36
+
| Error (`Msg e) ->
37
+
Log.warn (fun m -> m "Gzip decompression failed: %s" e);
38
+
Error e
39
+
40
+
(** Decompress deflate-encoded data (raw DEFLATE, RFC 1951) *)
41
+
let decompress_deflate data =
42
+
Log.debug (fun m -> m "Decompressing deflate data (%d bytes)" (String.length data));
43
+
let i = De.bigstring_create De.io_buffer_size in
44
+
let o = De.bigstring_create De.io_buffer_size in
45
+
let w = De.make_window ~bits:15 in
46
+
let r = Buffer.create (String.length data * 2) in
47
+
let p = ref 0 in
48
+
let refill buf =
49
+
let len = min (String.length data - !p) De.io_buffer_size in
50
+
Bigstringaf.blit_from_string data ~src_off:!p buf ~dst_off:0 ~len;
51
+
p := !p + len;
52
+
len
53
+
in
54
+
let flush buf len =
55
+
let str = Bigstringaf.substring buf ~off:0 ~len in
56
+
Buffer.add_string r str
57
+
in
58
+
match De.Higher.uncompress ~w ~refill ~flush i o with
59
+
| Ok () ->
60
+
let result = Buffer.contents r in
61
+
Log.debug (fun m -> m "Deflate decompression succeeded: %d -> %d bytes"
62
+
(String.length data) (String.length result));
63
+
Ok result
64
+
| Error (`Msg e) ->
65
+
Log.warn (fun m -> m "Deflate decompression failed: %s" e);
66
+
Error e
67
+
68
+
(** Decompress zlib-encoded data (DEFLATE with zlib header, RFC 1950) *)
69
+
let decompress_zlib data =
70
+
Log.debug (fun m -> m "Decompressing zlib data (%d bytes)" (String.length data));
71
+
let i = De.bigstring_create De.io_buffer_size in
72
+
let o = De.bigstring_create De.io_buffer_size in
73
+
let allocate bits = De.make_window ~bits in
74
+
let r = Buffer.create (String.length data * 2) in
75
+
let p = ref 0 in
76
+
let refill buf =
77
+
let len = min (String.length data - !p) De.io_buffer_size in
78
+
Bigstringaf.blit_from_string data ~src_off:!p buf ~dst_off:0 ~len;
79
+
p := !p + len;
80
+
len
81
+
in
82
+
let flush buf len =
83
+
let str = Bigstringaf.substring buf ~off:0 ~len in
84
+
Buffer.add_string r str
85
+
in
86
+
match Zl.Higher.uncompress ~allocate ~refill ~flush i o with
87
+
| Ok _ ->
88
+
let result = Buffer.contents r in
89
+
Log.debug (fun m -> m "Zlib decompression succeeded: %d -> %d bytes"
90
+
(String.length data) (String.length result));
91
+
Ok result
92
+
| Error (`Msg e) ->
93
+
Log.warn (fun m -> m "Zlib decompression failed: %s" e);
94
+
Error e
95
+
96
+
(** Decompress body based on Content-Encoding header *)
97
+
let decompress_body ~content_encoding body =
98
+
let encoding = String.lowercase_ascii (String.trim content_encoding) in
99
+
match encoding with
100
+
| "gzip" | "x-gzip" ->
101
+
(match decompress_gzip body with
102
+
| Ok decompressed -> decompressed
103
+
| Error _ -> body) (* Fall back to raw body on error *)
104
+
| "deflate" ->
105
+
(* "deflate" in HTTP can mean either raw DEFLATE or zlib-wrapped.
106
+
Many servers send zlib-wrapped data despite the spec. Try zlib first,
107
+
then fall back to raw deflate. *)
108
+
(match decompress_zlib body with
109
+
| Ok decompressed -> decompressed
110
+
| Error _ ->
111
+
match decompress_deflate body with
112
+
| Ok decompressed -> decompressed
113
+
| Error _ -> body)
114
+
| "identity" | "" -> body
115
+
| other ->
116
+
Log.warn (fun m -> m "Unknown Content-Encoding '%s', returning raw body" other);
117
+
body
118
+
11
119
(** Build HTTP/1.1 request as a string *)
12
120
let build_request ~method_ ~uri ~headers ~body_str =
13
121
let path = Uri.path uri in
···
167
275
in
168
276
169
277
(status, resp_headers, body_str)
278
+
279
+
(** Make HTTP request with optional auto-decompression *)
280
+
let make_request_decompress ~method_ ~uri ~headers ~body_str ~auto_decompress flow =
281
+
let (status, resp_headers, body_str) = make_request ~method_ ~uri ~headers ~body_str flow in
282
+
if auto_decompress then
283
+
let body_str = match Headers.get "content-encoding" resp_headers with
284
+
| Some encoding -> decompress_body ~content_encoding:encoding body_str
285
+
| None -> body_str
286
+
in
287
+
(* Remove Content-Encoding header after decompression since body is now uncompressed *)
288
+
let resp_headers = match Headers.get "content-encoding" resp_headers with
289
+
| Some _ -> Headers.remove "content-encoding" resp_headers
290
+
| None -> resp_headers
291
+
in
292
+
(status, resp_headers, body_str)
293
+
else
294
+
(status, resp_headers, body_str)
+55
-8
lib/one.ml
+55
-8
lib/one.ml
···
6
6
let src = Logs.Src.create "requests.one" ~doc:"One-shot HTTP Requests"
7
7
module Log = (val Logs.src_log src : Logs.LOG)
8
8
9
+
(* Helper to check if two URIs have the same origin for security purposes.
10
+
Used to determine if sensitive headers (Authorization, Cookie) should be
11
+
stripped during redirects. Following Python requests behavior:
12
+
- Same host and same scheme = same origin
13
+
- http -> https upgrade on same host = allowed (more secure)
14
+
TODO: Support .netrc for re-acquiring auth credentials on new hosts *)
15
+
let same_origin uri1 uri2 =
16
+
let host1 = Uri.host uri1 |> Option.map String.lowercase_ascii in
17
+
let host2 = Uri.host uri2 |> Option.map String.lowercase_ascii in
18
+
let scheme1 = Uri.scheme uri1 |> Option.value ~default:"http" in
19
+
let scheme2 = Uri.scheme uri2 |> Option.value ~default:"http" in
20
+
match host1, host2 with
21
+
| Some h1, Some h2 when String.equal h1 h2 ->
22
+
(* Same host - allow same scheme or http->https upgrade *)
23
+
String.equal scheme1 scheme2 ||
24
+
(scheme1 = "http" && scheme2 = "https")
25
+
| _ -> false
26
+
27
+
(* Strip sensitive headers for cross-origin redirects to prevent credential leakage *)
28
+
let strip_sensitive_headers headers =
29
+
headers
30
+
|> Headers.remove "Authorization"
31
+
9
32
(* Helper to create TCP connection to host:port *)
10
33
let connect_tcp ~sw ~net ~host ~port =
11
34
Log.debug (fun m -> m "Connecting to %s:%d" host port);
···
92
115
(* Main request implementation - completely stateless *)
93
116
let request ~sw ~clock ~net ?headers ?body ?auth ?timeout
94
117
?(follow_redirects = true) ?(max_redirects = 10)
95
-
?(verify_tls = true) ?tls_config ~method_ url =
118
+
?(verify_tls = true) ?tls_config ?(auto_decompress = true) ~method_ url =
96
119
97
120
let start_time = Unix.gettimeofday () in
98
121
let method_str = Method.to_string method_ in
···
112
135
|> Option.fold ~none:headers ~some:(fun mime -> Headers.content_type mime headers)
113
136
in
114
137
138
+
(* Add Accept-Encoding header for auto-decompression if not already set *)
139
+
let headers =
140
+
if auto_decompress && not (Headers.mem "Accept-Encoding" headers) then
141
+
Headers.set "Accept-Encoding" "gzip, deflate" headers
142
+
else
143
+
headers
144
+
in
145
+
115
146
(* Convert body to string for sending *)
116
147
let request_body_str = Option.fold ~none:"" ~some:Body.Private.to_string body in
117
148
118
-
(* Execute request with redirects *)
119
-
let rec make_with_redirects url_to_fetch redirects_left =
149
+
(* Track the original URL for cross-origin redirect detection *)
150
+
let original_uri = Uri.of_string url in
151
+
152
+
(* Execute request with redirects
153
+
headers_for_request: the headers to use for this specific request (may have auth stripped) *)
154
+
let rec make_with_redirects ~headers_for_request url_to_fetch redirects_left =
120
155
let uri_to_fetch = Uri.of_string url_to_fetch in
121
156
122
157
(* Connect to URL (opens new TCP connection) *)
123
158
let flow = connect_to_url ~sw ~clock ~net ~url:url_to_fetch
124
159
~timeout ~verify_tls ~tls_config in
125
160
126
-
(* Make HTTP request using low-level client *)
161
+
(* Make HTTP request using low-level client with optional auto-decompression *)
127
162
let status, resp_headers, response_body_str =
128
-
Http_client.make_request ~method_:method_str ~uri:uri_to_fetch
129
-
~headers ~body_str:request_body_str flow
163
+
Http_client.make_request_decompress ~method_:method_str ~uri:uri_to_fetch
164
+
~headers:headers_for_request ~body_str:request_body_str
165
+
~auto_decompress flow
130
166
in
131
167
132
168
Log.info (fun m -> m "Received response: status=%d" status);
···
144
180
(status, resp_headers, response_body_str, url_to_fetch)
145
181
| Some location ->
146
182
Log.info (fun m -> m "Following redirect to %s (%d remaining)" location redirects_left);
147
-
make_with_redirects location (redirects_left - 1)
183
+
(* Strip sensitive headers on cross-origin redirects (security)
184
+
Following Python requests behavior: auth headers should not leak to other hosts *)
185
+
let redirect_uri = Uri.of_string location in
186
+
let headers_for_redirect =
187
+
if same_origin original_uri redirect_uri then
188
+
headers_for_request
189
+
else begin
190
+
Log.debug (fun m -> m "Cross-origin redirect detected: stripping Authorization header");
191
+
strip_sensitive_headers headers_for_request
192
+
end
193
+
in
194
+
make_with_redirects ~headers_for_request:headers_for_redirect location (redirects_left - 1)
148
195
end else
149
196
(status, resp_headers, response_body_str, url_to_fetch)
150
197
in
151
198
152
199
let final_status, final_headers, final_body_str, final_url =
153
-
make_with_redirects url max_redirects
200
+
make_with_redirects ~headers_for_request:headers url max_redirects
154
201
in
155
202
156
203
let elapsed = Unix.gettimeofday () -. start_time in
+4
-2
lib/one.mli
+4
-2
lib/one.mli
···
63
63
?max_redirects:int ->
64
64
?verify_tls:bool ->
65
65
?tls_config:Tls.Config.client ->
66
+
?auto_decompress:bool ->
66
67
method_:Method.t ->
67
68
string ->
68
69
Response.t
69
70
(** [request ~sw ~clock ~net ?headers ?body ?auth ?timeout ?follow_redirects
70
-
?max_redirects ?verify_tls ?tls_config ~method_ url] makes a single HTTP
71
-
request without connection pooling.
71
+
?max_redirects ?verify_tls ?tls_config ?auto_decompress ~method_ url] makes
72
+
a single HTTP request without connection pooling.
72
73
73
74
Each call opens a new TCP connection (with TLS if https://), makes the
74
75
request, and closes the connection when the switch closes.
···
84
85
@param max_redirects Maximum redirects to follow (default: 10)
85
86
@param verify_tls Whether to verify TLS certificates (default: true)
86
87
@param tls_config Custom TLS configuration (default: system CA certs)
88
+
@param auto_decompress Whether to automatically decompress gzip/deflate responses (default: true)
87
89
@param method_ HTTP method (GET, POST, etc.)
88
90
@param url URL to request
89
91
*)
+130
-11
lib/requests.ml
+130
-11
lib/requests.ml
···
46
46
retry : Retry.config option;
47
47
persist_cookies : bool;
48
48
xdg : Xdge.t option;
49
+
auto_decompress : bool;
49
50
50
51
(* Statistics - mutable but NOTE: when sessions are derived via record update
51
52
syntax ({t with field = value}), these are copied not shared. Each derived
···
74
75
?retry
75
76
?(persist_cookies = false)
76
77
?xdg
78
+
?(auto_decompress = true)
77
79
env =
78
80
79
81
let clock = env#clock in
···
156
158
retry;
157
159
persist_cookies;
158
160
xdg;
161
+
auto_decompress;
159
162
requests_made = 0;
160
163
total_time = 0.0;
161
164
retries_count = 0;
···
186
189
let cookies (T t) = t.cookie_jar
187
190
let clear_cookies (T t) = Cookeio_jar.clear t.cookie_jar
188
191
192
+
(* Helper to check if two URIs have the same origin for security purposes.
193
+
Used to determine if sensitive headers (Authorization, Cookie) should be
194
+
stripped during redirects. Following Python requests behavior:
195
+
- Same host and same scheme = same origin
196
+
- http -> https upgrade on same host = allowed (more secure)
197
+
TODO: Support .netrc for re-acquiring auth credentials on new hosts *)
198
+
let same_origin uri1 uri2 =
199
+
let host1 = Uri.host uri1 |> Option.map String.lowercase_ascii in
200
+
let host2 = Uri.host uri2 |> Option.map String.lowercase_ascii in
201
+
let scheme1 = Uri.scheme uri1 |> Option.value ~default:"http" in
202
+
let scheme2 = Uri.scheme uri2 |> Option.value ~default:"http" in
203
+
match host1, host2 with
204
+
| Some h1, Some h2 when String.equal h1 h2 ->
205
+
(* Same host - allow same scheme or http->https upgrade *)
206
+
String.equal scheme1 scheme2 ||
207
+
(scheme1 = "http" && scheme2 = "https")
208
+
| _ -> false
209
+
210
+
(* Strip sensitive headers for cross-origin redirects to prevent credential leakage *)
211
+
let strip_sensitive_headers headers =
212
+
headers
213
+
|> Headers.remove "Authorization"
214
+
189
215
(* Internal request function using connection pools *)
190
216
let make_request_internal (T t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =
191
217
let start_time = Unix.gettimeofday () in
···
221
247
| None -> headers
222
248
in
223
249
250
+
(* Add Accept-Encoding header for auto-decompression if not already set *)
251
+
let base_headers =
252
+
if t.auto_decompress && not (Headers.mem "Accept-Encoding" base_headers) then
253
+
Headers.set "Accept-Encoding" "gzip, deflate" base_headers
254
+
else
255
+
base_headers
256
+
in
257
+
224
258
(* Convert body to string for sending *)
225
259
let request_body_str = match body with
226
260
| None -> ""
···
249
283
)
250
284
in
251
285
286
+
(* Track the original URL for cross-origin redirect detection *)
287
+
let original_uri = Uri.of_string url in
288
+
252
289
let response =
253
290
254
-
(* Execute request with redirect handling *)
255
-
let rec make_with_redirects url_to_fetch redirects_left =
291
+
(* Execute request with redirect handling
292
+
headers_for_request: the headers to use for this specific request (may have auth stripped) *)
293
+
let rec make_with_redirects ~headers_for_request url_to_fetch redirects_left =
256
294
let uri_to_fetch = Uri.of_string url_to_fetch in
257
295
258
296
(* Parse the redirect URL to get correct host and port *)
···
292
330
match cookies with
293
331
| [] ->
294
332
Log.debug (fun m -> m "No cookies found for %s%s" fetch_domain fetch_path);
295
-
base_headers
333
+
headers_for_request
296
334
| cookies ->
297
335
let cookie_header = Cookeio.make_cookie_header cookies in
298
336
Log.debug (fun m -> m "Adding %d cookies for %s%s: Cookie: %s"
299
337
(List.length cookies) fetch_domain fetch_path cookie_header);
300
-
Headers.set "Cookie" cookie_header base_headers
338
+
Headers.set "Cookie" cookie_header headers_for_request
301
339
)
302
340
in
303
341
···
314
352
let make_request_fn () =
315
353
Conpool.with_connection redirect_pool redirect_endpoint (fun flow ->
316
354
(* Flow is already TLS-wrapped if from https_pool, plain TCP if from http_pool *)
317
-
(* Use our low-level HTTP client *)
318
-
Http_client.make_request ~method_:method_str ~uri:uri_to_fetch
319
-
~headers:headers_with_cookies ~body_str:request_body_str flow
355
+
(* Use our low-level HTTP client with optional auto-decompression *)
356
+
Http_client.make_request_decompress ~method_:method_str ~uri:uri_to_fetch
357
+
~headers:headers_with_cookies ~body_str:request_body_str
358
+
~auto_decompress:t.auto_decompress flow
320
359
)
321
360
in
322
361
···
369
408
Uri.to_string resolved
370
409
in
371
410
Log.info (fun m -> m "Following redirect to %s (%d remaining)" absolute_location redirects_left);
372
-
make_with_redirects absolute_location (redirects_left - 1)
411
+
(* Strip sensitive headers on cross-origin redirects (security)
412
+
Following Python requests behavior: auth headers should not leak to other hosts *)
413
+
let redirect_uri = Uri.of_string absolute_location in
414
+
let headers_for_redirect =
415
+
if same_origin original_uri redirect_uri then
416
+
headers_for_request
417
+
else begin
418
+
Log.debug (fun m -> m "Cross-origin redirect detected: stripping Authorization header");
419
+
strip_sensitive_headers headers_for_request
420
+
end
421
+
in
422
+
make_with_redirects ~headers_for_request:headers_for_redirect absolute_location (redirects_left - 1)
373
423
end else
374
424
(status, resp_headers, response_body_str, url_to_fetch)
375
425
in
376
426
377
427
let max_redir = Option.value max_redirects ~default:t.max_redirects in
378
428
let final_status, final_headers, final_body_str, final_url =
379
-
make_with_redirects url max_redir
429
+
make_with_redirects ~headers_for_request:base_headers url max_redir
380
430
in
381
431
382
432
let elapsed = Unix.gettimeofday () -. start_time in
···
415
465
416
466
response
417
467
468
+
(* Helper to handle Digest authentication 401 challenge *)
469
+
let handle_digest_auth (T t as wrapped_t) ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~method_ ~url response =
470
+
(* Check if we got a 401 and have Digest auth configured *)
471
+
let auth_to_use = match auth with Some a -> a | None -> Option.value t.auth ~default:Auth.none in
472
+
if Response.status_code response = 401 && Auth.is_digest auth_to_use then begin
473
+
match Auth.get_digest_credentials auth_to_use with
474
+
| Some (username, password) ->
475
+
(match Response.header "www-authenticate" response with
476
+
| Some www_auth ->
477
+
(match Auth.parse_www_authenticate www_auth with
478
+
| Some challenge ->
479
+
Log.info (fun m -> m "Received Digest challenge, retrying with authentication");
480
+
let uri = Uri.of_string url in
481
+
let uri_path = Uri.path uri in
482
+
let uri_path = if uri_path = "" then "/" else uri_path in
483
+
(* Apply digest auth to headers *)
484
+
let base_headers = Option.value headers ~default:Headers.empty in
485
+
let auth_headers = Auth.apply_digest
486
+
~username ~password
487
+
~method_:(Method.to_string method_)
488
+
~uri:uri_path
489
+
~challenge
490
+
base_headers
491
+
in
492
+
(* Retry with Digest auth - use Auth.none to prevent double-application *)
493
+
make_request_internal wrapped_t ~headers:auth_headers ?body ~auth:Auth.none ?timeout
494
+
?follow_redirects ?max_redirects ~method_ url
495
+
| None ->
496
+
Log.warn (fun m -> m "Could not parse Digest challenge from WWW-Authenticate");
497
+
response)
498
+
| None ->
499
+
Log.warn (fun m -> m "401 response has no WWW-Authenticate header");
500
+
response)
501
+
| None -> response
502
+
end else
503
+
response
504
+
418
505
(* Public request function - executes synchronously with retry support *)
419
506
let request (T t as wrapped_t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =
507
+
(* Helper to wrap response with Digest auth handling *)
508
+
let with_digest_handling response =
509
+
handle_digest_auth wrapped_t ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~method_ ~url response
510
+
in
420
511
match t.retry with
421
512
| None ->
422
513
(* No retry configured, execute directly *)
423
-
make_request_internal wrapped_t ?headers ?body ?auth ?timeout
424
-
?follow_redirects ?max_redirects ~method_ url
514
+
let response = make_request_internal wrapped_t ?headers ?body ?auth ?timeout
515
+
?follow_redirects ?max_redirects ~method_ url in
516
+
with_digest_handling response
425
517
| Some retry_config ->
426
518
(* Wrap in retry logic *)
427
519
let should_retry_exn = function
···
440
532
try
441
533
let response = make_request_internal wrapped_t ?headers ?body ?auth ?timeout
442
534
?follow_redirects ?max_redirects ~method_ url in
535
+
(* Handle Digest auth challenge if applicable *)
536
+
let response = with_digest_handling response in
443
537
let status = Response.status_code response in
444
538
445
539
(* Check if this status code should be retried *)
···
738
832
(* Suppress TLS debug output by default *)
739
833
set_tls_tracing_level Logs.Warning
740
834
end
835
+
836
+
(** {1 Module-Level Convenience Functions}
837
+
838
+
These functions perform one-off requests without creating a session.
839
+
They are thin wrappers around {!One} module functions.
840
+
For multiple requests to the same hosts, prefer creating a session with {!create}
841
+
to benefit from connection pooling and cookie persistence. *)
842
+
843
+
let simple_get ~sw (env : < clock: _ Eio.Time.clock; net: _ Eio.Net.t; .. >) ?headers ?auth ?timeout url =
844
+
One.get ~sw ~clock:env#clock ~net:env#net ?headers ?auth ?timeout url
845
+
846
+
let simple_post ~sw (env : < clock: _ Eio.Time.clock; net: _ Eio.Net.t; .. >) ?headers ?body ?auth ?timeout url =
847
+
One.post ~sw ~clock:env#clock ~net:env#net ?headers ?body ?auth ?timeout url
848
+
849
+
let simple_put ~sw (env : < clock: _ Eio.Time.clock; net: _ Eio.Net.t; .. >) ?headers ?body ?auth ?timeout url =
850
+
One.put ~sw ~clock:env#clock ~net:env#net ?headers ?body ?auth ?timeout url
851
+
852
+
let simple_patch ~sw (env : < clock: _ Eio.Time.clock; net: _ Eio.Net.t; .. >) ?headers ?body ?auth ?timeout url =
853
+
One.patch ~sw ~clock:env#clock ~net:env#net ?headers ?body ?auth ?timeout url
854
+
855
+
let simple_delete ~sw (env : < clock: _ Eio.Time.clock; net: _ Eio.Net.t; .. >) ?headers ?auth ?timeout url =
856
+
One.delete ~sw ~clock:env#clock ~net:env#net ?headers ?auth ?timeout url
857
+
858
+
let simple_head ~sw (env : < clock: _ Eio.Time.clock; net: _ Eio.Net.t; .. >) ?headers ?auth ?timeout url =
859
+
One.head ~sw ~clock:env#clock ~net:env#net ?headers ?auth ?timeout url
+83
lib/requests.mli
+83
lib/requests.mli
···
228
228
?retry:Retry.config ->
229
229
?persist_cookies:bool ->
230
230
?xdg:Xdge.t ->
231
+
?auto_decompress:bool ->
231
232
< clock: _ Eio.Time.clock; net: _ Eio.Net.t; fs: Eio.Fs.dir_ty Eio.Path.t; .. > ->
232
233
t
233
234
(** Create a new requests instance with persistent state and connection pooling.
···
250
251
@param retry Retry configuration for failed requests
251
252
@param persist_cookies Whether to persist cookies to disk (default: false)
252
253
@param xdg XDG directory context for cookies (required if persist_cookies=true)
254
+
@param auto_decompress Whether to automatically decompress gzip/deflate responses (default: true)
253
255
254
256
{b Note:} HTTP caching has been disabled for simplicity. See CACHEIO.md for integration notes
255
257
if you need to restore caching functionality in the future.
···
695
697
Use [Logs.Src.set_level src] to control logging verbosity.
696
698
Example: [Logs.Src.set_level Requests.src (Some Logs.Debug)] *)
697
699
val src : Logs.Src.t
700
+
701
+
(** {1 Module-Level Convenience Functions}
702
+
703
+
These functions perform one-off requests without creating a session.
704
+
They are thin wrappers around {!One} module functions with a simplified
705
+
environment-based interface.
706
+
707
+
For multiple requests to the same hosts, prefer creating a session with
708
+
{!create} to benefit from connection pooling and cookie persistence.
709
+
710
+
{b Example:}
711
+
{[
712
+
Eio_main.run @@ fun env ->
713
+
Eio.Switch.run @@ fun sw ->
714
+
let response = Requests.simple_get ~sw env "https://example.com" in
715
+
Printf.printf "Status: %d\n" (Response.status_code response)
716
+
]}
717
+
*)
718
+
719
+
val simple_get :
720
+
sw:Eio.Switch.t ->
721
+
< clock: _ Eio.Time.clock; net: _ Eio.Net.t; .. > ->
722
+
?headers:Headers.t ->
723
+
?auth:Auth.t ->
724
+
?timeout:Timeout.t ->
725
+
string ->
726
+
Response.t
727
+
(** [simple_get ~sw env url] performs a one-off GET request. *)
728
+
729
+
val simple_post :
730
+
sw:Eio.Switch.t ->
731
+
< clock: _ Eio.Time.clock; net: _ Eio.Net.t; .. > ->
732
+
?headers:Headers.t ->
733
+
?body:Body.t ->
734
+
?auth:Auth.t ->
735
+
?timeout:Timeout.t ->
736
+
string ->
737
+
Response.t
738
+
(** [simple_post ~sw env url] performs a one-off POST request. *)
739
+
740
+
val simple_put :
741
+
sw:Eio.Switch.t ->
742
+
< clock: _ Eio.Time.clock; net: _ Eio.Net.t; .. > ->
743
+
?headers:Headers.t ->
744
+
?body:Body.t ->
745
+
?auth:Auth.t ->
746
+
?timeout:Timeout.t ->
747
+
string ->
748
+
Response.t
749
+
(** [simple_put ~sw env url] performs a one-off PUT request. *)
750
+
751
+
val simple_patch :
752
+
sw:Eio.Switch.t ->
753
+
< clock: _ Eio.Time.clock; net: _ Eio.Net.t; .. > ->
754
+
?headers:Headers.t ->
755
+
?body:Body.t ->
756
+
?auth:Auth.t ->
757
+
?timeout:Timeout.t ->
758
+
string ->
759
+
Response.t
760
+
(** [simple_patch ~sw env url] performs a one-off PATCH request. *)
761
+
762
+
val simple_delete :
763
+
sw:Eio.Switch.t ->
764
+
< clock: _ Eio.Time.clock; net: _ Eio.Net.t; .. > ->
765
+
?headers:Headers.t ->
766
+
?auth:Auth.t ->
767
+
?timeout:Timeout.t ->
768
+
string ->
769
+
Response.t
770
+
(** [simple_delete ~sw env url] performs a one-off DELETE request. *)
771
+
772
+
val simple_head :
773
+
sw:Eio.Switch.t ->
774
+
< clock: _ Eio.Time.clock; net: _ Eio.Net.t; .. > ->
775
+
?headers:Headers.t ->
776
+
?auth:Auth.t ->
777
+
?timeout:Timeout.t ->
778
+
string ->
779
+
Response.t
780
+
(** [simple_head ~sw env url] performs a one-off HEAD request. *)
+23
lib/response.ml
+23
lib/response.ml
···
66
66
else
67
67
t.body
68
68
69
+
let text t =
70
+
if t.closed then
71
+
failwith "Response has been closed"
72
+
else
73
+
Eio.Buf_read.of_flow t.body ~max_size:max_int |> Eio.Buf_read.take_all
74
+
75
+
let json t =
76
+
let body_str = text t in
77
+
match Jsont_bytesrw.decode_string' Jsont.json body_str with
78
+
| Ok json -> Ok json
79
+
| Error e -> Error (Jsont.Error.to_string e)
80
+
81
+
let raise_for_status t =
82
+
if t.status >= 400 then
83
+
raise (Error.HTTPError {
84
+
url = t.url;
85
+
status = t.status;
86
+
reason = Status.reason_phrase (Status.of_int t.status);
87
+
body = None;
88
+
headers = t.headers;
89
+
})
90
+
else
91
+
t
69
92
70
93
(* Pretty printers *)
71
94
let pp ppf t =
+33
lib/response.mli
+33
lib/response.mli
···
106
106
]}
107
107
*)
108
108
109
+
val text : t -> string
110
+
(** [text response] reads and returns the entire response body as a string.
111
+
The response body is fully consumed by this operation.
112
+
113
+
@raise Failure if the response has already been closed. *)
114
+
115
+
val json : t -> (Jsont.json, string) result
116
+
(** [json response] parses the response body as JSON.
117
+
Returns [Ok json] on success or [Error msg] if parsing fails.
118
+
The response body is fully consumed by this operation.
119
+
120
+
Example:
121
+
{[
122
+
match Response.json response with
123
+
| Ok json -> process_json json
124
+
| Error msg -> Printf.eprintf "JSON parse error: %s\n" msg
125
+
]}
126
+
127
+
@raise Failure if the response has already been closed. *)
128
+
129
+
val raise_for_status : t -> t
130
+
(** [raise_for_status response] raises {!Error.HTTPError} if the response
131
+
status code indicates an error (>= 400). Returns the response unchanged
132
+
if the status indicates success (< 400).
133
+
134
+
This is useful for failing fast on HTTP errors:
135
+
{[
136
+
let response = Requests.get req url |> Response.raise_for_status in
137
+
(* Only reaches here if status < 400 *)
138
+
process_success response
139
+
]}
140
+
141
+
@raise Error.HTTPError if status code >= 400. *)
109
142
110
143
(** {1 Pretty Printing} *)
111
144