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
open Lwt.Infix
module Make (IO : S.IO) = struct
module IO = IO
module Request = Make.Request (IO)
module Response = Make.Response (IO)
let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server module"
module Log = (val Logs.src_log src : Logs.LOG)
type conn = IO.conn * Cohttp.Connection.t
type response_action =
[ `Expert of Cohttp.Response.t * (IO.ic -> IO.oc -> unit Lwt.t)
| `Response of Cohttp.Response.t * Body.t ]
type t = {
callback : conn -> Cohttp.Request.t -> Body.t -> response_action Lwt.t;
conn_closed : conn -> unit;
}
let make_response_action ?(conn_closed = ignore) ~callback () =
{ conn_closed; callback }
let make ?conn_closed ~callback () =
let callback conn req body =
callback conn req body >|= fun rsp -> `Response rsp
in
make_response_action ?conn_closed ~callback ()
let make_expert ?conn_closed ~callback () =
let callback conn req body =
callback conn req body >|= fun rsp -> `Expert rsp
in
make_response_action ?conn_closed ~callback ()
module Transfer_IO = Cohttp__Transfer_io.Make (IO)
let resolve_local_file ~docroot ~uri =
Cohttp.Path.resolve_local_file ~docroot ~uri
let respond ? ?(flush = true) ~status ~body () =
let encoding =
match headers with
| None -> Body.transfer_encoding body
| Some -> (
match Header.get_transfer_encoding headers with
| Cohttp.Transfer.Unknown -> Body.transfer_encoding body
| t -> t)
in
let res = Response.make ~status ~flush ~encoding ?headers () in
Lwt.return (res, body)
let respond_string ?(flush = true) ? ~status ~body () =
let res =
Response.make ~status ~flush
~encoding:(Cohttp.Transfer.Fixed (Int64.of_int (String.length body)))
?headers ()
in
let body = Body.of_string body in
Lwt.return (res, body)
let respond_error ? ?(status = `Internal_server_error) ~body () =
respond_string ?headers ~status ~body:("Error: " ^ body) ()
let respond_redirect ? ~uri () =
let =
match headers with
| None -> Header.init_with "location" (Uri.to_string uri)
| Some h -> Header.add_unless_exists h "location" (Uri.to_string uri)
in
respond ~headers ~status:`Found ~body:`Empty ()
let respond_need_auth ? ~auth () =
let = match headers with None -> Header.init () | Some h -> h in
let = Header.add_authorization_req headers auth in
respond ~headers ~status:`Unauthorized ~body:`Empty ()
let respond_not_found ?uri () =
let body =
match uri with
| None -> "Not found"
| Some uri -> "Not found: " ^ Uri.to_string uri
in
respond_string ~status:`Not_found ~body ()
let read_body ic req =
match Request.has_body req with
| `Yes ->
let reader = Request.make_body_reader req ic in
let body_stream = Body.create_stream Request.read_body_chunk reader in
Body.of_stream body_stream
| `No | `Unknown -> `Empty
let handle_request callback conn req body =
Log.debug (fun m -> m "Handle request: %a." Request.pp_hum req);
Lwt.finalize
(fun () ->
Lwt.catch
(fun () -> callback conn req body)
(function
| Out_of_memory -> Lwt.fail Out_of_memory
| exn ->
Log.err (fun f ->
f "Error handling %a: %s" Request.pp_hum req
(Printexc.to_string exn));
respond_error ~body:"Internal Server Error" () >|= fun rsp ->
`Response rsp))
(fun () -> Body.drain_body body)
let handle_response ~keep_alive oc res body conn_closed handle_client =
IO.catch (fun () ->
let flush = Response.flush res in
Response.write ~flush
(fun writer -> Body.write_body (Response.write_body writer) body)
res oc)
>>= function
| Ok () ->
if keep_alive then handle_client oc
else
let () = conn_closed () in
Lwt.return_unit
| Error e ->
Log.info (fun m -> m "IO error while writing body: %a" IO.pp_error e);
conn_closed ();
Body.drain_body body
let rec handle_client ic oc conn spec =
Request.read ic >>= function
| `Eof ->
spec.conn_closed conn;
Lwt.return_unit
| `Invalid data ->
Log.err (fun m -> m "invalid input %s while handling client" data);
spec.conn_closed conn;
Lwt.return_unit
| `Ok req -> (
let body = read_body ic req in
handle_request spec.callback conn req body >>= function
| `Response (res, body) ->
let keep_alive = Request.is_keep_alive req in
handle_response ~keep_alive oc res body
(fun () -> spec.conn_closed conn)
(fun oc -> handle_client ic oc conn spec)
| `Expert (res, io_handler) ->
Response.write_header res oc >>= fun () ->
io_handler ic oc >>= fun () -> handle_client ic oc conn spec)
let callback spec io_id ic oc =
let conn_id = Cohttp.Connection.create () in
let conn_closed () = spec.conn_closed (io_id, conn_id) in
Lwt.catch
(fun () ->
IO.catch (fun () -> handle_client ic oc (io_id, conn_id) spec)
>>= function
| Ok () -> Lwt.return_unit
| Error e ->
Log.info (fun m ->
m "IO error while handling client: %a" IO.pp_error e);
conn_closed ();
Lwt.return_unit)
(fun e ->
conn_closed ();
Lwt.fail e)
end