gazagnaire.org
forked from
anil.recoil.org/ocaml-requests
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
6let src = Logs.Src.create "requests.auth" ~doc:"HTTP Authentication"
7
8module Log = (val Logs.src_log src : Logs.LOG)
9
10type t =
11 | No_auth
12 | Basic of { username : string; password : string }
13 | Bearer of { token : string }
14 | Bearer_form of { token : string }
15 (** RFC 6750 Section 2.2: Bearer token in form-encoded body *)
16 | Digest of { username : string; password : string }
17 | Signature of Signature.config (** RFC 9421: HTTP Message Signatures *)
18 | Custom of (Headers.t -> Headers.t)
19
20type digest_challenge = {
21 realm : string;
22 nonce : string;
23 qop : string option;
24 algorithm : string; (** MD5, SHA-256, etc. *)
25 opaque : string option;
26 stale : bool;
27 userhash : bool; (** RFC 7616: If true, hash the username *)
28}
29(** Digest authentication challenge parsed from WWW-Authenticate header *)
30
31let none = No_auth
32let basic ~username ~password = Basic { username; password }
33let bearer ~token = Bearer { token }
34let digest ~username ~password = Digest { username; password }
35let signature config = Signature config
36let custom f = Custom f
37
38(** Check if a URL uses HTTPS scheme *)
39let is_https url =
40 let uri = Uri.of_string url in
41 match Uri.scheme uri with Some "https" -> true | _ -> false
42
43(** Get the authentication type name for error messages *)
44let type_name = function
45 | No_auth -> "None"
46 | Basic _ -> "Basic"
47 | Bearer _ -> "Bearer"
48 | Bearer_form _ -> "Bearer (form)"
49 | Digest _ -> "Digest"
50 | Signature _ -> "Signature"
51 | Custom _ -> "Custom"
52
53(** Check if auth type requires HTTPS (per RFC 7617/6750). Basic, Bearer, and
54 Digest send credentials that can be intercepted. Signature does not strictly
55 require HTTPS as it provides its own integrity. *)
56let requires_https = function
57 | Basic _ | Bearer _ | Bearer_form _ | Digest _ -> true
58 | No_auth | Signature _ | Custom _ -> false
59
60(** Validate that sensitive authentication is used over HTTPS. Per RFC 7617
61 Section 4 (Basic) and RFC 6750 Section 5.1 (Bearer): These authentication
62 methods MUST be used over TLS to prevent credential leakage.
63
64 @param allow_insecure_auth
65 If true, skip the check (for testing environments)
66 @param url The request URL
67 @param auth The authentication configuration
68 @raise Error.Insecure_auth if auth requires HTTPS but URL is HTTP *)
69let validate_secure_transport ?(allow_insecure_auth = false) ~url auth =
70 if allow_insecure_auth then
71 Log.warn (fun m ->
72 m "allow_insecure_auth=true: skipping HTTPS check for %s auth"
73 (type_name auth))
74 else if requires_https auth && not (is_https url) then begin
75 Log.err (fun m ->
76 m
77 "%s authentication rejected over HTTP (use HTTPS or \
78 allow_insecure_auth=true)"
79 (type_name auth));
80 raise (Error.err (Error.Insecure_auth { url; auth_type = type_name auth }))
81 end
82
83let apply auth headers =
84 match auth with
85 | No_auth -> headers
86 | Basic { username; password } ->
87 Log.debug (fun m ->
88 m "Applying basic authentication for user: %s" username);
89 Headers.basic ~username ~password headers
90 | Bearer { token } ->
91 Log.debug (fun m -> m "Applying bearer token authentication");
92 Headers.bearer token headers
93 | Bearer_form { token = _ } ->
94 Log.debug (fun m ->
95 m "Bearer form auth - token goes in body, not headers");
96 (* Bearer form auth puts token in body, not headers.
97 Use bearer_form_body to get the body content. *)
98 headers
99 | Digest { username; password = _ } ->
100 Log.debug (fun m ->
101 m "Digest auth configured for user: %s (requires server challenge)"
102 username);
103 (* Digest auth requires server challenge first, handled elsewhere *)
104 headers
105 | Signature _ ->
106 Log.debug (fun m ->
107 m "Signature auth configured (requires request context)");
108 (* Signature auth requires request context (method, URI) to compute.
109 Handled separately in request flow via apply_signature. *)
110 headers
111 | Custom f ->
112 Log.debug (fun m -> m "Applying custom authentication handler");
113 f headers
114
115(** Apply authentication with HTTPS validation. This is the secure version that
116 checks transport security before applying auth.
117
118 @param allow_insecure_auth If true, allow auth over HTTP (not recommended)
119 @param url The request URL (used for security check)
120 @param auth The authentication to apply
121 @param headers The headers to modify *)
122let apply_secure ?(allow_insecure_auth = false) ~url auth headers =
123 validate_secure_transport ~allow_insecure_auth ~url auth;
124 apply auth headers
125
126(** {1 Digest Authentication Implementation} *)
127
128(** Parse comma-separated key=value or key="value" pairs. *)
129let rec parse_digest_kv_pairs acc str =
130 let str = String.trim str in
131 if str = "" then List.rev acc
132 else
133 match String.index_opt str '=' with
134 | None -> List.rev acc
135 | Some eq_idx ->
136 let key = String.trim (String.sub str 0 eq_idx) in
137 let rest =
138 String.sub str (eq_idx + 1) (String.length str - eq_idx - 1)
139 in
140 let rest = String.trim rest in
141 let value, remaining =
142 if String.length rest > 0 && rest.[0] = '"' then
143 match String.index_from_opt rest 1 '"' with
144 | Some end_quote ->
145 let v = String.sub rest 1 (end_quote - 1) in
146 let rem =
147 String.sub rest (end_quote + 1)
148 (String.length rest - end_quote - 1)
149 in
150 let rem = String.trim rem in
151 let rem =
152 if String.length rem > 0 && rem.[0] = ',' then
153 String.sub rem 1 (String.length rem - 1)
154 else rem
155 in
156 (v, rem)
157 | None -> (rest, "")
158 else
159 match String.index_opt rest ',' with
160 | Some comma ->
161 let v = String.trim (String.sub rest 0 comma) in
162 let rem =
163 String.sub rest (comma + 1) (String.length rest - comma - 1)
164 in
165 (v, rem)
166 | None -> (String.trim rest, "")
167 in
168 parse_digest_kv_pairs
169 ((String.lowercase_ascii key, value) :: acc)
170 remaining
171
172(** Parse WWW-Authenticate header for Digest challenge *)
173let parse_www_authenticate header =
174 Log.debug (fun m -> m "Parsing WWW-Authenticate: %s" header);
175 let header = String.trim header in
176 if
177 not
178 (String.length header >= 7
179 && String.lowercase_ascii (String.sub header 0 7) = "digest ")
180 then begin
181 Log.debug (fun m -> m "Not a Digest challenge");
182 None
183 end
184 else
185 let params = String.sub header 7 (String.length header - 7) in
186 let pairs = parse_digest_kv_pairs [] params in
187 match (List.assoc_opt "realm" pairs, List.assoc_opt "nonce" pairs) with
188 | Some realm, Some nonce ->
189 let challenge =
190 {
191 realm;
192 nonce;
193 qop = List.assoc_opt "qop" pairs;
194 algorithm =
195 List.assoc_opt "algorithm" pairs |> Option.value ~default:"MD5";
196 opaque = List.assoc_opt "opaque" pairs;
197 stale = List.assoc_opt "stale" pairs = Some "true";
198 userhash = List.assoc_opt "userhash" pairs = Some "true";
199 }
200 in
201 Log.debug (fun m ->
202 m
203 "Parsed Digest challenge: realm=%s nonce=%s algorithm=%s \
204 userhash=%b"
205 challenge.realm challenge.nonce challenge.algorithm
206 challenge.userhash);
207 Option.some challenge
208 | _ ->
209 Log.warn (fun m ->
210 m "Digest challenge missing required fields (realm/nonce)");
211 Option.none
212
213(** Hash function based on algorithm. Supports MD5 (default), SHA-256, and
214 SHA-512 per RFC 7616.
215 @raise Error.Authentication_failed if an unsupported algorithm is requested
216*)
217let hash_string ~algorithm s =
218 match String.uppercase_ascii algorithm with
219 | "MD5" | "MD5-SESS" -> Digestif.MD5.(to_hex (digest_string s))
220 | "SHA-256" | "SHA256" | "SHA-256-SESS" ->
221 Digestif.SHA256.(to_hex (digest_string s))
222 | "SHA-512" | "SHA512" -> Digestif.SHA512.(to_hex (digest_string s))
223 | "SHA-512-256" | "SHA512-256" ->
224 (* SHA-512/256 requires specific initialization vectors that differ from
225 standard SHA-512. Truncating SHA-512 output is cryptographically incorrect.
226 This algorithm is rarely used; recommend SHA-256 instead. *)
227 Log.err (fun m ->
228 m "SHA-512-256 algorithm not supported (requires special IVs)");
229 raise
230 (Error.err
231 (Error.Authentication_failed
232 {
233 url = "";
234 reason =
235 "Digest algorithm SHA-512-256 is not supported. Server \
236 should offer SHA-256 or MD5.";
237 }))
238 | other ->
239 (* RFC 7616: Unknown algorithms should be rejected to prevent security downgrades.
240 Silent fallback to MD5 could mask server misconfigurations. *)
241 Log.err (fun m -> m "Unknown digest algorithm '%s'" other);
242 raise
243 (Error.err
244 (Error.Authentication_failed
245 {
246 url = "";
247 reason =
248 Fmt.str
249 "Unknown digest algorithm '%s'. Supported: MD5, SHA-256, \
250 SHA-512."
251 other;
252 }))
253
254(** Generate a random client nonce *)
255let generate_cnonce () =
256 let bytes = Crypto_rng.generate 8 in
257 (* Convert bytes to hex string *)
258 let hex_of_char c =
259 let n = Char.code c in
260 Fmt.str "%02x" n
261 in
262 String.concat ""
263 (List.init (String.length bytes) (fun i -> hex_of_char bytes.[i]))
264
265(** Check if algorithm is a -sess variant *)
266let is_sess_algorithm algorithm =
267 let alg = String.uppercase_ascii algorithm in
268 String.ends_with ~suffix:"-SESS" alg
269
270(** Compute digest response according to RFC 7616.
271
272 @param body
273 Optional request body for auth-int qop (body hash included in HA2) *)
274let compute_digest_response ~username ~password ~method_ ~uri ~challenge ~nc
275 ~cnonce ?body () =
276 let algorithm = challenge.algorithm in
277 (* HA1 calculation differs for -sess algorithms (RFC 7616 Section 3.4.2) *)
278 let ha1_base =
279 hash_string ~algorithm
280 (Fmt.str "%s:%s:%s" username challenge.realm password)
281 in
282 let ha1 =
283 if is_sess_algorithm algorithm then
284 (* For -sess: HA1 = hash(hash(username:realm:password):nonce:cnonce) *)
285 hash_string ~algorithm
286 (Fmt.str "%s:%s:%s" ha1_base challenge.nonce cnonce)
287 else ha1_base
288 in
289 (* Determine which qop to use *)
290 let selected_qop =
291 match challenge.qop with
292 | Some qop ->
293 let qop_parts = String.split_on_char ',' qop |> List.map String.trim in
294 (* Prefer auth-int if body is provided and available, else auth *)
295 if List.mem "auth-int" qop_parts && Option.is_some body then
296 Some "auth-int"
297 else if List.mem "auth" qop_parts then Some "auth"
298 else if qop_parts <> [] then Some (List.hd qop_parts)
299 else None
300 | None -> None
301 in
302 (* HA2 depends on qop *)
303 let ha2 =
304 match (selected_qop, body) with
305 | Some "auth-int", Some body_content ->
306 (* HA2 = hash(method:uri:hash(body)) for auth-int *)
307 let body_hash = hash_string ~algorithm body_content in
308 hash_string ~algorithm (Fmt.str "%s:%s:%s" method_ uri body_hash)
309 | _ ->
310 (* HA2 = hash(method:uri) for auth or no qop *)
311 hash_string ~algorithm (Fmt.str "%s:%s" method_ uri)
312 in
313 (* Response depends on qop *)
314 let response, actual_qop =
315 match selected_qop with
316 | Some qop ->
317 (* qop present: hash(HA1:nonce:nc:cnonce:qop:HA2) *)
318 let resp =
319 hash_string ~algorithm
320 (Fmt.str "%s:%s:%s:%s:%s:%s" ha1 challenge.nonce nc cnonce qop ha2)
321 in
322 (resp, Some qop)
323 | None ->
324 (* No qop: hash(HA1:nonce:HA2) *)
325 let resp =
326 hash_string ~algorithm (Fmt.str "%s:%s:%s" ha1 challenge.nonce ha2)
327 in
328 (resp, None)
329 in
330 Log.debug (fun m ->
331 m "Computed digest response for user %s (qop=%s)" username
332 (Option.value ~default:"none" actual_qop));
333 (response, actual_qop)
334
335(** Build the Authorization header value for Digest auth.
336 @param actual_qop The qop that was actually used (auth or auth-int) *)
337let build_digest_header ~username ~uri ~challenge ~nc ~cnonce ~response
338 ~actual_qop =
339 (* RFC 7616 Section 3.4.4: userhash support *)
340 let username_value, userhash_param =
341 if challenge.userhash then
342 let hashed =
343 hash_string ~algorithm:challenge.algorithm
344 (Fmt.str "%s:%s" username challenge.realm)
345 in
346 (hashed, Some "userhash=true")
347 else (username, None)
348 in
349 let parts =
350 [
351 Fmt.str "username=\"%s\"" username_value;
352 Fmt.str "realm=\"%s\"" challenge.realm;
353 Fmt.str "nonce=\"%s\"" challenge.nonce;
354 Fmt.str "uri=\"%s\"" uri;
355 Fmt.str "algorithm=%s" challenge.algorithm;
356 Fmt.str "response=\"%s\"" response;
357 ]
358 in
359 let parts =
360 match userhash_param with Some p -> parts @ [ p ] | None -> parts
361 in
362 let parts =
363 match actual_qop with
364 | Some qop ->
365 parts
366 @ [
367 Fmt.str "qop=%s" qop;
368 Fmt.str "nc=%s" nc;
369 Fmt.str "cnonce=\"%s\"" cnonce;
370 ]
371 | None -> parts
372 in
373 let parts =
374 match challenge.opaque with
375 | Some o -> parts @ [ Fmt.str "opaque=\"%s\"" o ]
376 | None -> parts
377 in
378 "Digest " ^ String.concat ", " parts
379
380(** {1 Nonce Count Tracking}
381
382 Per RFC 7616, the nonce count (nc) must be incremented for each request
383 using the same server nonce to prevent replay attacks. *)
384
385module Nonce_counter = struct
386 type t = (string, int) Hashtbl.t
387 (** Mutable nonce count tracker, keyed by server nonce *)
388
389 let create () : t = Hashtbl.create 16
390
391 (** Get and increment the nonce count for a given server nonce. Returns the
392 count formatted as 8 hex digits (e.g., "00000001"). *)
393 let next (t : t) ~nonce =
394 let count =
395 match Hashtbl.find_opt t nonce with Some c -> c + 1 | None -> 1
396 in
397 Hashtbl.replace t nonce count;
398 Fmt.str "%08x" count
399
400 (** Clear all tracked nonces (e.g., on session reset) *)
401 let clear (t : t) = Hashtbl.clear t
402end
403
404(** Apply Digest authentication given a challenge.
405 @param nonce_counter
406 Optional nonce counter for replay protection. If provided, the nonce count
407 is tracked and incremented per-nonce. If not provided, defaults to
408 "00000001" (single-request mode).
409 @param body Optional request body for auth-int qop support. *)
410let apply_digest ?nonce_counter ?body ~username ~password ~method_ ~uri
411 ~challenge headers =
412 let nc =
413 match nonce_counter with
414 | Some counter -> Nonce_counter.next counter ~nonce:challenge.nonce
415 | None -> "00000001"
416 in
417 let cnonce = generate_cnonce () in
418 let response, actual_qop =
419 compute_digest_response ~username ~password ~method_ ~uri ~challenge ~nc
420 ~cnonce ?body ()
421 in
422 let auth_header =
423 build_digest_header ~username ~uri ~challenge ~nc ~cnonce ~response
424 ~actual_qop
425 in
426 Log.debug (fun m ->
427 m "Applied Digest authentication for user %s (nc=%s qop=%s)" username nc
428 (Option.value ~default:"none" actual_qop));
429 Headers.set `Authorization auth_header headers
430
431(** Check if auth type is Digest *)
432let is_digest = function Digest _ -> true | _ -> false
433
434(** Get Digest credentials if configured *)
435let digest_credentials = function
436 | Digest { username; password } -> Some (username, password)
437 | _ -> None
438
439(** {1 Bearer Form Authentication}
440
441 Per RFC 6750 Section 2.2: Bearer token can be sent as a form-encoded body
442 parameter "access_token". This is less preferred than the Authorization
443 header but may be required by some APIs. *)
444
445let bearer_form ~token = Bearer_form { token }
446let is_bearer_form = function Bearer_form _ -> true | _ -> false
447
448let bearer_form_body = function
449 | Bearer_form { token } -> Some (Fmt.str "access_token=%s" token)
450 | _ -> None
451
452(** Check if stale=true in digest challenge, indicating password is still valid.
453 Per RFC 7616: If stale=true, the client should retry with same credentials
454 using the new nonce. If stale=false or not present, credentials are wrong.
455*)
456let digest_is_stale challenge = challenge.stale
457
458(** {1 HTTP Message Signatures (RFC 9421)} *)
459
460let is_signature = function Signature _ -> true | _ -> false
461let signature_config = function Signature config -> Some config | _ -> None
462
463(** Apply HTTP Message Signature to headers given request context. This computes
464 and adds the Signature-Input and Signature headers.
465
466 @param clock Eio clock for timestamp generation
467 @param method_ The HTTP method
468 @param uri The request URI
469 @param headers The headers to sign (and add signature to)
470 @param auth The authentication configuration (must be [Signature])
471 @return
472 Updated headers with signature, or original headers if not Signature auth
473*)
474let apply_signature ~clock ~method_ ~uri ~headers auth =
475 match auth with
476 | Signature config -> (
477 let context = Signature.Context.request ~method_ ~uri ~headers in
478 match Signature.sign ~clock ~config ~context ~headers with
479 | Ok signed_headers ->
480 Log.debug (fun m -> m "Applied HTTP message signature");
481 signed_headers
482 | Error e ->
483 Log.err (fun m ->
484 m "Failed to apply HTTP message signature: %s"
485 (Signature.sign_error_to_string e));
486 headers)
487 | _ -> headers
488
489let pp fmt = function
490 | No_auth -> Format.pp_print_string fmt "No_auth"
491 | Basic { username; _ } -> Fmt.pf fmt "Basic(%s)" username
492 | Bearer _ -> Format.pp_print_string fmt "Bearer(<token>)"
493 | Bearer_form _ -> Format.pp_print_string fmt "Bearer_form(<token>)"
494 | Digest { username; _ } -> Fmt.pf fmt "Digest(%s)" username
495 | Signature _ -> Format.pp_print_string fmt "Signature(<config>)"
496 | Custom _ -> Format.pp_print_string fmt "Custom(<fn>)"