+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ 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 General Public License for more details.
+
+ You should have received a copy of the GNU 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 Neturl;;
+open Printf;;
+
+let debug = false
+let debug_print str =
+ prerr_endline ("DEBUG: " ^ str);
+ flush stderr
+
+let default_addr = "0.0.0.0"
+let default_port = 80
+let default_timeout = 300
+
+(*
+type url_syntax_option =
+ Url_part_not_recognized
+ | Url_part_allowed
+ | Url_part_required
+
+* (1) scheme://user:password@host:port/path;params?query#fragment
+*)
+
+let request_uri_syntax = {
+ url_enable_scheme = Url_part_not_recognized;
+ url_enable_user = Url_part_not_recognized;
+ url_enable_password = Url_part_not_recognized;
+ url_enable_host = Url_part_not_recognized;
+ url_enable_port = Url_part_not_recognized;
+ url_enable_path = Url_part_required;
+ url_enable_param = Url_part_not_recognized;
+ url_enable_query = Url_part_allowed;
+ url_enable_fragment = Url_part_not_recognized;
+ url_enable_other = Url_part_not_recognized;
+ url_accepts_8bits = false;
+ url_is_valid = (fun _ -> true);
+}
+
+let crlf = "\r\n"
+
+exception Malformed_request of string
+exception Unsupported_method of string
+exception Malformed_request_URI of string
+exception Unsupported_HTTP_version of string
+exception Malformed_query of string
+exception Malformed_query_binding of string * string
+
+ (** given a list of length 2
+ @return a pair formed by the elements of the list
+ @raise Assert_failure if the list length isn't 2
+ *)
+let pair_of_2_sized_list = function
+ | [a;b] -> (a,b)
+ | _ -> assert false
+
+ (** given an HTTP like query string (e.g. "name1=value1&name2=value2&...")
+ @return a list of pairs [("name1", "value1"); ("name2", "value2")]
+ @raise Malformed_query if the string isn't a valid query string
+ @raise Malformed_query_binding if some piece of the query isn't valid
+ *)
+let split_query_params =
+ let (bindings_sep, binding_sep) = (Pcre.regexp "&", Pcre.regexp "=") in
+ fun ~query ->
+ let bindings = Pcre.split ~rex:bindings_sep query in
+ if List.length bindings < 1 then
+ raise (Malformed_query query);
+ List.map
+ (fun binding ->
+ let pieces = Pcre.split ~rex:binding_sep binding in
+ if List.length pieces <> 2 then
+ raise (Malformed_query_binding (binding, query));
+ pair_of_2_sized_list pieces)
+ bindings
+
+ (** given an input channel and a separator
+ @return a line read from it (like Pervasives.input_line)
+ line is returned only after reading a separator string; separator string isn't
+ included in the returned value
+ FIXME what about efficiency?, input is performed char-by-char
+ *)
+let generic_input_line ~sep ~ic =
+ let sep_len = String.length sep in
+ if sep_len < 1 then
+ failwith ("Separator '" ^ sep ^ "' is too short!")
+ else (* valid separator *)
+ let line = ref "" in
+ let sep_pointer = ref 0 in
+ try
+ while true do
+ if !sep_pointer >= String.length sep then (* line completed *)
+ raise End_of_file
+ else begin (* incomplete line: need to read more *)
+ let ch = input_char ic in
+ if ch = String.get sep !sep_pointer then (* next piece of sep *)
+ incr sep_pointer
+ else begin (* useful char *)
+ for i = 0 to !sep_pointer - 1 do
+ line := !line ^ (String.make 1 (String.get sep i))
+ done;
+ sep_pointer := 0;
+ line := !line ^ (String.make 1 ch)
+ end
+ end
+ done;
+ assert false (* unreacheable statement *)
+ with End_of_file ->
+ if !line = "" then
+ raise End_of_file
+ else
+ !line
+
+ (** given an input channel, reads from it a GET HTTP request and
+ @return a pair <path, query_params> where path is a string representing the
+ requested path and query_params is a list of pairs <name, value> (the GET
+ parameters)
+ *)
+let parse_http_request =
+ let patch_empty_path s = (if s = "" then "/" else s) in
+ let pieces_sep = Pcre.regexp " " in
+ fun ~ic ->
+ let request_line = generic_input_line ~sep:crlf ~ic in
+ if debug then
+ debug_print ("request_line: '" ^ request_line ^ "'");
+ match Pcre.split ~rex:pieces_sep request_line with
+ | [meth; request_uri_raw; http_version] ->
+ if meth <> "GET" then
+ raise (Unsupported_method meth);
+ (match http_version with
+ | "HTTP/1.0" | "HTTP/1.1" -> ()
+ | _ -> raise (Unsupported_HTTP_version http_version));
+ let request_uri =
+ try
+ url_of_string request_uri_syntax request_uri_raw
+ with Malformed_URL ->
+ raise (Malformed_request_URI request_uri_raw)
+ in
+ let path =
+ patch_empty_path (String.concat "/" (url_path request_uri))
+ in
+ let query_params =
+ try split_query_params (url_query request_uri) with Not_found -> []
+ in
+ (path, query_params)
+ | _ -> raise (Malformed_request request_line)
+
+ (** 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
+
+ (** TODO perform some sanity test on header and value *)
+let send_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: parse a code argument from a function which have two optional
+ arguments "code" and "status" *)
+let get_code_argument func_name =
+ fun ~code ~status ->
+ (match code, status with
+ | Some c, None -> c
+ | None, Some s -> Http_common.code_of_status s
+ | Some _, Some _ ->
+ failwith (func_name ^ " you must give 'code' or 'status', not both")
+ | None, None ->
+ failwith (func_name ^ " you must give 'code' or 'status', not none"))
+
+ (** internal: low level for send_status_line *)
+let send_status_line' ~version ~code =
+ let status_line =
+ String.concat
+ " "
+ [ Http_common.string_of_version version;
+ string_of_int code;
+ Http_common.reason_phrase_of_code code ]
+ in
+ send_raw ~data:(status_line ^ crlf)
+
+let send_status_line
+ ?(version = Http_common.http_version) ?code ?status outchan
+ =
+ send_status_line'
+ ~version
+ ~code:(get_code_argument "Daemon.send_status_line" ~code ~status)
+ outchan
+
+let send_basic_headers
+ ?(version = Http_common.http_version) ?code ?status outchan
+ =
+ send_status_line'
+ ~version ~code:(get_code_argument "Daemon.send_basic_headers" ~code ~status)
+ outchan;
+ send_headers
+ ~headers:["Date", Http_misc.date_822 (); "Server", "OCaml HTTP Daemon"]
+ outchan
+
+ (** 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 =
+ let reason_phrase = Http_common.reason_phrase_of_code code in
+ let body =
+ 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
+ (match body with None -> "" | Some text -> "\n" ^ text)
+ in
+ send_raw ~data:body
+
+ (** 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
+ f_name ?(is_valid_status = fun _ -> true) ?(headers = []) ~body () =
+ fun ?(version = Http_common.http_version) ?code ?status outchan ->
+ let code = get_code_argument f_name ~code ~status in
+ if not (is_valid_status code) then
+ failwith (sprintf "'%d' isn't a valid status code for %s" code f_name)
+ else begin (* status code suitable for answering *)
+ send_basic_headers ~version ~code outchan;
+ send_header ~header:"Connection" ~value:"close" outchan;
+ send_header
+ ~header:"Content-Type"
+ ~value:"text/html; charset=iso-8859-1"
+ outchan;
+ send_headers ~headers outchan;
+ send_CRLF outchan;
+ send_foo_body ~code ~body outchan
+ end
+
+ (* TODO sanity tests on location *)
+let respond_redirect
+ ~location ?body
+ ?(version = Http_common.http_version) ?(code = 301) ?status outchan =
+ let code =
+ match status with
+ | None -> code
+ | Some (s: Http_types.redirection_status) -> Http_common.code_of_status s
+ in
+ send_empty_response
+ "Daemon.respond_redirect" ~is_valid_status:Http_common.is_redirection
+ ~headers:["Location", location] ~body ()
+ ~version ~code outchan
+
+let respond_error
+ ?body
+ ?(version = Http_common.http_version) ?(code = 400) ?status outchan =
+ let code =
+ match status with
+ | None -> code
+ | Some s -> Http_common.code_of_status s
+ in
+ send_empty_response
+ "Daemon.respond_error" ~is_valid_status:Http_common.is_error ~body ()
+ ~version ~code outchan
+
+let respond_not_found ~url ?(version = Http_common.http_version) outchan =
+ send_empty_response
+ "Daemon.respond_not_found" ~body:None ()
+ ~version ~code:404 outchan
+
+let respond_forbidden ~url ?(version = Http_common.http_version) outchan =
+ send_empty_response
+ "Daemon.respond_permission_denied" ~body:None ()
+ ~version ~code:403 outchan
+
+let send_file ?name ?file outchan =
+ let buflen = 1024 in
+ let buf = String.make buflen ' ' in
+ let (file, cleanup) =
+ (match (name, file) with
+ | Some n, None -> (* if we open the file, we close it before returning *)
+ let f = open_in n in
+ f, (fun () -> close_in f)
+ | None, Some f -> (f, (fun () -> ()))
+ | _ -> failwith "Daemon.send_file: either name or file must be given")
+ 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_common.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: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:200 outchan;
+ send_header
+ ~header:"Content-Length"
+ ~value:(string_of_int (Http_misc.filesize fname))
+ outchan;
+ send_CRLF outchan;
+ send_file ~file outchan;
+ close_in file
+ end
+ with
+ | Unix.Unix_error (Unix.EACCES, s, _) when (s = fname) ->
+ respond_forbidden ~url:fname ~version outchan
+ | Sys_error s when
+ (Pcre.pmatch ~rex:(Pcre.regexp (fname ^ ": Permission denied")) s) ->
+ respond_forbidden ~url:fname ~version outchan
+ end
+
+let respond_with (res: Http_types.response) outchan =
+ res#serialize outchan;
+ flush outchan
+
+let start
+ ?(addr = default_addr) ?(port = default_port)
+ ?(timeout = Some default_timeout)
+ callback
+ =
+ let sockaddr = Unix.ADDR_INET (Unix.inet_addr_of_string addr, port) in
+ let timeout_callback signo =
+ if signo = Sys.sigalrm then begin
+ debug_print "TIMEOUT, exiting ...";
+ exit 2
+ end
+ in
+ let daemon_callback inchan outchan =
+ (match timeout with
+ | Some timeout ->
+ ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_callback));
+ ignore (Unix.alarm timeout)
+ | None -> ());
+ try
+ let (path, parameters) = parse_http_request inchan in
+ callback path parameters outchan;
+ flush outchan
+ with
+ | End_of_file ->
+ respond_error ~code:400 ~body:"Unexpected End Of File" outchan
+ | Malformed_request req ->
+ respond_error
+ ~code:400
+ ~body:(
+ "request 1st line format should be: '<method> <url> <version>'" ^
+ "<br />\nwhile received request 1st line was:<br />\n" ^ req)
+ outchan
+ | Unsupported_method meth ->
+ respond_error
+ ~code:501
+ ~body:("Method '" ^ meth ^ "' isn't supported (yet)")
+ outchan
+ | Malformed_request_URI uri ->
+ respond_error ~code:400 ~body:("Malformed URL: '" ^ uri ^ "'") outchan
+ | Unsupported_HTTP_version version ->
+ respond_error
+ ~code:505
+ ~body:("HTTP version '" ^ version ^ "' isn't supported (yet)")
+ outchan
+ | Malformed_query query ->
+ respond_error
+ ~code:400 ~body:("Malformed query string '" ^ query ^ "'") outchan
+ | Malformed_query_binding (binding, query) ->
+ respond_error
+ ~code:400
+ ~body:(
+ sprintf "Malformed query element '%s' in query '%s'" binding query)
+ outchan
+ in
+ Unix.establish_server daemon_callback sockaddr
+
+let start'
+ ?(addr = default_addr) ?(port = default_port)
+ ?(timeout = Some default_timeout)
+ (callback: (Http_types.request -> out_channel -> unit))
+ =
+ let wrapper path params outchan =
+ let req = new Http_request.request ~path ~params in
+ callback req outchan
+ in
+ start ~addr ~port ~timeout wrapper
+
+module Trivial =
+ struct
+ let callback path _ outchan =
+ if not (Pcre.pmatch ~rex:(Pcre.regexp "^/") path) then
+ respond_error ~code:400 outchan
+ else
+ respond_file ~fname:(Http_misc.strip_heading_slash path) outchan
+ let start ?(addr = default_addr) ?(port = default_port) () =
+ start ~addr ~port callback
+ end
+