jon.recoil.org
forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
anil.recoil.org
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6(** HTTP header field handling per {{:https://datatracker.ietf.org/doc/html/rfc9110#section-5}RFC 9110 Section 5}
7
8 This module provides an efficient implementation of HTTP headers with
9 case-insensitive field names per {{:https://datatracker.ietf.org/doc/html/rfc9110#section-5.1}RFC 9110 Section 5.1}.
10 Headers can have multiple values for the same field name (e.g., Set-Cookie).
11
12 {2 Type-Safe Header Names}
13
14 Header names use the {!Header_name.t} type, providing compile-time safety
15 for standard headers while allowing custom headers via [`Other]:
16
17 {[
18 let headers = Headers.empty
19 |> Headers.set `Content_type "application/json"
20 |> Headers.set `Authorization "Bearer token"
21 |> Headers.set (`Other "X-Custom") "value"
22 ]}
23
24 {2 Security}
25
26 Header names and values are validated to prevent HTTP header injection
27 attacks. CR and LF characters are rejected per
28 {{:https://datatracker.ietf.org/doc/html/rfc9110#section-5.5}RFC 9110 Section 5.5}.
29*)
30
31(** Log source for header operations *)
32val src : Logs.Src.t
33
34type t
35(** Abstract header collection type. Headers are stored with case-insensitive
36 keys and maintain insertion order. *)
37
38(** {1 Creation and Conversion} *)
39
40val empty : t
41(** [empty] creates an empty header collection. *)
42
43val of_list : (string * string) list -> t
44(** [of_list pairs] creates headers from an association list of string pairs.
45 This is useful when parsing headers from the wire format.
46 Later entries override earlier ones for the same key. *)
47
48val to_list : t -> (string * string) list
49(** [to_list headers] converts headers to an association list.
50 The order of headers is preserved. *)
51
52(** {1 Header Injection Prevention} *)
53
54exception Invalid_header of { name: string; reason: string }
55(** Raised when a header name or value contains invalid characters (CR/LF)
56 that could enable HTTP request smuggling attacks. *)
57
58exception Invalid_basic_auth of { reason: string }
59(** Raised when Basic auth credentials contain invalid characters.
60 Per {{:https://datatracker.ietf.org/doc/html/rfc7617#section-2}RFC 7617 Section 2}:
61 - Username must not contain colon characters
62 - Username and password must not contain control characters (0x00-0x1F, 0x7F) *)
63
64(** {1 Type-Safe Header Operations}
65
66 These functions use {!Header_name.t} for compile-time type safety. *)
67
68val add : Header_name.t -> string -> t -> t
69(** [add name value headers] adds a header value. Multiple values
70 for the same header name are allowed (e.g., for Set-Cookie).
71
72 @raise Invalid_header if the header value contains CR/LF characters
73 (to prevent HTTP header injection attacks). *)
74
75val set : Header_name.t -> string -> t -> t
76(** [set name value headers] sets a header value, replacing any
77 existing values for that header name.
78
79 @raise Invalid_header if the header value contains CR/LF characters
80 (to prevent HTTP header injection attacks). *)
81
82val get : Header_name.t -> t -> string option
83(** [get name headers] returns the first value for a header name,
84 or [None] if the header doesn't exist. *)
85
86val get_all : Header_name.t -> t -> string list
87(** [get_all name headers] returns all values for a header name.
88 Returns an empty list if the header doesn't exist. *)
89
90val remove : Header_name.t -> t -> t
91(** [remove name headers] removes all values for a header name. *)
92
93val mem : Header_name.t -> t -> bool
94(** [mem name headers] checks if a header name exists. *)
95
96(** {1 String-Based Header Operations}
97
98 These functions accept string header names for wire format compatibility.
99 Use these when parsing HTTP messages where header names arrive as strings. *)
100
101val add_string : string -> string -> t -> t
102(** [add_string name value headers] adds a header using a string name.
103 Use this when parsing headers from the wire.
104
105 @raise Invalid_header if the header name or value contains CR/LF characters. *)
106
107val set_string : string -> string -> t -> t
108(** [set_string name value headers] sets a header using a string name.
109
110 @raise Invalid_header if the header name or value contains CR/LF characters. *)
111
112val get_string : string -> t -> string option
113(** [get_string name headers] gets a header using a string name. *)
114
115val get_all_string : string -> t -> string list
116(** [get_all_string name headers] gets all values for a string header name. *)
117
118val remove_string : string -> t -> t
119(** [remove_string name headers] removes a header using a string name. *)
120
121val mem_string : string -> t -> bool
122(** [mem_string name headers] checks if a header exists using a string name. *)
123
124(** {1 Merging} *)
125
126val merge : t -> t -> t
127(** [merge base override] merges two header collections.
128 Headers from [override] replace those in [base]. *)
129
130(** {1 Common Header Builders}
131
132 Convenience functions for setting common HTTP headers.
133*)
134
135val content_type : Mime.t -> t -> t
136(** [content_type mime headers] sets the Content-Type header. *)
137
138val content_length : int64 -> t -> t
139(** [content_length length headers] sets the Content-Length header. *)
140
141val accept : Mime.t -> t -> t
142(** [accept mime headers] sets the Accept header. *)
143
144val accept_language : string -> t -> t
145(** [accept_language lang headers] sets the Accept-Language header.
146 Per {{:https://datatracker.ietf.org/doc/html/rfc9110#section-12.5.4}RFC 9110 Section 12.5.4}.
147
148 Examples:
149 {[
150 headers |> Headers.accept_language "en-US"
151 headers |> Headers.accept_language "en-US, en;q=0.9, de;q=0.8"
152 headers |> Headers.accept_language "*"
153 ]} *)
154
155val authorization : string -> t -> t
156(** [authorization value headers] sets the Authorization header with a raw value. *)
157
158val bearer : string -> t -> t
159(** [bearer token headers] sets the Authorization header with a Bearer token.
160 Example: [bearer "abc123"] sets ["Authorization: Bearer abc123"] *)
161
162val basic : username:string -> password:string -> t -> t
163(** [basic ~username ~password headers] sets the Authorization header with
164 HTTP Basic authentication (base64-encoded username:password).
165
166 @raise Invalid_basic_auth if the username contains a colon character or if
167 either username or password contains control characters (RFC 7617 Section 2). *)
168
169val user_agent : string -> t -> t
170(** [user_agent ua headers] sets the User-Agent header. *)
171
172val host : string -> t -> t
173(** [host hostname headers] sets the Host header. *)
174
175val cookie : string -> string -> t -> t
176(** [cookie name value headers] adds a cookie to the Cookie header.
177 Multiple cookies can be added by calling this function multiple times. *)
178
179val range : start:int64 -> ?end_:int64 -> unit -> t -> t
180(** [range ~start ?end_ () headers] sets the Range header for partial content.
181 Example: [range ~start:0L ~end_:999L ()] requests the first 1000 bytes. *)
182
183(** {1 HTTP 100-Continue Support}
184
185 Per Recommendation #7: Expect: 100-continue protocol for large uploads.
186 RFC 9110 Section 10.1.1 (Expect) *)
187
188val expect : string -> t -> t
189(** [expect value headers] sets the Expect header.
190 Example: [expect "100-continue"] for large request bodies. *)
191
192val expect_100_continue : t -> t
193(** [expect_100_continue headers] sets [Expect: 100-continue].
194 Use this for large uploads to allow the server to reject the request
195 before the body is sent, saving bandwidth. *)
196
197(** {1 TE Header Support}
198
199 Per RFC 9110 Section 10.1.4: The TE header indicates what transfer codings
200 the client is willing to accept in the response, and whether the client is
201 willing to accept trailer fields in a chunked transfer coding. *)
202
203val te : string -> t -> t
204(** [te value headers] sets the TE header to indicate accepted transfer codings.
205 Example: [te "trailers, deflate"] *)
206
207val te_trailers : t -> t
208(** [te_trailers headers] sets [TE: trailers] to indicate the client accepts
209 trailer fields in chunked transfer coding. Per RFC 9110 Section 10.1.4,
210 a client MUST send this if it wishes to receive trailers. *)
211
212(** {1 Cache Control Headers}
213
214 Per Recommendation #17 and #19: Response caching and conditional requests.
215 RFC 9111 (HTTP Caching), RFC 9110 Section 8.8.2-8.8.3 (Last-Modified, ETag) *)
216
217val if_none_match : string -> t -> t
218(** [if_none_match etag headers] sets the If-None-Match header for conditional requests.
219 The request succeeds only if the resource's ETag does NOT match.
220 Used with GET/HEAD to implement efficient caching (returns 304 Not Modified if matches). *)
221
222val if_match : string -> t -> t
223(** [if_match etag headers] sets the If-Match header for conditional requests.
224 The request succeeds only if the resource's ETag matches.
225 Used with PUT/DELETE for optimistic concurrency (prevents lost updates). *)
226
227val if_modified_since : string -> t -> t
228(** [if_modified_since date headers] sets the If-Modified-Since header.
229 The date should be in HTTP-date format (RFC 9110 Section 5.6.7).
230 Example: ["Sun, 06 Nov 1994 08:49:37 GMT"] *)
231
232val if_unmodified_since : string -> t -> t
233(** [if_unmodified_since date headers] sets the If-Unmodified-Since header.
234 The request succeeds only if the resource has NOT been modified since the date. *)
235
236val http_date_of_ptime : Ptime.t -> string
237(** [http_date_of_ptime time] formats a Ptime.t as an HTTP-date.
238 Format: "Sun, 06 Nov 1994 08:49:37 GMT" (RFC 9110 Section 5.6.7) *)
239
240val if_modified_since_ptime : Ptime.t -> t -> t
241(** [if_modified_since_ptime time headers] sets If-Modified-Since using a Ptime.t value. *)
242
243val if_unmodified_since_ptime : Ptime.t -> t -> t
244(** [if_unmodified_since_ptime time headers] sets If-Unmodified-Since using a Ptime.t value. *)
245
246val cache_control : string -> t -> t
247(** [cache_control directives headers] sets the Cache-Control header with a raw directive string.
248 Example: [cache_control "no-cache, max-age=3600"] *)
249
250val cache_control_directives :
251 ?max_age:int ->
252 ?max_stale:int option option ->
253 ?min_fresh:int ->
254 ?no_cache:bool ->
255 ?no_store:bool ->
256 ?no_transform:bool ->
257 ?only_if_cached:bool ->
258 unit -> t -> t
259(** [cache_control_directives ?max_age ?max_stale ?min_fresh ~no_cache ~no_store
260 ~no_transform ~only_if_cached () headers] builds a Cache-Control header
261 from individual directives (RFC 9111 request directives).
262
263 - [max_age]: Maximum age in seconds the client is willing to accept
264 - [max_stale]: Accept stale responses:
265 - [None]: omit max_stale entirely
266 - [Some None]: "max-stale" (accept any staleness)
267 - [Some (Some n)]: "max-stale=N" (accept n seconds staleness)
268 - [min_fresh]: Response must be fresh for at least n more seconds
269 - [no_cache]: Force revalidation with origin server
270 - [no_store]: Response must not be stored in cache
271 - [no_transform]: Intermediaries must not transform the response
272 - [only_if_cached]: Only return cached response, 504 if not available *)
273
274val etag : string -> t -> t
275(** [etag value headers] sets the ETag header (for responses).
276 Example: [etag "\"abc123\""] *)
277
278val last_modified : string -> t -> t
279(** [last_modified date headers] sets the Last-Modified header (for responses).
280 The date should be in HTTP-date format. *)
281
282val last_modified_ptime : Ptime.t -> t -> t
283(** [last_modified_ptime time headers] sets Last-Modified using a Ptime.t value. *)
284
285(** {1 Connection Header Handling}
286
287 Per {{:https://datatracker.ietf.org/doc/html/rfc9110#section-7.6.1}RFC 9110 Section 7.6.1}:
288 The Connection header field lists hop-by-hop header fields that MUST be
289 removed before forwarding the message. *)
290
291val parse_connection_header : t -> Header_name.t list
292(** [parse_connection_header headers] parses the Connection header value
293 into a list of header names. *)
294
295val get_hop_by_hop_headers : t -> Header_name.t list
296(** [get_hop_by_hop_headers headers] returns all hop-by-hop headers.
297 This is the union of {!Header_name.hop_by_hop_headers} and any headers
298 listed in the Connection header. *)
299
300val remove_hop_by_hop : t -> t
301(** [remove_hop_by_hop headers] removes all hop-by-hop headers.
302 This should be called before caching or forwarding a response.
303 Per RFC 9110 Section 7.6.1. *)
304
305val connection_close : t -> bool
306(** [connection_close headers] returns [true] if Connection: close is present.
307 This indicates the connection should be closed after the current message. *)
308
309val connection_keep_alive : t -> bool
310(** [connection_keep_alive headers] returns [true] if Connection: keep-alive is present.
311 This is primarily used with HTTP/1.0 to request a persistent connection. *)
312
313(** {1 Aliases} *)
314
315val get_multi : Header_name.t -> t -> string list
316(** [get_multi] is an alias for {!get_all}. *)
317
318(** Pretty printer for headers *)
319val pp : Format.formatter -> t -> unit
320
321(** Brief pretty printer showing count only *)
322val pp_brief : Format.formatter -> t -> unit