anil.recoil.org
A batteries included HTTP/1.1 client in OCaml
Add typed Header_name module and refactor headers system
Introduces a new Header_name module that provides type-safe header name
handling with polymorphic variants for common HTTP headers. This improves
type safety and reduces string-based errors when working with headers.
Key changes:
- Add lib/header_name.ml and lib/header_name.mli with typed header names
- Refactor Headers module to use Header_name.t for core operations
- Update all modules to use typed header names where applicable
- Maintain string-based operations for wire format compatibility
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+1
-1
bin/ocurl.ml
+1
-1
bin/ocurl.ml
+1
-1
lib/auth.ml
+1
-1
lib/auth.ml
···
347
~username ~uri ~challenge ~nc ~cnonce ~response ~actual_qop in
348
Log.debug (fun m -> m "Applied Digest authentication for user %s (nc=%s qop=%s)"
349
username nc (Option.value ~default:"none" actual_qop));
350
-
Headers.set "Authorization" auth_header headers
351
352
(** Check if auth type is Digest *)
353
let is_digest = function
···
347
~username ~uri ~challenge ~nc ~cnonce ~response ~actual_qop in
348
Log.debug (fun m -> m "Applied Digest authentication for user %s (nc=%s qop=%s)"
349
username nc (Option.value ~default:"none" actual_qop));
350
+
Headers.set `Authorization auth_header headers
351
352
(** Check if auth type is Digest *)
353
let is_digest = function
+15
-12
lib/cache.ml
+15
-12
lib/cache.ml
···
46
let vary_values = match vary, request_headers with
47
| Some vary_names, Some headers ->
48
List.filter_map (fun name ->
49
-
match Headers.get name headers with
50
| Some value -> Some (String.lowercase_ascii name, value)
51
| None -> None
52
) vary_names
···
64
65
let vary_matches ~cached_vary ~request_headers =
66
List.for_all (fun (name, cached_value) ->
67
-
match Headers.get name request_headers with
68
| Some req_value -> req_value = cached_value
69
| None -> cached_value = ""
70
) cached_vary
71
72
(** Parse Age header value *)
73
let parse_age headers =
74
-
match Headers.get "age" headers with
75
| Some age_str ->
76
(try int_of_string age_str with _ -> 0)
77
| None -> 0
···
81
(* First try explicit freshness from Cache-Control or Expires *)
82
match Cache_control.freshness_lifetime
83
~response_cc:cache_control
84
-
?expires:(Headers.get "expires" headers)
85
-
?date:(Headers.get "date" headers)
86
() with
87
| Some lifetime -> Some lifetime
88
| None ->
89
(* Fall back to heuristic freshness *)
90
Cache_control.heuristic_freshness
91
-
?last_modified:(Headers.get "last-modified" headers)
92
~response_time
93
()
94
···
148
false
149
end else begin
150
let cache_control =
151
-
match Headers.get "cache-control" headers with
152
| Some cc -> Cache_control.parse_response cc
153
| None -> Cache_control.empty_response
154
in
···
157
false
158
end else begin
159
let date_value =
160
-
match Headers.get "date" headers with
161
| Some date_str -> Http_date.parse date_str
162
| None -> None
163
in
164
let age_value = parse_age headers in
165
-
let etag = Headers.get "etag" headers in
166
-
let last_modified = Headers.get "last-modified" headers in
167
let vary_headers =
168
-
match Headers.get "vary" headers, request_headers with
169
| Some vary, Some req_hdrs ->
170
let vary_names = parse_vary vary in
171
List.filter_map (fun name ->
172
-
match Headers.get name req_hdrs with
173
| Some value -> Some (name, value)
174
| None -> None
175
) vary_names
···
46
let vary_values = match vary, request_headers with
47
| Some vary_names, Some headers ->
48
List.filter_map (fun name ->
49
+
(* Vary header names come from the wire, use string lookup *)
50
+
match Headers.get_string name headers with
51
| Some value -> Some (String.lowercase_ascii name, value)
52
| None -> None
53
) vary_names
···
65
66
let vary_matches ~cached_vary ~request_headers =
67
List.for_all (fun (name, cached_value) ->
68
+
(* Vary header names are dynamic strings from the wire *)
69
+
match Headers.get_string name request_headers with
70
| Some req_value -> req_value = cached_value
71
| None -> cached_value = ""
72
) cached_vary
73
74
(** Parse Age header value *)
75
let parse_age headers =
76
+
match Headers.get `Age headers with
77
| Some age_str ->
78
(try int_of_string age_str with _ -> 0)
79
| None -> 0
···
83
(* First try explicit freshness from Cache-Control or Expires *)
84
match Cache_control.freshness_lifetime
85
~response_cc:cache_control
86
+
?expires:(Headers.get `Expires headers)
87
+
?date:(Headers.get `Date headers)
88
() with
89
| Some lifetime -> Some lifetime
90
| None ->
91
(* Fall back to heuristic freshness *)
92
Cache_control.heuristic_freshness
93
+
?last_modified:(Headers.get `Last_modified headers)
94
~response_time
95
()
96
···
150
false
151
end else begin
152
let cache_control =
153
+
match Headers.get `Cache_control headers with
154
| Some cc -> Cache_control.parse_response cc
155
| None -> Cache_control.empty_response
156
in
···
159
false
160
end else begin
161
let date_value =
162
+
match Headers.get `Date headers with
163
| Some date_str -> Http_date.parse date_str
164
| None -> None
165
in
166
let age_value = parse_age headers in
167
+
let etag = Headers.get `Etag headers in
168
+
let last_modified = Headers.get `Last_modified headers in
169
let vary_headers =
170
+
match Headers.get `Vary headers, request_headers with
171
| Some vary, Some req_hdrs ->
172
let vary_names = parse_vary vary in
173
List.filter_map (fun name ->
174
+
(* Vary header names are dynamic strings from the wire *)
175
+
match Headers.get_string name req_hdrs with
176
| Some value -> Some (name, value)
177
| None -> None
178
) vary_names
+200
lib/header_name.ml
+200
lib/header_name.ml
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP Header Names as Polymorphic Variants
7
+
8
+
This module provides type-safe HTTP header names using polymorphic variants.
9
+
All standard headers have dedicated variants, with [`Other] for non-standard
10
+
or unknown headers. Header names are case-insensitive per RFC 9110 Section 5.1. *)
11
+
12
+
(** Standard HTTP header names.
13
+
14
+
These cover all headers defined in RFC 9110, RFC 9111, RFC 9112, and
15
+
common authentication headers from RFC 7235, RFC 7617, RFC 6750. *)
16
+
type standard = [
17
+
| `Accept
18
+
| `Accept_encoding
19
+
| `Accept_language
20
+
| `Age
21
+
| `Authorization
22
+
| `Cache_control
23
+
| `Connection
24
+
| `Content_encoding
25
+
| `Content_length
26
+
| `Content_type
27
+
| `Cookie
28
+
| `Date
29
+
| `Etag
30
+
| `Expect
31
+
| `Expires
32
+
| `Host
33
+
| `If_match
34
+
| `If_modified_since
35
+
| `If_none_match
36
+
| `If_unmodified_since
37
+
| `Keep_alive
38
+
| `Last_modified
39
+
| `Link
40
+
| `Location
41
+
| `Proxy_authenticate
42
+
| `Proxy_authorization
43
+
| `Range
44
+
| `Retry_after
45
+
| `Set_cookie
46
+
| `Te
47
+
| `Trailer
48
+
| `Transfer_encoding
49
+
| `Upgrade
50
+
| `User_agent
51
+
| `Vary
52
+
| `Www_authenticate
53
+
]
54
+
55
+
(** Complete header name type including non-standard headers.
56
+
57
+
Use [`Other name] for headers not in the standard set.
58
+
The name should be provided in its canonical form (e.g., "X-Custom-Header"). *)
59
+
type t = [ standard | `Other of string ]
60
+
61
+
(** Convert a header name to its canonical wire format string.
62
+
63
+
Standard headers are converted to their canonical capitalization.
64
+
[`Other] headers are returned as-is. *)
65
+
let to_string : t -> string = function
66
+
| `Accept -> "Accept"
67
+
| `Accept_encoding -> "Accept-Encoding"
68
+
| `Accept_language -> "Accept-Language"
69
+
| `Age -> "Age"
70
+
| `Authorization -> "Authorization"
71
+
| `Cache_control -> "Cache-Control"
72
+
| `Connection -> "Connection"
73
+
| `Content_encoding -> "Content-Encoding"
74
+
| `Content_length -> "Content-Length"
75
+
| `Content_type -> "Content-Type"
76
+
| `Cookie -> "Cookie"
77
+
| `Date -> "Date"
78
+
| `Etag -> "ETag"
79
+
| `Expect -> "Expect"
80
+
| `Expires -> "Expires"
81
+
| `Host -> "Host"
82
+
| `If_match -> "If-Match"
83
+
| `If_modified_since -> "If-Modified-Since"
84
+
| `If_none_match -> "If-None-Match"
85
+
| `If_unmodified_since -> "If-Unmodified-Since"
86
+
| `Keep_alive -> "Keep-Alive"
87
+
| `Last_modified -> "Last-Modified"
88
+
| `Link -> "Link"
89
+
| `Location -> "Location"
90
+
| `Proxy_authenticate -> "Proxy-Authenticate"
91
+
| `Proxy_authorization -> "Proxy-Authorization"
92
+
| `Range -> "Range"
93
+
| `Retry_after -> "Retry-After"
94
+
| `Set_cookie -> "Set-Cookie"
95
+
| `Te -> "TE"
96
+
| `Trailer -> "Trailer"
97
+
| `Transfer_encoding -> "Transfer-Encoding"
98
+
| `Upgrade -> "Upgrade"
99
+
| `User_agent -> "User-Agent"
100
+
| `Vary -> "Vary"
101
+
| `Www_authenticate -> "WWW-Authenticate"
102
+
| `Other s -> s
103
+
104
+
(** Convert a string to a header name.
105
+
106
+
Performs case-insensitive matching against known headers.
107
+
Unknown headers are wrapped in [`Other]. *)
108
+
let of_string s : t =
109
+
match String.lowercase_ascii s with
110
+
| "accept" -> `Accept
111
+
| "accept-encoding" -> `Accept_encoding
112
+
| "accept-language" -> `Accept_language
113
+
| "age" -> `Age
114
+
| "authorization" -> `Authorization
115
+
| "cache-control" -> `Cache_control
116
+
| "connection" -> `Connection
117
+
| "content-encoding" -> `Content_encoding
118
+
| "content-length" -> `Content_length
119
+
| "content-type" -> `Content_type
120
+
| "cookie" -> `Cookie
121
+
| "date" -> `Date
122
+
| "etag" -> `Etag
123
+
| "expect" -> `Expect
124
+
| "expires" -> `Expires
125
+
| "host" -> `Host
126
+
| "if-match" -> `If_match
127
+
| "if-modified-since" -> `If_modified_since
128
+
| "if-none-match" -> `If_none_match
129
+
| "if-unmodified-since" -> `If_unmodified_since
130
+
| "keep-alive" -> `Keep_alive
131
+
| "last-modified" -> `Last_modified
132
+
| "link" -> `Link
133
+
| "location" -> `Location
134
+
| "proxy-authenticate" -> `Proxy_authenticate
135
+
| "proxy-authorization" -> `Proxy_authorization
136
+
| "range" -> `Range
137
+
| "retry-after" -> `Retry_after
138
+
| "set-cookie" -> `Set_cookie
139
+
| "te" -> `Te
140
+
| "trailer" -> `Trailer
141
+
| "transfer-encoding" -> `Transfer_encoding
142
+
| "upgrade" -> `Upgrade
143
+
| "user-agent" -> `User_agent
144
+
| "vary" -> `Vary
145
+
| "www-authenticate" -> `Www_authenticate
146
+
| _ -> `Other s
147
+
148
+
(** Convert to lowercase string for internal map keys. *)
149
+
let to_lowercase_string (name : t) : string =
150
+
match name with
151
+
| `Other s -> String.lowercase_ascii s
152
+
| #standard as s -> String.lowercase_ascii (to_string s)
153
+
154
+
(** Compare two header names (case-insensitive). *)
155
+
let compare (a : t) (b : t) : int =
156
+
String.compare (to_lowercase_string a) (to_lowercase_string b)
157
+
158
+
(** Check equality of two header names (case-insensitive). *)
159
+
let equal (a : t) (b : t) : bool =
160
+
compare a b = 0
161
+
162
+
(** Pretty printer for header names. *)
163
+
let pp ppf name =
164
+
Format.pp_print_string ppf (to_string name)
165
+
166
+
(** {1 Header Categories}
167
+
168
+
Useful groupings for protocol handling. *)
169
+
170
+
(** Default hop-by-hop headers per RFC 9110 Section 7.6.1.
171
+
172
+
These headers MUST be removed before forwarding a message. *)
173
+
let hop_by_hop_headers : t list = [
174
+
`Connection;
175
+
`Keep_alive;
176
+
`Proxy_authenticate;
177
+
`Proxy_authorization;
178
+
`Te;
179
+
`Trailer;
180
+
`Transfer_encoding;
181
+
`Upgrade;
182
+
]
183
+
184
+
(** Headers that MUST NOT appear in trailers per RFC 9110 Section 6.5.1. *)
185
+
let forbidden_trailer_headers : t list = [
186
+
`Transfer_encoding;
187
+
`Content_length;
188
+
`Host;
189
+
`Content_encoding;
190
+
`Content_type;
191
+
`Trailer;
192
+
]
193
+
194
+
(** Check if a header is a hop-by-hop header. *)
195
+
let is_hop_by_hop (name : t) : bool =
196
+
List.exists (equal name) hop_by_hop_headers
197
+
198
+
(** Check if a header is forbidden in trailers. *)
199
+
let is_forbidden_trailer (name : t) : bool =
200
+
List.exists (equal name) forbidden_trailer_headers
+139
lib/header_name.mli
+139
lib/header_name.mli
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** HTTP Header Names as Polymorphic Variants
7
+
8
+
This module provides type-safe HTTP header names using polymorphic variants.
9
+
All standard headers have dedicated variants, with [`Other] for non-standard
10
+
or unknown headers.
11
+
12
+
{2 Usage}
13
+
14
+
{[
15
+
(* Use standard headers directly *)
16
+
let headers = Headers.empty
17
+
|> Headers.set `Content_type "application/json"
18
+
|> Headers.set `Accept "text/html"
19
+
20
+
(* Use custom headers with `Other *)
21
+
let headers = headers
22
+
|> Headers.set (`Other "X-Custom-Header") "value"
23
+
24
+
(* Pattern match on headers *)
25
+
match Headers.get `Content_type headers with
26
+
| Some ct -> print_endline ct
27
+
| None -> ()
28
+
]}
29
+
30
+
Header names are case-insensitive per
31
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-5.1}RFC 9110 Section 5.1}. *)
32
+
33
+
(** {1 Types} *)
34
+
35
+
(** Standard HTTP header names.
36
+
37
+
These cover headers defined in:
38
+
- {{:https://datatracker.ietf.org/doc/html/rfc9110}RFC 9110} (HTTP Semantics)
39
+
- {{:https://datatracker.ietf.org/doc/html/rfc9111}RFC 9111} (HTTP Caching)
40
+
- {{:https://datatracker.ietf.org/doc/html/rfc9112}RFC 9112} (HTTP/1.1)
41
+
- {{:https://datatracker.ietf.org/doc/html/rfc7235}RFC 7235} (HTTP Authentication)
42
+
- {{:https://datatracker.ietf.org/doc/html/rfc6265}RFC 6265} (HTTP Cookies) *)
43
+
type standard = [
44
+
| `Accept
45
+
| `Accept_encoding
46
+
| `Accept_language
47
+
| `Age
48
+
| `Authorization
49
+
| `Cache_control
50
+
| `Connection
51
+
| `Content_encoding
52
+
| `Content_length
53
+
| `Content_type
54
+
| `Cookie
55
+
| `Date
56
+
| `Etag
57
+
| `Expect
58
+
| `Expires
59
+
| `Host
60
+
| `If_match
61
+
| `If_modified_since
62
+
| `If_none_match
63
+
| `If_unmodified_since
64
+
| `Keep_alive
65
+
| `Last_modified
66
+
| `Link
67
+
| `Location
68
+
| `Proxy_authenticate
69
+
| `Proxy_authorization
70
+
| `Range
71
+
| `Retry_after
72
+
| `Set_cookie
73
+
| `Te
74
+
| `Trailer
75
+
| `Transfer_encoding
76
+
| `Upgrade
77
+
| `User_agent
78
+
| `Vary
79
+
| `Www_authenticate
80
+
]
81
+
82
+
(** Complete header name type including non-standard headers.
83
+
84
+
Use [`Other name] for headers not in the standard set.
85
+
The name should be provided in its canonical form (e.g., "X-Custom-Header"). *)
86
+
type t = [ standard | `Other of string ]
87
+
88
+
(** {1 Conversion} *)
89
+
90
+
val to_string : t -> string
91
+
(** [to_string name] converts a header name to its canonical wire format.
92
+
93
+
Standard headers use their canonical capitalization (e.g., [`Content_type]
94
+
becomes ["Content-Type"]). [`Other] headers are returned as-is. *)
95
+
96
+
val of_string : string -> t
97
+
(** [of_string s] parses a string into a header name.
98
+
99
+
Performs case-insensitive matching against known headers. Unknown headers
100
+
are wrapped in [`Other]. *)
101
+
102
+
val to_lowercase_string : t -> string
103
+
(** [to_lowercase_string name] returns the lowercase form for internal use. *)
104
+
105
+
(** {1 Comparison} *)
106
+
107
+
val compare : t -> t -> int
108
+
(** [compare a b] compares two header names case-insensitively. *)
109
+
110
+
val equal : t -> t -> bool
111
+
(** [equal a b] checks equality of two header names case-insensitively. *)
112
+
113
+
(** {1 Pretty Printing} *)
114
+
115
+
val pp : Format.formatter -> t -> unit
116
+
(** [pp ppf name] pretty-prints a header name. *)
117
+
118
+
(** {1 Header Categories} *)
119
+
120
+
val hop_by_hop_headers : t list
121
+
(** Default hop-by-hop headers per
122
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-7.6.1}RFC 9110 Section 7.6.1}.
123
+
124
+
These headers MUST be removed before forwarding a message:
125
+
Connection, Keep-Alive, Proxy-Authenticate, Proxy-Authorization,
126
+
TE, Trailer, Transfer-Encoding, Upgrade. *)
127
+
128
+
val forbidden_trailer_headers : t list
129
+
(** Headers that MUST NOT appear in trailers per
130
+
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-6.5.1}RFC 9110 Section 6.5.1}.
131
+
132
+
Includes: Transfer-Encoding, Content-Length, Host, Content-Encoding,
133
+
Content-Type, Trailer. *)
134
+
135
+
val is_hop_by_hop : t -> bool
136
+
(** [is_hop_by_hop name] returns [true] if [name] is a hop-by-hop header. *)
137
+
138
+
val is_forbidden_trailer : t -> bool
139
+
(** [is_forbidden_trailer name] returns [true] if [name] is forbidden in trailers. *)
+97
-58
lib/headers.ml
+97
-58
lib/headers.ml
···
9
(* Use a map with lowercase keys for case-insensitive lookup *)
10
module StringMap = Map.Make(String)
11
12
type t = (string * string list) StringMap.t
13
14
let empty = StringMap.empty
15
-
16
-
let normalize_key k = String.lowercase_ascii k
17
18
(** {1 Header Injection Prevention}
19
···
55
reason = "Password contains control characters (RFC 7617 Section 2)"
56
})
57
58
-
let validate_header_name name =
59
if String.contains name '\r' || String.contains name '\n' then
60
raise (Invalid_header {
61
name;
···
69
reason = "Header value contains CR/LF characters (potential HTTP smuggling)"
70
})
71
72
-
let add key value t =
73
-
validate_header_name key;
74
-
validate_header_value key value;
75
-
let nkey = normalize_key key in
76
let existing =
77
match StringMap.find_opt nkey t with
78
| Some (_, values) -> values
79
| None -> []
80
in
81
(* Append to maintain order, avoiding reversal on retrieval *)
82
StringMap.add nkey (key, existing @ [value]) t
83
84
-
let set key value t =
85
-
validate_header_name key;
86
validate_header_value key value;
87
-
let nkey = normalize_key key in
88
StringMap.add nkey (key, [value]) t
89
90
-
let get key t =
91
-
let nkey = normalize_key key in
92
match StringMap.find_opt nkey t with
93
| Some (_, values) -> List.nth_opt values 0
94
| None -> None
95
96
-
let get_all key t =
97
-
let nkey = normalize_key key in
98
match StringMap.find_opt nkey t with
99
| Some (_, values) -> values
100
| None -> []
101
102
-
let remove key t =
103
-
let nkey = normalize_key key in
104
StringMap.remove nkey t
105
106
-
let mem key t =
107
-
let nkey = normalize_key key in
108
StringMap.mem nkey t
109
110
let of_list lst =
111
-
List.fold_left (fun acc (k, v) -> add k v acc) empty lst
112
113
let to_list t =
114
StringMap.fold (fun _ (orig_key, values) acc ->
···
120
let merge t1 t2 =
121
StringMap.union (fun _ _ v2 -> Some v2) t1 t2
122
123
-
(* Common header builders *)
124
125
let content_type mime t =
126
-
set "Content-Type" (Mime.to_string mime) t
127
128
let content_length len t =
129
-
set "Content-Length" (Int64.to_string len) t
130
131
let accept mime t =
132
-
set "Accept" (Mime.to_string mime) t
133
134
let accept_language lang t =
135
-
set "Accept-Language" lang t
136
137
let authorization value t =
138
-
set "Authorization" value t
139
140
let bearer token t =
141
-
set "Authorization" (Printf.sprintf "Bearer %s" token) t
142
143
let basic ~username ~password t =
144
validate_basic_auth_credentials ~username ~password;
145
let credentials = Printf.sprintf "%s:%s" username password in
146
let encoded = Base64.encode_exn credentials in
147
-
set "Authorization" (Printf.sprintf "Basic %s" encoded) t
148
149
let user_agent ua t =
150
-
set "User-Agent" ua t
151
152
let host h t =
153
-
set "Host" h t
154
155
let cookie name value t =
156
-
add "Cookie" (Printf.sprintf "%s=%s" name value) t
157
158
let range ~start ?end_ () t =
159
let range_value = match end_ with
160
| None -> Printf.sprintf "bytes=%Ld-" start
161
| Some e -> Printf.sprintf "bytes=%Ld-%Ld" start e
162
in
163
-
set "Range" range_value t
164
165
(** {1 HTTP 100-Continue Support}
166
···
168
RFC 9110 Section 10.1.1 (Expect) *)
169
170
let expect value t =
171
-
set "Expect" value t
172
173
let expect_100_continue t =
174
-
set "Expect" "100-continue" t
175
176
(** {1 Cache Control Headers}
177
···
179
RFC 9111 (HTTP Caching), RFC 9110 Section 8.8.2-8.8.3 (Last-Modified, ETag) *)
180
181
let if_none_match etag t =
182
-
set "If-None-Match" etag t
183
184
let if_match etag t =
185
-
set "If-Match" etag t
186
187
let if_modified_since date t =
188
-
set "If-Modified-Since" date t
189
190
let if_unmodified_since date t =
191
-
set "If-Unmodified-Since" date t
192
193
(** Format a Ptime.t as an HTTP-date (RFC 9110 Section 5.6.7) *)
194
let http_date_of_ptime time =
···
210
if_unmodified_since (http_date_of_ptime time) t
211
212
let cache_control directives t =
213
-
set "Cache-Control" directives t
214
215
(** Build Cache-Control header from common directive components.
216
For max_stale: [None] = not present, [Some None] = any staleness, [Some (Some n)] = n seconds *)
···
252
let directives = if only_if_cached then "only-if-cached" :: directives else directives in
253
match directives with
254
| [] -> t
255
-
| _ -> set "Cache-Control" (String.concat ", " (List.rev directives)) t
256
257
let etag value t =
258
-
set "ETag" value t
259
260
let last_modified date t =
261
-
set "Last-Modified" date t
262
263
let last_modified_ptime time t =
264
last_modified (http_date_of_ptime time) t
265
266
(* Additional helper for getting multiple header values *)
267
-
let get_multi key t = get_all key t
268
269
(** {1 Connection Header Handling}
270
271
Per RFC 9110 Section 7.6.1: The Connection header field lists hop-by-hop
272
header fields that MUST be removed before forwarding the message. *)
273
-
274
-
(** Default hop-by-hop headers that should always be removed for forwarding.
275
-
Per RFC 9110 Section 7.6.1. *)
276
-
let default_hop_by_hop_headers = [
277
-
"connection"; "keep-alive"; "proxy-authenticate"; "proxy-authorization";
278
-
"te"; "trailer"; "transfer-encoding"; "upgrade"
279
-
]
280
281
(** Parse Connection header value into list of header names.
282
The Connection header lists additional hop-by-hop headers. *)
283
-
let parse_connection_header = function
284
| None -> []
285
| Some value ->
286
String.split_on_char ',' value
287
-
|> List.map (fun s -> String.trim (String.lowercase_ascii s))
288
-
|> List.filter (fun s -> s <> "")
289
290
(** Get all hop-by-hop headers from a response.
291
Returns the union of default hop-by-hop headers and any headers
292
listed in the Connection header. *)
293
let get_hop_by_hop_headers t =
294
-
let connection_headers = parse_connection_header (get "connection" t) in
295
-
default_hop_by_hop_headers @ connection_headers
296
-
|> List.sort_uniq String.compare
297
298
(** Remove hop-by-hop headers from a header collection.
299
This should be called before caching or forwarding a response.
···
305
(** Check if a response indicates the connection should be closed.
306
Returns true if Connection: close is present. *)
307
let connection_close t =
308
-
match get "connection" t with
309
| Some value ->
310
String.split_on_char ',' value
311
|> List.exists (fun s -> String.trim (String.lowercase_ascii s) = "close")
···
314
(** Check if a response indicates the connection should be kept alive.
315
Returns true if Connection: keep-alive is present (HTTP/1.0 behavior). *)
316
let connection_keep_alive t =
317
-
match get "connection" t with
318
| Some value ->
319
String.split_on_char ',' value
320
|> List.exists (fun s -> String.trim (String.lowercase_ascii s) = "keep-alive")
···
332
let pp_brief ppf t =
333
let headers = to_list t in
334
let count = List.length headers in
335
-
Format.fprintf ppf "Headers(%d entries)" count
···
9
(* Use a map with lowercase keys for case-insensitive lookup *)
10
module StringMap = Map.Make(String)
11
12
+
(** The internal representation stores: (canonical_name, values) *)
13
type t = (string * string list) StringMap.t
14
15
let empty = StringMap.empty
16
17
(** {1 Header Injection Prevention}
18
···
54
reason = "Password contains control characters (RFC 7617 Section 2)"
55
})
56
57
+
let validate_header_name_str name =
58
if String.contains name '\r' || String.contains name '\n' then
59
raise (Invalid_header {
60
name;
···
68
reason = "Header value contains CR/LF characters (potential HTTP smuggling)"
69
})
70
71
+
(** {1 Core Operations with Typed Header Names} *)
72
+
73
+
let 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
+
85
+
let 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
+
91
+
let 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
+
97
+
let 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
+
103
+
let remove (name : Header_name.t) t =
104
+
let nkey = Header_name.to_lowercase_string name in
105
+
StringMap.remove nkey t
106
+
107
+
let 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
+
116
+
let 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
127
+
let 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
133
+
let 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
139
+
let 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
145
+
let remove_string key t =
146
+
let nkey = String.lowercase_ascii key in
147
StringMap.remove nkey t
148
149
+
let mem_string key t =
150
+
let nkey = String.lowercase_ascii key in
151
StringMap.mem nkey t
152
+
153
+
(** {1 Conversion} *)
154
155
let of_list lst =
156
+
List.fold_left (fun acc (k, v) -> add_string k v acc) empty lst
157
158
let to_list t =
159
StringMap.fold (fun _ (orig_key, values) acc ->
···
165
let merge t1 t2 =
166
StringMap.union (fun _ _ v2 -> Some v2) t1 t2
167
168
+
(** {1 Common Header Builders} *)
169
170
let content_type mime t =
171
+
set `Content_type (Mime.to_string mime) t
172
173
let content_length len t =
174
+
set `Content_length (Int64.to_string len) t
175
176
let accept mime t =
177
+
set `Accept (Mime.to_string mime) t
178
179
let accept_language lang t =
180
+
set `Accept_language lang t
181
182
let authorization value t =
183
+
set `Authorization value t
184
185
let bearer token t =
186
+
set `Authorization (Printf.sprintf "Bearer %s" token) t
187
188
let 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
194
let user_agent ua t =
195
+
set `User_agent ua t
196
197
let host h t =
198
+
set `Host h t
199
200
let cookie name value t =
201
+
add `Cookie (Printf.sprintf "%s=%s" name value) t
202
203
let 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
···
213
RFC 9110 Section 10.1.1 (Expect) *)
214
215
let expect value t =
216
+
set `Expect value t
217
218
let expect_100_continue t =
219
+
set `Expect "100-continue" t
220
221
(** {1 Cache Control Headers}
222
···
224
RFC 9111 (HTTP Caching), RFC 9110 Section 8.8.2-8.8.3 (Last-Modified, ETag) *)
225
226
let if_none_match etag t =
227
+
set `If_none_match etag t
228
229
let if_match etag t =
230
+
set `If_match etag t
231
232
let if_modified_since date t =
233
+
set `If_modified_since date t
234
235
let if_unmodified_since date t =
236
+
set `If_unmodified_since date t
237
238
(** Format a Ptime.t as an HTTP-date (RFC 9110 Section 5.6.7) *)
239
let http_date_of_ptime time =
···
255
if_unmodified_since (http_date_of_ptime time) t
256
257
let cache_control directives t =
258
+
set `Cache_control directives t
259
260
(** Build Cache-Control header from common directive components.
261
For max_stale: [None] = not present, [Some None] = any staleness, [Some (Some n)] = n seconds *)
···
297
let directives = if only_if_cached then "only-if-cached" :: directives else directives in
298
match directives with
299
| [] -> t
300
+
| _ -> set `Cache_control (String.concat ", " (List.rev directives)) t
301
302
let etag value t =
303
+
set `Etag value t
304
305
let last_modified date t =
306
+
set `Last_modified date t
307
308
let last_modified_ptime time t =
309
last_modified (http_date_of_ptime time) t
310
311
(* Additional helper for getting multiple header values *)
312
+
let get_multi name t = get_all name t
313
314
(** {1 Connection Header Handling}
315
316
Per RFC 9110 Section 7.6.1: The Connection header field lists hop-by-hop
317
header fields that MUST be removed before forwarding the message. *)
318
319
(** Parse Connection header value into list of header names.
320
The Connection header lists additional hop-by-hop headers. *)
321
+
let parse_connection_header t =
322
+
match get `Connection t with
323
| None -> []
324
| Some value ->
325
String.split_on_char ',' value
326
+
|> List.map (fun s -> Header_name.of_string (String.trim s))
327
+
|> List.filter (fun n -> not (Header_name.equal n (`Other "")))
328
329
(** Get all hop-by-hop headers from a response.
330
Returns the union of default hop-by-hop headers and any headers
331
listed in the Connection header. *)
332
let get_hop_by_hop_headers t =
333
+
let connection_headers = parse_connection_header t in
334
+
Header_name.hop_by_hop_headers @ connection_headers
335
+
|> List.sort_uniq Header_name.compare
336
337
(** Remove hop-by-hop headers from a header collection.
338
This should be called before caching or forwarding a response.
···
344
(** Check if a response indicates the connection should be closed.
345
Returns true if Connection: close is present. *)
346
let connection_close t =
347
+
match get `Connection t with
348
| Some value ->
349
String.split_on_char ',' value
350
|> List.exists (fun s -> String.trim (String.lowercase_ascii s) = "close")
···
353
(** Check if a response indicates the connection should be kept alive.
354
Returns true if Connection: keep-alive is present (HTTP/1.0 behavior). *)
355
let connection_keep_alive t =
356
+
match get `Connection t with
357
| Some value ->
358
String.split_on_char ',' value
359
|> List.exists (fun s -> String.trim (String.lowercase_ascii s) = "keep-alive")
···
371
let pp_brief ppf t =
372
let headers = to_list t in
373
let count = List.length headers in
374
+
Format.fprintf ppf "Headers(%d entries)" count
+62
-32
lib/headers.mli
+62
-32
lib/headers.mli
···
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 Security}
13
14
Header names and values are validated to prevent HTTP header injection
15
attacks. CR and LF characters are rejected per
16
{{:https://datatracker.ietf.org/doc/html/rfc9110#section-5.5}RFC 9110 Section 5.5}.
17
-
18
-
{2 Examples}
19
-
20
-
{[
21
-
let headers =
22
-
Headers.empty
23
-
|> Headers.content_type Mime.json
24
-
|> Headers.bearer "token123"
25
-
|> Headers.set "X-Custom" "value"
26
-
]}
27
*)
28
29
(** Log source for header operations *)
···
39
(** [empty] creates an empty header collection. *)
40
41
val of_list : (string * string) list -> t
42
-
(** [of_list pairs] creates headers from an association list.
43
Later entries override earlier ones for the same key. *)
44
45
val to_list : t -> (string * string) list
···
58
- Username must not contain colon characters
59
- Username and password must not contain control characters (0x00-0x1F, 0x7F) *)
60
61
-
(** {1 Manipulation} *)
62
63
-
val add : string -> string -> t -> t
64
(** [add name value headers] adds a header value. Multiple values
65
for the same header name are allowed (e.g., for Set-Cookie).
66
67
-
@raise Invalid_header if the header name or value contains CR/LF characters
68
(to prevent HTTP header injection attacks). *)
69
70
-
val set : string -> string -> t -> t
71
(** [set name value headers] sets a header value, replacing any
72
existing values for that header name.
73
74
-
@raise Invalid_header if the header name or value contains CR/LF characters
75
(to prevent HTTP header injection attacks). *)
76
77
-
val get : string -> t -> string option
78
(** [get name headers] returns the first value for a header name,
79
or [None] if the header doesn't exist. *)
80
81
-
val get_all : string -> t -> string list
82
(** [get_all name headers] returns all values for a header name.
83
Returns an empty list if the header doesn't exist. *)
84
85
-
val remove : string -> t -> t
86
(** [remove name headers] removes all values for a header name. *)
87
88
-
val mem : string -> t -> bool
89
(** [mem name headers] checks if a header name exists. *)
90
91
val merge : t -> t -> t
92
(** [merge base override] merges two header collections.
···
238
The Connection header field lists hop-by-hop header fields that MUST be
239
removed before forwarding the message. *)
240
241
-
val default_hop_by_hop_headers : string list
242
-
(** Default hop-by-hop headers that should always be removed for forwarding.
243
-
Includes: connection, keep-alive, proxy-authenticate, proxy-authorization,
244
-
te, trailer, transfer-encoding, upgrade. *)
245
246
-
val parse_connection_header : string option -> string list
247
-
(** [parse_connection_header header_value] parses a Connection header value
248
-
into a list of header names (all lowercase). *)
249
-
250
-
val get_hop_by_hop_headers : t -> string list
251
(** [get_hop_by_hop_headers headers] returns all hop-by-hop headers.
252
-
This is the union of {!default_hop_by_hop_headers} and any headers
253
listed in the Connection header. *)
254
255
val remove_hop_by_hop : t -> t
···
267
268
(** {1 Aliases} *)
269
270
-
val get_multi : string -> t -> string list
271
(** [get_multi] is an alias for {!get_all}. *)
272
273
(** Pretty printer for headers *)
274
val pp : Format.formatter -> t -> unit
275
276
(** Brief pretty printer showing count only *)
277
-
val pp_brief : Format.formatter -> t -> unit
···
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 *)
···
41
(** [empty] creates an empty header collection. *)
42
43
val 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
48
val to_list : t -> (string * string) list
···
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
68
+
val 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
75
+
val 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
82
+
val 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
86
+
val 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
90
+
val remove : Header_name.t -> t -> t
91
(** [remove name headers] removes all values for a header name. *)
92
93
+
val 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
+
101
+
val 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
+
107
+
val 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
+
112
+
val get_string : string -> t -> string option
113
+
(** [get_string name headers] gets a header using a string name. *)
114
+
115
+
val get_all_string : string -> t -> string list
116
+
(** [get_all_string name headers] gets all values for a string header name. *)
117
+
118
+
val remove_string : string -> t -> t
119
+
(** [remove_string name headers] removes a header using a string name. *)
120
+
121
+
val mem_string : string -> t -> bool
122
+
(** [mem_string name headers] checks if a header exists using a string name. *)
123
+
124
+
(** {1 Merging} *)
125
126
val merge : t -> t -> t
127
(** [merge base override] merges two header collections.
···
273
The Connection header field lists hop-by-hop header fields that MUST be
274
removed before forwarding the message. *)
275
276
+
val parse_connection_header : t -> Header_name.t list
277
+
(** [parse_connection_header headers] parses the Connection header value
278
+
into a list of header names. *)
279
280
+
val get_hop_by_hop_headers : t -> Header_name.t list
281
(** [get_hop_by_hop_headers headers] returns all hop-by-hop headers.
282
+
This is the union of {!Header_name.hop_by_hop_headers} and any headers
283
listed in the Connection header. *)
284
285
val remove_hop_by_hop : t -> t
···
297
298
(** {1 Aliases} *)
299
300
+
val get_multi : Header_name.t -> t -> string list
301
(** [get_multi] is an alias for {!get_all}. *)
302
303
(** Pretty printer for headers *)
304
val pp : Format.formatter -> t -> unit
305
306
(** Brief pretty printer showing count only *)
307
+
val pp_brief : Format.formatter -> t -> unit
+6
-6
lib/http_client.ml
+6
-6
lib/http_client.ml
···
140
141
(** Apply auto-decompression to response if enabled *)
142
let maybe_decompress ~limits ~auto_decompress (status, resp_headers, body_str) =
143
-
match auto_decompress, Headers.get "content-encoding" resp_headers with
144
| true, Some encoding ->
145
let body_str = decompress_body ~limits ~content_encoding:encoding body_str in
146
-
let resp_headers = Headers.remove "content-encoding" resp_headers in
147
(status, resp_headers, body_str)
148
| _ ->
149
(status, resp_headers, body_str)
···
207
(* Error response - server rejected based on headers *)
208
Log.info (fun m -> m "Server rejected request with status %d before body sent" status);
209
let resp_headers = Http_read.headers ~limits buf_read in
210
-
let transfer_encoding = Headers.get "transfer-encoding" resp_headers in
211
-
let content_length = Headers.get "content-length" resp_headers |> Option.map Int64.of_string in
212
let body_str = match transfer_encoding, content_length with
213
| Some te, _ when String.lowercase_ascii te |> String.trim = "chunked" ->
214
Http_read.chunked_body ~limits buf_read
···
254
Expect_continue.enabled expect_100 &&
255
body_len >= Expect_continue.threshold expect_100 &&
256
body_len > 0L &&
257
-
not (Headers.mem "expect" headers) (* Don't override explicit Expect header *)
258
in
259
260
if not use_100_continue then begin
···
268
(* Add Expect: 100-continue header and Content-Type if present *)
269
let headers_with_expect = Headers.expect_100_continue headers in
270
let headers_with_expect = match Body.content_type body with
271
-
| Some mime -> Headers.add "content-type" (Mime.to_string mime) headers_with_expect
272
| None -> headers_with_expect
273
in
274
···
140
141
(** Apply auto-decompression to response if enabled *)
142
let maybe_decompress ~limits ~auto_decompress (status, resp_headers, body_str) =
143
+
match auto_decompress, Headers.get `Content_encoding resp_headers with
144
| true, Some encoding ->
145
let body_str = decompress_body ~limits ~content_encoding:encoding body_str in
146
+
let resp_headers = Headers.remove `Content_encoding resp_headers in
147
(status, resp_headers, body_str)
148
| _ ->
149
(status, resp_headers, body_str)
···
207
(* Error response - server rejected based on headers *)
208
Log.info (fun m -> m "Server rejected request with status %d before body sent" status);
209
let resp_headers = Http_read.headers ~limits buf_read in
210
+
let transfer_encoding = Headers.get `Transfer_encoding resp_headers in
211
+
let content_length = Headers.get `Content_length resp_headers |> Option.map Int64.of_string in
212
let body_str = match transfer_encoding, content_length with
213
| Some te, _ when String.lowercase_ascii te |> String.trim = "chunked" ->
214
Http_read.chunked_body ~limits buf_read
···
254
Expect_continue.enabled expect_100 &&
255
body_len >= Expect_continue.threshold expect_100 &&
256
body_len > 0L &&
257
+
not (Headers.mem `Expect headers) (* Don't override explicit Expect header *)
258
in
259
260
if not use_100_continue then begin
···
268
(* Add Expect: 100-continue header and Content-Type if present *)
269
let headers_with_expect = Headers.expect_100_continue headers in
270
let headers_with_expect = match Body.content_type body with
271
+
| Some mime -> Headers.add `Content_type (Mime.to_string mime) headers_with_expect
272
| None -> headers_with_expect
273
in
274
+4
-4
lib/http_read.ml
+4
-4
lib/http_read.ml
···
679
) else
680
(* Determine how to read body based on headers.
681
Per RFC 9112 Section 6.3: Transfer-Encoding takes precedence over Content-Length *)
682
-
let transfer_encoding = Headers.get "transfer-encoding" hdrs in
683
-
let content_length = parse_content_length (Headers.get "content-length" hdrs) in
684
let body = match is_chunked_encoding transfer_encoding, content_length with
685
| true, Some _ ->
686
(* Both headers present - potential HTTP request smuggling indicator *)
···
722
let hdrs = headers ~limits r in
723
724
(* Determine body type *)
725
-
let transfer_encoding = Headers.get "transfer-encoding" hdrs in
726
-
let content_length = parse_content_length (Headers.get "content-length" hdrs) in
727
728
(* Per RFC 9112 Section 6.3: When both Transfer-Encoding and Content-Length
729
are present, Transfer-Encoding takes precedence. The presence of both
···
679
) else
680
(* Determine how to read body based on headers.
681
Per RFC 9112 Section 6.3: Transfer-Encoding takes precedence over Content-Length *)
682
+
let transfer_encoding = Headers.get `Transfer_encoding hdrs in
683
+
let content_length = parse_content_length (Headers.get `Content_length hdrs) in
684
let body = match is_chunked_encoding transfer_encoding, content_length with
685
| true, Some _ ->
686
(* Both headers present - potential HTTP request smuggling indicator *)
···
722
let hdrs = headers ~limits r in
723
724
(* Determine body type *)
725
+
let transfer_encoding = Headers.get `Transfer_encoding hdrs in
726
+
let content_length = parse_content_length (Headers.get `Content_length hdrs) in
727
728
(* Per RFC 9112 Section 6.3: When both Transfer-Encoding and Content-Length
729
are present, Transfer-Encoding takes precedence. The presence of both
+22
-22
lib/http_write.ml
+22
-22
lib/http_write.ml
···
79
request_line w ~method_ ~uri;
80
81
(* Ensure Host header is present *)
82
-
let hdrs = if not (Headers.mem "host" hdrs) then
83
-
Headers.add "host" (host_value uri) hdrs
84
else hdrs in
85
86
(* Ensure Connection header for keep-alive *)
87
-
let hdrs = if not (Headers.mem "connection" hdrs) then
88
-
Headers.add "connection" "keep-alive" hdrs
89
else hdrs in
90
91
(* Add Content-Length if we have a body length *)
92
let hdrs = match content_length with
93
-
| Some len when len > 0L && not (Headers.mem "content-length" hdrs) ->
94
-
Headers.add "content-length" (Int64.to_string len) hdrs
95
| _ -> hdrs
96
in
97
···
148
149
(* Add Content-Type header if body has one *)
150
let hdrs = match content_type with
151
-
| Some mime when not (Headers.mem "content-type" hdrs) ->
152
-
Headers.add "content-type" (Mime.to_string mime) hdrs
153
| _ -> hdrs
154
in
155
156
(* Determine if we need chunked encoding *)
157
let use_chunked = Body.Private.is_chunked body in
158
159
-
let hdrs = if use_chunked && not (Headers.mem "transfer-encoding" hdrs) then
160
-
Headers.add "transfer-encoding" "chunked" hdrs
161
else hdrs in
162
163
(* Write request line and headers *)
···
213
request_line_absolute w ~method_ ~uri;
214
215
(* Ensure Host header is present *)
216
-
let hdrs = if not (Headers.mem "host" hdrs) then
217
-
Headers.add "host" (host_value uri) hdrs
218
else hdrs in
219
220
(* Ensure Connection header for keep-alive *)
221
-
let hdrs = if not (Headers.mem "connection" hdrs) then
222
-
Headers.add "connection" "keep-alive" hdrs
223
else hdrs in
224
225
(* Add Content-Length if we have a body length *)
226
let hdrs = match content_length with
227
-
| Some len when len > 0L && not (Headers.mem "content-length" hdrs) ->
228
-
Headers.add "content-length" (Int64.to_string len) hdrs
229
| _ -> hdrs
230
in
231
···
233
let hdrs = match proxy_auth with
234
| Some auth ->
235
let auth_headers = Auth.apply auth Headers.empty in
236
-
(match Headers.get "authorization" auth_headers with
237
-
| Some value -> Headers.add "proxy-authorization" value hdrs
238
| None -> hdrs)
239
| None -> hdrs
240
in
···
252
253
(* Add Content-Type header if body has one *)
254
let hdrs = match content_type with
255
-
| Some mime when not (Headers.mem "content-type" hdrs) ->
256
-
Headers.add "content-type" (Mime.to_string mime) hdrs
257
| _ -> hdrs
258
in
259
260
(* Determine if we need chunked encoding *)
261
let use_chunked = Body.Private.is_chunked body in
262
263
-
let hdrs = if use_chunked && not (Headers.mem "transfer-encoding" hdrs) then
264
-
Headers.add "transfer-encoding" "chunked" hdrs
265
else hdrs in
266
267
(* Write request line and headers *)
···
79
request_line w ~method_ ~uri;
80
81
(* Ensure Host header is present *)
82
+
let hdrs = if not (Headers.mem `Host hdrs) then
83
+
Headers.add `Host (host_value uri) hdrs
84
else hdrs in
85
86
(* Ensure Connection header for keep-alive *)
87
+
let hdrs = if not (Headers.mem `Connection hdrs) then
88
+
Headers.add `Connection "keep-alive" hdrs
89
else hdrs in
90
91
(* Add Content-Length if we have a body length *)
92
let hdrs = match content_length with
93
+
| Some len when len > 0L && not (Headers.mem `Content_length hdrs) ->
94
+
Headers.add `Content_length (Int64.to_string len) hdrs
95
| _ -> hdrs
96
in
97
···
148
149
(* Add Content-Type header if body has one *)
150
let hdrs = match content_type with
151
+
| Some mime when not (Headers.mem `Content_type hdrs) ->
152
+
Headers.add `Content_type (Mime.to_string mime) hdrs
153
| _ -> hdrs
154
in
155
156
(* Determine if we need chunked encoding *)
157
let use_chunked = Body.Private.is_chunked body in
158
159
+
let hdrs = if use_chunked && not (Headers.mem `Transfer_encoding hdrs) then
160
+
Headers.add `Transfer_encoding "chunked" hdrs
161
else hdrs in
162
163
(* Write request line and headers *)
···
213
request_line_absolute w ~method_ ~uri;
214
215
(* Ensure Host header is present *)
216
+
let hdrs = if not (Headers.mem `Host hdrs) then
217
+
Headers.add `Host (host_value uri) hdrs
218
else hdrs in
219
220
(* Ensure Connection header for keep-alive *)
221
+
let hdrs = if not (Headers.mem `Connection hdrs) then
222
+
Headers.add `Connection "keep-alive" hdrs
223
else hdrs in
224
225
(* Add Content-Length if we have a body length *)
226
let hdrs = match content_length with
227
+
| Some len when len > 0L && not (Headers.mem `Content_length hdrs) ->
228
+
Headers.add `Content_length (Int64.to_string len) hdrs
229
| _ -> hdrs
230
in
231
···
233
let hdrs = match proxy_auth with
234
| Some auth ->
235
let auth_headers = Auth.apply auth Headers.empty in
236
+
(match Headers.get `Authorization auth_headers with
237
+
| Some value -> Headers.add `Proxy_authorization value hdrs
238
| None -> hdrs)
239
| None -> hdrs
240
in
···
252
253
(* Add Content-Type header if body has one *)
254
let hdrs = match content_type with
255
+
| Some mime when not (Headers.mem `Content_type hdrs) ->
256
+
Headers.add `Content_type (Mime.to_string mime) hdrs
257
| _ -> hdrs
258
in
259
260
(* Determine if we need chunked encoding *)
261
let use_chunked = Body.Private.is_chunked body in
262
263
+
let hdrs = if use_chunked && not (Headers.mem `Transfer_encoding hdrs) then
264
+
Headers.add `Transfer_encoding "chunked" hdrs
265
else hdrs in
266
267
(* Write request line and headers *)
+1
-1
lib/link.ml
+1
-1
lib/link.ml
+6
-6
lib/one.ml
+6
-6
lib/one.ml
···
104
105
(* Add default User-Agent if not already set - per RFC 9110 Section 10.1.5 *)
106
let headers =
107
-
if not (Headers.mem "User-Agent" headers) then
108
-
Headers.set "User-Agent" Version.user_agent headers
109
else
110
headers
111
in
···
123
124
(* Add Accept-Encoding header for auto-decompression if not already set *)
125
let headers =
126
-
if auto_decompress && not (Headers.mem "Accept-Encoding" headers) then
127
-
Headers.set "Accept-Encoding" "gzip, deflate" headers
128
else
129
headers
130
in
···
185
let _version, status, resp_headers, body_str =
186
Http_read.response ~limits ~method_ buf_read in
187
(* Handle decompression if enabled *)
188
-
let body_str = match auto_decompress, Headers.get "content-encoding" resp_headers with
189
| true, Some encoding ->
190
Http_client.decompress_body ~limits ~content_encoding:encoding body_str
191
| _ -> body_str
···
237
raise (Error.err (Error.Too_many_redirects { url; count = max_redirects; max = max_redirects }))
238
end;
239
240
-
match Headers.get "location" resp_headers with
241
| None ->
242
Log.debug (fun m -> m "Redirect response missing Location header");
243
(status, resp_headers, response_body_str, url_to_fetch)
···
104
105
(* Add default User-Agent if not already set - per RFC 9110 Section 10.1.5 *)
106
let headers =
107
+
if not (Headers.mem `User_agent headers) then
108
+
Headers.set `User_agent Version.user_agent headers
109
else
110
headers
111
in
···
123
124
(* Add Accept-Encoding header for auto-decompression if not already set *)
125
let headers =
126
+
if auto_decompress && not (Headers.mem `Accept_encoding headers) then
127
+
Headers.set `Accept_encoding "gzip, deflate" headers
128
else
129
headers
130
in
···
185
let _version, status, resp_headers, body_str =
186
Http_read.response ~limits ~method_ buf_read in
187
(* Handle decompression if enabled *)
188
+
let body_str = match auto_decompress, Headers.get `Content_encoding resp_headers with
189
| true, Some encoding ->
190
Http_client.decompress_body ~limits ~content_encoding:encoding body_str
191
| _ -> body_str
···
237
raise (Error.err (Error.Too_many_redirects { url; count = max_redirects; max = max_redirects }))
238
end;
239
240
+
match Headers.get `Location resp_headers with
241
| None ->
242
Log.debug (fun m -> m "Redirect response missing Location header");
243
(status, resp_headers, response_body_str, url_to_fetch)
+1
-1
lib/proxy_tunnel.ml
+1
-1
lib/proxy_tunnel.ml
+4
-4
lib/redirect.ml
+4
-4
lib/redirect.ml
···
37
Per Recommendation #1: Also strip Cookie, Proxy-Authorization, WWW-Authenticate *)
38
let strip_sensitive_headers headers =
39
headers
40
-
|> Headers.remove "Authorization"
41
-
|> Headers.remove "Cookie"
42
-
|> Headers.remove "Proxy-Authorization"
43
-
|> Headers.remove "WWW-Authenticate"
44
45
(** {1 Redirect URL Validation} *)
46
···
37
Per Recommendation #1: Also strip Cookie, Proxy-Authorization, WWW-Authenticate *)
38
let strip_sensitive_headers headers =
39
headers
40
+
|> Headers.remove `Authorization
41
+
|> Headers.remove `Cookie
42
+
|> Headers.remove `Proxy_authorization
43
+
|> Headers.remove `Www_authenticate
44
45
(** {1 Redirect URL Validation} *)
46
+18
-17
lib/requests.ml
+18
-17
lib/requests.ml
···
199
}
200
201
let set_default_header (T t) key value =
202
-
T { t with default_headers = Headers.set key value t.default_headers }
203
204
let remove_default_header (T t) key =
205
-
T { t with default_headers = Headers.remove key t.default_headers }
206
207
let set_auth (T t) auth =
208
Log.debug (fun m -> m "Setting authentication method");
···
322
match xsrf_value with
323
| Some token ->
324
Log.debug (fun m -> m "Adding XSRF token header: %s" xsrf_header_name);
325
-
Headers.set xsrf_header_name token headers
326
| None -> headers
327
328
(* Internal request function using connection pools *)
···
347
348
(* Add default User-Agent if not already set - per RFC 9110 Section 10.1.5 *)
349
let headers =
350
-
if not (Headers.mem "User-Agent" headers) then
351
-
Headers.set "User-Agent" Version.user_agent headers
352
else
353
headers
354
in
···
388
389
(* Add Accept-Encoding header for auto-decompression if not already set *)
390
let base_headers =
391
-
if t.auto_decompress && not (Headers.mem "Accept-Encoding" base_headers) then
392
-
Headers.set "Accept-Encoding" "gzip, deflate" base_headers
393
else
394
base_headers
395
in
···
403
let cookie_domain = Uri.host uri |> Option.value ~default:"" in
404
let cookie_path = Uri.path uri in
405
Eio.Mutex.use_rw ~protect:true t.cookie_mutex (fun () ->
406
-
match Headers.get_all "Set-Cookie" resp_headers with
407
| [] -> ()
408
| cookie_headers ->
409
Log.debug (fun m -> m "Received %d Set-Cookie headers" (List.length cookie_headers));
···
473
let cookie_header = Cookeio.make_cookie_header cookies in
474
Log.debug (fun m -> m "Adding %d cookies for %s%s: Cookie: %s"
475
(List.length cookies) fetch_domain fetch_path cookie_header);
476
-
Headers.set "Cookie" cookie_header headers_for_request
477
)
478
in
479
···
526
let _version, status, resp_headers, body_str =
527
Http_read.response ~limits ~method_ buf_read in
528
(* Handle decompression if enabled *)
529
-
let body_str = match t.auto_decompress, Headers.get "content-encoding" resp_headers with
530
| true, Some encoding ->
531
Http_client.decompress_body ~limits ~content_encoding:encoding body_str
532
| _ -> body_str
···
600
raise (Error.err (Error.Too_many_redirects { url; count = max_redir; max = max_redir }))
601
end;
602
603
-
match Headers.get "location" resp_headers with
604
| None ->
605
Log.debug (fun m -> m "Redirect response missing Location header");
606
(status, resp_headers, response_body_str, url_to_fetch)
···
707
match Auth.get_digest_credentials auth_to_use with
708
| Some (username, password) ->
709
(* RFC 7235: 401 uses WWW-Authenticate, 407 uses Proxy-Authenticate *)
710
-
let challenge_header = if status = 401 then "www-authenticate" else "proxy-authenticate" in
711
-
let auth_header_name = if status = 401 then "Authorization" else "Proxy-Authorization" in
712
(match Response.header challenge_header response with
713
| Some www_auth ->
714
(match Auth.parse_www_authenticate www_auth with
···
730
Headers.empty
731
in
732
(* Get the auth value and set it on the correct header name *)
733
-
let auth_headers = match Headers.get "Authorization" auth_value with
734
| Some v -> Headers.set auth_header_name v base_headers
735
| None -> base_headers
736
in
···
738
make_request_internal wrapped_t ~headers:auth_headers ?body ~auth:Auth.none ?timeout
739
?follow_redirects ?max_redirects ~method_ url
740
| None ->
741
-
Log.warn (fun m -> m "Could not parse Digest challenge from %s" challenge_header);
742
response)
743
| None ->
744
-
Log.warn (fun m -> m "%d response has no %s header" status challenge_header);
745
response)
746
| None -> response
747
end else
···
789
(* Per Recommendation #4: Use Retry-After header when available *)
790
let delay =
791
if retry_config.respect_retry_after && (status = 429 || status = 503) then
792
-
match Response.header "retry-after" response with
793
| Some value ->
794
Retry.parse_retry_after value
795
|> Option.value ~default:(Retry.calculate_backoff ~config:retry_config ~attempt)
···
199
}
200
201
let set_default_header (T t) key value =
202
+
T { t with default_headers = Headers.set (Header_name.of_string key) value t.default_headers }
203
204
let remove_default_header (T t) key =
205
+
T { t with default_headers = Headers.remove (Header_name.of_string key) t.default_headers }
206
207
let set_auth (T t) auth =
208
Log.debug (fun m -> m "Setting authentication method");
···
322
match xsrf_value with
323
| Some token ->
324
Log.debug (fun m -> m "Adding XSRF token header: %s" xsrf_header_name);
325
+
(* XSRF header name is configurable, use string variant *)
326
+
Headers.set_string xsrf_header_name token headers
327
| None -> headers
328
329
(* Internal request function using connection pools *)
···
348
349
(* Add default User-Agent if not already set - per RFC 9110 Section 10.1.5 *)
350
let headers =
351
+
if not (Headers.mem `User_agent headers) then
352
+
Headers.set `User_agent Version.user_agent headers
353
else
354
headers
355
in
···
389
390
(* Add Accept-Encoding header for auto-decompression if not already set *)
391
let base_headers =
392
+
if t.auto_decompress && not (Headers.mem `Accept_encoding base_headers) then
393
+
Headers.set `Accept_encoding "gzip, deflate" base_headers
394
else
395
base_headers
396
in
···
404
let cookie_domain = Uri.host uri |> Option.value ~default:"" in
405
let cookie_path = Uri.path uri in
406
Eio.Mutex.use_rw ~protect:true t.cookie_mutex (fun () ->
407
+
match Headers.get_all `Set_cookie resp_headers with
408
| [] -> ()
409
| cookie_headers ->
410
Log.debug (fun m -> m "Received %d Set-Cookie headers" (List.length cookie_headers));
···
474
let cookie_header = Cookeio.make_cookie_header cookies in
475
Log.debug (fun m -> m "Adding %d cookies for %s%s: Cookie: %s"
476
(List.length cookies) fetch_domain fetch_path cookie_header);
477
+
Headers.set `Cookie cookie_header headers_for_request
478
)
479
in
480
···
527
let _version, status, resp_headers, body_str =
528
Http_read.response ~limits ~method_ buf_read in
529
(* Handle decompression if enabled *)
530
+
let body_str = match t.auto_decompress, Headers.get `Content_encoding resp_headers with
531
| true, Some encoding ->
532
Http_client.decompress_body ~limits ~content_encoding:encoding body_str
533
| _ -> body_str
···
601
raise (Error.err (Error.Too_many_redirects { url; count = max_redir; max = max_redir }))
602
end;
603
604
+
match Headers.get `Location resp_headers with
605
| None ->
606
Log.debug (fun m -> m "Redirect response missing Location header");
607
(status, resp_headers, response_body_str, url_to_fetch)
···
708
match Auth.get_digest_credentials auth_to_use with
709
| Some (username, password) ->
710
(* RFC 7235: 401 uses WWW-Authenticate, 407 uses Proxy-Authenticate *)
711
+
let challenge_header : Header_name.t = if status = 401 then `Www_authenticate else `Proxy_authenticate in
712
+
let auth_header_name : Header_name.t = if status = 401 then `Authorization else `Proxy_authorization in
713
(match Response.header challenge_header response with
714
| Some www_auth ->
715
(match Auth.parse_www_authenticate www_auth with
···
731
Headers.empty
732
in
733
(* Get the auth value and set it on the correct header name *)
734
+
let auth_headers = match Headers.get `Authorization auth_value with
735
| Some v -> Headers.set auth_header_name v base_headers
736
| None -> base_headers
737
in
···
739
make_request_internal wrapped_t ~headers:auth_headers ?body ~auth:Auth.none ?timeout
740
?follow_redirects ?max_redirects ~method_ url
741
| None ->
742
+
Log.warn (fun m -> m "Could not parse Digest challenge from %s" (Header_name.to_string challenge_header));
743
response)
744
| None ->
745
+
Log.warn (fun m -> m "%d response has no %s header" status (Header_name.to_string challenge_header));
746
response)
747
| None -> response
748
end else
···
790
(* Per Recommendation #4: Use Retry-After header when available *)
791
let delay =
792
if retry_config.respect_retry_after && (status = 429 || status = 503) then
793
+
match Response.header `Retry_after response with
794
| Some value ->
795
Retry.parse_retry_after value
796
|> Option.value ~default:(Retry.calculate_backoff ~config:retry_config ~attempt)
+13
-11
lib/response.ml
+13
-11
lib/response.ml
···
43
44
let header name t = Headers.get name t.headers
45
46
(** Option monad operators for cleaner code *)
47
let ( let* ) = Option.bind
48
let ( let+ ) x f = Option.map f x
49
50
let content_type t =
51
-
let+ ct = Headers.get "content-type" t.headers in
52
Mime.of_string ct
53
54
let content_length t =
55
-
let* len = Headers.get "content-length" t.headers in
56
try Some (Int64.of_string len) with _ -> None
57
58
-
let location t = Headers.get "location" t.headers
59
60
(** {1 Conditional Request / Caching Headers}
61
62
Per Recommendation #19: Conditional Request Helpers (ETag/Last-Modified)
63
RFC 9110 Section 8.8.2-8.8.3 *)
64
65
-
let etag t = Headers.get "etag" t.headers
66
67
-
let last_modified t = Headers.get "last-modified" t.headers
68
69
let parse_http_date = Http_date.parse
70
···
72
let* lm = last_modified t in
73
Http_date.parse lm
74
75
-
let date t = Headers.get "date" t.headers
76
77
let date_ptime t =
78
let* d = date t in
79
Http_date.parse d
80
81
-
let expires t = Headers.get "expires" t.headers
82
83
let expires_ptime t =
84
let* exp = expires t in
85
Http_date.parse exp
86
87
let age t =
88
-
let* s = Headers.get "age" t.headers in
89
try Some (int_of_string s) with _ -> None
90
91
(** {1 Cache-Control Parsing}
···
93
Per Recommendation #17: Response Caching with RFC 7234/9111 Compliance *)
94
95
let cache_control t =
96
-
Option.map Cache_control.parse_response (Headers.get "cache-control" t.headers)
97
98
-
let cache_control_raw t = Headers.get "cache-control" t.headers
99
100
(** Check if response is cacheable based on status and Cache-Control *)
101
let is_cacheable t =
···
141
let is_not_modified t = t.status = 304
142
143
(** Get the Vary header which indicates which request headers affect caching *)
144
-
let vary t = Headers.get "vary" t.headers
145
146
(** Parse Vary header into list of header names *)
147
let vary_headers t =
···
43
44
let header name t = Headers.get name t.headers
45
46
+
let header_string name t = Headers.get_string name t.headers
47
+
48
(** Option monad operators for cleaner code *)
49
let ( let* ) = Option.bind
50
let ( let+ ) x f = Option.map f x
51
52
let content_type t =
53
+
let+ ct = Headers.get `Content_type t.headers in
54
Mime.of_string ct
55
56
let content_length t =
57
+
let* len = Headers.get `Content_length t.headers in
58
try Some (Int64.of_string len) with _ -> None
59
60
+
let location t = Headers.get `Location t.headers
61
62
(** {1 Conditional Request / Caching Headers}
63
64
Per Recommendation #19: Conditional Request Helpers (ETag/Last-Modified)
65
RFC 9110 Section 8.8.2-8.8.3 *)
66
67
+
let etag t = Headers.get `Etag t.headers
68
69
+
let last_modified t = Headers.get `Last_modified t.headers
70
71
let parse_http_date = Http_date.parse
72
···
74
let* lm = last_modified t in
75
Http_date.parse lm
76
77
+
let date t = Headers.get `Date t.headers
78
79
let date_ptime t =
80
let* d = date t in
81
Http_date.parse d
82
83
+
let expires t = Headers.get `Expires t.headers
84
85
let expires_ptime t =
86
let* exp = expires t in
87
Http_date.parse exp
88
89
let age t =
90
+
let* s = Headers.get `Age t.headers in
91
try Some (int_of_string s) with _ -> None
92
93
(** {1 Cache-Control Parsing}
···
95
Per Recommendation #17: Response Caching with RFC 7234/9111 Compliance *)
96
97
let cache_control t =
98
+
Option.map Cache_control.parse_response (Headers.get `Cache_control t.headers)
99
100
+
let cache_control_raw t = Headers.get `Cache_control t.headers
101
102
(** Check if response is cacheable based on status and Cache-Control *)
103
let is_cacheable t =
···
143
let is_not_modified t = t.status = 304
144
145
(** Get the Vary header which indicates which request headers affect caching *)
146
+
let vary t = Headers.get `Vary t.headers
147
148
(** Parse Vary header into list of header names *)
149
let vary_headers t =
+8
-1
lib/response.mli
+8
-1
lib/response.mli
···
66
val headers : t -> Headers.t
67
(** [headers response] returns all response headers. *)
68
69
-
val header : string -> t -> string option
70
(** [header name response] returns the value of a specific header, or [None] if not present.
71
Header names are case-insensitive. *)
72
73
val content_type : t -> Mime.t option
···
66
val headers : t -> Headers.t
67
(** [headers response] returns all response headers. *)
68
69
+
val header : Header_name.t -> t -> string option
70
(** [header name response] returns the value of a specific header, or [None] if not present.
71
+
Header names are case-insensitive.
72
+
73
+
Example: [header `Content_type response] *)
74
+
75
+
val header_string : string -> t -> string option
76
+
(** [header_string name response] returns the value of a header by string name.
77
+
Use this when header names come from external sources (e.g., wire format).
78
Header names are case-insensitive. *)
79
80
val content_type : t -> Mime.t option