From: Stefano Zacchiroli Date: Thu, 14 Nov 2002 11:57:58 +0000 (+0000) Subject: no longer use -pack and Http.*, now interface is the usual Http_* X-Git-Tag: V_0_0_3~16 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=6a8da4dd52033adfe80533f7467439aec1561147;p=helm.git no longer use -pack and Http.*, now interface is the usual Http_* --- diff --git a/helm/DEVEL/ocaml-http/.depend b/helm/DEVEL/ocaml-http/.depend index 72d1e0263..528e32d66 100644 --- a/helm/DEVEL/ocaml-http/.depend +++ b/helm/DEVEL/ocaml-http/.depend @@ -1,16 +1,15 @@ -common.cmo: types.cmi common.cmi -common.cmx: types.cmx common.cmi -daemon.cmo: common.cmi misc.cmi request.cmi types.cmi daemon.cmi -daemon.cmx: common.cmx misc.cmx request.cmx types.cmx daemon.cmi -misc.cmo: misc.cmi -misc.cmx: misc.cmi -request.cmo: common.cmi request.cmi -request.cmx: common.cmx request.cmi -response.cmo: common.cmi daemon.cmi types.cmi response.cmi -response.cmx: common.cmx daemon.cmx types.cmx response.cmi -types.cmo: types.cmi -types.cmx: types.cmi -common.cmi: types.cmi -daemon.cmi: types.cmi -request.cmi: types.cmi -response.cmi: types.cmi +http_common.cmo: http_types.cmi http_common.cmi +http_common.cmx: http_types.cmx http_common.cmi +http_daemon.cmo: http_common.cmi http_misc.cmi http_request.cmi \ + http_types.cmi http_daemon.cmi +http_daemon.cmx: http_common.cmx http_misc.cmx http_request.cmx \ + http_types.cmx http_daemon.cmi +http_misc.cmo: http_misc.cmi +http_misc.cmx: http_misc.cmi +http_request.cmo: http_common.cmi http_request.cmi +http_request.cmx: http_common.cmx http_request.cmi +http_response.cmo: http_common.cmi http_daemon.cmi http_response.cmi +http_response.cmx: http_common.cmx http_daemon.cmx http_response.cmi +http_types.cmo: http_types.cmi +http_types.cmx: http_types.cmi +http_common.cmi: http_types.cmi diff --git a/helm/DEVEL/ocaml-http/Makefile b/helm/DEVEL/ocaml-http/Makefile index 950c72035..4f4def3fe 100644 --- a/helm/DEVEL/ocaml-http/Makefile +++ b/helm/DEVEL/ocaml-http/Makefile @@ -1,6 +1,7 @@ include Makefile.defs -MODULES = common misc types request daemon response +MODULES = http_common http_misc http_types http_request http_daemon http_response +PUBLIC_MODULES = http_common http_types http_request http_daemon http_response DESTDIR = $(shell $(OCAMLFIND) printconf stdlib) all: http.cma @@ -24,14 +25,10 @@ depend: %.cmx: %.ml %.cmi $(OCAMLOPT) -c $< -http.cmo: $(patsubst %,%.cmo,$(MODULES)) - ocamlc -pack -o $@ $^ -http.cmx: $(patsubst %,%.cmx,$(MODULES)) - ocamlopt -pack -o $@ $^ -http.cma: http.cmo - $(OCAMLC) -a -o $@ $< -http.cmxa: http.cmx - $(OCAMLOPT) -a -o $@ $< +http.cma: $(patsubst %,%.cmo,$(MODULES)) + $(OCAMLC) -a -o $@ $^ +http.cmxa: $(patsubst %,%.cmx,$(MODULES)) + $(OCAMLOPT) -a -o $@ $^ meta: META META: META.in @@ -55,7 +52,8 @@ dist: distclean depend rm -rf $(DISTDIR)/ install: META $(OCAMLFIND) install -destdir $(DESTDIR) $(PKGNAME) \ - META common.mli types.mli request.mli daemon.mli response.mli http.* + META $(patsubst %,%.mli,$(PUBLIC_MODULES)) \ + $(patsubst %,%.cmi,$(PUBLIC_MODULES)) http.cm{,x}a http.a .PHONY: \ all opt world examples examples.opt depend clean distclean dist \ diff --git a/helm/DEVEL/ocaml-http/Makefile.defs b/helm/DEVEL/ocaml-http/Makefile.defs index a22325292..060a57037 100644 --- a/helm/DEVEL/ocaml-http/Makefile.defs +++ b/helm/DEVEL/ocaml-http/Makefile.defs @@ -8,7 +8,7 @@ OCAMLOPT = $(OCAMLFIND) ocamlopt $(COMMON_OPTS) OCAMLDEP = $(OCAMLFIND) ocamldep $(COMMON_OPTS) DISTNAME = ocaml-http -DISTVERSION = 0.0.1 +DISTVERSION = 0.0.2 DISTDIR = $(DISTNAME)-$(DISTVERSION) EXTRA_DIST = INSTALL LICENSE README META.in Makefile Makefile.defs .depend tophttp diff --git a/helm/DEVEL/ocaml-http/common.ml b/helm/DEVEL/ocaml-http/common.ml deleted file mode 100644 index b175d2e38..000000000 --- a/helm/DEVEL/ocaml-http/common.ml +++ /dev/null @@ -1,193 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> Stefano Zacchiroli - - 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 -*) - -exception Invalid_HTTP_version of string -exception Invalid_code of int -exception Invalid_status of Types.status - -let http_version = `HTTP_1_1 - -let string_of_version = function - | `HTTP_1_0 -> "HTTP/1.0" - | `HTTP_1_1 -> "HTTP/1.1" - -let version_of_string = function - | "HTTP/1.0" -> `HTTP_1_0 - | "HTTP/1.1" -> `HTTP_1_1 - | invalid_version -> raise (Invalid_HTTP_version invalid_version) - -let status_of_code = function - | 100 -> `Informational `Continue - | 101 -> `Informational `Switching_protocols - | 200 -> `Success `OK - | 201 -> `Success `Created - | 202 -> `Success `Accepted - | 203 -> `Success `Non_authoritative_information - | 204 -> `Success `No_content - | 205 -> `Success `Reset_content - | 206 -> `Success `Partial_content - | 300 -> `Redirection `Multiple_choices - | 301 -> `Redirection `Moved_permanently - | 302 -> `Redirection `Found - | 303 -> `Redirection `See_other - | 304 -> `Redirection `Not_modified - | 305 -> `Redirection `Use_proxy - | 307 -> `Redirection `Temporary_redirect - | 400 -> `Client_error `Bad_request - | 401 -> `Client_error `Unauthorized - | 402 -> `Client_error `Payment_required - | 403 -> `Client_error `Forbidden - | 404 -> `Client_error `Not_found - | 405 -> `Client_error `Method_not_allowed - | 406 -> `Client_error `Not_acceptable - | 407 -> `Client_error `Proxy_authentication_required - | 408 -> `Client_error `Request_time_out - | 409 -> `Client_error `Conflict - | 410 -> `Client_error `Gone - | 411 -> `Client_error `Length_required - | 412 -> `Client_error `Precondition_failed - | 413 -> `Client_error `Request_entity_too_large - | 414 -> `Client_error `Request_URI_too_large - | 415 -> `Client_error `Unsupported_media_type - | 416 -> `Client_error `Requested_range_not_satisfiable - | 417 -> `Client_error `Expectation_failed - | 500 -> `Server_error `Internal_server_error - | 501 -> `Server_error `Not_implemented - | 502 -> `Server_error `Bad_gateway - | 503 -> `Server_error `Service_unavailable - | 504 -> `Server_error `Gateway_time_out - | 505 -> `Server_error `HTTP_version_not_supported - | invalid_code -> raise (Invalid_code invalid_code) - -let code_of_status = function - | `Informational `Continue -> 100 - | `Informational `Switching_protocols -> 101 - | `Success `OK -> 200 - | `Success `Created -> 201 - | `Success `Accepted -> 202 - | `Success `Non_authoritative_information -> 203 - | `Success `No_content -> 204 - | `Success `Reset_content -> 205 - | `Success `Partial_content -> 206 - | `Redirection `Multiple_choices -> 300 - | `Redirection `Moved_permanently -> 301 - | `Redirection `Found -> 302 - | `Redirection `See_other -> 303 - | `Redirection `Not_modified -> 304 - | `Redirection `Use_proxy -> 305 - | `Redirection `Temporary_redirect -> 307 - | `Client_error `Bad_request -> 400 - | `Client_error `Unauthorized -> 401 - | `Client_error `Payment_required -> 402 - | `Client_error `Forbidden -> 403 - | `Client_error `Not_found -> 404 - | `Client_error `Method_not_allowed -> 405 - | `Client_error `Not_acceptable -> 406 - | `Client_error `Proxy_authentication_required -> 407 - | `Client_error `Request_time_out -> 408 - | `Client_error `Conflict -> 409 - | `Client_error `Gone -> 410 - | `Client_error `Length_required -> 411 - | `Client_error `Precondition_failed -> 412 - | `Client_error `Request_entity_too_large -> 413 - | `Client_error `Request_URI_too_large -> 414 - | `Client_error `Unsupported_media_type -> 415 - | `Client_error `Requested_range_not_satisfiable -> 416 - | `Client_error `Expectation_failed -> 417 - | `Server_error `Internal_server_error -> 500 - | `Server_error `Not_implemented -> 501 - | `Server_error `Bad_gateway -> 502 - | `Server_error `Service_unavailable -> 503 - | `Server_error `Gateway_time_out -> 504 - | `Server_error `HTTP_version_not_supported -> 505 - -let reason_phrase_of_code = function - | 100 -> "Continue" - | 101 -> "Switching protocols" - | 200 -> "OK" - | 201 -> "Created" - | 202 -> "Accepted" - | 203 -> "Non authoritative information" - | 204 -> "No content" - | 205 -> "Reset content" - | 206 -> "Partial content" - | 300 -> "Multiple choices" - | 301 -> "Moved permanently" - | 302 -> "Found" - | 303 -> "See other" - | 304 -> "Not modified" - | 305 -> "Use proxy" - | 307 -> "Temporary redirect" - | 400 -> "Bad request" - | 401 -> "Unauthorized" - | 402 -> "Payment required" - | 403 -> "Forbidden" - | 404 -> "Not found" - | 405 -> "Method not allowed" - | 406 -> "Not acceptable" - | 407 -> "Proxy authentication required" - | 408 -> "Request time out" - | 409 -> "Conflict" - | 410 -> "Gone" - | 411 -> "Length required" - | 412 -> "Precondition failed" - | 413 -> "Request entity too large" - | 414 -> "Request URI too large" - | 415 -> "Unsupported media type" - | 416 -> "Requested range not satisfiable" - | 417 -> "Expectation failed" - | 500 -> "Internal server error" - | 501 -> "Not implemented" - | 502 -> "Bad gateway" - | 503 -> "Service unavailable" - | 504 -> "Gateway time out" - | 505 -> "HTTP version not supported" - | invalid_code -> raise (Invalid_code invalid_code) - -let reason_phrase_of_status s = reason_phrase_of_code (code_of_status s) - -let is_informational code = - match status_of_code code with - | `Informational _ -> true - | _ -> false - -let is_success code = - match status_of_code code with - | `Success _ -> true - | _ -> false - -let is_redirection code = - match status_of_code code with - | `Redirection _ -> true - | _ -> false - -let is_client_error code = - match status_of_code code with - | `Client_error _ -> true - | _ -> false - -let is_server_error code = - match status_of_code code with - | `Server_error _ -> true - | _ -> false - -let is_error code = is_client_error code || is_server_error code - diff --git a/helm/DEVEL/ocaml-http/common.mli b/helm/DEVEL/ocaml-http/common.mli deleted file mode 100644 index 1b2874837..000000000 --- a/helm/DEVEL/ocaml-http/common.mli +++ /dev/null @@ -1,43 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> Stefano Zacchiroli - - 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 -*) - -exception Invalid_HTTP_version of string -exception Invalid_code of int -exception Invalid_status of Types.status - -val http_version: Types.version - -val string_of_version: Types.version -> string -val version_of_string: string -> Types.version - -val status_of_code: int -> Types.status -val code_of_status: [< Types.status] -> int - -val reason_phrase_of_code: int -> string -val reason_phrase_of_status: [< Types.status] -> string - -val is_informational: int -> bool -val is_success: int -> bool -val is_redirection: int -> bool -val is_client_error: int -> bool -val is_server_error: int -> bool -val is_error: int -> bool - diff --git a/helm/DEVEL/ocaml-http/daemon.ml b/helm/DEVEL/ocaml-http/daemon.ml deleted file mode 100644 index 19ba359fe..000000000 --- a/helm/DEVEL/ocaml-http/daemon.ml +++ /dev/null @@ -1,452 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> Stefano Zacchiroli - - 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 where path is a string representing the - requested path and query_params is a list of pairs (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 -> 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 - " " - [ Common.string_of_version version; - string_of_int code; - Common.reason_phrase_of_code code ] - in - send_raw ~data:(status_line ^ crlf) - -let send_status_line ?(version = 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 = 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", 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 = Common.reason_phrase_of_code code in - let body = - sprintf -" - -%d %s - -

%d - %s

%s -" - 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 = 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 = Common.http_version) ?(code = 301) ?status outchan = - let code = - match status with - | None -> code - | Some (s: Types.redirection_status) -> Common.code_of_status s - in - send_empty_response - "Daemon.respond_redirect" ~is_valid_status:Common.is_redirection - ~headers:["Location", location] ~body () - ~version ~code outchan - -let respond_error - ?body - ?(version = Common.http_version) ?(code = 400) ?status outchan = - let code = - match status with - | None -> code - | Some s -> Common.code_of_status s - in - send_empty_response - "Daemon.respond_error" ~is_valid_status:Common.is_error ~body () - ~version ~code outchan - -let respond_not_found ~url ?(version = Common.http_version) outchan = - send_empty_response - "Daemon.respond_not_found" ~body:None () - ~version ~code:404 outchan - -let respond_forbidden ~url ?(version = 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 "\n%s\n\n" name; - let (dirs, files) = - List.partition (fun e -> Misc.is_directory (path ^ e)) (Misc.ls dir) - in - List.iter - (fun d -> fprintf outchan "%s/
\n" d d) - (List.sort compare dirs); - List.iter - (fun f -> fprintf outchan "%s
\n" f f) - (List.sort compare files); - fprintf outchan "\n"; - flush outchan - -let respond_file ~fname ?(version = 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 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 (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: 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: ' '" ^ - "
\nwhile received request 1st line was:
\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: (Types.request -> out_channel -> unit)) - = - let wrapper path params outchan = - let req = new 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:(Misc.strip_heading_slash path) outchan - let start ?(addr = default_addr) ?(port = default_port) () = - start ~addr ~port callback - end - diff --git a/helm/DEVEL/ocaml-http/daemon.mli b/helm/DEVEL/ocaml-http/daemon.mli deleted file mode 100644 index c7ffee437..000000000 --- a/helm/DEVEL/ocaml-http/daemon.mli +++ /dev/null @@ -1,114 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> Stefano Zacchiroli - - 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 -*) - - (** send a CRLF sequence on the given output channel, this is mandatory after - the last header was sent and before start sending the response body *) -val send_CRLF: out_channel -> unit - - (** send response status line, version is the http version used in response, - either code or status must be given (not both, not none) which represent the - HTTP response code, outchan is the output channel to which send status line *) -val send_status_line: - ?version: Types.version -> ?code: int -> ?status: Types.status -> - out_channel -> - unit - - (** like send_status_line but additionally will also send "Date" and "Server" - standard headers *) -val send_basic_headers: - ?version: Types.version -> ?code: int -> ?status: Types.status -> - out_channel -> - unit - - (** send an HTTP header on outchan *) -val send_header: header: string -> value: string -> out_channel -> unit - - (** as send_header, but for a list of pairs *) -val send_headers: headers:(string * string) list -> out_channel -> unit - - (** send a file through an out_channel, file can be passed as an in_channel - (if 'file' is given) or as a file name (if 'name' is given) *) -val send_file: ?name:string -> ?file:in_channel -> out_channel -> unit - - (** send a 404 (not found) HTTP response *) -val respond_not_found: - url:string -> ?version: Types.version -> out_channel -> unit - - (** send a 403 (forbidden) HTTP response *) -val respond_forbidden: - url:string -> ?version: Types.version -> out_channel -> unit - - (** send a "redirection" class response, optional body argument contains data - that will be displayed in the body of the response, default response status is - 302 (moved permanently), only redirection status are accepted by this - function, other values will @raise Failure *) -val respond_redirect: - location:string -> ?body:string -> - ?version: Types.version -> ?code: int -> ?status: Types.redirection_status -> - out_channel -> - unit - - (** send an "error" response (i.e. 400 <= status < 600), optional body - argument as per send_redirect, default response status is 400 (bad request), - only error status are accepted by this function, other values will - @raise Failure *) -val respond_error: - ?body:string -> - ?version: Types.version -> ?code: int -> ?status: Types.error_status -> - out_channel -> - unit - - (** tipical static pages http daemon behaviour, if requested url is a file, - return it, it it is a directory return a directory listing of it *) -val respond_file: fname:string -> ?version: Types.version -> out_channel -> unit - - (** respond using a prebuilt Types.response object *) -val respond_with: Types.response -> out_channel -> unit - - (** create an HTTP daemon listening on 'addr':'port' (defaults are - addr:"0.0.0.0" and port:80), callback is the user supplied function which - receive as a first parameter the path required by the the HTTP client as a - string, and a list of pair representing parameters passed - via GET. The last argument of the callback is an output_channel connected to - the HTTP client to which the user can write directly. 'timeout' parameter - sets a timeout for each request processed by the daemon, if it's set to None, - daemon waits forever for completed requests (use with care!), default is 5 - minute *) -val start: - ?addr: string -> ?port: int -> ?timeout: int option -> - (string -> (string * string) list -> out_channel -> unit) -> - unit - - (** identical to 'start' above but callback receive two arguments, the second - one is an out_channel as per 'start', but the secondo one is a Request.request - object *) -val start': - ?addr: string -> ?port: int -> ?timeout: int option -> - (Types.request -> out_channel -> unit) -> - unit - - (** Trivial static pages HTTP daemon *) -module Trivial : - sig - val callback : string -> 'a -> out_channel -> unit - val start : ?addr:string -> ?port:int -> unit -> unit - end - diff --git a/helm/DEVEL/ocaml-http/debian/changelog b/helm/DEVEL/ocaml-http/debian/changelog index 01fce0df4..7044be84f 100644 --- a/helm/DEVEL/ocaml-http/debian/changelog +++ b/helm/DEVEL/ocaml-http/debian/changelog @@ -1,3 +1,10 @@ +ocaml-http (0.0.2) unstable; urgency=low + + * Doesn't use anymore -pack, library is now accessible as Http_daemon, + Http_response, ... in place of Http.Daemon, Http.Response, ... + + -- Stefano Zacchiroli Thu, 14 Nov 2002 12:51:07 +0100 + ocaml-http (0.0.1) unstable; urgency=low * Initial Release. diff --git a/helm/DEVEL/ocaml-http/examples/Makefile b/helm/DEVEL/ocaml-http/examples/Makefile index 51e5e2f3b..794b64ef4 100644 --- a/helm/DEVEL/ocaml-http/examples/Makefile +++ b/helm/DEVEL/ocaml-http/examples/Makefile @@ -14,4 +14,4 @@ opt: $(patsubst %,%.opt,$(EXAMPLES)) distclean: clean clean: - -rm -f *.cm[ioax] *.o $(EXAMPLES) + -rm -f *.cm[ioax] *.o $(EXAMPLES) $(patsubst %,%.opt,$(EXAMPLES)) diff --git a/helm/DEVEL/ocaml-http/examples/always_ok_daemon.ml b/helm/DEVEL/ocaml-http/examples/always_ok_daemon.ml index 020d4f600..aafe347e7 100644 --- a/helm/DEVEL/ocaml-http/examples/always_ok_daemon.ml +++ b/helm/DEVEL/ocaml-http/examples/always_ok_daemon.ml @@ -19,8 +19,8 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) -open Http.Daemon;; -open Http.Response;; +open Http_daemon;; +open Http_response;; (* start an http daemon that alway respond with a 200 status code and an empty content *) -start (fun _ _ -> respond_with (new Http.Response.response)) +start (fun _ _ -> respond_with (new Http_response.response)) diff --git a/helm/DEVEL/ocaml-http/examples/dump_args.ml b/helm/DEVEL/ocaml-http/examples/dump_args.ml index ba8e4f5ce..6f3f60bbb 100644 --- a/helm/DEVEL/ocaml-http/examples/dump_args.ml +++ b/helm/DEVEL/ocaml-http/examples/dump_args.ml @@ -32,18 +32,18 @@ in let callback path args outchan = match path with | "/gone" -> - Http.Daemon.respond_redirect + Http_daemon.respond_redirect ~location:"/foo" ~body:"REDIRECT" ~code:302 outchan | "/error" -> - Http.Daemon.respond_error ~body:"ERROR" ~code:500 outchan + Http_daemon.respond_error ~body:"ERROR" ~code:500 outchan | _ -> begin - Http.Daemon.send_basic_headers ~code:200 outchan; - Http.Daemon.send_CRLF outchan; + Http_daemon.send_basic_headers ~code:200 outchan; + Http_daemon.send_CRLF outchan; output_string outchan (dump_args path args) end in -print_endline "Starting custom Http.Daemon ..."; +print_endline "Starting custom Http_daemon ..."; flush stdout; -Http.Daemon.start ~addr:"127.0.0.1" ~port:9999 callback +Http_daemon.start ~addr:"127.0.0.1" ~port:9999 callback diff --git a/helm/DEVEL/ocaml-http/examples/obj_foo.ml b/helm/DEVEL/ocaml-http/examples/obj_foo.ml index 98e024045..d28c7e4ac 100644 --- a/helm/DEVEL/ocaml-http/examples/obj_foo.ml +++ b/helm/DEVEL/ocaml-http/examples/obj_foo.ml @@ -20,6 +20,6 @@ *) let callback req outchan = - Http.Daemon.respond_error ~body:(req#param "foo") outchan + Http_daemon.respond_error ~body:(req#param "foo") outchan in -Http.Daemon.start' ~addr:"127.0.0.1" ~port:9999 callback +Http_daemon.start' ~addr:"127.0.0.1" ~port:9999 callback diff --git a/helm/DEVEL/ocaml-http/examples/timeout.ml b/helm/DEVEL/ocaml-http/examples/timeout.ml index 56522f52d..261b8ee3a 100644 --- a/helm/DEVEL/ocaml-http/examples/timeout.ml +++ b/helm/DEVEL/ocaml-http/examples/timeout.ml @@ -23,5 +23,5 @@ let callback _ _ outchan = output_string outchan "Here you are!\n"; flush outchan in -Http.Daemon.start ~addr:"127.0.0.1" ~port:9999 ~timeout:(Some 10) callback +Http_daemon.start ~addr:"127.0.0.1" ~port:9999 ~timeout:(Some 10) callback diff --git a/helm/DEVEL/ocaml-http/examples/webfsd.ml b/helm/DEVEL/ocaml-http/examples/webfsd.ml index ef5c1cb07..6babe3dde 100644 --- a/helm/DEVEL/ocaml-http/examples/webfsd.ml +++ b/helm/DEVEL/ocaml-http/examples/webfsd.ml @@ -36,5 +36,5 @@ let argspec = in Arg.parse argspec (fun _ -> ()) ""; Sys.chdir !root; -Http.Daemon.Trivial.start ~addr:!addr ~port:!port () +Http_daemon.Trivial.start ~addr:!addr ~port:!port () diff --git a/helm/DEVEL/ocaml-http/http_common.ml b/helm/DEVEL/ocaml-http/http_common.ml new file mode 100644 index 000000000..8e59dbd58 --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_common.ml @@ -0,0 +1,193 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> Stefano Zacchiroli + + 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 +*) + +exception Invalid_HTTP_version of string +exception Invalid_code of int +exception Invalid_status of Http_types.status + +let http_version = `HTTP_1_1 + +let string_of_version = function + | `HTTP_1_0 -> "HTTP/1.0" + | `HTTP_1_1 -> "HTTP/1.1" + +let version_of_string = function + | "HTTP/1.0" -> `HTTP_1_0 + | "HTTP/1.1" -> `HTTP_1_1 + | invalid_version -> raise (Invalid_HTTP_version invalid_version) + +let status_of_code = function + | 100 -> `Informational `Continue + | 101 -> `Informational `Switching_protocols + | 200 -> `Success `OK + | 201 -> `Success `Created + | 202 -> `Success `Accepted + | 203 -> `Success `Non_authoritative_information + | 204 -> `Success `No_content + | 205 -> `Success `Reset_content + | 206 -> `Success `Partial_content + | 300 -> `Redirection `Multiple_choices + | 301 -> `Redirection `Moved_permanently + | 302 -> `Redirection `Found + | 303 -> `Redirection `See_other + | 304 -> `Redirection `Not_modified + | 305 -> `Redirection `Use_proxy + | 307 -> `Redirection `Temporary_redirect + | 400 -> `Client_error `Bad_request + | 401 -> `Client_error `Unauthorized + | 402 -> `Client_error `Payment_required + | 403 -> `Client_error `Forbidden + | 404 -> `Client_error `Not_found + | 405 -> `Client_error `Method_not_allowed + | 406 -> `Client_error `Not_acceptable + | 407 -> `Client_error `Proxy_authentication_required + | 408 -> `Client_error `Request_time_out + | 409 -> `Client_error `Conflict + | 410 -> `Client_error `Gone + | 411 -> `Client_error `Length_required + | 412 -> `Client_error `Precondition_failed + | 413 -> `Client_error `Request_entity_too_large + | 414 -> `Client_error `Request_URI_too_large + | 415 -> `Client_error `Unsupported_media_type + | 416 -> `Client_error `Requested_range_not_satisfiable + | 417 -> `Client_error `Expectation_failed + | 500 -> `Server_error `Internal_server_error + | 501 -> `Server_error `Not_implemented + | 502 -> `Server_error `Bad_gateway + | 503 -> `Server_error `Service_unavailable + | 504 -> `Server_error `Gateway_time_out + | 505 -> `Server_error `HTTP_version_not_supported + | invalid_code -> raise (Invalid_code invalid_code) + +let code_of_status = function + | `Informational `Continue -> 100 + | `Informational `Switching_protocols -> 101 + | `Success `OK -> 200 + | `Success `Created -> 201 + | `Success `Accepted -> 202 + | `Success `Non_authoritative_information -> 203 + | `Success `No_content -> 204 + | `Success `Reset_content -> 205 + | `Success `Partial_content -> 206 + | `Redirection `Multiple_choices -> 300 + | `Redirection `Moved_permanently -> 301 + | `Redirection `Found -> 302 + | `Redirection `See_other -> 303 + | `Redirection `Not_modified -> 304 + | `Redirection `Use_proxy -> 305 + | `Redirection `Temporary_redirect -> 307 + | `Client_error `Bad_request -> 400 + | `Client_error `Unauthorized -> 401 + | `Client_error `Payment_required -> 402 + | `Client_error `Forbidden -> 403 + | `Client_error `Not_found -> 404 + | `Client_error `Method_not_allowed -> 405 + | `Client_error `Not_acceptable -> 406 + | `Client_error `Proxy_authentication_required -> 407 + | `Client_error `Request_time_out -> 408 + | `Client_error `Conflict -> 409 + | `Client_error `Gone -> 410 + | `Client_error `Length_required -> 411 + | `Client_error `Precondition_failed -> 412 + | `Client_error `Request_entity_too_large -> 413 + | `Client_error `Request_URI_too_large -> 414 + | `Client_error `Unsupported_media_type -> 415 + | `Client_error `Requested_range_not_satisfiable -> 416 + | `Client_error `Expectation_failed -> 417 + | `Server_error `Internal_server_error -> 500 + | `Server_error `Not_implemented -> 501 + | `Server_error `Bad_gateway -> 502 + | `Server_error `Service_unavailable -> 503 + | `Server_error `Gateway_time_out -> 504 + | `Server_error `HTTP_version_not_supported -> 505 + +let reason_phrase_of_code = function + | 100 -> "Continue" + | 101 -> "Switching protocols" + | 200 -> "OK" + | 201 -> "Created" + | 202 -> "Accepted" + | 203 -> "Non authoritative information" + | 204 -> "No content" + | 205 -> "Reset content" + | 206 -> "Partial content" + | 300 -> "Multiple choices" + | 301 -> "Moved permanently" + | 302 -> "Found" + | 303 -> "See other" + | 304 -> "Not modified" + | 305 -> "Use proxy" + | 307 -> "Temporary redirect" + | 400 -> "Bad request" + | 401 -> "Unauthorized" + | 402 -> "Payment required" + | 403 -> "Forbidden" + | 404 -> "Not found" + | 405 -> "Method not allowed" + | 406 -> "Not acceptable" + | 407 -> "Proxy authentication required" + | 408 -> "Request time out" + | 409 -> "Conflict" + | 410 -> "Gone" + | 411 -> "Length required" + | 412 -> "Precondition failed" + | 413 -> "Request entity too large" + | 414 -> "Request URI too large" + | 415 -> "Unsupported media type" + | 416 -> "Requested range not satisfiable" + | 417 -> "Expectation failed" + | 500 -> "Internal server error" + | 501 -> "Not implemented" + | 502 -> "Bad gateway" + | 503 -> "Service unavailable" + | 504 -> "Gateway time out" + | 505 -> "HTTP version not supported" + | invalid_code -> raise (Invalid_code invalid_code) + +let reason_phrase_of_status s = reason_phrase_of_code (code_of_status s) + +let is_informational code = + match status_of_code code with + | `Informational _ -> true + | _ -> false + +let is_success code = + match status_of_code code with + | `Success _ -> true + | _ -> false + +let is_redirection code = + match status_of_code code with + | `Redirection _ -> true + | _ -> false + +let is_client_error code = + match status_of_code code with + | `Client_error _ -> true + | _ -> false + +let is_server_error code = + match status_of_code code with + | `Server_error _ -> true + | _ -> false + +let is_error code = is_client_error code || is_server_error code + diff --git a/helm/DEVEL/ocaml-http/http_common.mli b/helm/DEVEL/ocaml-http/http_common.mli new file mode 100644 index 000000000..172e66e5a --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_common.mli @@ -0,0 +1,43 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> Stefano Zacchiroli + + 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 +*) + +exception Invalid_HTTP_version of string +exception Invalid_code of int +exception Invalid_status of Http_types.status + +val http_version: Http_types.version + +val string_of_version: Http_types.version -> string +val version_of_string: string -> Http_types.version + +val status_of_code: int -> Http_types.status +val code_of_status: [< Http_types.status] -> int + +val reason_phrase_of_code: int -> string +val reason_phrase_of_status: [< Http_types.status] -> string + +val is_informational: int -> bool +val is_success: int -> bool +val is_redirection: int -> bool +val is_client_error: int -> bool +val is_server_error: int -> bool +val is_error: int -> bool + diff --git a/helm/DEVEL/ocaml-http/http_daemon.ml b/helm/DEVEL/ocaml-http/http_daemon.ml new file mode 100644 index 000000000..3fa78b349 --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_daemon.ml @@ -0,0 +1,456 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> Stefano Zacchiroli + + 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 where path is a string representing the + requested path and query_params is a list of pairs (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 +" + +%d %s + +

%d - %s

%s +" + 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 "\n%s\n\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 "%s/
\n" d d) + (List.sort compare dirs); + List.iter + (fun f -> fprintf outchan "%s
\n" f f) + (List.sort compare files); + fprintf outchan "\n"; + 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: ' '" ^ + "
\nwhile received request 1st line was:
\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 + diff --git a/helm/DEVEL/ocaml-http/http_daemon.mli b/helm/DEVEL/ocaml-http/http_daemon.mli new file mode 100644 index 000000000..60384b26c --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_daemon.mli @@ -0,0 +1,117 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> Stefano Zacchiroli + + 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 +*) + + (** send a CRLF sequence on the given output channel, this is mandatory after + the last header was sent and before start sending the response body *) +val send_CRLF: out_channel -> unit + + (** send response status line, version is the http version used in response, + either code or status must be given (not both, not none) which represent the + HTTP response code, outchan is the output channel to which send status line *) +val send_status_line: + ?version: Http_types.version -> ?code: int -> ?status: Http_types.status -> + out_channel -> + unit + + (** like send_status_line but additionally will also send "Date" and "Server" + standard headers *) +val send_basic_headers: + ?version: Http_types.version -> ?code: int -> ?status: Http_types.status -> + out_channel -> + unit + + (** send an HTTP header on outchan *) +val send_header: header: string -> value: string -> out_channel -> unit + + (** as send_header, but for a list of pairs *) +val send_headers: headers:(string * string) list -> out_channel -> unit + + (** send a file through an out_channel, file can be passed as an in_channel + (if 'file' is given) or as a file name (if 'name' is given) *) +val send_file: ?name:string -> ?file:in_channel -> out_channel -> unit + + (** send a 404 (not found) HTTP response *) +val respond_not_found: + url:string -> ?version: Http_types.version -> out_channel -> unit + + (** send a 403 (forbidden) HTTP response *) +val respond_forbidden: + url:string -> ?version: Http_types.version -> out_channel -> unit + + (** send a "redirection" class response, optional body argument contains data + that will be displayed in the body of the response, default response status is + 302 (moved permanently), only redirection status are accepted by this + function, other values will @raise Failure *) +val respond_redirect: + location:string -> ?body:string -> + ?version: Http_types.version -> + ?code: int -> ?status: Http_types.redirection_status -> + out_channel -> + unit + + (** send an "error" response (i.e. 400 <= status < 600), optional body + argument as per send_redirect, default response status is 400 (bad request), + only error status are accepted by this function, other values will + @raise Failure *) +val respond_error: + ?body:string -> + ?version: Http_types.version -> + ?code: int -> ?status: Http_types.error_status -> + out_channel -> + unit + + (** tipical static pages http daemon behaviour, if requested url is a file, + return it, it it is a directory return a directory listing of it *) +val respond_file: + fname:string -> ?version: Http_types.version -> out_channel -> unit + + (** respond using a prebuilt Http_types.response object *) +val respond_with: Http_types.response -> out_channel -> unit + + (** create an HTTP daemon listening on 'addr':'port' (defaults are + addr:"0.0.0.0" and port:80), callback is the user supplied function which + receive as a first parameter the path required by the the HTTP client as a + string, and a list of pair representing parameters passed + via GET. The last argument of the callback is an output_channel connected to + the HTTP client to which the user can write directly. 'timeout' parameter + sets a timeout for each request processed by the daemon, if it's set to None, + daemon waits forever for completed requests (use with care!), default is 5 + minute *) +val start: + ?addr: string -> ?port: int -> ?timeout: int option -> + (string -> (string * string) list -> out_channel -> unit) -> + unit + + (** identical to 'start' above but callback receive two arguments, the second + one is an out_channel as per 'start', but the secondo one is a Request.request + object *) +val start': + ?addr: string -> ?port: int -> ?timeout: int option -> + (Http_types.request -> out_channel -> unit) -> + unit + + (** Trivial static pages HTTP daemon *) +module Trivial : + sig + val callback : string -> 'a -> out_channel -> unit + val start : ?addr:string -> ?port:int -> unit -> unit + end + diff --git a/helm/DEVEL/ocaml-http/http_misc.ml b/helm/DEVEL/ocaml-http/http_misc.ml new file mode 100644 index 000000000..a1ea266a4 --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_misc.ml @@ -0,0 +1,45 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> Stefano Zacchiroli + + 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 +*) + +let date_822 () = + Netdate.mk_mail_date ~zone:Netdate.localzone (Unix.time ()) + +let is_directory name = + match Unix.lstat name with + | { Unix.st_kind = Unix.S_DIR } -> true + | _ -> false + +let filesize fname = (Unix.stat fname).Unix.st_size + +let strip_trailing_slash = + let rex = Pcre.regexp "/$" in + fun s -> Pcre.replace ~rex ~templ:"" s + +let strip_heading_slash = + let rex = Pcre.regexp "^/" in + fun s -> Pcre.replace ~rex ~templ:"" s + +let ls dir = + let rec ls' entries = + try ls' ((Unix.readdir dir)::entries) with End_of_file -> entries + in + ls' [] + diff --git a/helm/DEVEL/ocaml-http/http_misc.mli b/helm/DEVEL/ocaml-http/http_misc.mli new file mode 100644 index 000000000..5a74fe4ff --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_misc.mli @@ -0,0 +1,41 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> Stefano Zacchiroli + + 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 +*) + + (** @return the current date compliant to RFC 1123, which updates RFC 822 + zone info are retrieved from UTC *) +val date_822: unit -> string + + (** @return true if 'name' is a directory on the file system, false otherwise + *) +val is_directory: string -> bool + + (** @return the filesize of fname *) +val filesize: string -> int + + (** strip trailing '/', if any, from a string and @return the new string *) +val strip_trailing_slash: string -> string + + (** strip heading '/', if any, from a string and @return the new string *) +val strip_heading_slash: string -> string + + (** given a dir handle @return a list of entries contained *) +val ls: Unix.dir_handle -> string list + diff --git a/helm/DEVEL/ocaml-http/http_request.ml b/helm/DEVEL/ocaml-http/http_request.ml new file mode 100644 index 000000000..91bc98a67 --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_request.ml @@ -0,0 +1,44 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> Stefano Zacchiroli + + 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 Http_common;; + +exception Param_not_found of string + +class request ~path ~params = + object (self) + val params_tbl = + let tbl = Hashtbl.create (List.length params) in + List.iter (fun (n,v) -> Hashtbl.add tbl n v) params; + tbl + val uri = + path ^ "?" ^ + (String.concat "&" (List.map (fun (n, v) -> n ^ "=" ^ v) params)) + method uri = uri + method path = path + method param name = + try + Hashtbl.find params_tbl name + with Not_found -> + raise (Param_not_found name) + method params = params + end + diff --git a/helm/DEVEL/ocaml-http/http_request.mli b/helm/DEVEL/ocaml-http/http_request.mli new file mode 100644 index 000000000..e8632c4f8 --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_request.mli @@ -0,0 +1,27 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> Stefano Zacchiroli + + 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 +*) + +exception Param_not_found of string + + (** fooish class to enclose callback's arguments *) +class request: + path: string -> params: (string * string) list -> Http_types.request + diff --git a/helm/DEVEL/ocaml-http/http_response.ml b/helm/DEVEL/ocaml-http/http_response.ml new file mode 100644 index 000000000..b71d887fc --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_response.ml @@ -0,0 +1,137 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> Stefano Zacchiroli + + 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 Http_common;; +open Http_daemon;; + +exception Invalid_status_line of string +exception Header_not_found of string + + (* TODO sanity checks on set* methods' arguments (e.g. dates 822 compliant, + code values < 600, ...) *) +class response = + let default_code = 200 in + (* remove all bindings of 'name' from hashtbl 'tbl' *) + let rec hashtbl_remove_all tbl name = + if not (Hashtbl.mem tbl name) then + raise (Header_not_found name); + Hashtbl.remove tbl name; + if Hashtbl.mem tbl name then hashtbl_remove_all tbl name + in + (* "version code reason_phrase" *) + let status_line_re = Pcre.regexp "^(HTTP/\d\.\d) (\d{3}) (.*)$" in + object (self) + val mutable version = Http_common.http_version + val mutable code = default_code val mutable reason: string option = None + val contentsBuf = Buffer.create 1024 + val headers = Hashtbl.create 11 + + method version = version + method setVersion v = version <- v + + method code = code + method setCode c = code <- c + method status = status_of_code code + method setStatus (s: Http_types.status) = code <- code_of_status s + method reason = + match reason with + | None -> reason_phrase_of_code code + | Some r -> r + method setReason r = reason <- Some r + method statusLine = + String.concat + " " + [string_of_version self#version; string_of_int self#code; self#reason] + method setStatusLine s = + try + let subs = Pcre.extract ~rex:status_line_re s in + self#setVersion (Http_common.version_of_string subs.(1)); + self#setCode (int_of_string subs.(2)); + self#setReason subs.(3) + with Not_found -> + raise (Invalid_status_line s) + + method isInformational = is_informational code + method isSuccess = is_success code + method isRedirection = is_redirection code + method isClientError = is_client_error code + method isServerError = is_server_error code + method isError = is_error code + + method contents = Buffer.contents contentsBuf + method setContents c = + Buffer.clear contentsBuf; + Buffer.add_string contentsBuf c + method contentsBuf = contentsBuf + method setContentsBuf b = + Buffer.clear contentsBuf; + Buffer.add_buffer contentsBuf b + method addContents s = Buffer.add_string contentsBuf s + method addContentsBuf b = Buffer.add_buffer contentsBuf b + + (** adds an header named 'name' with value 'value', if an header with the + same name exists, the new value is considered an addition to the header as + specified in RFC 2616, thus getting value for this header will return a + comma separated list of values provided via 'addHeader' *) + method addHeader ~name ~value = Hashtbl.add headers name value + (** set the value of header 'name' to 'value', removing all previous + values if any *) + method replaceHeader ~name ~value = Hashtbl.replace headers name value + (** remove the header named 'name', please note that this remove all + values provided for this header *) + method removeHeader ~name = hashtbl_remove_all headers name + method hasHeader ~name = Hashtbl.mem headers name + (** @return value of header 'name', if multiple values were provided for + header 'name', the return value will be a comma separated list of + provided values as stated in RFC 2616 *) + method header ~name = + if not (self#hasHeader name) then + raise (Header_not_found name); + String.concat ", " (List.rev (Hashtbl.find_all headers name)) + (** @return all headers as a list of pairs *) + method headers = + List.rev + (Hashtbl.fold + (fun name _ headers -> (name, self#header ~name)::headers) + headers + []) + + method contentType = self#header "Content-Type" + method setContentType t = self#replaceHeader "Content-Type" t + method contentEncoding = self#header "Content-Encoding" + method setContentEncoding e = self#replaceHeader "Content-Encoding" e + method date = self#header "Date" + method setDate d = self#replaceHeader "Date" d + method expires = self#header "Expires" + method setExpires t = self#replaceHeader "Expires" t + method server = self#header "Server" + method setServer s = self#replaceHeader "Server" s + + method serialize outchan = + output_string outchan self#statusLine; + send_CRLF outchan; + send_headers self#headers outchan; + send_CRLF outchan; + Buffer.output_buffer outchan contentsBuf; + flush outchan + + end + diff --git a/helm/DEVEL/ocaml-http/http_response.mli b/helm/DEVEL/ocaml-http/http_response.mli new file mode 100644 index 000000000..ec0a58eed --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_response.mli @@ -0,0 +1,25 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> Stefano Zacchiroli + + 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 +*) + +exception Invalid_status_line of string + +class response: Http_types.response + diff --git a/helm/DEVEL/ocaml-http/http_types.ml b/helm/DEVEL/ocaml-http/http_types.ml new file mode 100644 index 000000000..37621ef07 --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_types.ml @@ -0,0 +1,151 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> Stefano Zacchiroli + + 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 +*) + +type version = + [ `HTTP_1_0 + | `HTTP_1_1 + ] + +type meth = [ `GET ] + +type informational_substatus = + [ `Continue + | `Switching_protocols + ] + +type success_substatus = + [ `OK + | `Created + | `Accepted + | `Non_authoritative_information + | `No_content + | `Reset_content + | `Partial_content + ] + +type redirection_substatus = + [ `Multiple_choices + | `Moved_permanently + | `Found + | `See_other + | `Not_modified + | `Use_proxy + | `Temporary_redirect + ] + +type client_error_substatus = + [ `Bad_request + | `Unauthorized + | `Payment_required + | `Forbidden + | `Not_found + | `Method_not_allowed + | `Not_acceptable + | `Proxy_authentication_required + | `Request_time_out + | `Conflict + | `Gone + | `Length_required + | `Precondition_failed + | `Request_entity_too_large + | `Request_URI_too_large + | `Unsupported_media_type + | `Requested_range_not_satisfiable + | `Expectation_failed + ] + +type server_error_substatus = + [ `Internal_server_error + | `Not_implemented + | `Bad_gateway + | `Service_unavailable + | `Gateway_time_out + | `HTTP_version_not_supported + ] + +type informational_status = [ `Informational of informational_substatus ] +type success_status = [ `Success of success_substatus ] +type redirection_status = [ `Redirection of redirection_substatus ] +type client_error_status = [ `Client_error of client_error_substatus ] +type server_error_status = [ `Server_error of server_error_substatus ] + +type error_status = + [ client_error_status + | server_error_status + ] + +type status = + [ informational_status + | success_status + | redirection_status + | client_error_status + | server_error_status + ] + +class type response = + object + method version: version + method setVersion: version -> unit + method code: int + method setCode: int -> unit + method status: status + method setStatus: status -> unit + method reason: string + method setReason: string -> unit + method statusLine: string + method setStatusLine: string -> unit + method isInformational: bool + method isSuccess: bool + method isRedirection: bool + method isClientError: bool + method isServerError: bool + method isError: bool + method contents: string + method setContents: string -> unit + method contentsBuf: Buffer.t + method setContentsBuf: Buffer.t -> unit + method addContents: string -> unit + method addContentsBuf: Buffer.t -> unit + method addHeader: name:string -> value:string -> unit + method replaceHeader: name:string -> value:string -> unit + method removeHeader: name:string -> unit + method hasHeader: name:string -> bool + method header: name:string -> string + method headers: (string * string) list + method contentType: string + method setContentType: string -> unit + method contentEncoding: string + method setContentEncoding: string -> unit + method date: string + method setDate: string -> unit + method expires: string + method setExpires: string -> unit + method server: string + method setServer: string -> unit + method serialize: out_channel -> unit + end +class type request = + object + method uri: string + method path: string + method param: string -> string + method params: (string * string) list + end diff --git a/helm/DEVEL/ocaml-http/misc.ml b/helm/DEVEL/ocaml-http/misc.ml deleted file mode 100644 index a1ea266a4..000000000 --- a/helm/DEVEL/ocaml-http/misc.ml +++ /dev/null @@ -1,45 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> Stefano Zacchiroli - - 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 -*) - -let date_822 () = - Netdate.mk_mail_date ~zone:Netdate.localzone (Unix.time ()) - -let is_directory name = - match Unix.lstat name with - | { Unix.st_kind = Unix.S_DIR } -> true - | _ -> false - -let filesize fname = (Unix.stat fname).Unix.st_size - -let strip_trailing_slash = - let rex = Pcre.regexp "/$" in - fun s -> Pcre.replace ~rex ~templ:"" s - -let strip_heading_slash = - let rex = Pcre.regexp "^/" in - fun s -> Pcre.replace ~rex ~templ:"" s - -let ls dir = - let rec ls' entries = - try ls' ((Unix.readdir dir)::entries) with End_of_file -> entries - in - ls' [] - diff --git a/helm/DEVEL/ocaml-http/misc.mli b/helm/DEVEL/ocaml-http/misc.mli deleted file mode 100644 index 5a74fe4ff..000000000 --- a/helm/DEVEL/ocaml-http/misc.mli +++ /dev/null @@ -1,41 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> Stefano Zacchiroli - - 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 -*) - - (** @return the current date compliant to RFC 1123, which updates RFC 822 - zone info are retrieved from UTC *) -val date_822: unit -> string - - (** @return true if 'name' is a directory on the file system, false otherwise - *) -val is_directory: string -> bool - - (** @return the filesize of fname *) -val filesize: string -> int - - (** strip trailing '/', if any, from a string and @return the new string *) -val strip_trailing_slash: string -> string - - (** strip heading '/', if any, from a string and @return the new string *) -val strip_heading_slash: string -> string - - (** given a dir handle @return a list of entries contained *) -val ls: Unix.dir_handle -> string list - diff --git a/helm/DEVEL/ocaml-http/request.ml b/helm/DEVEL/ocaml-http/request.ml deleted file mode 100644 index 0f5681f7f..000000000 --- a/helm/DEVEL/ocaml-http/request.ml +++ /dev/null @@ -1,44 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> Stefano Zacchiroli - - 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 Common;; - -exception Param_not_found of string - -class request ~path ~params = - object (self) - val params_tbl = - let tbl = Hashtbl.create (List.length params) in - List.iter (fun (n,v) -> Hashtbl.add tbl n v) params; - tbl - val uri = - path ^ "?" ^ - (String.concat "&" (List.map (fun (n, v) -> n ^ "=" ^ v) params)) - method uri = uri - method path = path - method param name = - try - Hashtbl.find params_tbl name - with Not_found -> - raise (Param_not_found name) - method params = params - end - diff --git a/helm/DEVEL/ocaml-http/request.mli b/helm/DEVEL/ocaml-http/request.mli deleted file mode 100644 index 9f2e93656..000000000 --- a/helm/DEVEL/ocaml-http/request.mli +++ /dev/null @@ -1,26 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> Stefano Zacchiroli - - 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 -*) - -exception Param_not_found of string - - (** fooish class to enclose callback's arguments *) -class request: path: string -> params: (string * string) list -> Types.request - diff --git a/helm/DEVEL/ocaml-http/response.ml b/helm/DEVEL/ocaml-http/response.ml deleted file mode 100644 index caad5ab56..000000000 --- a/helm/DEVEL/ocaml-http/response.ml +++ /dev/null @@ -1,137 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> Stefano Zacchiroli - - 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 Common;; -open Daemon;; - -exception Invalid_status_line of string -exception Header_not_found of string - - (* TODO sanity checks on set* methods' arguments (e.g. dates 822 compliant, - code values < 600, ...) *) -class response = - let default_code = 200 in - (* remove all bindings of 'name' from hashtbl 'tbl' *) - let rec hashtbl_remove_all tbl name = - if not (Hashtbl.mem tbl name) then - raise (Header_not_found name); - Hashtbl.remove tbl name; - if Hashtbl.mem tbl name then hashtbl_remove_all tbl name - in - (* "version code reason_phrase" *) - let status_line_re = Pcre.regexp "^(HTTP/\d\.\d) (\d{3}) (.*)$" in - object (self) - val mutable version = Common.http_version - val mutable code = default_code val mutable reason: string option = None - val contentsBuf = Buffer.create 1024 - val headers = Hashtbl.create 11 - - method version = version - method setVersion v = version <- v - - method code = code - method setCode c = code <- c - method status = status_of_code code - method setStatus (s: Types.status) = code <- code_of_status s - method reason = - match reason with - | None -> reason_phrase_of_code code - | Some r -> r - method setReason r = reason <- Some r - method statusLine = - String.concat - " " - [string_of_version self#version; string_of_int self#code; self#reason] - method setStatusLine s = - try - let subs = Pcre.extract ~rex:status_line_re s in - self#setVersion (Common.version_of_string subs.(1)); - self#setCode (int_of_string subs.(2)); - self#setReason subs.(3) - with Not_found -> - raise (Invalid_status_line s) - - method isInformational = is_informational code - method isSuccess = is_success code - method isRedirection = is_redirection code - method isClientError = is_client_error code - method isServerError = is_server_error code - method isError = is_error code - - method contents = Buffer.contents contentsBuf - method setContents c = - Buffer.clear contentsBuf; - Buffer.add_string contentsBuf c - method contentsBuf = contentsBuf - method setContentsBuf b = - Buffer.clear contentsBuf; - Buffer.add_buffer contentsBuf b - method addContents s = Buffer.add_string contentsBuf s - method addContentsBuf b = Buffer.add_buffer contentsBuf b - - (** adds an header named 'name' with value 'value', if an header with the - same name exists, the new value is considered an addition to the header as - specified in RFC 2616, thus getting value for this header will return a - comma separated list of values provided via 'addHeader' *) - method addHeader ~name ~value = Hashtbl.add headers name value - (** set the value of header 'name' to 'value', removing all previous - values if any *) - method replaceHeader ~name ~value = Hashtbl.replace headers name value - (** remove the header named 'name', please note that this remove all - values provided for this header *) - method removeHeader ~name = hashtbl_remove_all headers name - method hasHeader ~name = Hashtbl.mem headers name - (** @return value of header 'name', if multiple values were provided for - header 'name', the return value will be a comma separated list of - provided values as stated in RFC 2616 *) - method header ~name = - if not (self#hasHeader name) then - raise (Header_not_found name); - String.concat ", " (List.rev (Hashtbl.find_all headers name)) - (** @return all headers as a list of pairs *) - method headers = - List.rev - (Hashtbl.fold - (fun name _ headers -> (name, self#header ~name)::headers) - headers - []) - - method contentType = self#header "Content-Type" - method setContentType t = self#replaceHeader "Content-Type" t - method contentEncoding = self#header "Content-Encoding" - method setContentEncoding e = self#replaceHeader "Content-Encoding" e - method date = self#header "Date" - method setDate d = self#replaceHeader "Date" d - method expires = self#header "Expires" - method setExpires t = self#replaceHeader "Expires" t - method server = self#header "Server" - method setServer s = self#replaceHeader "Server" s - - method serialize outchan = - output_string outchan self#statusLine; - send_CRLF outchan; - send_headers self#headers outchan; - send_CRLF outchan; - Buffer.output_buffer outchan contentsBuf; - flush outchan - - end - diff --git a/helm/DEVEL/ocaml-http/response.mli b/helm/DEVEL/ocaml-http/response.mli deleted file mode 100644 index 84011aaba..000000000 --- a/helm/DEVEL/ocaml-http/response.mli +++ /dev/null @@ -1,25 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> Stefano Zacchiroli - - 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 -*) - -exception Invalid_status_line of string - -class response: Types.response - diff --git a/helm/DEVEL/ocaml-http/types.ml b/helm/DEVEL/ocaml-http/types.ml deleted file mode 100644 index 37621ef07..000000000 --- a/helm/DEVEL/ocaml-http/types.ml +++ /dev/null @@ -1,151 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> Stefano Zacchiroli - - 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 -*) - -type version = - [ `HTTP_1_0 - | `HTTP_1_1 - ] - -type meth = [ `GET ] - -type informational_substatus = - [ `Continue - | `Switching_protocols - ] - -type success_substatus = - [ `OK - | `Created - | `Accepted - | `Non_authoritative_information - | `No_content - | `Reset_content - | `Partial_content - ] - -type redirection_substatus = - [ `Multiple_choices - | `Moved_permanently - | `Found - | `See_other - | `Not_modified - | `Use_proxy - | `Temporary_redirect - ] - -type client_error_substatus = - [ `Bad_request - | `Unauthorized - | `Payment_required - | `Forbidden - | `Not_found - | `Method_not_allowed - | `Not_acceptable - | `Proxy_authentication_required - | `Request_time_out - | `Conflict - | `Gone - | `Length_required - | `Precondition_failed - | `Request_entity_too_large - | `Request_URI_too_large - | `Unsupported_media_type - | `Requested_range_not_satisfiable - | `Expectation_failed - ] - -type server_error_substatus = - [ `Internal_server_error - | `Not_implemented - | `Bad_gateway - | `Service_unavailable - | `Gateway_time_out - | `HTTP_version_not_supported - ] - -type informational_status = [ `Informational of informational_substatus ] -type success_status = [ `Success of success_substatus ] -type redirection_status = [ `Redirection of redirection_substatus ] -type client_error_status = [ `Client_error of client_error_substatus ] -type server_error_status = [ `Server_error of server_error_substatus ] - -type error_status = - [ client_error_status - | server_error_status - ] - -type status = - [ informational_status - | success_status - | redirection_status - | client_error_status - | server_error_status - ] - -class type response = - object - method version: version - method setVersion: version -> unit - method code: int - method setCode: int -> unit - method status: status - method setStatus: status -> unit - method reason: string - method setReason: string -> unit - method statusLine: string - method setStatusLine: string -> unit - method isInformational: bool - method isSuccess: bool - method isRedirection: bool - method isClientError: bool - method isServerError: bool - method isError: bool - method contents: string - method setContents: string -> unit - method contentsBuf: Buffer.t - method setContentsBuf: Buffer.t -> unit - method addContents: string -> unit - method addContentsBuf: Buffer.t -> unit - method addHeader: name:string -> value:string -> unit - method replaceHeader: name:string -> value:string -> unit - method removeHeader: name:string -> unit - method hasHeader: name:string -> bool - method header: name:string -> string - method headers: (string * string) list - method contentType: string - method setContentType: string -> unit - method contentEncoding: string - method setContentEncoding: string -> unit - method date: string - method setDate: string -> unit - method expires: string - method setExpires: string -> unit - method server: string - method setServer: string -> unit - method serialize: out_channel -> unit - end -class type request = - object - method uri: string - method path: string - method param: string -> string - method params: (string * string) list - end diff --git a/helm/DEVEL/ocaml-http/types.mli b/helm/DEVEL/ocaml-http/types.mli deleted file mode 100644 index aac630960..000000000 --- a/helm/DEVEL/ocaml-http/types.mli +++ /dev/null @@ -1,147 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> Stefano Zacchiroli - - 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 -*) - -type version = [ `HTTP_1_0 | `HTTP_1_1 ] - -and meth = [ `GET ] - -and informational_substatus = [ `Continue | `Switching_protocols ] - -and success_substatus = - [ `Accepted - | `Created - | `No_content - | `Non_authoritative_information - | `OK - | `Partial_content - | `Reset_content - ] - -and redirection_substatus = - [ `Found - | `Moved_permanently - | `Multiple_choices - | `Not_modified - | `See_other - | `Temporary_redirect - | `Use_proxy - ] - -and client_error_substatus = - [ `Bad_request - | `Conflict - | `Expectation_failed - | `Forbidden - | `Gone - | `Length_required - | `Method_not_allowed - | `Not_acceptable - | `Not_found - | `Payment_required - | `Precondition_failed - | `Proxy_authentication_required - | `Request_URI_too_large - | `Request_entity_too_large - | `Request_time_out - | `Requested_range_not_satisfiable - | `Unauthorized - | `Unsupported_media_type - ] - -and server_error_substatus = - [ `Bad_gateway - | `Gateway_time_out - | `HTTP_version_not_supported - | `Internal_server_error - | `Not_implemented - | `Service_unavailable - ] - -and informational_status = [ `Informational of informational_substatus ] -and success_status = [ `Success of success_substatus ] -and redirection_status = [ `Redirection of redirection_substatus ] -and client_error_status = [ `Client_error of client_error_substatus ] -and server_error_status = [ `Server_error of server_error_substatus ] - -and error_status = - [ `Client_error of client_error_substatus - | `Server_error of server_error_substatus - ] - -and status = - [ `Client_error of client_error_substatus - | `Informational of informational_substatus - | `Redirection of redirection_substatus - | `Server_error of server_error_substatus - | `Success of success_substatus - ] - -class type response = - object - method addContents : string -> unit - method addContentsBuf : Buffer.t -> unit - method addHeader : name:string -> value:string -> unit - method code : int - method contentEncoding : string - method contentType : string - method contents : string - method contentsBuf : Buffer.t - method date : string - method expires : string - method hasHeader : name:string -> bool - method header : name:string -> string - method headers : (string * string) list - method isClientError : bool - method isError : bool - method isInformational : bool - method isRedirection : bool - method isServerError : bool - method isSuccess : bool - method reason : string - method removeHeader : name:string -> unit - method replaceHeader : name:string -> value:string -> unit - method serialize : out_channel -> unit - method server : string - method setCode : int -> unit - method setContentEncoding : string -> unit - method setContentType : string -> unit - method setContents : string -> unit - method setContentsBuf : Buffer.t -> unit - method setDate : string -> unit - method setExpires : string -> unit - method setReason : string -> unit - method setServer : string -> unit - method setStatus : status -> unit - method setStatusLine : string -> unit - method setVersion : version -> unit - method status : status - method statusLine : string - method version : version - end - -class type request = - object - method uri: string - method path: string - method param: string -> string - method params: (string * string) list - end -