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.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
12type t = (string * string list) StringMap.t
13
14let empty = StringMap.empty
15
16let normalize_key k = String.lowercase_ascii k
17
18(** {1 Header Injection Prevention}
19
20 Per Recommendation #3: Validate that header names and values do not contain
21 newlines (CR/LF) which could enable HTTP request smuggling attacks.
22
23 Note: We use Invalid_argument here to avoid a dependency cycle with Error module.
24 The error will be caught and wrapped appropriately by higher-level code. *)
25
26exception Invalid_header of { name: string; reason: string }
27
28let validate_header_name name =
29 if String.contains name '\r' || String.contains name '\n' then
30 raise (Invalid_header {
31 name;
32 reason = "Header name contains CR/LF characters (potential HTTP smuggling)"
33 })
34
35let validate_header_value name value =
36 if String.contains value '\r' || String.contains value '\n' then
37 raise (Invalid_header {
38 name;
39 reason = "Header value contains CR/LF characters (potential HTTP smuggling)"
40 })
41
42let add key value t =
43 validate_header_name key;
44 validate_header_value key value;
45 let nkey = normalize_key key in
46 let existing =
47 match StringMap.find_opt nkey t with
48 | Some (_, values) -> values
49 | None -> []
50 in
51 (* Append to maintain order, avoiding reversal on retrieval *)
52 StringMap.add nkey (key, existing @ [value]) t
53
54let set key value t =
55 validate_header_name key;
56 validate_header_value key value;
57 let nkey = normalize_key key in
58 StringMap.add nkey (key, [value]) t
59
60let get key t =
61 let nkey = normalize_key key in
62 match StringMap.find_opt nkey t with
63 | Some (_, values) -> List.nth_opt values 0
64 | None -> None
65
66let get_all key t =
67 let nkey = normalize_key key in
68 match StringMap.find_opt nkey t with
69 | Some (_, values) -> values
70 | None -> []
71
72let remove key t =
73 let nkey = normalize_key key in
74 StringMap.remove nkey t
75
76let mem key t =
77 let nkey = normalize_key key in
78 StringMap.mem nkey t
79
80let of_list lst =
81 List.fold_left (fun acc (k, v) -> add k v acc) empty lst
82
83let to_list t =
84 StringMap.fold (fun _ (orig_key, values) acc ->
85 (* Values are already in correct order, build list in reverse then reverse at end *)
86 List.fold_left (fun acc v -> (orig_key, v) :: acc) acc values
87 ) t []
88 |> List.rev
89
90let merge t1 t2 =
91 StringMap.union (fun _ _ v2 -> Some v2) t1 t2
92
93(* Common header builders *)
94
95let content_type mime t =
96 set "Content-Type" (Mime.to_string mime) t
97
98let content_length len t =
99 set "Content-Length" (Int64.to_string len) t
100
101let accept mime t =
102 set "Accept" (Mime.to_string mime) t
103
104let authorization value t =
105 set "Authorization" value t
106
107let bearer token t =
108 set "Authorization" (Printf.sprintf "Bearer %s" token) t
109
110let basic ~username ~password t =
111 let credentials = Printf.sprintf "%s:%s" username password in
112 let encoded = Base64.encode_exn credentials in
113 set "Authorization" (Printf.sprintf "Basic %s" encoded) t
114
115let user_agent ua t =
116 set "User-Agent" ua t
117
118let host h t =
119 set "Host" h t
120
121let cookie name value t =
122 add "Cookie" (Printf.sprintf "%s=%s" name value) t
123
124let range ~start ?end_ () t =
125 let range_value = match end_ with
126 | None -> Printf.sprintf "bytes=%Ld-" start
127 | Some e -> Printf.sprintf "bytes=%Ld-%Ld" start e
128 in
129 set "Range" range_value t
130
131(** {1 HTTP 100-Continue Support}
132
133 Per Recommendation #7: Expect: 100-continue protocol for large uploads.
134 RFC 9110 Section 10.1.1 (Expect) *)
135
136let expect value t =
137 set "Expect" value t
138
139let expect_100_continue t =
140 set "Expect" "100-continue" t
141
142(** {1 Cache Control Headers}
143
144 Per Recommendation #17 and #19: Response caching and conditional requests.
145 RFC 9111 (HTTP Caching), RFC 9110 Section 8.8.2-8.8.3 (Last-Modified, ETag) *)
146
147let if_none_match etag t =
148 set "If-None-Match" etag t
149
150let if_match etag t =
151 set "If-Match" etag t
152
153let if_modified_since date t =
154 set "If-Modified-Since" date t
155
156let if_unmodified_since date t =
157 set "If-Unmodified-Since" date t
158
159(** Format a Ptime.t as an HTTP-date (RFC 9110 Section 5.6.7) *)
160let http_date_of_ptime time =
161 (* HTTP-date format: "Sun, 06 Nov 1994 08:49:37 GMT" *)
162 let (year, month, day), ((hour, min, sec), _tz_offset) = Ptime.to_date_time time in
163 let weekday = match Ptime.weekday time with
164 | `Sun -> "Sun" | `Mon -> "Mon" | `Tue -> "Tue" | `Wed -> "Wed"
165 | `Thu -> "Thu" | `Fri -> "Fri" | `Sat -> "Sat"
166 in
167 let month_name = [| ""; "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun";
168 "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |].(month) in
169 Printf.sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT"
170 weekday day month_name year hour min sec
171
172let if_modified_since_ptime time t =
173 if_modified_since (http_date_of_ptime time) t
174
175let if_unmodified_since_ptime time t =
176 if_unmodified_since (http_date_of_ptime time) t
177
178let cache_control directives t =
179 set "Cache-Control" directives t
180
181(** Build Cache-Control header from common directive components.
182 For max_stale: [None] = not present, [Some None] = any staleness, [Some (Some n)] = n seconds *)
183let cache_control_directives
184 : ?max_age:int ->
185 ?max_stale:int option option ->
186 ?min_fresh:int ->
187 ?no_cache:bool ->
188 ?no_store:bool ->
189 ?no_transform:bool ->
190 ?only_if_cached:bool ->
191 unit -> t -> t
192 = fun
193 ?max_age
194 ?max_stale
195 ?min_fresh
196 ?(no_cache = false)
197 ?(no_store = false)
198 ?(no_transform = false)
199 ?(only_if_cached = false)
200 () t ->
201 let directives = [] in
202 let directives = match max_age with
203 | Some age -> Printf.sprintf "max-age=%d" age :: directives
204 | None -> directives
205 in
206 let directives = match max_stale with
207 | Some (Some None) -> "max-stale" :: directives
208 | Some (Some (Some secs)) -> Printf.sprintf "max-stale=%d" secs :: directives
209 | Some None | None -> directives
210 in
211 let directives = match min_fresh with
212 | Some secs -> Printf.sprintf "min-fresh=%d" secs :: directives
213 | None -> directives
214 in
215 let directives = if no_cache then "no-cache" :: directives else directives in
216 let directives = if no_store then "no-store" :: directives else directives in
217 let directives = if no_transform then "no-transform" :: directives else directives in
218 let directives = if only_if_cached then "only-if-cached" :: directives else directives in
219 match directives with
220 | [] -> t
221 | _ -> set "Cache-Control" (String.concat ", " (List.rev directives)) t
222
223let etag value t =
224 set "ETag" value t
225
226let last_modified date t =
227 set "Last-Modified" date t
228
229let last_modified_ptime time t =
230 last_modified (http_date_of_ptime time) t
231
232(* Additional helper for getting multiple header values *)
233let get_multi key t = get_all key t
234
235(* Pretty printer for headers *)
236let pp ppf t =
237 Format.fprintf ppf "@[<v>Headers:@,";
238 let headers = to_list t in
239 List.iter (fun (k, v) ->
240 Format.fprintf ppf " %s: %s@," k v
241 ) headers;
242 Format.fprintf ppf "@]"
243
244let pp_brief ppf t =
245 let headers = to_list t in
246 let count = List.length headers in
247 Format.fprintf ppf "Headers(%d entries)" count