]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/ocaml-http/http_daemon.ml
* added todo file
[helm.git] / helm / DEVEL / ocaml-http / http_daemon.ml
1
2 (*
3   OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
4
5   Copyright (C) <2002-2005> Stefano Zacchiroli <zack@cs.unibo.it>
6
7   This program is free software; you can redistribute it and/or modify
8   it under the terms of the GNU Library General Public License as
9   published by the Free Software Foundation, version 2.
10
11   This program is distributed in the hope that it will be useful,
12   but WITHOUT ANY WARRANTY; without even the implied warranty of
13   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14   GNU Library General Public License for more details.
15
16   You should have received a copy of the GNU Library General Public
17   License along with this program; if not, write to the Free Software
18   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
19   USA
20 *)
21
22 open Printf
23
24 open Http_common
25 open Http_types
26 open Http_constants
27 open Http_parser
28
29   (** send raw data on outchan, flushing it afterwards *)
30 let send_raw ~data outchan =
31   output_string outchan data;
32   flush outchan
33
34 let send_CRLF = send_raw ~data:crlf
35
36 let send_header ~header ~value =
37   Http_parser_sanity.heal_header (header, value);
38   send_raw ~data:(header ^ ": " ^ value ^ crlf)
39
40 let send_headers ~headers outchan =
41   List.iter (fun (header, value) -> send_header ~header ~value outchan) headers
42
43   (** internal: low level for send_status_line *)
44 let send_status_line' ~version code =
45   let status_line =
46     String.concat
47       " "
48       [ string_of_version version;
49       string_of_int code;
50       Http_misc.reason_phrase_of_code code ]
51   in
52   send_raw ~data:(status_line ^ crlf)
53
54 let int_of_code = function
55   | `Code code -> code
56   | `Status status -> code_of_status status
57
58 let send_status_line ?(version = http_version) ~(code: status_code) outchan =
59   send_status_line' ~version (int_of_code code) outchan
60
61   (* FIXME duplication of code between this and response#addBasicHeaders *)
62 let send_basic_headers ?(version = http_version) ~(code: status_code) outchan =
63   send_status_line' ~version (int_of_code code) outchan;
64   send_headers
65     ~headers:["Date", Http_misc.date_822 (); "Server", server_string]
66     outchan
67
68   (** internal: given a status code and an additional body return a string
69   representing an HTML document that explains the meaning of given status code.
70   Additional data can be added to the body via 'body' argument *)
71 let foo_body code body =
72   let reason_phrase = Http_misc.reason_phrase_of_code code in
73   sprintf
74 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
75 <HTML><HEAD>
76 <TITLE>%d %s</TITLE>
77 </HEAD><BODY>
78 <H1>%d - %s</H1>%s
79 </BODY></HTML>"
80     code reason_phrase code reason_phrase body
81
82   (** internal: send a fooish body explaining in HTML form the 'reason phrase'
83   of an HTTP response; body, if given, will be appended to the body *)
84 let send_foo_body code body = send_raw ~data:(foo_body code body)
85
86   (* Warning: keep default values in sync with Http_response.response class *)
87 let respond ?(body = "") ?(headers = []) ?version ?(code = `Code 200) outchan =
88   send_basic_headers ?version ~code outchan;
89   send_headers ~headers outchan;
90   send_header "Content-Length" (string_of_int (String.length body)) outchan;
91   send_CRLF outchan;
92   send_raw ~data:body outchan
93
94   (** internal: low level for respond_redirect, respond_error, ...
95   This function send a status line corresponding to a given code, some basic
96   headers, the additional headers (if given) and an HTML page containing the
97   reason phrase; if body is given it will be included in the body of the HTML
98   page *)
99 let send_empty_response
100   func_name ?(is_valid_status = fun _ -> true) ?(headers=[]) ?(body="") () =
101     fun ?version code outchan ->
102       if not (is_valid_status (int_of_code code)) then
103         failwith
104           (sprintf "'%d' isn't a valid status code for %s"
105             (int_of_code code) func_name)
106       else begin  (* status code suitable for answering *)
107         let headers =
108           [ "Connection", "close";
109             "Content-Type", "text/html; charset=iso-8859-1" ] @ headers
110         in
111         let body = (foo_body (int_of_code code) body) ^ body in
112         respond ?version ~code ~headers ~body outchan
113       end
114
115 let respond_redirect
116   ~location ?body ?version ?(code = `Code 301) outchan
117   =
118   send_empty_response "Daemon.respond_redirect" ~is_valid_status:is_redirection
119     ~headers:["Location", location] ?body () ?version code outchan
120
121 let respond_error ?body ?version ?(code = `Code 400) outchan =
122   send_empty_response "Daemon.respond_error" ~is_valid_status:is_error
123     ?body () ?version code outchan
124
125 let respond_not_found ~url ?version outchan =
126   send_empty_response "Daemon.respond_not_found" () ?version (`Code 404) outchan
127
128 let respond_forbidden ~url ?version outchan =
129   send_empty_response "Daemon.respond_permission_denied" () ?version
130   (`Code 403) outchan
131
132 let respond_unauthorized ?version ?(realm = server_string) outchan =
133   let body =
134     sprintf "401 - Unauthorized - Authentication failed for realm \"%s\"" realm
135   in
136   respond ~headers:["WWW-Authenticate", sprintf "Basic realm=\"%s\"" realm]
137     ~code:(`Code 401) ~body outchan
138
139 let send_file ~src outchan =
140   let buflen = 1024 in
141   let buf = String.make buflen ' ' in
142
143   let (file, cleanup) =
144     match src with
145     | FileSrc fname -> (* if we open the file, we close it before returning *)
146         let f = open_in fname in
147         f, (fun () -> close_in f)
148     | InChanSrc inchan -> inchan, ignore
149   in
150   try
151     while true do
152       let bytes = input file buf 0 buflen in
153       if bytes = 0 then
154         raise End_of_file
155       else
156         output outchan buf 0 bytes
157     done;
158     assert false
159   with End_of_file ->
160     begin
161       flush outchan;
162       cleanup ()
163     end
164
165   (* TODO interface is too ugly to advertise this function in .mli *)
166   (** create a minimal HTML directory listing of a given directory and send it
167   over an out_channel, directory is passed as a dir_handle; name is the
168   directory name, used for pretty printing purposes; path is the opened dir
169   path, used to test its contents with stat *)
170 let send_dir_listing ~dir ~name ~path outchan =
171   fprintf outchan "<html>\n<head><title>%s</title></head>\n<body>\n" name;
172   let (dirs, files) =
173     List.partition (fun e -> Http_misc.is_directory (path ^ e)) (Http_misc.ls dir)
174   in
175   List.iter
176     (fun d -> fprintf outchan "<a href=\"%s/\">%s/</a><br />\n" d d)
177     (List.sort compare dirs);
178   List.iter
179     (fun f -> fprintf outchan "<a href=\"%s\">%s</a><br />\n" f f)
180     (List.sort compare files);
181   fprintf outchan "</body>\n</html>";
182   flush outchan
183
184 let respond_file ~fname ?(version = http_version) outchan =
185   (** ASSUMPTION: 'fname' doesn't begin with a "/"; it's relative to the current
186   document root (usually the daemon's cwd) *)
187   let droot = Sys.getcwd () in  (* document root *)
188   let path = droot ^ "/" ^ fname in (* full path to the desired file *)
189   if not (Sys.file_exists path) then (* file not found *)
190     respond_not_found ~url:fname outchan
191   else begin
192     try
193       if Http_misc.is_directory path then begin (* file found, is a dir *)
194         let dir = Unix.opendir path in
195         send_basic_headers ~version ~code:(`Code 200) outchan;
196         send_header "Content-Type" "text/html" outchan;
197         send_CRLF outchan;
198         send_dir_listing ~dir ~name:fname ~path outchan;
199         Unix.closedir dir
200       end else begin  (* file found, is something else *)
201         let file = open_in fname in
202         send_basic_headers ~version ~code:(`Code 200) outchan;
203         send_header
204           ~header:"Content-Length"
205           ~value:(string_of_int (Http_misc.filesize fname))
206           outchan;
207         send_CRLF outchan;
208         send_file ~src:(InChanSrc file) outchan;
209         close_in file
210       end
211     with
212     | Unix.Unix_error (Unix.EACCES, _, _)
213     | Sys_error _ ->
214         respond_forbidden ~url:fname ~version outchan
215   end
216
217 let respond_with (res: Http_types.response) outchan =
218   res#serialize outchan;
219   flush outchan
220
221   (** internal: this exception is raised after a malformed request has been read
222   by a serving process to signal main server (or itself if mode = `Single) to
223   skip to next request *)
224 exception Again;;
225
226 let pp_parse_exc e =
227   sprintf "HTTP request parse error: %s" (Printexc.to_string e)
228
229   (* given a Http_parser.parse_request like function, wrap it in a function that
230   do the same and additionally catch parsing exception sending HTTP error
231   messages back to client as needed. Returned function raises Again when it
232   encounter a parse error (name 'Again' is intended for future versions that
233   will support http keep alive signaling that a new request has to be parsed
234   from client) *)
235 let rec wrap_parse_request_w_safety parse_function inchan outchan =
236 (*   try *)
237   (try
238     parse_function inchan
239   with
240   | (End_of_file) as e ->
241       debug_print (pp_parse_exc e);
242       respond_error ~code:(`Code 400) ~body:"Unexpected End Of File" outchan;
243       raise Again
244   | (Malformed_request req) as e ->
245       debug_print (pp_parse_exc e);
246       respond_error ~code:(`Code 400)
247         ~body:("request 1st line format should be: '<method> <url> <version>'" ^
248           "<br />\nwhile received request 1st line was:<br />\n" ^ req)
249         outchan;
250       raise Again
251   | (Invalid_HTTP_method meth) as e ->
252       debug_print (pp_parse_exc e);
253       respond_error ~code:(`Code 501)
254         ~body:("Method '" ^ meth ^ "' isn't supported (yet)")
255         outchan;
256       raise Again
257   | (Malformed_request_URI uri) as e ->
258       debug_print (pp_parse_exc e);
259       respond_error ~code:(`Code 400) ~body:("Malformed URL: '" ^ uri ^ "'")
260         outchan;
261       raise Again
262   | (Invalid_HTTP_version version) as e ->
263       debug_print (pp_parse_exc e);
264       respond_error ~code:(`Code 505)
265         ~body:("HTTP version '" ^ version ^ "' isn't supported (yet)")
266         outchan;
267       raise Again
268   | (Malformed_query query) as e ->
269       debug_print (pp_parse_exc e);
270       respond_error ~code:(`Code 400)
271         ~body:(sprintf "Malformed query string '%s'" query) outchan;
272       raise Again
273   | (Malformed_query_part (binding, query)) as e ->
274       debug_print (pp_parse_exc e);
275       respond_error ~code:(`Code 400)
276         ~body:(sprintf "Malformed query part '%s' in query '%s'" binding query)
277         outchan;
278       raise Again)
279 (*  (* preliminary support for HTTP keep alive connections ... *)
280   with Again ->
281     wrap_parse_request_w_safety parse_function inchan outchan
282 *)
283
284   (* wrapper around Http_parser.parse_request which catch parsing exceptions and
285   return error messages to client as needed
286   @param inchan in_channel from which read incoming requests
287   @param outchan out_channl on which respond with error messages if needed
288   *)
289 let safe_parse_request = wrap_parse_request_w_safety parse_request
290
291   (* as above but for OO version (Http_parser.parse_request') *)
292 let safe_parse_request' = wrap_parse_request_w_safety (new Http_request.request)
293
294 let chdir_to_document_root = function (* chdir to document root *)
295   | Some dir -> Sys.chdir dir
296   | None -> ()
297
298 let server_of_mode = function
299   | `Single -> Http_tcp_server.simple
300   | `Fork   -> Http_tcp_server.fork
301   | `Thread -> Http_tcp_server.thread
302
303   (* TODO what happens when a Quit exception is raised by a callback? Do other
304   callbacks keep on living until the end or are them all killed immediatly?
305   The right semantics should obviously be the first one *)
306
307 let handle_manual_auth outchan f =
308   try
309     f ()
310   with
311   | Unauthorized realm -> respond_unauthorized ~realm outchan
312   | Again -> ()
313
314 let handle_auth req spec outchan =
315   try
316     (match (spec.auth, req#authorization) with
317     | None, _ -> spec.callback req outchan  (* no auth required *)
318     | Some (realm, `Basic (spec_username, spec_password)),
319       Some (`Basic (username, password))
320       when (username = spec_username) && (password = spec_password) ->
321         (* auth ok *)
322         spec.callback req outchan
323     | Some (realm, _), _ -> raise (Unauthorized realm)) (* auth failure *)
324   with
325   | Unauthorized realm -> respond_unauthorized ~realm outchan
326   | Again -> ()
327
328   (* TODO support also chroot to 'root', not only chdir *)
329   (* TODO deprecated: remove from future versions *)
330   (* curried request *)
331 let start
332   ?(addr = default_addr) ?(port = default_port)
333   ?(timeout = default_timeout) ?(mode = default_mode) ?root callback
334   =
335   Http_misc.warn
336     "Http_daemon.start is deprecated in favour of Http_daemon.main and will be removed in future versions of the library";
337   chdir_to_document_root root;
338   let sockaddr = Http_misc.build_sockaddr (addr, port) in
339   let daemon_callback inchan outchan =
340     handle_manual_auth outchan (fun () ->
341       let (path, parameters) = safe_parse_request inchan outchan in
342       callback path parameters outchan;
343       flush outchan);
344   in
345   try
346     (server_of_mode mode) ~sockaddr ~timeout daemon_callback 
347   with Quit -> ()
348
349   (* OO request *)
350   (* TODO deprecated: remove from future versions *)
351 let start'
352   ?(addr = default_addr) ?(port = default_port)
353   ?(timeout = default_timeout) ?(mode = default_mode) ?root callback
354 =
355   Http_misc.warn
356     "Http_daemon.start' is deprecated in favour of Http_daemon.main and will be removed in future versions of the library";
357   chdir_to_document_root root;
358   let sockaddr = Http_misc.build_sockaddr (addr, port) in
359   let daemon_callback inchan outchan =
360     handle_manual_auth outchan (fun () ->
361       let req = safe_parse_request' inchan outchan in
362       callback req outchan;
363       flush outchan)
364   in
365   try
366     (server_of_mode mode) ~sockaddr ~timeout daemon_callback 
367   with Quit -> ()
368
369 let main spec =
370   chdir_to_document_root spec.root_dir;
371   let sockaddr = Http_misc.build_sockaddr (spec.address, spec.port) in
372   let daemon_callback inchan outchan =
373     try
374       let req = safe_parse_request' inchan outchan in
375       handle_auth req spec outchan;
376       flush outchan
377     with exn ->
378       (match spec.exn_handler with
379       | Some f ->
380           debug_print "uncaught exception: executing handler";
381           f exn outchan
382       | None ->
383           debug_print "uncaught exception but no handler given: re-raising";
384           raise exn)
385   in
386   try
387     (server_of_mode spec.mode) ~sockaddr ~timeout:spec.timeout daemon_callback 
388   with Quit -> ()
389
390 module Trivial =
391   struct
392     let heading_slash_RE = Pcre.regexp "^/"
393
394     let trivial_callback req outchan =
395       let path = req#path in
396       if not (Pcre.pmatch ~rex:heading_slash_RE path) then
397         respond_error ~code:(`Code 400) outchan
398       else
399         respond_file ~fname:(Http_misc.strip_heading_slash path) outchan
400
401     let callback = trivial_callback
402
403     let main spec = main { spec with callback = trivial_callback }
404   end
405
406   (* @param inchan input channel connected to client
407      @param outchan output channel connected to client
408      @param sockaddr client socket address *)
409 class connection inchan outchan sockaddr =
410   (* ASSUMPTION: inchan and outchan are channels built on top of the same
411   Unix.file_descr thus closing one of them will close also the other *)
412   let close' o = o#close in
413   object (self)
414
415     initializer Gc.finalise close' self
416
417     val mutable closed = false
418
419     method private assertNotClosed =
420       if closed then
421         failwith "Http_daemon.connection: connection is closed"
422
423     method getRequest =
424       self#assertNotClosed;
425       try
426         Some (safe_parse_request' inchan outchan)
427       with Again -> None
428
429     method respond_with res =
430       self#assertNotClosed;
431       respond_with res outchan
432
433     method close =
434       self#assertNotClosed;
435       close_in inchan;  (* this close also outchan *)
436       closed <- true
437
438   end
439
440 class daemon ?(addr = "0.0.0.0") ?(port = 80) () =
441   object (self)
442
443     val suck =
444       Http_tcp_server.init_socket (Http_misc.build_sockaddr (addr, port))
445
446     method accept =
447       let (cli_suck, cli_sockaddr) = Unix.accept suck in  (* may block *)
448       let (inchan, outchan) =
449         (Unix.in_channel_of_descr cli_suck, Unix.out_channel_of_descr cli_suck)
450       in
451       new connection inchan outchan cli_sockaddr
452
453     method getRequest =
454       let conn = self#accept in
455       match conn#getRequest with
456       | None ->
457           conn#close;
458           self#getRequest
459       | Some req -> (req, conn)
460
461   end
462
463 open Http_constants
464
465 let default_spec = {
466   address = default_addr;
467   auth = default_auth;
468   callback = default_callback;
469   mode = default_mode;
470   port = default_port;
471   root_dir = default_root_dir;
472   exn_handler = default_exn_handler;
473   timeout = default_timeout;
474 }
475
476 let daemon_spec
477   ?(address = default_addr) ?(auth = default_auth)
478   ?(callback = default_callback) ?(mode = default_mode) ?(port = default_port)
479   ?(root_dir = default_root_dir) ?(exn_handler = default_exn_handler)
480   ?(timeout = default_timeout)
481   ()
482 =
483   { default_spec with
484       address = address;
485       auth = auth;
486       callback = callback;
487       mode = mode;
488       port = port;
489       root_dir = root_dir;
490       exn_handler = exn_handler;
491       timeout = timeout;
492   }
493