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.headers" ~doc:"HTTP Headers"
7module Log = (val Logs.src_log src : Logs.LOG)
8
9(* Use a map with lowercase keys for case-insensitive lookup *)
10module StringMap = Map.Make(String)
11
12(** The internal representation stores: (canonical_name, values) *)
13type t = (string * string list) StringMap.t
14
15let empty = StringMap.empty
16
17(** {1 Header Injection Prevention}
18
19 Per Recommendation #3: Validate that header names and values do not contain
20 newlines (CR/LF) which could enable HTTP request smuggling attacks.
21
22 Note: We use Invalid_argument here to avoid a dependency cycle with Error module.
23 The error will be caught and wrapped appropriately by higher-level code. *)
24
25exception Invalid_header of { name: string; reason: string }
26
27(** {1 Basic Auth Credential Validation}
28
29 Per RFC 7617 Section 2:
30 - Username must not contain a colon character
31 - Neither username nor password may contain control characters (0x00-0x1F, 0x7F) *)
32
33exception Invalid_basic_auth of { reason: string }
34
35let contains_control_chars s =
36 String.exists (fun c ->
37 let code = Char.code c in
38 code <= 0x1F || code = 0x7F
39 ) s
40
41let validate_basic_auth_credentials ~username ~password =
42 (* RFC 7617 Section 2: "a user-id containing a colon character is invalid" *)
43 if String.contains username ':' then
44 raise (Invalid_basic_auth {
45 reason = "Username contains colon character (RFC 7617 Section 2)"
46 });
47 (* RFC 7617 Section 2: "The user-id and password MUST NOT contain any control characters" *)
48 if contains_control_chars username then
49 raise (Invalid_basic_auth {
50 reason = "Username contains control characters (RFC 7617 Section 2)"
51 });
52 if contains_control_chars password then
53 raise (Invalid_basic_auth {
54 reason = "Password contains control characters (RFC 7617 Section 2)"
55 })
56
57let validate_header_name_str name =
58 if String.contains name '\r' || String.contains name '\n' then
59 raise (Invalid_header {
60 name;
61 reason = "Header name contains CR/LF characters (potential HTTP smuggling)"
62 })
63
64let validate_header_value name value =
65 if String.contains value '\r' || String.contains value '\n' then
66 raise (Invalid_header {
67 name;
68 reason = "Header value contains CR/LF characters (potential HTTP smuggling)"
69 })
70
71(** {1 Core Operations with Typed Header Names} *)
72
73let add (name : Header_name.t) value t =
74 let canonical = Header_name.to_string name in
75 let nkey = Header_name.to_lowercase_string name in
76 validate_header_value canonical value;
77 let existing =
78 match StringMap.find_opt nkey t with
79 | Some (_, values) -> values
80 | None -> []
81 in
82 (* Append to maintain order, avoiding reversal on retrieval *)
83 StringMap.add nkey (canonical, existing @ [value]) t
84
85let set (name : Header_name.t) value t =
86 let canonical = Header_name.to_string name in
87 let nkey = Header_name.to_lowercase_string name in
88 validate_header_value canonical value;
89 StringMap.add nkey (canonical, [value]) t
90
91let get (name : Header_name.t) t =
92 let nkey = Header_name.to_lowercase_string name in
93 match StringMap.find_opt nkey t with
94 | Some (_, values) -> List.nth_opt values 0
95 | None -> None
96
97let get_all (name : Header_name.t) t =
98 let nkey = Header_name.to_lowercase_string name in
99 match StringMap.find_opt nkey t with
100 | Some (_, values) -> values
101 | None -> []
102
103let remove (name : Header_name.t) t =
104 let nkey = Header_name.to_lowercase_string name in
105 StringMap.remove nkey t
106
107let mem (name : Header_name.t) t =
108 let nkey = Header_name.to_lowercase_string name in
109 StringMap.mem nkey t
110
111(** {1 String-based Operations for Wire Format Compatibility}
112
113 These are used internally when parsing HTTP messages from the wire,
114 where header names come as strings. *)
115
116let add_string key value t =
117 validate_header_name_str key;
118 validate_header_value key value;
119 let nkey = String.lowercase_ascii key in
120 let existing =
121 match StringMap.find_opt nkey t with
122 | Some (_, values) -> values
123 | None -> []
124 in
125 StringMap.add nkey (key, existing @ [value]) t
126
127let set_string key value t =
128 validate_header_name_str key;
129 validate_header_value key value;
130 let nkey = String.lowercase_ascii key in
131 StringMap.add nkey (key, [value]) t
132
133let get_string key t =
134 let nkey = String.lowercase_ascii key in
135 match StringMap.find_opt nkey t with
136 | Some (_, values) -> List.nth_opt values 0
137 | None -> None
138
139let get_all_string key t =
140 let nkey = String.lowercase_ascii key in
141 match StringMap.find_opt nkey t with
142 | Some (_, values) -> values
143 | None -> []
144
145let remove_string key t =
146 let nkey = String.lowercase_ascii key in
147 StringMap.remove nkey t
148
149let mem_string key t =
150 let nkey = String.lowercase_ascii key in
151 StringMap.mem nkey t
152
153(** {1 Conversion} *)
154
155let of_list lst =
156 List.fold_left (fun acc (k, v) -> add_string k v acc) empty lst
157
158let to_list t =
159 StringMap.fold (fun _ (orig_key, values) acc ->
160 (* Values are already in correct order, build list in reverse then reverse at end *)
161 List.fold_left (fun acc v -> (orig_key, v) :: acc) acc values
162 ) t []
163 |> List.rev
164
165let merge t1 t2 =
166 StringMap.union (fun _ _ v2 -> Some v2) t1 t2
167
168(** {1 Common Header Builders} *)
169
170let content_type mime t =
171 set `Content_type (Mime.to_string mime) t
172
173let content_length len t =
174 set `Content_length (Int64.to_string len) t
175
176let accept mime t =
177 set `Accept (Mime.to_string mime) t
178
179let accept_language lang t =
180 set `Accept_language lang t
181
182let authorization value t =
183 set `Authorization value t
184
185let bearer token t =
186 set `Authorization (Printf.sprintf "Bearer %s" token) t
187
188let basic ~username ~password t =
189 validate_basic_auth_credentials ~username ~password;
190 let credentials = Printf.sprintf "%s:%s" username password in
191 let encoded = Base64.encode_exn credentials in
192 set `Authorization (Printf.sprintf "Basic %s" encoded) t
193
194let user_agent ua t =
195 set `User_agent ua t
196
197let host h t =
198 set `Host h t
199
200let cookie name value t =
201 add `Cookie (Printf.sprintf "%s=%s" name value) t
202
203let range ~start ?end_ () t =
204 let range_value = match end_ with
205 | None -> Printf.sprintf "bytes=%Ld-" start
206 | Some e -> Printf.sprintf "bytes=%Ld-%Ld" start e
207 in
208 set `Range range_value t
209
210(** {1 HTTP 100-Continue Support}
211
212 Per Recommendation #7: Expect: 100-continue protocol for large uploads.
213 RFC 9110 Section 10.1.1 (Expect) *)
214
215let expect value t =
216 set `Expect value t
217
218let expect_100_continue t =
219 set `Expect "100-continue" t
220
221(** {1 TE Header Support}
222
223 Per RFC 9110 Section 10.1.4: The TE header indicates what transfer codings
224 the client is willing to accept in the response, and whether the client is
225 willing to accept trailer fields in a chunked transfer coding. *)
226
227let te value t =
228 set `Te value t
229
230let te_trailers t =
231 set `Te "trailers" t
232
233(** {1 Cache Control Headers}
234
235 Per Recommendation #17 and #19: Response caching and conditional requests.
236 RFC 9111 (HTTP Caching), RFC 9110 Section 8.8.2-8.8.3 (Last-Modified, ETag) *)
237
238let if_none_match etag t =
239 set `If_none_match etag t
240
241let if_match etag t =
242 set `If_match etag t
243
244let if_modified_since date t =
245 set `If_modified_since date t
246
247let if_unmodified_since date t =
248 set `If_unmodified_since date t
249
250(** Format a Ptime.t as an HTTP-date (RFC 9110 Section 5.6.7) *)
251let http_date_of_ptime time =
252 (* HTTP-date format: "Sun, 06 Nov 1994 08:49:37 GMT" *)
253 let (year, month, day), ((hour, min, sec), _tz_offset) = Ptime.to_date_time time in
254 let weekday = match Ptime.weekday time with
255 | `Sun -> "Sun" | `Mon -> "Mon" | `Tue -> "Tue" | `Wed -> "Wed"
256 | `Thu -> "Thu" | `Fri -> "Fri" | `Sat -> "Sat"
257 in
258 let month_name = [| ""; "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun";
259 "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |].(month) in
260 Printf.sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT"
261 weekday day month_name year hour min sec
262
263let if_modified_since_ptime time t =
264 if_modified_since (http_date_of_ptime time) t
265
266let if_unmodified_since_ptime time t =
267 if_unmodified_since (http_date_of_ptime time) t
268
269let cache_control directives t =
270 set `Cache_control directives t
271
272(** Build Cache-Control header from common directive components.
273 For max_stale: [None] = not present, [Some None] = any staleness, [Some (Some n)] = n seconds *)
274let cache_control_directives
275 : ?max_age:int ->
276 ?max_stale:int option option ->
277 ?min_fresh:int ->
278 ?no_cache:bool ->
279 ?no_store:bool ->
280 ?no_transform:bool ->
281 ?only_if_cached:bool ->
282 unit -> t -> t
283 = fun
284 ?max_age
285 ?max_stale
286 ?min_fresh
287 ?(no_cache = false)
288 ?(no_store = false)
289 ?(no_transform = false)
290 ?(only_if_cached = false)
291 () t ->
292 let directives = [] in
293 let directives = match max_age with
294 | Some age -> Printf.sprintf "max-age=%d" age :: directives
295 | None -> directives
296 in
297 let directives = match max_stale with
298 | Some (Some None) -> "max-stale" :: directives
299 | Some (Some (Some secs)) -> Printf.sprintf "max-stale=%d" secs :: directives
300 | Some None | None -> directives
301 in
302 let directives = match min_fresh with
303 | Some secs -> Printf.sprintf "min-fresh=%d" secs :: directives
304 | None -> directives
305 in
306 let directives = if no_cache then "no-cache" :: directives else directives in
307 let directives = if no_store then "no-store" :: directives else directives in
308 let directives = if no_transform then "no-transform" :: directives else directives in
309 let directives = if only_if_cached then "only-if-cached" :: directives else directives in
310 match directives with
311 | [] -> t
312 | _ -> set `Cache_control (String.concat ", " (List.rev directives)) t
313
314let etag value t =
315 set `Etag value t
316
317let last_modified date t =
318 set `Last_modified date t
319
320let last_modified_ptime time t =
321 last_modified (http_date_of_ptime time) t
322
323(* Additional helper for getting multiple header values *)
324let get_multi name t = get_all name t
325
326(** {1 Connection Header Handling}
327
328 Per RFC 9110 Section 7.6.1: The Connection header field lists hop-by-hop
329 header fields that MUST be removed before forwarding the message. *)
330
331(** Parse Connection header value into list of header names.
332 The Connection header lists additional hop-by-hop headers. *)
333let parse_connection_header t =
334 match get `Connection t with
335 | None -> []
336 | Some value ->
337 String.split_on_char ',' value
338 |> List.map (fun s -> Header_name.of_string (String.trim s))
339 |> List.filter (fun n -> not (Header_name.equal n (`Other "")))
340
341(** Get all hop-by-hop headers from a response.
342 Returns the union of default hop-by-hop headers and any headers
343 listed in the Connection header. *)
344let get_hop_by_hop_headers t =
345 let connection_headers = parse_connection_header t in
346 Header_name.hop_by_hop_headers @ connection_headers
347 |> List.sort_uniq Header_name.compare
348
349(** Remove hop-by-hop headers from a header collection.
350 This should be called before caching or forwarding a response.
351 Per RFC 9110 Section 7.6.1. *)
352let remove_hop_by_hop t =
353 let hop_by_hop = get_hop_by_hop_headers t in
354 List.fold_left (fun headers name -> remove name headers) t hop_by_hop
355
356(** Check if a response indicates the connection should be closed.
357 Returns true if Connection: close is present. *)
358let connection_close t =
359 match get `Connection t with
360 | Some value ->
361 String.split_on_char ',' value
362 |> List.exists (fun s -> String.trim (String.lowercase_ascii s) = "close")
363 | None -> false
364
365(** Check if a response indicates the connection should be kept alive.
366 Returns true if Connection: keep-alive is present (HTTP/1.0 behavior). *)
367let connection_keep_alive t =
368 match get `Connection t with
369 | Some value ->
370 String.split_on_char ',' value
371 |> List.exists (fun s -> String.trim (String.lowercase_ascii s) = "keep-alive")
372 | None -> false
373
374(* Pretty printer for headers *)
375let pp ppf t =
376 Format.fprintf ppf "@[<v>Headers:@,";
377 let headers = to_list t in
378 List.iter (fun (k, v) ->
379 Format.fprintf ppf " %s: %s@," k v
380 ) headers;
381 Format.fprintf ppf "@]"
382
383let pp_brief ppf t =
384 let headers = to_list t in
385 let count = List.length headers in
386 Format.fprintf ppf "Headers(%d entries)" count