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