My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** RFC 2617 HTTP Digest Authentication implementation *)
2
3module Log = (val Logs.src_log (Logs.Src.create "requests.digest_auth" ~doc:"HTTP Digest Authentication") : Logs.LOG)
4
5(** Digest auth challenge parameters from WWW-Authenticate header *)
6type challenge = {
7 realm : string;
8 domain : string option;
9 nonce : string;
10 opaque : string option;
11 stale : bool;
12 algorithm : [`MD5 | `MD5_sess | `SHA256 | `SHA256_sess];
13 qop : [`Auth | `Auth_int] list option; (* quality of protection *)
14 charset : string option;
15 userhash : bool;
16}
17
18(** Client's chosen parameters for response *)
19type client_data = {
20 username : string;
21 password : string;
22 nc : int; (* nonce count *)
23 cnonce : string; (* client nonce *)
24 qop_chosen : [`Auth | `Auth_int] option;
25}
26
27(** Parse WWW-Authenticate header for Digest challenge *)
28let parse_challenge header_value =
29 (* Remove "Digest " prefix if present *)
30 let value =
31 if String.starts_with ~prefix:"Digest " header_value then
32 String.sub header_value 7 (String.length header_value - 7)
33 else header_value
34 in
35
36 (* Parse comma-separated key=value pairs *)
37 let parse_params str =
38 let rec parse_one pos acc =
39 if pos >= String.length str then acc
40 else
41 (* Skip whitespace *)
42 let pos = ref pos in
43 while !pos < String.length str && str.[!pos] = ' ' do incr pos done;
44 if !pos >= String.length str then acc
45 else
46 (* Find key *)
47 let key_start = !pos in
48 while !pos < String.length str && str.[!pos] <> '=' do incr pos done;
49 if !pos >= String.length str then acc
50 else
51 let key = String.trim (String.sub str key_start (!pos - key_start)) in
52 incr pos; (* Skip '=' *)
53
54 (* Parse value - may be quoted *)
55 let value, next_pos =
56 if !pos < String.length str && str.[!pos] = '"' then begin
57 (* Quoted value *)
58 incr pos;
59 let value_start = !pos in
60 while !pos < String.length str && str.[!pos] <> '"' do
61 if str.[!pos] = '\\' && !pos + 1 < String.length str then
62 pos := !pos + 2 (* Skip escaped character *)
63 else
64 incr pos
65 done;
66 let value = String.sub str value_start (!pos - value_start) in
67 if !pos < String.length str then incr pos; (* Skip closing quote *)
68 (* Skip to next comma *)
69 while !pos < String.length str && str.[!pos] <> ',' do incr pos done;
70 if !pos < String.length str then incr pos; (* Skip comma *)
71 (value, !pos)
72 end else begin
73 (* Unquoted value *)
74 let value_start = !pos in
75 while !pos < String.length str && str.[!pos] <> ',' do incr pos done;
76 let value = String.trim (String.sub str value_start (!pos - value_start)) in
77 if !pos < String.length str then incr pos; (* Skip comma *)
78 (value, !pos)
79 end
80 in
81 parse_one next_pos ((key, value) :: acc)
82 in
83 List.rev (parse_one 0 [])
84 in
85
86 let params = parse_params value in
87
88 (* Extract required and optional parameters *)
89 let get_param name = List.assoc_opt name params in
90 let get_param_req name =
91 match get_param name with
92 | Some v -> v
93 | None -> failwith (Printf.sprintf "Missing required Digest parameter: %s" name)
94 in
95
96 try
97 let realm = get_param_req "realm" in
98 let nonce = get_param_req "nonce" in
99
100 let algorithm = match get_param "algorithm" with
101 | Some "MD5" | None -> `MD5
102 | Some "MD5-sess" -> `MD5_sess
103 | Some "SHA-256" -> `SHA256
104 | Some "SHA-256-sess" -> `SHA256_sess
105 | Some a ->
106 Log.warn (fun m -> m "Unknown digest algorithm: %s, using MD5" a);
107 `MD5
108 in
109
110 let qop = match get_param "qop" with
111 | None -> None
112 | Some qop_str ->
113 let qops = String.split_on_char ',' qop_str |> List.map String.trim in
114 Some (List.filter_map (function
115 | "auth" -> Some `Auth
116 | "auth-int" -> Some `Auth_int
117 | _ -> None
118 ) qops)
119 in
120
121 Some {
122 realm;
123 domain = get_param "domain";
124 nonce;
125 opaque = get_param "opaque";
126 stale = (match get_param "stale" with
127 | Some "true" | Some "TRUE" -> true
128 | _ -> false);
129 algorithm;
130 qop;
131 charset = get_param "charset";
132 userhash = (match get_param "userhash" with
133 | Some "true" | Some "TRUE" -> true
134 | _ -> false);
135 }
136 with
137 | Failure msg ->
138 Log.warn (fun m -> m "Failed to parse Digest challenge: %s" msg);
139 None
140 | Not_found -> None
141
142(** Generate client nonce *)
143let generate_cnonce () =
144 let rand_bytes = Mirage_crypto_rng.generate 16 in
145 Base64.encode_string rand_bytes
146
147(** Hash function based on algorithm *)
148let hash_function = function
149 | `MD5 | `MD5_sess ->
150 fun s -> Digestif.MD5.(to_hex (digest_string s))
151 | `SHA256 | `SHA256_sess ->
152 fun s -> Digestif.SHA256.(to_hex (digest_string s))
153
154(** Calculate H(A1) according to RFC 2617 *)
155let calculate_ha1 ~algorithm ~username ~realm ~password ~nonce ~cnonce =
156 let hash = hash_function algorithm in
157 match algorithm with
158 | `MD5 | `SHA256 ->
159 hash (Printf.sprintf "%s:%s:%s" username realm password)
160 | `MD5_sess | `SHA256_sess ->
161 let ha1_base = hash (Printf.sprintf "%s:%s:%s" username realm password) in
162 hash (Printf.sprintf "%s:%s:%s" ha1_base nonce cnonce)
163
164(** Calculate H(A2) according to RFC 2617 *)
165let calculate_ha2 ~algorithm ~meth ~uri ~qop ~body =
166 let hash = hash_function algorithm in
167 let method_str = match meth with
168 | `GET -> "GET" | `POST -> "POST" | `PUT -> "PUT"
169 | `DELETE -> "DELETE" | `HEAD -> "HEAD" | `OPTIONS -> "OPTIONS"
170 | `PATCH -> "PATCH" | `TRACE -> "TRACE" | `CONNECT -> "CONNECT"
171 | `Other s -> s
172 in
173 match qop with
174 | None | Some `Auth ->
175 hash (Printf.sprintf "%s:%s" method_str (Uri.path_and_query uri))
176 | Some `Auth_int ->
177 (* For auth-int, include hash of entity body *)
178 let body_hash = match body with
179 | None -> hash ""
180 | Some b -> hash b
181 in
182 hash (Printf.sprintf "%s:%s:%s" method_str (Uri.path_and_query uri) body_hash)
183
184(** Calculate the response hash *)
185let calculate_response ~ha1 ~ha2 ~nonce ~nc ~cnonce ~qop =
186 let hash = hash_function `MD5 in (* Response always uses the same hash as HA1 *)
187 match qop with
188 | None ->
189 hash (Printf.sprintf "%s:%s:%s" ha1 nonce ha2)
190 | Some qop_value ->
191 let qop_str = match qop_value with
192 | `Auth -> "auth"
193 | `Auth_int -> "auth-int"
194 in
195 let nc_str = Printf.sprintf "%08x" nc in
196 hash (Printf.sprintf "%s:%s:%s:%s:%s:%s" ha1 nonce nc_str cnonce qop_str ha2)
197
198(** Generate Authorization header value for Digest auth *)
199let generate_auth_header ~challenge ~client_data ~meth ~uri ~body =
200 let { username; password; nc; cnonce; qop_chosen } = client_data in
201 let { realm; nonce; opaque; algorithm; _ } = challenge in
202
203 (* Calculate hashes *)
204 let ha1 = calculate_ha1 ~algorithm ~username ~realm ~password ~nonce ~cnonce in
205 let ha2 = calculate_ha2 ~algorithm ~meth ~uri ~qop:qop_chosen ~body in
206 let response = calculate_response ~ha1 ~ha2 ~nonce ~nc ~cnonce ~qop:qop_chosen in
207
208 (* Build Authorization header *)
209 let params = [
210 ("username", Printf.sprintf "\"%s\"" username);
211 ("realm", Printf.sprintf "\"%s\"" realm);
212 ("nonce", Printf.sprintf "\"%s\"" nonce);
213 ("uri", Printf.sprintf "\"%s\"" (Uri.path_and_query uri));
214 ("response", Printf.sprintf "\"%s\"" response);
215 ] in
216
217 let params = match algorithm with
218 | `MD5 -> params (* MD5 is default, don't need to specify *)
219 | `MD5_sess -> ("algorithm", "MD5-sess") :: params
220 | `SHA256 -> ("algorithm", "SHA-256") :: params
221 | `SHA256_sess -> ("algorithm", "SHA-256-sess") :: params
222 in
223
224 let params = match opaque with
225 | Some o -> ("opaque", Printf.sprintf "\"%s\"" o) :: params
226 | None -> params
227 in
228
229 let params = match qop_chosen with
230 | None -> params
231 | Some qop ->
232 let qop_str = match qop with `Auth -> "auth" | `Auth_int -> "auth-int" in
233 let nc_str = Printf.sprintf "%08x" nc in
234 ("qop", qop_str) ::
235 ("nc", nc_str) ::
236 ("cnonce", Printf.sprintf "\"%s\"" cnonce) ::
237 params
238 in
239
240 "Digest " ^ String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) params)
241
242(** Nonce counter storage - in production should be persistent *)
243module NonceCounter = struct
244 let table = Hashtbl.create 16
245
246 let get_and_increment ~nonce =
247 let current = try Hashtbl.find table nonce with Not_found -> 0 in
248 Hashtbl.replace table nonce (current + 1);
249 current + 1
250
251 let reset ~nonce =
252 Hashtbl.remove table nonce
253end
254
255(** Apply Digest authentication to a request *)
256let apply_digest_auth ~username ~password ~meth ~uri ~headers ~body ~challenge_header =
257 match parse_challenge challenge_header with
258 | None ->
259 Log.warn (fun m -> m "Failed to parse Digest challenge");
260 headers
261 | Some challenge ->
262 (* Choose QOP if server offers options *)
263 let qop_chosen = match challenge.qop with
264 | None -> None
265 | Some qops ->
266 (* Prefer auth over auth-int for simplicity *)
267 if List.mem `Auth qops then Some `Auth
268 else if List.mem `Auth_int qops then Some `Auth_int
269 else None
270 in
271
272 (* Get or generate client nonce *)
273 let cnonce = generate_cnonce () in
274
275 (* Get and increment nonce counter *)
276 let nc = NonceCounter.get_and_increment ~nonce:challenge.nonce in
277
278 let client_data = { username; password; nc; cnonce; qop_chosen } in
279 let auth_value = generate_auth_header ~challenge ~client_data ~meth ~uri ~body in
280
281 Cohttp.Header.add headers "Authorization" auth_value
282
283(** Check if a response requires digest auth *)
284let is_digest_challenge response =
285 let status = Cohttp.Response.status response in
286 match Cohttp.Code.code_of_status status with
287 | 401 ->
288 (match Cohttp.Header.get (Cohttp.Response.headers response) "www-authenticate" with
289 | Some header when String.starts_with ~prefix:"Digest" header -> Some header
290 | _ -> None)
291 | _ -> None