-
Notifications
You must be signed in to change notification settings - Fork 1
/
http_daemon.ml
484 lines (420 loc) · 16.2 KB
/
http_daemon.ml
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
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
(*
OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
Copyright (C) <2002-2005> Stefano Zacchiroli <[email protected]>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Library General Public License as
published by the Free Software Foundation, version 2.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)
open Printf
open Http_common
open Http_types
open Http_constants
open Http_parser
exception Http_daemon_failure of string
(** send raw data on outchan, flushing it afterwards *)
let send_raw ~data outchan =
output_string outchan data;
flush outchan
let send_CRLF = send_raw ~data:crlf
let send_header ~header ~value =
let header = String.lowercase_ascii header in
Http_parser_sanity.heal_header (header, value);
send_raw ~data:(header ^ ": " ^ value ^ crlf)
let send_headers ~headers outchan =
List.iter (fun (header, value) -> send_header ~header ~value outchan) headers
(** internal: low level for send_status_line *)
let send_status_line' ~version code =
let status_line =
String.concat
" "
[ string_of_version version;
string_of_int code;
Http_misc.reason_phrase_of_code code ]
in
send_raw ~data:(status_line ^ crlf)
let int_of_code = function
| `Code code -> code
| `Status status -> code_of_status status
let send_status_line ?(version = http_version) ~(code: status_code) outchan =
send_status_line' ~version (int_of_code code) outchan
let get_basic_headers () =
["Date", Http_misc.date_822 ();
"Server", server_string;
"Connection", "close"]
let send_basic_headers ?(version = http_version) ~(code: status_code) outchan =
send_status_line' ~version (int_of_code code) outchan;
send_headers ~headers:(get_basic_headers ()) outchan
(** internal: given a status code and an additional body return a string
representing an HTML document that explains the meaning of given status code.
Additional data can be added to the body via 'body' argument *)
let foo_body code body =
let reason_phrase = Http_misc.reason_phrase_of_code code in
sprintf
"<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<HTML><HEAD>
<TITLE>%d %s</TITLE>
</HEAD><BODY>
<H1>%d - %s</H1>%s
</BODY></HTML>"
code reason_phrase code reason_phrase body
(** internal: send a fooish body explaining in HTML form the 'reason phrase'
of an HTTP response; body, if given, will be appended to the body *)
let send_foo_body code body = send_raw ~data:(foo_body code body)
(* Warning: keep default values in sync with Http_response.response class *)
let respond_head ?content_length ?(headers = []) ?version ?(code = `Code 200) outchan =
send_basic_headers ?version ~code outchan;
send_headers ~headers outchan;
(match content_length with
| None -> ()
| Some amount -> send_header "Content-Length" (string_of_int amount) outchan);
send_CRLF outchan
(* Warning: keep default values in sync with Http_response.response class *)
let respond ?(body = "") ?(headers = []) ?version ?(code = `Code 200) outchan =
send_basic_headers ?version ~code outchan;
send_headers ~headers outchan;
send_header "Content-Length" (string_of_int (String.length body)) outchan;
send_CRLF outchan;
send_raw ~data:body outchan
let respond_trace ?req ?(headers = []) ?version ?(code = `Code 200) outchan =
let body = match req with
| Some r -> string_of_request r
| None -> ""
in
respond ~body ~headers ?version ~code outchan
(** internal: low level for respond_redirect, respond_error, ...
This function send a status line corresponding to a given code, some basic
headers, the additional headers (if given) and an HTML page containing the
reason phrase; if body is given it will be included in the body of the HTML
page *)
let send_empty_response
func_name ?(is_valid_status = fun _ -> true) ?(headers=[]) ?(body="") () =
fun ?version code outchan ->
if not (is_valid_status (int_of_code code)) then
failwith
(sprintf "'%d' isn't a valid status code for %s"
(int_of_code code) func_name)
else begin (* status code suitable for answering *)
let headers =
[ "Content-Type", "text/html; charset=iso-8859-1" ] @ headers
in
let body = (foo_body (int_of_code code) body) ^ body in
respond ?version ~code ~headers ~body outchan
end
let respond_redirect
~location ?body ?version ?(code = `Code 301) outchan
=
send_empty_response "Daemon.respond_redirect" ~is_valid_status:is_redirection
~headers:["Location", location] ?body () ?version code outchan
let respond_error ?body ?version ?(code = `Code 400) outchan =
send_empty_response "Daemon.respond_error" ~is_valid_status:is_error
?body () ?version code outchan
let respond_not_found ~url ?version outchan =
send_empty_response "Daemon.respond_not_found" () ?version (`Code 404) outchan
let respond_forbidden ~url ?version outchan =
send_empty_response "Daemon.respond_permission_denied" () ?version
(`Code 403) outchan
let respond_unauthorized ?version ?(realm = server_string) outchan =
let body =
sprintf "401 - Unauthorized - Authentication failed for realm \"%s\"" realm
in
respond ~headers:["WWW-Authenticate", sprintf "Basic realm=\"%s\"" realm]
~code:(`Code 401) ~body outchan
let send_file ~src outchan =
let buflen = 1024 in
let buf = Bytes.make buflen ' ' in
let (file, cleanup) =
match src with
| FileSrc fname -> (* if we open the file, we close it before returning *)
let f = open_in fname in
f, (fun () -> close_in f)
| InChanSrc inchan -> inchan, ignore
in
try
while true do
let bytes = input file buf 0 buflen in
if bytes = 0 then
raise End_of_file
else
output outchan buf 0 bytes
done;
assert false
with End_of_file ->
begin
flush outchan;
cleanup ()
end
(* TODO interface is too ugly to advertise this function in .mli *)
(** create a minimal HTML directory listing of a given directory and send it
over an out_channel, directory is passed as a dir_handle; name is the
directory name, used for pretty printing purposes; path is the opened dir
path, used to test its contents with stat *)
let send_dir_listing ~dir ~name ~path outchan =
fprintf outchan "<html>\n<head><title>%s</title></head>\n<body>\n" name;
let (dirs, files) =
List.partition (fun e -> Http_misc.is_directory (path ^ e)) (Http_misc.ls dir)
in
List.iter
(fun d -> fprintf outchan "<a href=\"%s/\">%s/</a><br />\n" d d)
(List.sort compare dirs);
List.iter
(fun f -> fprintf outchan "<a href=\"%s\">%s</a><br />\n" f f)
(List.sort compare files);
fprintf outchan "</body>\n</html>";
flush outchan
let respond_file ~fname ?(version = http_version) outchan =
(** ASSUMPTION: 'fname' doesn't begin with a "/"; it's relative to the current
document root (usually the daemon's cwd) *)
let droot = Sys.getcwd () in (* document root *)
let path = droot ^ "/" ^ fname in (* full path to the desired file *)
if not (Sys.file_exists path) then (* file not found *)
respond_not_found ~url:fname outchan
else begin
try
if Http_misc.is_directory path then begin (* file found, is a dir *)
let dir = Unix.opendir path in
send_basic_headers ~version ~code:(`Code 200) outchan;
send_header "Content-Type" "text/html" outchan;
send_CRLF outchan;
send_dir_listing ~dir ~name:fname ~path outchan;
Unix.closedir dir
end else begin (* file found, is something else *)
let file = open_in fname in
send_basic_headers ~version ~code:(`Code 200) outchan;
send_header
~header:"Content-Length"
~value:(string_of_int (Http_misc.filesize fname))
outchan;
send_CRLF outchan;
send_file ~src:(InChanSrc file) outchan;
close_in file
end
with
| Unix.Unix_error (Unix.EACCES, _, _)
| Sys_error _ ->
respond_forbidden ~url:fname ~version outchan
end
let respond_with (res: Http_types.response) outchan =
res#serialize outchan;
flush outchan
(** internal: this exception is raised after a malformed request has been read
by a serving process to signal main server (or itself if mode = `Single) to
skip to next request *)
exception Again;;
let pp_parse_exc e =
sprintf "HTTP request parse error: %s" (Printexc.to_string e)
(* given a Http_parser.parse_request like function, wrap it in a function that
do the same and additionally catch parsing exception sending HTTP error
messages back to client as needed. Returned function raises Again when it
encounter a parse error (name 'Again' is intended for future versions that
will support http keep alive signaling that a new request has to be parsed
from client) *)
let rec wrap_parse_request_w_safety parse_function inchan outchan =
(try
parse_function inchan
with
| (Malformed_request req) as e ->
debug_print (pp_parse_exc e);
respond_error ~code:(`Code 400)
~body:("request 1st line format should be: " ^
"'<method> <url> <version>'" ^
"<br />\nwhile received request 1st line was:<br />\n" ^ req)
outchan;
raise Again
| (Invalid_HTTP_method meth) as e ->
debug_print (pp_parse_exc e);
respond_error ~code:(`Code 501)
~body:("Method '" ^ meth ^ "' isn't supported (yet)")
outchan;
raise Again
| (Malformed_request_URI uri) as e ->
debug_print (pp_parse_exc e);
respond_error ~code:(`Code 400) ~body:("Malformed URL: '" ^ uri ^ "'")
outchan;
raise Again
| (Invalid_HTTP_version version) as e ->
debug_print (pp_parse_exc e);
respond_error ~code:(`Code 505)
~body:("HTTP version '" ^ version ^ "' isn't supported (yet)")
outchan;
raise Again
| (Malformed_query query) as e ->
debug_print (pp_parse_exc e);
respond_error ~code:(`Code 400)
~body:(sprintf "Malformed query string '%s'" query) outchan;
raise Again
| (Malformed_query_part (binding, query)) as e ->
debug_print (pp_parse_exc e);
respond_error ~code:(`Code 400)
~body:(sprintf "Malformed query part '%s' in query '%s'" binding query)
outchan;
raise Again)
(* wrapper around Http_parser.parse_request which catch parsing exceptions and
return error messages to client as needed
@param inchan in_channel from which read incoming requests
@param outchan out_channl on which respond with error messages if needed
*)
let safe_parse_request = wrap_parse_request_w_safety parse_request
(* as above but for OO version (Http_parser.parse_request') *)
let safe_parse_request' = wrap_parse_request_w_safety (new Http_request.request)
let chdir_to_document_root = function (* chdir to document root *)
| Some dir -> Sys.chdir dir
| None -> ()
let server_of_mode = function
| `Single -> Http_tcp_server.simple
| `Fork -> Http_tcp_server.fork
| `Thread -> Http_tcp_server.thread
(* TODO what happens when a Quit exception is raised by a callback? Do other
callbacks keep on living until the end or are them all killed immediatly?
The right semantics should obviously be the first one *)
(** - handle HTTP authentication
* - handle automatic closures of client connections *)
let invoke_callback req spec outchan =
let callback req outchan =
if spec.auto_close then
Http_misc.finally
(fun () -> try close_out outchan with Sys_error _ -> ())
(fun () -> spec.callback req outchan) ()
else
spec.callback req outchan in
try
(match (spec.auth, req#authorization) with
| None, _ -> callback req outchan (* no auth required *)
| Some (realm, `Basic (spec_username, spec_password)),
Some (`Basic (username, password))
when (username = spec_username) && (password = spec_password) ->
(* auth ok *)
callback req outchan
| Some (realm, _), _ -> raise (Unauthorized realm)) (* auth failure *)
with
| Unauthorized realm -> respond_unauthorized ~realm outchan
| Again -> ()
let main spec =
chdir_to_document_root spec.root_dir;
let sockaddr = Http_misc.build_sockaddr (spec.address, spec.port) in
let daemon_callback inchan outchan =
let next_req () =
try Some (safe_parse_request' inchan outchan)
with _ -> None
in
let rec loop n =
match next_req () with
| Some req ->
debug_print (sprintf "request #%d" n);
invoke_callback req spec outchan;
flush outchan;
loop (n + 1)
| None ->
debug_print "server exiting";
()
in
debug_print "server starting";
try loop 1
with exn ->
debug_print (sprintf "uncaught exception: %s" (Printexc.to_string exn));
(match spec.exn_handler with
| Some f ->
debug_print "executing handler";
f exn outchan
| None ->
debug_print "no handler given: re-raising";
raise exn)
in
try
(server_of_mode spec.mode) ~sockaddr ~timeout:spec.timeout daemon_callback
with Quit -> ()
module Trivial =
struct
let heading_slash_RE = Pcre.regexp "^/"
let trivial_callback req outchan =
let path = req#path in
if not (Pcre.pmatch ~rex:heading_slash_RE path) then
respond_error ~code:(`Code 400) outchan
else
respond_file ~fname:(Http_misc.strip_heading_slash path) outchan
let callback = trivial_callback
let main spec = main { spec with callback = trivial_callback }
end
(** @param inchan input channel connected to client
@param outchan output channel connected to client
@param sockaddr client socket address *)
class connection inchan outchan sockaddr =
(* ASSUMPTION: inchan and outchan are channels built on top of the same
Unix.file_descr thus closing one of them will close also the other *)
let close' o = try o#close with Http_daemon_failure _ -> () in
object (self)
initializer Gc.finalise close' self
val mutable closed = false
method private assertNotClosed =
if closed then
raise (Http_daemon_failure
"Http_daemon.connection: connection is closed")
method getRequest =
self#assertNotClosed;
try
Some (safe_parse_request' inchan outchan)
with _ -> None
method respond_with res =
self#assertNotClosed;
respond_with res outchan
method close =
self#assertNotClosed;
close_in inchan; (* this close also outchan *)
closed <- true
end
class daemon ?(addr = "0.0.0.0") ?(port = 80) () =
object (self)
val suck =
Http_tcp_server.init_socket (Http_misc.build_sockaddr (addr, port))
method accept =
let (cli_suck, cli_sockaddr) = Unix.accept suck in (* may block *)
let (inchan, outchan) =
(Unix.in_channel_of_descr cli_suck, Unix.out_channel_of_descr cli_suck)
in
new connection inchan outchan cli_sockaddr
method getRequest =
let conn = self#accept in
match conn#getRequest with
| None ->
conn#close;
self#getRequest
| Some req -> (req, conn)
end
open Http_constants
let default_spec = {
address = default_addr;
auth = default_auth;
auto_close = default_auto_close;
callback = default_callback;
mode = default_mode;
port = default_port;
root_dir = default_root_dir;
exn_handler = default_exn_handler;
timeout = default_timeout;
}
let daemon_spec
?(address = default_addr) ?(auth = default_auth)
?(auto_close = default_auto_close)
?(callback = default_callback) ?(mode = default_mode) ?(port = default_port)
?(root_dir = default_root_dir) ?(exn_handler = default_exn_handler)
?(timeout = default_timeout)
()
=
{
address = address;
auth = auth;
auto_close = auto_close;
callback = callback;
mode = mode;
port = port;
root_dir = root_dir;
exn_handler = exn_handler;
timeout = timeout;
}