3 OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
5 Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
27 prerr_endline ("DEBUG: " ^ str);
30 let default_addr = "0.0.0.0"
32 let default_timeout = 300
35 type url_syntax_option =
36 Url_part_not_recognized
40 * (1) scheme://user:password@host:port/path;params?query#fragment
43 let request_uri_syntax = {
44 url_enable_scheme = Url_part_not_recognized;
45 url_enable_user = Url_part_not_recognized;
46 url_enable_password = Url_part_not_recognized;
47 url_enable_host = Url_part_not_recognized;
48 url_enable_port = Url_part_not_recognized;
49 url_enable_path = Url_part_required;
50 url_enable_param = Url_part_not_recognized;
51 url_enable_query = Url_part_allowed;
52 url_enable_fragment = Url_part_not_recognized;
53 url_enable_other = Url_part_not_recognized;
54 url_accepts_8bits = false;
55 url_is_valid = (fun _ -> true);
60 exception Malformed_request of string
61 exception Unsupported_method of string
62 exception Malformed_request_URI of string
63 exception Unsupported_HTTP_version of string
64 exception Malformed_query of string
65 exception Malformed_query_binding of string * string
67 (** given a list of length 2
68 @return a pair formed by the elements of the list
69 @raise Assert_failure if the list length isn't 2
71 let pair_of_2_sized_list = function
75 (** given an HTTP like query string (e.g. "name1=value1&name2=value2&...")
76 @return a list of pairs [("name1", "value1"); ("name2", "value2")]
77 @raise Malformed_query if the string isn't a valid query string
78 @raise Malformed_query_binding if some piece of the query isn't valid
80 let split_query_params =
81 let (bindings_sep, binding_sep) = (Pcre.regexp "&", Pcre.regexp "=") in
83 let bindings = Pcre.split ~rex:bindings_sep query in
84 if List.length bindings < 1 then
85 raise (Malformed_query query);
88 let pieces = Pcre.split ~rex:binding_sep binding in
89 if List.length pieces <> 2 then
90 raise (Malformed_query_binding (binding, query));
91 pair_of_2_sized_list pieces)
94 (** given an input channel and a separator
95 @return a line read from it (like Pervasives.input_line)
96 line is returned only after reading a separator string; separator string isn't
97 included in the returned value
98 FIXME what about efficiency?, input is performed char-by-char
100 let generic_input_line ~sep ~ic =
101 let sep_len = String.length sep in
103 failwith ("Separator '" ^ sep ^ "' is too short!")
104 else (* valid separator *)
106 let sep_pointer = ref 0 in
109 if !sep_pointer >= String.length sep then (* line completed *)
111 else begin (* incomplete line: need to read more *)
112 let ch = input_char ic in
113 if ch = String.get sep !sep_pointer then (* next piece of sep *)
115 else begin (* useful char *)
116 for i = 0 to !sep_pointer - 1 do
117 line := !line ^ (String.make 1 (String.get sep i))
120 line := !line ^ (String.make 1 ch)
124 assert false (* unreacheable statement *)
131 (** given an input channel, reads from it a GET HTTP request and
132 @return a pair <path, query_params> where path is a string representing the
133 requested path and query_params is a list of pairs <name, value> (the GET
136 let parse_http_request =
137 let patch_empty_path s = (if s = "" then "/" else s) in
138 let pieces_sep = Pcre.regexp " " in
140 let request_line = generic_input_line ~sep:crlf ~ic in
142 debug_print ("request_line: '" ^ request_line ^ "'");
143 match Pcre.split ~rex:pieces_sep request_line with
144 | [meth; request_uri_raw; http_version] ->
145 if meth <> "GET" then
146 raise (Unsupported_method meth);
147 (match http_version with
148 | "HTTP/1.0" | "HTTP/1.1" -> ()
149 | _ -> raise (Unsupported_HTTP_version http_version));
152 url_of_string request_uri_syntax request_uri_raw
153 with Malformed_URL ->
154 raise (Malformed_request_URI request_uri_raw)
157 patch_empty_path (String.concat "/" (url_path request_uri))
160 try split_query_params (url_query request_uri) with Not_found -> []
163 | _ -> raise (Malformed_request request_line)
165 (** send raw data on outchan, flushing it afterwards *)
166 let send_raw ~data outchan =
167 output_string outchan data;
170 let send_CRLF = send_raw ~data:crlf
172 (** TODO perform some sanity test on header and value *)
173 let send_header ~header ~value = send_raw ~data:(header ^ ": " ^ value ^ crlf)
175 let send_headers ~headers outchan =
176 List.iter (fun (header, value) -> send_header ~header ~value outchan) headers
178 (** internal: parse a code argument from a function which have two optional
179 arguments "code" and "status" *)
180 let get_code_argument func_name =
182 (match code, status with
184 | None, Some s -> Http_common.code_of_status s
186 failwith (func_name ^ " you must give 'code' or 'status', not both")
188 failwith (func_name ^ " you must give 'code' or 'status', not none"))
190 (** internal: low level for send_status_line *)
191 let send_status_line' ~version ~code =
195 [ Http_common.string_of_version version;
197 Http_common.reason_phrase_of_code code ]
199 send_raw ~data:(status_line ^ crlf)
202 ?(version = Http_common.http_version) ?code ?status outchan
206 ~code:(get_code_argument "Daemon.send_status_line" ~code ~status)
209 let send_basic_headers
210 ?(version = Http_common.http_version) ?code ?status outchan
213 ~version ~code:(get_code_argument "Daemon.send_basic_headers" ~code ~status)
216 ~headers:["Date", Http_misc.date_822 (); "Server", "OCaml HTTP Daemon"]
219 (** internal: send a fooish body explaining in HTML form the 'reason phrase'
220 of an HTTP response; body, if given, will be appended to the body *)
221 let send_foo_body ~code ~body =
222 let reason_phrase = Http_common.reason_phrase_of_code code in
225 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
231 code reason_phrase code reason_phrase
232 (match body with None -> "" | Some text -> "\n" ^ text)
236 (** internal: low level for respond_redirect, respond_error, ...
237 This function send a status line corresponding to a given code, some basic
238 headers, the additional headers (if given) and an HTML page containing the
239 reason phrase; if body is given it will be included in the body of the HTML
241 let send_empty_response
242 f_name ?(is_valid_status = fun _ -> true) ?(headers = []) ~body () =
243 fun ?(version = Http_common.http_version) ?code ?status outchan ->
244 let code = get_code_argument f_name ~code ~status in
245 if not (is_valid_status code) then
246 failwith (sprintf "'%d' isn't a valid status code for %s" code f_name)
247 else begin (* status code suitable for answering *)
248 send_basic_headers ~version ~code outchan;
249 send_header ~header:"Connection" ~value:"close" outchan;
251 ~header:"Content-Type"
252 ~value:"text/html; charset=iso-8859-1"
254 send_headers ~headers outchan;
256 send_foo_body ~code ~body outchan
259 (* TODO sanity tests on location *)
262 ?(version = Http_common.http_version) ?(code = 301) ?status outchan =
266 | Some (s: Http_types.redirection_status) -> Http_common.code_of_status s
269 "Daemon.respond_redirect" ~is_valid_status:Http_common.is_redirection
270 ~headers:["Location", location] ~body ()
271 ~version ~code outchan
275 ?(version = Http_common.http_version) ?(code = 400) ?status outchan =
279 | Some s -> Http_common.code_of_status s
282 "Daemon.respond_error" ~is_valid_status:Http_common.is_error ~body ()
283 ~version ~code outchan
285 let respond_not_found ~url ?(version = Http_common.http_version) outchan =
287 "Daemon.respond_not_found" ~body:None ()
288 ~version ~code:404 outchan
290 let respond_forbidden ~url ?(version = Http_common.http_version) outchan =
292 "Daemon.respond_permission_denied" ~body:None ()
293 ~version ~code:403 outchan
295 let send_file ?name ?file outchan =
297 let buf = String.make buflen ' ' in
298 let (file, cleanup) =
299 (match (name, file) with
300 | Some n, None -> (* if we open the file, we close it before returning *)
302 f, (fun () -> close_in f)
303 | None, Some f -> (f, (fun () -> ()))
304 | _ -> failwith "Daemon.send_file: either name or file must be given")
308 let bytes = input file buf 0 buflen in
312 output outchan buf 0 bytes
321 (* TODO interface is too ugly to advertise this function in .mli *)
322 (** create a minimal HTML directory listing of a given directory and send it
323 over an out_channel, directory is passed as a dir_handle; name is the
324 directory name, used for pretty printing purposes; path is the opened dir
325 path, used to test its contents with stat *)
326 let send_dir_listing ~dir ~name ~path outchan =
327 fprintf outchan "<html>\n<head><title>%s</title></head>\n<body>\n" name;
329 List.partition (fun e -> Http_misc.is_directory (path ^ e)) (Http_misc.ls dir)
332 (fun d -> fprintf outchan "<a href=\"%s/\">%s/</a><br />\n" d d)
333 (List.sort compare dirs);
335 (fun f -> fprintf outchan "<a href=\"%s\">%s</a><br />\n" f f)
336 (List.sort compare files);
337 fprintf outchan "</body>\n</html>";
340 let respond_file ~fname ?(version = Http_common.http_version) outchan =
341 (** ASSUMPTION: 'fname' doesn't begin with a "/"; it's relative to the current
342 document root (usually the daemon's cwd) *)
343 let droot = Sys.getcwd () in (* document root *)
344 let path = droot ^ "/" ^ fname in (* full path to the desired file *)
345 if not (Sys.file_exists path) then (* file not found *)
346 respond_not_found ~url:fname outchan
349 if Http_misc.is_directory path then begin (* file found, is a dir *)
350 let dir = Unix.opendir path in
351 send_basic_headers ~version ~code:200 outchan;
352 send_header "Content-Type" "text/html" outchan;
354 send_dir_listing ~dir ~name:fname ~path outchan;
356 end else begin (* file found, is something else *)
357 let file = open_in fname in
358 send_basic_headers ~version ~code:200 outchan;
360 ~header:"Content-Length"
361 ~value:(string_of_int (Http_misc.filesize fname))
364 send_file ~file outchan;
368 | Unix.Unix_error (Unix.EACCES, s, _) when (s = fname) ->
369 respond_forbidden ~url:fname ~version outchan
371 (Pcre.pmatch ~rex:(Pcre.regexp (fname ^ ": Permission denied")) s) ->
372 respond_forbidden ~url:fname ~version outchan
375 let respond_with (res: Http_types.response) outchan =
376 res#serialize outchan;
380 ?(addr = default_addr) ?(port = default_port)
381 ?(timeout = Some default_timeout)
384 let sockaddr = Unix.ADDR_INET (Unix.inet_addr_of_string addr, port) in
385 let timeout_callback signo =
386 if signo = Sys.sigalrm then begin
387 debug_print "TIMEOUT, exiting ...";
391 let daemon_callback inchan outchan =
394 ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_callback));
395 ignore (Unix.alarm timeout)
398 let (path, parameters) = parse_http_request inchan in
399 callback path parameters outchan;
403 respond_error ~code:400 ~body:"Unexpected End Of File" outchan
404 | Malformed_request req ->
408 "request 1st line format should be: '<method> <url> <version>'" ^
409 "<br />\nwhile received request 1st line was:<br />\n" ^ req)
411 | Unsupported_method meth ->
414 ~body:("Method '" ^ meth ^ "' isn't supported (yet)")
416 | Malformed_request_URI uri ->
417 respond_error ~code:400 ~body:("Malformed URL: '" ^ uri ^ "'") outchan
418 | Unsupported_HTTP_version version ->
421 ~body:("HTTP version '" ^ version ^ "' isn't supported (yet)")
423 | Malformed_query query ->
425 ~code:400 ~body:("Malformed query string '" ^ query ^ "'") outchan
426 | Malformed_query_binding (binding, query) ->
430 sprintf "Malformed query element '%s' in query '%s'" binding query)
433 Unix.establish_server daemon_callback sockaddr
436 ?(addr = default_addr) ?(port = default_port)
437 ?(timeout = Some default_timeout)
438 (callback: (Http_types.request -> out_channel -> unit))
440 let wrapper path params outchan =
441 let req = new Http_request.request ~path ~params in
444 start ~addr ~port ~timeout wrapper
448 let callback path _ outchan =
449 if not (Pcre.pmatch ~rex:(Pcre.regexp "^/") path) then
450 respond_error ~code:400 outchan
452 respond_file ~fname:(Http_misc.strip_heading_slash path) outchan
453 let start ?(addr = default_addr) ?(port = default_port) () =
454 start ~addr ~port callback