ocaml http/1, http/2 and websocket client and server library
gdiazlo.tngl.sh
1(** Response types and helper functions.
2
3 This module provides the canonical HTTP response type used throughout HCS.
4 It works with both HTTP/1.1 and HTTP/2 protocols. *)
5
6(** {1 Pre-built Responses}
7
8 Pre-built responses for zero-allocation hot paths. Create once at startup,
9 respond many times without allocation. *)
10module Prebuilt = struct
11 type t = {
12 status : H1.Status.t;
13 headers : H1.Headers.t;
14 body : Bigstringaf.t;
15 cached_h1_response : H1.Response.t Atomic.t;
16 cached_second : int Atomic.t;
17 }
18
19 let create ~status ?(headers = []) body_str =
20 let body =
21 Bigstringaf.of_string ~off:0 ~len:(String.length body_str) body_str
22 in
23 let body_len = Bigstringaf.length body in
24 let all_headers = ("content-length", string_of_int body_len) :: headers in
25 let h1_headers = H1.Headers.of_list all_headers in
26 let now = int_of_float (Unix.gettimeofday ()) in
27 let headers_with_date =
28 H1.Headers.add h1_headers "date" (Date_cache.get ())
29 in
30 let cached_resp = H1.Response.create ~headers:headers_with_date status in
31 {
32 status;
33 headers = h1_headers;
34 body;
35 cached_h1_response = Atomic.make cached_resp;
36 cached_second = Atomic.make now;
37 }
38
39 let create_bigstring ~status ?(headers = []) body =
40 let body_len = Bigstringaf.length body in
41 let all_headers = ("content-length", string_of_int body_len) :: headers in
42 let h1_headers = H1.Headers.of_list all_headers in
43 let now = int_of_float (Unix.gettimeofday ()) in
44 let headers_with_date =
45 H1.Headers.add h1_headers "date" (Date_cache.get ())
46 in
47 let cached_resp = H1.Response.create ~headers:headers_with_date status in
48 {
49 status;
50 headers = h1_headers;
51 body;
52 cached_h1_response = Atomic.make cached_resp;
53 cached_second = Atomic.make now;
54 }
55
56 let[@inline] get_cached_h1_response t =
57 let now = int_of_float (Unix.gettimeofday ()) in
58 let last = Atomic.get t.cached_second in
59 if now <> last then begin
60 let headers = H1.Headers.add t.headers "date" (Date_cache.get ()) in
61 let resp = H1.Response.create ~headers t.status in
62 Atomic.set t.cached_h1_response resp;
63 Atomic.set t.cached_second now
64 end;
65 Atomic.get t.cached_h1_response
66
67 let[@inline] respond_h1 reqd t =
68 let response = get_cached_h1_response t in
69 H1.Reqd.respond_with_bigstring reqd response t.body
70
71 let[@inline] respond_h2 reqd t =
72 let result = ref [] in
73 H1.Headers.iter
74 ~f:(fun name value -> result := (name, value) :: !result)
75 t.headers;
76 let h2_headers = H2.Headers.of_list (List.rev !result) in
77 let h2_status = (t.status :> H2.Status.t) in
78 let response = H2.Response.create ~headers:h2_headers h2_status in
79 H2.Reqd.respond_with_bigstring reqd response t.body
80end
81
82(** {1 Types} *)
83
84type body =
85 | Empty
86 | String of string
87 | Cstruct of Cstruct.t
88 | Bigstring of Bigstringaf.t
89 | Stream of { content_length : int64 option; next : unit -> Cstruct.t option }
90 | Prebuilt_body of Prebuilt.t
91
92type t = { status : H1.Status.t; headers : (string * string) list; body : body }
93
94(** {1 Basic Constructors} *)
95
96let make ?(status = `OK) ?(headers = []) body_str : t =
97 { status; headers; body = String body_str }
98
99let empty ?(status = `No_content) ?(headers = []) () : t =
100 { status; headers; body = Empty }
101
102(** {1 Status shortcuts - 2xx Success} *)
103
104let ok ?(headers = []) body : t = { status = `OK; headers; body = String body }
105
106let created ?(headers = []) ?location body : t =
107 let headers =
108 match location with
109 | Some loc -> ("Location", loc) :: headers
110 | None -> headers
111 in
112 { status = `Created; headers; body = String body }
113
114let accepted ?(headers = []) body : t =
115 { status = `Accepted; headers; body = String body }
116
117let no_content ?(headers = []) () : t =
118 { status = `No_content; headers; body = Empty }
119
120(** {1 Status shortcuts - 3xx Redirection} *)
121
122let redirect ?(permanent = false) ?(headers = []) location : t =
123 let status = if permanent then `Moved_permanently else `Found in
124 { status; headers = ("Location", location) :: headers; body = Empty }
125
126let moved_permanently ?(headers = []) location : t =
127 redirect ~permanent:true ~headers location
128
129let found ?(headers = []) location : t =
130 redirect ~permanent:false ~headers location
131
132let see_other ?(headers = []) location : t =
133 {
134 status = `See_other;
135 headers = ("Location", location) :: headers;
136 body = Empty;
137 }
138
139let temporary_redirect ?(headers = []) location : t =
140 {
141 status = `Temporary_redirect;
142 headers = ("Location", location) :: headers;
143 body = Empty;
144 }
145
146let not_modified ?(headers = []) () : t =
147 { status = `Not_modified; headers; body = Empty }
148
149(** {1 Status shortcuts - 4xx Client Errors} *)
150
151let bad_request ?(headers = []) ?(body = "Bad Request") () : t =
152 { status = `Bad_request; headers; body = String body }
153
154let unauthorized ?(headers = []) ?www_authenticate () : t =
155 let headers =
156 match www_authenticate with
157 | Some auth -> ("WWW-Authenticate", auth) :: headers
158 | None -> headers
159 in
160 { status = `Unauthorized; headers; body = String "Unauthorized" }
161
162let forbidden ?(headers = []) ?(body = "Forbidden") () : t =
163 { status = `Forbidden; headers; body = String body }
164
165let not_found ?(headers = []) ?(body = "Not Found") () : t =
166 { status = `Not_found; headers; body = String body }
167
168let method_not_allowed ?(headers = []) ~allowed () : t =
169 let allow_header =
170 String.concat ", " (List.map H1.Method.to_string allowed)
171 in
172 {
173 status = `Method_not_allowed;
174 headers = ("Allow", allow_header) :: headers;
175 body = String "Method Not Allowed";
176 }
177
178let conflict ?(headers = []) ?(body = "Conflict") () : t =
179 { status = `Conflict; headers; body = String body }
180
181let gone ?(headers = []) ?(body = "Gone") () : t =
182 { status = `Gone; headers; body = String body }
183
184let unprocessable_entity ?(headers = []) ?(body = "Unprocessable Entity") () : t
185 =
186 { status = `Code 422; headers; body = String body }
187
188let too_many_requests ?(headers = []) ?retry_after () : t =
189 let headers =
190 match retry_after with
191 | Some secs -> ("Retry-After", string_of_int secs) :: headers
192 | None -> headers
193 in
194 { status = `Code 429; headers; body = String "Too Many Requests" }
195
196(** {1 Status shortcuts - 5xx Server Errors} *)
197
198let internal_error ?(headers = []) ?(body = "Internal Server Error") () : t =
199 { status = `Internal_server_error; headers; body = String body }
200
201let not_implemented ?(headers = []) ?(body = "Not Implemented") () : t =
202 { status = `Not_implemented; headers; body = String body }
203
204let bad_gateway ?(headers = []) ?(body = "Bad Gateway") () : t =
205 { status = `Bad_gateway; headers; body = String body }
206
207let service_unavailable ?(headers = []) ?retry_after () : t =
208 let headers =
209 match retry_after with
210 | Some secs -> ("Retry-After", string_of_int secs) :: headers
211 | None -> headers
212 in
213 {
214 status = `Service_unavailable;
215 headers;
216 body = String "Service Unavailable";
217 }
218
219let gateway_timeout ?(headers = []) ?(body = "Gateway Timeout") () : t =
220 { status = `Gateway_timeout; headers; body = String body }
221
222(** {1 Content-Type helpers} *)
223
224let text ?(status = `OK) body : t =
225 {
226 status;
227 headers = [ ("Content-Type", "text/plain; charset=utf-8") ];
228 body = String body;
229 }
230
231let html ?(status = `OK) body : t =
232 {
233 status;
234 headers = [ ("Content-Type", "text/html; charset=utf-8") ];
235 body = String body;
236 }
237
238let json ?(status = `OK) body : t =
239 {
240 status;
241 headers = [ ("Content-Type", "application/json; charset=utf-8") ];
242 body = String body;
243 }
244
245let xml ?(status = `OK) body : t =
246 {
247 status;
248 headers = [ ("Content-Type", "application/xml; charset=utf-8") ];
249 body = String body;
250 }
251
252(** {1 Streaming and special responses} *)
253
254let stream ?(status = `OK) ?(headers = []) ?content_length next : t =
255 { status; headers; body = Stream { content_length; next } }
256
257let bigstring ?(status = `OK) ?(headers = []) bstr : t =
258 { status; headers; body = Bigstring bstr }
259
260let cstruct ?(status = `OK) ?(headers = []) cs : t =
261 { status; headers; body = Cstruct cs }
262
263let prebuilt p : t =
264 { status = p.Prebuilt.status; headers = []; body = Prebuilt_body p }
265
266(** {1 Response modifiers} *)
267
268let with_header name value (resp : t) : t =
269 { resp with headers = (name, value) :: resp.headers }
270
271let with_headers headers (resp : t) : t =
272 { resp with headers = headers @ resp.headers }
273
274let with_body body_str (resp : t) : t = { resp with body = String body_str }
275let with_body_raw body (resp : t) : t = { resp with body }
276let with_status status (resp : t) : t = { resp with status }
277
278let with_content_type content_type resp =
279 with_header "Content-Type" content_type resp
280
281let with_cache_control directive resp =
282 with_header "Cache-Control" directive resp
283
284let with_no_cache resp =
285 resp
286 |> with_header "Cache-Control" "no-store, no-cache, must-revalidate"
287 |> with_header "Pragma" "no-cache"
288
289let with_cors ?(origin = "*") ?(methods = "GET, POST, PUT, DELETE, OPTIONS")
290 ?(headers = "Content-Type, Authorization") resp =
291 resp
292 |> with_header "Access-Control-Allow-Origin" origin
293 |> with_header "Access-Control-Allow-Methods" methods
294 |> with_header "Access-Control-Allow-Headers" headers
295
296(** {1 Cookie helpers} *)
297
298let with_cookie ?(path = "/") ?(http_only = true) ?(secure = false)
299 ?(same_site = "Lax") ?max_age name value resp =
300 let buf = Buffer.create 128 in
301 Buffer.add_string buf name;
302 Buffer.add_char buf '=';
303 Buffer.add_string buf value;
304 Buffer.add_string buf "; Path=";
305 Buffer.add_string buf path;
306 if http_only then Buffer.add_string buf "; HttpOnly";
307 if secure then Buffer.add_string buf "; Secure";
308 Buffer.add_string buf "; SameSite=";
309 Buffer.add_string buf same_site;
310 (match max_age with
311 | None -> ()
312 | Some age ->
313 Buffer.add_string buf "; Max-Age=";
314 Buffer.add_string buf (string_of_int age));
315 with_header "Set-Cookie" (Buffer.contents buf) resp
316
317let clear_cookie ?(path = "/") name resp =
318 with_cookie ~path ~max_age:0 name "" resp