--- /dev/null
+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
--- /dev/null
+
+In order to build ocaml-http you will need:
+
+ - the ocaml compiler (>= 3.06)
+ [ http://caml.inria.fr ]
+
+ - findlib (>= 0.8)
+ [ http://www.ocaml-programming.de/packages/documentation/findlib/ ]
+
+ - ocamlnet (>= 0.94)
+ [ http://sourceforge.net/projects/ocamlnet ]
+
+ - pcre-ocaml (>= 4.28.2)
+ [ http://www.ai.univie.ac.at/~markus/home/ocaml_sources.html ]
+
+To build the bytecode library:
+
+ $ make all
+
+To build the nativecode library (only if you have an ocaml native code
+compiler):
+
+ $ make opt
+
+To install the built stuff in the OCaml standard library directory (as root):
+
+ # make install
+
+To install the built stuff in another directory:
+
+ $ make install DESTDIR=another_directory
+
+To build a debian package of the library (please note that to build a debian
+package you will also need some additional stuff like debhelper, fakeroot, ...):
+
+ $ fakeroot debian/rules binary
+
--- /dev/null
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
--- /dev/null
+description = "OCaml HTTP daemon library"
+version = "@DISTVERSION@"
+requires = "unix,pcre,netstring"
+archive(byte) = "http.cmo"
+archive(native) = "http.cmx"
--- /dev/null
+include Makefile.defs
+
+MODULES = common misc types request daemon response
+DESTDIR = $(shell $(OCAMLFIND) printconf stdlib)
+
+all: http.cmo
+opt: http.cmx
+world: all opt
+
+examples:
+ $(MAKE) -C examples/
+examples.opt:
+ $(MAKE) -C examples/ opt
+
+include .depend
+
+depend:
+ $(OCAMLDEP) *.ml *.mli > .depend
+
+%.cmi: %.mli
+ $(OCAMLC) -c $<
+%.cmo: %.ml %.cmi
+ $(OCAMLC) -c $<
+%.cmx: %.ml %.cmi
+ $(OCAMLOPT) -c $<
+
+http.cmo: $(patsubst %,%.cmo,$(MODULES))
+ ocamlc -pack -o $@ $^
+http.cmx: $(patsubst %,%.cmx,$(MODULES))
+ ocamlopt -pack -o $@ $^
+
+meta: META
+META: META.in
+ cat META.in | sed -e 's/@DISTVERSION@/$(DISTVERSION)/' > META
+
+clean:
+ $(MAKE) -C examples/ clean
+ -rm -f *.cm[ioax] *.o test{,.opt}
+distclean: clean
+ $(MAKE) -C examples/ distclean
+ -rm -f META
+dist: distclean depend
+ mkdir $(DISTDIR)
+ cp -r \
+ $(patsubst %,%.ml,$(MODULES)) $(patsubst %,%.mli,$(MODULES)) \
+ $(EXTRA_DIST) examples/ debian/ \
+ $(DISTDIR)/
+ -find $(DISTDIR)/ -type d -name CVS -exec rm -rf {} \;
+ -find $(DISTDIR)/ -type f -name ".cvs*" -exec rm -f {} \;
+ tar cvzf $(DISTDIR).tar.gz $(DISTDIR)/
+ rm -rf $(DISTDIR)/
+install: META
+ $(OCAMLFIND) install -destdir $(DESTDIR) $(PKGNAME) META *.mli http.*
+
+.PHONY: \
+ all opt world examples examples.opt depend clean distclean dist \
+ install meta
+
--- /dev/null
+PKGNAME = http
+
+DEBUG_OPTS =
+COMMON_OPTS = $(DEBUG_OPTS) -pp camlp4o -package "unix,pcre,netstring"
+OCAMLFIND = ocamlfind
+OCAMLC = $(OCAMLFIND) ocamlc $(COMMON_OPTS)
+OCAMLOPT = $(OCAMLFIND) ocamlopt $(COMMON_OPTS)
+OCAMLDEP = $(OCAMLFIND) ocamldep $(COMMON_OPTS)
+
+DISTNAME = ocaml-http
+DISTVERSION = 0.0.1
+DISTDIR = $(DISTNAME)-$(DISTVERSION)
+EXTRA_DIST = INSTALL LICENSE README META.in Makefile Makefile.defs .depend tophttp
+
+
--- /dev/null
+
+ocaml-http is a simple OCaml library for creating HTTP daemons, it is largely
+inspired to the Perl's HTTP:: modules family.
+
+Currently the library contains the following modules:
+
+* Http.Daemon
+
+ this module provide
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+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
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+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
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+open Neturl;;
+open Printf;;
+
+let debug = false
+let debug_print str =
+ prerr_endline ("DEBUG: " ^ str);
+ flush stderr
+
+let default_addr = "0.0.0.0"
+let default_port = 80
+let default_timeout = 300
+
+(*
+type url_syntax_option =
+ Url_part_not_recognized
+ | Url_part_allowed
+ | Url_part_required
+
+* (1) scheme://user:password@host:port/path;params?query#fragment
+*)
+
+let request_uri_syntax = {
+ url_enable_scheme = Url_part_not_recognized;
+ url_enable_user = Url_part_not_recognized;
+ url_enable_password = Url_part_not_recognized;
+ url_enable_host = Url_part_not_recognized;
+ url_enable_port = Url_part_not_recognized;
+ url_enable_path = Url_part_required;
+ url_enable_param = Url_part_not_recognized;
+ url_enable_query = Url_part_allowed;
+ url_enable_fragment = Url_part_not_recognized;
+ url_enable_other = Url_part_not_recognized;
+ url_accepts_8bits = false;
+ url_is_valid = (fun _ -> true);
+}
+
+let crlf = "\r\n"
+
+exception Malformed_request of string
+exception Unsupported_method of string
+exception Malformed_request_URI of string
+exception Unsupported_HTTP_version of string
+exception Malformed_query of string
+exception Malformed_query_binding of string * string
+
+ (** given a list of length 2
+ @return a pair formed by the elements of the list
+ @raise Assert_failure if the list length isn't 2
+ *)
+let pair_of_2_sized_list = function
+ | [a;b] -> (a,b)
+ | _ -> assert false
+
+ (** given an HTTP like query string (e.g. "name1=value1&name2=value2&...")
+ @return a list of pairs [("name1", "value1"); ("name2", "value2")]
+ @raise Malformed_query if the string isn't a valid query string
+ @raise Malformed_query_binding if some piece of the query isn't valid
+ *)
+let split_query_params =
+ let (bindings_sep, binding_sep) = (Pcre.regexp "&", Pcre.regexp "=") in
+ fun ~query ->
+ let bindings = Pcre.split ~rex:bindings_sep query in
+ if List.length bindings < 1 then
+ raise (Malformed_query query);
+ List.map
+ (fun binding ->
+ let pieces = Pcre.split ~rex:binding_sep binding in
+ if List.length pieces <> 2 then
+ raise (Malformed_query_binding (binding, query));
+ pair_of_2_sized_list pieces)
+ bindings
+
+ (** given an input channel and a separator
+ @return a line read from it (like Pervasives.input_line)
+ line is returned only after reading a separator string; separator string isn't
+ included in the returned value
+ FIXME what about efficiency?, input is performed char-by-char
+ *)
+let generic_input_line ~sep ~ic =
+ let sep_len = String.length sep in
+ if sep_len < 1 then
+ failwith ("Separator '" ^ sep ^ "' is too short!")
+ else (* valid separator *)
+ let line = ref "" in
+ let sep_pointer = ref 0 in
+ try
+ while true do
+ if !sep_pointer >= String.length sep then (* line completed *)
+ raise End_of_file
+ else begin (* incomplete line: need to read more *)
+ let ch = input_char ic in
+ if ch = String.get sep !sep_pointer then (* next piece of sep *)
+ incr sep_pointer
+ else begin (* useful char *)
+ for i = 0 to !sep_pointer - 1 do
+ line := !line ^ (String.make 1 (String.get sep i))
+ done;
+ sep_pointer := 0;
+ line := !line ^ (String.make 1 ch)
+ end
+ end
+ done;
+ assert false (* unreacheable statement *)
+ with End_of_file ->
+ if !line = "" then
+ raise End_of_file
+ else
+ !line
+
+ (** given an input channel, reads from it a GET HTTP request and
+ @return a pair <path, query_params> where path is a string representing the
+ requested path and query_params is a list of pairs <name, value> (the GET
+ parameters)
+ *)
+let parse_http_request =
+ let patch_empty_path s = (if s = "" then "/" else s) in
+ let pieces_sep = Pcre.regexp " " in
+ fun ~ic ->
+ let request_line = generic_input_line ~sep:crlf ~ic in
+ if debug then
+ debug_print ("request_line: '" ^ request_line ^ "'");
+ match Pcre.split ~rex:pieces_sep request_line with
+ | [meth; request_uri_raw; http_version] ->
+ if meth <> "GET" then
+ raise (Unsupported_method meth);
+ (match http_version with
+ | "HTTP/1.0" | "HTTP/1.1" -> ()
+ | _ -> raise (Unsupported_HTTP_version http_version));
+ let request_uri =
+ try
+ url_of_string request_uri_syntax request_uri_raw
+ with Malformed_URL ->
+ raise (Malformed_request_URI request_uri_raw)
+ in
+ let path =
+ patch_empty_path (String.concat "/" (url_path request_uri))
+ in
+ let query_params =
+ try split_query_params (url_query request_uri) with Not_found -> []
+ in
+ (path, query_params)
+ | _ -> raise (Malformed_request request_line)
+
+ (** send raw data on outchan, flushing it afterwards *)
+let send_raw ~data outchan =
+ output_string outchan data;
+ flush outchan
+
+let send_CRLF = send_raw ~data:crlf
+
+ (** TODO perform some sanity test on header and value *)
+let send_header ~header ~value = send_raw ~data:(header ^ ": " ^ value ^ crlf)
+
+let send_headers ~headers outchan =
+ List.iter (fun (header, value) -> send_header ~header ~value outchan) headers
+
+ (** internal: parse a code argument from a function which have two optional
+ arguments "code" and "status" *)
+let get_code_argument func_name =
+ fun ~code ~status ->
+ (match code, status with
+ | Some c, None -> c
+ | None, Some s -> 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
+"<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
+<HTML><HEAD>
+<TITLE>%d %s</TITLE>
+</HEAD><BODY>
+<H1>%d - %s</H1>%s
+</BODY></HTML>"
+ code reason_phrase code reason_phrase
+ (match body with None -> "" | Some text -> "\n" ^ text)
+ in
+ send_raw ~data:body
+
+ (** internal: low level for respond_redirect, respond_error, ...
+ This function send a status line corresponding to a given code, some basic
+ headers, the additional headers (if given) and an HTML page containing the
+ reason phrase; if body is given it will be included in the body of the HTML
+ page *)
+let send_empty_response
+ f_name ?(is_valid_status = fun _ -> true) ?(headers = []) ~body () =
+ fun ?(version = 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 "<html>\n<head><title>%s</title></head>\n<body>\n" name;
+ let (dirs, files) =
+ List.partition (fun e -> Misc.is_directory (path ^ e)) (Misc.ls dir)
+ in
+ List.iter
+ (fun d -> fprintf outchan "<a href=\"%s/\">%s/</a><br />\n" d d)
+ (List.sort compare dirs);
+ List.iter
+ (fun f -> fprintf outchan "<a href=\"%s\">%s</a><br />\n" f f)
+ (List.sort compare files);
+ fprintf outchan "</body>\n</html>";
+ flush outchan
+
+let respond_file ~fname ?(version = 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: '<method> <url> <version>'" ^
+ "<br />\nwhile received request 1st line was:<br />\n" ^ req)
+ outchan
+ | Unsupported_method meth ->
+ respond_error
+ ~code:501
+ ~body:("Method '" ^ meth ^ "' isn't supported (yet)")
+ outchan
+ | Malformed_request_URI uri ->
+ respond_error ~code:400 ~body:("Malformed URL: '" ^ uri ^ "'") outchan
+ | Unsupported_HTTP_version version ->
+ respond_error
+ ~code:505
+ ~body:("HTTP version '" ^ version ^ "' isn't supported (yet)")
+ outchan
+ | Malformed_query query ->
+ respond_error
+ ~code:400 ~body:("Malformed query string '" ^ query ^ "'") outchan
+ | Malformed_query_binding (binding, query) ->
+ respond_error
+ ~code:400
+ ~body:(
+ sprintf "Malformed query element '%s' in query '%s'" binding query)
+ outchan
+ in
+ Unix.establish_server daemon_callback sockaddr
+
+let start'
+ ?(addr = default_addr) ?(port = default_port)
+ ?(timeout = Some default_timeout)
+ (callback: (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
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+ (** 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 <header, value> *)
+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 <parameter, value> 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
+
--- /dev/null
+http (0.0.1) unstable; urgency=low
+
+ * Initial Release.
+
+ -- Stefano Zacchiroli <zack@debian.org> Wed, 13 Nov 2002 13:12:02 +0100
+
--- /dev/null
+Source: http
+Section: devel
+Priority: optional
+Maintainer: Stefano Zacchiroli <zack@debian.org>
+Build-Depends: debhelper (>> 4.0.0), ocaml-3.06, ocaml-findlib, libpcre-ocaml-dev, libocamlnet-ocaml-dev
+Standards-Version: 3.5.7
+
+Package: libhttp-ocaml-dev
+Architecture: any
+Depends: ocaml-3.06, libpcre-ocaml-dev, libocamlnet-ocaml-dev
+Description: OCaml module to build simple HTTP servers
+ OCaml module to build simple HTTP server, largely inspired to Perl's
+ HTTP::Daemon module.
+ .
+ Contains an Http.Daemon module which allow you to create simple HTTP
+ servers, and a set of facility functions to handle HTTP request and
+ responses.
+ .
+ Contains also classes that enclose HTTP request and responses.
--- /dev/null
+This package was debianized by Stefano Zacchiroli <zack@debian.org> on
+Wed, 13 Nov 2002 13:12:02 +0100.
+
+It was downloaded from <fill in ftp site>
+
+Upstream Author:
+ Stefano Zacchiroli <zack@cs.unibo.it>
+
+Copyright:
+
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
--- /dev/null
+/usr/lib/ocaml
--- /dev/null
+examples/*.ml
--- /dev/null
+#!/usr/bin/make -f
+
+#export DH_VERBOSE=1
+export DH_COMPAT=4
+
+TARGETDIR=$(CURDIR)/debian/libhttp-ocaml-dev
+
+build: build-stamp
+build-stamp:
+ dh_testdir
+ $(MAKE) all
+ if [ -x /usr/bin/ocamlopt ]; then $(MAKE) opt; else true; fi
+ touch build-stamp
+
+clean:
+ dh_testdir
+ dh_testroot
+ rm -f build-stamp
+ -$(MAKE) distclean
+ dh_clean
+
+install: build
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+ dh_installdirs
+ $(MAKE) install DESTDIR=$(TARGETDIR)/usr/lib/ocaml
+
+binary-arch: build install
+ dh_testdir
+ dh_testroot
+ dh_installdocs
+ dh_installexamples
+ dh_installchangelogs
+ dh_link
+ dh_strip
+ dh_compress
+ dh_fixperms
+ dh_installdeb
+ dh_shlibdeps
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+binary: binary-arch
+.PHONY: build clean binary-arch binary install
--- /dev/null
+include ../Makefile.defs
+OBJS = ../http.cmo
+OBJS_OPT = ../http.cmx
+EXAMPLES_OPTS = -I .. -linkpkg
+
+EXAMPLES = always_ok_daemon webfsd obj_foo dump_args timeout
+
+all: $(EXAMPLES)
+opt: $(patsubst %,%.opt,$(EXAMPLES))
+%: %.ml $(OBJS)
+ $(OCAMLC) $(EXAMPLES_OPTS) $(OBJS) -o $@ $<
+%.opt: %.ml $(OBJS_OPT)
+ $(OCAMLOPT) $(EXAMPLES_OPTS) $(OBJS_OPT) -o $@ $<
+
+distclean: clean
+clean:
+ -rm -f *.cm[ioax] *.o $(EXAMPLES)
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+open 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))
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+let dump_args path args =
+ Printf.sprintf
+ "PATH: %s\nARGS:\n%s"
+ path
+ (String.concat
+ ""
+ (List.map
+ (fun (name, value) -> "\tNAME: " ^ name ^ ", VALUE: " ^ value ^ "\n")
+ args))
+in
+let callback path args outchan =
+ match path with
+ | "/gone" ->
+ Http.Daemon.respond_redirect
+ ~location:"/foo" ~body:"REDIRECT" ~code:302 outchan
+ | "/error" ->
+ Http.Daemon.respond_error ~body:"ERROR" ~code:500 outchan
+ | _ ->
+ begin
+ 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 ...";
+flush stdout;
+Http.Daemon.start ~addr:"127.0.0.1" ~port:9999 callback
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+let callback req outchan =
+ Http.Daemon.respond_error ~body:(req#param "foo") outchan
+in
+Http.Daemon.start' ~addr:"127.0.0.1" ~port:9999 callback
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+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
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+let def_port = 80 in
+let def_addr = "0.0.0.0" in
+let def_root = Sys.getcwd () in
+
+let port = ref def_port in
+let addr = ref def_addr in
+let root = ref def_root in
+let argspec =
+ [ "-p", Arg.Int (fun p -> port := p),
+ "TCP port on which listen, default: " ^ string_of_int !port;
+ "-a", Arg.String (fun a -> addr := a),
+ "IP address on which listen, default: " ^ !addr;
+ "-r", Arg.String (fun r -> root := r),
+ "DocumentRoot, default: current working directory" ]
+in
+Arg.parse argspec (fun _ -> ()) "";
+Sys.chdir !root;
+Http.Daemon.Trivial.start ~addr:!addr ~port:!port ()
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+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' []
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+ (** @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
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+open 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
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+exception Param_not_found of string
+
+ (** fooish class to enclose callback's arguments *)
+class request: path: string -> params: (string * string) list -> Types.request
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+open 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 <name, value> *)
+ 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
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+exception Invalid_status_line of string
+
+class response: Types.response
+
--- /dev/null
+#use "topfind";;
+#require "unix";;
+#require "pcre";;
+#require "netstring";;
+#load "http.cmo";;
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+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
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+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
+
projects / helm.git / commitdiff