jon.recoil.org
forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
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 | Custom of (Headers.t -> Headers.t)
17
18(** Digest authentication challenge parsed from WWW-Authenticate header *)
19type digest_challenge = {
20 realm : string;
21 nonce : string;
22 qop : string option;
23 algorithm : string; (** MD5, SHA-256, etc. *)
24 opaque : string option;
25 stale : bool;
26 userhash : bool; (** RFC 7616: If true, hash the username *)
27}
28
29let none = No_auth
30
31let basic ~username ~password = Basic { username; password }
32
33let bearer ~token = Bearer { token }
34
35let digest ~username ~password = Digest { username; password }
36
37let custom f = Custom f
38
39(** Check if a URL uses HTTPS scheme *)
40let is_https url =
41 let uri = Uri.of_string url in
42 match Uri.scheme uri with
43 | Some "https" -> true
44 | _ -> false
45
46(** Get the authentication type name for error messages *)
47let auth_type_name = function
48 | No_auth -> "None"
49 | Basic _ -> "Basic"
50 | Bearer _ -> "Bearer"
51 | Bearer_form _ -> "Bearer (form)"
52 | Digest _ -> "Digest"
53 | Custom _ -> "Custom"
54
55(** Check if auth type requires HTTPS (per RFC 7617/6750).
56 Basic, Bearer, and Digest send credentials that can be intercepted. *)
57let requires_https = function
58 | Basic _ | Bearer _ | Bearer_form _ | Digest _ -> true
59 | No_auth | Custom _ -> false
60
61(** Validate that sensitive authentication is used over HTTPS.
62 Per RFC 7617 Section 4 (Basic) and RFC 6750 Section 5.1 (Bearer):
63 These authentication methods MUST be used over TLS to prevent credential leakage.
64
65 @param allow_insecure_auth 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 -> m "allow_insecure_auth=true: skipping HTTPS check for %s auth"
72 (auth_type_name auth))
73 else if requires_https auth && not (is_https url) then begin
74 Log.err (fun m -> m "%s authentication rejected over HTTP (use HTTPS or allow_insecure_auth=true)"
75 (auth_type_name auth));
76 raise (Error.err (Error.Insecure_auth {
77 url;
78 auth_type = auth_type_name auth
79 }))
80 end
81
82let apply auth headers =
83 match auth with
84 | No_auth -> headers
85 | Basic { username; password } ->
86 Log.debug (fun m -> m "Applying basic authentication for user: %s" username);
87 Headers.basic ~username ~password headers
88 | Bearer { token } ->
89 Log.debug (fun m -> m "Applying bearer token authentication");
90 Headers.bearer token headers
91 | Bearer_form { token = _ } ->
92 Log.debug (fun m -> m "Bearer form auth - token goes in body, not headers");
93 (* Bearer form auth puts token in body, not headers.
94 Use get_bearer_form_body to get the body content. *)
95 headers
96 | Digest { username; password = _ } ->
97 Log.debug (fun m -> m "Digest auth configured for user: %s (requires server challenge)" username);
98 (* Digest auth requires server challenge first, handled elsewhere *)
99 headers
100 | Custom f ->
101 Log.debug (fun m -> m "Applying custom authentication handler");
102 f headers
103
104(** Apply authentication with HTTPS validation.
105 This is the secure version that checks transport security before applying auth.
106
107 @param allow_insecure_auth If true, allow auth over HTTP (not recommended)
108 @param url The request URL (used for security check)
109 @param auth The authentication to apply
110 @param headers The headers to modify *)
111let apply_secure ?(allow_insecure_auth = false) ~url auth headers =
112 validate_secure_transport ~allow_insecure_auth ~url auth;
113 apply auth headers
114
115(** {1 Digest Authentication Implementation} *)
116
117(** Parse WWW-Authenticate header for Digest challenge *)
118let parse_www_authenticate header =
119 Log.debug (fun m -> m "Parsing WWW-Authenticate: %s" header);
120 let header = String.trim header in
121 if not (String.length header >= 7 &&
122 String.lowercase_ascii (String.sub header 0 7) = "digest ") then begin
123 Log.debug (fun m -> m "Not a Digest challenge");
124 None
125 end
126 else
127 let params = String.sub header 7 (String.length header - 7) in
128 (* Parse key=value or key="value" pairs, separated by commas *)
129 let pairs =
130 let rec parse_pairs acc str =
131 let str = String.trim str in
132 if str = "" then List.rev acc
133 else
134 match String.index_opt str '=' with
135 | None -> List.rev acc
136 | Some eq_idx ->
137 let key = String.trim (String.sub str 0 eq_idx) in
138 let rest = String.sub str (eq_idx + 1) (String.length str - eq_idx - 1) in
139 let rest = String.trim rest in
140 let value, remaining =
141 if String.length rest > 0 && rest.[0] = '"' then
142 (* Quoted value *)
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 = String.sub rest (end_quote + 1) (String.length rest - end_quote - 1) in
147 let rem = String.trim rem in
148 let rem = if String.length rem > 0 && rem.[0] = ',' then
149 String.sub rem 1 (String.length rem - 1)
150 else rem in
151 (v, rem)
152 | None -> (rest, "")
153 else
154 (* Unquoted value *)
155 match String.index_opt rest ',' with
156 | Some comma ->
157 let v = String.trim (String.sub rest 0 comma) in
158 let rem = String.sub rest (comma + 1) (String.length rest - comma - 1) in
159 (v, rem)
160 | None -> (String.trim rest, "")
161 in
162 parse_pairs ((String.lowercase_ascii key, value) :: acc) remaining
163 in
164 parse_pairs [] params
165 in
166 (* Extract required fields *)
167 match List.assoc_opt "realm" pairs, List.assoc_opt "nonce" pairs with
168 | Some realm, Some nonce ->
169 let challenge = {
170 realm;
171 nonce;
172 qop = List.assoc_opt "qop" pairs;
173 algorithm = List.assoc_opt "algorithm" pairs |> Option.value ~default:"MD5";
174 opaque = List.assoc_opt "opaque" pairs;
175 stale = List.assoc_opt "stale" pairs = (Some "true");
176 userhash = List.assoc_opt "userhash" pairs = (Some "true");
177 } in
178 Log.debug (fun m -> m "Parsed Digest challenge: realm=%s nonce=%s algorithm=%s userhash=%b"
179 challenge.realm challenge.nonce challenge.algorithm challenge.userhash);
180 Option.some challenge
181 | _ ->
182 Log.warn (fun m -> m "Digest challenge missing required fields (realm/nonce)");
183 Option.none
184
185(** Hash function based on algorithm.
186 Supports MD5 (default), SHA-256, and SHA-512 per RFC 7616.
187 @raise Error.Authentication_failed if an unsupported algorithm is requested *)
188let hash_string ~algorithm s =
189 match String.uppercase_ascii algorithm with
190 | "MD5" | "MD5-SESS" ->
191 Digestif.MD5.(to_hex (digest_string s))
192 | "SHA-256" | "SHA256" | "SHA-256-SESS" ->
193 Digestif.SHA256.(to_hex (digest_string s))
194 | "SHA-512" | "SHA512" ->
195 Digestif.SHA512.(to_hex (digest_string s))
196 | "SHA-512-256" | "SHA512-256" ->
197 (* SHA-512/256 requires specific initialization vectors that differ from
198 standard SHA-512. Truncating SHA-512 output is cryptographically incorrect.
199 This algorithm is rarely used; recommend SHA-256 instead. *)
200 Log.err (fun m -> m "SHA-512-256 algorithm not supported (requires special IVs)");
201 raise (Error.err (Error.Authentication_failed {
202 url = "";
203 reason = "Digest algorithm SHA-512-256 is not supported. Server should offer SHA-256 or MD5."
204 }))
205 | other ->
206 Log.warn (fun m -> m "Unknown digest algorithm '%s', defaulting to MD5" other);
207 Digestif.MD5.(to_hex (digest_string s))
208
209(** Generate a random client nonce *)
210let generate_cnonce () =
211 let bytes = Mirage_crypto_rng.generate 8 in
212 (* Convert bytes to hex string *)
213 let hex_of_char c =
214 let n = Char.code c in
215 Printf.sprintf "%02x" n
216 in
217 String.concat "" (List.init (String.length bytes) (fun i -> hex_of_char bytes.[i]))
218
219(** Compute digest response according to RFC 7616.
220
221 @param body Optional request body for auth-int qop (body hash included in HA2) *)
222let compute_digest_response ~username ~password ~method_ ~uri ~challenge ~nc ~cnonce ?body () =
223 let algorithm = challenge.algorithm in
224 (* HA1 = hash(username:realm:password) *)
225 let ha1 = hash_string ~algorithm
226 (Printf.sprintf "%s:%s:%s" username challenge.realm password) in
227 (* Determine which qop to use *)
228 let selected_qop = match challenge.qop with
229 | Some qop ->
230 let qop_parts = String.split_on_char ',' qop |> List.map String.trim in
231 (* Prefer auth-int if body is provided and available, else auth *)
232 if List.mem "auth-int" qop_parts && Option.is_some body then
233 Some "auth-int"
234 else if List.mem "auth" qop_parts then
235 Some "auth"
236 else if qop_parts <> [] then
237 Some (List.hd qop_parts)
238 else
239 None
240 | None -> None
241 in
242 (* HA2 depends on qop *)
243 let ha2 = match selected_qop, body with
244 | Some "auth-int", Some body_content ->
245 (* HA2 = hash(method:uri:hash(body)) for auth-int *)
246 let body_hash = hash_string ~algorithm body_content in
247 hash_string ~algorithm (Printf.sprintf "%s:%s:%s" method_ uri body_hash)
248 | _ ->
249 (* HA2 = hash(method:uri) for auth or no qop *)
250 hash_string ~algorithm (Printf.sprintf "%s:%s" method_ uri)
251 in
252 (* Response depends on qop *)
253 let response, actual_qop = match selected_qop with
254 | Some qop ->
255 (* qop present: hash(HA1:nonce:nc:cnonce:qop:HA2) *)
256 let resp = hash_string ~algorithm
257 (Printf.sprintf "%s:%s:%s:%s:%s:%s"
258 ha1 challenge.nonce nc cnonce qop ha2) in
259 (resp, Some qop)
260 | None ->
261 (* No qop: hash(HA1:nonce:HA2) *)
262 let resp = hash_string ~algorithm
263 (Printf.sprintf "%s:%s:%s" ha1 challenge.nonce ha2) in
264 (resp, None)
265 in
266 Log.debug (fun m -> m "Computed digest response for user %s (qop=%s)"
267 username (Option.value ~default:"none" actual_qop));
268 (response, actual_qop)
269
270(** Build the Authorization header value for Digest auth.
271 @param actual_qop The qop that was actually used (auth or auth-int) *)
272let build_digest_header ~username ~uri ~challenge ~nc ~cnonce ~response ~actual_qop =
273 (* RFC 7616 Section 3.4.4: userhash support *)
274 let username_value, userhash_param =
275 if challenge.userhash then
276 let hashed = hash_string ~algorithm:challenge.algorithm
277 (Printf.sprintf "%s:%s" username challenge.realm) in
278 (hashed, Some "userhash=true")
279 else
280 (username, None)
281 in
282 let parts = [
283 Printf.sprintf "username=\"%s\"" username_value;
284 Printf.sprintf "realm=\"%s\"" challenge.realm;
285 Printf.sprintf "nonce=\"%s\"" challenge.nonce;
286 Printf.sprintf "uri=\"%s\"" uri;
287 Printf.sprintf "algorithm=%s" challenge.algorithm;
288 Printf.sprintf "response=\"%s\"" response;
289 ] in
290 let parts = match userhash_param with
291 | Some p -> parts @ [p]
292 | None -> parts
293 in
294 let parts = match actual_qop with
295 | Some qop -> parts @ [
296 Printf.sprintf "qop=%s" qop;
297 Printf.sprintf "nc=%s" nc;
298 Printf.sprintf "cnonce=\"%s\"" cnonce;
299 ]
300 | None -> parts
301 in
302 let parts = match challenge.opaque with
303 | Some o -> parts @ [Printf.sprintf "opaque=\"%s\"" o]
304 | None -> parts
305 in
306 "Digest " ^ String.concat ", " parts
307
308(** {1 Nonce Count Tracking}
309
310 Per RFC 7616, the nonce count (nc) must be incremented for each request
311 using the same server nonce to prevent replay attacks. *)
312
313module Nonce_counter = struct
314 (** Mutable nonce count tracker, keyed by server nonce *)
315 type t = (string, int) Hashtbl.t
316
317 let create () : t = Hashtbl.create 16
318
319 (** Get and increment the nonce count for a given server nonce.
320 Returns the count formatted as 8 hex digits (e.g., "00000001"). *)
321 let next (t : t) ~nonce =
322 let count = match Hashtbl.find_opt t nonce with
323 | Some c -> c + 1
324 | None -> 1
325 in
326 Hashtbl.replace t nonce count;
327 Printf.sprintf "%08x" count
328
329 (** Clear all tracked nonces (e.g., on session reset) *)
330 let clear (t : t) = Hashtbl.clear t
331end
332
333(** Apply Digest authentication given a challenge.
334 @param nonce_counter Optional nonce counter for replay protection.
335 If provided, the nonce count is tracked and incremented per-nonce.
336 If not provided, defaults to "00000001" (single-request mode).
337 @param body Optional request body for auth-int qop support. *)
338let apply_digest ?nonce_counter ?body ~username ~password ~method_ ~uri ~challenge headers =
339 let nc = match nonce_counter with
340 | Some counter -> Nonce_counter.next counter ~nonce:challenge.nonce
341 | None -> "00000001"
342 in
343 let cnonce = generate_cnonce () in
344 let response, actual_qop = compute_digest_response
345 ~username ~password ~method_ ~uri ~challenge ~nc ~cnonce ?body () in
346 let auth_header = build_digest_header
347 ~username ~uri ~challenge ~nc ~cnonce ~response ~actual_qop in
348 Log.debug (fun m -> m "Applied Digest authentication for user %s (nc=%s qop=%s)"
349 username nc (Option.value ~default:"none" actual_qop));
350 Headers.set `Authorization auth_header headers
351
352(** Check if auth type is Digest *)
353let is_digest = function
354 | Digest _ -> true
355 | _ -> false
356
357(** Get Digest credentials if configured *)
358let get_digest_credentials = function
359 | Digest { username; password } -> Some (username, password)
360 | _ -> None
361
362(** {1 Bearer Form Authentication}
363
364 Per RFC 6750 Section 2.2: Bearer token can be sent as a form-encoded
365 body parameter "access_token". This is less preferred than the
366 Authorization header but may be required by some APIs. *)
367
368let bearer_form ~token = Bearer_form { token }
369
370let is_bearer_form = function
371 | Bearer_form _ -> true
372 | _ -> false
373
374let get_bearer_form_body = function
375 | Bearer_form { token } -> Some (Printf.sprintf "access_token=%s" token)
376 | _ -> None
377
378(** Check if stale=true in digest challenge, indicating password is still valid.
379 Per RFC 7616: If stale=true, the client should retry with same credentials
380 using the new nonce. If stale=false or not present, credentials are wrong. *)
381let digest_is_stale challenge = challenge.stale