ocaml http/1, http/2 and websocket client and server library
gdiazlo.tngl.sh
1(** Unified HTTP Client supporting HTTP/1.1 and HTTP/2.
2
3 This module provides a high-level HTTP client that automatically selects the
4 appropriate protocol based on ALPN negotiation or configuration. Connections
5 are pooled for high performance. *)
6
7type protocol = HTTP_1_1 | HTTP_2
8
9type config = {
10 connect_timeout : float;
11 read_timeout : float;
12 write_timeout : float;
13 follow_redirects : int option;
14 preferred_protocol : protocol option;
15 buffer_size : int;
16 max_response_body : int64 option;
17 tls : Tls_config.Client.t;
18 default_headers : (string * string) list;
19 pool : Pool.config;
20}
21
22let default_config =
23 {
24 connect_timeout = 30.0;
25 read_timeout = 30.0;
26 write_timeout = 30.0;
27 follow_redirects = Some 10;
28 preferred_protocol = Some HTTP_1_1;
29 buffer_size = 16384;
30 max_response_body = None;
31 tls = Tls_config.Client.default;
32 default_headers = [ ("User-Agent", "hcs/" ^ Build_info.version) ];
33 pool = Pool.default_config;
34 }
35
36let with_timeout timeout config =
37 { config with connect_timeout = timeout; read_timeout = timeout }
38
39let with_connect_timeout timeout config =
40 { config with connect_timeout = timeout }
41
42let with_read_timeout timeout config = { config with read_timeout = timeout }
43let with_write_timeout timeout config = { config with write_timeout = timeout }
44
45let with_redirects max_redirects config =
46 { config with follow_redirects = Some max_redirects }
47
48let without_redirects config = { config with follow_redirects = None }
49let with_buffer_size size config = { config with buffer_size = size }
50
51let with_max_response_body max_size config =
52 { config with max_response_body = Some max_size }
53
54let with_tls tls config = { config with tls }
55let with_insecure_tls config = { config with tls = Tls_config.Client.insecure }
56
57let with_http2 config =
58 { config with preferred_protocol = Some HTTP_2; tls = Tls_config.Client.h2 }
59
60let with_http11 config =
61 {
62 config with
63 preferred_protocol = Some HTTP_1_1;
64 tls = Tls_config.Client.default;
65 }
66
67let with_default_header name value config =
68 { config with default_headers = (name, value) :: config.default_headers }
69
70let with_default_headers headers config =
71 { config with default_headers = headers @ config.default_headers }
72
73let with_pool_config pool config = { config with pool }
74
75let with_max_connections max_conn config =
76 {
77 config with
78 pool = { config.pool with max_connections_per_host = max_conn };
79 }
80
81type error =
82 | Connection_failed of string
83 | Tls_error of string
84 | Protocol_error of string
85 | Timeout
86 | Invalid_response of string
87 | Too_many_redirects
88
89type response = {
90 status : int;
91 headers : (string * string) list;
92 body : string;
93 protocol : protocol;
94}
95
96type t = { config : config; h1_client : H1_client.t; h2_client : H2_client.t }
97
98let h1_status_to_int status = H1.Status.to_code status
99let h2_status_to_int status = H2.Status.to_code status
100
101let h1_headers_to_list headers =
102 let result = ref [] in
103 H1.Headers.iter
104 ~f:(fun name value -> result := (name, value) :: !result)
105 headers;
106 List.rev !result
107
108let h2_headers_to_list headers =
109 let result = ref [] in
110 H2.Headers.iter
111 ~f:(fun name value -> result := (name, value) :: !result)
112 headers;
113 List.rev !result
114
115let create ~sw ~net ~clock ?(config = default_config) () =
116 let h1_config : H1_client.config =
117 {
118 connect_timeout = config.connect_timeout;
119 read_timeout = config.read_timeout;
120 write_timeout = config.write_timeout;
121 follow_redirects = config.follow_redirects;
122 buffer_size = config.buffer_size;
123 max_response_body = config.max_response_body;
124 tls = config.tls;
125 default_headers = config.default_headers;
126 pool = config.pool;
127 }
128 in
129 let h2_config : H2_client.config =
130 {
131 connect_timeout = config.connect_timeout;
132 read_timeout = config.read_timeout;
133 buffer_size = config.buffer_size;
134 default_headers = config.default_headers;
135 pool = config.pool;
136 }
137 in
138 {
139 config;
140 h1_client = H1_client.create ~sw ~net ~clock ~config:h1_config ();
141 h2_client = H2_client.create ~sw ~net ~clock ~config:h2_config ();
142 }
143
144let close t =
145 H1_client.close t.h1_client;
146 H2_client.close t.h2_client
147
148let should_use_h2 config url =
149 let uri = Uri.of_string url in
150 let scheme = Uri.scheme uri |> Option.value ~default:"http" in
151 let is_https = String.equal scheme "https" in
152 match config.preferred_protocol with
153 | Some HTTP_2 -> true
154 | Some HTTP_1_1 -> false
155 | None -> (
156 is_https
157 &&
158 match config.tls.alpn_protocols with
159 | Some protos -> List.mem Tls_config.alpn_h2 protos
160 | None -> false)
161
162let map_h1_error = function
163 | H1_client.Connection_failed msg -> Connection_failed msg
164 | H1_client.Tls_error msg -> Tls_error msg
165 | H1_client.Timeout -> Timeout
166 | H1_client.Invalid_response msg -> Invalid_response msg
167 | H1_client.Too_many_redirects -> Too_many_redirects
168
169let map_h2_error = function
170 | H2_client.Connection_failed msg -> Connection_failed msg
171 | H2_client.Tls_error msg -> Tls_error msg
172 | H2_client.Protocol_error msg -> Protocol_error msg
173 | H2_client.Timeout -> Timeout
174 | H2_client.Invalid_response msg -> Invalid_response msg
175
176let request t url =
177 if should_use_h2 t.config url then
178 match H2_client.get t.h2_client url with
179 | Ok resp ->
180 Ok
181 {
182 status = h2_status_to_int resp.H2_client.status;
183 headers = h2_headers_to_list resp.headers;
184 body = resp.body;
185 protocol = HTTP_2;
186 }
187 | Error e -> Error (map_h2_error e)
188 else
189 match H1_client.get t.h1_client url with
190 | Ok resp ->
191 Ok
192 {
193 status = h1_status_to_int resp.H1_client.status;
194 headers = h1_headers_to_list resp.headers;
195 body = resp.body;
196 protocol = HTTP_1_1;
197 }
198 | Error e -> Error (map_h1_error e)
199
200let request_post t url ~body:request_body =
201 if should_use_h2 t.config url then
202 match H2_client.post t.h2_client url ~body:request_body with
203 | Ok resp ->
204 Ok
205 {
206 status = h2_status_to_int resp.H2_client.status;
207 headers = h2_headers_to_list resp.headers;
208 body = resp.body;
209 protocol = HTTP_2;
210 }
211 | Error e -> Error (map_h2_error e)
212 else
213 match H1_client.post t.h1_client url ~body:request_body with
214 | Ok resp ->
215 Ok
216 {
217 status = h1_status_to_int resp.H1_client.status;
218 headers = h1_headers_to_list resp.headers;
219 body = resp.body;
220 protocol = HTTP_1_1;
221 }
222 | Error e -> Error (map_h1_error e)
223
224let get ~sw ~net ~clock ?(config = default_config) url =
225 let t = create ~sw ~net ~clock ~config () in
226 let result = request t url in
227 close t;
228 result
229
230let post ~sw ~net ~clock ?(config = default_config) url ~body =
231 let t = create ~sw ~net ~clock ~config () in
232 let result = request_post t url ~body in
233 close t;
234 result