1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
open Monads
let src = Logs.Src.create "piaf.server" ~doc:"Piaf Server module"
module Log = (val Logs.src_log src : Logs.LOG)
module Reqd = Httpaf.Reqd
module Service = struct
type ('req, 'resp) t = 'req -> 'resp Lwt.t
end
module Middleware = struct
type ('req, 'resp, 'req', 'resp') t =
('req, 'resp) Service.t -> ('req', 'resp') Service.t
type ('req, 'resp) simple = ('req, 'resp, 'req, 'resp) t
end
module Handler = struct
type 'ctx ctx =
{ ctx : 'ctx
; request : Request.t
}
type 'ctx t = ('ctx ctx, Response.t) Service.t
let not_found _ =
Lwt.return
(Response.of_string
~body:"<html><body><h1>404 - Not found</h1></body></html>"
`Not_found)
end
include Handler
module Error_response = struct
type t = unit
end
let make_error_handler error_handler client_addr ?request error start_response =
let respond ~ body =
let =
Headers.add_length_related_headers ~body_length:(Body.length body) headers
in
let response_body = start_response (Headers.to_http1 headers) in
match Body.contents body with
| `Empty _ ->
Httpaf.Body.close_writer response_body
| `String s ->
Httpaf.Body.write_string response_body s;
Httpaf.Body.close_writer response_body
| `Bigstring { IOVec.buffer; off; len } ->
Httpaf.Body.write_bigstring response_body ~off ~len buffer;
Httpaf.Body.close_writer response_body
| `Stream stream ->
Body.stream_write_body (module Http1.Body) response_body stream
in
let request = Option.map Request.of_http1 request in
Lwt.async (fun () ->
Log.err (fun m ->
m
"Error handler called with error: %a%a"
Error.pp_hum
error
(Format.pp_print_option (fun fmt request ->
Format.fprintf fmt "; Request: @?%a" Request.pp_hum request))
request);
error_handler client_addr ?request ~respond error)
let default_error_handler
_client_addr ?request:_ ~respond (_error : Httpaf.Server_connection.error)
=
respond ~headers:(Headers.of_list [ "connection", "close" ]) Body.empty;
Lwt.return_unit
let report_exn reqd exn =
Log.err (fun m ->
let raw_backtrace = Printexc.get_raw_backtrace () in
m
"Exception while handling request: %s.@]@;<0 2>@[<v 0>%a@]"
(Printexc.to_string exn)
Util.Backtrace.pp_hum
raw_backtrace);
Reqd.report_exn reqd exn
let request_handler handler client_addr reqd =
let { Gluten.reqd; upgrade } = reqd in
let request = Reqd.request reqd in
let body_length = Httpaf.Request.body_length request in
let request_body =
Body.of_prim_body
(module Http1.Body : Body.BODY with type Read.t = [ `read ] Httpaf.Body.t)
~body_length:(body_length :> Body.length)
~on_eof:(fun body ->
match Reqd.error_code reqd with
| Some error ->
Body.embed_error_received body (Lwt.return (error :> Error.t))
| None ->
())
(Reqd.request_body reqd)
in
let request = Request.of_http1 ~body:request_body request in
Lwt.async_exception_hook := report_exn reqd;
Lwt.async (fun () ->
let open Lwt.Syntax in
Lwt.catch
(fun () ->
let+ ({ ; body; _ } as response) =
handler { ctx = client_addr; request }
in
match Reqd.error_code reqd with
| Some _ ->
Log.info (fun m ->
m
"Response returned by handler will not be written, currently \
handling error")
| None ->
let response =
{ response with
headers =
Headers.add_length_related_headers
~body_length:(Body.length body)
headers
}
in
let http1_response = Response.to_http1 response in
(match Body.contents body with
| `Empty upgrade_handler ->
if Body.Optional_handler.is_none upgrade_handler then
Reqd.respond_with_bigstring
reqd
http1_response
Bigstringaf.empty
else (
assert (response.status = `Switching_protocols);
Reqd.respond_with_upgrade reqd http1_response.headers (fun () ->
Body.Optional_handler.call_if_some upgrade_handler upgrade))
| `String s ->
Reqd.respond_with_string reqd http1_response s
| `Bigstring { IOVec.buffer; off; len } ->
let bstr = Bigstringaf.sub ~off ~len buffer in
Reqd.respond_with_bigstring reqd http1_response bstr
| `Stream stream ->
let response_body =
Reqd.respond_with_streaming reqd http1_response
in
Body.stream_write_body (module Http1.Body) response_body stream))
(Lwt.wrap2 report_exn reqd))
let create ?config ?(error_handler = default_error_handler) handler =
Httpaf_lwt_unix.Server.create_connection_handler
?config:(Option.map Config.to_http1_config config)
~request_handler:(request_handler handler)
~error_handler:(make_error_handler error_handler)