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