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