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
6(** HTTP Header Value Parsing
7
8 This module provides parsing and generation functions for complex HTTP header
9 values that go beyond simple strings.
10
11 @see <https://www.rfc-editor.org/rfc/rfc9110> RFC 9110: HTTP Semantics *)
12
13let src = Logs.Src.create "requests.header_parsing" ~doc:"HTTP Header Parsing"
14module Log = (val Logs.src_log src : Logs.LOG)
15
16(** {1 Content-Range (RFC 9110 Section 14.4)}
17
18 The Content-Range header indicates which part of a representation is
19 enclosed when a 206 (Partial Content) response is returned.
20
21 Format: [bytes start-end/complete-length] or [bytes */complete-length]
22
23 @see <https://www.rfc-editor.org/rfc/rfc9110#section-14.4> RFC 9110 Section 14.4 *)
24
25type content_range = {
26 unit : string;
27 (** The range unit, typically "bytes" *)
28 range : (int64 * int64) option;
29 (** The byte range (start, end) inclusive, or None for unsatisfied range *)
30 complete_length : int64 option;
31 (** The complete representation length, or None if unknown *)
32}
33
34let content_range_to_string cr =
35 let range_part = match cr.range with
36 | Some (start, end_) -> Printf.sprintf "%Ld-%Ld" start end_
37 | None -> "*"
38 in
39 let length_part = match cr.complete_length with
40 | Some len -> Int64.to_string len
41 | None -> "*"
42 in
43 Printf.sprintf "%s %s/%s" cr.unit range_part length_part
44
45let parse_content_range s =
46 let s = String.trim s in
47 (* Parse unit (e.g., "bytes") *)
48 match String.index_opt s ' ' with
49 | None ->
50 Log.debug (fun m -> m "Content-Range missing unit separator: %s" s);
51 None
52 | Some space_idx ->
53 let unit = String.sub s 0 space_idx in
54 let rest = String.sub s (space_idx + 1) (String.length s - space_idx - 1) in
55 (* Parse range/length *)
56 match String.index_opt rest '/' with
57 | None ->
58 Log.debug (fun m -> m "Content-Range missing range/length separator: %s" s);
59 None
60 | Some slash_idx ->
61 let range_part = String.sub rest 0 slash_idx in
62 let length_part = String.sub rest (slash_idx + 1) (String.length rest - slash_idx - 1) in
63 (* Parse range *)
64 let range =
65 if range_part = "*" then None
66 else match String.index_opt range_part '-' with
67 | None -> None
68 | Some dash_idx ->
69 let start_s = String.sub range_part 0 dash_idx in
70 let end_s = String.sub range_part (dash_idx + 1) (String.length range_part - dash_idx - 1) in
71 match Int64.of_string_opt start_s, Int64.of_string_opt end_s with
72 | Some start, Some end_ -> Some (start, end_)
73 | _ ->
74 Log.debug (fun m -> m "Content-Range invalid range numbers: %s" range_part);
75 None
76 in
77 (* Parse complete length *)
78 let complete_length =
79 if length_part = "*" then None
80 else Int64.of_string_opt length_part
81 in
82 Some { unit; range; complete_length }
83
84(** Create a Content-Range value for a byte range response.
85
86 @param start The first byte position (0-indexed)
87 @param end_ The last byte position (inclusive)
88 @param complete_length The total size of the representation *)
89let make_content_range ~start ~end_ ~complete_length =
90 { unit = "bytes"; range = Some (start, end_); complete_length = Some complete_length }
91
92(** Create a Content-Range value for an unsatisfied range (416 response).
93
94 @param complete_length The total size of the representation *)
95let make_unsatisfied_range ~complete_length =
96 { unit = "bytes"; range = None; complete_length = Some complete_length }
97
98(** {1 If-Range (RFC 9110 Section 13.1.5)}
99
100 The If-Range header makes a Range request conditional. It can contain
101 either an ETag or a Last-Modified date.
102
103 @see <https://www.rfc-editor.org/rfc/rfc9110#section-13.1.5> RFC 9110 Section 13.1.5 *)
104
105type if_range =
106 | If_range_etag of string
107 (** An entity tag (strong or weak) *)
108 | If_range_date of string
109 (** A Last-Modified date in HTTP-date format *)
110
111let if_range_to_string = function
112 | If_range_etag etag -> etag
113 | If_range_date date -> date
114
115(** Parse an If-Range header value.
116
117 Distinguishes between ETags (contain quotes or start with W/) and
118 HTTP-date values (start with a weekday abbreviation).
119
120 @see <https://www.rfc-editor.org/rfc/rfc9110#section-8.8.3> RFC 9110 Section 8.8.3 (ETag)
121 @see <https://www.rfc-editor.org/rfc/rfc9110#section-5.6.7> RFC 9110 Section 5.6.7 (HTTP-date) *)
122let parse_if_range s =
123 let s = String.trim s in
124 if String.length s = 0 then None
125 else
126 (* ETags are quoted strings or start with W/ for weak ETags *)
127 let is_etag =
128 (* Strong ETag: starts with quote *)
129 (String.length s >= 2 && s.[0] = '"') ||
130 (* Weak ETag: starts with W/ followed by quote *)
131 (String.length s >= 3 && s.[0] = 'W' && s.[1] = '/' && s.[2] = '"')
132 in
133 if is_etag then
134 Some (If_range_etag s)
135 else
136 (* HTTP-date starts with a weekday: Mon, Tue, Wed, Thu, Fri, Sat, Sun
137 or in obsolete formats: Monday, Tuesday, etc. *)
138 let weekdays = ["Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"; "Sun";
139 "Monday"; "Tuesday"; "Wednesday"; "Thursday"; "Friday"; "Saturday"; "Sunday"] in
140 let starts_with_weekday =
141 List.exists (fun day ->
142 String.length s >= String.length day &&
143 String.sub s 0 (String.length day) = day
144 ) weekdays
145 in
146 if starts_with_weekday then
147 Some (If_range_date s)
148 else
149 (* Ambiguous - treat as date if it contains digits typical of dates *)
150 if String.exists (fun c -> c >= '0' && c <= '9') s then
151 Some (If_range_date s)
152 else
153 (* Default to ETag for other values *)
154 Some (If_range_etag s)
155
156(** Create an If-Range value from an ETag. *)
157let if_range_of_etag etag = If_range_etag etag
158
159(** Create an If-Range value from a Last-Modified date string. *)
160let if_range_of_date date = If_range_date date
161
162(** Check if an If-Range value is an ETag. *)
163let if_range_is_etag = function
164 | If_range_etag _ -> true
165 | If_range_date _ -> false
166
167(** Check if an If-Range value is a date. *)
168let if_range_is_date = function
169 | If_range_date _ -> true
170 | If_range_etag _ -> false
171
172(** {1 Allow (RFC 9110 Section 10.2.1)}
173
174 The Allow header lists the set of methods supported by the target resource.
175
176 @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.1> RFC 9110 Section 10.2.1 *)
177
178(** Parse an Allow header value into a list of methods.
179
180 The Allow header is a comma-separated list of HTTP method names.
181 Example: "GET, HEAD, PUT" *)
182let parse_allow s =
183 String.split_on_char ',' s
184 |> List.map String.trim
185 |> List.filter (fun s -> String.length s > 0)
186 |> List.map Method.of_string
187
188(** Format a list of methods as an Allow header value. *)
189let allow_to_string methods =
190 methods
191 |> List.map Method.to_string
192 |> String.concat ", "
193
194(** Check if a method is in an Allow header value. *)
195let allow_contains method_ allow_value =
196 let methods = parse_allow allow_value in
197 List.exists (Method.equal method_) methods
198
199(** {1 Authentication-Info (RFC 9110 Section 11.6.3)}
200
201 The Authentication-Info header is sent by the server after successful
202 authentication. For Digest authentication, it provides a new nonce for
203 subsequent requests (avoiding 401 round-trips) and response authentication.
204
205 @see <https://www.rfc-editor.org/rfc/rfc9110#section-11.6.3> RFC 9110 Section 11.6.3 *)
206
207type authentication_info = {
208 nextnonce : string option;
209 (** Next nonce to use for subsequent requests *)
210 qop : string option;
211 (** Quality of protection that was used *)
212 rspauth : string option;
213 (** Response authentication (server proves it knows the password) *)
214 cnonce : string option;
215 (** Client nonce echoed back *)
216 nc : string option;
217 (** Nonce count echoed back *)
218}
219
220(** Parse an Authentication-Info header value.
221
222 Format is comma-separated key=value or key="value" pairs.
223 Example: [nextnonce="abc123", qop=auth, rspauth="xyz789"] *)
224let parse_authentication_info s =
225 let pairs =
226 let rec parse_pairs acc str =
227 let str = String.trim str in
228 if str = "" then List.rev acc
229 else
230 match String.index_opt str '=' with
231 | None -> List.rev acc
232 | Some eq_idx ->
233 let key = String.trim (String.sub str 0 eq_idx) in
234 let rest = String.sub str (eq_idx + 1) (String.length str - eq_idx - 1) in
235 let rest = String.trim rest in
236 let value, remaining =
237 if String.length rest > 0 && rest.[0] = '"' then
238 (* Quoted value *)
239 match String.index_from_opt rest 1 '"' with
240 | Some end_quote ->
241 let v = String.sub rest 1 (end_quote - 1) in
242 let rem = String.sub rest (end_quote + 1) (String.length rest - end_quote - 1) in
243 let rem = String.trim rem in
244 let rem = if String.length rem > 0 && rem.[0] = ',' then
245 String.sub rem 1 (String.length rem - 1)
246 else rem in
247 (v, rem)
248 | None -> (rest, "")
249 else
250 (* Unquoted value *)
251 match String.index_opt rest ',' with
252 | Some comma ->
253 let v = String.trim (String.sub rest 0 comma) in
254 let rem = String.sub rest (comma + 1) (String.length rest - comma - 1) in
255 (v, rem)
256 | None -> (String.trim rest, "")
257 in
258 parse_pairs ((String.lowercase_ascii key, value) :: acc) remaining
259 in
260 parse_pairs [] s
261 in
262 {
263 nextnonce = List.assoc_opt "nextnonce" pairs;
264 qop = List.assoc_opt "qop" pairs;
265 rspauth = List.assoc_opt "rspauth" pairs;
266 cnonce = List.assoc_opt "cnonce" pairs;
267 nc = List.assoc_opt "nc" pairs;
268 }
269
270(** Check if the Authentication-Info contains a new nonce.
271
272 If present, the client should use this nonce for subsequent requests
273 instead of waiting for a 401 response with a new challenge. *)
274let has_nextnonce info = Option.is_some info.nextnonce
275
276(** Get the next nonce from Authentication-Info, if present. *)
277let get_nextnonce info = info.nextnonce
278
279(** {1 Retry-After (RFC 9110 Section 10.2.3)}
280
281 The Retry-After header indicates how long to wait before retrying.
282 It can be either a date or a number of seconds.
283
284 @see <https://www.rfc-editor.org/rfc/rfc9110#section-10.2.3> RFC 9110 Section 10.2.3 *)
285
286type retry_after =
287 | Retry_after_date of string
288 (** An HTTP-date when the resource will be available *)
289 | Retry_after_seconds of int
290 (** Number of seconds to wait before retrying *)
291
292(** Parse a Retry-After header value. *)
293let parse_retry_after s =
294 let s = String.trim s in
295 match int_of_string_opt s with
296 | Some seconds -> Some (Retry_after_seconds seconds)
297 | None ->
298 (* Not a number, must be a date *)
299 if String.length s > 0 then
300 Some (Retry_after_date s)
301 else
302 None
303
304(** Convert a Retry-After value to a delay in seconds.
305
306 For date values, this requires the current time to compute the difference.
307 Returns None if the date cannot be parsed. Returns 0 if the date is in the past.
308
309 Per {{:https://datatracker.ietf.org/doc/html/rfc9110#section-10.2.3}RFC 9110 Section 10.2.3}:
310 "A delay-seconds value is a non-negative decimal integer, representing
311 time in seconds."
312
313 @param now The current time as a Unix timestamp *)
314let retry_after_to_seconds ?now retry_after =
315 match retry_after with
316 | Retry_after_seconds s -> Some s
317 | Retry_after_date date_str ->
318 match now with
319 | None ->
320 Log.debug (fun m -> m "Retry-After date requires 'now' parameter: %s" date_str);
321 None
322 | Some now_ts ->
323 match Http_date.parse date_str with
324 | None ->
325 Log.debug (fun m -> m "Failed to parse Retry-After HTTP-date: %s" date_str);
326 None
327 | Some ptime ->
328 let date_ts = Ptime.to_float_s ptime in
329 let diff = date_ts -. now_ts in
330 (* Clamp to 0 if date is in the past *)
331 Some (max 0 (int_of_float diff))
332
333(** {1 Accept-Ranges (RFC 9110 Section 14.3)}
334
335 The Accept-Ranges header indicates whether the server supports range requests.
336
337 @see <https://www.rfc-editor.org/rfc/rfc9110#section-14.3> RFC 9110 Section 14.3 *)
338
339type accept_ranges =
340 | Accept_ranges_bytes
341 (** Server supports byte range requests *)
342 | Accept_ranges_none
343 (** Server does not support range requests *)
344 | Accept_ranges_other of string
345 (** Server supports some other range unit *)
346
347(** Parse an Accept-Ranges header value. *)
348let parse_accept_ranges s =
349 match String.lowercase_ascii (String.trim s) with
350 | "bytes" -> Accept_ranges_bytes
351 | "none" -> Accept_ranges_none
352 | other -> Accept_ranges_other other
353
354(** Check if the server supports byte range requests. *)
355let supports_byte_ranges = function
356 | Accept_ranges_bytes -> true
357 | Accept_ranges_none | Accept_ranges_other _ -> false
358
359(** {1 Cache-Status (RFC 9211)}
360
361 The Cache-Status header field indicates how caches have handled a request.
362 It is a List structured field (RFC 8941) where each member is a cache
363 identifier with optional parameters.
364
365 @see <https://www.rfc-editor.org/rfc/rfc9211> RFC 9211: The Cache-Status HTTP Response Header Field *)
366
367(** Forward/stored response indicator for Cache-Status *)
368type cache_status_fwd =
369 | Fwd_uri_miss
370 (** The cache did not contain any matching response *)
371 | Fwd_vary_miss
372 (** The cache contained a response, but Vary header prevented match *)
373 | Fwd_miss
374 (** The cache did not find a usable response (generic) *)
375 | Fwd_request
376 (** The request semantics required forwarding (e.g., no-cache) *)
377 | Fwd_stale
378 (** The cache had a stale response that needed revalidation *)
379 | Fwd_partial
380 (** The cache had a partial response that needed completion *)
381 | Fwd_bypass
382 (** The cache was configured to bypass for this request *)
383 | Fwd_other of string
384 (** Other forward reason *)
385
386(** A single cache status entry from the Cache-Status header *)
387type cache_status_entry = {
388 cache_id : string;
389 (** Identifier for the cache (e.g., "CDN", "proxy", "Cloudflare") *)
390 hit : bool option;
391 (** True if served from cache without forwarding *)
392 fwd : cache_status_fwd option;
393 (** Why the request was forwarded *)
394 fwd_status : int option;
395 (** Status code from the forwarded response *)
396 stored : bool option;
397 (** Whether the response was stored in cache *)
398 collapsed : bool option;
399 (** Whether request was collapsed with others *)
400 ttl : int option;
401 (** Time-to-live remaining in seconds *)
402 key : string option;
403 (** Cache key used *)
404 detail : string option;
405 (** Implementation-specific detail *)
406}
407
408let cache_status_fwd_of_string = function
409 | "uri-miss" -> Fwd_uri_miss
410 | "vary-miss" -> Fwd_vary_miss
411 | "miss" -> Fwd_miss
412 | "request" -> Fwd_request
413 | "stale" -> Fwd_stale
414 | "partial" -> Fwd_partial
415 | "bypass" -> Fwd_bypass
416 | other -> Fwd_other other
417
418let cache_status_fwd_to_string = function
419 | Fwd_uri_miss -> "uri-miss"
420 | Fwd_vary_miss -> "vary-miss"
421 | Fwd_miss -> "miss"
422 | Fwd_request -> "request"
423 | Fwd_stale -> "stale"
424 | Fwd_partial -> "partial"
425 | Fwd_bypass -> "bypass"
426 | Fwd_other s -> s
427
428(** Parse a single Cache-Status entry.
429 Format: cache-id; param1; param2=value; param3="quoted" *)
430let parse_cache_status_entry s =
431 let s = String.trim s in
432 let parts = String.split_on_char ';' s in
433 match parts with
434 | [] -> None
435 | cache_id_part :: params ->
436 let cache_id = String.trim cache_id_part in
437 if cache_id = "" then None
438 else
439 let parse_param acc p =
440 let p = String.trim p in
441 match String.index_opt p '=' with
442 | None ->
443 (* Boolean parameter (presence = true) *)
444 (String.lowercase_ascii p, "?1") :: acc
445 | Some eq_idx ->
446 let key = String.trim (String.sub p 0 eq_idx) in
447 let value = String.trim (String.sub p (eq_idx + 1) (String.length p - eq_idx - 1)) in
448 (* Remove quotes if present *)
449 let value =
450 if String.length value >= 2 && value.[0] = '"' && value.[String.length value - 1] = '"' then
451 String.sub value 1 (String.length value - 2)
452 else value
453 in
454 (String.lowercase_ascii key, value) :: acc
455 in
456 let param_list = List.fold_left parse_param [] params in
457 let get_bool key =
458 match List.assoc_opt key param_list with
459 | Some "?1" | Some "true" | Some "1" -> Some true
460 | Some "?0" | Some "false" | Some "0" -> Some false
461 | _ -> None
462 in
463 let get_int key =
464 match List.assoc_opt key param_list with
465 | Some v -> int_of_string_opt v
466 | None -> None
467 in
468 let get_string key = List.assoc_opt key param_list in
469 Some {
470 cache_id;
471 hit = get_bool "hit";
472 fwd = Option.map cache_status_fwd_of_string (get_string "fwd");
473 fwd_status = get_int "fwd-status";
474 stored = get_bool "stored";
475 collapsed = get_bool "collapsed";
476 ttl = get_int "ttl";
477 key = get_string "key";
478 detail = get_string "detail";
479 }
480
481(** Parse a Cache-Status header value into a list of entries.
482 Multiple caches are separated by commas, with the response generator first. *)
483let parse_cache_status s =
484 String.split_on_char ',' s
485 |> List.filter_map parse_cache_status_entry
486
487(** Format a Cache-Status entry as a string. *)
488let cache_status_entry_to_string entry =
489 let params = [] in
490 let params = match entry.detail with Some v -> ("detail", Printf.sprintf "\"%s\"" v) :: params | None -> params in
491 let params = match entry.key with Some v -> ("key", Printf.sprintf "\"%s\"" v) :: params | None -> params in
492 let params = match entry.ttl with Some v -> ("ttl", string_of_int v) :: params | None -> params in
493 let params = match entry.collapsed with Some true -> ("collapsed", "") :: params | _ -> params in
494 let params = match entry.stored with Some true -> ("stored", "") :: params | _ -> params in
495 let params = match entry.fwd_status with Some v -> ("fwd-status", string_of_int v) :: params | None -> params in
496 let params = match entry.fwd with Some v -> ("fwd", cache_status_fwd_to_string v) :: params | None -> params in
497 let params = match entry.hit with Some true -> ("hit", "") :: params | _ -> params in
498 let param_strs = List.map (fun (k, v) ->
499 if v = "" then k else k ^ "=" ^ v
500 ) params in
501 match param_strs with
502 | [] -> entry.cache_id
503 | _ -> entry.cache_id ^ "; " ^ String.concat "; " param_strs
504
505(** Format a list of Cache-Status entries as a header value. *)
506let cache_status_to_string entries =
507 String.concat ", " (List.map cache_status_entry_to_string entries)
508
509(** Check if any cache reported a hit. *)
510let cache_status_is_hit entries =
511 List.exists (fun e -> e.hit = Some true) entries
512
513(** Check if the response was stored by any cache. *)
514let cache_status_is_stored entries =
515 List.exists (fun e -> e.stored = Some true) entries
516
517(** Get the forward reason from the first cache that forwarded. *)
518let cache_status_get_fwd entries =
519 List.find_map (fun e -> e.fwd) entries
520
521(** {1 Content-Digest / Repr-Digest (RFC 9530)}
522
523 Content-Digest contains a digest of the content (after content coding).
524 Repr-Digest contains a digest of the representation (before content coding).
525
526 Format: algorithm=:base64-digest:, algorithm=:base64-digest:
527
528 @see <https://www.rfc-editor.org/rfc/rfc9530> RFC 9530: Digest Fields *)
529
530(** Supported digest algorithms *)
531type digest_algorithm =
532 | Sha256
533 (** SHA-256 (recommended) *)
534 | Sha512
535 (** SHA-512 *)
536 | Other of string
537 (** Other algorithm (for forward compatibility) *)
538
539let digest_algorithm_of_string s =
540 match String.lowercase_ascii s with
541 | "sha-256" -> Sha256
542 | "sha-512" -> Sha512
543 | other -> Other other
544
545let digest_algorithm_to_string = function
546 | Sha256 -> "sha-256"
547 | Sha512 -> "sha-512"
548 | Other s -> s
549
550(** A single digest value with its algorithm *)
551type digest_value = {
552 algorithm : digest_algorithm;
553 (** The hash algorithm used *)
554 digest : string;
555 (** The base64-encoded digest value *)
556}
557
558(** Parse a Content-Digest or Repr-Digest header value.
559 Format: sha-256=:base64data:, sha-512=:base64data: *)
560let parse_digest_header s =
561 String.split_on_char ',' s
562 |> List.filter_map (fun part ->
563 let part = String.trim part in
564 match String.index_opt part '=' with
565 | None -> None
566 | Some eq_idx ->
567 let algo = String.trim (String.sub part 0 eq_idx) in
568 let value = String.trim (String.sub part (eq_idx + 1) (String.length part - eq_idx - 1)) in
569 (* RFC 9530 uses :base64: format for byte sequences *)
570 let digest =
571 if String.length value >= 2 && value.[0] = ':' && value.[String.length value - 1] = ':' then
572 String.sub value 1 (String.length value - 2)
573 else value
574 in
575 Some { algorithm = digest_algorithm_of_string algo; digest }
576 )
577
578(** Format a digest value as a string. *)
579let digest_value_to_string dv =
580 Printf.sprintf "%s=:%s:" (digest_algorithm_to_string dv.algorithm) dv.digest
581
582(** Format a list of digest values as a header value. *)
583let digest_header_to_string digests =
584 String.concat ", " (List.map digest_value_to_string digests)
585
586(** Compute the SHA-256 digest of content and return base64-encoded result. *)
587let compute_sha256 content =
588 let hash = Digestif.SHA256.digest_string content in
589 Base64.encode_string (Digestif.SHA256.to_raw_string hash)
590
591(** Compute the SHA-512 digest of content and return base64-encoded result. *)
592let compute_sha512 content =
593 let hash = Digestif.SHA512.digest_string content in
594 Base64.encode_string (Digestif.SHA512.to_raw_string hash)
595
596(** Compute a digest for content using the specified algorithm. *)
597let compute_digest ~algorithm content =
598 let digest = match algorithm with
599 | Sha256 -> compute_sha256 content
600 | Sha512 -> compute_sha512 content
601 | Other _ ->
602 Log.warn (fun m -> m "Unsupported digest algorithm, using SHA-256");
603 compute_sha256 content
604 in
605 { algorithm; digest }
606
607(** Create a Content-Digest header value for content.
608 Defaults to SHA-256 which is recommended by RFC 9530. *)
609let make_content_digest ?(algorithm = Sha256) content =
610 compute_digest ~algorithm content
611
612(** Validate that a digest matches the content.
613 Returns true if any of the provided digests matches. *)
614let validate_digest ~digests content =
615 List.exists (fun dv ->
616 let computed = compute_digest ~algorithm:dv.algorithm content in
617 computed.digest = dv.digest
618 ) digests
619
620(** Get the strongest available digest (prefer SHA-512 over SHA-256). *)
621let get_strongest_digest digests =
622 let sha512 = List.find_opt (fun d -> d.algorithm = Sha512) digests in
623 let sha256 = List.find_opt (fun d -> d.algorithm = Sha256) digests in
624 match sha512, sha256 with
625 | Some d, _ -> Some d
626 | None, Some d -> Some d
627 | None, None -> List.nth_opt digests 0
628
629(** {1 Strict-Transport-Security (RFC 6797)}
630
631 The Strict-Transport-Security (HSTS) header tells browsers to only
632 access the site over HTTPS.
633
634 @see <https://www.rfc-editor.org/rfc/rfc6797> RFC 6797: HTTP Strict Transport Security *)
635
636(** HSTS directive values *)
637type hsts = {
638 max_age : int64;
639 (** Required: Time in seconds the browser should remember HTTPS-only *)
640 include_subdomains : bool;
641 (** If true, policy applies to all subdomains *)
642 preload : bool;
643 (** If true, site requests inclusion in browser preload lists *)
644}
645
646(** Parse a Strict-Transport-Security header value.
647 Format: max-age=31536000; includeSubDomains; preload *)
648let parse_hsts s =
649 let directives =
650 String.split_on_char ';' s
651 |> List.map String.trim
652 |> List.filter (fun s -> String.length s > 0)
653 in
654 let max_age = ref None in
655 let include_subdomains = ref false in
656 let preload = ref false in
657 List.iter (fun directive ->
658 let directive_lower = String.lowercase_ascii directive in
659 if String.length directive_lower >= 8 &&
660 String.sub directive_lower 0 8 = "max-age=" then begin
661 let value_str = String.sub directive 8 (String.length directive - 8) in
662 max_age := Int64.of_string_opt (String.trim value_str)
663 end
664 else if directive_lower = "includesubdomains" then
665 include_subdomains := true
666 else if directive_lower = "preload" then
667 preload := true
668 else
669 Log.debug (fun m -> m "Unknown HSTS directive: %s" directive)
670 ) directives;
671 match !max_age with
672 | Some age -> Some {
673 max_age = age;
674 include_subdomains = !include_subdomains;
675 preload = !preload;
676 }
677 | None ->
678 Log.debug (fun m -> m "HSTS header missing required max-age directive");
679 None
680
681(** Format an HSTS value as a header string. *)
682let hsts_to_string hsts =
683 let parts = [Printf.sprintf "max-age=%Ld" hsts.max_age] in
684 let parts = if hsts.include_subdomains then parts @ ["includeSubDomains"] else parts in
685 let parts = if hsts.preload then parts @ ["preload"] else parts in
686 String.concat "; " parts
687
688(** Create an HSTS header value.
689 @param max_age Time in seconds (default: 1 year = 31536000)
690 @param include_subdomains Apply to subdomains (default: false)
691 @param preload Request preload list inclusion (default: false) *)
692let make_hsts ?(max_age = 31536000L) ?(include_subdomains = false) ?(preload = false) () =
693 { max_age; include_subdomains; preload }
694
695(** Check if HSTS is effectively enabled (max-age > 0). *)
696let hsts_is_enabled hsts = hsts.max_age > 0L
697
698(** Common HSTS configurations *)
699
700(** One year with subdomains - recommended for production *)
701let hsts_one_year_subdomains = { max_age = 31536000L; include_subdomains = true; preload = false }
702
703(** Two years with subdomains and preload - for HSTS preload submission *)
704let hsts_preload = { max_age = 63072000L; include_subdomains = true; preload = true }
705
706(** Disable HSTS by setting max-age to 0 *)
707let hsts_disable = { max_age = 0L; include_subdomains = false; preload = false }