From 21234d42000f5ceec3fe633344aa2f9564909bed Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 14 Dec 2016 16:43:01 +0100 Subject: [PATCH 001/111] Switch to Cohttp (WIP) --- .jenkins.sh | 1 + .merlin | 1 + Makefile.options | 2 + opam | 4 + src/Makefile | 6 + src/Makefile.filelist | 39 +- src/baselib/ocsigen_stream.ml | 6 +- src/baselib/ocsigen_stream.mli | 2 +- src/extensions/.depend | 14 +- src/extensions/Makefile | 33 +- src/extensions/revproxy.ml | 26 +- src/extensions/staticmod.ml | 109 ++- src/extensions/userconf.ml | 6 +- src/http/Makefile | 3 +- src/http/http_headers.ml | 77 +- src/http/http_headers.mli | 2 +- src/migrate/.depend | 13 + src/migrate/Makefile | 59 ++ src/migrate/of_cohttp.ml | 125 +++ src/migrate/of_cohttp.mli | 33 + src/migrate/to_cohttp.ml | 167 ++++ src/migrate/to_cohttp.mli | 48 + src/server/.depend | 105 +-- src/server/Makefile | 7 +- src/server/ocsigen_cohttp_server.ml | 217 +++++ src/server/ocsigen_cohttp_server.mli | 51 ++ src/server/ocsigen_common_server.mli | 33 - src/server/ocsigen_extensions.ml | 287 +++--- src/server/ocsigen_extensions.mli | 68 +- src/server/ocsigen_http_client.ml | 866 +----------------- src/server/ocsigen_http_client.mli | 118 +-- src/server/ocsigen_local_files.ml | 3 +- src/server/ocsigen_range.ml | 227 ----- src/server/ocsigen_range.mli | 28 - src/server/ocsigen_request_info.ml | 373 -------- src/server/ocsigen_request_info.mli | 274 ------ src/server/ocsigen_server.ml | 1248 +++----------------------- src/server/ocsigen_socket.ml | 5 + src/server/ocsigen_socket.mli | 5 + 39 files changed, 1295 insertions(+), 3396 deletions(-) create mode 100644 src/migrate/.depend create mode 100644 src/migrate/Makefile create mode 100644 src/migrate/of_cohttp.ml create mode 100644 src/migrate/of_cohttp.mli create mode 100644 src/migrate/to_cohttp.ml create mode 100644 src/migrate/to_cohttp.mli create mode 100644 src/server/ocsigen_cohttp_server.ml create mode 100644 src/server/ocsigen_cohttp_server.mli delete mode 100644 src/server/ocsigen_common_server.mli delete mode 100644 src/server/ocsigen_range.ml delete mode 100644 src/server/ocsigen_range.mli delete mode 100644 src/server/ocsigen_request_info.ml delete mode 100644 src/server/ocsigen_request_info.mli diff --git a/.jenkins.sh b/.jenkins.sh index 0865cba5a..1c40a096a 100644 --- a/.jenkins.sh +++ b/.jenkins.sh @@ -1,5 +1,6 @@ opam pin add --no-action ocsigenserver . opam install camlzip +opam pin add tyxml --dev-repo opam install --deps-only ocsigenserver opam install --verbose ocsigenserver diff --git a/.merlin b/.merlin index b2c56b1fc..73aa7401d 100644 --- a/.merlin +++ b/.merlin @@ -10,6 +10,7 @@ PKG ipaddr PKG tyxml tyxml.parser PKG camlzip PKG dynlink +PKG cohttp conduit.lwt-unix S src/** B src/** diff --git a/Makefile.options b/Makefile.options index 1609434aa..0524aa087 100644 --- a/Makefile.options +++ b/Makefile.options @@ -41,6 +41,8 @@ SERVER_PACKAGE := lwt.ssl \ tyxml \ tyxml.parser \ dynlink \ + cohttp.lwt \ + ppx_deriving.std INITPACKAGE := \"$(shell ${OCAMLFIND} query -p-format -recursive \ -separator '\";\"' ${SERVER_PACKAGE})\"; \ diff --git a/opam b/opam index 1b3dfb151..253f23110 100644 --- a/opam +++ b/opam @@ -56,6 +56,10 @@ depends: [ ("dbm" | "sqlite3" | "pgocaml") "ipaddr" {>= "2.1"} "camlp4" + "cohttp" {>= "0.17.0"} + + # REMOVE AFTER DEBUGGING + "ppx_deriving" ] depopts: "camlzip" conflicts: [ diff --git a/src/Makefile b/src/Makefile index eadc5ae0c..091ea432d 100644 --- a/src/Makefile +++ b/src/Makefile @@ -3,18 +3,21 @@ include ../Makefile.config all: metas confs ${MAKE} -C baselib all ${MAKE} -C http all + ${MAKE} -C migrate all ${MAKE} -C server all ${MAKE} -C extensions all byte: metas confs ${MAKE} -C baselib byte ${MAKE} -C http byte + ${MAKE} -C migrate byte ${MAKE} -C server byte ${MAKE} -C extensions byte opt: metas confs ${MAKE} -C baselib opt ${MAKE} -C http opt + ${MAKE} -C migrate opt ${MAKE} -C server opt ${MAKE} -C extensions opt @@ -146,6 +149,7 @@ reinstall: uninstall install clean: clean.local ${MAKE} -C baselib clean ${MAKE} -C http clean + ${MAKE} -C migrate clean ${MAKE} -C server clean ${MAKE} -C extensions clean @@ -159,6 +163,7 @@ clean.local: distclean: clean.local ${MAKE} -C baselib distclean ${MAKE} -C http distclean + ${MAKE} -C migrate distclean ${MAKE} -C server distclean ${MAKE} -C extensions distclean -rm -f *~ \#* .\#* @@ -171,5 +176,6 @@ distclean: clean.local depend: ${MAKE} -C baselib depend ${MAKE} -C http depend + ${MAKE} -C migrate depend ${MAKE} -C server depend ${MAKE} -C extensions depend diff --git a/src/Makefile.filelist b/src/Makefile.filelist index bbbea29d1..abf7c20a9 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -23,8 +23,7 @@ INTF_BASE := baselib/ocsigen_cache.cmi \ server/ocsigen_parseconfig.cmi \ server/ocsigen_http_client.cmi \ server/ocsigen_local_files.cmi \ - server/ocsigen_server.cmi \ - server/ocsigen_request_info.cmi + server/ocsigen_server.cmi INTF := ${INTF_BASE} baselib/ocsigen_getcommandline.cmi @@ -55,24 +54,24 @@ endif PLUGINS_BIN := -PLUGINS_INTF := extensions/ocsigen_comet.cmi \ - extensions/accesscontrol.cmi \ - extensions/authbasic.cmi \ - extensions/ocsipersist.cmi \ - -PLUGINS_IMPL := extensions/staticmod.cmo \ - extensions/cgimod.cmo \ - extensions/redirectmod.cmo \ - extensions/revproxy.cmo \ - extensions/extensiontemplate.cmo \ - extensions/accesscontrol.cmo \ - extensions/userconf.cmo \ - extensions/outputfilter.cmo \ - extensions/authbasic.cmo \ - extensions/rewritemod.cmo \ - extensions/extendconfiguration.cmo \ - extensions/ocsigen_comet.cmo \ - extensions/cors.cmo \ +PLUGINS_INTF := # extensions/ocsigen_comet.cmi \ + # extensions/accesscontrol.cmi \ + # extensions/authbasic.cmi \ + # extensions/ocsipersist.cmi \ + +PLUGINS_IMPL := # extensions/staticmod.cmo \ + # extensions/cgimod.cmo \ + # extensions/redirectmod.cmo \ + # extensions/revproxy.cmo \ + # extensions/extensiontemplate.cmo \ + # extensions/accesscontrol.cmo \ + # extensions/userconf.cmo \ + # extensions/outputfilter.cmo \ + # extensions/authbasic.cmo \ + # extensions/rewritemod.cmo \ + # extensions/extendconfiguration.cmo \ + # extensions/ocsigen_comet.cmo \ + # extensions/cors.cmo \ ifeq "$(CAMLZIP)" "YES" PLUGINS_IMPL += extensions/deflatemod.cmo diff --git a/src/baselib/ocsigen_stream.ml b/src/baselib/ocsigen_stream.ml index b8dd6dcfe..da980669d 100644 --- a/src/baselib/ocsigen_stream.ml +++ b/src/baselib/ocsigen_stream.ml @@ -253,7 +253,7 @@ let of_lwt_stream stream = (** Convert an {!Ocsigen_stream.t} into a {!Lwt_stream.t}. @param is_empty function to skip empty chunk. *) -let to_lwt_stream o_stream = +let to_lwt_stream ?(is_empty = (fun _ -> false)) o_stream = let stream = ref (get o_stream) in let rec wrap () = next !stream >>= function @@ -261,7 +261,9 @@ let to_lwt_stream o_stream = | Finished (Some next) -> stream := next; wrap () | Cont (value, next) -> stream := next; - Lwt.return (Some value) + if is_empty value + then wrap () + else Lwt.return (Some value) in Lwt_stream.from wrap module StringStream = struct diff --git a/src/baselib/ocsigen_stream.mli b/src/baselib/ocsigen_stream.mli index b0d114d94..5b4bca719 100644 --- a/src/baselib/ocsigen_stream.mli +++ b/src/baselib/ocsigen_stream.mli @@ -121,7 +121,7 @@ val of_lwt_stream : 'a Lwt_stream.t -> 'a t (** Convert an {!Ocsigen_stream.t} into a {!Lwt_stream.t}. @param is_empty function to skip empty chunk. *) -val to_lwt_stream : 'a t -> 'a Lwt_stream.t +val to_lwt_stream : ?is_empty:('a -> bool) -> 'a t -> 'a Lwt_stream.t module StringStream : sig diff --git a/src/extensions/.depend b/src/extensions/.depend index 46d0c062c..bc17c88d5 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -72,16 +72,14 @@ redirectmod.cmo : ../server/ocsigen_request_info.cmi \ redirectmod.cmx : ../server/ocsigen_request_info.cmx \ ../baselib/ocsigen_lib.cmx ../http/ocsigen_http_frame.cmx \ ../server/ocsigen_extensions.cmx -revproxy.cmo : ../baselib/ocsigen_stream.cmi \ +revproxy.cmo : ../migrate/of_cohttp.cmi ../baselib/ocsigen_stream.cmi \ ../server/ocsigen_request_info.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../server/ocsigen_http_client.cmi \ - ../http/ocsigen_headers.cmi ../server/ocsigen_extensions.cmi \ - ../http/http_headers.cmi -revproxy.cmx : ../baselib/ocsigen_stream.cmx \ + ../http/ocsigen_http_frame.cmi ../http/ocsigen_headers.cmi \ + ../server/ocsigen_extensions.cmi +revproxy.cmx : ../migrate/of_cohttp.cmx ../baselib/ocsigen_stream.cmx \ ../server/ocsigen_request_info.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../server/ocsigen_http_client.cmx \ - ../http/ocsigen_headers.cmx ../server/ocsigen_extensions.cmx \ - ../http/http_headers.cmx + ../http/ocsigen_http_frame.cmx ../http/ocsigen_headers.cmx \ + ../server/ocsigen_extensions.cmx rewritemod.cmo : ../server/ocsigen_request_info.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi rewritemod.cmx : ../server/ocsigen_request_info.cmx \ diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 0ec279d14..6013a25b0 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -8,9 +8,11 @@ PACKAGE := \ lwt.react \ netstring \ netstring-pcre \ - tyxml.parser + tyxml.parser \ + cohttp.lwt -LIBS := -I ../baselib -I ../http -I ../server ${addprefix -package ,${PACKAGE}} +LIBS := -I ../baselib -I ../http -I ../migrate -I ../server \ + ${addprefix -package ,${PACKAGE}} OCAMLC := $(OCAMLFIND) ocamlc ${BYTEDBG} OCAMLOPT := $(OCAMLFIND) ocamlopt ${OPTDBG} OCAMLDOC := $(OCAMLFIND) ocamldoc @@ -20,19 +22,20 @@ all: byte opt ### Extensions ### -FILES := staticmod.ml \ - cgimod.ml \ - redirectmod.ml \ - revproxy.ml \ - extensiontemplate.ml \ - accesscontrol.ml \ - userconf.ml \ - outputfilter.ml \ - authbasic.ml \ - rewritemod.ml \ - extendconfiguration.ml \ - ocsigen_comet.ml \ - cors.ml \ +FILES := + # staticmod.ml \ + # cgimod.ml \ + # redirectmod.ml \ + # revproxy.ml \ + # extensiontemplate.ml \ + # accesscontrol.ml \ + # userconf.ml \ + # outputfilter.ml \ + # authbasic.ml \ + # rewritemod.ml \ + # extendconfiguration.ml \ + # ocsigen_comet.ml \ + # cors.ml \ ifeq "$(CAMLZIP)" "YES" FILES += deflatemod.ml diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index a9acc8f8a..c1ef7f588 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -25,7 +25,7 @@ experimental Ocsigen_http_client module. TODO - - Change the policy for « trusted servers » for pipelining? + - Change the policy for trusted servers for pipelining? (see ocsigen_http_client.ml) - enhance pipelining - HTTP/1.0 @@ -43,6 +43,10 @@ open Ocsigen_lib open Lwt open Ocsigen_extensions open Simplexmlparser +open Cohttp +open Cohttp_lwt_unix + +module RI = Ocsigen_request_info let section = Lwt_log.Section.make "ocsigen:ext:revproxy" @@ -134,7 +138,7 @@ let gen dir = function | None -> host in - let do_request = + let do_request () = let ri = ri.request_info in let address = Unix.string_of_inet_addr (fst (get_server_address ri)) in let forward = @@ -148,6 +152,7 @@ let gen dir = function then "https" else "http" in +(* let headers = Http_headers.replace Http_headers.x_forwarded_proto @@ -187,12 +192,29 @@ let gen dir = function ~host ~inet_addr ~uri () +*) + + let (meth, version, headers, uri', body) = + Ocsigen_generate.to_cohttp_request ri in + let headers = + Cohttp.Header.add headers + "X-Forwarded-Proto" + (Cohttp.Code.string_of_version version) in + let headers = + Cohttp.Header.add headers + "X-Forwarded-For" + forward in + let headers = Cohttp.Header.remove headers "host" in + let uri = Printf.sprintf "%s://%s%s" + proto host uri in + Client.call ~headers ~body meth (Uri.of_string uri) in Lwt.return (Ext_found (fun () -> do_request () + >|= Of_cohttp.of_response_and_body' >>= fun http_frame -> let headers = http_frame diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index d9e4cf5b6..63c94667f 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -16,21 +16,16 @@ * You should have received a copy of the GNU Lesser 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. -*) -(*****************************************************************************) -(*****************************************************************************) -(* Ocsigen module to load static pages *) -(*****************************************************************************) -(*****************************************************************************) + *) -open Lwt +open Lwt.Infix open Ocsigen_lib open Ocsigen_extensions let section = Lwt_log.Section.make "ocsigen:ext:staticmod" + exception Not_concerned -(*****************************************************************************) (* Structures describing the static pages a each virtual server *) (* A static site is either an entire directory served unconditionnaly, @@ -39,6 +34,7 @@ exception Not_concerned type static_site_kind = | Dir of string (* Serves an entire directory *) | Regexp of regexp_site + and regexp_site = { source_regexp: Netstring_pcre.regexp; dest: Ocsigen_extensions.ud_string; @@ -46,9 +42,6 @@ and regexp_site = { root_checks: Ocsigen_extensions.ud_string option; } - - -(*****************************************************************************) (* Finding files *) (* Does the http status code returned for the page match the given filter ? *) @@ -58,7 +51,6 @@ let http_status_match status_filter status = | Some r -> Netstring_pcre.string_match r (string_of_int status) 0 <> None - (* Checks that the path specified in a userconf is correct. Currently, we check that the path does not contain ".." *) let correct_user_local_file = @@ -67,7 +59,6 @@ let correct_user_local_file = try ignore(Netstring_pcre.search_forward regexp path 0); false with Not_found -> true - (* Find the local file corresponding to [path] in the static site [dir], with [err] as the current http status (in case [dir] is a filter). Raises [Not_Concerned] if [dir] does not match, or returns @@ -121,53 +112,53 @@ let find_static_page ~request ~usermode ~dir ~err ~pathstring = let gen ~usermode ?cache dir = function | Ocsigen_extensions.Req_found (_, r) -> - Lwt.return (Ocsigen_extensions.Ext_do_nothing) + Lwt.return (Ocsigen_extensions.Ext_do_nothing) | Ocsigen_extensions.Req_not_found (err, ri) -> - catch - (fun () -> - Lwt_log.ign_info ~section "Is it a static file?"; - let status_filter, page = - find_static_page ~request:ri ~usermode ~dir ~err - ~pathstring:(Url.string_of_url_path ~encode:false - (Ocsigen_request_info.sub_path ri.request_info)) in - Ocsigen_local_files.content ri page - >>= fun answer -> - let answer = - if status_filter = false then - answer - else - (* The page is an error handler, we propagate - the original error code *) - (Ocsigen_http_frame.Result.update answer ~code:err ()) - in - let (<~) h (n, v) = Http_headers.replace n v h in - let answer = match cache with - | None -> answer - | Some 0 -> - (Ocsigen_http_frame.Result.update answer ~headers: - ((Ocsigen_http_frame.Result.headers answer) - <~ (Http_headers.cache_control, "no-cache") - <~ (Http_headers.expires, "0")) ()) - | Some duration -> - (Ocsigen_http_frame.Result.update answer ~headers: - ((Ocsigen_http_frame.Result.headers answer) - <~ (Http_headers.cache_control, "max-age="^ string_of_int duration) - <~ (Http_headers.expires, Ocsigen_http_com.gmtdate (Unix.time () +. float_of_int duration))) ()) - in - Lwt.return (Ext_found (fun () -> Lwt.return answer)) - ) - - (function - | Ocsigen_local_files.Failed_403 -> return (Ext_next 403) - (* XXX We should try to leave an information about this - error for later *) - | Ocsigen_local_files.NotReadableDirectory -> - return (Ext_next err) - | NoSuchUser | Not_concerned - | Ocsigen_local_files.Failed_404 -> return (Ext_next err) - | e -> fail e - ) - + let try_block () = + Lwt_log.ign_info ~section "Is it a static file?"; + let status_filter, page = + find_static_page ~request:ri ~usermode ~dir ~err + ~pathstring:(Url.string_of_url_path ~encode:false + (Ocsigen_cohttp_server.path_of_request + ri.request_info)) in + Ocsigen_local_files.content ri page + >>= fun answer -> + let answer = + if status_filter = false then + answer + else + (* The page is an error handler, we propagate + the original error code *) + (Ocsigen_http_frame.Result.update answer ~code:err ()) + in + let (<~) h (n, v) = Http_headers.replace n v h in + let answer = match cache with + | None -> answer + | Some 0 -> + (Ocsigen_http_frame.Result.update answer ~headers: + ((Ocsigen_http_frame.Result.headers answer) + <~ (Http_headers.cache_control, "no-cache") + <~ (Http_headers.expires, "0")) ()) + | Some duration -> + (Ocsigen_http_frame.Result.update answer ~headers: + ((Ocsigen_http_frame.Result.headers answer) + <~ (Http_headers.cache_control, "max-age="^ string_of_int duration) + <~ (Http_headers.expires, Ocsigen_http_com.gmtdate (Unix.time () +. float_of_int duration))) ()) + in + Lwt.return (Ext_found (fun () -> Lwt.return answer)) + and catch_block = function + | Ocsigen_local_files.Failed_403 -> + Lwt.return (Ext_next 403) + (* XXX We should try to leave an information about this error + for later *) + | Ocsigen_local_files.NotReadableDirectory -> + Lwt.return (Ext_next err) + | NoSuchUser | Not_concerned | Ocsigen_local_files.Failed_404 -> + Lwt.return (Ext_next err) + | e -> + Lwt.fail e + in + Lwt.catch try_block catch_block (*****************************************************************************) (** Parsing of config file *) diff --git a/src/extensions/userconf.ml b/src/extensions/userconf.ml index 16a87d0a4..ec51109db 100644 --- a/src/extensions/userconf.ml +++ b/src/extensions/userconf.ml @@ -57,11 +57,11 @@ let handle_parsing_error req = function (* Answer returned by userconf when the url matches *) let subresult new_req user_parse_site conf previous_err req req_state = Ext_sub_result - (fun awake cookies_to_set rs -> + (fun cookies_to_set rs -> (* XXX why is rs above never used ?? *) Lwt.catch (fun () -> - user_parse_site conf awake cookies_to_set + user_parse_site conf cookies_to_set (Ocsigen_extensions.Req_not_found (previous_err, new_req)) >>= fun (answer, cookies) -> (* If the request is not satisfied by userconf, the changes @@ -71,7 +71,7 @@ let subresult new_req user_parse_site conf previous_err req req_state = let rec aux ((answer, cts) as r) = match answer with | Ext_sub_result sr -> (* XXX Are these the good cookies ?? *) - sr awake cookies_to_set req_state + sr cookies_to_set req_state >>= aux | Ext_continue_with (newreq, cookies, err) -> Lwt.return diff --git a/src/http/Makefile b/src/http/Makefile index 119ebcb01..eb9473b4e 100644 --- a/src/http/Makefile +++ b/src/http/Makefile @@ -4,7 +4,8 @@ PACKAGE := \ netstring \ netstring-pcre \ lwt.ssl \ - tyxml + tyxml \ + cohttp LIBS := -I ../baselib ${addprefix -package ,${PACKAGE}} OCAMLC := $(OCAMLFIND) ocamlc ${BYTEDBG} diff --git a/src/http/http_headers.ml b/src/http/http_headers.ml index ef334f36e..ee58e0b86 100644 --- a/src/http/http_headers.ml +++ b/src/http/http_headers.ml @@ -18,9 +18,9 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type name = string * string -let name s = (s, String.lowercase s) -let name_to_string = fst +type name = string +let name : string -> name = String.lowercase +let name_to_string (nm : name) : string = nm let accept = name "Accept" let accept_charset = name "Accept-Charset" @@ -75,59 +75,58 @@ module NameHtbl = Hashtbl.Make (struct type t = name - let equal (_, n : _ * string) (_, n') = n = n' - let hash (_,n) = Hashtbl.hash n + let equal n n' = n = n' + let hash n = Hashtbl.hash n end) (****) -module Map = Map.Make (struct - type t = name - let compare (_,n) (_,n') = compare n n' - end) +type t = Cohttp.Header.t -type t = string list Map.t +let empty = Cohttp.Header.init () -let empty = Map.empty - -let find_all n h = List.rev (Map.find n h) +let find_all name map = + let l = List.rev (Cohttp.Header.get_multi map name) in + if l = [] then raise Not_found; + l (*XXX We currently return the last header. Should we fail if there is more than one? *) -let find n h = - match Map.find n h with - v :: _ -> v - | _ -> assert false - -let replace n v h = Map.add n [v] h -let replace_opt n v h = - match v with - None -> Map.remove n h - | Some v -> replace n v h +let find name map = match Cohttp.Header.get_multi map name with + | value :: _ -> value + | _ -> raise Not_found -let add n v h = - let vl = try find_all n h with Not_found -> [] in - Map.add n (v :: vl) h +let replace name value map = Cohttp.Header.replace map name value +let replace_opt name value map = match value with + | None -> Cohttp.Header.remove map name + | Some value -> replace name value map -let iter f h = - Map.iter - (fun n vl -> - match vl with - [v] -> f n v - | _ -> List.iter (fun v -> f n v) (List.rev vl)) - h +let add name value map = Cohttp.Header.add map name value -let fold f h acc = - Map.fold - (fun n vl acc -> f n (List.rev vl) acc) - h acc +let iter func map = + Cohttp.Header.iter + (fun name values -> List.iter (func name) values) + map -let with_defaults h h' = Map.fold Map.add h h' +(* XXX: + * old fold: (name -> string list -> 'a -> 'a) -> t -> 'a -> 'a + * new fold: (string -> string -> 'a -> 'a) -> t -> 'a -> 'a *) +let fold' func map acc = Cohttp.Header.fold func map acc +let fold func map acc = + let ( |> ) a f = f a in + let garbage = Cohttp.Header.fold + (fun key value garbage -> + try List.assoc key garbage + |> fun rest -> + (key, value :: rest) :: (List.remove_assoc key garbage) + with Not_found -> (key, [ value ]) :: garbage) + map [] + in List.fold_left (fun acc (key, values) -> func key values acc) acc garbage +let with_defaults h h' = fold' add h h' -(****) let (<<) h (n, v) = replace n v h let dyn_headers = diff --git a/src/http/http_headers.mli b/src/http/http_headers.mli index 7e7b033cb..0c21528f0 100644 --- a/src/http/http_headers.mli +++ b/src/http/http_headers.mli @@ -79,7 +79,7 @@ val access_control_allow_headers : name (****) -type t +type t = Cohttp.Header.t val empty : t (** returns an empty set of HTTP headers *) diff --git a/src/migrate/.depend b/src/migrate/.depend new file mode 100644 index 000000000..250c176bf --- /dev/null +++ b/src/migrate/.depend @@ -0,0 +1,13 @@ +of_cohttp.cmi : ../http/ocsigen_http_frame.cmi +to_cohttp.cmi : ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi \ + ../http/http_headers.cmi +of_cohttp.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ + ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi of_cohttp.cmi +of_cohttp.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ + ../http/ocsigen_http_frame.cmx ../http/ocsigen_cookies.cmx of_cohttp.cmi +to_cohttp.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ + ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi \ + ../http/http_headers.cmi to_cohttp.cmi +to_cohttp.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ + ../http/ocsigen_http_frame.cmx ../http/ocsigen_cookies.cmx \ + ../http/http_headers.cmx to_cohttp.cmi diff --git a/src/migrate/Makefile b/src/migrate/Makefile new file mode 100644 index 000000000..df14f55da --- /dev/null +++ b/src/migrate/Makefile @@ -0,0 +1,59 @@ +include ../../Makefile.config + +LIBS := -package bytes,lwt,cohttp,netstring,re.emacs -I ../baselib -I ../http +OCAMLC := $(OCAMLFIND) ocamlc${BYTEDBG} +OCAMLOPT := $(OCAMLFIND) ocamlopt ${OPTDBG} +OCAMLDOC := $(OCAMLFIND) ocamldoc +OCAMLDEP := $(OCAMLFIND) ocamldep + +all: byte opt + +### Common files ### + +FILES := of_cohttp.ml \ + to_cohttp.ml \ + +PREDEP := \ + +byte: migrate.cma +opt: migrate.cmxa + +migrate.cma: $(FILES:.ml=.cmo) + ${OCAMLC} -a -o $@ $^ +migrate.cmxa: $(FILES:.ml=.cmx) + ${OCAMLOPT} -a -o $@ $^ + +########## + +%.ml: %.mll + $(OCAMLLEX) $< +%.cmi: %.mli + $(OCAMLC) ${LIBS} -c $< +%.cmo: %.ml + $(OCAMLC) ${LIBS} -c $< +%.cmx: %.ml + $(OCAMLOPT) ${LIBS} -c $< +%.cmxs: %.cmxa + $(OCAMLOPT) -shared -linkall -o $@ $< + +## Clean up + +clean: + -rm -f *.cm* *.o *.a *.annot + -rm -f ${PREDEP} +distclean: clean + -rm -f *~ \#* .\#* + +## Dependencies + +depend: ${PREDEP} + $(OCAMLDEP) ${LIBS} *.mli *.ml > .depend + +type: $(FILES:.ml=.gmli) + +%.gmli: %.ml + $(OCAMLC) ${LIBS} -i $< > $@ + + +FORCE: +-include .depend diff --git a/src/migrate/of_cohttp.ml b/src/migrate/of_cohttp.ml new file mode 100644 index 000000000..830144142 --- /dev/null +++ b/src/migrate/of_cohttp.ml @@ -0,0 +1,125 @@ +open Ocsigen_lib +open Ocsigen_cookies + +let of_version vrs = + let open Ocsigen_http_frame.Http_header in + match vrs with + | `HTTP_1_0 -> HTTP10 + | `HTTP_1_1 -> HTTP11 + | _ -> raise Ocsigen_lib.Ocsigen_Bad_Request + +let of_meth meth = + let open Ocsigen_http_frame.Http_header in + match meth with + | `GET -> GET + | `POST -> POST + | `HEAD -> HEAD + | `PUT -> PUT + | `DELETE -> DELETE + | `OPTIONS -> OPTIONS + | `PATCH -> PATCH + | `TRACE -> TRACE + | `CONNECT -> CONNECT + | `Other "LINK" -> LINK + | `Other "UNLINK" -> UNLINK + | `Other _ -> raise Ocsigen_lib.Ocsigen_Bad_Request + +let of_request req = + let open Ocsigen_http_frame.Http_header in + { + mode = Query + (of_meth @@ Cohttp.Request.meth req, + Uri.to_string @@ Cohttp.Request.uri req); + proto = of_version @@ Cohttp.Request.version req; + headers = Cohttp.Request.headers req; + } + +let of_response resp = + let open Ocsigen_http_frame.Http_header in + { + mode = Answer (Cohttp.Code.code_of_status @@ Cohttp.Response.status resp); + proto = of_version @@ Cohttp.Response.version resp; + headers = Cohttp.Response.headers resp; + } + +let of_request_and_body (req, body) = + let open Ocsigen_http_frame in + { + frame_header = of_request req; + frame_content = Some + (Ocsigen_stream.of_lwt_stream + (Cohttp_lwt_body.to_stream body)); + frame_abort = (fun () -> Lwt.return ()); + (* XXX: It's obsolete ! *) + } + +let of_date str = + (* XXX: handle of GMT ? (see. To_cohttp.to_date) *) + Netdate.parse_epoch ~localzone:true ~zone:0 str + +let of_charset = + let re = Re_emacs.re ~case:true ".*charset=\\(.*\\)" in + let ca = Re.(compile (seq ([start; re]))) in + fun str -> + try + let subs = Re.exec ~pos:0 ca str in + let (start, stop) = Re.get_ofs subs 1 in + Some (String.sub str start (stop - start)) + with Not_found -> None + +let of_response_and_body (resp, body) = + let cookies = Ocsigen_cookies.Cookies.empty in + (* VVV: this function is only used by Ocsigen_local_files and this module + * create an empty Cookie table as response, it's useless to cast header *) + (* VVV: We could do a conversion function but will do nothing in the end. + * The conversion function is difficult! *) + let lastmodified = + match Cohttp.Header.get (Cohttp.Response.headers resp) "Last-Modified" with + | None -> None + | Some date -> Some (of_date date) in + let etag = + match Cohttp.Header.get (Cohttp.Response.headers resp) "ETag" with + | None -> None + | Some tag -> Scanf.sscanf tag "\"%s\"" (fun x -> Some x) in + let code = Cohttp.Code.code_of_status @@ Cohttp.Response.status resp in + let stream = + (Ocsigen_stream.of_lwt_stream + (Cohttp_lwt_body.to_stream body), None) in + (* XXX: I don't want to know what the second value! None! *) + let content_length = + let open Cohttp.Transfer in + match Cohttp.Response.encoding resp with + | Fixed i -> Some i + | _ -> None in + let content_type = Cohttp.Header.get_media_type + @@ Cohttp.Response.headers resp in + let headers = Cohttp.Response.headers resp in + let charset = + match Cohttp.Header.get (Cohttp.Response.headers resp) "Content-Type" with + | None -> None + | Some ct -> of_charset ct in + let location = + Cohttp.Header.get (Cohttp.Response.headers resp) "Location" in + Ocsigen_http_frame.Result.update (Ocsigen_http_frame.Result.empty ()) + ~cookies + ~lastmodified + ~etag + ~code + ~stream + ~content_length + ~content_type + ~headers + ~charset + ~location () + +(* VVV: Specific casting for revproxy extension *) + +let of_response_and_body' (resp, body) = + let open Ocsigen_http_frame in + { + frame_header = of_response resp; + frame_content = Some + (Ocsigen_stream.of_lwt_stream + (Cohttp_lwt_body.to_stream body)); + frame_abort = (fun () -> Lwt.return ()); + } diff --git a/src/migrate/of_cohttp.mli b/src/migrate/of_cohttp.mli new file mode 100644 index 000000000..ccf98ea88 --- /dev/null +++ b/src/migrate/of_cohttp.mli @@ -0,0 +1,33 @@ +(** Module to cast Cohttp value to OcsigenServer value *) + +(** [of_version] cast version of protocol *) +val of_version : Cohttp.Code.version -> Ocsigen_http_frame.Http_header.proto + +(** [of_meth] cast method of request *) +val of_meth : Cohttp.Code.meth -> Ocsigen_http_frame.Http_header.http_method + +(** [of_request] extracts only header of Cohttp request *) +val of_request : + Cohttp.Request.t -> Ocsigen_http_frame.Http_header.http_header + +(** [of_response] extracts only header of Cohttp response *) +val of_response : + Cohttp.Response.t -> Ocsigen_http_frame.Http_header.http_header + +(** [of_request_and_body] cast Cohttp request to OcsigenServer request *) +val of_request_and_body : + Cohttp.Request.t * Cohttp_lwt_body.t -> Ocsigen_http_frame.t + +(** [of_date] cast a date (as [string]) to timestamp *) +val of_date : string -> float + +val of_charset : string -> string option + +(** [of_response_and_body] cast Cohttp response to OcsigenServer response *) +val of_response_and_body : + Cohttp.Response.t * Cohttp_lwt_body.t -> Ocsigen_http_frame.result + +(** [of_response_and_body'] cast Cohttp response to OcsigenServer frame (like a + request). It's specially used by [revproxy] extension *) +val of_response_and_body' : + Cohttp.Response.t * Cohttp_lwt_body.t -> Ocsigen_http_frame.t diff --git a/src/migrate/to_cohttp.ml b/src/migrate/to_cohttp.ml new file mode 100644 index 000000000..994320169 --- /dev/null +++ b/src/migrate/to_cohttp.ml @@ -0,0 +1,167 @@ +module Cookie = struct + + open Ocsigen_cookies + open Ocsigen_lib + + let serialize_cookie_raw path exp name c secure = + Format.sprintf "%s=%s; path=/%s%s%s" + name c (Url.string_of_url_path ~encode:true path) + (if secure then "; secure" else "") + (match exp with + | Some s -> "; expires=" ^ + Netdate.format + "%a, %d-%b-%Y %H:%M:%S GMT" + (Netdate.create s) + | None -> "") + + let serialize_cookies path table headers = + CookiesTable.fold + (fun name c h -> + let exp, v, secure = match c with + | Ocsigen_cookies.OUnset -> (Some 0., "", false) + | Ocsigen_cookies.OSet (t, v, secure) -> (t, v, secure) + in + Http_headers.add + Http_headers.set_cookie (serialize_cookie_raw path exp name v secure) + h) + table + headers + + let serialize cookies headers = + Cookies.fold serialize_cookies cookies headers +end + +let to_version vrs = + let open Ocsigen_http_frame.Http_header in + match vrs with + | HTTP10 -> `HTTP_1_0 + | HTTP11 -> `HTTP_1_1 + +let to_meth meth = + let open Ocsigen_http_frame.Http_header in + match meth with + | GET -> `GET + | POST -> `POST + | HEAD -> `HEAD + | PUT -> `PUT + | DELETE -> `DELETE + | OPTIONS -> `OPTIONS + | PATCH -> `PATCH + | UNLINK -> `Other "UNLINK" + | LINK -> `Other "LINK" + | TRACE -> `Other "TRACE" + | CONNECT -> `Other "CONNECT" + +let to_headers : Http_headers.t -> Cohttp.Header.t = + fun x -> x + +let to_response ?encoding ?flush + { + Ocsigen_http_frame.Http_header.mode; + Ocsigen_http_frame.Http_header.proto; + Ocsigen_http_frame.Http_header.headers; + } = + let open Ocsigen_http_frame.Http_header in + match mode with + | Answer code -> + let version = to_version proto in + let status = Cohttp.Code.status_of_code code in + let headers = to_headers headers in + Cohttp.Response.make ~version ~status ?flush ?encoding ~headers () + | _ -> raise + (Invalid_argument "Ocsigen_http_frame.Http_header.to_cohttp_response") + +let to_request ?encoding + { + Ocsigen_http_frame.Http_header.mode; + Ocsigen_http_frame.Http_header.proto; + Ocsigen_http_frame.Http_header.headers; + } uri = + let open Ocsigen_http_frame.Http_header in + match mode with + | Query (meth, _) -> + let meth = to_meth meth in + let version = to_version proto in + let headers = to_headers headers in + Cohttp.Request.make ~meth ~version ?encoding ~headers uri + | _ -> raise + (Invalid_argument "Ocsigen_http_frame.Http_header.to_cohttp_request") + +let to_request_and_body ?encoding + { + Ocsigen_http_frame.frame_header; + Ocsigen_http_frame.frame_content; + } uri = + let stream = match frame_content with + | Some s -> Ocsigen_stream.to_lwt_stream + ~is_empty:(fun x -> String.length x = 0) + s + | None -> (Lwt_stream.from (fun () -> Lwt.return None) : string Lwt_stream.t) + in + (to_request ?encoding frame_header uri, Cohttp_lwt_body.of_stream stream) + +let to_date date = + let x = Netdate.mk_mail_date ~zone:0 date |> Bytes.unsafe_of_string in + try + let ind_plus = Bytes.index x '+' in + Bytes.set x ind_plus 'G'; + Bytes.set x (ind_plus + 1) 'M'; + Bytes.set x (ind_plus + 2) 'T'; + Bytes.sub x 0 (ind_plus + 3) + with Invalid_argument _ | Not_found -> (); x + +let to_type ty charset = + if String.length ty >= 4 then + match String.sub ty 0 4, charset with + | "text", Some "" -> ty + | "text", Some ch -> Format.sprintf "%s; charset=%s" ty ch + | _ -> + begin match String.sub ty (String.length ty - 4) 4, charset with + | ("+xml"|"/xml"), Some "" -> ty + | ("+xml"|"/xml"), Some ch -> Format.sprintf "%s; charset=%s" ty ch + | _ -> ty + end + else ty + +let to_response_and_body res = + let res_code = Ocsigen_http_frame.Result.code res in + let res_etag = Ocsigen_http_frame.Result.etag res in + let res_cookies = Ocsigen_http_frame.Result.cookies res in + let res_stream = Ocsigen_http_frame.Result.stream res in + let res_lastmodified = Ocsigen_http_frame.Result.lastmodified res in + let res_content_length = Ocsigen_http_frame.Result.content_length res in + let res_content_type = Ocsigen_http_frame.Result.content_type res in + let res_headers = Ocsigen_http_frame.Result.headers res in + let res_charset = Ocsigen_http_frame.Result.charset res in + let res_location = Ocsigen_http_frame.Result.location res in + let headers = + to_headers (Cookie.serialize res_cookies res_headers) in + let headers = match res_lastmodified with + | Some date -> Cohttp.Header.add headers "Last-Modified" (to_date date) + | None -> headers + in + let headers = match res_etag with + | Some etag -> Cohttp.Header.add headers "ETag" (Format.sprintf "\"%s\"" etag) + | None -> headers + in + let encoding = match res_content_length with + | Some length when length <= Int64.of_int max_int -> + Cohttp.Transfer.Fixed length + | _ -> Cohttp.Transfer.Chunked + in + let headers = match res_content_type with + | Some ty -> Cohttp.Header.add headers "Content-Type" (to_type ty res_charset) + | None -> headers + in + let headers = match res_location with + | Some location -> Cohttp.Header.add headers "Location" location + | None -> headers + in + (Cohttp.Response.make + ~status:(Cohttp.Code.status_of_code res_code) + ~encoding + ~headers + (), + Cohttp_lwt_body.of_stream (Ocsigen_stream.to_lwt_stream + ~is_empty:(fun x -> String.length x = 0) + (fst res_stream))) diff --git a/src/migrate/to_cohttp.mli b/src/migrate/to_cohttp.mli new file mode 100644 index 000000000..20a48f05a --- /dev/null +++ b/src/migrate/to_cohttp.mli @@ -0,0 +1,48 @@ +(** Module to cast OcsigenServer value to Cohttp value *) + +(** Module to serialize cookie to Cohttp headers *) +module Cookie : + sig + val serialize : + Ocsigen_cookies.cookie Ocsigen_cookies.CookiesTable.t + Ocsigen_cookies.Cookies.t -> Cohttp.Header.t -> Cohttp.Header.t + end + +(** [to_version] cast version of protocol *) +val to_version : + Ocsigen_http_frame.Http_header.proto -> [> `HTTP_1_0 | `HTTP_1_1 ] + +(** [to_meth] cast method of request *) +val to_meth : + Ocsigen_http_frame.Http_header.http_method -> Cohttp.Code.meth + +(** [to_headers] cast OcsigenServer headers to Cohttp headers (this function is + [fun x -> x] with simply annotation) *) +val to_headers : Http_headers.t -> Cohttp.Header.t + +(** [to_response] injects only header of new Cohttp response *) +val to_response : + ?encoding:Cohttp.Transfer.encoding -> + ?flush:bool -> + Ocsigen_http_frame.Http_header.http_header -> Cohttp.Response.t + +(** [to_request] injects only headers to new Cohttp request *) +val to_request : + ?encoding:Cohttp.Transfer.encoding -> + Ocsigen_http_frame.Http_header.http_header -> Uri.t -> Cohttp.Request.t + +(** [to_request_and_body] cast a OcsigenServer request to Cohttp request *) +val to_request_and_body : + ?encoding:Cohttp.Transfer.encoding -> + Ocsigen_http_frame.t -> + Uri.t -> Cohttp.Request.t * Cohttp_lwt_body.t + +(** [to_date] cast a date (as timestamp) to a string *) +val to_date : float -> string + +val to_type : string -> string option -> string + +(** [to_response_and_body] cast a OcsigenServer response to Cohttp response *) +val to_response_and_body : + Ocsigen_http_frame.result -> + Cohttp.Response.t * Cohttp_lwt_body.t diff --git a/src/server/.depend b/src/server/.depend index 1f122272a..b9c15669c 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -1,54 +1,53 @@ -ocsigen_command.cmi : -ocsigen_common_server.cmi : ocsigen_request_info.cmi \ +ocsigen_cohttp_server.cmi : \ ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi -ocsigen_extensions.cmi : ocsigen_request_info.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_http_com.cmi \ - ../http/ocsigen_cookies.cmi ocsigen_command.cmi \ - ../http/ocsigen_charset_mime.cmi -ocsigen_http_client.cmi : ../baselib/ocsigen_stream.cmi \ - ../http/ocsigen_http_frame.cmi ocsigen_extensions.cmi \ +ocsigen_command.cmi : +ocsigen_extensions.cmi : ../baselib/ocsigen_lib.cmi \ + ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi \ + ocsigen_command.cmi ../http/ocsigen_charset_mime.cmi +ocsigen_http_client.cmi : ../http/ocsigen_http_frame.cmi \ ../http/http_headers.cmi ocsigen_local_files.cmi : ../http/ocsigen_http_frame.cmi \ ocsigen_extensions.cmi ocsigen_parseconfig.cmi : ocsigen_socket.cmi ocsigen_extensions.cmi -ocsigen_range.cmi : ocsigen_request_info.cmi ../http/ocsigen_http_frame.cmi -ocsigen_request_info.cmi : ../baselib/polytables.cmi \ - ../baselib/ocsigen_lib.cmi ../http/ocsigen_http_frame.cmi \ - ../http/ocsigen_http_com.cmi ../http/ocsigen_cookies.cmi \ - ../http/http_headers.cmi ocsigen_server.cmi : ocsigen_socket.cmi : +ocsigen_cohttp_server.cmo : ../migrate/to_cohttp.cmi \ + ../baselib/ocsigen_stream.cmi ocsigen_socket.cmi \ + ../baselib/ocsigen_lib.cmi \ + ../http/ocsigen_http_frame.cmi ../http/ocsigen_headers.cmi \ + ../http/ocsigen_cookies.cmi \ + ../baselib/ocsigen_config.cmi ocsigen_cohttp_server.cmi +ocsigen_cohttp_server.cmx : ../migrate/to_cohttp.cmx \ + ../baselib/ocsigen_stream.cmx ocsigen_socket.cmx \ + ../baselib/ocsigen_lib.cmx \ + ../http/ocsigen_http_frame.cmx ../http/ocsigen_headers.cmx \ + ../http/ocsigen_cookies.cmx \ + ../baselib/ocsigen_config.cmx ocsigen_cohttp_server.cmi ocsigen_command.cmo : ../baselib/ocsigen_messages.cmi ocsigen_command.cmi ocsigen_command.cmx : ../baselib/ocsigen_messages.cmx ocsigen_command.cmi -ocsigen_extensions.cmo : ocsigen_request_info.cmi \ +ocsigen_extensions.cmo : \ ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_http_com.cmi \ - ../http/ocsigen_cookies.cmi ../baselib/ocsigen_config.cmi \ - ocsigen_command.cmi ../http/ocsigen_charset_mime.cmi \ + ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi \ + ../baselib/ocsigen_config.cmi ocsigen_command.cmi \ + ocsigen_cohttp_server.cmi ../http/ocsigen_charset_mime.cmi \ ocsigen_extensions.cmi -ocsigen_extensions.cmx : ocsigen_request_info.cmx \ +ocsigen_extensions.cmx : \ ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../http/ocsigen_http_com.cmx \ - ../http/ocsigen_cookies.cmx ../baselib/ocsigen_config.cmx \ - ocsigen_command.cmx ../http/ocsigen_charset_mime.cmx \ + ../http/ocsigen_http_frame.cmx ../http/ocsigen_cookies.cmx \ + ../baselib/ocsigen_config.cmx ocsigen_command.cmx \ + ocsigen_cohttp_server.cmx ../http/ocsigen_charset_mime.cmx \ ocsigen_extensions.cmi -ocsigen_http_client.cmo : ../baselib/ocsigen_stream.cmi \ - ../http/ocsigen_senders.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_http_com.cmi \ - ../http/ocsigen_headers.cmi ocsigen_extensions.cmi \ - ../baselib/ocsigen_config.cmi ../http/http_headers.cmi \ +ocsigen_http_client.cmo : ../migrate/to_cohttp.cmi ../migrate/of_cohttp.cmi \ + ../baselib/ocsigen_lib.cmi ../http/http_headers.cmi \ ocsigen_http_client.cmi -ocsigen_http_client.cmx : ../baselib/ocsigen_stream.cmx \ - ../http/ocsigen_senders.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../http/ocsigen_http_com.cmx \ - ../http/ocsigen_headers.cmx ocsigen_extensions.cmx \ - ../baselib/ocsigen_config.cmx ../http/http_headers.cmx \ +ocsigen_http_client.cmx : ../migrate/to_cohttp.cmx ../migrate/of_cohttp.cmx \ + ../baselib/ocsigen_lib.cmx ../http/http_headers.cmx \ ocsigen_http_client.cmi ocsigen_local_files.cmo : ../http/ocsigen_senders.cmi \ - ocsigen_request_info.cmi ocsigen_extensions.cmi \ + ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi ocsigen_local_files.cmi ocsigen_local_files.cmx : ../http/ocsigen_senders.cmx \ - ocsigen_request_info.cmx ocsigen_extensions.cmx \ + ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ocsigen_local_files.cmi ocsigen_parseconfig.cmo : ocsigen_socket.cmi ../baselib/ocsigen_loader.cmi \ ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ @@ -58,43 +57,23 @@ ocsigen_parseconfig.cmx : ocsigen_socket.cmx ../baselib/ocsigen_loader.cmx \ ../baselib/ocsigen_lib.cmx ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ../http/ocsigen_charset_mime.cmx \ ocsigen_parseconfig.cmi -ocsigen_range.cmo : ../baselib/ocsigen_stream.cmi ocsigen_request_info.cmi \ - ../baselib/ocsigen_lib.cmi ../http/ocsigen_http_frame.cmi \ - ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi \ - ../http/http_headers.cmi ocsigen_range.cmi -ocsigen_range.cmx : ../baselib/ocsigen_stream.cmx ocsigen_request_info.cmx \ - ../baselib/ocsigen_lib.cmx ../http/ocsigen_http_frame.cmx \ - ocsigen_extensions.cmx ../baselib/ocsigen_config.cmx \ - ../http/http_headers.cmx ocsigen_range.cmi -ocsigen_request_info.cmo : ../baselib/polytables.cmi \ - ../baselib/ocsigen_lib.cmi ../http/ocsigen_http_frame.cmi \ - ../http/ocsigen_http_com.cmi ../http/ocsigen_cookies.cmi \ - ocsigen_request_info.cmi -ocsigen_request_info.cmx : ../baselib/polytables.cmx \ - ../baselib/ocsigen_lib.cmx ../http/ocsigen_http_frame.cmx \ - ../http/ocsigen_http_com.cmx ../http/ocsigen_cookies.cmx \ - ocsigen_request_info.cmi -ocsigen_server.cmo : ../baselib/polytables.cmi ../baselib/ocsigen_stream.cmi \ - ocsigen_socket.cmi ../http/ocsigen_senders.cmi ocsigen_request_info.cmi \ - ocsigen_range.cmi ocsigen_parseconfig.cmi ../baselib/ocsigen_messages.cmi \ +ocsigen_server.cmo : ocsigen_socket.cmi \ + ocsigen_parseconfig.cmi ../baselib/ocsigen_messages.cmi \ ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_http_com.cmi \ - ocsigen_http_client.cmi ../http/ocsigen_headers.cmi \ + ../http/ocsigen_http_frame.cmi ../http/ocsigen_headers.cmi \ ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ ../baselib/ocsigen_config.cmi ../baselib/ocsigen_commandline.cmo \ - ocsigen_command.cmi ../baselib/ocsigen_cache.cmi ../http/multipart.cmi \ - ../http/http_headers.cmi ../baselib/dynlink_wrapper.cmo \ + ocsigen_command.cmi ocsigen_cohttp_server.cmi \ + ../baselib/ocsigen_cache.cmi ../baselib/dynlink_wrapper.cmo \ ocsigen_server.cmi -ocsigen_server.cmx : ../baselib/polytables.cmx ../baselib/ocsigen_stream.cmx \ - ocsigen_socket.cmx ../http/ocsigen_senders.cmx ocsigen_request_info.cmx \ - ocsigen_range.cmx ocsigen_parseconfig.cmx ../baselib/ocsigen_messages.cmx \ +ocsigen_server.cmx : ocsigen_socket.cmx \ + ocsigen_parseconfig.cmx ../baselib/ocsigen_messages.cmx \ ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../http/ocsigen_http_com.cmx \ - ocsigen_http_client.cmx ../http/ocsigen_headers.cmx \ + ../http/ocsigen_http_frame.cmx ../http/ocsigen_headers.cmx \ ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx ../baselib/ocsigen_commandline.cmx \ - ocsigen_command.cmx ../baselib/ocsigen_cache.cmx ../http/multipart.cmx \ - ../http/http_headers.cmx ../baselib/dynlink_wrapper.cmx \ + ocsigen_command.cmx ocsigen_cohttp_server.cmx \ + ../baselib/ocsigen_cache.cmx ../baselib/dynlink_wrapper.cmx \ ocsigen_server.cmi ocsigen_socket.cmo : ../baselib/ocsigen_lib_base.cmi \ ../baselib/ocsigen_lib.cmi ocsigen_socket.cmi diff --git a/src/server/Makefile b/src/server/Makefile index c1bd346ed..1e1c6694a 100644 --- a/src/server/Makefile +++ b/src/server/Makefile @@ -3,7 +3,8 @@ include ../../Makefile.config all: byte opt PACKAGE := ${SERVER_PACKAGE} ## See ../../Makefile.options -LIBS := -I ../baselib -I ../http ${addprefix -package ,${PACKAGE}} -I . +LIBS := -I ../baselib -I ../http -I ../migrate \ + ${addprefix -package ,${PACKAGE}} OCAMLC := $(OCAMLFIND) ocamlc ${BYTEDBG} ${THREAD} OCAMLOPT := $(OCAMLFIND) ocamlopt ${OPTDBG} ${THREAD} OCAMLDOC := $(OCAMLFIND) ocamldoc @@ -14,9 +15,8 @@ all: byte opt ### Common files ### FILES := ocsigen_socket.ml \ - ocsigen_request_info.ml \ ocsigen_command.ml \ - ocsigen_range.ml \ + ocsigen_cohttp_server.ml \ ocsigen_extensions.ml \ ocsigen_parseconfig.ml \ ocsigen_http_client.ml \ @@ -47,6 +47,7 @@ SERVERLIBS := ${PARSECOMMANDLINE} \ ../baselib/baselib.cma \ ../baselib/polytables.cma \ ../http/http.cma \ + ../migrate/migrate.cma \ ${PROJECTNAME}.cma \ SERVEROBJS := server_main.cmo diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml new file mode 100644 index 000000000..7156c747e --- /dev/null +++ b/src/server/ocsigen_cohttp_server.ml @@ -0,0 +1,217 @@ +open Lwt.Infix + +let section = Lwt_log.Section.make "ocsigen:cohttp" + +exception Ocsigen_unsupported_media +exception Ocsigen_http_error of (Ocsigen_cookies.cookieset * int) + +module Connection = struct + exception Lost_connection of exn + exception Aborted + exception Timeout + exception Keepalive_timeout + exception Connection_closed +end + +(** print_cohttp_request Print request for debug + * @param out_ch output for debug + * @param request Cohttp request *) + +let print_cohttp_request fmt request = + let print_list print_data out_ch lst = + let rec aux = function + | [] -> () + | [ x ] -> print_data out_ch x + | x :: r -> print_data out_ch x; aux r + in aux lst + in + + let open Cohttp.Request in + + Format.fprintf fmt "%s [%s/%s]:\n" + (Uri.to_string (Cohttp.Request.uri request)) + (Cohttp.Code.string_of_version request.version) + (Cohttp.Code.string_of_method request.meth) ; + + Cohttp.Header.iter + (fun key values -> + Format.fprintf fmt "\t%s = %a\n" key + (print_list Format.pp_print_string) values) + request.headers + +let waiters = Hashtbl.create 256 + +type request = { + r_address : Unix.inet_addr ; + r_port : int ; + r_filenames : string list ref; + r_sockaddr : Lwt_unix.sockaddr ; + r_request : Cohttp.Request.t ; + r_body : Cohttp_lwt_body.t ; + r_waiter : unit Lwt.t ; + mutable r_tries : int +} + +type result = { + r_response : Cohttp.Response.t ; + r_body : Cohttp_lwt_body.t ; + r_cookies : Ocsigen_cookies.cookieset +} + +let path_of_request {r_request} = + Cohttp.Request.uri r_request + |> Uri.path + |> Ocsigen_lib.Url.split_path + +let incr_tries r = r.r_tries <- r.r_tries + 1 + +let tries {r_tries} = r_tries + +exception Ocsigen_Is_a_directory of (request -> Neturl.url) + +let handler ~address ~port ~connector (flow, conn) request body = + + Lwt_log.ign_info_f ~section + "Receiving the request: %s" + (Format.asprintf "%a" print_cohttp_request request) + ; + + let filenames = ref [] in + let edn = Conduit_lwt_unix.endp_of_flow flow in + let rec getsockname = function + | `TCP (ip, port) -> + Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) + | `Unix_domain_socket path -> + Unix.ADDR_UNIX path + | `TLS (_, edn) -> getsockname edn + | `Unknown err -> raise (Failure ("resolution failed: " ^ err)) + | `Vchan_direct _ -> raise (Failure "VChan not supported") + | `Vchan_domain_socket _ -> raise (Failure "VChan not supported") + in + + let sockaddr = getsockname edn in + let (waiter, wakener) = Lwt.wait () in + Hashtbl.add waiters conn wakener; + + let handle_error exn = + + Lwt_log.ign_debug ~section ~exn "Got exception while handling request." ; + + let headers, ret_code = match exn with + | Ocsigen_http_error (cookies_to_set, code) -> + let headers = + To_cohttp.Cookie.serialize cookies_to_set (Cohttp.Header.init ()) + in + Some headers, code + | Ocsigen_stream.Interrupted Ocsigen_stream.Already_read -> + None, 500 + | Unix.Unix_error (Unix.EACCES, _, _) -> + None, 403 + | Ocsigen_http_frame.Http_error.Http_exception (code, _, headers) -> + headers, code + | Ocsigen_lib.Ocsigen_Bad_Request -> + None, 400 + | Ocsigen_unsupported_media -> + None, 415 + | Neturl.Malformed_URL -> + None, 400 + | Ocsigen_lib.Ocsigen_Request_too_long -> + None, 413 + | exn -> + Lwt_log.ign_error ~section ~exn "Error while handling request." ; + None, 500 + in + + Lwt_log.ign_warning_f ~section "Returning error code %i." ret_code ; + + let body = + match ret_code with + | 404 -> "Not Found" + | _ -> Printexc.to_string exn in + + Cohttp_lwt_unix.Server.respond_error + ?headers + ~status:(Cohttp.Code.status_of_code ret_code) + ~body () + in + + if !filenames <> [] then + List.iter + (fun a -> + try + Unix.unlink a + with Unix.Unix_error _ as exn -> + Lwt_log.ign_warning_f ~section ~exn + "Error while removing file %s" a) + !filenames; + + (* TODO: equivalent of Ocsigen_range *) + + connector { + r_address = address ; + r_port = port ; + r_filenames = filenames ; + r_sockaddr = sockaddr; + r_request = request; + r_body = body; + r_waiter = waiter; + r_tries = 0 + } >>= fun { r_response ; r_body } -> + + (* TODO: handle cookies *) + + Lwt.return (r_response, r_body) + +let conn_closed (flow, conn) = + try let wakener = Hashtbl.find waiters conn in + Lwt.wakeup wakener (); Hashtbl.remove waiters conn + with Not_found -> () + +let stop, stop_wakener = Lwt.wait () + +let shutdown_server timeout = + let process = match timeout with + | Some f -> (fun () -> Lwt_unix.sleep f) + | None -> (fun () -> Lwt.return ()) + in ignore + begin + (Lwt.pick [process (); stop]) + >>= fun () -> exit 0 + (* XXX: actually, deadlock with Lwt, cf. Lwt#48 *) + end + +let number_of_client () = 0 +let get_number_of_connected = number_of_client + +let service ?ssl ~address ~port ~connector () = + let tls_server_key = match ssl with + | Some (crt, key, Some password) -> + `TLS (`Crt_file_path crt, + `Key_file_path key, + `Password password) + | Some (crt, key, None) -> + `TLS (`Crt_file_path crt, + `Key_file_path key, + `No_password) + | None -> `None + in + (* We create a specific context for Conduit and Cohttp. *) + Conduit_lwt_unix.init + ~src:(Ocsigen_socket.string_of_socket_type address) + ~tls_server_key () >>= fun conduit_ctx -> + Lwt.return (Cohttp_lwt_unix_net.init ~ctx:conduit_ctx ()) >>= fun ctx -> + (* We catch the INET_ADDR of the server *) + let callback = + let address = Ocsigen_socket.to_inet_addr address in + handler ~address ~port ~connector + in + let config = Cohttp_lwt_unix.Server.make ~conn_closed ~callback () in + let mode = + match tls_server_key with + | `None -> `TCP (`Port port) + | `TLS (crt, key, pass) -> + `OpenSSL (crt, key, pass, `Port port) + in + Cohttp_lwt_unix.Server.create ~stop ~ctx ~mode config + >>= fun () -> + Lwt.return (Lwt.wakeup stop_wakener ()) diff --git a/src/server/ocsigen_cohttp_server.mli b/src/server/ocsigen_cohttp_server.mli new file mode 100644 index 000000000..25048984f --- /dev/null +++ b/src/server/ocsigen_cohttp_server.mli @@ -0,0 +1,51 @@ +exception Ocsigen_unsupported_media +exception Ocsigen_http_error of (Ocsigen_cookies.cookieset * int) + +module Connection : sig + exception Lost_connection of exn + exception Aborted + exception Timeout + exception Keepalive_timeout + exception Connection_closed +end + +type request = { + r_address : Unix.inet_addr ; + r_port : int ; + r_filenames : string list ref; + r_sockaddr : Lwt_unix.sockaddr ; + r_request : Cohttp.Request.t ; + r_body : Cohttp_lwt_body.t ; + r_waiter : unit Lwt.t ; + mutable r_tries : int +} + +type result = { + r_response : Cohttp.Response.t ; + r_body : Cohttp_lwt_body.t ; + r_cookies : Ocsigen_cookies.cookieset +} + +val incr_tries : request -> unit + +val tries : request -> int + +val path_of_request : request -> string list + +(** compute a redirection if path links to a directory *) +exception Ocsigen_Is_a_directory of (request -> Neturl.url) + +(** accessor to get number of client (used by eliom monitoring) *) +val number_of_client : unit -> int +(** alias of [number_of_client] *) +val get_number_of_connected : unit -> int +(** shutdown main loop of server *) +val shutdown_server : float option -> unit + +(** initialize a main loop of http server *) +val service : + ?ssl:string * string * (bool -> string) option -> + address:Ocsigen_socket.socket_type -> + port:int -> + connector:(request -> result Lwt.t) -> + unit -> unit Lwt.t diff --git a/src/server/ocsigen_common_server.mli b/src/server/ocsigen_common_server.mli deleted file mode 100644 index 519e1ce6c..000000000 --- a/src/server/ocsigen_common_server.mli +++ /dev/null @@ -1,33 +0,0 @@ -module type S = sig - - (** compute a redirection if path links to a directory *) - exception Ocsigen_Is_a_directory of (Ocsigen_request_info.request_info -> Neturl.url) - - exception Ocsigen_unsupported_media - exception Ocsigen_http_error of (Ocsigen_cookies.cookieset * int) - - module Connection : sig - exception Lost_connection of exn - exception Aborted - exception Timeout - exception Keepalive_timeout - exception Connection_closed - end - - (** accessor to get number of client (used by eliom monitoring) *) - val number_of_client : unit -> int - - (** alias of [number_of_client] *) - val get_number_of_connected : unit -> int - - (** shutdown main loop of server *) - val shutdown_server : float option -> unit - - (** initialize a main loop of http server *) - val service : - ?ssl:string * string * (bool -> string) option -> - address:string -> - port:int -> - connector:(Ocsigen_request_info.request_info -> unit -> Ocsigen_http_frame.result Lwt.t) -> - unit -> unit Lwt.t -end diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 6ecc9d61d..68da0e5a7 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -16,33 +16,19 @@ * You should have received a copy of the GNU Lesser 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. -*) -(*****************************************************************************) -(*****************************************************************************) -(*****************************************************************************) -(*****************************************************************************) - -(** Writing extensions for Ocsigen *) + *) -(* TODO - - - awake must be called after each Ext_found or Ext_found_continue_with - or Ext_found_stop sent by an extension. It is perhaps called too often. - -*) +(** Writing extensions for Ocsigen *) let section = Lwt_log.Section.make "ocsigen:ext" -open Lwt -open Ocsigen_lib -open Ocsigen_cookies +open Lwt.Infix -include Ocsigen_request_info -include Ocsigen_command +module Url = Ocsigen_lib.Url -module Ocsigen_request_info = Ocsigen_request_info +include Ocsigen_command -exception Ocsigen_http_error of (Ocsigen_cookies.cookieset * int) +exception Ocsigen_http_error = Ocsigen_cohttp_server.Ocsigen_http_error exception Ocsigen_Looping_request @@ -76,15 +62,6 @@ let rec equal_virtual_hosts (l1 : virtual_hosts) (l2 : virtual_hosts) = | (s1, _, p1) :: q1, (s2, _, p2) :: q2 -> s1 = s2 && p1 = p2 && equal_virtual_hosts q1 q2 -(*****************************************************************************) - -type client = Ocsigen_http_com.connection - -let client_id = Ocsigen_http_com.connection_id -let client_connection x = x -let client_of_connection x = x - - (*****************************************************************************) (* Server configuration, for local files that must not be sent *) @@ -193,17 +170,22 @@ and follow_symlink = (* Requests *) type request = { - request_info: request_info; + request_info: Ocsigen_cohttp_server.request; request_config: config_info; } -exception Ocsigen_Is_a_directory - of (Ocsigen_request_info.request_info -> Neturl.url) +type result = Ocsigen_cohttp_server.result = { + r_response : Cohttp.Response.t ; + r_body : Cohttp_lwt_body.t ; + r_cookies : Ocsigen_cookies.cookieset +} + +exception Ocsigen_Is_a_directory = Ocsigen_cohttp_server.Ocsigen_Is_a_directory type answer = | Ext_do_nothing (** I don't want to do anything *) - | Ext_found of (unit -> Ocsigen_http_frame.result Lwt.t) + | Ext_found of (unit -> result Lwt.t) (** "OK stop! I will take the page. You can start the following request of the same pipelined connection. Here is the function to generate the page". @@ -215,7 +197,7 @@ type answer = to another server before returning Ext_found, to ensure that all requests are done in same order). *) - | Ext_found_stop of (unit -> Ocsigen_http_frame.result Lwt.t) + | Ext_found_stop of (unit -> result Lwt.t) (** Found but do not try next extensions *) | Ext_next of int (** Page not found. Try next extension. The integer is the HTTP error code. @@ -268,10 +250,9 @@ type answer = the parsing function (of type [parse_fun]), that will return something of type [extension2]. *) - | Ext_found_continue_with of - (unit -> (Ocsigen_http_frame.result * request) Lwt.t) + | Ext_found_continue_with of (unit -> (result * request) Lwt.t) (** Same as [Ext_found] but may modify the request. *) - | Ext_found_continue_with' of (Ocsigen_http_frame.result * request) + | Ext_found_continue_with' of (result * request) (** Same as [Ext_found_continue_with] but does not allow to delay the computation of the page. You should probably not use it, but for output filters. @@ -279,10 +260,9 @@ type answer = and request_state = | Req_not_found of (int * request) - | Req_found of (request * Ocsigen_http_frame.result) + | Req_found of (request * result) and extension2 = - (unit -> unit) -> Ocsigen_cookies.cookieset -> request_state -> (answer * Ocsigen_cookies.cookieset) Lwt.t @@ -307,53 +287,82 @@ let (hosts : (virtual_hosts * config_info * extension2) list ref) = let set_hosts v = hosts := v let get_hosts () = !hosts +let host_of_request {Ocsigen_cohttp_server.r_request} = + Uri.host (Cohttp.Request.uri r_request) + +let port_of_request {Ocsigen_cohttp_server.r_port} = r_port + +let ssl_of_request _ = + (* FIXME *) + false + +let query_of_request {Ocsigen_cohttp_server.r_request} = + Uri.verbatim_query (Cohttp.Request.uri r_request) + +let update_path + { + request_info = ({Ocsigen_cohttp_server.r_request} as request_info); + request_config + } + path = + let request_info = + let r_request = + let meth = Cohttp.Request.meth r_request + and version = Cohttp.Request.version r_request + and encoding = Cohttp.Request.encoding r_request + and headers = Cohttp.Request.headers r_request + and uri = Uri.with_path (Cohttp.Request.uri r_request) path in + Cohttp.Request.make ~meth ~version ~encoding ~headers uri + in + { request_info with Ocsigen_cohttp_server.r_request } + in + {request_info ; request_config} (* Default hostname is either the Host header or the hostname set in the configuration file. *) -let get_hostname req = - if Ocsigen_config.get_usedefaulthostname () - then req.request_config.default_hostname - else match Ocsigen_request_info.host req.request_info with - | None -> req.request_config.default_hostname +let get_hostname {request_info ; request_config = {default_hostname}} = + if Ocsigen_config.get_usedefaulthostname () then + default_hostname + else + match host_of_request request_info with + | None -> default_hostname | Some host -> host (* Default port is either - the port the server is listening at - or the port in the Host header - or the default port set in the configuration file. *) -let get_port req = - if Ocsigen_config.get_usedefaulthostname () - then (if Ocsigen_request_info.ssl req.request_info - then req.request_config.default_httpsport - else req.request_config.default_httpport) - else match Ocsigen_request_info.port_from_host_field req.request_info with - | Some p -> p - | None -> - match Ocsigen_request_info.host req.request_info with - | Some _ -> if Ocsigen_request_info.ssl req.request_info then 443 else 80 - | None -> Ocsigen_request_info.server_port req.request_info - +let get_port + { + request_info = ({Ocsigen_cohttp_server.r_port} as request_info); + request_config = {default_httpport ; default_httpsport} + } = + if Ocsigen_config.get_usedefaulthostname () then + if ssl_of_request request_info then + default_httpsport + else + default_httpport + else + r_port let http_url_syntax = Hashtbl.find Neturl.common_url_syntax "http" let new_url_of_directory_request request ri = Lwt_log.ign_info ~section "Sending 301 Moved permanently"; let port = get_port request in - let ssl = Ocsigen_request_info.ssl ri in - let new_url = Neturl.make_url - ~scheme:(if ssl then "https" else "http") - ~host:(get_hostname request) - ?port:(if (port = 80 && not ssl) - || (ssl && port = 443) - then None - else Some port) - ~path:(""::(Url.add_end_slash_if_missing - (Ocsigen_request_info.full_path ri))) - ?query:(Ocsigen_request_info.get_params_string ri) - http_url_syntax - in new_url - - + let ssl = ssl_of_request ri in + Neturl.make_url + ~scheme:(if ssl then "https" else "http") + ~host:(get_hostname request) + ?port:(if (port = 80 && not ssl) + || (ssl && port = 443) + then None + else Some port) + ~path:("" :: + (Url.add_end_slash_if_missing + (Ocsigen_cohttp_server.path_of_request ri))) + ?query:(query_of_request ri) + http_url_syntax (*****************************************************************************) (* To give parameters to extensions: *) @@ -384,42 +393,35 @@ let site_match request (site_path : string list) url = -let add_to_res_cookies res cookies_to_set = +let add_to_res_cookies ({r_cookies} as r) cookies_to_set = if cookies_to_set = Ocsigen_cookies.Cookies.empty then - res - else - (Ocsigen_http_frame.Result.update res - ~cookies: - (Ocsigen_cookies.add_cookies - (Ocsigen_http_frame.Result.cookies res) cookies_to_set) ()) + r + else { + r with + r_cookies = Ocsigen_cookies.add_cookies r_cookies cookies_to_set + } -let make_ext awake cookies_to_set req_state (genfun : extension) (genfun2 : extension2) = +let make_ext cookies_to_set req_state (genfun : extension) (genfun2 : extension2) = genfun req_state >>= fun res -> let rec aux cookies_to_set = function - | Ext_do_nothing -> genfun2 awake cookies_to_set req_state + | Ext_do_nothing -> genfun2 cookies_to_set req_state | Ext_found r -> - awake (); r () >>= fun r' -> let ri = match req_state with | Req_found (ri, _) -> ri | Req_not_found (_, ri) -> ri in genfun2 - id (* already awoken *) Ocsigen_cookies.Cookies.empty (Req_found (ri, add_to_res_cookies r' cookies_to_set)) | Ext_found_continue_with r -> - awake (); r () >>= fun (r', req) -> genfun2 - id (* already awoken *) Ocsigen_cookies.Cookies.empty (Req_found (req, add_to_res_cookies r' cookies_to_set)) | Ext_found_continue_with' (r', req) -> - awake (); genfun2 - id (* already awoken *) Ocsigen_cookies.Cookies.empty (Req_found (req, add_to_res_cookies r' cookies_to_set)) | Ext_next e -> @@ -427,10 +429,9 @@ let make_ext awake cookies_to_set req_state (genfun : extension) (genfun2 : exte | Req_found (ri, _) -> ri | Req_not_found (_, ri) -> ri in - genfun2 awake cookies_to_set (Req_not_found (e, ri)) + genfun2 cookies_to_set (Req_not_found (e, ri)) | Ext_continue_with (ri, cook, e) -> genfun2 - awake (Ocsigen_cookies.add_cookies cook cookies_to_set) (Req_not_found (e, ri)) | Ext_found_stop _ @@ -440,7 +441,7 @@ let make_ext awake cookies_to_set req_state (genfun : extension) (genfun2 : exte | Ext_retry_with _ as res -> Lwt.return (res, cookies_to_set) | Ext_sub_result sr -> - sr awake cookies_to_set req_state + sr cookies_to_set req_state >>= fun (res, cookies_to_set) -> aux cookies_to_set res in @@ -488,7 +489,7 @@ let rec default_parse_config (Url.remove_dotdot (Neturl.split_path dir))) in let parse_config = make_parse_config path parse_host l in - let ext awake cookies_to_set = + let ext cookies_to_set = function | Req_found (ri, res) -> Lwt.return (Ext_found_continue_with' (res, ri), cookies_to_set) @@ -501,29 +502,32 @@ let rec default_parse_config Ocsigen_charset_mime.set_default_charset oldri.request_config.charset_assoc charset } } in - match site_match oldri path (Ocsigen_request_info.full_path oldri.request_info) with + match + site_match oldri path + (Ocsigen_cohttp_server.path_of_request oldri.request_info) + with | None -> Lwt_log.ign_info_f ~section "site \"%a\" does not match url \"%a\"." (fun () path -> Url.string_of_url_path ~encode:true path) path - (fun () oldri -> Url.string_of_url_path ~encode:true - (Ocsigen_request_info.full_path oldri.request_info)) oldri; + (fun () oldri -> + Url.string_of_url_path ~encode:true + (Ocsigen_cohttp_server.path_of_request + oldri.request_info)) oldri; Lwt.return (Ext_next e, cookies_to_set) | Some sub_path -> Lwt_log.ign_info_f ~section "site found: url \"%a\" matches \"%a\"." (fun () oldri -> Url.string_of_url_path ~encode:true - (Ocsigen_request_info.full_path oldri.request_info)) oldri + (Ocsigen_cohttp_server.path_of_request + oldri.request_info)) + oldri (fun () path -> Url.string_of_url_path ~encode:true path) path; - let ri = {oldri with - request_info = - (Ocsigen_request_info.update oldri.request_info - ~sub_path:sub_path - ~sub_path_string: - (Url.string_of_url_path - ~encode:true sub_path) ()) } + let ri = + update_path oldri + (Url.string_of_url_path ~encode:true sub_path) in - parse_config awake cookies_to_set (Req_not_found (e, ri)) + parse_config cookies_to_set (Req_not_found (e, ri)) >>= function (* After a site, we turn back to old ri *) | (Ext_stop_site (cs, err), cookies_to_set) @@ -531,7 +535,6 @@ let rec default_parse_config Lwt.return (Ext_continue_with (oldri, cs, err), cookies_to_set) | (Ext_found_continue_with r, cookies_to_set) -> - awake (); r () >>= fun (r', req) -> Lwt.return (Ext_found_continue_with' (r', oldri), cookies_to_set) @@ -560,7 +563,7 @@ and make_parse_config path parse_host l : extension2 = (* creates all site data, if any *) let rec parse_config : _ -> extension2 = function | [] -> - (fun (awake : unit -> unit) cookies_to_set -> function + (fun cookies_to_set -> function | Req_found (ri, res) -> Lwt.return (Ext_found_continue_with' (res, ri), cookies_to_set) | Req_not_found (e, ri) -> @@ -575,8 +578,8 @@ and make_parse_config path parse_host l : extension2 = try let genfun = f parse_config xmltag in let genfun2 = parse_config ll in - fun awake cookies_to_set req_state -> - make_ext awake cookies_to_set req_state genfun genfun2 + fun cookies_to_set req_state -> + make_ext cookies_to_set req_state genfun genfun2 with | Bad_config_tag_for_extension t -> (* This case happens only if no extension has recognized the @@ -686,10 +689,10 @@ let register_extension, parse_config_item, parse_user_site_item, get_beg_init, g (match begin_init with - | Some begin_init -> fun_beg := comp begin_init !fun_beg + | Some begin_init -> fun_beg := Ocsigen_lib.comp begin_init !fun_beg | None -> ()); (match end_init with - | Some end_init -> fun_end := comp end_init !fun_end; + | Some end_init -> fun_end := Ocsigen_lib.comp end_init !fun_end; | None -> ()); let curexnfun = !fun_exn in fun_exn := fun e -> try curexnfun e with e -> exn_handler e), @@ -817,7 +820,9 @@ module Configuration = struct function | Simplexmlparser.PCData str -> let spec_pcdata = - Option.get (fun () -> ignore_blank_pcdata ~in_tag) spec_pcdata + Ocsigen_lib.Option.get + (fun () -> ignore_blank_pcdata ~in_tag) + spec_pcdata in spec_pcdata str | Simplexmlparser.Element (name, attributes, elements) -> @@ -908,40 +913,23 @@ let string_of_host (h : virtual_hosts) = | Some p -> host ^ ":" ^ string_of_int p in List.fold_left (fun d arg -> d ^ aux1 arg ^" ") "" h +let compute_result ?(previous_cookies = Ocsigen_cookies.Cookies.empty) ri = + let host = host_of_request ri + and port = port_of_request ri in -let compute_result - ?(previous_cookies = Ocsigen_cookies.Cookies.empty) - ?(awake_next_request = false) ri = - - let host = Ocsigen_request_info.host ri in - let port = Ocsigen_request_info.server_port ri in - - let conn = client_connection (Ocsigen_request_info.client ri) in - let awake = - if awake_next_request - then - (let tobeawoken = ref true in - (* must be awoken once and only once *) - fun () -> - if !tobeawoken then begin - tobeawoken := false; - Ocsigen_http_com.wakeup_next_request conn - end) - else id + let string_of_host_option = function + | None -> ":"^(string_of_int port) + | Some h -> h^":"^(string_of_int port) in let rec do2 sites cookies_to_set ri = - Ocsigen_request_info.update_nb_tries ri (Ocsigen_request_info.nb_tries ri + 1); - if (Ocsigen_request_info.nb_tries ri) > Ocsigen_config.get_maxretries () - then fail Ocsigen_Looping_request + Ocsigen_cohttp_server.incr_tries ri; + if Ocsigen_cohttp_server.tries ri > Ocsigen_config.get_maxretries () then + Lwt.fail Ocsigen_Looping_request else - let string_of_host_option = function - | None -> ":"^(string_of_int port) - | Some h -> h^":"^(string_of_int port) - in let rec aux_host ri prev_err cookies_to_set = function - | [] -> fail (Ocsigen_http_error (cookies_to_set, prev_err)) + | [] -> Lwt.fail (Ocsigen_http_error (cookies_to_set, prev_err)) | (h, conf_info, host_function)::l when host_match ~virtual_hosts:h ~host ~port -> Lwt_log.ign_info_f ~section @@ -949,7 +937,6 @@ let compute_result (fun () -> string_of_host_option) host (fun () -> string_of_host) h; host_function - awake cookies_to_set (Req_not_found (prev_err, { request_info = ri; request_config = conf_info })) @@ -957,18 +944,15 @@ let compute_result (match res_ext with | Ext_found r | Ext_found_stop r -> - awake (); r () >>= fun r' -> Lwt.return (add_to_res_cookies r' cookies_to_set) | Ext_do_nothing -> aux_host ri prev_err cookies_to_set l | Ext_found_continue_with r -> - awake (); r () >>= fun (r', _) -> - return (add_to_res_cookies r' cookies_to_set) + Lwt.return (add_to_res_cookies r' cookies_to_set) | Ext_found_continue_with' (r, _) -> - awake (); - return (add_to_res_cookies r cookies_to_set) + Lwt.return (add_to_res_cookies r cookies_to_set) | Ext_next e -> aux_host ri e cookies_to_set l (* try next site *) @@ -977,7 +961,7 @@ let compute_result aux_host ri e (Ocsigen_cookies.add_cookies cook cookies_to_set) l (* try next site *) | Ext_stop_all (cook, e) -> - fail (Ocsigen_http_error (cookies_to_set, e)) + Lwt.fail (Ocsigen_http_error (cookies_to_set, e)) | Ext_continue_with (_, cook, e) -> aux_host ri e (Ocsigen_cookies.add_cookies cook cookies_to_set) l @@ -998,15 +982,8 @@ let compute_result aux_host ri prev_err cookies_to_set l in aux_host ri 404 cookies_to_set sites in - Lwt.finalize - (fun () -> - do2 (get_hosts ()) previous_cookies ri - ) - (fun () -> - awake (); - Lwt.return () - ) + do2 (get_hosts ()) previous_cookies ri (*****************************************************************************) @@ -1043,14 +1020,6 @@ let get_number_of_connected, ) - -let get_server_address ri = - let socket = Ocsigen_http_com.connection_fd (client_connection (Ocsigen_request_info.client ri)) in - match Lwt_ssl.getsockname socket with - | Unix.ADDR_UNIX _ -> failwith "unix domain socket have no ip" - | Unix.ADDR_INET (addr,port) -> addr,port - - (* user directories *) exception NoSuchUser diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 05bf0eeb6..ada7df8ee 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -32,11 +32,6 @@ open Ocsigen_cookies include (module type of Ocsigen_command) -module Ocsigen_request_info : (module type of Ocsigen_request_info - with type request_info = Ocsigen_request_info.request_info - and type file_info = Ocsigen_request_info.file_info - and type ifrange = Ocsigen_request_info.ifrange) - exception Ocsigen_http_error of (Ocsigen_cookies.cookieset * int) (** Xml tag not recognized by an extension (usually not a real error) *) @@ -130,40 +125,24 @@ and follow_symlink = (*****************************************************) - -type client = Ocsigen_http_com.connection -(** A value of this type represents the client who did the request. *) - -val client_id : client -> int -(** Returns the id number of the connection *) - -val client_connection : client -> Ocsigen_http_com.connection -(** Returns the connection *) - -type ifrange = Ocsigen_request_info.ifrange = - | IR_No - | IR_Ifunmodsince of float - | IR_ifmatch of string -type file_info = Ocsigen_request_info.file_info = { - tmp_filename: string; - filesize: int64; - raw_original_filename: string; - original_basename: string ; - file_content_type: ((string * string) * (string * string) list) option; -} -type request_info = Ocsigen_request_info.request_info -and request = { - request_info: request_info; +type request = { + request_info: Ocsigen_cohttp_server.request; request_config: config_info; } exception Ocsigen_Is_a_directory - of (Ocsigen_request_info.request_info -> Neturl.url) + of (Ocsigen_cohttp_server.request -> Neturl.url) + +type result = Ocsigen_cohttp_server.result = { + r_response : Cohttp.Response.t ; + r_body : Cohttp_lwt_body.t ; + r_cookies : Ocsigen_cookies.cookieset +} type answer = | Ext_do_nothing (** I don't want to do anything *) - | Ext_found of (unit -> Ocsigen_http_frame.result Lwt.t) + | Ext_found of (unit -> result Lwt.t) (** "OK stop! I will take the page. You can start the following request of the same pipelined connection. Here is the function to generate the page". @@ -175,7 +154,7 @@ type answer = In that case, wait to be sure that the new request will not overtake this one. *) - | Ext_found_stop of (unit -> Ocsigen_http_frame.result Lwt.t) + | Ext_found_stop of (unit -> result Lwt.t) (** Found but do not try next extensions *) | Ext_next of int (** Page not found. Try next extension. The integer is the HTTP error code. @@ -230,9 +209,9 @@ type answer = that will return something of type [extension2]. *) | Ext_found_continue_with of - (unit -> (Ocsigen_http_frame.result * request) Lwt.t) + (unit -> (result * request) Lwt.t) (** Same as [Ext_found] but may modify the request. *) - | Ext_found_continue_with' of (Ocsigen_http_frame.result * request) + | Ext_found_continue_with' of (result * request) (** Same as [Ext_found_continue_with] but does not allow to delay the computation of the page. You should probably not use it, but for output filters. @@ -240,10 +219,9 @@ type answer = and request_state = | Req_not_found of (int * request) - | Req_found of (request * Ocsigen_http_frame.result) + | Req_found of (request * result) and extension2 = - (unit -> unit) -> Ocsigen_cookies.cookieset -> request_state -> (answer * Ocsigen_cookies.cookieset) Lwt.t @@ -446,19 +424,12 @@ val get_hostname : request -> string - or the default port set in the configuration file. *) val get_port : request -> int - (** new_url_of_directory_request create a redirection and generating a new url for the client (depending on the server configuration and request) @param request configuration of the server @param ri request *) -val new_url_of_directory_request : request -> request_info -> Neturl.url - -(** Parsing URLs. - This allows to modify the URL in the request_info. - (to be used for example with Ext_retry_with or Ext_continue_with) -*) -val ri_of_url : ?full_rewrite:bool -> string -> request_info -> request_info - +val new_url_of_directory_request : + request -> Ocsigen_cohttp_server.request -> Neturl.url (** {3 User directories} *) @@ -504,8 +475,7 @@ val get_hosts : unit -> (virtual_hosts * config_info * extension2) list *) val compute_result : ?previous_cookies:Ocsigen_cookies.cookieset -> - ?awake_next_request:bool -> - request_info -> Ocsigen_http_frame.result Lwt.t + Ocsigen_cohttp_server.request -> result Lwt.t (** Profiling *) val get_number_of_connected : unit -> int @@ -526,9 +496,5 @@ val get_init_exn_handler : unit -> exn -> string val set_config : Simplexmlparser.xml list -> unit -val client_of_connection : Ocsigen_http_com.connection -> client - -val get_server_address : request_info -> Unix.inet_addr * int - val sockets : Lwt_unix.file_descr list ref val sslsockets : Lwt_unix.file_descr list ref diff --git a/src/server/ocsigen_http_client.ml b/src/server/ocsigen_http_client.ml index aaf8f9e15..f919edc73 100644 --- a/src/server/ocsigen_http_client.ml +++ b/src/server/ocsigen_http_client.ml @@ -1,835 +1,65 @@ -(* Ocsigen - * http://www.ocsigen.org - * ocsigen_http_client.ml Copyright (C) 2005 Vincent Balat - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - -(* - It is a first version. Many improvements are possible. - - TODO - - get using pipeline (~client parameter) - - better heuristic for trusting server keepalive? - I think it could be less strict, as we redo requests? - It should probably be different for a proxy or a reverse proxy ... - - keep the name of the server in pipeline table? - - Avoid the keepalive table to become too big - - Add a parameter to disable reuse of free connections? - - Allow to set parameters in config file (probing_time, etc) - - Find a way to pipeline POST requests? at least PUT? - - Does it work well if the server is using HTTP/1.0? - (probably not because of chunks) - - limit the number of concurrent requests to avoid too many opened - file descriptors - - Notes: - - Pipeline: - If the server decided to close the pipeline when some request has already - been sent, we redo the request. But ... it has never been tested!!!!! - See exception Pipeline_failed. - - Pipeline: we pipeline requests without body if possible, - and we resend on a new connection if the pipeline failed. - - We do not pipeline requests with non-empty body!!!!!!!!!!!!!! - and requests using CONNECT method. - CONNECT and POST because they are not idempotent (see RFC). - Requests with body because we do not keep the content so we can not resend - them ... - - - It is actually doing very few pipelining when used with - Firefox or Konqueror ... The previous request is always received before - sending the next one. Why? - - - Is it ok to reuse the same connection for several clients? - May be restrict to several connections from the same client? - What if the client is a proxy? - - What to do with headers like user-agent, server, etc? - For now we keep user-agent but send Ocsigen as server! - - If I'm right, we are not supposed to change the User-Agent (end-to-end) - but is there a hop-to-hop equivalent? What about other headers? - - Note that for now, we pipeline only if incoming requests were pipelined. - But we can reuse a free connection. - - If the server says Connection:close once, we do not trust it any more - for an amount of time ... - - Note (2011/02/09): I don't remember why there is a "head" field in the key - of connection_table and free_connection_table ... - -*) - +open Lwt open Ocsigen_lib -let section = Lwt_log.Section.make "ocsigen:http:client" -(* constants. Should be configurable *) -let max_free_open_connections = 10 - -exception Connection_timed_out -exception Connection_refused -exception Pipeline_failed - -let (>>=) = Lwt.(>>=) - -(* let _ = Ssl_threads.init () (* Does not work for now (deadlock) -- - bug in ocamlssl *) *) -let _ = Ssl.init () -let sslcontext = ref (Ssl.create_context Ssl.SSLv23 Ssl.Both_context) - -let request_sender = - Ocsigen_http_com.create_sender ~proto:Ocsigen_http_frame.Http_header.HTTP11 () - -(*****************************************************************************) -module T = Hashtbl.Make( - struct - type t = int * (Unix.inet_addr * int * bool) - (* client ID, (IP, port, doing HEAD request) *) - let equal = (=) - let hash = Hashtbl.hash - end) - -let connection_table = T.create 100 -(* - (comment added 2001/02/09) - - The connection table associates to each incoming connection - (called "client") the thread and information about the output requests, - in order to try to pipeline them on the same output connection. - - If the client parameter is not present, we do the - requests independantly. - We try to find a free connection to the right server - or we create one if there is none. - In that case, the distant server may have the request in wrong order. - - If there is a body in the request we want to do, - we do not try to pipeline, even if it comes from the same client. - We use a free (or new) connection. -*) - -module FT = struct - module T = - Hashtbl.Make( - struct - type t = Unix.inet_addr * int * bool (* IP, port, doing HEAD request *) - let equal = (=) - let hash = Hashtbl.hash - end) - - let free_connection_table = T.create 100 - (* contains unused opened output connections *) - - let add k v = - let add_last v = - let rec aux v = function - | [] -> [v], 2 - | a::l -> let l', size = aux v l in a::l', (size + 1) - in - function - | [] -> v, [], 1 - | a::l -> let l', size = aux v l in a, l', size - in - try - let l = T.find free_connection_table k in - let first, new_l, size = add_last v l in - let new_l = - if size > max_free_open_connections then begin - Lwt_log.ign_info ~section - "Too much free connections. Removing the oldest one."; - ignore - (!(fst first) >>= fun conn -> - Lwt_ssl.shutdown - (Ocsigen_http_com.connection_fd conn) Unix.SHUTDOWN_ALL; - Lwt.return ()); - new_l - end - else first::new_l - in - T.replace free_connection_table k new_l - with Not_found -> - T.replace free_connection_table k [v] - - let find_remove k = - match T.find free_connection_table k with - | [] -> - T.remove free_connection_table k; - raise Not_found - | [a] -> - T.remove free_connection_table k; - a - | a::l -> - T.replace free_connection_table k l; - a - - let remove k (conn, gf) = - let rec aux = function - | [] -> false, [] - | ((conn2, _) as a)::l -> - if conn2 == conn then - true, l - else - let (b, ll) = aux l in - b, a::ll - in - try - match T.find free_connection_table k with - | [] -> - T.remove free_connection_table k; - | [(conn2, _)] -> - if conn == conn2 then T.remove free_connection_table k; - | l -> - let b, ll = aux l in - if b then T.replace free_connection_table k ll; - with Not_found -> () - | exn -> Lwt_log.ign_info ~exn ~section - "exception while removing from connection table" - -end - -let remove_on_error_from_free_conn key ((_, gf) as v) = - ignore - (Lwt.catch - (fun () -> gf >>= fun _ -> Lwt.return ()) - (fun _ -> - FT.remove key v; - Lwt.return () - ) - ) - -(*****************************************************************************) -module KT = Hashtbl.Make( - struct - type t = Unix.inet_addr * int - let equal = (=) - let hash = Hashtbl.hash - end) - -type k = Probing of int | Yes | No of float (* last failure date *) - -let pipelining_table = KT.create 100 - -let probing_time = 1000 (* number of requests for probing *) -let purgatory_time = 10000 (* number of requests for probing after purgatory *) -let purgatory_delay = 86400. (* 1 day *) - -let appreciate_server_pipeline inet_addr port = - let key = (inet_addr, port) in - match - try - match KT.find pipelining_table key with - | Yes -> None - | No t when Unix.time () -. t < purgatory_delay -> None - | No t -> - Lwt_log.ign_notice_f ~section - "Give to server %a:%d a new probing period for pipelining." - (fun () -> Unix.string_of_inet_addr) inet_addr port; - Some purgatory_time (* second chance *) - | Probing n -> Some (n-1) - with Not_found -> - Lwt_log.ign_notice_f ~section - "Give to server %a:%d a first probing period for pipelining." (fun () -> Unix.string_of_inet_addr) inet_addr port; - Some probing_time - with - | None -> () - | Some n -> - if n < 0 then begin - Lwt_log.ign_warning_f ~section - "Trusts server %a:%d for pipelining. He passed the probing period." - (fun () -> Unix.string_of_inet_addr) inet_addr port; - KT.replace pipelining_table key Yes - end - else - KT.replace pipelining_table key (Probing n) - -let boycott_server_pipeline server_do_keepalive inet_addr port = - if server_do_keepalive then - Lwt_log.ign_warning_f ~section - "Do not trust server %a:%d any more for pipelining. He just closed the connection!" - (fun () -> Unix.string_of_inet_addr) inet_addr port; - KT.replace pipelining_table (inet_addr, port) (No (Unix.time ())) - -let keep_alive_server inet_addr port = - try - match KT.find pipelining_table (inet_addr, port) with - | Yes -> true - | No _ -> - Lwt_log.ign_info_f ~section - "Do not trust server %a:%d for for pipelining." - (fun () -> Unix.string_of_inet_addr) - inet_addr port; - false - | Probing _ -> - Lwt_log.ign_info_f ~section - "Currently probing server %a:%d for pipelining. No pipeline for now." - (fun () -> Unix.string_of_inet_addr) - inet_addr port; - false - with Not_found -> false - - -(*****************************************************************************) - -let handle_connection_error fd exn = match exn with - | Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> - Lwt_unix.close fd - >>= fun () -> Lwt.fail - (Ocsigen_http_frame.Http_error.Http_exception - (502, Some "Connection refused by distant server", None)) - | Unix.Unix_error (Unix.ECONNRESET, _, _) -> - (* Caused by shutting down the file descriptor after a timeout *) - Lwt_unix.close fd - >>= fun () -> Lwt.fail - (Ocsigen_http_frame.Http_error.Http_exception - (504, Some "Distant server closed connection", None)) - | e -> - Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return ()) - >>= fun () -> Lwt.fail e - - -let raw_request - ?client ?(keep_alive = true) ?headers ?(https=false) ?port - ~content ?content_length ~http_method ~host ~inet_addr ~uri () = - - let uri = if uri = "" then "/" else uri in - - let head = http_method = Ocsigen_http_frame.Http_header.HEAD in - - let port = match port with - | None -> if https then 443 else 80 - | Some p -> p - in - - Lwt_log.ign_info_f ~section "New request to host %s:%d for %s" host port uri; - - let keep_alive_asked = keep_alive in - let server_do_keepalive = keep_alive_server inet_addr port in - let do_keep_alive = keep_alive_asked && server_do_keepalive in - - let client = - if not do_keep_alive then - None - else client - in - - (* let do_pipeline = not client = None in *) - - if do_keep_alive then - Lwt_log.ign_info ~section "Doing keep_alive" - else - Lwt_log.ign_info ~section "NOT doing keep_alive"; - - if client = None then - Lwt_log.ign_info ~section "NOT pipelining" - else - Lwt_log.ign_info ~section "Will do pipelining if needed"; - - let close_on_error thr_conn gf = - (* No need for lingering close, if I am not wrong *) - ignore - (thr_conn >>= fun conn -> - (Lwt.catch - (fun () -> gf >>= fun _ -> Lwt.return ()) - (function - | Ocsigen_http_com.Connection_closed -> - Lwt_log.ign_info ~section "Connection closed by server (closing)"; - Lwt_ssl.close (Ocsigen_http_com.connection_fd conn) - | Ocsigen_http_com.Keepalive_timeout -> - Lwt_log.ign_info ~section "Connection closed by keepalive timeout"; - Lwt_ssl.close (Ocsigen_http_com.connection_fd conn) - | exn -> - Lwt_log.ign_warning ~section ~exn - "Exception caught while receiving frame - closing connection to the server."; - Lwt_ssl.close (Ocsigen_http_com.connection_fd conn) - ))) - in - - let new_conn () = - let sockaddr = Unix.ADDR_INET (inet_addr, port) in - let fd = - Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 - in - Lwt_unix.set_close_on_exec fd; - - let thr_conn = - let timeout = - Lwt_timeout.create (Ocsigen_config.get_server_timeout ()) - (fun () -> try Lwt_unix.shutdown fd Unix.SHUTDOWN_RECEIVE with _ -> ()); - in - Lwt.catch - (fun () -> - Lwt_timeout.start timeout; - Lwt_unix.connect - fd sockaddr >>= fun () -> - - (if https then - let s = Lwt_ssl.embed_uninitialized_socket fd !sslcontext in - Ssl.set_client_SNI_hostname - (Lwt_ssl.ssl_socket_of_uninitialized_socket s) host; - Lwt_ssl.ssl_perform_handshake s - else - Lwt.return (Lwt_ssl.plain fd)) - >>= fun socket -> - Lwt_timeout.stop timeout; - Lwt.return (Ocsigen_http_com.create_receiver - (Ocsigen_config.get_server_timeout ()) - Ocsigen_http_com.Answer socket)) - (Lwt_timeout.stop timeout; - handle_connection_error fd) - in - let gf = - thr_conn >>= fun conn -> - Ocsigen_http_com.get_http_frame ~head conn - in - close_on_error thr_conn gf; - (thr_conn, gf) - in - - let find_conn () = - (* If there is already a free connection for the same server, we reuse it *) - try - let c = FT.find_remove (inet_addr, port, head) in - Lwt_log.ign_info ~section "Free connection found"; - c - with Not_found -> - Lwt_log.ign_info ~section "Free connection not found - creating new one"; - let (c, g) = new_conn () in - (ref c, g) - in - - let (key_new_waiter, ref_thr_conn, get_frame) = - match client with - | Some client when (content = None && - (* Do not pipeline requests with content, - as we cannot resend them for now if the pipeline - failed. - Do not pipeline CONNECT and POST. - *) - http_method <> Ocsigen_http_frame.Http_header.CONNECT) - -> - (* Trying to pipeline *) - Lwt_log.ign_info_f ~section - "Trying to find an opened connection for same client - connection number %a" - (fun () x -> string_of_int (Ocsigen_extensions.client_id x)) client; - let new_waiter, new_waiter_awakener = Lwt.wait () in - let key = (Ocsigen_extensions.client_id client, (inet_addr, port, head)) in - (* Is there already a connection for the same client? *) - let (ref_thr_conn, get_frame, nb_users) = - try - let r = T.find connection_table key in - Lwt_log.ign_info ~section "Connection FOUND for this client! PIPELINING!"; - r - with Not_found -> - Lwt_log.ign_info ~section "Connection not found for this client's connection"; - let (ref_thr_conn, gf) = find_conn () in - (ref_thr_conn, gf, 0) - in - let new_get_frame = - new_waiter >>= fun () -> - !ref_thr_conn >>= fun conn -> - let gf = Ocsigen_http_com.get_http_frame ~head conn in - close_on_error !ref_thr_conn gf; - gf - in - Lwt_log.ign_info ~section "Putting connection in connection_table"; - T.replace connection_table key - (ref_thr_conn, new_get_frame, nb_users + 1); -(* remove_on_error key get_frame; *) - (Some (key, new_waiter_awakener), ref_thr_conn, get_frame) - | _ -> - (* No pipeline *) - let (ref_thr_conn, gf) = find_conn () in - (None, ref_thr_conn, gf) - - in - - (* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ *) - (* Now the request is pipelined. It is safe to return the function *) - - fun () -> - - let get_frame_ref = ref get_frame in - let request_sent, request_sent_awakener = - Lwt.wait () in (* awoken when request sent *) - - let query = Ocsigen_http_frame.Http_header.Query (http_method, uri) in - - let headers = - Http_headers.replace - (Http_headers.name "host") - host - (match headers with - | None -> Http_headers.empty - | Some h -> h) - in - - let f ?reopen slot = - - Lwt_log.ign_info ~section "Will send request when slot opened"; - Lwt.catch - (fun () -> - (match content with - | None -> - let empty_result = Ocsigen_http_frame.Result.empty () in - Ocsigen_http_com.send - ?reopen - slot - ~head:false (* We want to send the full request *) - ~mode:query - ~clientproto:Ocsigen_http_frame.Http_header.HTTP11 - ~keep_alive:keep_alive_asked (* we request keep alive - even if we do not pipeline - if we don't trust the server - *) - ~sender:request_sender - (Ocsigen_http_frame.Result.update empty_result - ~headers ()) - - | Some stream -> - Ocsigen_senders.Stream_content.result_of_content - stream >>= fun r -> - Ocsigen_http_com.send - ?reopen - slot - ~mode:query - ~head:false (* We want to send the full request *) - ~clientproto:Ocsigen_http_frame.Http_header.HTTP11 - ~keep_alive:keep_alive_asked - ~sender:request_sender - (Ocsigen_http_frame.Result.update r - ~content_length - ~headers ()) - ) >>= fun () -> - - Lwt_log.ign_info ~section "request sent"; - Lwt.wakeup request_sent_awakener (); - Lwt.return ()) - (fun e -> Lwt.wakeup_exn request_sent_awakener e; Lwt.fail e) - - in - - - let reopen () = - Lwt_log.ign_info ~section "Server not responding. Trying to open a new connection"; - let (thr_conn, gf) = new_conn () in - ref_thr_conn := thr_conn; - get_frame_ref := gf; - - Lwt_log.ign_info ~section "Retrying to do the request"; - thr_conn >>= fun conn -> - Ocsigen_http_com.start_processing conn (f ?reopen:None); (* starting the request *) - Lwt.return () - - in - - Lwt_log.ign_info ~section "Doing the request"; - let thr_conn = !ref_thr_conn in - thr_conn >>= fun conn -> - Ocsigen_http_com.start_processing conn (f ~reopen); (* starting the request *) - - - let finalize do_keep_alive = - let put_in_free_conn ?gf () = - Lwt_log.ign_info ~section "Putting in free connections"; - let gf = match gf with - | None -> - let gf = - !ref_thr_conn >>= fun conn -> - Ocsigen_http_com.get_http_frame ~head conn - in - close_on_error !ref_thr_conn gf; - gf - | Some gf -> gf - in - try - ignore (Lwt.poll gf); - FT.add (inet_addr, port, head) (ref_thr_conn, gf); - Lwt_log.ign_info ~section "Added in free connections"; - remove_on_error_from_free_conn - (inet_addr, port, head) (ref_thr_conn, gf) ; - Lwt.return () - with exn -> - Lwt_log.ign_info ~section ~exn - "exception while trying to keep free connection"; - !ref_thr_conn >>= fun conn -> - (* We can arrive here when there the server has closed the - connection. In this case, we have already closed the - connection as well, and we should ignore the error - when attempting to close it again below. *) - Lwt.catch - (fun () -> Lwt_ssl.close (Ocsigen_http_com.connection_fd conn)) - (fun _ -> Lwt.return ()) - in - if do_keep_alive then begin - match key_new_waiter with - | None -> (* no pipeline *) put_in_free_conn () - | Some (key, _) -> - (try - let (ref_thr_conn, gf, nb_users) = - T.find connection_table key - in - if nb_users = 1 then begin - Lwt_log.ign_info ~section "The connection is not used any more by the client"; - T.remove connection_table key; - put_in_free_conn ~gf () - end - else begin - T.replace connection_table key (ref_thr_conn, gf, nb_users - 1); - Lwt.return () - end - with Not_found -> - Lwt_log.ign_warning ~section - "Strange: connection disappeared from connection_table"; - Lwt.return ()) - end - else begin - !ref_thr_conn >>= fun conn -> - Lwt_ssl.close (Ocsigen_http_com.connection_fd conn) - end - in - - - Lwt.catch - (fun () -> - Lwt.catch - (fun () -> - (* We wait for the request to be sent, - because get_frame_ref may change *) - request_sent >>= fun () -> - (* getting and sending back the result: *) - !get_frame_ref) - (function - | Pipeline_failed -> - (* Previous request closed the pipeline - but the request has been sent. We redo it. *) - Lwt_log.ign_warning ~section - "Previous request closed the pipeline. Redoing the request on a new connection."; - reopen () >>= fun () -> - !get_frame_ref - | e -> Lwt.fail e)) - - (fun e -> - (* We advice subsequent get_frame that the pipeline failed: *) - (match key_new_waiter with - | None -> () - | Some (_, new_waiter_awakener) -> - Lwt.wakeup_exn new_waiter_awakener Pipeline_failed); - - finalize false >>= fun () -> - Lwt.fail e) - - >>= fun http_frame -> +open Cohttp +open Cohttp_lwt_unix - let server_keepalive = - Ocsigen_headers.get_keepalive http_frame.Ocsigen_http_frame.frame_header - in - if keep_alive_asked && not server_keepalive then - (* The server does not want to do keep-alive *) - boycott_server_pipeline server_do_keepalive inet_addr port - else if keep_alive_asked then - appreciate_server_pipeline inet_addr port; +let target https host ?port uri = + let scheme = if https then "https" else "http" in + Uri.resolve scheme (Uri.make ~scheme ~host ?port ()) (Uri.of_string uri) - let do_keep_alive = keep_alive_asked && server_keepalive in - (* We keep alive even if we do not trust the server for pipelining *) - - (* It is now time for starting subsequent get_frame: *) - (match key_new_waiter with - | None -> () - | Some (_, new_waiter) -> - if server_keepalive then - Lwt.wakeup new_waiter () - else - Lwt.wakeup_exn new_waiter Pipeline_failed); - - Lwt_log.ign_info ~section "frame received"; - (match http_frame.Ocsigen_http_frame.frame_content with - | None -> finalize do_keep_alive - | Some c -> - Ocsigen_stream.add_finalizer c (fun _ -> finalize do_keep_alive); - Lwt.return () - ) >>= fun () -> - - - let headers = - Http_headers.replace_opt - Http_headers.connection - None - http_frame.Ocsigen_http_frame.frame_header.Ocsigen_http_frame.Http_header.headers - in - let headers = - try - let connection_value = - Ocsigen_http_frame.Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header Http_headers.connection - in - Http_headers.replace_opt - (Http_headers.name connection_value) - None - headers - with Not_found -> headers - in - Lwt.return - {Ocsigen_http_frame.frame_header= - {Ocsigen_http_frame.Http_header.mode = - http_frame.Ocsigen_http_frame.frame_header.Ocsigen_http_frame.Http_header.mode; - Ocsigen_http_frame.Http_header.proto = - http_frame.Ocsigen_http_frame.frame_header.Ocsigen_http_frame.Http_header.proto; - Ocsigen_http_frame.Http_header.headers = headers}; - frame_content = http_frame.Ocsigen_http_frame.frame_content; - frame_abort = http_frame.Ocsigen_http_frame.frame_abort; - } - - -(*****************************************************************************) -let get ?v6 ?https ?port ?headers ~host ~uri () = - Ip_address.get_inet_addr ?v6 host >>= fun inet_addr -> - raw_request - ?https - ?port - ?headers - ~http_method:Ocsigen_http_frame.Http_header.GET - ~content:None - ~host:(match port with None -> host | Some p -> host^":"^string_of_int p) - ~inet_addr - ~uri - () - () - -let get_url ?v6 ?headers url = - let (https, host, port, uri, _, _, _) = Url.parse url in - let host = match host with None -> "localhost" | Some h -> h in - let uri = "/"^uri in - get ?v6 ?https ?port ?headers ~host ~uri () - -(*****************************************************************************) -let post_string ?v6 ?https ?port ?(headers = Http_headers.empty) +let post_string ?(https = false) ?port ?(headers = Http_headers.empty) ~host ~uri ~content ~content_type () = - Ip_address.get_inet_addr ?v6 host >>= fun inet_addr -> let content_type = String.concat "/" [fst content_type; snd content_type] in - raw_request - ?https - ?port - ~http_method:Ocsigen_http_frame.Http_header.POST - ~content:(Some (Ocsigen_stream.of_string content)) - ~content_length:(Int64.of_int (String.length content)) - ~headers:(Http_headers.add Http_headers.content_type content_type headers) - ~host:(match port with None -> host | Some p -> host^":"^string_of_int p) - ~inet_addr - ~uri - () - () - -let post_string_url ?v6 ?headers ~content ~content_type url = - let (https, host, port, uri, _, _, _) = Url.parse url in - let host = match host with None -> "localhost" | Some h -> h in - let uri = "/"^uri in - post_string ?v6 ?https ?port ?headers ~host ~uri ~content ~content_type () - - -(*****************************************************************************) -let post_urlencoded ?v6 ?https ?port ?headers ~host ~uri ~content () = - post_string ?v6 ?https ?port ?headers + let ( |> ) a f = f a in + let headers = + headers + |> Http_headers.add Http_headers.content_type content_type + |> Http_headers.add Http_headers.content_length + (string_of_int (String.length content)) + |> To_cohttp.to_headers in + Cohttp_lwt_unix.Client.post + ~body:(Cohttp_lwt_body.of_string content) + ~headers + (target https host ?port uri) + >|= Of_cohttp.of_response_and_body' + +let get ?(https = false) ?port ?headers ~host ~uri () = + Cohttp_lwt_unix.Client.get ?headers (target https host ?port uri) + >|= Of_cohttp.of_response_and_body' + +let post_urlencoded ?https ?port ?headers ~host ~uri ~content () = + post_string ?https ?port ?headers ~host ~uri ~content:(Netencoding.Url.mk_url_encoded_parameters content) ~content_type:("application","x-www-form-urlencoded") () -let post_urlencoded_url ?v6 ?headers ~content url = - let (https, host, port, uri, _, _, _) = Url.parse url in - let host = match host with None -> "localhost" | Some h -> h in - let uri = "/"^uri in - post_urlencoded ?v6 ?https ?port ?headers ~host ~uri ~content () - -(*****************************************************************************) let basic_raw_request - ?headers ?(https=false) ?port ~content ?content_length + ?(headers = Http_headers.empty) ?(https=false) ?port + ~content ?content_length ~http_method ~host ~inet_addr ~uri () = - - let port = match port with - | None -> if https then 443 else 80 - | Some p -> p - in - let sockaddr = Unix.ADDR_INET (inet_addr, port) in - let fd = - Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 - in - Lwt_unix.set_close_on_exec fd; - - Lwt.catch - (fun () -> - Lwt_unix.connect fd sockaddr >>= fun () -> - (if https then - let s = Lwt_ssl.embed_uninitialized_socket fd !sslcontext in - Ssl.set_client_SNI_hostname - (Lwt_ssl.ssl_socket_of_uninitialized_socket s) host; - Lwt_ssl.ssl_perform_handshake s - else - Lwt.return (Lwt_ssl.plain fd))) - (handle_connection_error fd) - >>= fun socket -> - - let query = Ocsigen_http_frame.Http_header.Query (http_method, uri) in - let conn = Ocsigen_http_com.create_receiver - (Ocsigen_config.get_server_timeout ()) - Ocsigen_http_com.Answer socket in + ignore inet_addr; let headers = - Http_headers.replace - (Http_headers.name "host") - host - (match headers with - | None -> Http_headers.empty - | Some h -> h) + match content_length with + Some len -> Http_headers.add Http_headers.content_length + (Int64.to_string len) headers + | None -> headers in - let f slot = - + let body = match content with + Some c -> + Some (Cohttp_lwt_body.of_stream (Ocsigen_stream.to_lwt_stream c)) | None -> - let empty_result = Ocsigen_http_frame.Result.empty () in - Ocsigen_http_com.send - slot - ~mode:query - ~clientproto:Ocsigen_http_frame.Http_header.HTTP11 - ~head:false - ~keep_alive:false - ~sender:request_sender - (Ocsigen_http_frame.Result.update empty_result - ~headers ()) - | Some stream -> - Ocsigen_senders.Stream_content.result_of_content stream >>= fun r -> - Ocsigen_http_com.send - slot - ~mode:query - ~clientproto:Ocsigen_http_frame.Http_header.HTTP11 - ~head:false - ~keep_alive:false - ~sender:request_sender - (Ocsigen_http_frame.Result.update r - ~content_length - ~headers ()) + None in - Ocsigen_http_com.start_processing conn f; (* starting the request *) - (* Ocsigen_http_com.wait_all_senders conn >>= fun () -> (* not needed *) *) - Lwt.catch - (fun () -> - Ocsigen_http_com.get_http_frame - ~head:(http_method = Ocsigen_http_frame.Http_header.HEAD) - conn - >>= fun http_frame -> - (match http_frame.Ocsigen_http_frame.frame_content with - | None -> Lwt_ssl.close socket - | Some c -> - Ocsigen_stream.add_finalizer c (fun _ -> Lwt_ssl.close socket); - Lwt.return ()) - >>= fun () -> - Lwt.return http_frame) - (fun e -> Lwt_ssl.close socket >>= fun () -> Lwt.fail e) + Cohttp_lwt_unix.Client.call ~headers ?body + (To_cohttp.to_meth http_method) (target https host ?port uri) + >|= Of_cohttp.of_response_and_body' + +let raw_request + ?keep_alive ?headers ?https ?port + ~content ?content_length ~http_method ~host ~inet_addr ~uri () () = + ignore keep_alive; + basic_raw_request + ?headers ?https ?port ~content ?content_length + ~http_method ~host ~inet_addr ~uri () diff --git a/src/server/ocsigen_http_client.mli b/src/server/ocsigen_http_client.mli index 34b873f64..3636522b9 100644 --- a/src/server/ocsigen_http_client.mli +++ b/src/server/ocsigen_http_client.mli @@ -1,50 +1,27 @@ -(* Ocsigen - * http://www.ocsigen.org - * ocsigen_http_client.ml Copyright (C) 2005 Vincent Balat - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - (** Using Ocsigen as a HTTP client *) -val get : - ?v6:bool -> - ?https: bool -> - ?port:int -> - ?headers: Http_headers.t -> - host:string -> - uri:string -> - unit -> - Ocsigen_http_frame.t Lwt.t (** Do a GET HTTP request. The default port is 80 for HTTP, 443 for HTTPS. The default protocol is http ([https=false]). - Warning: the stream must be finalized manually after reading, using {!Ocsigen_stream.finalize}, otherwise you will have fd leaks. *) +val get : + ?https: bool -> + ?port:int -> + ?headers: Http_headers.t -> + host:string -> + uri:string -> + unit -> + Ocsigen_http_frame.t Lwt.t -val get_url : ?v6:bool -> ?headers: Http_headers.t -> string -> Ocsigen_http_frame.t Lwt.t -(** Do a GET HTTP request. The string must be a full URL. - +(** Do a POST HTTP request. + The default port is 80 for HTTP, 443 for HTTPS. + The default protocol is http ([https=false]). Warning: the stream must be finalized manually after reading, using {!Ocsigen_stream.finalize}, otherwise you will have fd leaks. *) - val post_string : - ?v6:bool -> ?https: bool -> ?port:int -> ?headers: Http_headers.t -> @@ -54,29 +31,14 @@ val post_string : content_type:(string * string) -> unit -> Ocsigen_http_frame.t Lwt.t -(** Do a POST HTTP request. + +(** Do a POST HTTP request with URL encoded parameters as content. The default port is 80 for HTTP, 443 for HTTPS. The default protocol is http ([https=false]). - Warning: the stream must be finalized manually after reading, using {!Ocsigen_stream.finalize}, otherwise you will have fd leaks. *) - -val post_string_url : - ?v6:bool -> - ?headers: Http_headers.t -> - content:string -> - content_type:(string * string) -> - string -> - Ocsigen_http_frame.t Lwt.t -(** Do a GET HTTP request. The string must be a full URL. - - Warning: the stream must be finalized manually after reading, using - {!Ocsigen_stream.finalize}, otherwise you will have fd leaks. -*) - val post_urlencoded : - ?v6:bool -> ?https: bool -> ?port:int -> ?headers: Http_headers.t -> @@ -85,30 +47,8 @@ val post_urlencoded : content:(string * string) list -> unit -> Ocsigen_http_frame.t Lwt.t -(** Do a POST HTTP request with URL encoded parameters as content. - The default port is 80 for HTTP, 443 for HTTPS. - The default protocol is http ([https=false]). - - Warning: the stream must be finalized manually after reading, using - {!Ocsigen_stream.finalize}, otherwise you will have fd leaks. -*) - -val post_urlencoded_url : - ?v6:bool -> - ?headers: Http_headers.t -> - content:(string * string) list -> - string -> - Ocsigen_http_frame.t Lwt.t -(** Do a GET HTTP request with URL encoded parameters as content. - The string must be a full URL. - - Warning: the stream must be finalized manually after reading, using - {!Ocsigen_stream.finalize}, otherwise you will have fd leaks. -*) - val raw_request : - ?client: Ocsigen_extensions.client -> ?keep_alive: bool -> ?headers: Http_headers.t -> ?https: bool -> @@ -135,34 +75,8 @@ val raw_request : The default protocol is http ([https=false]). - The optional parameter [~keep_alive] asks to keep the connection opened - after the request for a short amount of time - to allow other requests to the same server to use the same connection. - It is true by default. - If there is one opened free connection, we will use it instead of opening - a new one. - - If you do this request to serve it later to a client or to generate a page - for a client, add the optional parameter [~client]. - Thus, the request you do will be pipelined - with other requests coming from the same connection. - A request will never be pipelined after a request from another client - connection. - Pipelining will be used only for requests to server we know supporting it - (according to previous requests). - It is recommended to specify this optional parameter for all requests - (with the value found in field - [ri_client] of type {!Ocsigen_extensions.request_info}). - - The optional parameter [?head] asks to do a [HEAD] HTTP request. - It is [false] by default. - - When called without the last parameter, the function will pipeline - the request (if needed), then return the function to get the page. - This allows to keep pipeline order when writing an extension. + The parameters [?keep_alive] and [~inet_addr] are ignored. *) -(*VVV Dangerous!! *) - val basic_raw_request : ?headers: Http_headers.t -> @@ -180,7 +94,3 @@ val basic_raw_request : but does not try to reuse connections. Opens a new connections for each request. Far less efficient. *) - - -(**/**) -val sslcontext : Ssl.context ref diff --git a/src/server/ocsigen_local_files.ml b/src/server/ocsigen_local_files.ml index ba226a119..e617c50cc 100644 --- a/src/server/ocsigen_local_files.ml +++ b/src/server/ocsigen_local_files.ml @@ -222,7 +222,8 @@ let content ~request ~file = match file with | RDir dirname -> Ocsigen_senders.Directory_content.result_of_content - (dirname, Ocsigen_request_info.full_path request.request_info) + (dirname, + Ocsigen_cohttp_server.path_of_request request.request_info) | RFile filename -> Ocsigen_senders.File_content.result_of_content (filename, diff --git a/src/server/ocsigen_range.ml b/src/server/ocsigen_range.ml deleted file mode 100644 index 5ebe6a6b4..000000000 --- a/src/server/ocsigen_range.ml +++ /dev/null @@ -1,227 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * ocsigen_range.ml Copyright (C) 2008 - * Vincent Balat - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - -(* - We send the range only if we know the content length - (the header of partial answers must contain the length) - - We compute range after content-encoding (deflation) - - We do not support multipart ranges. We send only an interval. - - The following works with any stream. - For files, it should be optimized with seek!!!!! -*) - -open Ocsigen_lib - -exception Range_416 - -(* We do not support multipart ranges. We send only an interval. - The following function checks if we support the range requested. -*) -let rec change_range = function - | Some ([], Some b, ifmatch) -> Some (b, None, ifmatch) - | Some ([ (b, e) ], None, ifmatch) -> Some (b, Some e, ifmatch) - | _ -> None - -let select_range length beg endopt skipfun stream = - let rec aux step num () = - if num = 0L - then Ocsigen_stream.empty None - else - (match step with - | Ocsigen_stream.Finished _ -> - Lwt.fail Ocsigen_stream.Stream_too_small - | Ocsigen_stream.Cont (c, f) -> Lwt.return (c, f)) - >>= fun (buf, nextstream) -> - let buflen = String.length buf in - let buflen64 = Int64.of_int buflen in - if (Int64.compare buflen64 num) <= 0 - then - Ocsigen_stream.cont buf (fun () -> - Ocsigen_stream.next nextstream >>= fun next -> - aux next (Int64.sub num buflen64) ()) - else - Ocsigen_stream.cont (String.sub buf 0 (Int64.to_int num)) - (fun () -> Ocsigen_stream.empty None) - in - Lwt.catch - (fun () -> - skipfun stream beg >>= fun new_s -> - Lwt.return - (match endopt with - | None -> - Ocsigen_stream.make - ~finalize: - (fun status -> Ocsigen_stream.finalize stream status) - (fun () -> Lwt.return new_s) - | Some endc -> - Ocsigen_stream.make - ~finalize: - (fun status -> Ocsigen_stream.finalize stream status) - (aux new_s length)) - ) - (function - | Ocsigen_stream.Stream_too_small -> Lwt.fail Range_416 - (* RFC 2616 A server SHOULD return a response with this status code if a request included a Range request-header field, and none of the range-specifier values in this field overlap the current extent of the selected resource, and the request did not include an If-Range request-header field. (For byte-ranges, this means that the first- byte-pos of all of the byte-range-spec values were greater than the current length of the selected resource.) *) - | e -> Lwt.fail e) - - -let compute_range ri res = - match Ocsigen_http_frame.Result.content_length res with - (* We support Ranges only if we know the content length, because - Content-Range always contains the length ... *) - | None -> Lwt.return res - | Some cl -> - (* Send range only if the code is 200!! *) - if (Ocsigen_http_frame.Result.code res <> 200) - || (Ocsigen_config.get_disablepartialrequests ()) - then Lwt.return res - else begin - let res = - Ocsigen_http_frame.Result.update res - ~headers: - (Http_headers.replace - Http_headers.accept_ranges "bytes" - (Ocsigen_http_frame.headers res)) () - in - match change_range (Lazy.force (Ocsigen_request_info.range ri)) with - | None -> Lwt.return res - | Some (_, _, Ocsigen_extensions.IR_ifmatch etag) - when (match Ocsigen_http_frame.Result.etag res with - | None -> true - | Some resetag -> String.compare etag resetag <> 0) -> - Lwt.return res - | Some (_, _, Ocsigen_extensions.IR_Ifunmodsince date) - when (match Ocsigen_http_frame.Result.lastmodified res with - | None -> true - | Some l -> l > date) - -> - Lwt.return res - | Some (beg, endopt, _) -> - - Lwt.catch - (fun () -> - (if Int64.compare cl beg <= 0 - then Lwt.fail Range_416 - else Lwt.return ()) >>= fun () -> - - let endc, length = match endopt with - | None -> (Int64.sub cl 1L, Int64.sub cl beg) - | Some e -> (e, Int64.add (Int64.sub e beg) 1L) - in - - let resstream, skipfun = - (Ocsigen_http_frame.Result.stream res) - in - (* stream transform *) - let skipfun = - match skipfun with - | None -> - (fun stream beg -> - (Ocsigen_stream.next - (Ocsigen_stream.get stream) >>= fun s -> - Ocsigen_stream.skip s beg)) - | Some f -> f - in - select_range - length beg endopt skipfun - resstream - >>= fun new_s -> - Lwt.return - (Ocsigen_http_frame.Result.update res - ~stream:(new_s, None) - ~code:206 - ~headers: - (Http_headers.replace - Http_headers.content_range - ("bytes "^Int64.to_string beg^"-"^ - Int64.to_string endc^"/"^ - Int64.to_string cl) - (Ocsigen_http_frame.Result.headers res)) - ~content_length:(Some length) ()) - ) - (function - | Range_416 -> - (* RFC 2616 When this status code is returned for a byte-range request, the response SHOULD include a Content-Range entity-header field specifying the current length of the selected resource *) - let dr = Ocsigen_http_frame.Result.default () in - Lwt.return - (Ocsigen_http_frame.Result.update dr - ~code:416 - ~headers: - (Http_headers.replace - Http_headers.content_range - ("bytes */"^Int64.to_string cl) - (Ocsigen_http_frame.Result.headers dr)) - ()) - | e -> Lwt.fail e) - - end - - -let get_range http_frame = - try - let rangeheader = Ocsigen_http_frame.Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header - Http_headers.range - in - - let decode_int index d e = - let a = Int64.of_string d in - let b = Int64.of_string e in - assert (Int64.compare index a < 0); - assert (Int64.compare a b <= 0); - (a, b) - in - - let interval, from = - let a,b = String.sep '=' rangeheader in - if String.compare a "bytes" <> 0 - then raise Not_found - else - let l = String.split ',' b in - let rec f index = function - | [] -> [], None - | [a] -> - let d, e = String.sep '-' a in - if e = "" - then [], Some (Int64.of_string d) - else [decode_int index d e], None - | a::l -> - let d, e = String.sep '-' a in - let a, b = decode_int index d e in - let ll, fr = f b l in (* not tail rec *) - (a, b)::ll, fr - in - f (-1L) l - in - - let ifrange = - try - let ifrangeheader = Ocsigen_http_frame.Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header - Http_headers.if_range - in - try - Ocsigen_extensions.IR_Ifunmodsince (Netdate.parse_epoch ifrangeheader) - with _ -> Ocsigen_extensions.IR_ifmatch ifrangeheader - with Not_found -> Ocsigen_extensions.IR_No - in - - Some (interval, from, ifrange) - - with _ -> None diff --git a/src/server/ocsigen_range.mli b/src/server/ocsigen_range.mli deleted file mode 100644 index 14322a286..000000000 --- a/src/server/ocsigen_range.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * ocsigen_range.ml Copyright (C) 2008 - * Vincent Balat - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - -(** [compute_range] add in header of result a media-range *) -val compute_range : - Ocsigen_request_info.request_info -> - Ocsigen_http_frame.result -> - Ocsigen_http_frame.result Lwt.t - -val get_range : Ocsigen_http_frame.t -> - ((int64 * int64) list * int64 option * Ocsigen_request_info.ifrange) option diff --git a/src/server/ocsigen_request_info.ml b/src/server/ocsigen_request_info.ml deleted file mode 100644 index c1c380516..000000000 --- a/src/server/ocsigen_request_info.ml +++ /dev/null @@ -1,373 +0,0 @@ -open Ocsigen_cookies -open Ocsigen_lib - -type ifrange = IR_No | IR_Ifunmodsince of float | IR_ifmatch of string - -type file_info = { - tmp_filename: string; - filesize: int64; - raw_original_filename: string; - original_basename: string ; - file_content_type: ((string * string) * (string * string) list) option; -} - -(** The request *) -type request_info = - {url_string: string; (** full URL *) - meth: Ocsigen_http_frame.Http_header.http_method; (** GET, POST, HEAD... *) - protocol: Ocsigen_http_frame.Http_header.proto; (** HTTP protocol used by client *) - ssl: bool; (** true if HTTPS, false if HTTP *) - full_path_string: string; (** full path of the URL *) - full_path: string list; (** full path of the URL *) - original_full_path_string: string; (** full path of the URL, as first sent by the client. Should not be changed by extensions, even rewritemod. It is used to create relative links. *) - original_full_path: string list; (** full path of the URL, as first sent by the client. See below. *) - sub_path: string list; (** path of the URL (only part concerning the site) *) - sub_path_string: string; (** path of the URL (only part concerning the site) *) - get_params_string: string option; (** string containing GET parameters *) - host: string option; (** Host field of the request (if any), without port *) - port_from_host_field: int option; (** Port in the host field of the request (if any) *) - get_params: (string * string) list Lazy.t; (** Association list of get parameters *) - initial_get_params: (string * string) list Lazy.t; (** Association list of get parameters, as sent by the browser (must not be modified by extensions) *) - post_params: ((string option * Int64.t option) -> (string * string) list Lwt.t) option; (** Association list of post parameters, if urlencoded form parameters or multipart data. None if other content type or no content. *) - files: ((string option * Int64.t option) -> (string * file_info) list Lwt.t) option; (** Files sent in the request (multipart data). None if other content type or no content. *) - remote_inet_addr: Unix.inet_addr; (** IP of the client *) - remote_ip: string; (** IP of the client *) - remote_ip_parsed: Ipaddr.t Lazy.t; (** IP of the client, parsed *) - remote_port: int; (** Port used by the client *) - forward_ip: string list; (** IPs of gateways the request went throught *) - server_port: int; (** Port of the request (server) *) - user_agent: string; (** User_agent of the browser *) - cookies_string: string option Lazy.t; (** Cookies sent by the browser *) - cookies: string CookiesTable.t Lazy.t; (** Cookies sent by the browser *) - ifmodifiedsince: float option; (** if-modified-since field *) - ifunmodifiedsince: float option; (** if-unmodified-since field *) - ifnonematch: string list option; (** if-none-match field ( * and weak entity tags not implemented) *) - ifmatch: string list option; (** if-match field ( * not implemented) *) - content_type: ((string * string) * (string * string) list) option; (** Content-Type HTTP header *) - content_type_string: string option; (** Content-Type HTTP header *) - content_length: int64 option; (** Content-Length HTTP header *) - referer: string option Lazy.t; (** Referer HTTP header *) - - origin: string option Lazy.t; - (** Where the cross-origin request or preflight request originates from. - http://www.w3.org/TR/cors/#origin-request-header *) - access_control_request_method : string option Lazy.t; - (** which method will be used in the actual request as part of - the preflight request. - http://www.w3.org/TR/cors/#access-control-request-method-request-he*) - access_control_request_headers : string list option Lazy.t; - (** Which headers will be used in the actual request as part of - the preflight request. - http://www.w3.org/TR/cors/#access-control-request-headers-request-h *) - - accept: ((string option * string option) * float option * (string * string) list) list Lazy.t; (** Accept HTTP header. For example [(Some "text", None)] means ["text/*"]. The float is the "quality" value, if any. The last association list is for other extensions. *) - accept_charset: (string option * float option) list Lazy.t; (** Accept-Charset HTTP header. [None] for the first value means "*". The float is the "quality" value, if any. *) - accept_encoding: (string option * float option) list Lazy.t; (** Accept-Encoding HTTP header. [None] for the first value means "*". The float is the "quality" value, if any. *) - accept_language: (string * float option) list Lazy.t; (** Accept-Language HTTP header. The float is the "quality" value, if any. *) - - http_frame: Ocsigen_http_frame.t; (** The full http_frame *) - mutable request_cache: Polytables.t; - (** Use this to put anything you want, - for example, information for subsequent - extensions - *) - client: Ocsigen_http_com.connection; (** The request connection *) - range: ((int64 * int64) list * int64 option * ifrange) option Lazy.t; - (** Range HTTP header. [None] means all the document. - List of intervals + possibly from an index to the end of the document. - *) - timeofday: float; (** An Unix timestamp computed at the beginning of the request *) - mutable nb_tries: int; (** For internal use: - used to prevent loops of requests *) - - connection_closed: unit Lwt.t; (** a thread waking up when the connection is closed *) - } -(** If you force [ri_files] or [ri_post_params], the request is fully read, - so it is not possible any more to read it from [ri_http_frame] - (and vice versa). -*) - -(* used to modify the url in ri (for example for retrying after rewrite) *) -let ri_of_url ?(full_rewrite = false) url ri = - let (_, host, _, url, path, params, get_params) = Url.parse url in - let host = match host with - | Some h -> host - | None -> ri.host - in - let path_string = Url.string_of_url_path ~encode:true path in - let original_full_path, original_full_path_string = - if full_rewrite - then (path, path_string) - else (ri.original_full_path, ri.original_full_path_string) - in - {ri with - url_string = url; - host ; - full_path_string = path_string; - full_path = path; - original_full_path_string ; - original_full_path ; - sub_path = path; - sub_path_string = path_string; - get_params_string = params; - get_params ; - } - -let make - ~url_string - ~meth - ~protocol - ?(ssl=false) - ~full_path_string - ~full_path - ?(original_full_path_string=full_path_string) - ?(original_full_path=full_path) - ?(sub_path=full_path) - ?(sub_path_string=Url.string_of_url_path ~encode:true full_path) - ~get_params_string - ~host - ~port_from_host_field - ~get_params - ?(initial_get_params=get_params) - ~post_params - ~files - ~remote_inet_addr - ~remote_ip - ?(remote_ip_parsed=lazy (Ipaddr.of_string_exn remote_ip)) - ~remote_port - ?(forward_ip=[]) - ~server_port - ~user_agent - ~cookies_string - ~cookies - ~ifmodifiedsince - ~ifunmodifiedsince - ~ifnonematch - ~ifmatch - ~content_type - ~content_type_string - ~content_length - ~referer - ~origin - ~access_control_request_method - ~access_control_request_headers - ~accept - ~accept_charset - ~accept_encoding - ~accept_language - ~http_frame - ?(request_cache=Polytables.create ()) - ~client - ~range - (* XXX: We should have this line but it would produce a circular dependency - * between the two modules - * - * ?(range=lazy (Ocsigen_range.get_range http_frame)) *) - ?(timeofday=Unix.gettimeofday ()) - ?(nb_tries=0) - ?(connection_closed=Ocsigen_http_com.closed client) - () = - { - url_string; - meth; - protocol; - ssl; - full_path_string; - full_path; - original_full_path_string; - original_full_path; - sub_path; - sub_path_string; - get_params_string; - host; - port_from_host_field; - get_params; - initial_get_params; - post_params; - files; - remote_inet_addr; - remote_ip; - remote_ip_parsed; - remote_port; - forward_ip; - server_port; - user_agent; - cookies_string; - cookies; - ifmodifiedsince; - ifunmodifiedsince; - ifnonematch; - ifmatch; - content_type; - content_type_string; - content_length; - referer; - origin; - access_control_request_method; - access_control_request_headers; - accept; - accept_charset; - accept_encoding; - accept_language; - http_frame; - request_cache; - client; - range; - timeofday; - nb_tries; - connection_closed; - } - -let update ri - ?(url_string=ri.url_string) - ?(meth=ri.meth) - ?(protocol=ri.protocol) - ?(ssl=ri.ssl) - ?(full_path_string=ri.full_path_string) - ?(full_path=ri.full_path) - ?(original_full_path_string=ri.original_full_path_string) - ?(original_full_path=ri.original_full_path) - ?(sub_path=ri.sub_path) - ?(sub_path_string=ri.sub_path_string) - ?(get_params_string=ri.get_params_string) - ?(host=ri.host) - ?(port_from_host_field=ri.port_from_host_field) - ?(get_params=ri.get_params) - ?(initial_get_params=ri.initial_get_params) - ?(post_params=ri.post_params) - ?(files=ri.files) - ?(remote_inet_addr=ri.remote_inet_addr) - ?(remote_ip=ri.remote_ip) - ?(remote_ip_parsed=ri.remote_ip_parsed) - ?(remote_port=ri.remote_port) - ?(forward_ip=ri.forward_ip) - ?(server_port=ri.server_port) - ?(user_agent=ri.user_agent) - ?(cookies_string=ri.cookies_string) - ?(cookies=ri.cookies) - ?(ifmodifiedsince=ri.ifmodifiedsince) - ?(ifunmodifiedsince=ri.ifunmodifiedsince) - ?(ifnonematch=ri.ifnonematch) - ?(ifmatch=ri.ifmatch) - ?(content_type=ri.content_type) - ?(content_type_string=ri.content_type_string) - ?(content_length=ri.content_length) - ?(referer=ri.referer) - ?(origin=ri.origin) - ?(access_control_request_method=ri.access_control_request_method) - ?(access_control_request_headers=ri.access_control_request_headers) - ?(accept=ri.accept) - ?(accept_charset=ri.accept_charset) - ?(accept_encoding=ri.accept_encoding) - ?(accept_language=ri.accept_language) - ?(http_frame=ri.http_frame) - ?(request_cache=ri.request_cache) - ?(client=ri.client) - ?(range=ri.range) - ?(timeofday=ri.timeofday) - ?(nb_tries=ri.nb_tries) - ?(connection_closed=ri.connection_closed) - () = - { - url_string; - meth; - protocol; - ssl; - full_path_string; - full_path; - original_full_path_string; - original_full_path; - sub_path; - sub_path_string; - get_params_string; - host; - port_from_host_field; - get_params; - initial_get_params; - post_params; - files; - remote_inet_addr; - remote_ip; - remote_ip_parsed; - remote_port; - forward_ip; - server_port; - user_agent; - cookies_string; - cookies; - ifmodifiedsince; - ifunmodifiedsince; - ifnonematch; - ifmatch; - content_type; - content_type_string; - content_length; - referer; - origin; - access_control_request_method; - access_control_request_headers; - accept; - accept_charset; - accept_encoding; - accept_language; - http_frame; - request_cache; - client; - range; - timeofday; - nb_tries; - connection_closed; - } - -let update_nb_tries ri value = ri.nb_tries <- value -let update_request_cache ri value = ri.request_cache <- value - -let range { range; _ } = range -let url_string { url_string; _ } = url_string -let protocol { protocol; _ } = protocol -let http_frame { http_frame; _ } = http_frame -let meth { meth; _ } = meth -let ifmatch { ifmatch; _ } = ifmatch -let ifunmodifiedsince { ifunmodifiedsince; _ } = ifunmodifiedsince -let ifnonematch { ifnonematch; _ } = ifnonematch -let ifmodifiedsince { ifmodifiedsince; _ } = ifmodifiedsince -let remote_ip { remote_ip; _ } = remote_ip -let user_agent { user_agent; } = user_agent -let host { host; _ } = host -let ssl { ssl; _ } = ssl -let port_from_host_field { port_from_host_field; _ } = - port_from_host_field -let server_port { server_port; _ } = server_port -let full_path { full_path; _ } = full_path -let get_params_string { get_params_string; _ } = get_params_string -let client { client; _ } = client -let nb_tries { nb_tries; _ } = nb_tries -let sub_path { sub_path; _ } = sub_path -let content_length { content_length; _ } = content_length -let content_type_string { content_type_string; _ } = content_type_string -let remote_port { remote_port; _ } = remote_port -let sub_path_string { sub_path_string; _ } = sub_path_string -let full_path_string { full_path_string; _ } = full_path_string -let remote_inet_addr { remote_inet_addr; _ } = remote_inet_addr -let forward_ip { forward_ip; _ } = forward_ip -let remote_ip_parsed { remote_ip_parsed; _ } = remote_ip_parsed -let content_type { content_type; _ } = content_type -let origin { origin; _ } = origin -let access_control_request_method { access_control_request_method; _ } = - access_control_request_method -let access_control_request_headers { access_control_request_headers; _ } = - access_control_request_headers -let request_cache { request_cache; _ } = request_cache -let files { files; _ } = files -let original_full_path { original_full_path; _ } = original_full_path -let cookies { cookies; _ } = cookies -let post_params { post_params; _ } = post_params -let get_params { get_params; _ } = get_params -let initial_get_params { initial_get_params; _ } = initial_get_params -let original_full_path_string { original_full_path_string; _ } = - original_full_path_string -let timeofday { timeofday; _ } = timeofday -let accept_language { accept_language; _ } = accept_language -let accept_encoding { accept_encoding; _ } = accept_encoding -let accept { accept; _ } = accept -let connection_closed { connection_closed; _ } = connection_closed diff --git a/src/server/ocsigen_request_info.mli b/src/server/ocsigen_request_info.mli deleted file mode 100644 index 402f7da99..000000000 --- a/src/server/ocsigen_request_info.mli +++ /dev/null @@ -1,274 +0,0 @@ -open Ocsigen_cookies - -type ifrange = IR_No | IR_Ifunmodsince of float | IR_ifmatch of string - -type file_info = { - tmp_filename: string; - filesize: int64; - raw_original_filename: string; - original_basename: string ; - file_content_type: ((string * string) * (string * string) list) option; -} - -type request_info - -(** Parsing URLs. - This allows to modify the URL in the request_info. - (to be used for example with Ext_retry_with or Ext_continue_with) - *) -val ri_of_url : ?full_rewrite:bool -> string -> request_info -> request_info - -(** Make a request_info *) -val make : - url_string:string -> - meth:Ocsigen_http_frame.Http_header.http_method -> - protocol:Ocsigen_http_frame.Http_header.proto -> - ?ssl:bool -> - full_path_string:string -> - full_path:Ocsigen_lib.Url.path -> - ?original_full_path_string:string -> - ?original_full_path:Ocsigen_lib.Url.path -> - ?sub_path:Ocsigen_lib.Url.path -> - ?sub_path_string:Ocsigen_lib.Url.uri -> - get_params_string:string option -> - host:string option -> - port_from_host_field:int option -> - get_params:(string * string) list Lazy.t -> - ?initial_get_params:(string * string) list Lazy.t -> - post_params:(string option * Int64.t option -> - (string * string) list Lwt.t) - option -> - files:(string option * Int64.t option -> - (string * file_info) list Lwt.t) - option -> - remote_inet_addr:Unix.inet_addr -> - remote_ip:string -> - ?remote_ip_parsed:Ipaddr.t Lazy.t -> - remote_port:int -> - ?forward_ip:string list -> - server_port:int -> - user_agent:string -> - cookies_string:string option Lazy.t -> - cookies:string Ocsigen_cookies.CookiesTable.t Lazy.t -> - ifmodifiedsince:float option -> - ifunmodifiedsince:float option -> - ifnonematch:string list option -> - ifmatch:string list option -> - content_type:((string * string) * (string * string) list) - option -> - content_type_string:string option -> - content_length:int64 option -> - referer:string option Lazy.t -> - origin:string option Lazy.t -> - access_control_request_method:string option Lazy.t -> - access_control_request_headers:string list option Lazy.t -> - accept:Http_headers.accept Lazy.t -> - accept_charset:(string option * float option) list Lazy.t -> - accept_encoding:(string option * float option) list Lazy.t -> - accept_language:(string * float option) list Lazy.t -> - http_frame:Ocsigen_http_frame.t -> - ?request_cache:Polytables.t -> - client:Ocsigen_http_com.connection -> - range:((int64 * int64) list * int64 option * ifrange) option - Lazy.t -> - ?timeofday:float -> - ?nb_tries:int -> - ?connection_closed:unit Lwt.t -> unit -> request_info - -val update : - request_info -> - ?url_string:string -> - ?meth:Ocsigen_http_frame.Http_header.http_method -> - ?protocol:Ocsigen_http_frame.Http_header.proto -> - ?ssl:bool -> - ?full_path_string:string -> - ?full_path:string list -> - ?original_full_path_string:string -> - ?original_full_path:string list -> - ?sub_path:string list -> - ?sub_path_string:string -> - ?get_params_string:string option -> - ?host:string option -> - ?port_from_host_field:int option -> - ?get_params:(string * string) list Lazy.t -> - ?initial_get_params:(string * string) list Lazy.t -> - ?post_params:(string option * Int64.t option -> - (string * string) list Lwt.t) - option -> - ?files:(string option * Int64.t option -> - (string * file_info) list Lwt.t) - option -> - ?remote_inet_addr:Unix.inet_addr -> - ?remote_ip:string -> - ?remote_ip_parsed:Ipaddr.t Lazy.t -> - ?remote_port:int -> - ?forward_ip:string list -> - ?server_port:int -> - ?user_agent:string -> - ?cookies_string:string option Lazy.t -> - ?cookies:string Ocsigen_cookies.CookiesTable.t Lazy.t -> - ?ifmodifiedsince:float option -> - ?ifunmodifiedsince:float option -> - ?ifnonematch:string list option -> - ?ifmatch:string list option -> - ?content_type:((string * string) * (string * string) list) - option -> - ?content_type_string:string option -> - ?content_length:int64 option -> - ?referer:string option Lazy.t -> - ?origin:string option Lazy.t -> - ?access_control_request_method:string option Lazy.t -> - ?access_control_request_headers:string list option Lazy.t -> - ?accept:Http_headers.accept Lazy.t -> - ?accept_charset:(string option * float option) list Lazy.t -> - ?accept_encoding:(string option * float option) list Lazy.t -> - ?accept_language:(string * float option) list Lazy.t -> - ?http_frame:Ocsigen_http_frame.t -> - ?request_cache:Polytables.t -> - ?client:Ocsigen_http_com.connection -> - ?range:((int64 * int64) list * int64 option * ifrange) option - Lazy.t -> - ?timeofday:float -> - ?nb_tries:int -> - ?connection_closed:unit Lwt.t -> unit -> request_info - -(** Update [nb_tries] slot of [request_info] *) -val update_nb_tries : request_info -> int -> unit - -(** Update cache of [request_info] *) -val update_request_cache : request_info -> Polytables.t -> unit - -(** Accessor for range of request_info *) -val range : request_info -> ((int64 * int64) list * int64 option * ifrange) option Lazy.t - -(** Accessor for url of request_info *) -val url_string : request_info -> string - -(** Accessor for protocol of request_info *) -val protocol : request_info -> Ocsigen_http_frame.Http_header.proto - -(** Accessor for http_frame of request_info *) -val http_frame : request_info -> Ocsigen_http_frame.t - -(** Accessor for method of request_info *) -val meth : request_info -> Ocsigen_http_frame.Http_header.http_method - -(** Accessor for ifmatch of request_info *) -val ifmatch : request_info -> string list option - -(** Accessor for ifunmodifiedsince of request_info *) -val ifunmodifiedsince : request_info -> float option - -(** Accessor for ifnonematch of request_info *) -val ifnonematch : request_info -> string list option - -(** Accessor for ifmodifiedsince of request_info *) -val ifmodifiedsince : request_info -> float option - -(** Accessor for remote_ip of request_info *) -val remote_ip : request_info -> string - -(** Accessor for user_agent of request_info *) -val user_agent : request_info -> string - -(** Accessor for host of request_info *) -val host : request_info -> string option - -(** Accessor for ssl of request_info *) -val ssl : request_info -> bool - -(** Accessor for port_from_host_field of request_info *) -val port_from_host_field : request_info -> int option - -(** Accessor for server_port of request_info *) -val server_port : request_info -> int - -(** Accessor for full_path of request_info *) -val full_path : request_info -> string list - -(** Accessor for get_params_string of request_info *) -val get_params_string : request_info -> string option - -(** Accessor for client of request_info *) -val client : request_info -> Ocsigen_http_com.connection - -(** Accessor for nb_tries of request_info *) -val nb_tries : request_info -> int - -(** Accessor for sub_path of request_info *) -val sub_path : request_info -> string list - -(** Accessor for content_length of request_info *) -val content_length : request_info -> int64 option - -(** Accessor for content_type_string of request_info *) -val content_type_string : request_info -> string option - -(** Accessor for remote_port of request_info *) -val remote_port : request_info -> int - -(** Accessor for sub_path_string of request_info *) -val sub_path_string : request_info -> string - -(** Accessor for full_path_string of request_info *) -val full_path_string : request_info -> string - -(** Accessor for remote_inet_addr of request_info *) -val remote_inet_addr : request_info -> Unix.inet_addr - -(** Accessor for forward_ip of request_info *) -val forward_ip : request_info -> string list - -(** Accessor for remote_ip_parsed of request_info *) -val remote_ip_parsed : request_info -> Ipaddr.t Lazy.t - -(** Accessor for content_type of request_info *) -val content_type : request_info -> ((string * string) * (string * string) list) option - -(** Accessor for origin of request_info *) -val origin : request_info -> string option Lazy.t - -(** Accessor for access_control_request_method of request_info *) -val access_control_request_method : request_info -> string option Lazy.t - -(** Accessor for access_control_request_headers of request_info *) -val access_control_request_headers : request_info -> string list option Lazy.t - -(** Accessor for request_cache of request_info *) -val request_cache : request_info -> Polytables.t - -(** Accessor for files of request_info *) -val files : request_info -> ((string option * Int64.t option) -> (string * file_info) list Lwt.t) option - -(** Accessor for original_full_path of request_info *) -val original_full_path : request_info -> string list - -(** Accessor for cookies of request_info *) -val cookies : request_info -> string CookiesTable.t Lazy.t - -(** Accessor for post_params of request_info *) -val post_params : request_info -> ((string option * Int64.t option) -> (string * string) list Lwt.t) option - -(** Accessor for get_params of request_info *) -val get_params : request_info -> (string * string) list Lazy.t - -(** Accessor for initial_get_params of request_info *) -val initial_get_params : request_info -> (string * string) list Lazy.t - -(** Accessor for original_full_path_string of request_info *) -val original_full_path_string : request_info -> string - -(** Accessor for timeofday of request_info *) -val timeofday : request_info -> float - -(** Accessor for accept_language of request_info *) -val accept_language : request_info -> (string * float option) list Lazy.t - -(** Accessor for accept_encoding of request_info *) -val accept_encoding : request_info -> (string option * float option) list Lazy.t - -(** Accessor for accept of request_info *) -val accept : request_info -> Http_headers.accept Lazy.t - -(** Accessor for connection_closed of request_info *) -val connection_closed : request_info -> unit Lwt.t diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index f1f4aa3d6..1e589e9c5 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -19,23 +19,16 @@ *) open Lwt +open Ocsigen_messages open Ocsigen_socket open Ocsigen_lib open Ocsigen_extensions open Ocsigen_http_frame open Ocsigen_headers -open Ocsigen_http_com -open Ocsigen_senders open Ocsigen_config open Ocsigen_parseconfig open Ocsigen_cookies - -exception Ocsigen_unsupported_media -exception Ssl_Exception -exception Ocsigen_upload_forbidden -exception Socket_closed - -let shutdown = ref false +open Lazy let () = Random.self_init () @@ -55,32 +48,6 @@ let _ = (fun e -> Lwt_log.ign_error ~section ~exn:e "Uncaught Exception after lwt \ timeout") -let sslctx = Ocsigen_http_client.sslcontext - - -let ip_of_sockaddr = function - | Unix.ADDR_INET (ip, port) -> ip - | _ -> raise (Ocsigen_Internal_Error "ip of unix socket") - -let port_of_sockaddr = function - | Unix.ADDR_INET (ip, port) -> port - | _ -> raise (Ocsigen_Internal_Error "port of unix socket") - - -let get_boundary ctparams = List.assoc "boundary" ctparams - -let find_field field content_disp = - let (_, res) = Netstring_pcre.search_forward - (Netstring_pcre.regexp (field^"=.([^\"]*).;?")) content_disp 0 in - Netstring_pcre.matched_group res 1 content_disp - -type to_write = - No_File of string * Buffer.t - | A_File of (string * string * string * Unix.file_descr - * ((string * string) * (string * string) list) option) - -let counter = let c = ref (Random.int 1000000) in fun () -> c := !c + 1 ; !c - let warn sockaddr s = Lwt_log.ign_warning_f ~section "While talking to %a:%s" (fun () sockaddr -> @@ -91,929 +58,10 @@ let dbg sockaddr s = Unix.string_of_inet_addr (ip_of_sockaddr sockaddr)) sockaddr s - let http_url_syntax = Hashtbl.find Neturl.common_url_syntax "http" -let rec find_post_params http_frame ct filenames = - match http_frame.Ocsigen_http_frame.frame_content with - | None -> None - | Some body_gen -> - let ((ct, cst), ctparams) = match ct with - (* RFC 2616, sect. 7.2.1 *) - (* If the media type remains unknown, the recipient SHOULD - treat it as type "application/octet-stream". *) - | None -> (("application", "octet-stream"), []) - | Some (c, p) -> (c, p) - in - match String.lowercase ct, String.lowercase cst with - | "application", "x-www-form-urlencoded" -> - Some (find_post_params_form_urlencoded body_gen) - | "multipart", "form-data" -> - Some (find_post_params_multipart_form_data - body_gen ctparams filenames) - | _ -> None - -and find_post_params_form_urlencoded body_gen _ = - catch - (fun () -> - let body = Ocsigen_stream.get body_gen in - (* BY, adapted from a previous comment. Should this stream be - consumed in case of error? *) - Ocsigen_stream.string_of_stream - (Ocsigen_config.get_maxrequestbodysizeinmemory ()) - body >>= fun r -> - let r = Url.fixup_url_string r in - Lwt.return ((Netencoding.Url.dest_url_encoded_parameters r), []) - ) - (function - | Ocsigen_stream.String_too_large -> fail Input_is_too_large - | e -> fail e) - -and find_post_params_multipart_form_data body_gen ctparams filenames - (uploaddir, maxuploadfilesize) = - (* Same question here, should this stream be consumed after an error ? *) - let body = Ocsigen_stream.get body_gen - and bound = get_boundary ctparams - and params = ref [] - and files = ref [] in - let create hs = - let content_type = - try - let ct = List.assoc "content-type" hs in - Ocsigen_headers.parse_content_type (Some ct) - with _ -> None - in - let cd = List.assoc "content-disposition" hs in - let p_name = find_field "name" cd in - try - let store = find_field "filename" cd in - match uploaddir with - | Some dname -> - let now = Printf.sprintf "%f-%d" - (Unix.gettimeofday ()) (counter ()) in - let fname = dname^"/"^now in - let fd = Unix.openfile fname - [Unix.O_CREAT; Unix.O_TRUNC; Unix.O_WRONLY; Unix.O_NONBLOCK] 0o666 - in - Lwt_log.ign_info_f ~section "Upload file opened: %s" fname; - filenames := fname::!filenames; - A_File (p_name, fname, store, fd, content_type) - | None -> raise Ocsigen_upload_forbidden - with Not_found -> No_File (p_name, Buffer.create 1024) - in - let rec add where s = - match where with - | No_File (p_name, to_buf) -> - Buffer.add_string to_buf s; - return () - | A_File (_,_,_,wh,_) -> - let len = String.length s in - let r = Unix.write wh s 0 len in - if r < len then - (*XXXX Inefficient if s is long *) - add where (String.sub s r (len - r)) - else - Lwt_unix.yield () - in - let stop size = function - | No_File (p_name, to_buf) -> - return - (params := !params @ [(p_name, Buffer.contents to_buf)]) - (* a la fin ? *) - | A_File (p_name,fname,oname,wh, content_type) -> - files := - !files@[(p_name, {tmp_filename=fname; - filesize=size; - raw_original_filename=oname; - original_basename=(Filename.basename oname); - file_content_type = content_type; - })]; - Unix.close wh; - return () - in - Multipart.scan_multipart_body_from_stream - body bound create add stop maxuploadfilesize >>= fun () -> - (*VVV Does scan_multipart_body_from_stream read until the end or - only what it needs? If we do not consume here, the following - request will be read only when this one is finished ... *) - Ocsigen_stream.consume body_gen >>= fun () -> - Lwt.return (!params, !files) - -let wrap_stream f x frame_content = - Ocsigen_stream.make ~finalize:(fun outcome -> - match frame_content with - | Some stream -> - Ocsigen_stream.finalize stream outcome - | None -> - Lwt.return () - ) - (fun () -> - f x >>= fun () -> - match frame_content with - | Some stream -> - Ocsigen_stream.next (Ocsigen_stream.get stream) - | None -> - Ocsigen_stream.empty None - ) - -let handle_100_continue slot frame = - { frame with - frame_content = Some (wrap_stream send_100_continue slot - frame.frame_content) - } - -let handle_expect slot frame = - let expect_list = Ocsigen_headers.get_expect frame in - let proto = Http_header.get_proto frame.frame_header in - List.fold_left (fun frame tok -> - match String.lowercase tok with - | "100-continue" -> - if proto = Http_header.HTTP11 then - handle_100_continue slot frame - else - frame - | _ -> - raise (Ocsigen_http_error (Ocsigen_cookies.empty_cookieset, 417)) - ) frame expect_list - -(* reading the request *) -let get_request_infos - meth clientproto url http_frame filenames sockaddr port receiver - sender_slot = - - Lwt.catch - (fun () -> - - let (_, headerhost, headerport, url, path, params, get_params) = - Url.parse url - in - - let headerhost, headerport = - match headerhost with - | None -> get_host_from_host_header http_frame - | _ -> headerhost, headerport - in - - (* RFC: - 1. If Request-URI is an absoluteURI, the host is part of the Request-URI. - Any Host header field value in the request MUST be ignored. - 2. If the Request-URI is not an absoluteURI, and the request includes a - Host header field, the host is determined by the Host header field value. - 3. If the host as determined by rule 1 or 2 is not a valid host on the - server, the response MUST be a 400 (Bad Request) error message. - *) - (* Here we don't trust the port information given by the request. - We use the port we are listening on. *) - Lwt_log.ign_info_f ~section "host=%s" - (match headerhost with None -> "" | Some h -> h); - - (* Servers MUST report a 400 (Bad Request) error if an HTTP/1.1 - request does not include a Host request-header. *) - - if clientproto = Ocsigen_http_frame.Http_header.HTTP11 - && headerhost = None - then raise Ocsigen_Bad_Request; - - let useragent = get_user_agent http_frame in - - let cookies_string = lazy (get_cookie_string http_frame) in - - let cookies = - lazy (match (Lazy.force cookies_string) with - | None -> CookiesTable.empty - | Some s -> parse_cookies s) - in - - let ifmodifiedsince = get_if_modified_since http_frame in - - let ifunmodifiedsince = get_if_unmodified_since http_frame in - - let ifnonematch = get_if_none_match http_frame in - - let ifmatch = get_if_match http_frame in - - let client_inet_addr = ip_of_sockaddr sockaddr in - - let ct_string = get_content_type http_frame in - - let ct = Ocsigen_headers.parse_content_type ct_string in - - let cl = get_content_length http_frame in - - let referer = lazy (get_referer http_frame) in - - let origin = lazy (get_origin http_frame) in - - let access_control_request_method = - lazy (get_access_control_request_method http_frame) in - - let access_control_request_headers = - lazy (get_access_control_request_headers http_frame) in - - let accept = lazy (get_accept http_frame) in - - let accept_charset = lazy (get_accept_charset http_frame) in - - let accept_encoding = lazy (get_accept_encoding http_frame) in - - let accept_language = lazy (get_accept_language http_frame) in - - let post_params0 = - match meth with - | Http_header.GET - | Http_header.DELETE - | Http_header.PUT - | Http_header.HEAD -> None - | Http_header.POST - | Http_header.OPTIONS -> - begin - match find_post_params http_frame ct filenames with - | None -> None - | Some f -> - let r = ref None in - Some (fun ci -> - match !r with - | None -> let res = f ci in - r := Some res; - res - | Some r -> r) - end - | _ -> failwith "get_request_infos: HTTP method not implemented" - in - let post_params = - match post_params0 with - | None -> None - | Some f -> Some (fun ci -> f ci >>= fun (a, _) -> Lwt.return a) - in - let files = - match post_params0 with - | None -> None - | Some f -> Some (fun ci -> f ci >>= fun (_, b) -> Lwt.return b) - in - - let ipstring = Unix.string_of_inet_addr client_inet_addr in - let path_string = Url.string_of_url_path ~encode:true path in - - Lwt.return - (Ocsigen_request_info.make - ~url_string:url - ~meth:meth - ~protocol:http_frame.Ocsigen_http_frame - .frame_header.Ocsigen_http_frame.Http_header - .proto - ~ssl:(Lwt_ssl.is_ssl (Ocsigen_http_com.connection_fd receiver)) - ~full_path_string:path_string - ~full_path:path - ~original_full_path_string:path_string - ~original_full_path:path - ~sub_path:path - ~sub_path_string:(Url.string_of_url_path ~encode:true path) - ~get_params_string:params - ~host:headerhost - ~port_from_host_field:headerport - ~get_params:get_params - ~initial_get_params:get_params - ~post_params:post_params - ~files:files - ~remote_inet_addr:client_inet_addr - ~remote_ip:ipstring - ~remote_ip_parsed:(lazy (Ipaddr.of_string_exn ipstring)) - ~remote_port:(port_of_sockaddr sockaddr) - ~forward_ip:[] - ~server_port:port - ~user_agent:useragent - ~cookies_string:cookies_string - ~cookies:cookies - ~ifmodifiedsince:ifmodifiedsince - ~ifunmodifiedsince:ifunmodifiedsince - ~ifnonematch:ifnonematch - ~ifmatch:ifmatch - ~content_type:ct - ~content_type_string:ct_string - ~content_length:cl - ~referer:referer - ~origin:origin - ~access_control_request_method:access_control_request_method - ~access_control_request_headers:access_control_request_headers - ~accept:accept - ~accept_charset:accept_charset - ~accept_encoding:accept_encoding - ~accept_language:accept_language - ~http_frame:(handle_expect sender_slot http_frame) - ~request_cache:(Polytables.create () ) - ~client:(Ocsigen_extensions.client_of_connection receiver) - ~range:(lazy (Ocsigen_range.get_range http_frame)) - ~timeofday:(Unix.gettimeofday ()) - ~nb_tries:0 - ~connection_closed:(Ocsigen_http_com.closed receiver) ()) - ) - (fun e -> - Lwt_log.ign_info ~section ~exn:e "Exn during get_request_infos"; - Lwt.fail e) - - -(* An http result [res] frame has been computed. Depending on - the If-(None-)?Match and If-(Un)?Modified-Since headers of [ri], - we return this frame, a 304: Not-Modified, or a 412: Precondition Failed. - See RFC 2616, sections 14.24, 14.25, 14.26, 14.28 and 13.3.4 -*) -let handle_result_frame ri res send = - (* Subfonctions to handle each header separately *) - let if_unmodified_since unmodified_since = (* Section 14.28 *) - if (Result.code res = 412 || - (200 <= Result.code res && Result.code res < 300)) then - match Result.lastmodified res with - | Some r -> - if r <= unmodified_since then - `Ignore_header - else - `Precondition_failed - | None -> `Ignore_header - else - `Ignore_header - - and if_modified_since modified_since = (* Section 14.25 *) - if Result.code res = 200 then - match Result.lastmodified res with - | Some r -> - if r <= modified_since then - `Unmodified - else - `Ignore_header - | _ -> `Ignore_header - else - `Ignore_header - - and if_none_match if_none_match = (* Section 14.26 *) - if (Result.code res = 412 || - (200 <= Result.code res && Result.code res < 300)) then - match Result.etag res with - | None -> `Ignore_header - | Some e -> - if List.mem e if_none_match then - if (Ocsigen_request_info.meth ri) = Http_header.GET || - (Ocsigen_request_info.meth ri) = Http_header.HEAD then - `Unmodified - else - `Precondition_failed - else - `Ignore_header_and_ModifiedSince - else - `Ignore_header - - and if_match if_match = (* Section 14.24 *) - if (Result.code res = 412 || - (200 <= Result.code res && Result.code res < 300)) then - match Result.etag res with - | None -> `Precondition_failed - | Some e -> - if List.mem e if_match then - `Ignore_header - else - `Precondition_failed - else - `Ignore_header - - in - - let handle_header f h = match h with - | None -> `No_header - | Some h -> f h - in - - (* Main code *) - let r = - (* For the cases unspecified with RFC2616. we follow more or less - the order used by Apache. See the function - modules/http/http_protocol.c/ap_meets_conditions in the Apache - source *) - match handle_header if_match (Ocsigen_request_info.ifmatch ri) with - | `Precondition_failed -> `Precondition_failed - | `No_header | `Ignore_header -> - match handle_header if_unmodified_since - (Ocsigen_request_info.ifunmodifiedsince ri) with - | `Precondition_failed -> `Precondition_failed - | `No_header | `Ignore_header -> - match handle_header if_none_match - (Ocsigen_request_info.ifnonematch ri) with - | `Precondition_failed -> `Precondition_failed - | `Ignore_header_and_ModifiedSince -> `Std - | `Unmodified | `No_header as r1 -> - (match handle_header if_modified_since - (Ocsigen_request_info.ifmodifiedsince ri) with - | `Unmodified | `No_header as r2 -> - if r1 = `No_header && r2 = `No_header then - `Std - else - `Unmodified - | `Ignore_header -> `Std) - | `Ignore_header -> - (* We cannot return a 304, so there is no need to consult - if_modified_since *) - `Std - in - match r with - | `Unmodified -> - Lwt_log.ign_info ~section "Sending 304 Not modified"; - Ocsigen_stream.finalize (fst (Result.stream res)) `Success >>= fun () -> - let headers = - let keep h headers = - try - Http_headers.add h (Http_headers.find h (Result.headers res)) headers - with Not_found -> - headers - in - Http_headers.(keep cache_control (keep expires empty)) - in - send (Result.update (Ocsigen_http_frame.Result.empty ()) - ~code:304 (* Not modified *) - ~lastmodified:(Result.lastmodified res) - ~etag:(Result.etag res) - ~headers ()) - - | `Precondition_failed -> - Lwt_log.ign_info ~section - "Sending 412 Precondition Failed (conditional headers)"; - Ocsigen_stream.finalize (fst (Result.stream res)) `Success >>= fun () -> - send (Result.update (Ocsigen_http_frame.Result.empty ()) - ~code:412 (* Precondition failed *) ()) - - | `Std -> - Ocsigen_range.compute_range ri res - >>= send - -let service receiver sender_slot request meth url port sockaddr = - (* sender_slot is here for pipelining: - we must wait before sending the page, - because the previous one may not be sent *) - - let head = meth = Http_header.HEAD in - let clientproto = - Http_header.get_proto request.Ocsigen_http_frame.frame_header in - - let handle_service_errors e = - (* Exceptions during page generation *) - Lwt_log.ign_info ~section ~exn:e "Exception during generation/sending"; - let send_error ?cookies code = - Ocsigen_senders.send_error ~exn:e sender_slot ~clientproto ?cookies ~head - ~code ~sender:Ocsigen_http_com.default_sender () - in - match e with - (* EXCEPTIONS WHILE COMPUTING A PAGE *) - | Ocsigen_http_error (cookies_to_set, i) -> - Lwt_log.ign_info_f ~section - "Sending HTTP error %d %s" - i - (Ocsigen_http_frame.Http_error.expl_of_code i); - send_error ~cookies:cookies_to_set i - | Ocsigen_stream.Interrupted Ocsigen_stream.Already_read -> - Lwt_log.ign_warning ~section - "Cannot read the request twice. You probably have \ - two incompatible options in configuration, \ - or the order of the options in the config file is wrong."; - send_error 500 (* Internal error *) - | Unix.Unix_error (Unix.EACCES,_,_) - | Ocsigen_upload_forbidden -> - Lwt_log.ign_info ~section "Sending 403 Forbidden"; - send_error 403 - | Http_error.Http_exception (code,_,_) -> - Ocsigen_http_frame.Http_error.display_http_exception e; - send_error code - | Ocsigen_Bad_Request -> - Lwt_log.ign_info ~section "Sending 400"; - send_error 400 - | Ocsigen_unsupported_media -> - Lwt_log.ign_info ~section "Sending 415"; - send_error 415 - | Neturl.Malformed_URL -> - Lwt_log.ign_info ~section "Sending 400 (Malformed URL)"; - send_error 400 - | Ocsigen_Request_too_long -> - Lwt_log.ign_info ~section "Sending 413 (Entity too large)"; - send_error 413 - | e -> - Lwt_log.ign_warning_f ~section ~exn:e - "Exn during page generation (sending 500)"; - send_error 500 - in - let finish_request () = - (* We asynchronously finish to read the request contents if this - is not done yet so that: - - we can handle the next request - - there is no dead-lock with the client writing the request and - the server writing the response. - We need to do this once the request has been handled before sending - any reply to the client. *) - match request.Ocsigen_http_frame.frame_content with - | Some f -> - ignore - (Lwt.catch - (fun () -> - Ocsigen_stream.finalize f `Success - (* will consume the stream and unlock the mutex - if not already done *) - ) - (function - | e -> - - (match e with - | Ocsigen_http_com.Lost_connection _ -> - warn sockaddr "connection abruptly closed by peer \ - while reading contents" - | Ocsigen_http_com.Timeout -> - warn sockaddr "timeout while reading contents" - | Ocsigen_http_com.Aborted -> - dbg sockaddr "reading thread aborted" - | Http_error.Http_exception (code, mesg, _) -> - warn sockaddr (Http_error.string_of_http_exception e) - | _ -> - Ocsigen_messages.unexpected_exception - e "Server.finish_request" - ); - Ocsigen_http_com.abort receiver; - (* We unlock the receiver in order to resume the - reading loop. As the connection has been aborted, - the next read will fail and the connection will be - closed properly. *) - Ocsigen_http_com.unlock_receiver receiver; - Lwt.return ())) - | None -> - () - in - - (* body of service *) - if meth <> Http_header.GET && - meth <> Http_header.POST && - meth <> Http_header.HEAD && - meth <> Http_header.OPTIONS && - meth <> Http_header.DELETE && - meth <> Http_header.PUT - then begin - (* VVV Warning: This must be done once and only once. - Put this somewhere else to ensure that? - *) - warn sockaddr ("Bad request: \""^url^"\""); - Ocsigen_http_com.wakeup_next_request receiver; - finish_request (); - (* RFC 2616, sect 5.1.1 *) - send_error - sender_slot ~clientproto ~head ~code:501 - ~sender:Ocsigen_http_com.default_sender () - end else begin - let filenames = ref [] (* All the files sent by the request *) in - - Lwt.finalize (fun () -> - (* *** First of all, we read the whole the request - (that will possibly create files) *) - Lwt.try_bind - (fun () -> - get_request_infos - meth clientproto url request filenames sockaddr - port receiver sender_slot) - (fun ri -> - (* *** Now we generate the page and send it *) - (* Log *) - Ocsigen_messages.accesslog - (try - let x_forwarded_for = Http_headers.find - Http_headers.x_forwarded_for - (Ocsigen_request_info.http_frame ri) - .frame_header.Http_header.headers in - Format.sprintf - "connection for %s from %s (%s) with X-Forwarded-For: \ - %s: %s" - (match Ocsigen_request_info.host ri with - | None -> "" - | Some h -> h) - (Ocsigen_request_info.remote_ip ri) - (Ocsigen_request_info.user_agent ri) - x_forwarded_for - (Ocsigen_request_info.url_string ri) - with - | Not_found -> - Format.sprintf - "connection for %s from %s (%s): %s" - (match Ocsigen_request_info.host ri with - | None -> "" - | Some h -> h) - (Ocsigen_request_info.remote_ip ri) - (Ocsigen_request_info.user_agent ri) - (Ocsigen_request_info.url_string ri)); - let send_aux = - send sender_slot ~clientproto ~head - ~sender:Ocsigen_http_com.default_sender - in - - (* Generation of pages is delegated to extensions: *) - Lwt.try_bind - (fun () -> Ocsigen_extensions.compute_result - ~awake_next_request:true ri) - (fun res -> - finish_request (); - handle_result_frame ri res send_aux - ) - (fun e -> - finish_request (); - match e with - | Ocsigen_extensions.Ocsigen_Is_a_directory fun_request -> - (* User requested a directory. We redirect it to - the correct url (with a slash), so that relative - urls become correct *) - let new_url = fun_request ri in - send_aux - (Result.update (Ocsigen_http_frame.Result.empty ()) - ~code:301 - ~location:(Some (Neturl.string_of_url new_url)) ()) - | _ -> handle_service_errors e - ) - ) - (fun e -> - warn sockaddr ("Bad request: \""^url^"\""); - Ocsigen_http_com.wakeup_next_request receiver; - finish_request (); - handle_service_errors e - )) - (fun () -> - (* We remove all the files created by the request - (files sent by the client) *) - if !filenames <> [] then Lwt_log.ign_info ~section "** Removing files"; - List.iter - (fun a -> - try Unix.unlink a - with Unix.Unix_error _ as e -> - Lwt_log.ign_warning_f ~section ~exn:e "Error while removing \ - file %s" a ) - !filenames; - return ()) - end - -let linger in_ch receiver = - Lwt.catch - (fun () -> - (* We wait for 30 seconds at most and close the connection - after 2 seconds without receiving data from the client *) - let abort_fun () = Lwt_ssl.abort in_ch Exit in - let long_timeout = Lwt_timeout.create 30 abort_fun in - let short_timeout = Lwt_timeout.create 2 abort_fun in - Lwt_timeout.start long_timeout; - let s = String.create 1024 in - - let rec linger_aux () = - Lwt_ssl.wait_read in_ch >>= fun () -> - Lwt.try_bind - (fun () -> - Lwt_timeout.start short_timeout; - Lwt_ssl.read in_ch s 0 1024) - (fun len -> - if len > 0 then linger_aux () else Lwt.return ()) - (fun e -> - begin match e with - Unix.Unix_error(Unix.ECONNRESET,_,_) - | Ssl.Read_error (Ssl.Error_syscall | Ssl.Error_ssl) - | Exit -> - Lwt.return () - | _ -> - Lwt.fail e - end) - in - (* We start the lingering reads before waiting for the - senders to terminate in order to avoid a deadlock *) - let linger_thread = linger_aux () in - Ocsigen_http_com.wait_all_senders receiver >>= fun () -> - Lwt_log.ign_info ~section "** SHUTDOWN"; - Lwt_ssl.ssl_shutdown in_ch >>= fun () -> - Lwt_ssl.shutdown in_ch Unix.SHUTDOWN_SEND; - linger_thread >>= fun () -> - Lwt_timeout.stop long_timeout; - Lwt_timeout.stop short_timeout; - Lwt.return ()) - (fun e -> - Ocsigen_messages.unexpected_exception e "Server.linger"; Lwt.return ()) - let try_bind' f g h = Lwt.try_bind f h g -let add_to_receivers_waiting_for_pipeline, - remove_from_receivers_waiting_for_pipeline, - iter_receivers_waiting_for_pipeline = - let l = Clist.create () in - ((fun r -> - let node = Clist.make r in - Clist.insert l node; - node), - Clist.remove, - (fun f -> - Clist.fold_left - (fun t v -> - (*VVV reread this. Is yield here ok? *) - t >>= Lwt_unix.yield >>= fun () -> - f v) - (Lwt.return ()) - l)) - -let handle_connection port in_ch sockaddr = - let receiver = Ocsigen_http_com.create_receiver - (Ocsigen_config.get_client_timeout ()) Query in_ch - in - - let handle_write_errors e = - begin match e with - | Lost_connection e' -> - warn sockaddr ("connection abruptly closed by peer (" - ^ Printexc.to_string e' ^ ")") - | Ocsigen_http_com.Timeout -> - warn sockaddr "timeout" - | Ocsigen_http_com.Aborted -> - dbg sockaddr "writing thread aborted" - | Ocsigen_stream.Interrupted e' -> - warn sockaddr ("interrupted content stream (" - ^ Printexc.to_string e' ^ ")") - | _ -> - Ocsigen_messages.unexpected_exception e "Server.handle_write_errors" - end; - Ocsigen_http_com.abort receiver; - Lwt.fail Ocsigen_http_com.Aborted - in - - let handle_read_errors e = - begin match e with - | Ocsigen_http_com.Connection_closed -> - (* This is the clean way to terminate the connection *) - dbg sockaddr "connection closed by peer"; - Ocsigen_http_com.abort receiver; - Ocsigen_http_com.wait_all_senders receiver - | Ocsigen_http_com.Keepalive_timeout -> - dbg sockaddr "keepalive timeout"; - Ocsigen_http_com.abort receiver; - Ocsigen_http_com.wait_all_senders receiver - | Ocsigen_http_com.Lost_connection _ -> - warn sockaddr "connection abruptly closed by peer"; - Ocsigen_http_com.abort receiver; - Ocsigen_http_com.wait_all_senders receiver - | Ocsigen_http_com.Timeout -> - warn sockaddr "timeout"; - Ocsigen_http_com.abort receiver; - Ocsigen_http_com.wait_all_senders receiver - | Ocsigen_http_com.Aborted -> - dbg sockaddr "reading thread aborted"; - Ocsigen_http_com.wait_all_senders receiver - | Http_error.Http_exception (code, mes, _) -> - warn sockaddr (Http_error.string_of_http_exception e); - Ocsigen_http_com.start_processing receiver (fun slot -> - (*XXX We should use the right information for clientproto - and head... *) - send_error slot - ~clientproto:Ocsigen_http_frame.Http_header.HTTP10 - ~head:false - (* ~keep_alive:false *) - ~exn:e - ~sender:Ocsigen_http_com.default_sender ()); - linger in_ch receiver - | _ -> - Ocsigen_messages.unexpected_exception e "Server.handle_read_errors"; - Ocsigen_http_com.abort receiver; - Ocsigen_http_com.wait_all_senders receiver - end - in - - let rec handle_request ?receiver_pos () = - try_bind' - (fun () -> - Lwt_log.ign_info ~section "** Receiving HTTP message"; - (if Ocsigen_config.get_respect_pipeline () then - (* if we lock this mutex, requests from a same connection will be sent - to extensions in the same order they are received on pipeline. - It is locked only in server. Ocsigen_http_client has its own mutex. - (*VVV use the same? *) - *) - Ocsigen_http_com.block_next_request receiver - else - Lwt.return ()) - >>= fun () -> - Ocsigen_http_com.get_http_frame receiver) - (fun exn -> - (* We remove the receiver from the set of requests - waiting for pipeline *) - (match receiver_pos with - | Some pos -> remove_from_receivers_waiting_for_pipeline pos - | None -> ()); - handle_read_errors exn) - (fun request -> - (* As above *) - (match receiver_pos with - | Some pos -> remove_from_receivers_waiting_for_pipeline pos - | None -> ()); - let meth, url = - match - Http_header.get_firstline request.Ocsigen_http_frame.frame_header - with - | Http_header.Query a -> a - | _ -> assert false - (*XXX Should be checked in [get_http_frame] *) - in - Ocsigen_http_com.start_processing receiver (fun slot -> - Lwt.catch - (fun () -> - (*XXX Why do we need the port but not the host name? *) - service receiver slot request meth url port sockaddr) - handle_write_errors); - if not !shutdown && - get_keepalive request.Ocsigen_http_frame.frame_header - then - (* We put the receiver in the set of receiver waiting for - pipeline in order to be able to shutdown the connections - if the server is shutting down. - *) - handle_request - ~receiver_pos:(add_to_receivers_waiting_for_pipeline receiver) () - else (* No keep-alive => no pipeline *) - (* We wait for the query to be entirely read and for - the reply to be sent *) - Ocsigen_http_com.lock_receiver receiver >>= fun () -> - Ocsigen_http_com.wait_all_senders receiver >>= fun () -> - Lwt_ssl.ssl_shutdown in_ch - ) - - in (* body of handle_connection *) - handle_request () - -let rec wait_connection use_ssl port socket = - let handle_exn e = - Lwt_unix.yield () >>= fun () -> match e with - | Socket_closed -> - Lwt_log.ign_info ~section "Socket closed"; - Lwt.return () - | Unix.Unix_error ((Unix.EMFILE | Unix.ENFILE), _, _) -> - (* this should not happen, report it *) - Lwt_log.ign_error ~section - "Max number of file descriptors reached unexpectedly, please check..."; - wait_connection use_ssl port socket - | e -> - Lwt_log.ign_info_f ~section ~exn:e "Accept failed"; - wait_connection use_ssl port socket - in - try_bind' - (fun () -> - (* if too much connections, - we wait for a signal before accepting again *) - let max = get_max_number_of_connections () in - (if get_number_of_connected () < max - then Lwt.return () - else begin - Lwt_log.ign_warning_f ~section - "Max simultaneous connections (%d) reached." - (get_max_number_of_connections ()); - wait_fewer_connected max - end) >>= fun () -> - (* We do several accept(), as explained in - "Accept()able strategies ..." by Tim Brecht & al. *) - Lwt_unix.accept_n socket 50) - handle_exn - (fun (l, e) -> - let number_of_accepts = List.length l in - Lwt_log.ign_info_f ~section "received %d accepts" number_of_accepts; - incr_connected number_of_accepts; - if e = None then ignore (wait_connection use_ssl port socket); - - let handle_one (s, sockaddr) = - Lwt_log.ign_info ~section - "** New CONNECTION"; - Lwt.catch - (fun () -> - Lwt_unix.set_close_on_exec s; - Lwt_unix.setsockopt s Unix.TCP_NODELAY true; - begin if use_ssl then - Lwt_ssl.ssl_accept s !sslctx - else - Lwt.return (Lwt_ssl.plain s) - end >>= fun in_ch -> - handle_connection port in_ch sockaddr) - (fun e -> - Ocsigen_messages.unexpected_exception e - "Server.wait_connection (handle connection)"; - (match e with - | Ssl.Accept_error(Ssl.Error_ssl|Ssl.Error_syscall) -> - Ocsigen_messages.warning - ("Last SSL error: " ^ Ssl.get_error_string ()) - | _ -> ()); - return ()) - >>= fun () -> - Lwt_log.ign_info ~section "** CLOSE"; - catch - (fun () -> Lwt_unix.close s) - (function Unix.Unix_error _ as e -> - Ocsigen_messages.unexpected_exception - e "Server.wait_connection (close)"; - Lwt.return () - | e -> Lwt.fail e) - >>= decr_connected - in - - Lwt_list.iter_p handle_one l >>= fun () -> - match e with - | Some e -> handle_exn e - | None -> Lwt.return ()) - - (* fatal errors messages *) let errmsg = function | Dynlink_wrapper.Error e -> @@ -1046,9 +94,6 @@ let errmsg = function (("Fatal - Uncaught exception: "^Printexc.to_string exn), 100) - - - (* loading new configuration *) let reload_conf s = try @@ -1065,7 +110,12 @@ let reload_conf s = let reload ?file () = (* That function cannot be interrupted??? *) - Lwt_log.ign_notice ~section "Reloading config file" ; + Lwt_log.ign_warning ~section "Reloading config file" ; + (try + match parse_config ?file () with + | [] -> () + | s::_ -> reload_conf s + with e -> errlog (fst (errmsg e))); (try match parse_config ?file () with @@ -1073,54 +123,23 @@ let reload ?file () = | s::_ -> reload_conf s with e -> Lwt_log.ign_error ~section (fst (errmsg e))); - Lwt_log.ign_notice ~section "Config file reloaded" - - -let shutdown_server s l = - try - let timeout = match l with - | [] -> Ocsigen_config.get_shutdown_timeout () - | ["notimeout"] -> None - | [t] -> - Some (float_of_string t) - | _ -> failwith "syntax error in command" - in - Lwt_log.ign_notice ~section "Shutting down"; - List.iter - (fun s -> Lwt_unix.abort s Socket_closed) !sockets; - List.iter - (fun s -> Lwt_unix.abort s Socket_closed) !sslsockets; - sockets := []; - sslsockets := []; - shutdown := true; - if Ocsigen_extensions.get_number_of_connected () <= 0 - then exit 0; - (match timeout with - | Some t -> ignore (Lwt_unix.sleep t >>= fun () -> exit 0) - | None -> ()); - ignore - (iter_receivers_waiting_for_pipeline - (fun receiver -> - (*VVV reread this - why are we using infinite iterators? *) - Ocsigen_http_com.wait_all_senders receiver >>= fun () -> - Ocsigen_http_com.abort receiver; - Lwt.return ())); - with Failure e -> - Lwt_log.ign_warning_f ~section "Wrong command: %s (%s)" s e - + Lwt_log.ign_warning ~section "Config file reloaded" let _ = let f s = function | ["reopen_logs"] -> Ocsigen_messages.open_files () >>= fun () -> - Lwt_log.ign_notice ~section "Log files reopened"; + Lwt_log.ign_warning ~section "Log files reopened"; Lwt.return () | ["reload"] -> reload (); Lwt.return () | ["reload"; file] -> reload ~file (); Lwt.return () - | "shutdown"::l -> shutdown_server s l; Lwt.return () + | ["shutdown"] -> Ocsigen_cohttp_server.shutdown_server None; Lwt.return () + | ["shutdown"; f] -> + Ocsigen_cohttp_server.shutdown_server (Some (float_of_string f)); + Lwt.return () | ["gc"] -> Gc.compact (); - Lwt_log.ign_notice ~section "Heap compaction requested by user"; + Lwt_log.ign_warning ~section "Heap compaction requested by user"; Lwt.return () | ["clearcache"] -> Ocsigen_cache.clear_all_caches (); Lwt.return () @@ -1128,31 +147,7 @@ let _ = in Ocsigen_command.register_command_function f -exception Stop of int * string - -let start_server () = - let stop n fmt = Printf.ksprintf (fun s -> raise (Stop (n, s))) fmt in - (** Thread waiting for events on a the listening port *) - let listen use_ssl (addr, port) wait_end_init = - let listening_sockets = - try - let sockets = make_sockets addr port in - List.iter (fun x -> Lwt_unix.listen x 1024) sockets; - sockets - with - | Unix.Unix_error (Unix.EACCES, _, _) -> - stop 7 "Fatal - You are not allowed to use port %d." port - | Unix.Unix_error (Unix.EADDRINUSE, _, _) -> - stop 8 "Fatal - The port %d is already in use." port - | exn -> - stop 100 "Fatal - Uncaught exception: %s" (Printexc.to_string exn) - in - List.iter (fun x -> - ignore (wait_end_init >>= fun () -> - wait_connection use_ssl port x)) listening_sockets; - listening_sockets - in - try +let start_server () = try (* initialization functions for modules (Ocsigen extensions or application code) loaded from now on will be executed directly. *) @@ -1186,16 +181,50 @@ let start_server () = Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH old_term; raise exn in - let run (user, group) (_, ports, sslports) (minthreads, maxthreads) s = + + let extensions_connector = Ocsigen_extensions.compute_result in + + let run (user, group) (ssl, ports, sslports) (minthreads, maxthreads) s = Ocsigen_messages.open_files ~user ~group () >>= fun () -> - let wait_end_init, wait_end_init_awakener = wait () in + (*let wait_end_init, wait_end_init_awakener = wait () in *) (* Listening on all ports: *) - sockets := List.fold_left - (fun a i -> (listen false i wait_end_init) @ a) [] ports; - sslsockets := List.fold_left - (fun a i -> (listen true i wait_end_init) @ a) [] sslports; + (* + sockets := List.fold_left + (fun a i -> (listen false i wait_end_init extensions_connector)@a) [] ports; + sslsockets := List.fold_left + (fun a i -> (listen true i wait_end_init extensions_connector)@a) [] sslports; + *) + + let connection = match ports with + | [] -> [(Ocsigen_socket.All, 80)] + | l -> l + in + + let ssl_connection = + let ssl = match ssl with + | None + | Some { + Ocsigen_parseconfig.ssl_certificate = None ; + Ocsigen_parseconfig.ssl_privatekey = None + } -> + None + | Some { + Ocsigen_parseconfig.ssl_certificate = Some crt ; + Ocsigen_parseconfig.ssl_privatekey = Some key + } -> + Some (crt, key) + | Some { Ocsigen_parseconfig.ssl_privatekey = None } -> + raise (Ocsigen_config.Config_file_error "SSL key is missing") + | Some { Ocsigen_parseconfig.ssl_certificate = None } -> + raise (Ocsigen_config.Config_file_error "SSL certificate is missing") + in match sslports, ssl with + | [], Some (crt, key) -> [(Ocsigen_socket.All, 443, (crt, key))] + | l, Some (crt, key) -> + List.map (fun (a, p) -> (a, p, (crt, key))) l + | _ -> [] + in begin match ports with | (_, p)::_ -> Ocsigen_config.set_default_port p @@ -1210,37 +239,38 @@ let start_server () = let gid = match group with | None -> Unix.getgid () - | Some group -> (try - (Unix.getgrnam group).Unix.gr_gid - with Not_found as e -> - Lwt_log.ign_error ~section "Error: Wrong group"; - raise e) + | Some group -> + try (Unix.getgrnam group).Unix.gr_gid + with Not_found as e -> + errlog ("Error: Wrong group"); + raise e in let uid = match user with | None -> current_uid - | Some user -> (try - (Unix.getpwnam user).Unix.pw_uid - with Not_found as e -> - Lwt_log.ign_error ~section "Error: Wrong user"; - raise e) + | Some user -> + try (Unix.getpwnam user).Unix.pw_uid + with Not_found as e -> + errlog ("Error: Wrong user"); + raise e in (* A pipe to communicate with the server *) let commandpipe = get_command_pipe () in - (try - ignore (Unix.stat commandpipe); - with Unix.Unix_error _ -> - (try + begin + try + ignore (Unix.stat commandpipe); + with Unix.Unix_error _ -> + try let umask = Unix.umask 0 in Unix.mkfifo commandpipe 0o660; Unix.chown commandpipe uid gid; ignore (Unix.umask umask); - Lwt_log.ign_notice ~section "Command pipe created"; + Lwt_log.ign_warning ~section "Command pipe created"; with e -> Lwt_log.ign_error ~section ~exn:e - "Cannot create the command pipe")); - + "Cannot create the command pipe"; + end ; (* I change the user for the process *) begin try if current_uid = 0 then begin @@ -1311,7 +341,7 @@ let start_server () = let rec f () = Lwt_chan.input_line pipe >>= fun s -> - Lwt_log.ign_notice ~section ("Command received: "^s); + Ocsigen_messages.warning ("Command received: "^s); (Lwt.catch (fun () -> let prefix, c = @@ -1340,64 +370,68 @@ let start_server () = Lwt_log.ign_error ~section ~exn:e "Uncaught Exception" ); - Lwt.wakeup wait_end_init_awakener (); - - Lwt_log.ign_notice ~section "Ocsigen has been launched \ - (initialisations ok)"; - - fst (Lwt.wait ()) - - in - - let set_passwd_if_needed (ssl, ports, sslports) = - if sslports <> [] - then - match ssl with - | None - | Some {ssl_certificate = None; ssl_privatekey = None} -> () - | Some {ssl_certificate = None} -> - raise (Ocsigen_config.Config_file_error - "SSL certificate is missing") - | Some {ssl_privatekey = None} -> - raise (Ocsigen_config.Config_file_error - "SSL key is missing") - | Some {ssl_certificate = Some c; ssl_privatekey = Some k} -> - Ssl.set_password_callback !sslctx (ask_for_passwd sslports); - Ssl.use_certificate !sslctx c k - in + (* Lwt.wakeup wait_end_init_awakener (); *) + (* + let config = { + Server.callback = + Ocsigen_cohttp_server.service_cohttp + ~address + ~port + ~extensions_connector; + Server.conn_closed = (fun _ _ () -> ()) + } in + + let process = [ Server.create ~address ~port config ] in + let process = match ssl with + | Some (address, port) -> + let config = { + Server.callback = + Ocsigen_brouette.service_cohttp + ~address + ~port + ~extensions_connector; + Server.conn_closed = (fun _ _ () -> ()) + + } in Server.create ~address ~port config :: process + | None -> process + in Lwt.join process + *) - let set_ciphers_if_needed = function - | Some {ssl_ciphers = Some s}, _, _ :: _ -> - (try - Ssl.set_cipher_list !sslctx s - with Ssl.Cipher_error -> - raise (Ocsigen_config.Config_file_error - "Invalid cipher string")) - | _, _, _ -> - () - in + Lwt.join + ((List.map (fun (address, port) -> Ocsigen_cohttp_server.service + ~address + ~port + ~connector:extensions_connector ()) connection) + @ + (List.map (fun (address, port, (crt, key)) -> Ocsigen_cohttp_server.service + ~ssl:(crt, key, Some (ask_for_passwd [(address, port)])) + ~address + ~port + ~connector:extensions_connector ())) ssl_connection) + (* + Ocsigen_messages.warning "Ocsigen has been launched (initialisations ok)"; + + fst (Lwt.wait ()) + *) - let set_dhfile_if_needed = function - | Some {ssl_dhfile = Some e}, _, _ :: _ -> - (try - Ssl.init_dh_from_file !sslctx e - with Ssl.Diffie_hellman_error -> - raise (Ocsigen_config.Config_file_error - "Invalid DH file")) - | _, _, _ -> - () in - let set_curve_if_needed = function - | Some {ssl_curve = Some c}, _, _ :: _ -> - (try - Ssl.init_ec_from_named_curve !sslctx c - with Ssl.Ec_curve_error -> - raise (Ocsigen_config.Config_file_error - "Invalid EC curve")) - | _, _, _ -> - () - in + (* + let set_passwd_if_needed (ssl, ports, sslports) = + if sslports <> [] + then + match ssl with + | None + | Some (None, None) -> () + | Some (None, _) -> raise (Ocsigen_config.Config_file_error + "SSL certificate is missing") + | Some (_, None) -> raise (Ocsigen_config.Config_file_error + "SSL key is missing") + | Some ((Some c), (Some k)) -> + Ssl.set_password_callback !Server.ssl_context (ask_for_passwd sslports); + Ssl.use_certificate !Server.ssl_context c k + in + *) let write_pid pid = match Ocsigen_config.get_pidfile () with @@ -1417,13 +451,10 @@ let start_server () = | [] -> () | [h] -> let user_info, sslinfo, threadinfo = extract_info h in - set_passwd_if_needed sslinfo; - set_ciphers_if_needed sslinfo; - set_dhfile_if_needed sslinfo; - set_curve_if_needed sslinfo; + (* set_passwd_if_needed sslinfo; *) if (get_daemon ()) then - let pid = Lwt_unix.fork () in + let pid = Unix.fork () in if pid = 0 then Lwt_main.run (run user_info sslinfo threadinfo h) @@ -1441,11 +472,6 @@ let start_server () = in launch config_servers - with - | Stop (n, s) -> - Lwt_main.run (Lwt_log.error ~section s); - exit n - | e -> + with e -> let msg, errno = errmsg e in - Lwt_main.run (Lwt_log.error ~section msg); - exit errno + errlog msg; exit errno diff --git a/src/server/ocsigen_socket.ml b/src/server/ocsigen_socket.ml index 5af6f7deb..729ca8b06 100644 --- a/src/server/ocsigen_socket.ml +++ b/src/server/ocsigen_socket.ml @@ -66,3 +66,8 @@ let string_of_socket_type = function | All -> Unix.string_of_inet_addr Unix.inet_addr_any | IPv4 u -> Unix.string_of_inet_addr u | IPv6 u -> Unix.string_of_inet_addr u + +let to_inet_addr = function + | All -> Unix.inet_addr_any + | IPv4 u -> u + | IPv6 u -> u diff --git a/src/server/ocsigen_socket.mli b/src/server/ocsigen_socket.mli index 393f0b05f..5c90b3008 100644 --- a/src/server/ocsigen_socket.mli +++ b/src/server/ocsigen_socket.mli @@ -26,3 +26,8 @@ val port_of_sockaddr : Unix.sockaddr -> int @param A socket_type *) val string_of_socket_type : socket_type -> string + +(** to_inet_addr accessor of inet addr + @param A socket_type +*) +val to_inet_addr : socket_type -> Unix.inet_addr From dcf6b838d4dcff8daacfd6993118f2d9fd4f5de7 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 14 Dec 2016 18:03:34 +0100 Subject: [PATCH 002/111] Compile staticmod against cohttp server --- src/Makefile.filelist | 2 +- src/extensions/.depend | 4 +- src/extensions/Makefile | 3 +- src/extensions/staticmod.ml | 102 +++++++++++++++++---------- src/server/ocsigen_cohttp_server.ml | 5 ++ src/server/ocsigen_cohttp_server.mli | 5 ++ 6 files changed, 80 insertions(+), 41 deletions(-) diff --git a/src/Makefile.filelist b/src/Makefile.filelist index abf7c20a9..dca369145 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -59,7 +59,7 @@ PLUGINS_INTF := # extensions/ocsigen_comet.cmi \ # extensions/authbasic.cmi \ # extensions/ocsipersist.cmi \ -PLUGINS_IMPL := # extensions/staticmod.cmo \ +PLUGINS_IMPL := extensions/staticmod.cmo # extensions/cgimod.cmo \ # extensions/redirectmod.cmo \ # extensions/revproxy.cmo \ diff --git a/src/extensions/.depend b/src/extensions/.depend index bc17c88d5..b0e7accf0 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -84,11 +84,11 @@ rewritemod.cmo : ../server/ocsigen_request_info.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi rewritemod.cmx : ../server/ocsigen_request_info.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx -staticmod.cmo : ../server/ocsigen_request_info.cmi \ +staticmod.cmo : \ ../server/ocsigen_local_files.cmi ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_http_frame.cmi ../http/ocsigen_http_com.cmi \ ../server/ocsigen_extensions.cmi ../http/http_headers.cmi -staticmod.cmx : ../server/ocsigen_request_info.cmx \ +staticmod.cmx : \ ../server/ocsigen_local_files.cmx ../baselib/ocsigen_lib.cmx \ ../http/ocsigen_http_frame.cmx ../http/ocsigen_http_com.cmx \ ../server/ocsigen_extensions.cmx ../http/http_headers.cmx diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 6013a25b0..05a6d0961 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -22,8 +22,7 @@ all: byte opt ### Extensions ### -FILES := - # staticmod.ml \ +FILES := staticmod.ml # cgimod.ml \ # redirectmod.ml \ # revproxy.ml \ diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 63c94667f..54e96ca6f 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -19,8 +19,6 @@ *) open Lwt.Infix -open Ocsigen_lib -open Ocsigen_extensions let section = Lwt_log.Section.make "ocsigen:ext:staticmod" @@ -74,7 +72,7 @@ let find_static_page ~request ~usermode ~dir ~err ~pathstring = Filename.concat d pathstring, (match usermode with | None -> Some d - | Some { localfiles_root = r } -> Some r + | Some { Ocsigen_extensions.localfiles_root = r } -> Some r )) | Regexp { source_regexp = source; dest = dest; http_status_filter = status_filter; @@ -113,48 +111,75 @@ let find_static_page ~request ~usermode ~dir ~err ~pathstring = let gen ~usermode ?cache dir = function | Ocsigen_extensions.Req_found (_, r) -> Lwt.return (Ocsigen_extensions.Ext_do_nothing) - | Ocsigen_extensions.Req_not_found (err, ri) -> + | Ocsigen_extensions.Req_not_found + (err, ({request_info} as request)) -> let try_block () = Lwt_log.ign_info ~section "Is it a static file?"; let status_filter, page = - find_static_page ~request:ri ~usermode ~dir ~err - ~pathstring:(Url.string_of_url_path ~encode:false - (Ocsigen_cohttp_server.path_of_request - ri.request_info)) in - Ocsigen_local_files.content ri page - >>= fun answer -> + let pathstring = + Ocsigen_lib.Url.string_of_url_path + ~encode:false + (Ocsigen_cohttp_server.path_of_request request_info) + in + find_static_page ~request ~usermode ~dir ~err ~pathstring + in + let fname = + match page with + | Ocsigen_local_files.RFile fname -> + fname + | Ocsigen_local_files.RDir _ -> + failwith "FIXME: staticmod dirs not implemented" + in + Cohttp_lwt_unix.Server.respond_file ~fname () >>= fun answer -> + let ({ Ocsigen_cohttp_server.r_response } as answer) = + Ocsigen_cohttp_server.result_of_cohttp answer + in let answer = - if status_filter = false then + if not status_filter then answer else - (* The page is an error handler, we propagate - the original error code *) - (Ocsigen_http_frame.Result.update answer ~code:err ()) + { answer with + r_response = { + r_response with + status = Cohttp.Code.status_of_code err + } + } in - let (<~) h (n, v) = Http_headers.replace n v h in - let answer = match cache with - | None -> answer - | Some 0 -> - (Ocsigen_http_frame.Result.update answer ~headers: - ((Ocsigen_http_frame.Result.headers answer) - <~ (Http_headers.cache_control, "no-cache") - <~ (Http_headers.expires, "0")) ()) + let answer = + match cache with + | None -> + answer | Some duration -> - (Ocsigen_http_frame.Result.update answer ~headers: - ((Ocsigen_http_frame.Result.headers answer) - <~ (Http_headers.cache_control, "max-age="^ string_of_int duration) - <~ (Http_headers.expires, Ocsigen_http_com.gmtdate (Unix.time () +. float_of_int duration))) ()) + let cache_control, expires = + if duration = 0 then + "no-cache", "0" + else + "max-age=" ^ string_of_int duration, + Ocsigen_http_com.gmtdate + (Unix.time () +. float_of_int duration) + in + let {Cohttp.Response.headers} = r_response in + let headers = + Cohttp.Header.( + replace + (replace headers "Cache-Control" cache_control) + "Expires" expires + ) + in + { answer with r_response = { r_response with headers } } in - Lwt.return (Ext_found (fun () -> Lwt.return answer)) + Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return answer)) and catch_block = function | Ocsigen_local_files.Failed_403 -> - Lwt.return (Ext_next 403) + Lwt.return (Ocsigen_extensions.Ext_next 403) (* XXX We should try to leave an information about this error for later *) | Ocsigen_local_files.NotReadableDirectory -> - Lwt.return (Ext_next err) - | NoSuchUser | Not_concerned | Ocsigen_local_files.Failed_404 -> - Lwt.return (Ext_next err) + Lwt.return (Ocsigen_extensions.Ext_next err) + | Ocsigen_extensions.NoSuchUser + | Ocsigen_extensions.Not_concerned + | Ocsigen_local_files.Failed_404 -> + Lwt.return (Ocsigen_extensions.Ext_next err) | e -> Lwt.fail e in @@ -179,7 +204,9 @@ type options = { opt_cache: int option; } -let parse_config userconf _ : parse_config_aux = fun _ _ _ element -> +let parse_config userconf _ + : Ocsigen_extensions.parse_config_aux + = fun _ _ _ element -> let opt = ref { opt_dir = None; @@ -259,10 +286,11 @@ let parse_config userconf _ : parse_config_aux = fun _ _ _ element -> !opt.opt_dest, !opt.opt_root_checks with | (None, None, None, _, _) -> - badconfig "Missing attribute dir, regexp, or code for " + Ocsigen_extensions.badconfig + "Missing attribute dir, regexp, or code for " | (Some d, None, None, None, None) -> - Dir (Url.remove_end_slash d) + Dir (Ocsigen_lib.Url.remove_end_slash d) | (None, Some r, code, Some t, rc) -> Regexp { source_regexp = r; @@ -275,13 +303,15 @@ let parse_config userconf _ : parse_config_aux = fun _ _ _ element -> Regexp { dest = t; http_status_filter = code; root_checks = None; source_regexp = Netstring_pcre.regexp "^.*$" } - | _ -> badconfig "Wrong attributes for " + | _ -> + Ocsigen_extensions.badconfig "Wrong attributes for " in gen ~usermode:userconf ?cache:!opt.opt_cache kind (*****************************************************************************) (** extension registration *) -let () = register_extension +let () = + Ocsigen_extensions.register_extension ~name:"staticmod" ~fun_site:(fun _ -> parse_config None) ~user_fun_site:(fun path _ -> parse_config (Some path)) diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml index 7156c747e..0cd4092c0 100644 --- a/src/server/ocsigen_cohttp_server.ml +++ b/src/server/ocsigen_cohttp_server.ml @@ -58,6 +58,11 @@ type result = { r_cookies : Ocsigen_cookies.cookieset } +let result_of_cohttp + ?(cookies = Ocsigen_cookies.empty_cookieset) + (r_response, r_body) = + { r_response ; r_body ; r_cookies = cookies } + let path_of_request {r_request} = Cohttp.Request.uri r_request |> Uri.path diff --git a/src/server/ocsigen_cohttp_server.mli b/src/server/ocsigen_cohttp_server.mli index 25048984f..57a548470 100644 --- a/src/server/ocsigen_cohttp_server.mli +++ b/src/server/ocsigen_cohttp_server.mli @@ -26,6 +26,11 @@ type result = { r_cookies : Ocsigen_cookies.cookieset } +val result_of_cohttp : + ?cookies : Ocsigen_cookies.cookieset -> + (Cohttp.Response.t * Cohttp_lwt_body.t) -> + result + val incr_tries : request -> unit val tries : request -> int From 7f88d64a4853c10f3dd91842e1a9e1a5e253532d Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 15 Dec 2016 16:11:24 +0100 Subject: [PATCH 003/111] Ocsigen_cohttp_server.{Request,Answer} modules --- src/extensions/staticmod.ml | 41 ++++----- src/server/ocsigen_cohttp_server.ml | 124 +++++++++++++++++++-------- src/server/ocsigen_cohttp_server.mli | 87 ++++++++++++------- src/server/ocsigen_extensions.ml | 89 ++++++++----------- src/server/ocsigen_extensions.mli | 30 +++---- src/server/ocsigen_local_files.ml | 2 +- 6 files changed, 207 insertions(+), 166 deletions(-) diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 54e96ca6f..2baf07ce4 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -71,8 +71,10 @@ let find_static_page ~request ~usermode ~dir ~err ~pathstring = (false, Filename.concat d pathstring, (match usermode with - | None -> Some d - | Some { Ocsigen_extensions.localfiles_root = r } -> Some r + | None -> + Some d + | Some { Ocsigen_extensions.localfiles_root } -> + Some localfiles_root )) | Regexp { source_regexp = source; dest = dest; http_status_filter = status_filter; @@ -86,7 +88,7 @@ let find_static_page ~request ~usermode ~dir ~err ~pathstring = Ocsigen_extensions.replace_user_dir source dest pathstring and root_checks = (match rc, usermode with - | None, Some { localfiles_root = r } -> + | None, Some { Ocsigen_extensions.localfiles_root = r } -> Some r | Some _, Some _ -> raise (Ocsigen_extensions.Error_in_user_config_file @@ -112,14 +114,14 @@ let gen ~usermode ?cache dir = function | Ocsigen_extensions.Req_found (_, r) -> Lwt.return (Ocsigen_extensions.Ext_do_nothing) | Ocsigen_extensions.Req_not_found - (err, ({request_info} as request)) -> + (err, ({ Ocsigen_extensions.request_info } as request)) -> let try_block () = Lwt_log.ign_info ~section "Is it a static file?"; let status_filter, page = let pathstring = Ocsigen_lib.Url.string_of_url_path ~encode:false - (Ocsigen_cohttp_server.path_of_request request_info) + (Ocsigen_cohttp_server.Request.path request_info) in find_static_page ~request ~usermode ~dir ~err ~pathstring in @@ -131,19 +133,13 @@ let gen ~usermode ?cache dir = function failwith "FIXME: staticmod dirs not implemented" in Cohttp_lwt_unix.Server.respond_file ~fname () >>= fun answer -> - let ({ Ocsigen_cohttp_server.r_response } as answer) = - Ocsigen_cohttp_server.result_of_cohttp answer - in + let answer = Ocsigen_cohttp_server.Answer.of_cohttp answer in let answer = if not status_filter then answer else - { answer with - r_response = { - r_response with - status = Cohttp.Code.status_of_code err - } - } + Ocsigen_cohttp_server.Answer.set_status answer + (Cohttp.Code.status_of_code err) in let answer = match cache with @@ -158,15 +154,10 @@ let gen ~usermode ?cache dir = function Ocsigen_http_com.gmtdate (Unix.time () +. float_of_int duration) in - let {Cohttp.Response.headers} = r_response in - let headers = - Cohttp.Header.( - replace - (replace headers "Cache-Control" cache_control) - "Expires" expires - ) - in - { answer with r_response = { r_response with headers } } + Ocsigen_cohttp_server.Answer.replace_headers answer [ + "Cache-Control" , cache_control ; + "Expires" , expires ; + ] in Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return answer)) and catch_block = function @@ -192,8 +183,8 @@ let gen ~usermode ?cache dir = function let rewrite_local_path userconf path = match userconf with | None -> path - | Some { Ocsigen_extensions.localfiles_root = root } -> - root ^ "/" ^ path + | Some { Ocsigen_extensions.localfiles_root } -> + localfiles_root ^ "/" ^ path type options = { opt_dir: string option; diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml index 0cd4092c0..71ca86c01 100644 --- a/src/server/ocsigen_cohttp_server.ml +++ b/src/server/ocsigen_cohttp_server.ml @@ -13,6 +13,85 @@ module Connection = struct exception Connection_closed end +module Request = struct + + type t = { + r_address : Unix.inet_addr ; + r_port : int ; + r_filenames : string list ref ; + r_sockaddr : Lwt_unix.sockaddr ; + r_request : Cohttp.Request.t ; + r_body : Cohttp_lwt_body.t ; + r_waiter : unit Lwt.t ; + mutable r_tries : int + } + + let host { r_request } = + Uri.host (Cohttp.Request.uri r_request) + + let port { r_port } = + r_port + + let query { r_request } = + Uri.verbatim_query (Cohttp.Request.uri r_request) + + let path {r_request} = + Cohttp.Request.uri r_request + |> Uri.path + |> Ocsigen_lib.Url.split_path + + let header {r_request} id = + let h = Cohttp.Request.headers r_request in + Cohttp.Header.get h id + + let tries {r_tries} = r_tries + + let incr_tries r = r.r_tries <- r.r_tries + 1 + +end + +module Answer = struct + + type t = { + a_response : Cohttp.Response.t ; + a_body : Cohttp_lwt_body.t ; + a_cookies : Ocsigen_cookies.cookieset + } + + let of_cohttp + ?(cookies = Ocsigen_cookies.empty_cookieset) + (a_response, a_body) = + { a_response ; a_body ; a_cookies = cookies } + + let to_cohttp { a_response ; a_body } = a_response, a_body + + let set_status ({ a_response } as a) status = + { a with a_response = { a_response with status } } + + let add_cookies ({ a_cookies } as a) cookies = + if cookies = Ocsigen_cookies.Cookies.empty then + a + else { + a with + a_cookies = Ocsigen_cookies.add_cookies a_cookies cookies + } + + let replace_headers ({ a_response } as a) l = + let headers = + List.fold_left + (fun headers (id, content) -> + Cohttp.Header.replace headers id content) + (Cohttp.Response.headers a_response) + l + in + { a with a_response = { a_response with headers } } + +end + +type request = Request.t + +type answer = Answer.t + (** print_cohttp_request Print request for debug * @param out_ch output for debug * @param request Cohttp request *) @@ -41,37 +120,6 @@ let print_cohttp_request fmt request = let waiters = Hashtbl.create 256 -type request = { - r_address : Unix.inet_addr ; - r_port : int ; - r_filenames : string list ref; - r_sockaddr : Lwt_unix.sockaddr ; - r_request : Cohttp.Request.t ; - r_body : Cohttp_lwt_body.t ; - r_waiter : unit Lwt.t ; - mutable r_tries : int -} - -type result = { - r_response : Cohttp.Response.t ; - r_body : Cohttp_lwt_body.t ; - r_cookies : Ocsigen_cookies.cookieset -} - -let result_of_cohttp - ?(cookies = Ocsigen_cookies.empty_cookieset) - (r_response, r_body) = - { r_response ; r_body ; r_cookies = cookies } - -let path_of_request {r_request} = - Cohttp.Request.uri r_request - |> Uri.path - |> Ocsigen_lib.Url.split_path - -let incr_tries r = r.r_tries <- r.r_tries + 1 - -let tries {r_tries} = r_tries - exception Ocsigen_Is_a_directory of (request -> Neturl.url) let handler ~address ~port ~connector (flow, conn) request body = @@ -152,20 +200,20 @@ let handler ~address ~port ~connector (flow, conn) request body = (* TODO: equivalent of Ocsigen_range *) - connector { + connector { Request. r_address = address ; r_port = port ; r_filenames = filenames ; - r_sockaddr = sockaddr; - r_request = request; - r_body = body; - r_waiter = waiter; + r_sockaddr = sockaddr ; + r_request = request ; + r_body = body ; + r_waiter = waiter ; r_tries = 0 - } >>= fun { r_response ; r_body } -> + } >>= fun { Answer.a_response ; a_body } -> (* TODO: handle cookies *) - Lwt.return (r_response, r_body) + Lwt.return (a_response, a_body) let conn_closed (flow, conn) = try let wakener = Hashtbl.find waiters conn in diff --git a/src/server/ocsigen_cohttp_server.mli b/src/server/ocsigen_cohttp_server.mli index 57a548470..73193c29f 100644 --- a/src/server/ocsigen_cohttp_server.mli +++ b/src/server/ocsigen_cohttp_server.mli @@ -9,41 +9,67 @@ module Connection : sig exception Connection_closed end -type request = { - r_address : Unix.inet_addr ; - r_port : int ; - r_filenames : string list ref; - r_sockaddr : Lwt_unix.sockaddr ; - r_request : Cohttp.Request.t ; - r_body : Cohttp_lwt_body.t ; - r_waiter : unit Lwt.t ; - mutable r_tries : int -} - -type result = { - r_response : Cohttp.Response.t ; - r_body : Cohttp_lwt_body.t ; - r_cookies : Ocsigen_cookies.cookieset -} - -val result_of_cohttp : - ?cookies : Ocsigen_cookies.cookieset -> - (Cohttp.Response.t * Cohttp_lwt_body.t) -> - result - -val incr_tries : request -> unit - -val tries : request -> int - -val path_of_request : request -> string list +module Request : sig + + type t = { + r_address : Unix.inet_addr ; + r_port : int ; + r_filenames : string list ref; + r_sockaddr : Lwt_unix.sockaddr ; + r_request : Cohttp.Request.t ; + r_body : Cohttp_lwt_body.t ; + r_waiter : unit Lwt.t ; + mutable r_tries : int + } + + val host : t -> string option + + val port : t -> int + + val query : t -> string option + + val path : t -> string list + + val header : t -> string -> string option + + val tries : t -> int + + val incr_tries : t -> unit + +end + +module Answer : sig + + type t = { + a_response : Cohttp.Response.t ; + a_body : Cohttp_lwt_body.t ; + a_cookies : Ocsigen_cookies.cookieset + } + + val of_cohttp : + ?cookies : Ocsigen_cookies.cookieset -> + (Cohttp.Response.t * Cohttp_lwt_body.t) -> + t + + val to_cohttp : t -> Cohttp.Response.t * Cohttp_lwt_body.t + + val set_status : t -> Cohttp.Code.status_code -> t + + val add_cookies : t -> Ocsigen_cookies.cookieset -> t + + val replace_headers : t -> (string * string) list -> t + +end (** compute a redirection if path links to a directory *) -exception Ocsigen_Is_a_directory of (request -> Neturl.url) +exception Ocsigen_Is_a_directory of (Request.t -> Neturl.url) (** accessor to get number of client (used by eliom monitoring) *) val number_of_client : unit -> int + (** alias of [number_of_client] *) val get_number_of_connected : unit -> int + (** shutdown main loop of server *) val shutdown_server : float option -> unit @@ -52,5 +78,6 @@ val service : ?ssl:string * string * (bool -> string) option -> address:Ocsigen_socket.socket_type -> port:int -> - connector:(request -> result Lwt.t) -> - unit -> unit Lwt.t + connector:(Request.t -> Answer.t Lwt.t) -> + unit -> + unit Lwt.t diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 68da0e5a7..204007518 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -26,12 +26,13 @@ open Lwt.Infix module Url = Ocsigen_lib.Url +module S = Ocsigen_cohttp_server + include Ocsigen_command -exception Ocsigen_http_error = Ocsigen_cohttp_server.Ocsigen_http_error +exception Ocsigen_http_error = S.Ocsigen_http_error exception Ocsigen_Looping_request - (** Xml tag not recognized by an extension (usually not a real error) *) exception Bad_config_tag_for_extension of string @@ -170,17 +171,13 @@ and follow_symlink = (* Requests *) type request = { - request_info: Ocsigen_cohttp_server.request; - request_config: config_info; + request_info : S.Request.t; + request_config : config_info; } -type result = Ocsigen_cohttp_server.result = { - r_response : Cohttp.Response.t ; - r_body : Cohttp_lwt_body.t ; - r_cookies : Ocsigen_cookies.cookieset -} +type result = S.Answer.t -exception Ocsigen_Is_a_directory = Ocsigen_cohttp_server.Ocsigen_Is_a_directory +exception Ocsigen_Is_a_directory = S.Ocsigen_Is_a_directory type answer = | Ext_do_nothing @@ -287,21 +284,15 @@ let (hosts : (virtual_hosts * config_info * extension2) list ref) = let set_hosts v = hosts := v let get_hosts () = !hosts -let host_of_request {Ocsigen_cohttp_server.r_request} = - Uri.host (Cohttp.Request.uri r_request) - -let port_of_request {Ocsigen_cohttp_server.r_port} = r_port - let ssl_of_request _ = (* FIXME *) false -let query_of_request {Ocsigen_cohttp_server.r_request} = - Uri.verbatim_query (Cohttp.Request.uri r_request) - let update_path { - request_info = ({Ocsigen_cohttp_server.r_request} as request_info); + request_info = + ({ S.Request.r_request } + as request_info); request_config } path = @@ -314,7 +305,7 @@ let update_path and uri = Uri.with_path (Cohttp.Request.uri r_request) path in Cohttp.Request.make ~meth ~version ~encoding ~headers uri in - { request_info with Ocsigen_cohttp_server.r_request } + { request_info with S.Request.r_request } in {request_info ; request_config} @@ -324,7 +315,7 @@ let get_hostname {request_info ; request_config = {default_hostname}} = if Ocsigen_config.get_usedefaulthostname () then default_hostname else - match host_of_request request_info with + match S.Request.host request_info with | None -> default_hostname | Some host -> host @@ -334,8 +325,8 @@ let get_hostname {request_info ; request_config = {default_hostname}} = - or the default port set in the configuration file. *) let get_port { - request_info = ({Ocsigen_cohttp_server.r_port} as request_info); - request_config = {default_httpport ; default_httpsport} + request_info ; + request_config = { default_httpport ; default_httpsport } } = if Ocsigen_config.get_usedefaulthostname () then if ssl_of_request request_info then @@ -343,7 +334,7 @@ let get_port else default_httpport else - r_port + Ocsigen_cohttp_server.Request.port request_info let http_url_syntax = Hashtbl.find Neturl.common_url_syntax "http" @@ -360,8 +351,8 @@ let new_url_of_directory_request request ri = else Some port) ~path:("" :: (Url.add_end_slash_if_missing - (Ocsigen_cohttp_server.path_of_request ri))) - ?query:(query_of_request ri) + (S.Request.path ri))) + ?query:(S.Request.query ri) http_url_syntax (*****************************************************************************) @@ -390,17 +381,6 @@ let site_match request (site_path : string list) url = | [], [] -> Some [] | _ -> aux site_path url - - - -let add_to_res_cookies ({r_cookies} as r) cookies_to_set = - if cookies_to_set = Ocsigen_cookies.Cookies.empty then - r - else { - r with - r_cookies = Ocsigen_cookies.add_cookies r_cookies cookies_to_set - } - let make_ext cookies_to_set req_state (genfun : extension) (genfun2 : extension2) = genfun req_state >>= fun res -> @@ -414,16 +394,16 @@ let make_ext cookies_to_set req_state (genfun : extension) (genfun2 : extension2 in genfun2 Ocsigen_cookies.Cookies.empty - (Req_found (ri, add_to_res_cookies r' cookies_to_set)) + (Req_found (ri, S.Answer.add_cookies r' cookies_to_set)) | Ext_found_continue_with r -> r () >>= fun (r', req) -> genfun2 Ocsigen_cookies.Cookies.empty - (Req_found (req, add_to_res_cookies r' cookies_to_set)) + (Req_found (req, S.Answer.add_cookies r' cookies_to_set)) | Ext_found_continue_with' (r', req) -> genfun2 Ocsigen_cookies.Cookies.empty - (Req_found (req, add_to_res_cookies r' cookies_to_set)) + (Req_found (req, S.Answer.add_cookies r' cookies_to_set)) | Ext_next e -> let ri = match req_state with | Req_found (ri, _) -> ri @@ -504,23 +484,24 @@ let rec default_parse_config in match site_match oldri path - (Ocsigen_cohttp_server.path_of_request oldri.request_info) + (S.Request.path oldri.request_info) with | None -> Lwt_log.ign_info_f ~section "site \"%a\" does not match url \"%a\"." - (fun () path -> Url.string_of_url_path ~encode:true path) path + (fun () path -> + Url.string_of_url_path ~encode:true path) path (fun () oldri -> Url.string_of_url_path ~encode:true - (Ocsigen_cohttp_server.path_of_request - oldri.request_info)) oldri; + (S.Request.path oldri.request_info)) + oldri; Lwt.return (Ext_next e, cookies_to_set) | Some sub_path -> Lwt_log.ign_info_f ~section "site found: url \"%a\" matches \"%a\"." - (fun () oldri -> Url.string_of_url_path ~encode:true - (Ocsigen_cohttp_server.path_of_request - oldri.request_info)) + (fun () oldri -> + Url.string_of_url_path ~encode:true + (S.Request.path oldri.request_info)) oldri (fun () path -> Url.string_of_url_path ~encode:true path) path; let ri = @@ -915,8 +896,8 @@ let string_of_host (h : virtual_hosts) = let compute_result ?(previous_cookies = Ocsigen_cookies.Cookies.empty) ri = - let host = host_of_request ri - and port = port_of_request ri in + let host = S.Request.host ri + and port = S.Request.port ri in let string_of_host_option = function | None -> ":"^(string_of_int port) @@ -924,8 +905,8 @@ let compute_result ?(previous_cookies = Ocsigen_cookies.Cookies.empty) ri = in let rec do2 sites cookies_to_set ri = - Ocsigen_cohttp_server.incr_tries ri; - if Ocsigen_cohttp_server.tries ri > Ocsigen_config.get_maxretries () then + S.Request.incr_tries ri; + if S.Request.tries ri > Ocsigen_config.get_maxretries () then Lwt.fail Ocsigen_Looping_request else let rec aux_host ri prev_err cookies_to_set = function @@ -945,14 +926,14 @@ let compute_result ?(previous_cookies = Ocsigen_cookies.Cookies.empty) ri = | Ext_found r | Ext_found_stop r -> r () >>= fun r' -> - Lwt.return (add_to_res_cookies r' cookies_to_set) + Lwt.return (S.Answer.add_cookies r' cookies_to_set) | Ext_do_nothing -> aux_host ri prev_err cookies_to_set l | Ext_found_continue_with r -> r () >>= fun (r', _) -> - Lwt.return (add_to_res_cookies r' cookies_to_set) + Lwt.return (S.Answer.add_cookies r' cookies_to_set) | Ext_found_continue_with' (r, _) -> - Lwt.return (add_to_res_cookies r cookies_to_set) + Lwt.return (S.Answer.add_cookies r cookies_to_set) | Ext_next e -> aux_host ri e cookies_to_set l (* try next site *) diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index ada7df8ee..0908cf6a4 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -126,23 +126,17 @@ and follow_symlink = (*****************************************************) type request = { - request_info: Ocsigen_cohttp_server.request; + request_info: Ocsigen_cohttp_server.Request.t; request_config: config_info; } exception Ocsigen_Is_a_directory - of (Ocsigen_cohttp_server.request -> Neturl.url) - -type result = Ocsigen_cohttp_server.result = { - r_response : Cohttp.Response.t ; - r_body : Cohttp_lwt_body.t ; - r_cookies : Ocsigen_cookies.cookieset -} + of (Ocsigen_cohttp_server.Request.t -> Neturl.url) type answer = | Ext_do_nothing (** I don't want to do anything *) - | Ext_found of (unit -> result Lwt.t) + | Ext_found of (unit -> Ocsigen_cohttp_server.Answer.t Lwt.t) (** "OK stop! I will take the page. You can start the following request of the same pipelined connection. Here is the function to generate the page". @@ -154,7 +148,7 @@ type answer = In that case, wait to be sure that the new request will not overtake this one. *) - | Ext_found_stop of (unit -> result Lwt.t) + | Ext_found_stop of (unit -> Ocsigen_cohttp_server.Answer.t Lwt.t) (** Found but do not try next extensions *) | Ext_next of int (** Page not found. Try next extension. The integer is the HTTP error code. @@ -209,9 +203,9 @@ type answer = that will return something of type [extension2]. *) | Ext_found_continue_with of - (unit -> (result * request) Lwt.t) + (unit -> (Ocsigen_cohttp_server.Answer.t * request) Lwt.t) (** Same as [Ext_found] but may modify the request. *) - | Ext_found_continue_with' of (result * request) + | Ext_found_continue_with' of (Ocsigen_cohttp_server.Answer.t * request) (** Same as [Ext_found_continue_with] but does not allow to delay the computation of the page. You should probably not use it, but for output filters. @@ -219,7 +213,7 @@ type answer = and request_state = | Req_not_found of (int * request) - | Req_found of (request * result) + | Req_found of (request * Ocsigen_cohttp_server.Answer.t) and extension2 = Ocsigen_cookies.cookieset -> @@ -429,7 +423,7 @@ val get_port : request -> int @param request configuration of the server @param ri request *) val new_url_of_directory_request : - request -> Ocsigen_cohttp_server.request -> Neturl.url + request -> Ocsigen_cohttp_server.Request.t -> Neturl.url (** {3 User directories} *) @@ -470,12 +464,12 @@ val set_hosts : (virtual_hosts * config_info * extension2) list -> unit val get_hosts : unit -> (virtual_hosts * config_info * extension2) list -(** Compute the result to be sent to the client, - by trying all extensions according the configuration file. -*) +(** Compute the answer to be sent to the client, by trying all + extensions according the configuration file. *) val compute_result : ?previous_cookies:Ocsigen_cookies.cookieset -> - Ocsigen_cohttp_server.request -> result Lwt.t + Ocsigen_cohttp_server.Request.t -> + Ocsigen_cohttp_server.Answer.t Lwt.t (** Profiling *) val get_number_of_connected : unit -> int diff --git a/src/server/ocsigen_local_files.ml b/src/server/ocsigen_local_files.ml index e617c50cc..d4fbd582f 100644 --- a/src/server/ocsigen_local_files.ml +++ b/src/server/ocsigen_local_files.ml @@ -223,7 +223,7 @@ let content ~request ~file = | RDir dirname -> Ocsigen_senders.Directory_content.result_of_content (dirname, - Ocsigen_cohttp_server.path_of_request request.request_info) + Ocsigen_cohttp_server.Request.path request.request_info) | RFile filename -> Ocsigen_senders.File_content.result_of_content (filename, From f27a32b775373d7dd8690838d011dd2b279a145f Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 15 Dec 2016 18:26:40 +0100 Subject: [PATCH 004/111] Compile authbasic against Cohttp --- src/Makefile.filelist | 8 +- src/extensions/.depend | 4 +- src/extensions/Makefile | 2 +- src/extensions/authbasic.ml | 145 +++++++++++++++++------------------- 4 files changed, 75 insertions(+), 84 deletions(-) diff --git a/src/Makefile.filelist b/src/Makefile.filelist index dca369145..d83b514fb 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -54,12 +54,13 @@ endif PLUGINS_BIN := -PLUGINS_INTF := # extensions/ocsigen_comet.cmi \ +PLUGINS_INTF := extensions/authbasic.cmi + # extensions/ocsigen_comet.cmi \ # extensions/accesscontrol.cmi \ - # extensions/authbasic.cmi \ # extensions/ocsipersist.cmi \ -PLUGINS_IMPL := extensions/staticmod.cmo +PLUGINS_IMPL := extensions/staticmod.cmo \ + extensions/authbasic.cmo # extensions/cgimod.cmo \ # extensions/redirectmod.cmo \ # extensions/revproxy.cmo \ @@ -67,7 +68,6 @@ PLUGINS_IMPL := extensions/staticmod.cmo # extensions/accesscontrol.cmo \ # extensions/userconf.cmo \ # extensions/outputfilter.cmo \ - # extensions/authbasic.cmo \ # extensions/rewritemod.cmo \ # extensions/extendconfiguration.cmo \ # extensions/ocsigen_comet.cmo \ diff --git a/src/extensions/.depend b/src/extensions/.depend index b0e7accf0..18b6d89a5 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -10,10 +10,10 @@ accesscontrol.cmx : ../server/ocsigen_request_info.cmx \ ../baselib/ocsigen_lib.cmx ../http/ocsigen_http_frame.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../http/http_headers.cmx ../http/framepp.cmx accesscontrol.cmi -authbasic.cmo : ../server/ocsigen_request_info.cmi \ +authbasic.cmo : \ ../http/ocsigen_http_frame.cmi ../server/ocsigen_extensions.cmi \ ../http/ocsigen_cookies.cmi ../http/http_headers.cmi authbasic.cmi -authbasic.cmx : ../server/ocsigen_request_info.cmx \ +authbasic.cmx : \ ../http/ocsigen_http_frame.cmx ../server/ocsigen_extensions.cmx \ ../http/ocsigen_cookies.cmx ../http/http_headers.cmx authbasic.cmi cgimod.cmo : ../baselib/ocsigen_stream.cmi ../http/ocsigen_senders.cmi \ diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 05a6d0961..6bf74a2c2 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -22,7 +22,7 @@ all: byte opt ### Extensions ### -FILES := staticmod.ml +FILES := staticmod.ml authbasic.ml # cgimod.ml \ # redirectmod.ml \ # revproxy.ml \ diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index 779bce82e..48d456b3e 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -18,100 +18,90 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Printf -open Lwt -open Ocsigen_extensions -open Ocsigen_http_frame +open Lwt.Infix let section = Lwt_log.Section.make "ocsigen:ext:access-control" -(*****************************************************************************) (* Management of basic authentication methods *) exception Bad_config_tag_for_auth of string let register_basic_authentication_method, get_basic_authentication_method = - let fun_auth = ref - (fun config -> - raise (Bad_config_tag_for_auth "")) + + let fun_auth = + ref (fun config -> + raise + (Bad_config_tag_for_auth + "")) in - (********* register_basic_authentication_method *********) + (* register_basic_authentication_method *) (fun new_fun_auth -> let old_fun_auth = !fun_auth in - fun_auth := - (fun config -> - try - old_fun_auth config - with - | Bad_config_tag_for_auth c -> new_fun_auth config)), - - (********* get_basic_authentication_method *********) - (fun config -> - !fun_auth config) + fun_auth := (fun config -> + try + old_fun_auth config + with Bad_config_tag_for_auth c -> + new_fun_auth config)), + (* get_basic_authentication_method *) + (fun config -> !fun_auth config) -(*****************************************************************************) (* Basic authentication with a predefined login/password (example) *) - let _ = let open Simplexmlparser in - register_basic_authentication_method - (function - | Element ("plain", ["login", login; "password", password], _) -> - (fun l p -> Lwt.return (login = l && password = p)) - | _ -> raise (Bad_config_tag_for_extension "not for htpasswd")) + register_basic_authentication_method @@ function + | Element ("plain", ["login", login; "password", password], _) -> + (fun l p -> Lwt.return (login = l && password = p)) + | _ -> + raise + (Ocsigen_extensions.Bad_config_tag_for_extension "not for htpasswd") +let gen ~realm ~auth rs = -(*****************************************************************************) + let reject () = + let h = + Http_headers.add + (Http_headers.name "WWW-Authenticate") + (Printf.sprintf "Basic realm=\"%s\"" realm) + Http_headers.empty + in + Lwt_log.ign_info ~section "AUTH: invalid credentials!"; + Lwt.fail + (Ocsigen_http_frame.Http_error.Http_exception (401, None, Some h)) + + and invalid_header () = + Lwt_log.ign_info ~section + "AUTH: invalid Authorization header"; + Lwt.fail + (Ocsigen_extensions.Ocsigen_http_error + (Ocsigen_cookies.Cookies.empty, 400)) + + in + + let validate ~err s = + match Cohttp.Auth.credential_of_string s with + | `Basic (user, pass) -> + auth user pass >>= fun b -> + if b then + Lwt.return (Ocsigen_extensions.Ext_next err) + else + reject () + | `Other s -> + invalid_header () + in -let gen ~realm ~auth rs = match rs with | Ocsigen_extensions.Req_not_found (err, ri) -> - let reject () = - let h = Http_headers.add - (Http_headers.name "WWW-Authenticate") - (sprintf "Basic realm=\"%s\"" realm) - Http_headers.empty - in - Lwt_log.ign_info ~section "AUTH: invalid credentials!"; - fail (Http_error.Http_exception (401, None, Some h)) - in - begin try - let (login, password) = - let credentials = - Http_headers.find - (Http_headers.name "Authorization") - (Ocsigen_request_info.http_frame ri.request_info) - .Ocsigen_http_frame.frame_header - .Ocsigen_http_frame.Http_header.headers - in - let encoded = - let n = String.length credentials in - if n > 6 && String.sub credentials 0 6 = "Basic " then - String.sub credentials 6 (n-6) - else - failwith "credentials" - in - let decoded = Netencoding.Base64.decode encoded in - let i = String.index decoded ':' in - (String.sub decoded 0 i, - String.sub decoded (i+1) (String.length decoded - (i+1))) - in - auth login password >>= - (fun r -> - if r then begin - Lwt_log.ign_info ~section "AUTH: invalid credentials!"; - Lwt.return (Ocsigen_extensions.Ext_next err) - end - else reject ()) - with - | Not_found -> reject () - | exn -> - Lwt_log.ign_info ~exn ~section - "AUTH: Invalid Authorization header"; - fail (Ocsigen_http_error (Ocsigen_cookies.Cookies.empty, 400)) - end + (match + Ocsigen_cohttp_server.Request.header + ri.Ocsigen_extensions.request_info + "Authorization" + with + | Some s -> + validate ~err s + | None -> + reject ()) | Ocsigen_extensions.Req_found (ri, r) -> Lwt.return Ocsigen_extensions.Ext_do_nothing @@ -134,18 +124,19 @@ let parse_config element = ~other_elements:(fun name attrs content -> rest_ref := Simplexmlparser.Element (name, attrs, content) :: !rest_ref) - ()] + ()] element ); let realm = !realm_ref in let auth = match !rest_ref with | [ x ] -> get_basic_authentication_method x - | _ -> badconfig "Bad syntax for tag authbasic" - in gen ~realm ~auth + | _ -> Ocsigen_extensions.badconfig "Bad syntax for tag authbasic" + in + gen ~realm ~auth -(*****************************************************************************) (** Registration of the extension *) -let () = register_extension +let () = + Ocsigen_extensions.register_extension ~name:"authbasic" ~fun_site:(fun _ _ _ _ _ -> parse_config) ~user_fun_site:(fun _ _ _ _ _ _ -> parse_config) From 0c52f0b911991986c26321f53db7fc4228966ee5 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 16 Dec 2016 16:12:32 +0100 Subject: [PATCH 005/111] Compile redirectmod against Cohttp --- src/Makefile.filelist | 4 +- src/extensions/.depend | 8 +- src/extensions/Makefile | 3 +- src/extensions/redirectmod.ml | 142 +++++++++++---------------- src/server/ocsigen_cohttp_server.ml | 46 ++++++--- src/server/ocsigen_cohttp_server.mli | 17 ++++ src/server/ocsigen_extensions.ml | 87 ++++++++-------- src/server/ocsigen_extensions.mli | 5 +- 8 files changed, 155 insertions(+), 157 deletions(-) diff --git a/src/Makefile.filelist b/src/Makefile.filelist index d83b514fb..383f06e96 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -60,9 +60,9 @@ PLUGINS_INTF := extensions/authbasic.cmi # extensions/ocsipersist.cmi \ PLUGINS_IMPL := extensions/staticmod.cmo \ - extensions/authbasic.cmo + extensions/authbasic.cmo \ + extensions/redirectmod.cmo # extensions/cgimod.cmo \ - # extensions/redirectmod.cmo \ # extensions/revproxy.cmo \ # extensions/extensiontemplate.cmo \ # extensions/accesscontrol.cmo \ diff --git a/src/extensions/.depend b/src/extensions/.depend index 18b6d89a5..88fc58983 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -66,12 +66,8 @@ outputfilter.cmo : ../http/ocsigen_http_frame.cmi \ outputfilter.cmx : ../http/ocsigen_http_frame.cmx \ ../http/ocsigen_headers.cmx ../server/ocsigen_extensions.cmx \ ../http/http_headers.cmx -redirectmod.cmo : ../server/ocsigen_request_info.cmi \ - ../baselib/ocsigen_lib.cmi ../http/ocsigen_http_frame.cmi \ - ../server/ocsigen_extensions.cmi -redirectmod.cmx : ../server/ocsigen_request_info.cmx \ - ../baselib/ocsigen_lib.cmx ../http/ocsigen_http_frame.cmx \ - ../server/ocsigen_extensions.cmx +redirectmod.cmo : ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi +redirectmod.cmx : ../baselib/ocsigen_lib.cmx ../server/ocsigen_extensions.cmx revproxy.cmo : ../migrate/of_cohttp.cmi ../baselib/ocsigen_stream.cmi \ ../server/ocsigen_request_info.cmi ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_http_frame.cmi ../http/ocsigen_headers.cmi \ diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 6bf74a2c2..93143cc3b 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -22,9 +22,8 @@ all: byte opt ### Extensions ### -FILES := staticmod.ml authbasic.ml +FILES := staticmod.ml authbasic.ml redirectmod.ml # cgimod.ml \ - # redirectmod.ml \ # revproxy.ml \ # extensiontemplate.ml \ # accesscontrol.ml \ diff --git a/src/extensions/redirectmod.ml b/src/extensions/redirectmod.ml index cb30cc1d0..27607d2fc 100644 --- a/src/extensions/redirectmod.ml +++ b/src/extensions/redirectmod.ml @@ -16,97 +16,67 @@ * You should have received a copy of the GNU Lesser 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. -*) -(*****************************************************************************) -(*****************************************************************************) -(* Ocsigen extension for defining page redirections *) -(* in the configuration file *) -(*****************************************************************************) -(*****************************************************************************) + *) -(* To compile it: - ocamlfind ocamlc -thread -package netstring-pcre,ocsigen -c extensiontemplate.ml - - Then load it dynamically from Ocsigen's config file: - - -*) - -open Ocsigen_lib - -open Ocsigen_extensions +(* Define page redirections in the configuration file *) let section = Lwt_log.Section.make "ocsigen:ext:redirectmod" - -(*****************************************************************************) -(* The table of redirections for each virtual server *) -type assockind = - | Regexp of Netstring_pcre.regexp * string - * yesnomaybe (* full url *) - * bool (* temporary *) - - - -(*****************************************************************************) -(** The function that will generate the pages from the request. *) +(* The table of redirections for each virtual server *) +type assockind = Regexp of + Netstring_pcre.regexp * + string * + Ocsigen_lib.yesnomaybe * (* full url *) + bool (* temporary *) + +let attempt_redir dir err ri () = + Lwt_log.ign_info ~section "Is it a redirection?"; + let Regexp (regexp, dest, full, temp) = dir in + let redir = + let find full = + Ocsigen_extensions.find_redirection + regexp full dest ri + in + match full with + | Yes -> + find true + | No -> + find false + | Maybe -> + try + find false + with Ocsigen_extensions.Not_concerned -> + find true + in + Lwt_log.ign_info_f ~section + "YES! %s redirection to: %s" + (if temp then "Temporary " else "Permanent ") + redir; + let empty_result = Ocsigen_http_frame.Result.empty () in + Lwt.return @@ Ocsigen_extensions.Ext_found (fun () -> + let response = + let headers = Cohttp.Header.(init_with "Location" redir) + and status = if temp then `Found else `Moved_permanently in + Cohttp.Response.make ~status ~headers () + in + Lwt.return (Ocsigen_cohttp_server.Answer.make ~response ())) + +(** The function that will generate the pages from the request *) let gen dir = function | Ocsigen_extensions.Req_found _ -> Lwt.return Ocsigen_extensions.Ext_do_nothing - | Ocsigen_extensions.Req_not_found (err, ri) -> - Lwt.catch - (* Is it a redirection? *) - (fun () -> - Lwt_log.ign_info ~section "Is it a redirection?"; - let Regexp (regexp, dest, full, temp) = dir in - let redir = - let fi full = - Ocsigen_extensions.find_redirection - regexp - full - dest - (Ocsigen_request_info.ssl ri.request_info) - (Ocsigen_request_info.host ri.request_info) - (Ocsigen_request_info.server_port ri.request_info) - (Ocsigen_request_info.get_params_string ri.request_info) - (Ocsigen_request_info.sub_path_string ri.request_info) - (Ocsigen_request_info.full_path_string ri.request_info) - in - match full with - | Yes -> fi true - | No -> fi false - | Maybe -> - try fi false - with Ocsigen_extensions.Not_concerned -> fi true - in - Lwt_log.ign_info_f ~section - "YES! %s redirection to: %s" - (if temp then "Temporary " else "Permanent ") - redir; - let empty_result = Ocsigen_http_frame.Result.empty () in - Lwt.return - (Ext_found - (fun () -> - Lwt.return - (Ocsigen_http_frame.Result.update empty_result - ~location:(Some redir) - ~code: - (if temp then 302 else 301) ()))) - ) - (function - | Ocsigen_extensions.Not_concerned -> Lwt.return (Ext_next err) - | e -> Lwt.fail e) - - - - -(*****************************************************************************) + | Ocsigen_extensions.Req_not_found (err, {request_info}) -> + Lwt.catch (attempt_redir dir err request_info) @@ function + | Ocsigen_extensions.Not_concerned -> + Lwt.return (Ocsigen_extensions.Ext_next err) + | e -> + Lwt.fail e let parse_config config_elem = - let pattern = ref None in - let dest = ref "" in - let mode = ref Yes in - let temporary = ref false in + let pattern = ref None + and dest = ref "" + and mode = ref Ocsigen_lib.Yes + and temporary = ref false in Ocsigen_extensions.( Configuration.process_element ~in_tag:"host" @@ -142,13 +112,13 @@ let parse_config config_elem = config_elem ); match !pattern with - | None -> badconfig "Missing attribute regexp for " + | None -> + Ocsigen_extensions.badconfig "Missing attribute regexp for " | Some regexp -> gen (Regexp (Netstring_pcre.regexp regexp, !dest, !mode, !temporary)) -(*****************************************************************************) -(** Registration of the extension *) -let () = register_extension +let () = + Ocsigen_extensions.register_extension ~name:"redirectmod" ~fun_site:(fun _ _ _ _ _ -> parse_config) ~user_fun_site:(fun _ _ _ _ _ _ -> parse_config) diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml index 71ca86c01..a980dce9a 100644 --- a/src/server/ocsigen_cohttp_server.ml +++ b/src/server/ocsigen_cohttp_server.ml @@ -26,19 +26,33 @@ module Request = struct mutable r_tries : int } - let host { r_request } = + let address {r_address} = + r_address + + let host {r_request} = Uri.host (Cohttp.Request.uri r_request) - let port { r_port } = + let port {r_port} = r_port - let query { r_request } = + let ssl _ = + (* FIXME *) + false + + let query {r_request} = Uri.verbatim_query (Cohttp.Request.uri r_request) - let path {r_request} = - Cohttp.Request.uri r_request - |> Uri.path - |> Ocsigen_lib.Url.split_path + let path_string {r_request} = + Uri.path (Cohttp.Request.uri r_request) + + let path r = + Ocsigen_lib.Url.split_path (path_string r) + + (* FIXME *) + let sub_path_string = path_string + + (* FIXME *) + let sub_path = path let header {r_request} id = let h = Cohttp.Request.headers r_request in @@ -58,6 +72,12 @@ module Answer = struct a_cookies : Ocsigen_cookies.cookieset } + let make + ?(cookies = Ocsigen_cookies.empty_cookieset) + ?(body = Cohttp_lwt_body.empty) + ~response () = + { a_response = response ; a_body = body ; a_cookies = cookies } + let of_cohttp ?(cookies = Ocsigen_cookies.empty_cookieset) (a_response, a_body) = @@ -136,10 +156,14 @@ let handler ~address ~port ~connector (flow, conn) request body = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) | `Unix_domain_socket path -> Unix.ADDR_UNIX path - | `TLS (_, edn) -> getsockname edn - | `Unknown err -> raise (Failure ("resolution failed: " ^ err)) - | `Vchan_direct _ -> raise (Failure "VChan not supported") - | `Vchan_domain_socket _ -> raise (Failure "VChan not supported") + | `TLS (_, edn) -> + getsockname edn + | `Unknown err -> + raise (Failure ("resolution failed: " ^ err)) + | `Vchan_direct _ -> + raise (Failure "VChan not supported") + | `Vchan_domain_socket _ -> + raise (Failure "VChan not supported") in let sockaddr = getsockname edn in diff --git a/src/server/ocsigen_cohttp_server.mli b/src/server/ocsigen_cohttp_server.mli index 73193c29f..0889046b6 100644 --- a/src/server/ocsigen_cohttp_server.mli +++ b/src/server/ocsigen_cohttp_server.mli @@ -22,14 +22,24 @@ module Request : sig mutable r_tries : int } + val address : t -> Unix.inet_addr + val host : t -> string option val port : t -> int + val ssl : t -> bool + val query : t -> string option val path : t -> string list + val path_string : t -> string + + val sub_path : t -> string list + + val sub_path_string : t -> string + val header : t -> string -> string option val tries : t -> int @@ -46,6 +56,13 @@ module Answer : sig a_cookies : Ocsigen_cookies.cookieset } + val make : + ?cookies : Ocsigen_cookies.cookieset -> + ?body : Cohttp_lwt_body.t -> + response : Cohttp.Response.t -> + unit -> + t + val of_cohttp : ?cookies : Ocsigen_cookies.cookieset -> (Cohttp.Response.t * Cohttp_lwt_body.t) -> diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 204007518..1d224ba07 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -284,10 +284,6 @@ let (hosts : (virtual_hosts * config_info * extension2) list ref) = let set_hosts v = hosts := v let get_hosts () = !hosts -let ssl_of_request _ = - (* FIXME *) - false - let update_path { request_info = @@ -329,7 +325,7 @@ let get_port request_config = { default_httpport ; default_httpsport } } = if Ocsigen_config.get_usedefaulthostname () then - if ssl_of_request request_info then + if S.Request.ssl request_info then default_httpsport else default_httpport @@ -341,7 +337,7 @@ let http_url_syntax = Hashtbl.find Neturl.common_url_syntax "http" let new_url_of_directory_request request ri = Lwt_log.ign_info ~section "Sending 301 Moved permanently"; let port = get_port request in - let ssl = ssl_of_request ri in + let ssl = S.Request.ssl ri in Neturl.make_url ~scheme:(if ssl then "https" else "http") ~host:(get_hostname request) @@ -531,9 +527,9 @@ let rec default_parse_config in (function | Req_found (ri, r) -> - Lwt.return (Ext_found_continue_with' (r, ri)) + Lwt.return (Ext_found_continue_with' (r, ri)) | Req_not_found (err, ri) -> - Lwt.return (Ext_sub_result ext)) + Lwt.return (Ext_sub_result ext)) | Simplexmlparser.Element (tag,_,_) -> raise (Bad_config_tag_for_extension tag) | _ -> raise (Ocsigen_config.Config_file_error @@ -551,10 +547,9 @@ and make_parse_config path parse_host l : extension2 = Lwt.return (Ext_continue_with (ri, Ocsigen_cookies.Cookies.empty, e), cookies_to_set)) - (* was Lwt.return (Ext_next e, cookies_to_set)) - but to use make_parse_site with userconf, - we need to know current ri after parsing the sub-configuration. - *) + (* was Lwt.return (Ext_next e, cookies_to_set)), but to use + make_parse_site with userconf, we need to know current ri after + parsing the sub-configuration. *) | xmltag::ll -> try let genfun = f parse_config xmltag in @@ -1035,43 +1030,41 @@ let replace_user_dir regexp dest pathstring = Lwt_log.ign_info_f ~section "No such user %s" u; raise NoSuchUser - -(*****************************************************************************) -(* Finding redirections *) - exception Not_concerned -let find_redirection regexp full_url dest - https host port - get_params_string - sub_path_string - full_path_string - = - if full_url - then - match host with - | None -> raise Not_concerned - | Some host -> - let path = - match get_params_string with - | None -> full_path_string - | Some g -> full_path_string ^ "?" ^ g - in - let path = - Url.make_absolute_url https host port ("/"^path) - in - (match Netstring_pcre.string_match regexp path 0 with - | None -> raise Not_concerned - | Some _ -> (* Matching regexp found! *) - Netstring_pcre.global_replace regexp dest path - ) +let (>|!) v f = + match v with + | None -> + raise Not_concerned + | Some v -> + f v + +let find_redirection regexp full_url dest r = + if full_url then + S.Request.host r >|! fun host -> + let path = + let full_path = S.Request.path_string r in + match S.Request.query r with + | None -> full_path + | Some g -> full_path ^ "?" ^ g + in + let path = + Url.make_absolute_url + (S.Request.ssl r) + host + (S.Request.port r) + ("/" ^ path) + in + Netstring_pcre.string_match regexp path 0 >|! fun _ -> + (* Matching regexp found! *) + Netstring_pcre.global_replace regexp dest path else let path = - match get_params_string with - | None -> sub_path_string - | Some g -> sub_path_string ^ "?" ^ g + let sub_path = S.Request.sub_path_string r in + match S.Request.query r with + | None -> sub_path + | Some g -> sub_path ^ "?" ^ g in - match Netstring_pcre.string_match regexp path 0 with - | None -> raise Not_concerned - | Some _ -> (* Matching regexp found! *) - Netstring_pcre.global_replace regexp dest path + Netstring_pcre.string_match regexp path 0 >|! fun _ -> + (* Matching regexp found! *) + Netstring_pcre.global_replace regexp dest path diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 0908cf6a4..4a337fed0 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -448,9 +448,8 @@ val find_redirection : Netstring_pcre.regexp -> bool -> string -> - bool -> - string option -> int -> string option -> string -> string -> string - + Ocsigen_cohttp_server.Request.t -> + string (**/**) (**/**) From 0356eb2bb455f415447d5daf0aa984cb08ee1f38 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 2 Feb 2017 14:40:39 +0100 Subject: [PATCH 006/111] Compile accesscontrol against Cohttp --- src/extensions/.depend | 4 +- src/extensions/Makefile | 3 +- src/extensions/accesscontrol.ml | 680 ++++++++++++++------------- src/extensions/accesscontrol.mli | 3 +- src/extensions/authbasic.ml | 4 +- src/extensions/rewritemod.ml | 14 +- src/extensions/staticmod.ml | 12 +- src/server/ocsigen_cohttp_server.ml | 129 +++-- src/server/ocsigen_cohttp_server.mli | 48 +- src/server/ocsigen_extensions.ml | 155 +++--- src/server/ocsigen_extensions.mli | 119 +++-- 11 files changed, 633 insertions(+), 538 deletions(-) diff --git a/src/extensions/.depend b/src/extensions/.depend index 88fc58983..b2c04f31b 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -2,11 +2,11 @@ accesscontrol.cmi : ../server/ocsigen_extensions.cmi authbasic.cmi : ocsigen_comet.cmi : ../baselib/ocsigen_stream.cmi ocsipersist.cmi : -accesscontrol.cmo : ../server/ocsigen_request_info.cmi \ +accesscontrol.cmo : \ ../baselib/ocsigen_lib.cmi ../http/ocsigen_http_frame.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ ../http/http_headers.cmi ../http/framepp.cmi accesscontrol.cmi -accesscontrol.cmx : ../server/ocsigen_request_info.cmx \ +accesscontrol.cmx : \ ../baselib/ocsigen_lib.cmx ../http/ocsigen_http_frame.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../http/http_headers.cmx ../http/framepp.cmx accesscontrol.cmi diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 93143cc3b..d9acaa3b9 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -22,11 +22,10 @@ all: byte opt ### Extensions ### -FILES := staticmod.ml authbasic.ml redirectmod.ml +FILES := staticmod.ml authbasic.ml redirectmod.ml accesscontrol.ml # cgimod.ml \ # revproxy.ml \ # extensiontemplate.ml \ - # accesscontrol.ml \ # userconf.ml \ # outputfilter.ml \ # authbasic.ml \ diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index 4f48f4cfd..7c64d9bed 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -18,196 +18,177 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** Filtering requests in the configuration file *) - -(* - -Then load it dynamically from Ocsigen's config file: - - -*) +(* Filtering requests via the configuration file *) open Ocsigen_lib -open Printf -open Lwt -open Ocsigen_extensions open Simplexmlparser open Ocsigen_http_frame - let section = Lwt_log.Section.make "ocsigen:ext:access-control" -(*****************************************************************************) -(* Parsing a condition *) - let rec parse_condition = function - | Element ("ip", ["value", s], []) -> - let prefix = - try - Ipaddr.Prefix.of_string_exn s - with Ipaddr.Parse_error _ -> - try - let ip = Ipaddr.of_string_exn s in - Ipaddr.Prefix.of_addr ip - with _ -> - badconfig "Bad ip/netmask [%s] in condition" s - in - (fun ri -> - let r = Ipaddr.Prefix.mem - (Lazy.force (Ocsigen_request_info.remote_ip_parsed ri)) prefix - in - if r then - Lwt_log.ign_info_f ~section - "IP: %a matches %s" - (fun () -> Ocsigen_request_info.remote_ip) ri s - else - Lwt_log.ign_info_f ~section - "IP: %a does not match %s" - (fun () -> Ocsigen_request_info.remote_ip) ri s; - r) - | Element ("ip" as s, _, _) -> badconfig "Bad syntax for tag %s" s - - | Element ("port", ["value", s], []) -> - let port = - try - int_of_string s - with Failure _ -> - badconfig "Bad port [%s] in condition" s - in - (fun ri -> - let r = Ocsigen_request_info.server_port ri = port in - if r then - Lwt_log.ign_info_f ~section - "PORT: %d accepted" port - else - Lwt_log.ign_info_f ~section - "PORT: %a not accepted (%d expected)" - (fun () ri -> string_of_int (Ocsigen_request_info.server_port ri)) - ri port; - r) - | Element ("port" as s, _, _) -> badconfig "Bad syntax for tag %s" s - - | Element ("ssl", [], []) -> - (fun ri -> - let r = Ocsigen_request_info.ssl ri in - if r then - Lwt_log.ign_info ~section "SSL: accepted" - else - Lwt_log.ign_info ~section "SSL: not accepted"; - r) - | Element ("ssl" as s, _, _) -> badconfig "Bad syntax for tag %s" s - - | Element ("header", ["name", name; "regexp", reg], []) -> - let regexp = - try - Netstring_pcre.regexp ("^"^reg^"$") - with Failure _ -> - badconfig "Bad regular expression [%s] in
condition" reg - in - (fun ri -> - let r = - List.exists - (fun a -> - let r = Netstring_pcre.string_match regexp a 0 <> None in - if r then - Lwt_log.ign_info_f "HEADER: header %s matches %S" name reg; - r) - (try - (Http_headers.find_all - (Http_headers.name name) - (Ocsigen_request_info.http_frame ri) - .Ocsigen_http_frame.frame_header - .Ocsigen_http_frame.Http_header.headers) - with - | Not_found -> []) - in - if not r - then Lwt_log.ign_info_f "HEADER: header %s does not match %S" name reg; - r) - | Element ("header" as s, _, _) -> badconfig "Bad syntax for tag %s" s - - | Element ("method", ["value", s], []) -> - let meth = - try - Framepp.method_of_string s - with Failure _ -> - badconfig "Bad method [%s] in condition" s - in - (fun ri -> - let r = meth = Ocsigen_request_info.meth ri in - if r then - Lwt_log.ign_info_f ~section - "METHOD: %a matches %s" - (fun () ri -> Framepp.string_of_method (Ocsigen_request_info.meth ri)) ri s - else - Lwt_log.ign_info_f ~section - "METHOD: %a does not match %s" - (fun () ri -> Framepp.string_of_method (Ocsigen_request_info.meth ri)) ri s; - r) - | Element ("method" as s, _, _) -> badconfig "Bad syntax for tag %s" s - - | Element ("protocol", ["value", s], []) -> - let pr = - try - Framepp.proto_of_string s - with Failure _ -> - badconfig "Bad protocol [%s] in condition" s - in - (fun ri -> - let r = pr = Ocsigen_request_info.protocol ri in - if r then - Lwt_log.ign_info_f ~section - "PROTOCOL: %a matches %s" - (fun () ri -> Framepp.string_of_proto (Ocsigen_request_info.protocol ri)) ri s - else - Lwt_log.ign_info_f ~section - "PROTOCOL: %a does not match %s" - (fun () ri -> Framepp.string_of_proto (Ocsigen_request_info.protocol ri)) ri s; - r) - | Element ("protocol" as s, _, _) -> badconfig "Bad syntax for tag %s" s - - | Element ("path", ["regexp", s], []) -> - let regexp = - try - Netstring_pcre.regexp ("^"^s^"$") - with Failure _ -> - badconfig "Bad regular expression [%s] in condition" s - in - (fun ri -> - let r = - Netstring_pcre.string_match - regexp (Ocsigen_request_info.sub_path_string ri) 0 <> None - in - if r then - Lwt_log.ign_info_f ~section - "PATH: \"%a\" matches %S" - (fun () ri -> Ocsigen_request_info.sub_path_string ri) ri s - else - Lwt_log.ign_info_f ~section - "PATH: \"%a\" does not match %S" - (fun () ri -> Ocsigen_request_info.sub_path_string ri) ri s; - r) - | Element ("path" as s, _, _) -> badconfig "Bad syntax for tag %s" s + | Element ("ip", ["value", s], []) -> + let prefix = + try + Ipaddr.Prefix.of_string_exn s + with Ipaddr.Parse_error _ -> + try + let ip = Ipaddr.of_string_exn s in + Ipaddr.Prefix.of_addr ip + with _ -> + Ocsigen_extensions.badconfig + "Bad ip/netmask [%s] in condition" s + in + (fun ri -> + let r = + Ipaddr.Prefix.mem + (Ocsigen_cohttp_server.Request.remote_ip_parsed ri) + prefix + in + if r then + Lwt_log.ign_info_f ~section + "IP: %a matches %s" + (fun () -> Ocsigen_cohttp_server.Request.remote_ip) ri s + else + Lwt_log.ign_info_f ~section + "IP: %a does not match %s" + (fun () -> Ocsigen_cohttp_server.Request.remote_ip) ri s; + r) + | Element ("ip" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + + | Element ("port", ["value", s], []) -> + let port = + try + int_of_string s + with Failure _ -> + Ocsigen_extensions.badconfig + "Bad port [%s] in condition" s + in + (fun ri -> + let r = Ocsigen_cohttp_server.Request.port ri = port in + if r then + Lwt_log.ign_info_f ~section + "PORT: %d accepted" port + else + Lwt_log.ign_info_f ~section + "PORT: %a not accepted (%d expected)" + (fun () ri -> + string_of_int (Ocsigen_cohttp_server.Request.port ri)) + ri port; + r) + | Element ("port" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + + | Element ("ssl", [], []) -> + (fun ri -> + let r = Ocsigen_cohttp_server.Request.ssl ri in + if r then + Lwt_log.ign_info ~section "SSL: accepted" + else + Lwt_log.ign_info ~section "SSL: not accepted"; + r) + | Element ("ssl" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + + | Element ("header", ["name", name; "regexp", reg], []) -> + let regexp = + try + Netstring_pcre.regexp ("^"^reg^"$") + with Failure _ -> + Ocsigen_extensions.badconfig + "Bad regular expression [%s] in
condition" + reg + in + (fun ri -> + let r = + List.exists + (fun a -> + let r = Netstring_pcre.string_match regexp a 0 <> None in + if r then + Lwt_log.ign_info_f "HEADER: header %s matches %S" name reg; + r) + (Ocsigen_cohttp_server.Request.header_multi ri name) + in + if not r + then Lwt_log.ign_info_f "HEADER: header %s does not match %S" name reg; + r) + | Element ("header" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + + | Element ("method", ["value", s], []) -> fun ri -> + let m = Cohttp.Code.method_of_string s + and m' = Ocsigen_cohttp_server.Request.meth ri in + let s' = Cohttp.Code.string_of_method m' in + let r = m = m' in + if r then + Lwt_log.ign_info_f ~section "METHOD: %s matches %s" s' s + else + Lwt_log.ign_info_f ~section "METHOD: %s does not match %s" s' s; + r + + | Element ("method" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + + | Element ("protocol", ["value", s], []) -> fun ri -> + let v = Cohttp.Code.version_of_string s + and v' = Ocsigen_cohttp_server.Request.version ri in + let s' = Cohttp.Code.string_of_version v' in + let r = v = v' in + if r then + Lwt_log.ign_info_f ~section "PROTOCOL: %s matches %s" s' s + else + Lwt_log.ign_info_f ~section "PROTOCOL: %s does not match %s" s' s; + r + + | Element ("protocol" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + + | Element ("path", ["regexp", s], []) -> + let regexp = + try + Netstring_pcre.regexp ("^"^s^"$") + with Failure _ -> + Ocsigen_extensions.badconfig + "Bad regular expression [%s] in condition" s + in + fun ri -> + let sps = Ocsigen_cohttp_server.Request.sub_path_string ri in + let r = Netstring_pcre.string_match regexp sps 0 <> None in + if r then + Lwt_log.ign_info_f ~section "PATH: \"%s\" matches %S" sps s + else + Lwt_log.ign_info_f ~section "PATH: \"%s\" does not match %S" sps s; + r + + | Element ("path" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + + | Element ("and", [], sub) -> + let sub = List.map parse_condition sub in + (fun ri -> List.for_all (fun cond -> cond ri) sub) + + | Element ("and" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s - | Element ("and", [], sub) -> - let sub = List.map parse_condition sub in - (fun ri -> List.for_all (fun cond -> cond ri) sub) - | Element ("and" as s, _, _) -> badconfig "Bad syntax for tag %s" s + | Element ("or", [], sub) -> + let sub = List.map parse_condition sub in + (fun ri -> List.exists (fun cond -> cond ri) sub) - | Element ("or", [], sub) -> - let sub = List.map parse_condition sub in - (fun ri -> List.exists (fun cond -> cond ri) sub) - | Element ("or" as s, _, _) -> badconfig "Bad syntax for tag %s" s + | Element ("or" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s - | Element ("not", [], [sub]) -> - let sub = parse_condition sub in - (fun ri -> not (sub ri)) - | Element ("not" as s, _, _) -> badconfig "Bad syntax for tag %s" s + | Element ("not", [], [sub]) -> + let sub = parse_condition sub in + (fun ri -> not (sub ri)) - | _ -> - badconfig "Bad syntax for condition" + | Element ("not" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + + | _ -> + Ocsigen_extensions.badconfig "Bad syntax for condition" (*****************************************************************************) @@ -218,150 +199,180 @@ let comma_space_regexp = Netstring_pcre.regexp "\ *,\ *" let parse_config parse_fun = function | Element ("if", [], sub) -> - let (condition, sub) = match sub with - | cond::q -> (parse_condition cond, q) - | _ -> badconfig "Bad condition in " - in - let (ithen, sub) = match sub with - | Element("then", [], ithen)::q -> (parse_fun ithen, q) - | _ -> badconfig "Bad branch in " - in - let (ielse, sub) = match sub with - | Element ("else", [], ielse)::([] as q) -> (parse_fun ielse, q) - | [] -> (parse_fun [], []) - | _ -> badconfig "Bad branch in " - in - (function - | Ocsigen_extensions.Req_found (ri, _) - | Ocsigen_extensions.Req_not_found (_, ri) -> - Lwt.return - (if condition ri.request_info then begin - Lwt_log.ign_info ~section "COND: going into branch"; - Ocsigen_extensions.Ext_sub_result ithen - end - else begin - Lwt_log.ign_info ~section "COND: going into branch, if any"; - Ocsigen_extensions.Ext_sub_result ielse - end)) - | Element ("if" as s, _, _) -> badconfig "Bad syntax for tag %s" s + let (condition, sub) = match sub with + | cond :: q -> + parse_condition cond, q + | _ -> + Ocsigen_extensions.badconfig "Bad condition in " + in + let (ithen, sub) = match sub with + | Element ("then", [], ithen) :: q -> + parse_fun ithen, q + | _ -> + Ocsigen_extensions.badconfig "Bad branch in " + in + let (ielse, sub) = match sub with + | Element ("else", [], ielse)::([] as q) -> + parse_fun ielse, q + | [] -> (parse_fun [], []) + | _ -> + Ocsigen_extensions.badconfig "Bad branch in " + in + (function + | Ocsigen_extensions.Req_found (ri, _) + | Ocsigen_extensions.Req_not_found (_, ri) -> + Lwt.return + (if condition ri.Ocsigen_extensions.request_info then begin + Lwt_log.ign_info ~section "COND: going into branch"; + Ocsigen_extensions.Ext_sub_result ithen + end + else begin + Lwt_log.ign_info ~section "COND: going into branch, if any"; + Ocsigen_extensions.Ext_sub_result ielse + end)) + | Element ("if" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s | Element ("notfound", [], []) -> - (fun rs -> - Lwt_log.ign_info ~section "NOT_FOUND: taking in charge 404"; - Lwt.return (Ocsigen_extensions.Ext_stop_all - (Ocsigen_cookies.Cookies.empty, 404))) - | Element ("notfound" as s, _, _) -> badconfig "Bad syntax for tag %s" s + (fun rs -> + Lwt_log.ign_info ~section "NOT_FOUND: taking in charge 404"; + Lwt.return (Ocsigen_extensions.Ext_stop_all + (Ocsigen_cookies.Cookies.empty, `Not_found))) + | Element ("notfound" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s | Element ("nextsite", [], []) -> - (function - | Ocsigen_extensions.Req_found (_, r) -> - Lwt.return (Ocsigen_extensions.Ext_found_stop - (fun () -> Lwt.return r)) - | Ocsigen_extensions.Req_not_found (err, ri) -> - Lwt.return (Ocsigen_extensions.Ext_stop_site - (Ocsigen_cookies.Cookies.empty, 404))) + (function + | Ocsigen_extensions.Req_found (_, r) -> + Lwt.return (Ocsigen_extensions.Ext_found_stop + (fun () -> Lwt.return r)) + | Ocsigen_extensions.Req_not_found (err, ri) -> + Lwt.return (Ocsigen_extensions.Ext_stop_site + (Ocsigen_cookies.Cookies.empty, `Not_found))) | Element ("nexthost", [], []) -> - (function - | Ocsigen_extensions.Req_found (_, r) -> - Lwt.return (Ocsigen_extensions.Ext_found_stop - (fun () -> Lwt.return r)) - | Ocsigen_extensions.Req_not_found (err, ri) -> - Lwt.return (Ocsigen_extensions.Ext_stop_host - (Ocsigen_cookies.Cookies.empty, 404))) - | Element ("nextsite" as s, _, _) -> badconfig "Bad syntax for tag %s" s + (function + | Ocsigen_extensions.Req_found (_, r) -> + Lwt.return (Ocsigen_extensions.Ext_found_stop + (fun () -> Lwt.return r)) + | Ocsigen_extensions.Req_not_found (err, ri) -> + Lwt.return (Ocsigen_extensions.Ext_stop_host + (Ocsigen_cookies.Cookies.empty, `Not_found))) + | Element ("nextsite" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s | Element ("stop", [], []) -> - (function - | Ocsigen_extensions.Req_found (_, r) -> - Lwt.return (Ocsigen_extensions.Ext_found_stop - (fun () -> Lwt.return r)) - | Ocsigen_extensions.Req_not_found (err, ri) -> - Lwt.return (Ocsigen_extensions.Ext_stop_all - (Ocsigen_cookies.Cookies.empty, 404))) - | Element ("stop" as s, _, _) -> badconfig "Bad syntax for tag %s" s + (function + | Ocsigen_extensions.Req_found (_, r) -> + Lwt.return (Ocsigen_extensions.Ext_found_stop + (fun () -> Lwt.return r)) + | Ocsigen_extensions.Req_not_found (err, ri) -> + Lwt.return (Ocsigen_extensions.Ext_stop_all + (Ocsigen_cookies.Cookies.empty, `Not_found))) + | Element ("stop" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s | Element ("forbidden", [], []) -> (fun rs -> Lwt_log.ign_info ~section "FORBIDDEN: taking in charge 403"; - Lwt.return (Ocsigen_extensions.Ext_stop_all - (Ocsigen_cookies.Cookies.empty, 403))) - | Element ("forbidden" as s, _, _) -> badconfig "Bad syntax for tag %s" s + Lwt.return (Ocsigen_extensions.Ext_stop_all + (Ocsigen_cookies.Cookies.empty, `Forbidden))) + + | Element ("forbidden" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s | Element ("iffound", [], sub) -> - let ext = parse_fun sub in - (function - | Ocsigen_extensions.Req_found (_, _) -> - Lwt.return (Ext_sub_result ext) - | Ocsigen_extensions.Req_not_found (err, ri) -> - Lwt.return (Ocsigen_extensions.Ext_next err)) - | Element ("iffound" as s, _, _) -> badconfig "Bad syntax for tag %s" s + let ext = parse_fun sub in + (function + | Ocsigen_extensions.Req_found (_, _) -> + Lwt.return (Ocsigen_extensions.Ext_sub_result ext) + | Ocsigen_extensions.Req_not_found (err, ri) -> + Lwt.return (Ocsigen_extensions.Ext_next err)) + + | Element ("iffound" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s | Element ("ifnotfound", [], sub) -> - let ext = parse_fun sub in - (function - | Ocsigen_extensions.Req_found (_, r) -> - Lwt.return (Ocsigen_extensions.Ext_found - (fun () -> Lwt.return r)) - | Ocsigen_extensions.Req_not_found (err, ri) -> - Lwt.return (Ext_sub_result ext)) + let ext = parse_fun sub in + (function + | Ocsigen_extensions.Req_found (_, r) -> + Lwt.return (Ocsigen_extensions.Ext_found + (fun () -> Lwt.return r)) + | Ocsigen_extensions.Req_not_found (err, ri) -> + Lwt.return (Ocsigen_extensions.Ext_sub_result ext)) | Element ("ifnotfound", [("code", s)], sub) -> - let ext = parse_fun sub in - let r = Netstring_pcre.regexp ("^"^s^"$") in - (function - | Ocsigen_extensions.Req_found (_, r) -> - Lwt.return (Ocsigen_extensions.Ext_found - (fun () -> Lwt.return r)) - | Ocsigen_extensions.Req_not_found (err, ri) -> - if Netstring_pcre.string_match r (string_of_int err) 0 <> None then - Lwt.return (Ext_sub_result ext) - else - Lwt.return (Ocsigen_extensions.Ext_next err)) - | Element ("ifnotfound" as s, _, _) -> badconfig "Bad syntax for tag %s" s + let ext = parse_fun sub in + let r = Netstring_pcre.regexp ("^"^s^"$") in + (function + | Ocsigen_extensions.Req_found (_, r) -> + Lwt.return (Ocsigen_extensions.Ext_found + (fun () -> Lwt.return r)) + | Ocsigen_extensions.Req_not_found (err, ri) -> + if + let err = + string_of_int + Cohttp.Code.(code_of_status (err :> status_code)) + in + Netstring_pcre.string_match r err 0 <> None + then + Lwt.return (Ocsigen_extensions.Ext_sub_result ext) + else + Lwt.return (Ocsigen_extensions.Ext_next err)) + | Element ("ifnotfound" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s | Element ("allow-forward-for", param, _) -> - let apply request code = + let apply ({Ocsigen_extensions.request_info} as request) code = Lwt_log.ign_info ~section "Allowed proxy"; let request = - try - let header = Http_headers.find Http_headers.x_forwarded_for - (Ocsigen_request_info.http_frame request.request_info).frame_header.Http_header.headers in - match Netstring_pcre.split comma_space_regexp header with - | [] - | [_] -> Lwt_log.ign_info_f ~section "Malformed X-Forwarded-For field: %s" header; - request - | original_ip::proxies -> - let last_proxy = List.last proxies in - let proxy_ip = Ipaddr.of_string_exn last_proxy in - let equal_ip = proxy_ip = - Lazy.force (Ocsigen_request_info.remote_ip_parsed request.request_info) in - let need_equal_ip = - match param with - | [] -> false - | ["check-equal-ip",b] -> - ( try bool_of_string b - with Invalid_argument _ -> - badconfig "Bad syntax for argument of tag allow-forward-for" ) - | _ -> badconfig "Bad syntax for argument of tag allow-forward-for" + let header = + Ocsigen_cohttp_server.Request.header + request_info "X-Forwarded-For" in - if equal_ip || (not need_equal_ip) - then - { request with request_info = - (Ocsigen_request_info.update request.request_info - ~remote_ip:original_ip - ~remote_ip_parsed:(lazy (Ipaddr.of_string_exn original_ip)) - ~forward_ip:proxies ()) } - else (* the announced ip of the proxy is not its real ip *) - ( Lwt_log.ign_warning_f ~section - "X-Forwarded-For: host ip ( %a ) does not match the header ( %s )" - (fun () -> Ocsigen_request_info.remote_ip) request.request_info - header; - request ) - with - | Not_found -> request + match header with + | Some header -> + (match Netstring_pcre.split comma_space_regexp header with + | original_ip :: proxies -> + let last_proxy = List.last proxies in + let proxy_ip = Ipaddr.of_string_exn last_proxy in + let equal_ip = + proxy_ip = + Ocsigen_cohttp_server.Request.remote_ip_parsed request_info + in + let need_equal_ip = + match param with + | [] -> false + | ["check-equal-ip", b] -> + ( try + bool_of_string b + with Invalid_argument _ -> + Ocsigen_extensions.badconfig + "Bad syntax for argument of tag allow-forward-for") + | _ -> + Ocsigen_extensions.badconfig + "Bad syntax for argument of tag allow-forward-for" + in + if equal_ip || not need_equal_ip then + Ocsigen_extensions.update_ips + ~forward_ip:proxies + request + original_ip + else (* the announced ip of the proxy is not its real ip *) + (Lwt_log.ign_warning_f ~section + "X-Forwarded-For: host ip (%s) \ + does not match the header (%s)" + (Ocsigen_cohttp_server.Request.remote_ip request_info) + header; + request) + | _ -> + Lwt_log.ign_info_f ~section + "Malformed X-Forwarded-For field: %s" header; + request) + | None -> + request in - Lwt.return + Lwt.return (Ocsigen_extensions.Ext_continue_with ( request, Ocsigen_cookies.Cookies.empty, @@ -369,53 +380,52 @@ let parse_config parse_fun = function in (function | Ocsigen_extensions.Req_found (request, resp) -> - apply request (Ocsigen_http_frame.Result.code resp) - | Ocsigen_extensions.Req_not_found (code, request) -> apply request code) + apply request (Ocsigen_cohttp_server.Answer.status resp) + | Ocsigen_extensions.Req_not_found (code, request) -> + apply request code) | Element ("allow-forward-proto", _, _) -> - let apply request code = + let apply ({ Ocsigen_extensions.request_info } as request) code = Lwt_log.ign_info ~section "Allowed proxy for ssl"; - let request = - try - let header = Http_headers.find Http_headers.x_forwarded_proto - (Ocsigen_request_info.http_frame request.request_info) - .frame_header.Http_header.headers in - match String.lowercase header with - | "http" -> - { request with request_info = - (Ocsigen_request_info.update request.request_info - ~ssl:false ()) } - | "https" -> - { request with request_info = - (Ocsigen_request_info.update request.request_info - ~ssl:true ()) } - | _ -> - Lwt_log.ign_info_f ~section - "Malformed X-Forwarded-Proto field: %s" header; - request - with - | Not_found -> request + let request_info = + let header = + Ocsigen_cohttp_server.Request.header + request_info + "X-Forwarded-Proto" + in + match header with + | Some header -> + (match String.lowercase header with + | "http" -> + Ocsigen_cohttp_server.Request.set_ssl request_info false + | "https" -> + Ocsigen_cohttp_server.Request.set_ssl request_info true + | _ -> + Lwt_log.ign_info_f ~section + "Malformed X-Forwarded-Proto field: %s" header; + request_info) + | None -> + request_info in - Lwt.return + Lwt.return (Ocsigen_extensions.Ext_continue_with - ( request, + ( { request with request_info }, Ocsigen_cookies.Cookies.empty, code )) in (function | Ocsigen_extensions.Req_found (request, resp) -> - apply request (Ocsigen_http_frame.Result.code resp) + apply request (Ocsigen_cohttp_server.Answer.status resp) | Ocsigen_extensions.Req_not_found (code, request) -> apply request code) - | Element (t, _, _) -> raise (Bad_config_tag_for_extension t) - | _ -> badconfig "(accesscontrol extension) Bad data" - - - - -(*****************************************************************************) -(** Registration of the extension *) -let () = register_extension - ~name:"accesscontrol" - ~fun_site:(fun _ _ _ _ -> parse_config) - ~user_fun_site:(fun _ _ _ _ _ -> parse_config) - () + | Element (t, _, _) -> + raise (Ocsigen_extensions.Bad_config_tag_for_extension t) + | _ -> + Ocsigen_extensions.badconfig "(accesscontrol extension) Bad data" + +(* Registration of the extension *) +let () = + Ocsigen_extensions.register_extension + ~name:"accesscontrol" + ~fun_site:(fun _ _ _ _ -> parse_config) + ~user_fun_site:(fun _ _ _ _ _ -> parse_config) + () diff --git a/src/extensions/accesscontrol.mli b/src/extensions/accesscontrol.mli index 06a98bdae..f156b2a93 100644 --- a/src/extensions/accesscontrol.mli +++ b/src/extensions/accesscontrol.mli @@ -18,6 +18,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - +(* val parse_condition : Simplexmlparser.xml -> Ocsigen_extensions.request_info -> bool +*) diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index 48d456b3e..4b09e989c 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -74,8 +74,8 @@ let gen ~realm ~auth rs = Lwt_log.ign_info ~section "AUTH: invalid Authorization header"; Lwt.fail - (Ocsigen_extensions.Ocsigen_http_error - (Ocsigen_cookies.Cookies.empty, 400)) + (Ocsigen_cohttp_server.Ocsigen_http_error + (Ocsigen_cookies.Cookies.empty, `Bad_request)) in diff --git a/src/extensions/rewritemod.ml b/src/extensions/rewritemod.ml index 912125b90..24e7492ac 100644 --- a/src/extensions/rewritemod.ml +++ b/src/extensions/rewritemod.ml @@ -17,18 +17,14 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(*****************************************************************************) -(*****************************************************************************) -(* Ocsigen extension for rewriteing URLs *) -(* in the configuration file *) -(*****************************************************************************) -(*****************************************************************************) + +(* Rewrite URLs in the configuration file *) (* IMPORTANT WARNING It is really basic for now: - - rewrites only subpaths (and do not change get parameters) - - changes only ri_sub_path and ri_sub_path_tring - not ri_full_path and ri_full_path_string and ri_url_string and ri_url + - rewrites only subpaths (and doees not change get parameters) + - changes only ri_sub_path and ri_sub_path_string + not ri_full_path, nor ri_full_path_string, nor ri_url_string, nor ri_url This is probably NOT what we want ... *) diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 2baf07ce4..a415f0632 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -47,7 +47,10 @@ let http_status_match status_filter status = match status_filter with | None -> true | Some r -> - Netstring_pcre.string_match r (string_of_int status) 0 <> None + Netstring_pcre.string_match r + (string_of_int + Cohttp.Code.(code_of_status (status :> status_code))) 0 + <> None (* Checks that the path specified in a userconf is correct. Currently, we check that the path does not contain ".." *) @@ -65,7 +68,7 @@ let correct_user_local_file = If the parameter [usermode] is true, we check that the path is valid. *) -let find_static_page ~request ~usermode ~dir ~err ~pathstring = +let find_static_page ~request ~usermode ~dir ~(err : Cohttp.Code.status) ~pathstring = let status_filter, filename, root = match dir with | Dir d -> (false, @@ -138,8 +141,7 @@ let gen ~usermode ?cache dir = function if not status_filter then answer else - Ocsigen_cohttp_server.Answer.set_status answer - (Cohttp.Code.status_of_code err) + Ocsigen_cohttp_server.Answer.set_status answer err in let answer = match cache with @@ -162,7 +164,7 @@ let gen ~usermode ?cache dir = function Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return answer)) and catch_block = function | Ocsigen_local_files.Failed_403 -> - Lwt.return (Ocsigen_extensions.Ext_next 403) + Lwt.return (Ocsigen_extensions.Ext_next `Forbidden) (* XXX We should try to leave an information about this error for later *) | Ocsigen_local_files.NotReadableDirectory -> diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml index a980dce9a..9d8bb4622 100644 --- a/src/server/ocsigen_cohttp_server.ml +++ b/src/server/ocsigen_cohttp_server.ml @@ -3,7 +3,8 @@ open Lwt.Infix let section = Lwt_log.Section.make "ocsigen:cohttp" exception Ocsigen_unsupported_media -exception Ocsigen_http_error of (Ocsigen_cookies.cookieset * int) +exception Ocsigen_http_error of + Ocsigen_cookies.cookieset * Cohttp.Code.status module Connection = struct exception Lost_connection of exn @@ -16,22 +17,55 @@ end module Request = struct type t = { - r_address : Unix.inet_addr ; - r_port : int ; - r_filenames : string list ref ; - r_sockaddr : Lwt_unix.sockaddr ; - r_request : Cohttp.Request.t ; - r_body : Cohttp_lwt_body.t ; - r_waiter : unit Lwt.t ; + r_address : Unix.inet_addr ; + r_port : int ; + r_filenames : string list ref ; + r_sockaddr : Lwt_unix.sockaddr ; + r_remote_ip : string Lazy.t ; + r_remote_ip_parsed : Ipaddr.t Lazy.t ; + r_forward_ip : string list ; + r_request : Cohttp.Request.t ; + r_body : Cohttp_lwt_body.t ; + r_waiter : unit Lwt.t ; mutable r_tries : int } + let make + ?(forward_ip = []) + ~address ~port ~filenames ~sockaddr ~request ~body ~waiter () + = + let r_remote_ip = + lazy + (Unix.string_of_inet_addr + (Ocsigen_socket.ip_of_sockaddr sockaddr)) + in + let r_remote_ip_parsed = + lazy (Ipaddr.of_string_exn (Lazy.force r_remote_ip)) + in + { + r_address = address ; + r_port = port ; + r_filenames = filenames ; + r_sockaddr = sockaddr ; + r_remote_ip ; + r_remote_ip_parsed ; + r_forward_ip = forward_ip ; + r_request = request ; + r_body = body ; + r_waiter = waiter ; + r_tries = 0 + } + + let address {r_address} = r_address let host {r_request} = Uri.host (Cohttp.Request.uri r_request) + let meth {r_request} = + Cohttp.Request.meth r_request + let port {r_port} = r_port @@ -39,6 +73,9 @@ module Request = struct (* FIXME *) false + let version {r_request} = + Cohttp.Request.version r_request + let query {r_request} = Uri.verbatim_query (Cohttp.Request.uri r_request) @@ -58,10 +95,30 @@ module Request = struct let h = Cohttp.Request.headers r_request in Cohttp.Header.get h id + let header_multi {r_request} id = + let h = Cohttp.Request.headers r_request in + Cohttp.Header.get_multi h id + + (* let remote_address {r_sockaddr} = *) + (* Ocsigen_socket.ip_of_sockaddr r_sockaddr *) + + (* let remote_ip r = *) + (* Unix.string_of_inet_addr (remote_address r) *) + + (* let remote_ip_parsed r = *) + (* Ipaddr.of_string_exn (remote_ip r) *) + + let remote_ip {r_remote_ip} = Lazy.force r_remote_ip + + let remote_ip_parsed {r_remote_ip_parsed} = Lazy.force r_remote_ip_parsed + let tries {r_tries} = r_tries let incr_tries r = r.r_tries <- r.r_tries + 1 + (* FIXME *) + let set_ssl r _ = r + end module Answer = struct @@ -86,7 +143,11 @@ module Answer = struct let to_cohttp { a_response ; a_body } = a_response, a_body let set_status ({ a_response } as a) status = - { a with a_response = { a_response with status } } + { a with + a_response = { + a_response with status = (status :> Cohttp.Code.status_code) + } + } let add_cookies ({ a_cookies } as a) cookies = if cookies = Ocsigen_cookies.Cookies.empty then @@ -106,6 +167,13 @@ module Answer = struct in { a with a_response = { a_response with headers } } + let status { a_response = { Cohttp.Response.status } } = + match status with + | `Code _ -> + failwith "FIXME: Cohttp.Code.status_code -> status" + | #Cohttp.Code.status as a -> + a + end type request = Request.t @@ -181,35 +249,36 @@ let handler ~address ~port ~connector (flow, conn) request body = in Some headers, code | Ocsigen_stream.Interrupted Ocsigen_stream.Already_read -> - None, 500 + None, `Internal_server_error | Unix.Unix_error (Unix.EACCES, _, _) -> - None, 403 - | Ocsigen_http_frame.Http_error.Http_exception (code, _, headers) -> - headers, code + None, `Forbidden + (* FIXME Cohttp transition + | Ocsigen_http_frame.Http_error.Http_exception + (code, _, headers) -> + headers, code *) | Ocsigen_lib.Ocsigen_Bad_Request -> - None, 400 + None, `Bad_request | Ocsigen_unsupported_media -> - None, 415 + None, `Unsupported_media_type | Neturl.Malformed_URL -> - None, 400 + None, `Bad_request | Ocsigen_lib.Ocsigen_Request_too_long -> - None, 413 + None, `Request_entity_too_large | exn -> Lwt_log.ign_error ~section ~exn "Error while handling request." ; - None, 500 + None, `Internal_server_error in - Lwt_log.ign_warning_f ~section "Returning error code %i." ret_code ; + Lwt_log.ign_warning_f ~section "Returning error code %i." + (Cohttp.Code.code_of_status (ret_code :> Cohttp.Code.status_code)); let body = match ret_code with - | 404 -> "Not Found" + | `Not_found -> "Not Found" | _ -> Printexc.to_string exn in Cohttp_lwt_unix.Server.respond_error - ?headers - ~status:(Cohttp.Code.status_of_code ret_code) - ~body () + ?headers ~status:(ret_code :> Cohttp.Code.status_code) ~body () in if !filenames <> [] then @@ -224,16 +293,10 @@ let handler ~address ~port ~connector (flow, conn) request body = (* TODO: equivalent of Ocsigen_range *) - connector { Request. - r_address = address ; - r_port = port ; - r_filenames = filenames ; - r_sockaddr = sockaddr ; - r_request = request ; - r_body = body ; - r_waiter = waiter ; - r_tries = 0 - } >>= fun { Answer.a_response ; a_body } -> + connector + (Request.make + ~address ~port ~filenames ~sockaddr ~request ~body ~waiter ()) + >>= fun { Answer.a_response ; a_body } -> (* TODO: handle cookies *) diff --git a/src/server/ocsigen_cohttp_server.mli b/src/server/ocsigen_cohttp_server.mli index 0889046b6..0fbd018c4 100644 --- a/src/server/ocsigen_cohttp_server.mli +++ b/src/server/ocsigen_cohttp_server.mli @@ -1,5 +1,6 @@ exception Ocsigen_unsupported_media -exception Ocsigen_http_error of (Ocsigen_cookies.cookieset * int) +exception Ocsigen_http_error of + Ocsigen_cookies.cookieset * Cohttp.Code.status module Connection : sig exception Lost_connection of exn @@ -12,24 +13,43 @@ end module Request : sig type t = { - r_address : Unix.inet_addr ; - r_port : int ; - r_filenames : string list ref; - r_sockaddr : Lwt_unix.sockaddr ; - r_request : Cohttp.Request.t ; - r_body : Cohttp_lwt_body.t ; - r_waiter : unit Lwt.t ; + r_address : Unix.inet_addr ; + r_port : int ; + r_filenames : string list ref ; + r_sockaddr : Lwt_unix.sockaddr ; + r_remote_ip : string Lazy.t ; + r_remote_ip_parsed : Ipaddr.t Lazy.t ; + r_forward_ip : string list ; + r_request : Cohttp.Request.t ; + r_body : Cohttp_lwt_body.t ; + r_waiter : unit Lwt.t ; mutable r_tries : int } + val make : + ?forward_ip : string list -> + address : Unix.inet_addr -> + port : int -> + filenames : string list ref -> + sockaddr : Lwt_unix.sockaddr -> + request : Cohttp.Request.t -> + body : Cohttp_lwt_body.t -> + waiter : unit Lwt.t -> + unit -> + t + val address : t -> Unix.inet_addr val host : t -> string option + val meth : t -> Cohttp.Code.meth + val port : t -> int val ssl : t -> bool + val version : t -> Cohttp.Code.version + val query : t -> string option val path : t -> string list @@ -42,10 +62,18 @@ module Request : sig val header : t -> string -> string option + val header_multi : t -> string -> string list + + val remote_ip : t -> string + + val remote_ip_parsed : t -> Ipaddr.t + val tries : t -> int val incr_tries : t -> unit + val set_ssl : t -> bool -> t + end module Answer : sig @@ -70,7 +98,9 @@ module Answer : sig val to_cohttp : t -> Cohttp.Response.t * Cohttp_lwt_body.t - val set_status : t -> Cohttp.Code.status_code -> t + val status : t -> Cohttp.Code.status + + val set_status : t -> Cohttp.Code.status -> t val add_cookies : t -> Ocsigen_cookies.cookieset -> t diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 1d224ba07..578fef3b0 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -175,102 +175,86 @@ type request = { request_config : config_info; } -type result = S.Answer.t - exception Ocsigen_Is_a_directory = S.Ocsigen_Is_a_directory type answer = | Ext_do_nothing (** I don't want to do anything *) - | Ext_found of (unit -> result Lwt.t) - (** "OK stop! I will take the page. - You can start the following request of the same pipelined connection. - Here is the function to generate the page". - The extension must return Ext_found as soon as possible - when it is sure it is safe to start next request. - Usually immediately. But in some case, for example proxies, - you don't want the request of one connection to be handled in - different order. (for example revproxy.ml starts its requests - to another server before returning Ext_found, to ensure that all - requests are done in same order). - *) - | Ext_found_stop of (unit -> result Lwt.t) + | Ext_found of (unit -> Ocsigen_cohttp_server.Answer.t Lwt.t) + (** "OK stop! I will take the page. You can start the following + request of the same pipelined connection. Here is the function + to generate the page". The extension must return Ext_found as + soon as possible when it is sure it is safe to start next + request. Usually immediately. But in some case, for example + proxies, you don't want the request of one connection to be + handled in different order. (for example revproxy.ml starts its + requests to another server before returning Ext_found, to ensure + that all requests are done in same order). *) + | Ext_found_stop of (unit -> Ocsigen_cohttp_server.Answer.t Lwt.t) (** Found but do not try next extensions *) - | Ext_next of int (** Page not found. Try next extension. - The integer is the HTTP error code. - It is usally 404, but may be for ex 403 (forbidden) - if you want another extension to try after a 403. - Same as Ext_continue_with but does not change - the request. - *) - | Ext_stop_site of (Ocsigen_cookies.cookieset * int) - (** Error. Do not try next extension, but - try next site. - The integer is the HTTP error code, usally 403. - *) - | Ext_stop_host of (Ocsigen_cookies.cookieset * int) - (** Error. Do not try next extension, + | Ext_next of Cohttp.Code.status + (** Page not found. Try next extension. The status is usually + `Not_found, but may be for example `Forbidden (403) if you want + to try another extension afterwards. Same as Ext_continue_with + but does not change the request. *) + | Ext_stop_site of (Ocsigen_cookies.cookieset * Cohttp.Code.status) + (** Error. Do not try next extension, but try next site. *) + | Ext_stop_host of (Ocsigen_cookies.cookieset * Cohttp.Code.status) + (** Error. + Do not try next extension, do not try next site, - but try next host. - The integer is the HTTP error code, usally 403. - *) - | Ext_stop_all of (Ocsigen_cookies.cookieset * int) + but try next host. *) + | Ext_stop_all of (Ocsigen_cookies.cookieset * Cohttp.Code.status) (** Error. Do not try next extension, do not try next site, - do not try next host. - The integer is the HTTP error code, usally 403. - *) - | Ext_continue_with of (request * Ocsigen_cookies.cookieset * int) + do not try next host. *) + | Ext_continue_with of + (request * Ocsigen_cookies.cookieset * Cohttp.Code.status) (** Used to modify the request before giving it to next extension. - The extension returns the request (possibly modified) - and a set of cookies if it wants to set or cookies - ({!Ocsigen_cookies.Cookies.empty} for no cookies). - You must add these cookies yourself in request if you - want them to be seen by subsequent extensions, - for example using {!Ocsigen_http_frame.compute_new_ri_cookies}. - The integer is usually equal to the error code received - from preceding extension (but you may want to modify it). - *) + The extension returns the request (possibly modified) and a set + of cookies if it wants to set or cookies + ({!Ocsigen_cookies.Cookies.empty} for no cookies). You must add + these cookies yourself in request if you want them to be seen by + subsequent extensions, for example using + {!Ocsigen_http_frame.compute_new_ri_cookies}. The status is + usually equal to the one received from preceding extension (but + you may want to modify it). *) | Ext_retry_with of request * Ocsigen_cookies.cookieset - (** Used to retry all the extensions with a new request. - The extension returns the request (possibly modified) - and a set of cookies if it wants to set or cookies - ({!Ocsigen_cookies.Cookies.empty} for no cookies). - You must add these cookies yourself in request if you - want them to be seen by subsequent extensions, - for example using {!Ocsigen_http_frame.compute_new_ri_cookies}. - *) + (** Used to retry all the extensions with a new request. The + extension returns the request (possibly modified) and a set of + cookies if it wants to set or cookies + ({!Ocsigen_cookies.Cookies.empty} for no cookies). You must add + these cookies yourself in request if you want them to be seen by + subsequent extensions, for example using + {!Ocsigen_http_frame.compute_new_ri_cookies}. *) | Ext_sub_result of extension2 (** Used if your extension want to define option that may contain - other options from other extensions. - In that case, while parsing the configuration file, call - the parsing function (of type [parse_fun]), - that will return something of type [extension2]. - *) - | Ext_found_continue_with of (unit -> (result * request) Lwt.t) + other options from other extensions. In that case, while + parsing the configuration file, call the parsing function (of + type [parse_fun]), that will return something of type + [extension2]. *) + | Ext_found_continue_with of + (unit -> (Ocsigen_cohttp_server.Answer.t * request) Lwt.t) (** Same as [Ext_found] but may modify the request. *) - | Ext_found_continue_with' of (result * request) + | Ext_found_continue_with' of + (Ocsigen_cohttp_server.Answer.t * request) (** Same as [Ext_found_continue_with] but does not allow to delay - the computation of the page. You should probably not use it, - but for output filters. - *) + the computation of the page. You should probably not use it, but + for output filters. *) and request_state = - | Req_not_found of (int * request) - | Req_found of (request * result) + | Req_not_found of (Cohttp.Code.status * request) + | Req_found of (request * Ocsigen_cohttp_server.Answer.t) and extension2 = Ocsigen_cookies.cookieset -> request_state -> (answer * Ocsigen_cookies.cookieset) Lwt.t - type extension = request_state -> answer Lwt.t - type parse_fun = Simplexmlparser.xml list -> extension2 - type parse_host = Parse_host of (Url.path -> @@ -285,12 +269,10 @@ let set_hosts v = hosts := v let get_hosts () = !hosts let update_path - { - request_info = + { request_info = ({ S.Request.r_request } as request_info); - request_config - } + request_config } path = let request_info = let r_request = @@ -303,7 +285,24 @@ let update_path in { request_info with S.Request.r_request } in - {request_info ; request_config} + { request_info ; request_config } + +let update_ips ?forward_ip { request_info ; request_config } s = + let r_forward_ip = + match forward_ip with + | Some forward_ip -> + forward_ip + | None -> + request_info.r_forward_ip + in + { request_info = + { request_info with + r_remote_ip = lazy s ; + r_remote_ip_parsed = lazy (Ipaddr.of_string_exn s) ; + r_forward_ip + } ; + request_config + } (* Default hostname is either the Host header or the hostname set in the configuration file. *) @@ -904,7 +903,11 @@ let compute_result ?(previous_cookies = Ocsigen_cookies.Cookies.empty) ri = if S.Request.tries ri > Ocsigen_config.get_maxretries () then Lwt.fail Ocsigen_Looping_request else - let rec aux_host ri prev_err cookies_to_set = function + let rec aux_host + ri + (prev_err : Cohttp.Code.status) + cookies_to_set = + function | [] -> Lwt.fail (Ocsigen_http_error (cookies_to_set, prev_err)) | (h, conf_info, host_function)::l when host_match ~virtual_hosts:h ~host ~port -> @@ -956,7 +959,7 @@ let compute_result ?(previous_cookies = Ocsigen_cookies.Cookies.empty) ri = (fun () -> string_of_host_option) host (fun () -> string_of_host) h; aux_host ri prev_err cookies_to_set l - in aux_host ri 404 cookies_to_set sites + in aux_host ri `Not_found cookies_to_set sites in do2 (get_hosts ()) previous_cookies ri diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 4a337fed0..8ff4d7ab6 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -32,8 +32,6 @@ open Ocsigen_cookies include (module type of Ocsigen_command) -exception Ocsigen_http_error of (Ocsigen_cookies.cookieset * int) - (** Xml tag not recognized by an extension (usually not a real error) *) exception Bad_config_tag_for_extension of string @@ -137,82 +135,69 @@ type answer = | Ext_do_nothing (** I don't want to do anything *) | Ext_found of (unit -> Ocsigen_cohttp_server.Answer.t Lwt.t) - (** "OK stop! I will take the page. - You can start the following request of the same pipelined connection. - Here is the function to generate the page". - The extension must return Ext_found as soon as possible - when it is sure it is safe to start next request. - Usually as soon as you know that the result will be Ext_found. - But in some case, for example proxies, you don't want the request of - one connection to be handled in different order. - In that case, wait to be sure that the new request will not - overtake this one. - *) + (** "OK stop! I will take the page. You can start the following + request of the same pipelined connection. Here is the function + to generate the page". The extension must return Ext_found as + soon as possible when it is sure it is safe to start next + request. Usually immediately. But in some case, for example + proxies, you don't want the request of one connection to be + handled in different order. (for example revproxy.ml starts its + requests to another server before returning Ext_found, to ensure + that all requests are done in same order). *) | Ext_found_stop of (unit -> Ocsigen_cohttp_server.Answer.t Lwt.t) (** Found but do not try next extensions *) - | Ext_next of int (** Page not found. Try next extension. - The integer is the HTTP error code. - It is usally 404, but may be for ex 403 (forbidden) - if you want another extension to try after a 403. - Same as Ext_continue_with but does not change - the request. - *) - | Ext_stop_site of (Ocsigen_cookies.cookieset * int) - (** Error. Do not try next extension, but - try next site. - The integer is the HTTP error code, usally 403. - *) - | Ext_stop_host of (Ocsigen_cookies.cookieset * int) - (** Error. Do not try next extension, + | Ext_next of Cohttp.Code.status + (** Page not found. Try next extension. The status is usually + `Not_found, but may be for example `Forbidden (403) if you want + to try another extension afterwards. Same as Ext_continue_with + but does not change the request. *) + | Ext_stop_site of (Ocsigen_cookies.cookieset * Cohttp.Code.status) + (** Error. Do not try next extension, but try next site. *) + | Ext_stop_host of (Ocsigen_cookies.cookieset * Cohttp.Code.status) + (** Error. + Do not try next extension, do not try next site, - but try next host. - The integer is the HTTP error code, usally 403. - *) - | Ext_stop_all of (Ocsigen_cookies.cookieset * int) - (** Error. Do not try next extension (even filters), + but try next host. *) + | Ext_stop_all of (Ocsigen_cookies.cookieset * Cohttp.Code.status) + (** Error. Do not try next extension, do not try next site, - do not try next host, - do not . - The integer is the HTTP error code, usally 403. - *) - | Ext_continue_with of (request * Ocsigen_cookies.cookieset * int) + do not try next host. *) + | Ext_continue_with of + (request * Ocsigen_cookies.cookieset * Cohttp.Code.status) (** Used to modify the request before giving it to next extension. - The extension returns the request_info (possibly modified) - and a set of cookies if it wants to set or cookies - ([!Ocsigen_cookies.Cookies.empty] for no cookies). - You must add these cookies yourself in request_info if you - want them to be seen by subsequent extensions, - for example using {!Ocsigen_http_frame.compute_new_ri_cookies}. - The integer is usually equal to the error code received - from preceding extension (but you may want to modify it). - *) + The extension returns the request (possibly modified) and a set + of cookies if it wants to set or cookies + ({!Ocsigen_cookies.Cookies.empty} for no cookies). You must add + these cookies yourself in request if you want them to be seen by + subsequent extensions, for example using + {!Ocsigen_http_frame.compute_new_ri_cookies}. The status is + usually equal to the one received from preceding extension (but + you may want to modify it). *) | Ext_retry_with of request * Ocsigen_cookies.cookieset - (** Used to retry all the extensions with a new request_info. - The extension returns the request_info (possibly modified) - and a set of cookies if it wants to set or cookies - ([!Ocsigen_cookies.Cookies.empty] for no cookies). - You must add these cookies yourself in request_info if you - want them to be seen by subsequent extensions, - for example using {!Ocsigen_http_frame.compute_new_ri_cookies}. - *) + (** Used to retry all the extensions with a new request. The + extension returns the request (possibly modified) and a set of + cookies if it wants to set or cookies + ({!Ocsigen_cookies.Cookies.empty} for no cookies). You must add + these cookies yourself in request if you want them to be seen by + subsequent extensions, for example using + {!Ocsigen_http_frame.compute_new_ri_cookies}. *) | Ext_sub_result of extension2 (** Used if your extension want to define option that may contain - other options from other extensions. - In that case, while parsing the configuration file, call - the parsing function (of type [parse_fun]), - that will return something of type [extension2]. - *) + other options from other extensions. In that case, while + parsing the configuration file, call the parsing function (of + type [parse_fun]), that will return something of type + [extension2]. *) | Ext_found_continue_with of (unit -> (Ocsigen_cohttp_server.Answer.t * request) Lwt.t) (** Same as [Ext_found] but may modify the request. *) - | Ext_found_continue_with' of (Ocsigen_cohttp_server.Answer.t * request) + | Ext_found_continue_with' of + (Ocsigen_cohttp_server.Answer.t * request) (** Same as [Ext_found_continue_with] but does not allow to delay - the computation of the page. You should probably not use it, - but for output filters. - *) + the computation of the page. You should probably not use it, but + for output filters. *) and request_state = - | Req_not_found of (int * request) + | Req_not_found of (Cohttp.Code.status * request) | Req_found of (request * Ocsigen_cohttp_server.Answer.t) and extension2 = @@ -463,6 +448,12 @@ val set_hosts : (virtual_hosts * config_info * extension2) list -> unit val get_hosts : unit -> (virtual_hosts * config_info * extension2) list +val update_ips : + ?forward_ip : string list -> + request -> + string -> + request + (** Compute the answer to be sent to the client, by trying all extensions according the configuration file. *) val compute_result : From b74c678f2fcdb20a8ae78b90614336d90b800898 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 2 Feb 2017 16:40:01 +0100 Subject: [PATCH 007/111] Compile cors against Cohttp --- src/extensions/.depend | 4 +- src/extensions/Makefile | 3 +- src/extensions/accesscontrol.ml | 11 +- src/extensions/authbasic.ml | 2 +- src/extensions/cors.ml | 192 +++++++++++++-------------- src/extensions/staticmod.ml | 4 +- src/server/ocsigen_cohttp_server.ml | 8 +- src/server/ocsigen_cohttp_server.mli | 6 +- 8 files changed, 115 insertions(+), 115 deletions(-) diff --git a/src/extensions/.depend b/src/extensions/.depend index b2c04f31b..f10b5109e 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -28,10 +28,10 @@ cgimod.cmx : ../baselib/ocsigen_stream.cmx ../http/ocsigen_senders.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx ../http/http_headers.cmx \ ../http/framepp.cmx -cors.cmo : ../server/ocsigen_request_info.cmi ../baselib/ocsigen_lib.cmi \ +cors.cmo : ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_http_frame.cmi ../server/ocsigen_extensions.cmi \ ../http/http_headers.cmi ../http/framepp.cmi -cors.cmx : ../server/ocsigen_request_info.cmx ../baselib/ocsigen_lib.cmx \ +cors.cmx : ../baselib/ocsigen_lib.cmx \ ../http/ocsigen_http_frame.cmx ../server/ocsigen_extensions.cmx \ ../http/http_headers.cmx ../http/framepp.cmx deflatemod.cmo : ../baselib/ocsigen_stream.cmi \ diff --git a/src/extensions/Makefile b/src/extensions/Makefile index d9acaa3b9..c4b0dbfe8 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -22,7 +22,7 @@ all: byte opt ### Extensions ### -FILES := staticmod.ml authbasic.ml redirectmod.ml accesscontrol.ml +FILES := accesscontrol.ml authbasic.ml cors.ml staticmod.ml redirectmod.ml # cgimod.ml \ # revproxy.ml \ # extensiontemplate.ml \ @@ -32,7 +32,6 @@ FILES := staticmod.ml authbasic.ml redirectmod.ml accesscontrol.ml # rewritemod.ml \ # extendconfiguration.ml \ # ocsigen_comet.ml \ - # cors.ml \ ifeq "$(CAMLZIP)" "YES" FILES += deflatemod.ml diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index 7c64d9bed..6994a4469 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -96,12 +96,13 @@ let rec parse_condition = function | Element ("header", ["name", name; "regexp", reg], []) -> let regexp = try - Netstring_pcre.regexp ("^"^reg^"$") + Netstring_pcre.regexp ("^" ^ reg ^ "$") with Failure _ -> Ocsigen_extensions.badconfig "Bad regular expression [%s] in
condition" reg in + (fun ri -> let r = List.exists @@ -110,7 +111,8 @@ let rec parse_condition = function if r then Lwt_log.ign_info_f "HEADER: header %s matches %S" name reg; r) - (Ocsigen_cohttp_server.Request.header_multi ri name) + (Ocsigen_cohttp_server.Request.header_multi ri + (Http_headers.name name)) in if not r then Lwt_log.ign_info_f "HEADER: header %s does not match %S" name reg; @@ -328,7 +330,8 @@ let parse_config parse_fun = function let request = let header = Ocsigen_cohttp_server.Request.header - request_info "X-Forwarded-For" + request_info + Http_headers.x_forwarded_for in match header with | Some header -> @@ -391,7 +394,7 @@ let parse_config parse_fun = function let header = Ocsigen_cohttp_server.Request.header request_info - "X-Forwarded-Proto" + Http_headers.x_forwarded_proto in match header with | Some header -> diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index 4b09e989c..c22d3feec 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -96,7 +96,7 @@ let gen ~realm ~auth rs = (match Ocsigen_cohttp_server.Request.header ri.Ocsigen_extensions.request_info - "Authorization" + Http_headers.authorization with | Some s -> validate ~err s diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index b8e2a2a4e..0a4dacc47 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -16,61 +16,54 @@ * You should have received a copy of the GNU Lesser 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. -*) + *) -(** Handling Cross-Origin Resource Sharing headers *) - -open Ocsigen_lib -open Lwt +(** Handle Cross-Origin Resource Sharing (CORS) headers *) let section = Lwt_log.Section.make "ocsigen:ext:cors" (*** MAIN FUNCTION ***) let default_frame () = - (Ocsigen_http_frame.Result.update (Ocsigen_http_frame.Result.default ()) - ~code:200 - ~content_length:(Some 0L) ()) + Ocsigen_cohttp_server.Answer.make + ~response:(Cohttp.Response.make ~status:`OK ()) + () -type config = - { allowed_method : Ocsigen_http_frame.Http_header.http_method list option; - (* None means: all method are accepted *) - allowed_credentials : bool; - max_age : int option; - exposed_headers : string list } +type config = { + allowed_method : Ocsigen_http_frame.Http_header.http_method list option; + (* None means: all method are accepted *) + allowed_credentials : bool; + max_age : int option; + exposed_headers : string list +} exception Refused -let add_headers config rq response = - match Lazy.force (Ocsigen_request_info - .origin rq.Ocsigen_extensions.request_info) with - | None -> return Ocsigen_extensions.Ext_do_nothing +let add_headers config r response = + + match Ocsigen_cohttp_server.Request.header r Http_headers.origin with + + | None -> + Lwt.return Ocsigen_extensions.Ext_do_nothing + | Some origin -> + Lwt_log.ign_info_f ~section "request with origin: %s" origin; - let res_headers = (Ocsigen_http_frame.Result.headers response) in - let res_headers = Http_headers.add - Http_headers.access_control_allow_origin - origin - res_headers - in + let l = [Http_headers.origin, origin] in - let res_headers = - if config.allowed_credentials - then Http_headers.add - Http_headers.access_control_allow_credentials - "true" - res_headers - else res_headers + let l = + if config.allowed_credentials then + (Http_headers.access_control_allow_credentials, "true") :: l + else + l in - let res_headers = - let req_method = Lazy.force - (Ocsigen_request_info - .access_control_request_method rq.Ocsigen_extensions.request_info) - in - match req_method with - None -> res_headers + let l = + match + Ocsigen_cohttp_server.Request.header r + Http_headers.access_control_request_method + with | Some request_method -> let allowed_method = match config.allowed_method with @@ -78,82 +71,84 @@ let add_headers config rq response = | Some l -> try List.mem (Framepp.method_of_string request_method) l - with - | _ -> false in - if allowed_method - then Http_headers.add - Http_headers.access_control_allow_methods - request_method res_headers + with _ -> + false + in + if allowed_method then + (Http_headers.access_control_allow_methods, request_method) :: l else - (Lwt_log.ign_info ~section "Method refused"; - raise Refused) in - - let res_headers = - let req_headers = Lazy.force - (Ocsigen_request_info - .access_control_request_headers rq.Ocsigen_extensions.request_info) - in - match req_headers with - None -> res_headers + (Lwt_log.ign_info ~section "Method refused"; + raise Refused) + | None -> + l + in + + let l = + match + Ocsigen_cohttp_server.Request.header r + Http_headers.access_control_request_headers + with | Some request_headers -> - Http_headers.add Http_headers.access_control_allow_headers - (String.concat ", " request_headers) res_headers in + (Http_headers.access_control_request_headers, request_headers) :: l + | None -> + l + in - let res_headers = + let l = match config.max_age with - | None -> res_headers | Some max_age -> - Http_headers.add Http_headers.access_control_max_age - (string_of_int max_age) res_headers in + (Http_headers.access_control_max_age, string_of_int max_age) :: l + | None -> + l + in - let res_headers = + let l = match config.exposed_headers with - | [] -> res_headers - | _ -> - Http_headers.add Http_headers.access_control_expose_headers - (String.concat ", " config.exposed_headers) res_headers in + | [] -> + l + | exposed_headers -> + (Http_headers.access_control_expose_headers, + String.concat ", " exposed_headers) :: + l - return - (Ocsigen_extensions.Ext_found (fun () -> return - (Ocsigen_http_frame.Result.update response - ~headers:res_headers ()))) + in + + Lwt.return + (Ocsigen_extensions.Ext_found + (fun () -> Lwt.return @@ + Ocsigen_cohttp_server.Answer.replace_headers response l)) let main config = function - | Ocsigen_extensions.Req_not_found (_, rq) -> - begin match (Ocsigen_request_info.meth - rq.Ocsigen_extensions.request_info) with - | Ocsigen_http_frame.Http_header.OPTIONS -> - Lwt_log.ign_info ~section "OPTIONS request"; - begin + | Ocsigen_extensions.Req_not_found + (_, {Ocsigen_extensions.request_info}) -> + (match Ocsigen_cohttp_server.Request.meth request_info with + | `OPTIONS -> + (Lwt_log.ign_info ~section "OPTIONS request"; try - add_headers config rq (default_frame ()) - with - | Refused -> - Lwt_log.ign_info ~section "Refused request"; - Lwt.return Ocsigen_extensions.Ext_do_nothing - end - | _ -> - Lwt.return Ocsigen_extensions.Ext_do_nothing - end - - | Ocsigen_extensions.Req_found (rq,response) -> + add_headers config request_info (default_frame ()) + with Refused -> + (Lwt_log.ign_info ~section "Refused request"; + Lwt.return Ocsigen_extensions.Ext_do_nothing)) + | _ -> + Lwt.return Ocsigen_extensions.Ext_do_nothing) + + | Ocsigen_extensions.Req_found ({request_info}, response) -> Lwt_log.ign_info ~section "answered request"; - add_headers config rq response - -(*** EPILOGUE ***) + add_headers config request_info response -(* registering extension *) +(* Register extension *) -let comma_space_regexp = Netstring_pcre.regexp "[[:blank:]\n]*,[[:blank:]\n]*" +let comma_space_regexp = + Netstring_pcre.regexp "[[:blank:]\n]*,[[:blank:]\n]*" let parse_config _ _ parse_fun config_elem = - let config = ref - { allowed_method = None; - allowed_credentials = false; - max_age = None; - exposed_headers = [] } - in + let config = ref { + allowed_method = None; + allowed_credentials = false; + max_age = None; + exposed_headers = [] + } in Ocsigen_extensions.( Configuration.process_element ~in_tag:"host" @@ -192,7 +187,8 @@ let parse_config _ _ parse_fun config_elem = let site_creator (_ : Ocsigen_extensions.virtual_hosts) _ = parse_config let user_site_creator (_ : Ocsigen_extensions.userconf_info) = site_creator -let () = Ocsigen_extensions.register_extension +let () = + Ocsigen_extensions.register_extension ~name:"CORS" ~fun_site:site_creator ~user_fun_site:user_site_creator diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index a415f0632..2264ea8c6 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -157,8 +157,8 @@ let gen ~usermode ?cache dir = function (Unix.time () +. float_of_int duration) in Ocsigen_cohttp_server.Answer.replace_headers answer [ - "Cache-Control" , cache_control ; - "Expires" , expires ; + Http_headers.cache_control , cache_control ; + Http_headers.expires , expires ; ] in Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return answer)) diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml index 9d8bb4622..57f586cc7 100644 --- a/src/server/ocsigen_cohttp_server.ml +++ b/src/server/ocsigen_cohttp_server.ml @@ -93,11 +93,11 @@ module Request = struct let header {r_request} id = let h = Cohttp.Request.headers r_request in - Cohttp.Header.get h id + Cohttp.Header.get h (Http_headers.name_to_string id) let header_multi {r_request} id = let h = Cohttp.Request.headers r_request in - Cohttp.Header.get_multi h id + Cohttp.Header.get_multi h (Http_headers.name_to_string id) (* let remote_address {r_sockaddr} = *) (* Ocsigen_socket.ip_of_sockaddr r_sockaddr *) @@ -161,7 +161,9 @@ module Answer = struct let headers = List.fold_left (fun headers (id, content) -> - Cohttp.Header.replace headers id content) + Cohttp.Header.replace headers + (Http_headers.name_to_string id) + content) (Cohttp.Response.headers a_response) l in diff --git a/src/server/ocsigen_cohttp_server.mli b/src/server/ocsigen_cohttp_server.mli index 0fbd018c4..96b5c44a3 100644 --- a/src/server/ocsigen_cohttp_server.mli +++ b/src/server/ocsigen_cohttp_server.mli @@ -60,9 +60,9 @@ module Request : sig val sub_path_string : t -> string - val header : t -> string -> string option + val header : t -> Http_headers.name -> string option - val header_multi : t -> string -> string list + val header_multi : t -> Http_headers.name -> string list val remote_ip : t -> string @@ -104,7 +104,7 @@ module Answer : sig val add_cookies : t -> Ocsigen_cookies.cookieset -> t - val replace_headers : t -> (string * string) list -> t + val replace_headers : t -> (Http_headers.name * string) list -> t end From 5074237e2515518ad07f1841606c8860a89a1f4f Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 2 Feb 2017 18:09:53 +0100 Subject: [PATCH 008/111] Compile outputfilter against Cohttp --- src/extensions/.depend | 4 +- src/extensions/Makefile | 5 +- src/extensions/outputfilter.ml | 135 +++++++++++---------------- src/server/ocsigen_cohttp_server.ml | 50 +++++++++- src/server/ocsigen_cohttp_server.mli | 12 +++ 5 files changed, 118 insertions(+), 88 deletions(-) diff --git a/src/extensions/.depend b/src/extensions/.depend index f10b5109e..c7aacbdfe 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -60,10 +60,10 @@ ocsigen_comet.cmx : ../baselib/ocsigen_stream.cmx \ ../server/ocsigen_request_info.cmx ../baselib/ocsigen_lib.cmx \ ../http/ocsigen_http_frame.cmx ../server/ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ocsigen_comet.cmi -outputfilter.cmo : ../http/ocsigen_http_frame.cmi \ +outputfilter.cmo : \ ../http/ocsigen_headers.cmi ../server/ocsigen_extensions.cmi \ ../http/http_headers.cmi -outputfilter.cmx : ../http/ocsigen_http_frame.cmx \ +outputfilter.cmx : \ ../http/ocsigen_headers.cmx ../server/ocsigen_extensions.cmx \ ../http/http_headers.cmx redirectmod.cmo : ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi diff --git a/src/extensions/Makefile b/src/extensions/Makefile index c4b0dbfe8..3091414c4 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -22,13 +22,12 @@ all: byte opt ### Extensions ### -FILES := accesscontrol.ml authbasic.ml cors.ml staticmod.ml redirectmod.ml +FILES := accesscontrol.ml authbasic.ml cors.ml outputfilter.ml \ + staticmod.ml redirectmod.ml # cgimod.ml \ # revproxy.ml \ # extensiontemplate.ml \ # userconf.ml \ - # outputfilter.ml \ - # authbasic.ml \ # rewritemod.ml \ # extendconfiguration.ml \ # ocsigen_comet.ml \ diff --git a/src/extensions/outputfilter.ml b/src/extensions/outputfilter.ml index a38ddf6b0..98f417c84 100644 --- a/src/extensions/outputfilter.ml +++ b/src/extensions/outputfilter.ml @@ -16,84 +16,49 @@ * You should have received a copy of the GNU Lesser 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. -*) -(*****************************************************************************) -(*****************************************************************************) -(* This module allows to rewrite the output sent by the server *) -(*****************************************************************************) -(*****************************************************************************) + *) -open Lwt -open Ocsigen_extensions -open Ocsigen_headers +(* This module enables rewritting the server output *) type outputfilter = | Rewrite_header of (Http_headers.name * Netstring_pcre.regexp * string) | Add_header of (Http_headers.name * string * bool option) let gen filter = function - | Req_not_found (code,_) -> return (Ext_next code) - | Req_found (ri, res) -> - let new_headers = - match filter with + | Ocsigen_extensions.Req_not_found (code, _) -> + Lwt.return (Ocsigen_extensions.Ext_next code) + | Ocsigen_extensions.Req_found (ri, res) -> + Lwt.return @@ Ocsigen_extensions.Ext_found (fun () -> + Lwt.return @@ match filter with | Rewrite_header (header, regexp, dest) -> - begin - try - let header_values = - Http_headers.find_all header - (Ocsigen_http_frame.Result.headers res) - in - let h = - Http_headers.replace_opt header None - (Ocsigen_http_frame.Result.headers res) - in - List.fold_left - (fun h value -> - Http_headers.add - header - (Netstring_pcre.global_replace regexp dest value) - h - ) - h - header_values - with - | Not_found -> Ocsigen_http_frame.Result.headers res - end + (try + let l = + List.map + (Netstring_pcre.global_replace regexp dest) + (Ocsigen_cohttp_server.Answer.header_multi res header) + and a = Ocsigen_cohttp_server.Answer.remove_header res header in + Ocsigen_cohttp_server.Answer.add_header_multi a header l + with Not_found -> + res) | Add_header (header, dest, replace) -> - begin - match replace with - | None -> - begin - try - ignore (Http_headers.find header (Ocsigen_http_frame.Result.headers res)); - (Ocsigen_http_frame.Result.headers res) - with - | Not_found -> - Http_headers.add header dest (Ocsigen_http_frame.Result.headers res) - end - | Some false -> - Http_headers.add header dest (Ocsigen_http_frame.Result.headers res) - | Some true -> - Http_headers.replace header dest (Ocsigen_http_frame.Result.headers res) - end - in - Lwt.return - (Ocsigen_extensions.Ext_found - (fun () -> - Lwt.return - (Ocsigen_http_frame.Result.update res ~headers:new_headers ()))) + match replace with + | None -> + (match Ocsigen_cohttp_server.Answer.header res header with + | Some _ -> + res + | None -> + Ocsigen_cohttp_server.Answer.add_header res header dest) + | Some false -> + Ocsigen_cohttp_server.Answer.add_header res header dest + | Some true -> + Ocsigen_cohttp_server.Answer.replace_header res header dest) let gen_code code = function - | Req_not_found (code,_) -> return (Ext_next code) - | Req_found (ri, res) -> - Lwt.return - (Ocsigen_extensions.Ext_found - (fun () -> - Lwt.return (Ocsigen_http_frame.Result.update res ~code ()))) - - - -(*****************************************************************************) + | Ocsigen_extensions.Req_not_found (code, _) -> + Lwt.return (Ocsigen_extensions.Ext_next code) + | Ocsigen_extensions.Req_found (ri, res) -> + Lwt.return @@ Ocsigen_extensions.Ext_found (fun () -> + Lwt.return (Ocsigen_cohttp_server.Answer.set_status res code)) let parse_config config_elem = let header = ref None in @@ -135,7 +100,14 @@ let parse_config config_elem = ~attributes:[ Configuration.attribute ~name:"code" (fun s -> - try code := Some (int_of_string s) + try + match + Cohttp.Code.status_of_code (int_of_string s) + with + | #Cohttp.Code.status as status -> + code := Some status + | `Code _ -> + failwith "Invalid code" with Failure _ -> badconfig "Invalid code attribute in " ); @@ -147,23 +119,22 @@ let parse_config config_elem = | None -> begin match !header, !regexp, !dest, !replace with | (_, Some _, _, Some _) -> - badconfig - "Wrong attributes for : attributes regexp and \ - replace can't be set simultaneously" - | (Some h, Some r, Some d, None) -> - gen (Rewrite_header (Http_headers.name h, r, d)) - | (Some h, None, Some d, rep) -> - gen (Add_header (Http_headers.name h, d, rep)) - | _ -> - badconfig - "Wrong attributes for " + Ocsigen_extensions.badconfig + "Wrong attributes for : attributes regexp and \ + replace can't be set simultaneously" + | (Some h, Some r, Some d, None) -> + gen (Rewrite_header (Http_headers.name h, r, d)) + | (Some h, None, Some d, rep) -> + gen (Add_header (Http_headers.name h, d, rep)) + | _ -> + Ocsigen_extensions.badconfig + "Wrong attributes for " end | Some code -> gen_code code -(*****************************************************************************) -(** Registration of the extension *) -let () = register_extension +let () = + Ocsigen_extensions.register_extension ~name:"outputfilter" ~fun_site:(fun _ _ _ _ _ -> parse_config) ~user_fun_site:(fun _ _ _ _ _ _ -> parse_config) diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml index 57f586cc7..79a7f3559 100644 --- a/src/server/ocsigen_cohttp_server.ml +++ b/src/server/ocsigen_cohttp_server.ml @@ -157,7 +157,55 @@ module Answer = struct a_cookies = Ocsigen_cookies.add_cookies a_cookies cookies } - let replace_headers ({ a_response } as a) l = + let header {a_response} id = + let h = Cohttp.Response.headers a_response in + Cohttp.Header.get h (Http_headers.name_to_string id) + + let header_multi {a_response} id = + let h = Cohttp.Response.headers a_response in + Cohttp.Header.get_multi h (Http_headers.name_to_string id) + + let add_header + ({a_response = ({headers} as a_response)} as a) + id v = { + a with + a_response = { + a_response with + headers = + Cohttp.Header.add headers (Http_headers.name_to_string id) v + } + } + + let add_header_multi + ({a_response = ({headers} as a_response)} as a) + id l = + let id = Http_headers.name_to_string id in + let headers = + List.fold_left + (fun headers -> Cohttp.Header.add headers id) + headers + l + in + { a with a_response = { a_response with headers } } + + let remove_header ({a_response} as a) id = + let headers = Cohttp.Response.headers a_response + and id = Http_headers.name_to_string id in + let headers = Cohttp.Header.remove headers id in + { a with a_response = { a_response with headers } } + + let replace_header + ({a_response = ({headers} as a_response)} as a) + id v = { + a with + a_response = { + a_response with + headers = + Cohttp.Header.replace headers (Http_headers.name_to_string id) v + } + } + + let replace_headers ({a_response} as a) l = let headers = List.fold_left (fun headers (id, content) -> diff --git a/src/server/ocsigen_cohttp_server.mli b/src/server/ocsigen_cohttp_server.mli index 96b5c44a3..27db0c910 100644 --- a/src/server/ocsigen_cohttp_server.mli +++ b/src/server/ocsigen_cohttp_server.mli @@ -104,8 +104,20 @@ module Answer : sig val add_cookies : t -> Ocsigen_cookies.cookieset -> t + val header : t -> Http_headers.name -> string option + + val header_multi : t -> Http_headers.name -> string list + + val add_header : t -> Http_headers.name -> string -> t + + val add_header_multi : t -> Http_headers.name -> string list -> t + + val replace_header : t -> Http_headers.name -> string -> t + val replace_headers : t -> (Http_headers.name * string) list -> t + val remove_header : t -> Http_headers.name -> t + end (** compute a redirection if path links to a directory *) From 49f366ff02c9fdccb9c39e63c86f6c09778d21b8 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 2 Feb 2017 18:47:19 +0100 Subject: [PATCH 009/111] Compile rewritemod against Cohttp [dummy] We need to correctly handle paths in Ocsigen_cohttp_server.Request for this to work. --- src/extensions/.depend | 4 +- src/extensions/Makefile | 3 +- src/extensions/rewritemod.ml | 181 +++++++++++++----------------- src/server/ocsigen_extensions.ml | 4 + src/server/ocsigen_extensions.mli | 2 + 5 files changed, 89 insertions(+), 105 deletions(-) diff --git a/src/extensions/.depend b/src/extensions/.depend index c7aacbdfe..529e92622 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -76,9 +76,9 @@ revproxy.cmx : ../migrate/of_cohttp.cmx ../baselib/ocsigen_stream.cmx \ ../server/ocsigen_request_info.cmx ../baselib/ocsigen_lib.cmx \ ../http/ocsigen_http_frame.cmx ../http/ocsigen_headers.cmx \ ../server/ocsigen_extensions.cmx -rewritemod.cmo : ../server/ocsigen_request_info.cmi \ +rewritemod.cmo : \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi -rewritemod.cmx : ../server/ocsigen_request_info.cmx \ +rewritemod.cmx : \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx staticmod.cmo : \ ../server/ocsigen_local_files.cmi ../baselib/ocsigen_lib.cmi \ diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 3091414c4..0c2cadc67 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -23,12 +23,11 @@ all: byte opt ### Extensions ### FILES := accesscontrol.ml authbasic.ml cors.ml outputfilter.ml \ - staticmod.ml redirectmod.ml + redirectmod.ml rewritemod.ml staticmod.ml # cgimod.ml \ # revproxy.ml \ # extensiontemplate.ml \ # userconf.ml \ - # rewritemod.ml \ # extendconfiguration.ml \ # ocsigen_comet.ml \ diff --git a/src/extensions/rewritemod.ml b/src/extensions/rewritemod.ml index 24e7492ac..e2266aece 100644 --- a/src/extensions/rewritemod.ml +++ b/src/extensions/rewritemod.ml @@ -16,102 +16,77 @@ * You should have received a copy of the GNU Lesser 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. -*) + *) (* Rewrite URLs in the configuration file *) (* IMPORTANT WARNING + It is really basic for now: - rewrites only subpaths (and doees not change get parameters) - changes only ri_sub_path and ri_sub_path_string not ri_full_path, nor ri_full_path_string, nor ri_url_string, nor ri_url - This is probably NOT what we want ... -*) - - - -(* To compile it: - ocamlfind ocamlc -thread -package netstring-pcre,ocsigen -c extensiontemplate.ml - - Then load it dynamically from Ocsigen's config file: - -*) - -open Lwt -open Ocsigen_extensions -open Simplexmlparser + This is probably NOT what we want... *) let section = Lwt_log.Section.make "ocsigen:ext:rewritemod" exception Not_concerned - -(*****************************************************************************) -(* The table of rewrites for each virtual server *) -type assockind = - | Regexp of Netstring_pcre.regexp * string * bool - - - -(*****************************************************************************) -(* Finding rewrites *) +(* The table of rewrites for each virtual server *) +type assockind = Regexp of Netstring_pcre.regexp * string * bool let find_rewrite (Regexp (regexp, dest, fullrewrite)) suburl = (match Netstring_pcre.string_match regexp suburl 0 with - | None -> raise Not_concerned + | None -> + raise Not_concerned | Some _ -> (* Matching regexp found! *) - Netstring_pcre.global_replace regexp dest suburl), fullrewrite - - - + Netstring_pcre.global_replace regexp dest suburl), + fullrewrite - - -(*****************************************************************************) -(** The function that will generate the pages from the request. *) +(* The function that will generate the pages from the request *) let gen regexp continue = function | Ocsigen_extensions.Req_found _ -> Lwt.return Ocsigen_extensions.Ext_do_nothing | Ocsigen_extensions.Req_not_found (err, ri) -> - catch - (* Is it a rewrite? *) - (fun () -> - Lwt_log.ign_info ~section "Is it a rewrite?"; - let redir, fullrewrite = - let ri = ri.request_info in - find_rewrite regexp - (match Ocsigen_request_info.get_params_string ri with - | None -> Ocsigen_request_info.sub_path_string ri - | Some g -> (Ocsigen_request_info.sub_path_string ri) ^ "?" ^ g) - in - Lwt_log.ign_info_f ~section "YES! rewrite to: %s" redir; - if continue - then - return - (Ext_continue_with - ({ ri with request_info = - Ocsigen_extensions.ri_of_url - ~full_rewrite:fullrewrite - redir ri.request_info }, - Ocsigen_cookies.Cookies.empty, - err) - ) - else - return - (Ext_retry_with - ({ ri with request_info = - Ocsigen_extensions.ri_of_url - ~full_rewrite:fullrewrite - redir ri.request_info }, - Ocsigen_cookies.Cookies.empty) - ) - ) - (function - | Not_concerned -> return (Ext_next err) - | e -> fail e) - -(*****************************************************************************) + let try_block () = + Lwt_log.ign_info ~section "Is it a rewrite?"; + let redir, full_rewrite = + let ri = ri.Ocsigen_extensions.request_info in + find_rewrite regexp + (match Ocsigen_cohttp_server.Request.query ri with + | None -> + Ocsigen_cohttp_server.Request.sub_path_string ri + | Some g -> + Ocsigen_cohttp_server.Request.sub_path_string ri + ^ "?" ^ g) + in + Lwt_log.ign_info_f ~section "YES! rewrite to: %s" redir; + if continue then + Lwt.return @@ Ocsigen_extensions.Ext_continue_with + ({ ri with + Ocsigen_extensions.request_info = + Ocsigen_extensions.ri_of_url + ~full_rewrite + redir + ri.Ocsigen_extensions.request_info }, + Ocsigen_cookies.Cookies.empty, + err) + else + Lwt.return @@ Ocsigen_extensions.Ext_retry_with + ({ ri with + Ocsigen_extensions.request_info = + Ocsigen_extensions.ri_of_url + ~full_rewrite + redir ri.Ocsigen_extensions.request_info }, + Ocsigen_cookies.Cookies.empty) + and catch_block = function + | Ocsigen_extensions.Not_concerned -> + Lwt.return (Ocsigen_extensions.Ext_next err) + | e -> + Lwt.fail e + in + Lwt.catch try_block catch_block let parse_config element = let regexp = ref "" in @@ -122,41 +97,45 @@ let parse_config element = Configuration.process_element ~in_tag:"host" ~other_elements:(fun t _ _ -> raise (Bad_config_tag_for_extension t)) - ~elements:[Configuration.element - ~name:"rewrite" - ~attributes:[Configuration.attribute - ~name:"regexp" - ~obligatory:true - (fun s -> regexp := s); - Configuration.attribute - ~name:"url" - (fun s -> dest := Some s); - Configuration.attribute - ~name:"dest" - (fun s -> dest := Some s); - Configuration.attribute - ~name:"fullrewrite" - (fun s -> fullrewrite := (s = "fullrewrite" - || s = "true")); - Configuration.attribute - ~name:"continue" - (fun s -> continue := (s = "continue" - || s = "true")); - ] - ()] + ~elements:[ + Configuration.element + ~name:"rewrite" + ~attributes:[ + Configuration.attribute + ~name:"regexp" + ~obligatory:true + (fun s -> regexp := s); + Configuration.attribute + ~name:"url" + (fun s -> dest := Some s); + Configuration.attribute + ~name:"dest" + (fun s -> dest := Some s); + Configuration.attribute + ~name:"fullrewrite" + (fun s -> fullrewrite := (s = "fullrewrite" || s = "true")); + Configuration.attribute + ~name:"continue" + (fun s -> continue := (s = "continue" || s = "true")); + ] + ()] element ); match !dest with - | None -> raise (Error_in_config_file "url attribute expected for ") + | None -> + raise + (Ocsigen_extensions.Error_in_config_file + "url attribute expected for ") | Some dest -> - gen (Regexp ((Netstring_pcre.regexp ("^"^ !regexp^"$")), - dest, !fullrewrite)) + gen + (Regexp + ((Netstring_pcre.regexp ("^" ^ !regexp ^ "$")), + dest, !fullrewrite)) !continue - -(*****************************************************************************) (** Registration of the extension *) -let () = register_extension +let () = + Ocsigen_extensions.register_extension ~name:"rewritemod" ~fun_site:(fun _ _ _ _ _ -> parse_config) ~user_fun_site:(fun _ _ _ _ _ _ -> parse_config) diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 578fef3b0..d550c00f2 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -1071,3 +1071,7 @@ let find_redirection regexp full_url dest r = Netstring_pcre.string_match regexp path 0 >|! fun _ -> (* Matching regexp found! *) Netstring_pcre.global_replace regexp dest path + +(* FIXME COHTTP TRANSITION DUMMY *) +let ri_of_url ~full_rewrite _ request_info = + request_info diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 8ff4d7ab6..d0beb6a8f 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -482,3 +482,5 @@ val set_config : Simplexmlparser.xml list -> unit val sockets : Lwt_unix.file_descr list ref val sslsockets : Lwt_unix.file_descr list ref + +val ri_of_url : full_rewrite:'a -> 'b -> 'c -> 'c From 45880a6e8fdd4d630024dbe466c6ff9d2e6540f9 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 3 Feb 2017 13:38:05 +0100 Subject: [PATCH 010/111] Un-open most modules in src/server --- src/server/ocsigen_extensions.mli | 11 +++---- src/server/ocsigen_http_client.ml | 5 +-- src/server/ocsigen_local_files.ml | 54 +++++++++++++++++-------------- src/server/ocsigen_parseconfig.ml | 6 ++-- src/server/ocsigen_server.ml | 54 ++++++++++++++----------------- src/server/ocsigen_socket.ml | 2 -- 6 files changed, 62 insertions(+), 70 deletions(-) diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index d0beb6a8f..fd3f2a4fa 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -24,11 +24,7 @@ (*****************************************************************************) (*****************************************************************************) -(** Writing extensions for Ocsigen *) - -open Lwt -open Ocsigen_lib -open Ocsigen_cookies +(** Extensions interface for Ocsigen Server *) include (module type of Ocsigen_command) @@ -261,7 +257,7 @@ type parse_config = and parse_config_user = userconf_info -> parse_config and parse_config_aux = - Url.path -> parse_host -> + Ocsigen_lib.Url.path -> parse_host -> (parse_fun -> Simplexmlparser.xml -> extension ) @@ -439,7 +435,8 @@ val find_redirection : (**/**) (**/**) -val make_parse_config : Url.path -> parse_config_aux -> parse_fun +val make_parse_config : + Ocsigen_lib.Url.path -> parse_config_aux -> parse_fun val parse_config_item : parse_config val parse_user_site_item : parse_config_user diff --git a/src/server/ocsigen_http_client.ml b/src/server/ocsigen_http_client.ml index f919edc73..fe3a6f9d0 100644 --- a/src/server/ocsigen_http_client.ml +++ b/src/server/ocsigen_http_client.ml @@ -1,7 +1,4 @@ -open Lwt -open Ocsigen_lib -open Cohttp -open Cohttp_lwt_unix +open Lwt.Infix let target https host ?port uri = let scheme = if https then "https" else "http" in diff --git a/src/server/ocsigen_local_files.ml b/src/server/ocsigen_local_files.ml index d4fbd582f..14a0a446c 100644 --- a/src/server/ocsigen_local_files.ml +++ b/src/server/ocsigen_local_files.ml @@ -16,17 +16,15 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ocsigen_extensions -(* Displaying of a local file or directory. Currently used in - staticmod and eliom_predefmod*) +(* Display of a local file or directory. Currently used in staticmod + and eliom_predefmod *) let section = Lwt_log.Section.make "ocsigen:local-file" exception Failed_403 exception Failed_404 exception NotReadableDirectory - (* Policies for following symlinks *) type symlink_policy = stat:Unix.LargeFile.stats -> lstat:Unix.LargeFile.stats -> bool @@ -90,9 +88,12 @@ let check_symlinks ~no_check_for ~filename policy = check_symlinks_parent_directories filename no_check_for policy in match policy with - | AlwaysFollowSymlinks -> true - | DoNotFollowSymlinks -> aux never_follow_symlinks - | FollowSymlinksIfOwnerMatch -> aux follow_symlinks_if_owner_match + | Ocsigen_extensions.AlwaysFollowSymlinks -> + true + | Ocsigen_extensions.DoNotFollowSymlinks -> + aux never_follow_symlinks + | Ocsigen_extensions.FollowSymlinksIfOwnerMatch -> + aux follow_symlinks_if_owner_match let check_dotdot = let regexp = Netstring_pcre.regexp "(/\\.\\./)|(/\\.\\.$)" in @@ -111,11 +112,11 @@ let can_send filename request = Netstring_pcre.string_match (Ocsigen_extensions.do_not_serve_to_regexp arg) filename 0 <> None in - if matches request.do_not_serve_403 then ( + if matches request.Ocsigen_extensions.do_not_serve_403 then ( Lwt_log.ign_info ~section "this file is forbidden"; raise Failed_403) else - if matches request.do_not_serve_404 then ( + if matches request.Ocsigen_extensions.do_not_serve_404 then ( Lwt_log.ign_info ~section "this file must be hidden"; raise Failed_404) @@ -143,7 +144,10 @@ type resolved = - otherwise returns [filename] *) (* See also module Files in eliom.ml *) -let resolve ?no_check_for ~request ~filename () = +let resolve + ?no_check_for + ~request:({Ocsigen_extensions.request_config} as request) + ~filename () = (* We only accept absolute filenames in daemon mode, as we do not really know what is the current directory *) let filename = @@ -170,10 +174,10 @@ let resolve ?no_check_for ~request ~filename () = let rec find_index = function | [] -> (* No suitable index, we try to list the directory *) - if request.request_config.list_directory_content then ( + if request_config.Ocsigen_extensions.list_directory_content then ( Lwt_log.ign_info ~section "Displaying directory content"; - (filename, stat)) - else ( + (filename, stat) + ) else ( (* No suitable index *) Lwt_log.ign_info ~section "No index and no listing"; raise NotReadableDirectory) @@ -184,7 +188,9 @@ let resolve ?no_check_for ~request ~filename () = (index, Unix.LargeFile.stat index) with | Unix.Unix_error (Unix.ENOENT, _, _) -> find_index q - in find_index request.request_config.default_directory_index + in + find_index + request_config.Ocsigen_extensions.default_directory_index else (filename, stat) in @@ -193,9 +199,9 @@ let resolve ?no_check_for ~request ~filename () = (Lwt_log.ign_info_f ~section "Filenames cannot contain .. as in \"%s\"." filename; raise Failed_403) else if check_symlinks ~filename ~no_check_for - request.request_config.follow_symlinks + request_config.Ocsigen_extensions.follow_symlinks then ( - can_send filename request.request_config; + can_send filename request_config; (* If the previous function did not fail, we are authorized to send this file *) Lwt_log.ign_info_f ~section "Returning \"%s\"." filename; @@ -217,19 +223,19 @@ let resolve ?no_check_for ~request ~filename () = (* Given a local file or directory, we retrieve its content *) -let content ~request ~file = +let content + ~request:{ Ocsigen_extensions.request_config = + { Ocsigen_extensions.charset_assoc ; mime_assoc } ; + request_info + } + ~file = try match file with | RDir dirname -> Ocsigen_senders.Directory_content.result_of_content - (dirname, - Ocsigen_cohttp_server.Request.path request.request_info) + (dirname, Ocsigen_cohttp_server.Request.path request_info) | RFile filename -> Ocsigen_senders.File_content.result_of_content - (filename, - request.request_config.charset_assoc, - request.request_config.mime_assoc - ) - + (filename, charset_assoc, mime_assoc) with | Unix.Unix_error (Unix.EACCES,_,_) -> raise Failed_403 diff --git a/src/server/ocsigen_parseconfig.ml b/src/server/ocsigen_parseconfig.ml index 2fa513a31..4313d9f8d 100644 --- a/src/server/ocsigen_parseconfig.ml +++ b/src/server/ocsigen_parseconfig.ml @@ -21,9 +21,7 @@ (******************************************************************) (** Config file parsing *) -open Ocsigen_lib open Ocsigen_socket - open Simplexmlparser open Ocsigen_config @@ -31,7 +29,7 @@ let section = Lwt_log.Section.make "ocsigen:config" let blah_of_string f tag s = try - f (String.remove_spaces s 0 ((String.length s) -1)) + f (Ocsigen_lib.String.remove_spaces s 0 ((String.length s) -1)) with Failure _ -> raise (Ocsigen_config.Config_file_error ("While parsing <"^tag^"> - "^s^ " is not a valid value.")) @@ -77,7 +75,7 @@ let parse_size = let tebi = Int64.mul mebi mebi in fun s -> let l = String.length s in - let s = String.remove_spaces s 0 (l-1) in + let s = Ocsigen_lib.String.remove_spaces s 0 (l-1) in let v l = try Int64.of_string (String.sub s 0 l) diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index 1e589e9c5..2cd5665f6 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -18,17 +18,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Lwt -open Ocsigen_messages -open Ocsigen_socket -open Ocsigen_lib -open Ocsigen_extensions -open Ocsigen_http_frame -open Ocsigen_headers -open Ocsigen_config -open Ocsigen_parseconfig -open Ocsigen_cookies -open Lazy +open Lwt.Infix let () = Random.self_init () @@ -51,12 +41,15 @@ let _ = let warn sockaddr s = Lwt_log.ign_warning_f ~section "While talking to %a:%s" (fun () sockaddr -> - Unix.string_of_inet_addr (ip_of_sockaddr sockaddr)) sockaddr s + Unix.string_of_inet_addr (Ocsigen_socket.ip_of_sockaddr sockaddr)) + sockaddr s + let dbg sockaddr s = Lwt_log.ign_info_f ~section "While talking to %a:%s" (fun () sockaddr -> - Unix.string_of_inet_addr (ip_of_sockaddr sockaddr)) sockaddr s - + Unix.string_of_inet_addr + (Ocsigen_socket.ip_of_sockaddr sockaddr)) + sockaddr s let http_url_syntax = Hashtbl.find Neturl.common_url_syntax "http" @@ -99,7 +92,7 @@ let reload_conf s = try Ocsigen_extensions.start_initialisation (); - parse_server true s; + Ocsigen_parseconfig.parse_server true s; Ocsigen_extensions.end_initialisation (); with e -> @@ -112,13 +105,13 @@ let reload ?file () = (* That function cannot be interrupted??? *) Lwt_log.ign_warning ~section "Reloading config file" ; (try - match parse_config ?file () with + match Ocsigen_parseconfig.parse_config ?file () with | [] -> () | s::_ -> reload_conf s - with e -> errlog (fst (errmsg e))); + with e -> Ocsigen_messages.errlog (fst (errmsg e))); (try - match parse_config ?file () with + match Ocsigen_parseconfig.parse_config ?file () with | [] -> () | s::_ -> reload_conf s with e -> Lwt_log.ign_error ~section (fst (errmsg e))); @@ -153,7 +146,7 @@ let start_server () = try code) loaded from now on will be executed directly. *) Ocsigen_loader.set_init_on_load true; - let config_servers = parse_config () in + let config_servers = Ocsigen_parseconfig.parse_config () in let number_of_servers = List.length config_servers in @@ -242,7 +235,7 @@ let start_server () = try | Some group -> try (Unix.getgrnam group).Unix.gr_gid with Not_found as e -> - errlog ("Error: Wrong group"); + Ocsigen_messages.errlog ("Error: Wrong group"); raise e in @@ -251,12 +244,12 @@ let start_server () = try | Some user -> try (Unix.getpwnam user).Unix.pw_uid with Not_found as e -> - errlog ("Error: Wrong user"); + Ocsigen_messages.errlog ("Error: Wrong user"); raise e in (* A pipe to communicate with the server *) - let commandpipe = get_command_pipe () in + let commandpipe = Ocsigen_config.get_command_pipe () in begin try ignore (Unix.stat commandpipe); @@ -297,7 +290,8 @@ let start_server () = try if maxthreads < minthreads then raise - (Config_file_error "maxthreads should be greater than minthreads"); + (Ocsigen_config.Config_file_error + "maxthreads should be greater than minthreads"); ignore (Ocsigen_config.init_preempt minthreads @@ -310,7 +304,7 @@ let start_server () = try Ocsigen_extensions.start_initialisation (); - parse_server false s; + Ocsigen_parseconfig.parse_server false s; Dynlink_wrapper.prohibit ["Ocsigen_extensions.R"]; (* As libraries are reloaded each time the config file is read, @@ -345,11 +339,11 @@ let start_server () = try (Lwt.catch (fun () -> let prefix, c = - match String.split ~multisep:true ' ' s with + match Ocsigen_lib.String.split ~multisep:true ' ' s with | [] -> raise Ocsigen_command.Unknown_command | a::l -> try - let aa, ab = String.sep ':' a in + let aa, ab = Ocsigen_lib.String.sep ':' a in (Some aa, (ab::l)) with Not_found -> None, (a::l) in @@ -450,9 +444,11 @@ let start_server () = try let rec launch = function | [] -> () | [h] -> - let user_info, sslinfo, threadinfo = extract_info h in + let user_info, sslinfo, threadinfo = + Ocsigen_parseconfig.extract_info h + in (* set_passwd_if_needed sslinfo; *) - if (get_daemon ()) + if Ocsigen_config.get_daemon () then let pid = Unix.fork () in if pid = 0 @@ -474,4 +470,4 @@ let start_server () = try with e -> let msg, errno = errmsg e in - errlog msg; exit errno + Ocsigen_messages.errlog msg; exit errno diff --git a/src/server/ocsigen_socket.ml b/src/server/ocsigen_socket.ml index 729ca8b06..f8570f1ef 100644 --- a/src/server/ocsigen_socket.ml +++ b/src/server/ocsigen_socket.ml @@ -1,5 +1,3 @@ -open Ocsigen_lib - type socket_type = | All | IPv4 of Unix.inet_addr From a9cff8c3c76d5aecc8de3c1d5051fc9f9814226a Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 3 Feb 2017 14:52:55 +0100 Subject: [PATCH 011/111] Improve Ocsigen_cohttp_server.Request - store sub_path - update function - Abstract t type --- src/extensions/accesscontrol.ml | 16 ++++--- src/server/ocsigen_cohttp_server.ml | 64 +++++++++++++++++++--------- src/server/ocsigen_cohttp_server.mli | 29 ++++++------- src/server/ocsigen_extensions.ml | 37 ++++------------ src/server/ocsigen_extensions.mli | 6 --- 5 files changed, 78 insertions(+), 74 deletions(-) diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index 6994a4469..8bf308ed6 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -357,10 +357,14 @@ let parse_config parse_fun = function "Bad syntax for argument of tag allow-forward-for" in if equal_ip || not need_equal_ip then - Ocsigen_extensions.update_ips - ~forward_ip:proxies - request - original_ip + { request + with + Ocsigen_extensions.request_info = + Ocsigen_cohttp_server.Request.update + ~forward_ip:proxies + ~remote_ip:original_ip + request_info + } else (* the announced ip of the proxy is not its real ip *) (Lwt_log.ign_warning_f ~section "X-Forwarded-For: host ip (%s) \ @@ -400,9 +404,9 @@ let parse_config parse_fun = function | Some header -> (match String.lowercase header with | "http" -> - Ocsigen_cohttp_server.Request.set_ssl request_info false + Ocsigen_cohttp_server.Request.update ~ssl:false request_info | "https" -> - Ocsigen_cohttp_server.Request.set_ssl request_info true + Ocsigen_cohttp_server.Request.update ~ssl:true request_info | _ -> Lwt_log.ign_info_f ~section "Malformed X-Forwarded-Proto field: %s" header; diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml index 79a7f3559..3a4e812ec 100644 --- a/src/server/ocsigen_cohttp_server.ml +++ b/src/server/ocsigen_cohttp_server.ml @@ -26,14 +26,14 @@ module Request = struct r_forward_ip : string list ; r_request : Cohttp.Request.t ; r_body : Cohttp_lwt_body.t ; + r_sub_path : string option ; r_waiter : unit Lwt.t ; mutable r_tries : int } let make - ?(forward_ip = []) - ~address ~port ~filenames ~sockaddr ~request ~body ~waiter () - = + ?(forward_ip = []) ?sub_path + ~address ~port ~filenames ~sockaddr ~request ~body ~waiter () = let r_remote_ip = lazy (Unix.string_of_inet_addr @@ -52,10 +52,43 @@ module Request = struct r_forward_ip = forward_ip ; r_request = request ; r_body = body ; + r_sub_path = sub_path ; r_waiter = waiter ; r_tries = 0 } + let update + ?forward_ip ?remote_ip ?ssl ?request + ({ + r_request ; + r_forward_ip ; + r_remote_ip ; + r_remote_ip_parsed + } as r) = + (* FIXME : ssl *) + let r_request = + match request with + | Some request -> + request + | None -> + r_request + and r_forward_ip = + match forward_ip with + | Some forward_ip -> + forward_ip + | None -> + r_forward_ip + and r_remote_ip, r_remote_ip_parsed = + match remote_ip with + | Some remote_ip -> + lazy remote_ip, lazy (Ipaddr.of_string_exn remote_ip) + | None -> + r_remote_ip, r_remote_ip_parsed + in + { r with r_request ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed } + + let request {r_request} = + r_request let address {r_address} = r_address @@ -85,11 +118,14 @@ module Request = struct let path r = Ocsigen_lib.Url.split_path (path_string r) - (* FIXME *) - let sub_path_string = path_string + let sub_path_string = function + | {r_sub_path = Some r_sub_path} -> + r_sub_path + | r -> + path_string r - (* FIXME *) - let sub_path = path + let sub_path r = + Ocsigen_lib.Url.split_path (sub_path_string r) let header {r_request} id = let h = Cohttp.Request.headers r_request in @@ -99,26 +135,16 @@ module Request = struct let h = Cohttp.Request.headers r_request in Cohttp.Header.get_multi h (Http_headers.name_to_string id) - (* let remote_address {r_sockaddr} = *) - (* Ocsigen_socket.ip_of_sockaddr r_sockaddr *) - - (* let remote_ip r = *) - (* Unix.string_of_inet_addr (remote_address r) *) - - (* let remote_ip_parsed r = *) - (* Ipaddr.of_string_exn (remote_ip r) *) - let remote_ip {r_remote_ip} = Lazy.force r_remote_ip let remote_ip_parsed {r_remote_ip_parsed} = Lazy.force r_remote_ip_parsed + let forward_ip {r_forward_ip} = r_forward_ip + let tries {r_tries} = r_tries let incr_tries r = r.r_tries <- r.r_tries + 1 - (* FIXME *) - let set_ssl r _ = r - end module Answer = struct diff --git a/src/server/ocsigen_cohttp_server.mli b/src/server/ocsigen_cohttp_server.mli index 27db0c910..7efffc7c8 100644 --- a/src/server/ocsigen_cohttp_server.mli +++ b/src/server/ocsigen_cohttp_server.mli @@ -12,22 +12,11 @@ end module Request : sig - type t = { - r_address : Unix.inet_addr ; - r_port : int ; - r_filenames : string list ref ; - r_sockaddr : Lwt_unix.sockaddr ; - r_remote_ip : string Lazy.t ; - r_remote_ip_parsed : Ipaddr.t Lazy.t ; - r_forward_ip : string list ; - r_request : Cohttp.Request.t ; - r_body : Cohttp_lwt_body.t ; - r_waiter : unit Lwt.t ; - mutable r_tries : int - } + type t val make : ?forward_ip : string list -> + ?sub_path : string -> address : Unix.inet_addr -> port : int -> filenames : string list ref -> @@ -38,6 +27,16 @@ module Request : sig unit -> t + val update : + ?forward_ip : string list -> + ?remote_ip : string -> + ?ssl : bool -> + ?request : Cohttp.Request.t -> + t -> + t + + val request : t -> Cohttp.Request.t + val address : t -> Unix.inet_addr val host : t -> string option @@ -68,12 +67,12 @@ module Request : sig val remote_ip_parsed : t -> Ipaddr.t + val forward_ip : t -> string list + val tries : t -> int val incr_tries : t -> unit - val set_ssl : t -> bool -> t - end module Answer : sig diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index d550c00f2..bdc51cd72 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -269,41 +269,22 @@ let set_hosts v = hosts := v let get_hosts () = !hosts let update_path - { request_info = - ({ S.Request.r_request } - as request_info); - request_config } + { request_info ; request_config } path = + let r = Ocsigen_cohttp_server.Request.request request_info in let request_info = - let r_request = - let meth = Cohttp.Request.meth r_request - and version = Cohttp.Request.version r_request - and encoding = Cohttp.Request.encoding r_request - and headers = Cohttp.Request.headers r_request - and uri = Uri.with_path (Cohttp.Request.uri r_request) path in + let request = + let meth = Cohttp.Request.meth r + and version = Cohttp.Request.version r + and encoding = Cohttp.Request.encoding r + and headers = Cohttp.Request.headers r + and uri = Uri.with_path (Cohttp.Request.uri r) path in Cohttp.Request.make ~meth ~version ~encoding ~headers uri in - { request_info with S.Request.r_request } + Ocsigen_cohttp_server.Request.update ~request request_info in { request_info ; request_config } -let update_ips ?forward_ip { request_info ; request_config } s = - let r_forward_ip = - match forward_ip with - | Some forward_ip -> - forward_ip - | None -> - request_info.r_forward_ip - in - { request_info = - { request_info with - r_remote_ip = lazy s ; - r_remote_ip_parsed = lazy (Ipaddr.of_string_exn s) ; - r_forward_ip - } ; - request_config - } - (* Default hostname is either the Host header or the hostname set in the configuration file. *) let get_hostname {request_info ; request_config = {default_hostname}} = diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index fd3f2a4fa..1f534ff4a 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -445,12 +445,6 @@ val set_hosts : (virtual_hosts * config_info * extension2) list -> unit val get_hosts : unit -> (virtual_hosts * config_info * extension2) list -val update_ips : - ?forward_ip : string list -> - request -> - string -> - request - (** Compute the answer to be sent to the client, by trying all extensions according the configuration file. *) val compute_result : From f37b1ef4bd7d2096dcb010ae6ea26533104b2d4d Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 3 Feb 2017 16:28:10 +0100 Subject: [PATCH 012/111] Implement Ocsigen_cohttp_server.Request.update_url - Replaces old ri_of_url - Untested --- src/extensions/rewritemod.ml | 12 +++++++----- src/server/ocsigen_cohttp_server.ml | 13 +++++++++++++ src/server/ocsigen_cohttp_server.mli | 6 ++++++ src/server/ocsigen_extensions.ml | 4 ---- src/server/ocsigen_extensions.mli | 2 -- 5 files changed, 26 insertions(+), 11 deletions(-) diff --git a/src/extensions/rewritemod.ml b/src/extensions/rewritemod.ml index e2266aece..575557a4d 100644 --- a/src/extensions/rewritemod.ml +++ b/src/extensions/rewritemod.ml @@ -66,19 +66,21 @@ let gen regexp continue = function Lwt.return @@ Ocsigen_extensions.Ext_continue_with ({ ri with Ocsigen_extensions.request_info = - Ocsigen_extensions.ri_of_url + Ocsigen_cohttp_server.Request.update_url ~full_rewrite - redir - ri.Ocsigen_extensions.request_info }, + (Uri.of_string redir) + ri.Ocsigen_extensions.request_info + }, Ocsigen_cookies.Cookies.empty, err) else Lwt.return @@ Ocsigen_extensions.Ext_retry_with ({ ri with Ocsigen_extensions.request_info = - Ocsigen_extensions.ri_of_url + Ocsigen_cohttp_server.Request.update_url ~full_rewrite - redir ri.Ocsigen_extensions.request_info }, + (Uri.of_string redir) + ri.Ocsigen_extensions.request_info }, Ocsigen_cookies.Cookies.empty) and catch_block = function | Ocsigen_extensions.Not_concerned -> diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml index 3a4e812ec..ce76e4287 100644 --- a/src/server/ocsigen_cohttp_server.ml +++ b/src/server/ocsigen_cohttp_server.ml @@ -31,6 +31,9 @@ module Request = struct mutable r_tries : int } + (* FIXME: old ocsigenserver used to store original_full_path. Do we + really need that? *) + let make ?(forward_ip = []) ?sub_path ~address ~port ~filenames ~sockaddr ~request ~body ~waiter () = @@ -87,6 +90,16 @@ module Request = struct in { r with r_request ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed } + let update_url ?(full_rewrite = false) url ({r_request} as r) = + let r_request = + let meth = Cohttp.Request.meth r_request + and version = Cohttp.Request.version r_request + and encoding = Cohttp.Request.encoding r_request + and headers = Cohttp.Request.headers r_request in + Cohttp.Request.make ~meth ~version ~encoding ~headers url + and r_sub_path = None in + { r with r_request ; r_sub_path } + let request {r_request} = r_request diff --git a/src/server/ocsigen_cohttp_server.mli b/src/server/ocsigen_cohttp_server.mli index 7efffc7c8..6a3672320 100644 --- a/src/server/ocsigen_cohttp_server.mli +++ b/src/server/ocsigen_cohttp_server.mli @@ -35,6 +35,12 @@ module Request : sig t -> t + val update_url : + ?full_rewrite : bool -> + Uri.t -> + t -> + t + val request : t -> Cohttp.Request.t val address : t -> Unix.inet_addr diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index bdc51cd72..d40d65bdc 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -1052,7 +1052,3 @@ let find_redirection regexp full_url dest r = Netstring_pcre.string_match regexp path 0 >|! fun _ -> (* Matching regexp found! *) Netstring_pcre.global_replace regexp dest path - -(* FIXME COHTTP TRANSITION DUMMY *) -let ri_of_url ~full_rewrite _ request_info = - request_info diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 1f534ff4a..5e752235a 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -473,5 +473,3 @@ val set_config : Simplexmlparser.xml list -> unit val sockets : Lwt_unix.file_descr list ref val sslsockets : Lwt_unix.file_descr list ref - -val ri_of_url : full_rewrite:'a -> 'b -> 'c -> 'c From fbb54f328cfe299aa7646da6b1c13a9ee59397bf Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 3 Feb 2017 16:32:10 +0100 Subject: [PATCH 013/111] Remove extensiontemplate (to be re-added with new APIs) --- src/Makefile.filelist | 1 - src/extensions/.depend | 4 - src/extensions/Makefile | 1 - src/extensions/extensiontemplate.ml | 210 ---------------------------- 4 files changed, 216 deletions(-) delete mode 100644 src/extensions/extensiontemplate.ml diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 383f06e96..a9a0acbbd 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -64,7 +64,6 @@ PLUGINS_IMPL := extensions/staticmod.cmo \ extensions/redirectmod.cmo # extensions/cgimod.cmo \ # extensions/revproxy.cmo \ - # extensions/extensiontemplate.cmo \ # extensions/accesscontrol.cmo \ # extensions/userconf.cmo \ # extensions/outputfilter.cmo \ diff --git a/src/extensions/.depend b/src/extensions/.depend index 529e92622..7ea282035 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -48,10 +48,6 @@ extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ extendconfiguration.cmx : ../server/ocsigen_parseconfig.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx ../http/ocsigen_charset_mime.cmx -extensiontemplate.cmo : ../http/ocsigen_senders.cmi \ - ../server/ocsigen_extensions.cmi -extensiontemplate.cmx : ../http/ocsigen_senders.cmx \ - ../server/ocsigen_extensions.cmx ocsigen_comet.cmo : ../baselib/ocsigen_stream.cmi \ ../server/ocsigen_request_info.cmi ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_http_frame.cmi ../server/ocsigen_extensions.cmi \ diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 0c2cadc67..aa9b20016 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -26,7 +26,6 @@ FILES := accesscontrol.ml authbasic.ml cors.ml outputfilter.ml \ redirectmod.ml rewritemod.ml staticmod.ml # cgimod.ml \ # revproxy.ml \ - # extensiontemplate.ml \ # userconf.ml \ # extendconfiguration.ml \ # ocsigen_comet.ml \ diff --git a/src/extensions/extensiontemplate.ml b/src/extensions/extensiontemplate.ml deleted file mode 100644 index 80edff9f8..000000000 --- a/src/extensions/extensiontemplate.ml +++ /dev/null @@ -1,210 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * Module extensiontemplate.ml - * Copyright (C) 2007 Vincent Balat - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) -(*****************************************************************************) -(*****************************************************************************) -(* This is an example of extension for Ocsigen *) -(* Take this as a template for writing your own extensions to the Web server *) -(*****************************************************************************) -(*****************************************************************************) - -(* If you want to create an extension to filter the output of the server - (for ex: compression), have a look at deflatemod.ml as an example. - It is very similar to this example, but using - Ocsigen_extensions.register_output_filter - instead of Ocsigen_extensions.register_extension. -*) - -(* To compile it: - ocamlfind ocamlc -thread -package netstring-pcre,ocsigen -c extensiontemplate.ml - - Then load it dynamically from Ocsigen's config file: - - -*) - -open Lwt -open Ocsigen_extensions -open Simplexmlparser - - - -(*****************************************************************************) -(** Extensions may take some options from the config file. - These options are written in xml inside the tag. - For example: - - - ... - - -*) - -let rec parse_global_config = function - | [] -> () - | (Element ("myoption", [("myattr", s)], []))::ll -> () - | _ -> raise (Error_in_config_file - ("Unexpected content inside extensiontemplate config")) - - - -(*****************************************************************************) -(** The function that will generate the pages from the request, or modify - a result generated by another extension. - - - a value of type [Ocsigen_extensions.conf_info] containing - the current configuration options - - [Ocsigen_extensions.req_state] is the request, possibly modified by previous - extensions, or already found - -*) -let gen = function - | Ocsigen_extensions.Req_found _ -> - (* If previous extension already found the page, you can - modify the result (if you write a filter) or return it - without modification like this: *) - Lwt.return Ocsigen_extensions.Ext_do_nothing - | Ocsigen_extensions.Req_not_found (err, ri) -> - (* If previous extensions did not find the result, - I decide here to answer with a default page - (for the example): - *) - return (Ext_found - (fun () -> - let content = "Extensiontemplate page" in - Ocsigen_senders.Text_content.result_of_content - (content, "text/plain"))) - - - -(*****************************************************************************) -(** Extensions may define new tags for configuring each site. - These tags are inside ... in the config file. - - For example: - - - - - Each extension will set its own configuration options, for example: - - - - - - - Here parse_site is the function used to parse the config file inside this - site. Use this if you want to put extensions config options inside - your own option. For example: - - {[ - | Element ("iffound", [], sub) -> - let ext = parse_fun sub in - (* DANGER: parse_fun MUST be called BEFORE the function! *) - (fun charset -> function - | Ocsigen_extensions.Req_found (_, _) -> - Lwt.return (Ext_sub_result ext) - | Ocsigen_extensions.Req_not_found (err, ri) -> - Lwt.return (Ocsigen_extensions.Ext_not_found err)) - ]} -*) - -let parse_config path _ parse_site = function - | Element ("extensiontemplate", atts, []) -> gen - | Element (t, _, _) -> raise (Bad_config_tag_for_extension t) - | _ -> - raise (Error_in_config_file "Unexpected data in config file") - - - - -(*****************************************************************************) -(** Function to be called at the beginning of the initialisation phase - of the server (actually each time the config file is reloaded) *) -let begin_init () = - () - -(** Function to be called at the end of the initialisation phase *) -let end_init () = - () - - - -(*****************************************************************************) -(** A function that will create an error message from the exceptions - that may be raised during the initialisation phase, and raise again - all other exceptions. That function has type exn -> string. Use the - raise function if you don't need any. *) -let exn_handler = raise - - - - -(*****************************************************************************) -(* a function taking - {ul - {- the name of the virtual }} - that will be called for each , - and that will generate a function taking: - {ul - {- the path attribute of a tag - that will be called for each , - and that will generate a function taking:}} - {ul - {- an item of the config file - that will be called on each tag inside and:} - {ul - {- raise [Bad_config_tag_for_extension] if it does not recognize that tag} - {- return something of type [extension] (filter or page generator)}} -*) -let site_creator - (hostpattern : Ocsigen_extensions.virtual_hosts) - (config_info : Ocsigen_extensions.config_info) - = parse_config -(* hostpattern has type Ocsigen_extensions.virtual_hosts - and represents the name of the virtual host. - The path and the charset are declared in -*) - - -(* Same thing if the extension is loaded inside a local config - file (using the userconf extension). However, we receive - one additional argument, the root of the files the user - can locally serve. See staticmod and userconf for details *) -let user_site_creator (path : Ocsigen_extensions.userconf_info) = site_creator - -(*****************************************************************************) -(** Registration of the extension *) -let () = register_extension - ~name:"extensionname" - ~fun_site:site_creator - - (* If your extension is safe for users and if you want to allow - exactly the same options as for global configuration, use the same - [site_creator] function for [user_fun_site] as for [fun_site]. - - If you don't want to allow users to use that extension in their - configuration files, you can omit user_fun_site. - *) - ~user_fun_site:user_site_creator - ~init_fun: parse_global_config - - ~begin_init ~end_init ~exn_handler - () - From c49cde7dffa694f6d510e744fb4f505d1d43a06f Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 3 Feb 2017 16:57:22 +0100 Subject: [PATCH 014/111] Fix installation of extensions --- src/Makefile.filelist | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/src/Makefile.filelist b/src/Makefile.filelist index a9a0acbbd..a7ca5ad54 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -54,23 +54,15 @@ endif PLUGINS_BIN := -PLUGINS_INTF := extensions/authbasic.cmi +PLUGINS_INTF := extensions/authbasic.cmi extensions/accesscontrol.cmi # extensions/ocsigen_comet.cmi \ # extensions/accesscontrol.cmi \ # extensions/ocsipersist.cmi \ -PLUGINS_IMPL := extensions/staticmod.cmo \ - extensions/authbasic.cmo \ - extensions/redirectmod.cmo - # extensions/cgimod.cmo \ - # extensions/revproxy.cmo \ - # extensions/accesscontrol.cmo \ - # extensions/userconf.cmo \ - # extensions/outputfilter.cmo \ - # extensions/rewritemod.cmo \ - # extensions/extendconfiguration.cmo \ - # extensions/ocsigen_comet.cmo \ - # extensions/cors.cmo \ +PLUGINS_IMPL := extensions/accesscontrol.cmo extensions/authbasic.cmo \ + extensions/cors.cmo extensions/outputfilter.cmo \ + extensions/redirectmod.cmo extensions/rewritemod.cmo \ + extensions/staticmod.cmo ifeq "$(CAMLZIP)" "YES" PLUGINS_IMPL += extensions/deflatemod.cmo From 179a50e29266f2a0b58dd9f073edc68b4cbae2f0 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 3 Feb 2017 17:19:27 +0100 Subject: [PATCH 015/111] Ocsigen_cohttp_server: handle errors --- src/server/ocsigen_cohttp_server.ml | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml index ce76e4287..dda22fbd1 100644 --- a/src/server/ocsigen_cohttp_server.ml +++ b/src/server/ocsigen_cohttp_server.ml @@ -381,15 +381,29 @@ let handler ~address ~port ~connector (flow, conn) request body = !filenames; (* TODO: equivalent of Ocsigen_range *) + (* TODO: handle cookies *) - connector - (Request.make - ~address ~port ~filenames ~sockaddr ~request ~body ~waiter ()) - >>= fun { Answer.a_response ; a_body } -> + let request = + Request.make + ~address ~port ~filenames ~sockaddr ~request ~body ~waiter + () - (* TODO: handle cookies *) + in - Lwt.return (a_response, a_body) + Lwt.catch + (fun () -> + connector request >>= fun { Answer.a_response ; a_body } -> + Lwt.return (a_response, a_body)) + (function + | Ocsigen_Is_a_directory fun_request -> + Cohttp_lwt_unix.Server.respond_redirect + ~uri: + (fun_request request + |> Neturl.string_of_url + |> Uri.of_string) + () + | exn -> + handle_error exn) let conn_closed (flow, conn) = try let wakener = Hashtbl.find waiters conn in From a29e386950fd2075976a2e9325706b57b5e2d8a9 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 3 Feb 2017 18:39:28 +0100 Subject: [PATCH 016/111] Use Cohttp types in Ocsigen_http_client API Do not translate back and forth. Do we really need this module? It doesn't do much on top of Cohttp_lwt_unix.Client. --- src/server/ocsigen_http_client.ml | 54 +++++++++++++++++------------- src/server/ocsigen_http_client.mli | 31 +++++++++-------- 2 files changed, 46 insertions(+), 39 deletions(-) diff --git a/src/server/ocsigen_http_client.ml b/src/server/ocsigen_http_client.ml index fe3a6f9d0..ad98ac286 100644 --- a/src/server/ocsigen_http_client.ml +++ b/src/server/ocsigen_http_client.ml @@ -4,59 +4,67 @@ let target https host ?port uri = let scheme = if https then "https" else "http" in Uri.resolve scheme (Uri.make ~scheme ~host ?port ()) (Uri.of_string uri) -let post_string ?(https = false) ?port ?(headers = Http_headers.empty) +let post_string ?(https = false) ?port ?(headers = Cohttp.Header.init ()) ~host ~uri ~content ~content_type () = - let content_type = String.concat "/" [fst content_type; snd content_type] in - let ( |> ) a f = f a in + let content_type = + String.concat "/" [ + fst content_type; + snd content_type + ] + in let headers = + let add n v m = + Cohttp.Header.add m + (Http_headers.name_to_string n) + v + in headers - |> Http_headers.add Http_headers.content_type content_type - |> Http_headers.add Http_headers.content_length - (string_of_int (String.length content)) - |> To_cohttp.to_headers in + |> add Http_headers.content_type content_type + |> add Http_headers.content_length (string_of_int (String.length content)) + in Cohttp_lwt_unix.Client.post ~body:(Cohttp_lwt_body.of_string content) ~headers (target https host ?port uri) - >|= Of_cohttp.of_response_and_body' let get ?(https = false) ?port ?headers ~host ~uri () = Cohttp_lwt_unix.Client.get ?headers (target https host ?port uri) - >|= Of_cohttp.of_response_and_body' let post_urlencoded ?https ?port ?headers ~host ~uri ~content () = post_string ?https ?port ?headers ~host ~uri ~content:(Netencoding.Url.mk_url_encoded_parameters content) - ~content_type:("application","x-www-form-urlencoded") + ~content_type:("application", "x-www-form-urlencoded") () let basic_raw_request - ?(headers = Http_headers.empty) ?(https=false) ?port + ?(headers = Http_headers.empty) ?(https = false) ?port ~content ?content_length - ~http_method ~host ~inet_addr ~uri () = + ~meth ~host ~inet_addr ~uri () = ignore inet_addr; let headers = match content_length with - Some len -> Http_headers.add Http_headers.content_length - (Int64.to_string len) headers - | None -> headers + | Some len -> + Cohttp.Header.add headers + Http_headers.(name_to_string content_length) + (Int64.to_string len) + | None -> + headers in let body = match content with - Some c -> - Some (Cohttp_lwt_body.of_stream (Ocsigen_stream.to_lwt_stream c)) + | Some c -> + Some (Cohttp_lwt_body.of_stream (Ocsigen_stream.to_lwt_stream c)) | None -> - None + None in - Cohttp_lwt_unix.Client.call ~headers ?body - (To_cohttp.to_meth http_method) (target https host ?port uri) - >|= Of_cohttp.of_response_and_body' + Cohttp_lwt_unix.Client.call ~headers ?body meth + (target https host ?port uri) let raw_request ?keep_alive ?headers ?https ?port - ~content ?content_length ~http_method ~host ~inet_addr ~uri () () = + ~content ?content_length ~meth ~host ~inet_addr ~uri () () = ignore keep_alive; basic_raw_request ?headers ?https ?port ~content ?content_length - ~http_method ~host ~inet_addr ~uri () + ~meth ~host ~inet_addr ~uri () diff --git a/src/server/ocsigen_http_client.mli b/src/server/ocsigen_http_client.mli index 3636522b9..7447f269a 100644 --- a/src/server/ocsigen_http_client.mli +++ b/src/server/ocsigen_http_client.mli @@ -1,19 +1,18 @@ (** Using Ocsigen as a HTTP client *) (** Do a GET HTTP request. + The default port is 80 for HTTP, 443 for HTTPS. - The default protocol is http ([https=false]). - Warning: the stream must be finalized manually after reading, using - {!Ocsigen_stream.finalize}, otherwise you will have fd leaks. -*) + + The default protocol is http ([https=false]). *) val get : ?https: bool -> ?port:int -> - ?headers: Http_headers.t -> + ?headers: Cohttp.Header.t -> host:string -> uri:string -> unit -> - Ocsigen_http_frame.t Lwt.t + (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t (** Do a POST HTTP request. The default port is 80 for HTTP, 443 for HTTPS. @@ -24,13 +23,13 @@ val get : val post_string : ?https: bool -> ?port:int -> - ?headers: Http_headers.t -> + ?headers: Cohttp.Header.t -> host:string -> uri:string -> content:string -> content_type:(string * string) -> unit -> - Ocsigen_http_frame.t Lwt.t + (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t (** Do a POST HTTP request with URL encoded parameters as content. The default port is 80 for HTTP, 443 for HTTPS. @@ -41,27 +40,27 @@ val post_string : val post_urlencoded : ?https: bool -> ?port:int -> - ?headers: Http_headers.t -> + ?headers: Cohttp.Header.t -> host:string -> uri:string -> content:(string * string) list -> unit -> - Ocsigen_http_frame.t Lwt.t + (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t val raw_request : ?keep_alive: bool -> - ?headers: Http_headers.t -> + ?headers: Cohttp.Header.t -> ?https: bool -> ?port:int -> content: string Ocsigen_stream.t option -> ?content_length: int64 -> - http_method: Ocsigen_http_frame.Http_header.http_method -> + meth:Cohttp.Code.meth -> host:string -> inet_addr:Unix.inet_addr -> uri:string -> unit -> unit -> - Ocsigen_http_frame.t Lwt.t + (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t (** Do an HTTP request (low level). @@ -79,17 +78,17 @@ val raw_request : *) val basic_raw_request : - ?headers: Http_headers.t -> + ?headers: Cohttp.Header.t -> ?https: bool -> ?port:int -> content: string Ocsigen_stream.t option -> ?content_length: int64 -> - http_method: Ocsigen_http_frame.Http_header.http_method -> + meth:Cohttp.Code.meth -> host:string -> inet_addr:Unix.inet_addr -> uri:string -> unit -> - Ocsigen_http_frame.t Lwt.t + (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t (** Same as {!Ocsigen_http_client.raw_request}, but does not try to reuse connections. Opens a new connections for each request. Far less efficient. From e986ef6fa01e2a56626bde294ca9d64d7edba209 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 6 Feb 2017 14:45:55 +0100 Subject: [PATCH 017/111] Compile revproxy against Cohttp --- src/Makefile.filelist | 4 +- src/extensions/.depend | 8 +- src/extensions/Makefile | 3 +- src/extensions/revproxy.ml | 320 +++++++++------------------ src/server/ocsigen_cohttp_server.ml | 6 + src/server/ocsigen_cohttp_server.mli | 7 + 6 files changed, 121 insertions(+), 227 deletions(-) diff --git a/src/Makefile.filelist b/src/Makefile.filelist index a7ca5ad54..40955655f 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -61,8 +61,8 @@ PLUGINS_INTF := extensions/authbasic.cmi extensions/accesscontrol.cmi PLUGINS_IMPL := extensions/accesscontrol.cmo extensions/authbasic.cmo \ extensions/cors.cmo extensions/outputfilter.cmo \ - extensions/redirectmod.cmo extensions/rewritemod.cmo \ - extensions/staticmod.cmo + extensions/redirectmod.cmo extensions/revproxy.cmo \ + extensions/rewritemod.cmo extensions/staticmod.cmo ifeq "$(CAMLZIP)" "YES" PLUGINS_IMPL += extensions/deflatemod.cmo diff --git a/src/extensions/.depend b/src/extensions/.depend index 7ea282035..15f142839 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -64,12 +64,12 @@ outputfilter.cmx : \ ../http/http_headers.cmx redirectmod.cmo : ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi redirectmod.cmx : ../baselib/ocsigen_lib.cmx ../server/ocsigen_extensions.cmx -revproxy.cmo : ../migrate/of_cohttp.cmi ../baselib/ocsigen_stream.cmi \ - ../server/ocsigen_request_info.cmi ../baselib/ocsigen_lib.cmi \ +revproxy.cmo : ../baselib/ocsigen_stream.cmi \ + ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_http_frame.cmi ../http/ocsigen_headers.cmi \ ../server/ocsigen_extensions.cmi -revproxy.cmx : ../migrate/of_cohttp.cmx ../baselib/ocsigen_stream.cmx \ - ../server/ocsigen_request_info.cmx ../baselib/ocsigen_lib.cmx \ +revproxy.cmx : ../baselib/ocsigen_stream.cmx \ + ../baselib/ocsigen_lib.cmx \ ../http/ocsigen_http_frame.cmx ../http/ocsigen_headers.cmx \ ../server/ocsigen_extensions.cmx rewritemod.cmo : \ diff --git a/src/extensions/Makefile b/src/extensions/Makefile index aa9b20016..e87457967 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -23,9 +23,8 @@ all: byte opt ### Extensions ### FILES := accesscontrol.ml authbasic.ml cors.ml outputfilter.ml \ - redirectmod.ml rewritemod.ml staticmod.ml + redirectmod.ml revproxy.ml rewritemod.ml staticmod.ml # cgimod.ml \ - # revproxy.ml \ # userconf.ml \ # extendconfiguration.ml \ # ocsigen_comet.ml \ diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index c1ef7f588..0ffee76bc 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -16,274 +16,158 @@ * You should have received a copy of the GNU Lesser 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. -*) + *) -(** Reverse proxy for Ocsigen *) +(** Reverse proxy for Ocsigen -(* - The reverse proxy is still experimental because it relies on the - experimental Ocsigen_http_client module. + The reverse proxy is still experimental because it relies on the + experimental Ocsigen_http_client module. - TODO - - Change the policy for trusted servers for pipelining? - (see ocsigen_http_client.ml) - - enhance pipelining - - HTTP/1.0 - - ... + TODO + - Change the policy for trusted servers for pipelining? + (see ocsigen_http_client.ml) + - enhance pipelining + - HTTP/1.0 + - ... + Enable returning for example (Ext_next 404) to allow other + extensions to take the request? There is a problem if the body + contains data (POST request) ... this data has been sent and is + lost ... *) - - Make possible to return for example (Ext_next 404) to allow - other extensions to take the request? - There is a problem if the body contains data (POST request) ... - this data has been sent and is lost ... -*) - -open Ocsigen_lib - -open Lwt +open Lwt.Infix open Ocsigen_extensions open Simplexmlparser open Cohttp open Cohttp_lwt_unix -module RI = Ocsigen_request_info - let section = Lwt_log.Section.make "ocsigen:ext:revproxy" exception Bad_answer_from_http_server +(** The table of redirections for each virtual server *) +type redir = { + regexp : Netstring_pcre.regexp ; + full_url : Ocsigen_lib.yesnomaybe ; + dest : string ; + pipeline : bool ; + keephost : bool +} -(*****************************************************************************) -(* The table of redirections for each virtual server *) -type redir = - { regexp: Netstring_pcre.regexp; - full_url: yesnomaybe; - dest: string; - pipeline: bool; - keephost: bool} - - -(*****************************************************************************) -(* Finding redirections *) - - -(** The function that will generate the pages from the request. *) - +(** Generate the pages from the request *) let gen dir = function | Ocsigen_extensions.Req_found _ -> Lwt.return Ocsigen_extensions.Ext_do_nothing -| Ocsigen_extensions.Req_not_found (err, ri) -> - catch - (* Is it a redirection? *) - (fun () -> - Lwt_log.ign_info ~section "Is it a redirection?"; - let dest = - let ri = ri.request_info in - let fi full = - Ocsigen_extensions.find_redirection - dir.regexp - full - dir.dest - (Ocsigen_request_info.ssl ri) - (Ocsigen_request_info.host ri) - (Ocsigen_request_info.server_port ri) - (Ocsigen_request_info.get_params_string ri) - (Ocsigen_request_info.sub_path_string ri) - (Ocsigen_request_info.full_path_string ri) - in - match dir.full_url with - | Yes -> fi true - | No -> fi false - | Maybe -> + | Ocsigen_extensions.Req_not_found (err, {request_info}) -> + Lwt.catch + (* Is it a redirection? *) + (fun () -> + Lwt_log.ign_info ~section "Is it a redirection?"; + let dest = + let fi full = + Ocsigen_extensions.find_redirection + dir.regexp + full + dir.dest + request_info + in + match dir.full_url with + | Ocsigen_lib.Yes -> fi true + | Ocsigen_lib.No -> fi false + | Ocsigen_lib.Maybe -> try fi false with Ocsigen_extensions.Not_concerned -> fi true in let (https, host, port, uri) = try - match Url.parse dest with + match Ocsigen_lib.Url.parse dest with | (Some https, Some host, port, uri, _, _, _) -> let port = match port with | None -> if https then 443 else 80 | Some p -> p in (https, host, port, uri) - | _ -> raise (Ocsigen_extensions.Error_in_config_file - ("Revproxy : error in destination URL "^dest)) + | _ -> + raise (Ocsigen_extensions.Error_in_config_file + ("Revproxy : error in destination URL "^dest)) (*VVV catch only Neturl exceptions! *) - with e -> raise (Ocsigen_extensions.Error_in_config_file - ("Revproxy : error in destination URL "^dest^" - "^ - Printexc.to_string e)) - in - let uri = "/"^uri in - Lwt_log.ign_info_f ~section - "YES! Redirection to http%s://%s:%d%s" - (if https then "s" else "") host port uri; + with e -> + raise (Ocsigen_extensions.Error_in_config_file + ("Revproxy : error in destination URL "^dest^" - "^ + Printexc.to_string e)) + in + let uri = "/"^uri in + Lwt_log.ign_info_f ~section + "YES! Redirection to http%s://%s:%d%s" + (if https then "s" else "") host port uri; - Ip_address.get_inet_addr host >>= fun inet_addr -> + Ocsigen_lib.Ip_address.get_inet_addr host >>= fun inet_addr -> (* It is now safe to start processing next request. - We are sure that the request won't be taken in disorder. - => We return. - *) + + We are sure that the request won't be taken in disorder, + so we return. *) let host = match - if dir.keephost - then match Ocsigen_request_info.host ri.request_info with - | Some h -> Some h - | None -> None - else None + if dir.keephost then + Ocsigen_cohttp_server.Request.host request_info + else + None with | Some h -> h | None -> host in let do_request () = - let ri = ri.request_info in - let address = Unix.string_of_inet_addr (fst (get_server_address ri)) in + let address = + Unix.string_of_inet_addr + (Ocsigen_cohttp_server.Request.address request_info) + in let forward = String.concat ", " - ((Ocsigen_request_info.remote_ip ri) - :: ((Ocsigen_request_info.forward_ip ri) - @ [address])) + (Ocsigen_cohttp_server.Request.remote_ip request_info + :: Ocsigen_cohttp_server.Request.forward_ip request_info + @ [address]) in let proto = - if Ocsigen_request_info.ssl ri - then "https" - else "http" + if Ocsigen_cohttp_server.Request.ssl request_info then + "https" + else + "http" in -(* - let headers = - Http_headers.replace - Http_headers.x_forwarded_proto - proto - (Http_headers.replace - Http_headers.x_forwarded_for - forward - ((Ocsigen_request_info.http_frame ri) - .Ocsigen_http_frame.frame_header - .Ocsigen_http_frame.Http_header.headers)) in - if dir.pipeline then - Ocsigen_http_client.raw_request - ~headers - ~https - ~port - ~client:(Ocsigen_request_info.client ri) - ~keep_alive:true - ~content: - (Ocsigen_request_info.http_frame ri) - .Ocsigen_http_frame.frame_content - ?content_length:(Ocsigen_request_info.content_length ri) - ~http_method:(Ocsigen_request_info.meth ri) - ~host - ~inet_addr - ~uri () - else - fun () -> - Ocsigen_http_client.basic_raw_request - ~headers - ~https - ~port - ~content: - (Ocsigen_request_info.http_frame ri) - .Ocsigen_http_frame.frame_content - ?content_length:(Ocsigen_request_info.content_length ri) - ~http_method:(Ocsigen_request_info.meth ri) - ~host - ~inet_addr - ~uri () -*) - - let (meth, version, headers, uri', body) = - Ocsigen_generate.to_cohttp_request ri in - let headers = - Cohttp.Header.add headers - "X-Forwarded-Proto" - (Cohttp.Code.string_of_version version) in let headers = - Cohttp.Header.add headers - "X-Forwarded-For" - forward in - let headers = Cohttp.Header.remove headers "host" in - let uri = Printf.sprintf "%s://%s%s" - proto host uri in + let h = + Cohttp.Request.headers + (Ocsigen_cohttp_server.Request.request request_info) + in + let h = + Ocsigen_cohttp_server.Request.version request_info + |> Cohttp.Code.string_of_version + |> Cohttp.Header.add h Http_headers.(name_to_string + x_forwarded_proto) + in + let h = + Cohttp.Header.add h + Http_headers.(name_to_string x_forwarded_for) + forward + in + Cohttp.Header.remove h Http_headers.(name_to_string host) + and uri = Printf.sprintf "%s://%s%s" proto host uri + and body = Ocsigen_cohttp_server.Request.body request_info + and meth = Ocsigen_cohttp_server.Request.meth request_info in Client.call ~headers ~body meth (Uri.of_string uri) in - Lwt.return - (Ext_found - (fun () -> - do_request () - - >|= Of_cohttp.of_response_and_body' - >>= fun http_frame -> - let headers = - http_frame - .Ocsigen_http_frame.frame_header - .Ocsigen_http_frame.Http_header.headers - in - let code = - match - http_frame - .Ocsigen_http_frame.frame_header - .Ocsigen_http_frame.Http_header.mode - with - | Ocsigen_http_frame.Http_header.Answer code -> code - | _ -> raise Bad_answer_from_http_server - in - match http_frame.Ocsigen_http_frame.frame_content with - | None -> - let empty_result = Ocsigen_http_frame.Result.empty () in - let length = - Ocsigen_headers.get_content_length http_frame - in - Ocsigen_stream.add_finalizer - (fst (Ocsigen_http_frame.Result.stream empty_result)) - (fun outcome -> - match outcome with - `Failure -> - http_frame.Ocsigen_http_frame.frame_abort () - | `Success -> - Lwt.return ()); - Lwt.return - (Ocsigen_http_frame.Result.update empty_result - ~content_length:length - ~headers - ~code ()) - | Some stream -> - let default_result = - Ocsigen_http_frame.Result.default () - in - let length = - Ocsigen_headers.get_content_length http_frame - in - Ocsigen_stream.add_finalizer stream - (fun outcome -> - match outcome with - `Failure -> - http_frame.Ocsigen_http_frame.frame_abort () - | `Success -> - Lwt.return ()); - Lwt.return - (Ocsigen_http_frame.Result.update default_result - ~content_length:length - ~stream:(stream, None) - ~headers - ~code ()) - ) - ) - ) + Lwt.return @@ Ext_found (fun () -> + do_request () >|= + Ocsigen_cohttp_server.Answer.of_cohttp)) (function - | Not_concerned -> return (Ext_next err) - | e -> fail e) - - - - -(*****************************************************************************) + | Not_concerned -> Lwt.return (Ext_next err) + | e -> Lwt.fail e) let parse_config config_elem = let regexp = ref None in - let full_url = ref Yes in + let full_url = ref Ocsigen_lib.Yes in let dest = ref None in let pipeline = ref true in let keephost = ref false in @@ -299,17 +183,17 @@ let parse_config config_elem = ~name:"regexp" (fun s -> regexp := Some s; - full_url := Yes); + full_url := Ocsigen_lib.Yes); Configuration.attribute ~name:"fullurl" (fun s -> regexp := Some s; - full_url := Yes); + full_url := Ocsigen_lib.Yes); Configuration.attribute ~name:"suburl" (fun s -> regexp := Some s; - full_url := No); + full_url := Ocsigen_lib.No); Configuration.attribute ~name:"dest" (fun s -> dest := Some s); @@ -339,8 +223,6 @@ let parse_config config_elem = keephost; } -(*****************************************************************************) -(** Registration of the extension *) let () = register_extension ~name:"revproxy" ~fun_site:(fun _ _ _ _ _ -> parse_config) diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml index dda22fbd1..6ca5f9d74 100644 --- a/src/server/ocsigen_cohttp_server.ml +++ b/src/server/ocsigen_cohttp_server.ml @@ -103,6 +103,12 @@ module Request = struct let request {r_request} = r_request + let body {r_body} = + r_body + + let map_cohttp_request ~f ({r_request} as r) = + {r with r_request = f r_request} + let address {r_address} = r_address diff --git a/src/server/ocsigen_cohttp_server.mli b/src/server/ocsigen_cohttp_server.mli index 6a3672320..083f0ec69 100644 --- a/src/server/ocsigen_cohttp_server.mli +++ b/src/server/ocsigen_cohttp_server.mli @@ -43,6 +43,13 @@ module Request : sig val request : t -> Cohttp.Request.t + val body : t -> Cohttp_lwt_body.t + + val map_cohttp_request : + f : (Cohttp.Request.t -> Cohttp.Request.t) -> + t -> + t + val address : t -> Unix.inet_addr val host : t -> string option From 8300f9af767418fce509d57e23f078bdc39f2c1a Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 6 Feb 2017 14:55:39 +0100 Subject: [PATCH 018/111] Remove Of_cohttp module --- src/migrate/.depend | 7 --- src/migrate/Makefile | 3 +- src/migrate/of_cohttp.ml | 125 -------------------------------------- src/migrate/of_cohttp.mli | 33 ---------- src/server/.depend | 4 +- 5 files changed, 3 insertions(+), 169 deletions(-) delete mode 100644 src/migrate/of_cohttp.ml delete mode 100644 src/migrate/of_cohttp.mli diff --git a/src/migrate/.depend b/src/migrate/.depend index 250c176bf..f0ba8dacc 100644 --- a/src/migrate/.depend +++ b/src/migrate/.depend @@ -1,10 +1,3 @@ -of_cohttp.cmi : ../http/ocsigen_http_frame.cmi -to_cohttp.cmi : ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi \ - ../http/http_headers.cmi -of_cohttp.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi of_cohttp.cmi -of_cohttp.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../http/ocsigen_cookies.cmx of_cohttp.cmi to_cohttp.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi \ ../http/http_headers.cmi to_cohttp.cmi diff --git a/src/migrate/Makefile b/src/migrate/Makefile index df14f55da..327384cea 100644 --- a/src/migrate/Makefile +++ b/src/migrate/Makefile @@ -10,8 +10,7 @@ all: byte opt ### Common files ### -FILES := of_cohttp.ml \ - to_cohttp.ml \ +FILES := to_cohttp.ml PREDEP := \ diff --git a/src/migrate/of_cohttp.ml b/src/migrate/of_cohttp.ml deleted file mode 100644 index 830144142..000000000 --- a/src/migrate/of_cohttp.ml +++ /dev/null @@ -1,125 +0,0 @@ -open Ocsigen_lib -open Ocsigen_cookies - -let of_version vrs = - let open Ocsigen_http_frame.Http_header in - match vrs with - | `HTTP_1_0 -> HTTP10 - | `HTTP_1_1 -> HTTP11 - | _ -> raise Ocsigen_lib.Ocsigen_Bad_Request - -let of_meth meth = - let open Ocsigen_http_frame.Http_header in - match meth with - | `GET -> GET - | `POST -> POST - | `HEAD -> HEAD - | `PUT -> PUT - | `DELETE -> DELETE - | `OPTIONS -> OPTIONS - | `PATCH -> PATCH - | `TRACE -> TRACE - | `CONNECT -> CONNECT - | `Other "LINK" -> LINK - | `Other "UNLINK" -> UNLINK - | `Other _ -> raise Ocsigen_lib.Ocsigen_Bad_Request - -let of_request req = - let open Ocsigen_http_frame.Http_header in - { - mode = Query - (of_meth @@ Cohttp.Request.meth req, - Uri.to_string @@ Cohttp.Request.uri req); - proto = of_version @@ Cohttp.Request.version req; - headers = Cohttp.Request.headers req; - } - -let of_response resp = - let open Ocsigen_http_frame.Http_header in - { - mode = Answer (Cohttp.Code.code_of_status @@ Cohttp.Response.status resp); - proto = of_version @@ Cohttp.Response.version resp; - headers = Cohttp.Response.headers resp; - } - -let of_request_and_body (req, body) = - let open Ocsigen_http_frame in - { - frame_header = of_request req; - frame_content = Some - (Ocsigen_stream.of_lwt_stream - (Cohttp_lwt_body.to_stream body)); - frame_abort = (fun () -> Lwt.return ()); - (* XXX: It's obsolete ! *) - } - -let of_date str = - (* XXX: handle of GMT ? (see. To_cohttp.to_date) *) - Netdate.parse_epoch ~localzone:true ~zone:0 str - -let of_charset = - let re = Re_emacs.re ~case:true ".*charset=\\(.*\\)" in - let ca = Re.(compile (seq ([start; re]))) in - fun str -> - try - let subs = Re.exec ~pos:0 ca str in - let (start, stop) = Re.get_ofs subs 1 in - Some (String.sub str start (stop - start)) - with Not_found -> None - -let of_response_and_body (resp, body) = - let cookies = Ocsigen_cookies.Cookies.empty in - (* VVV: this function is only used by Ocsigen_local_files and this module - * create an empty Cookie table as response, it's useless to cast header *) - (* VVV: We could do a conversion function but will do nothing in the end. - * The conversion function is difficult! *) - let lastmodified = - match Cohttp.Header.get (Cohttp.Response.headers resp) "Last-Modified" with - | None -> None - | Some date -> Some (of_date date) in - let etag = - match Cohttp.Header.get (Cohttp.Response.headers resp) "ETag" with - | None -> None - | Some tag -> Scanf.sscanf tag "\"%s\"" (fun x -> Some x) in - let code = Cohttp.Code.code_of_status @@ Cohttp.Response.status resp in - let stream = - (Ocsigen_stream.of_lwt_stream - (Cohttp_lwt_body.to_stream body), None) in - (* XXX: I don't want to know what the second value! None! *) - let content_length = - let open Cohttp.Transfer in - match Cohttp.Response.encoding resp with - | Fixed i -> Some i - | _ -> None in - let content_type = Cohttp.Header.get_media_type - @@ Cohttp.Response.headers resp in - let headers = Cohttp.Response.headers resp in - let charset = - match Cohttp.Header.get (Cohttp.Response.headers resp) "Content-Type" with - | None -> None - | Some ct -> of_charset ct in - let location = - Cohttp.Header.get (Cohttp.Response.headers resp) "Location" in - Ocsigen_http_frame.Result.update (Ocsigen_http_frame.Result.empty ()) - ~cookies - ~lastmodified - ~etag - ~code - ~stream - ~content_length - ~content_type - ~headers - ~charset - ~location () - -(* VVV: Specific casting for revproxy extension *) - -let of_response_and_body' (resp, body) = - let open Ocsigen_http_frame in - { - frame_header = of_response resp; - frame_content = Some - (Ocsigen_stream.of_lwt_stream - (Cohttp_lwt_body.to_stream body)); - frame_abort = (fun () -> Lwt.return ()); - } diff --git a/src/migrate/of_cohttp.mli b/src/migrate/of_cohttp.mli deleted file mode 100644 index ccf98ea88..000000000 --- a/src/migrate/of_cohttp.mli +++ /dev/null @@ -1,33 +0,0 @@ -(** Module to cast Cohttp value to OcsigenServer value *) - -(** [of_version] cast version of protocol *) -val of_version : Cohttp.Code.version -> Ocsigen_http_frame.Http_header.proto - -(** [of_meth] cast method of request *) -val of_meth : Cohttp.Code.meth -> Ocsigen_http_frame.Http_header.http_method - -(** [of_request] extracts only header of Cohttp request *) -val of_request : - Cohttp.Request.t -> Ocsigen_http_frame.Http_header.http_header - -(** [of_response] extracts only header of Cohttp response *) -val of_response : - Cohttp.Response.t -> Ocsigen_http_frame.Http_header.http_header - -(** [of_request_and_body] cast Cohttp request to OcsigenServer request *) -val of_request_and_body : - Cohttp.Request.t * Cohttp_lwt_body.t -> Ocsigen_http_frame.t - -(** [of_date] cast a date (as [string]) to timestamp *) -val of_date : string -> float - -val of_charset : string -> string option - -(** [of_response_and_body] cast Cohttp response to OcsigenServer response *) -val of_response_and_body : - Cohttp.Response.t * Cohttp_lwt_body.t -> Ocsigen_http_frame.result - -(** [of_response_and_body'] cast Cohttp response to OcsigenServer frame (like a - request). It's specially used by [revproxy] extension *) -val of_response_and_body' : - Cohttp.Response.t * Cohttp_lwt_body.t -> Ocsigen_http_frame.t diff --git a/src/server/.depend b/src/server/.depend index b9c15669c..57d6d9e44 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -37,10 +37,10 @@ ocsigen_extensions.cmx : \ ../baselib/ocsigen_config.cmx ocsigen_command.cmx \ ocsigen_cohttp_server.cmx ../http/ocsigen_charset_mime.cmx \ ocsigen_extensions.cmi -ocsigen_http_client.cmo : ../migrate/to_cohttp.cmi ../migrate/of_cohttp.cmi \ +ocsigen_http_client.cmo : \ ../baselib/ocsigen_lib.cmi ../http/http_headers.cmi \ ocsigen_http_client.cmi -ocsigen_http_client.cmx : ../migrate/to_cohttp.cmx ../migrate/of_cohttp.cmx \ +ocsigen_http_client.cmx : \ ../baselib/ocsigen_lib.cmx ../http/http_headers.cmx \ ocsigen_http_client.cmi ocsigen_local_files.cmo : ../http/ocsigen_senders.cmi \ From 7db0cef633e5fd3f0cc755551861a938127c2e51 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 6 Feb 2017 15:07:18 +0100 Subject: [PATCH 019/111] Remove Ocsigen_headers module --- src/Makefile.filelist | 1 - src/extensions/.depend | 12 +- src/http/.depend | 8 - src/http/Makefile | 1 - src/http/ocsigen_headers.ml | 347 ----------------------------------- src/http/ocsigen_headers.mli | 64 ------- src/server/.depend | 8 +- 7 files changed, 10 insertions(+), 431 deletions(-) delete mode 100644 src/http/ocsigen_headers.ml delete mode 100644 src/http/ocsigen_headers.mli diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 40955655f..1b82827b1 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -12,7 +12,6 @@ INTF_BASE := baselib/ocsigen_cache.cmi \ \ http/http_headers.cmi \ http/ocsigen_http_frame.cmi \ - http/ocsigen_headers.cmi \ http/framepp.cmi \ http/ocsigen_http_com.cmi \ http/ocsigen_charset_mime.cmi \ diff --git a/src/extensions/.depend b/src/extensions/.depend index 15f142839..7da2fe4fd 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -36,11 +36,11 @@ cors.cmx : ../baselib/ocsigen_lib.cmx \ ../http/http_headers.cmx ../http/framepp.cmx deflatemod.cmo : ../baselib/ocsigen_stream.cmi \ ../server/ocsigen_request_info.cmi ../http/ocsigen_http_frame.cmi \ - ../http/ocsigen_headers.cmi ../server/ocsigen_extensions.cmi \ + ../server/ocsigen_extensions.cmi \ ../http/http_headers.cmi deflatemod.cmx : ../baselib/ocsigen_stream.cmx \ ../server/ocsigen_request_info.cmx ../http/ocsigen_http_frame.cmx \ - ../http/ocsigen_headers.cmx ../server/ocsigen_extensions.cmx \ + ../server/ocsigen_extensions.cmx \ ../http/http_headers.cmx extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ @@ -57,20 +57,20 @@ ocsigen_comet.cmx : ../baselib/ocsigen_stream.cmx \ ../http/ocsigen_http_frame.cmx ../server/ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ocsigen_comet.cmi outputfilter.cmo : \ - ../http/ocsigen_headers.cmi ../server/ocsigen_extensions.cmi \ + ../server/ocsigen_extensions.cmi \ ../http/http_headers.cmi outputfilter.cmx : \ - ../http/ocsigen_headers.cmx ../server/ocsigen_extensions.cmx \ + ../server/ocsigen_extensions.cmx \ ../http/http_headers.cmx redirectmod.cmo : ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi redirectmod.cmx : ../baselib/ocsigen_lib.cmx ../server/ocsigen_extensions.cmx revproxy.cmo : ../baselib/ocsigen_stream.cmi \ ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_headers.cmi \ + ../http/ocsigen_http_frame.cmi \ ../server/ocsigen_extensions.cmi revproxy.cmx : ../baselib/ocsigen_stream.cmx \ ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../http/ocsigen_headers.cmx \ + ../http/ocsigen_http_frame.cmx \ ../server/ocsigen_extensions.cmx rewritemod.cmo : \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi diff --git a/src/http/.depend b/src/http/.depend index c5807311e..fcd69cfcd 100644 --- a/src/http/.depend +++ b/src/http/.depend @@ -3,8 +3,6 @@ http_headers.cmi : multipart.cmi : ../baselib/ocsigen_stream.cmi ocsigen_charset_mime.cmi : ocsigen_cookies.cmi : ../baselib/ocsigen_lib.cmi -ocsigen_headers.cmi : ../baselib/ocsigen_lib.cmi ocsigen_http_frame.cmi \ - ocsigen_cookies.cmi ocsigen_http_com.cmi : ../baselib/ocsigen_stream.cmi ocsigen_http_frame.cmi \ http_headers.cmi ocsigen_http_frame.cmi : ../baselib/ocsigen_stream.cmi \ @@ -28,12 +26,6 @@ ocsigen_charset_mime.cmx : ../baselib/ocsigen_lib.cmx \ ../baselib/ocsigen_config.cmx ocsigen_charset_mime.cmi ocsigen_cookies.cmo : ocsigen_cookies.cmi ocsigen_cookies.cmx : ocsigen_cookies.cmi -ocsigen_headers.cmo : ocsigen_senders.cmi ../baselib/ocsigen_lib.cmi \ - ocsigen_http_frame.cmi ocsigen_cookies.cmi http_headers.cmi \ - ocsigen_headers.cmi -ocsigen_headers.cmx : ocsigen_senders.cmx ../baselib/ocsigen_lib.cmx \ - ocsigen_http_frame.cmx ocsigen_cookies.cmx http_headers.cmx \ - ocsigen_headers.cmi ocsigen_http_com.cmo : ../baselib/ocsigen_stream.cmi \ ../baselib/ocsigen_lib.cmi ocsigen_http_frame.cmi ocsigen_cookies.cmi \ ../baselib/ocsigen_config.cmi http_lexer.cmo http_headers.cmi framepp.cmi \ diff --git a/src/http/Makefile b/src/http/Makefile index eb9473b4e..f6c4f111e 100644 --- a/src/http/Makefile +++ b/src/http/Makefile @@ -21,7 +21,6 @@ FILES := multipart.ml \ http_headers.ml \ ocsigen_cookies.ml \ ocsigen_http_frame.ml \ - ocsigen_headers.ml \ http_lexer.ml \ framepp.ml \ ocsigen_http_com.ml \ diff --git a/src/http/ocsigen_headers.ml b/src/http/ocsigen_headers.ml deleted file mode 100644 index 6e97a2d51..000000000 --- a/src/http/ocsigen_headers.ml +++ /dev/null @@ -1,347 +0,0 @@ -(* Ocsigen - * ocsigen_headers.ml Copyright (C) 2005 Vincent Balat - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - -(* TODO: rewrite header parsing! *) - -(** This module is for getting informations from HTTP header. *) -(** It uses the lowel level module Ocsigen_http_frame.Http_header. *) -(** It is very basic and must be completed for exhaustiveness. *) -(* Operation on strings are hand-written ... *) -(* Include in a better cooperative parser for header or use regexp?. *) - -open Ocsigen_http_frame -open Ocsigen_senders -open Ocsigen_lib -open Ocsigen_cookies - - -let find name frame = - Http_headers.find (Http_headers.name name) - frame.frame_header.Http_header.headers - -let find_all name frame = - Http_headers.find_all (Http_headers.name name) - frame.frame_header.Http_header.headers - -(* -XXX Get rid of all "try ... with _ -> ..." -*) -let list_flat_map f l = List.flatten (List.map f l) - -(* splits a quoted string, for ex "azert", " sdfmlskdf", "dfdsfs" *) -(* We are too kind ... We accept even if the separator is not ok :-( ? *) -let rec quoted_split char (* char is not used in that version *) s = - let longueur = String.length s in - let rec aux deb = - let rec nextquote s i = - if i>=longueur - then failwith "" - else - if s.[i] = '"' - then i - else - if s.[i] = '\\' - then nextquote s (i+2) - else nextquote s (i+1) - in - try - let first = (nextquote s deb) + 1 in - let afterlast = nextquote s first in - let value = String.sub s first (afterlast - first) in - value:: - (if (afterlast + 1) < longueur - then aux (afterlast + 1) - else []) - with Failure _ | Invalid_argument _ -> [] - in - aux 0 - - -let parse_quality parse_name s = - try - let a,b = String.sep ';' s in - let q,qv = String.sep '=' b in - if q="q" - then ((parse_name a), Some (float_of_string qv)) - else failwith "Parse error" - with _ -> ((parse_name s), None) - -let parse_star a = - if a = "*" - then None - else Some a - -let parse_mime_type a = - let b,c = String.sep '/' a in - ((parse_star b), (parse_star c)) - -let parse_extensions parse_name s = - try - let a,b = String.sep ';' s in - ((parse_name a), List.map (String.sep '=') (String.split ';' b)) - with _ -> ((parse_name s), []) - -let parse_list_with_quality parse_name s = - let splitted = list_flat_map (String.split ',') s in - List.map (parse_quality parse_name) splitted - -let parse_list_with_extensions parse_name s = - let splitted = list_flat_map (String.split ',') s in - List.map (parse_extensions parse_name) splitted - - -(*****************************************************************************) -let rec parse_cookies s = - let splitted = String.split ';' s in - try - List.fold_left - (fun beg a -> - let (n, v) = String.sep '=' a in - CookiesTable.add n v beg) - CookiesTable.empty - splitted - with _ -> CookiesTable.empty -(*VVV Actually the real syntax of cookies is more complex! *) -(* -http://www.w3.org/Protocols/rfc2109/rfc2109 -Mozilla spec + RFC2109 -http://ws.bokeland.com/blog/376/1043/2006/10/27/76832 -*) - - -let get_keepalive http_header = - Http_header.get_proto http_header = Ocsigen_http_frame.Http_header.HTTP11 - && - try - String.lowercase - (Http_header.get_headers_value http_header Http_headers.connection) - <> "close" - with Not_found -> - true -(* 06/02/2008 - If HTTP/1.0, we do not keep alive, even if the client asks so. - It would be possible, but only if the content-length is known. - Chunked encoding is not possible with HTTP/1.0. - As we cannot know if the output will be chunked or not, - we decided that we won't keep the connection open at all for - HTTP/1.0. - Another solution would be to keep it open if the client asks so, - and answer connection:close (and close) if we don't know the size - of the document. In that case, all requests that have been pipelined - would be processed by the server, but not sent back to the client. - Which one is the best? It really depends on the client. - If the client waits the answer before doing the following request, - it would be ok to keep the connection opened, - otherwise it is better not. - (+ pb with non-idempotent requests, that should not be pipelined) -*) - - - -(* RFC 2616, sect. 14.23 *) -(* XXX Not so simple: the host name may contain a colon! (RFC 3986) *) -let get_host_from_host_header = - let host_re = - Netstring_pcre.regexp "^(\\[[0-9A-Fa-f:.]+\\]|[^:]+)(:([0-9]+))?$" - in - fun http_frame -> - try - let hostport = - Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header Http_headers.host - in - match Netstring_pcre.string_match host_re hostport 0 with - | Some m -> - (Some (Netstring_pcre.matched_group m 1 hostport), - try Some (int_of_string - (Netstring_pcre.matched_group m 3 hostport)) - with Not_found -> None | Failure _ -> raise Ocsigen_Bad_Request) - | None -> raise Ocsigen_Bad_Request - with Not_found -> - (None, None) - -let get_user_agent http_frame = - try (Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header Http_headers.user_agent) - with Not_found -> "" - -let get_cookie_string http_frame = - try - Some (Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header Http_headers.cookie) - with Not_found -> - None - -let get_expect http_frame = - try - String.split ',' ( - Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header - Http_headers.expect - ) - with Not_found -> - [] - -let get_if_modified_since http_frame = - try - Some (Netdate.parse_epoch - (Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header - Http_headers.if_modified_since)) - with _ -> None - - -let get_if_unmodified_since http_frame = - try - Some (Netdate.parse_epoch - (Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header - Http_headers.if_unmodified_since)) - with _ -> None - - -let get_if_none_match http_frame = - try - Some (list_flat_map - (quoted_split ',') - (Http_header.get_headers_values - http_frame.Ocsigen_http_frame.frame_header Http_headers.if_none_match)) - with _ -> None - - -let get_if_match http_frame = - try - Some - (list_flat_map - (quoted_split ',') - (Http_header.get_headers_values - http_frame.Ocsigen_http_frame.frame_header Http_headers.if_match)) - with _ -> None - - -let get_content_type http_frame = - try - Some - (Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header Http_headers.content_type) - with Not_found -> None - -let parse_content_type = function - | None -> None - | Some s -> - match String.split ';' s with - | [] -> None - | a::l -> - try - let typ, subtype = String.sep '/' a in - let params = - try - List.map (String.sep '=') l - with Not_found -> [] - in - (*VVV If syntax error, we return no parameter at all *) - Some ((typ, subtype), params) - (*VVV If syntax error in type, we return None *) - with Not_found -> None - -let get_content_length http_frame = - try - Some - (Int64.of_string - (Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header Http_headers.content_length)) - with Not_found | Failure _ | Invalid_argument _ -> None - - -let get_referer http_frame = - try - Some - (Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header Http_headers.referer) - with _ -> None - - -let get_origin http_frame = - try - Some - (Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header Http_headers.origin) - with _ -> None - -let get_access_control_request_method http_frame = - try - Some - (Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header - Http_headers.access_control_request_method) - with _ -> None - -let get_access_control_request_headers http_frame = - try - let s = (Http_header.get_headers_value - http_frame.Ocsigen_http_frame.frame_header - Http_headers.access_control_request_headers) in - Some (String.split ',' s) - with _ -> None - -let get_referrer = get_referer - - -let get_accept http_frame = - try - let l = - parse_list_with_extensions - parse_mime_type - (Http_header.get_headers_values - http_frame.Ocsigen_http_frame.frame_header Http_headers.accept) - in - let change_quality (a, l) = - try - let q,ll = List.assoc_remove "q" l in - (a, Some (float_of_string q), ll) - with _ -> (a, None, l) - in - List.map change_quality l - with _ -> [] - - -let get_accept_charset http_frame = - try - parse_list_with_quality - parse_star - (Http_header.get_headers_values - http_frame.Ocsigen_http_frame.frame_header Http_headers.accept_charset) - with _ -> [] - - -let get_accept_encoding http_frame = - try - parse_list_with_quality - parse_star - (Http_header.get_headers_values - http_frame.Ocsigen_http_frame.frame_header Http_headers.accept_encoding) - with _ -> [] - - -let get_accept_language http_frame = - try - parse_list_with_quality - id - (Http_header.get_headers_values - http_frame.Ocsigen_http_frame.frame_header Http_headers.accept_language) - with _ -> [] diff --git a/src/http/ocsigen_headers.mli b/src/http/ocsigen_headers.mli deleted file mode 100644 index 220a66a98..000000000 --- a/src/http/ocsigen_headers.mli +++ /dev/null @@ -1,64 +0,0 @@ -(* Ocsigen - * ocsigen_headers.mli Copyright (C) 2005 Vincent Balat - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - -(** Getting informations from HTTP header. *) -(** This module uses the lowel level module Ocsigen_http_frame.Http_header. - It is very basic and must be completed for exhaustiveness. *) - -open Ocsigen_lib -open Ocsigen_cookies - -val find : string -> Ocsigen_http_frame.t -> string -(** find one of the values bound to [name] in the HTTP headers of the frame. - Raise [Not_found] if it is not bound. -*) - -val find_all : string -> Ocsigen_http_frame.t -> string list -(** find all the values bound to [name] in the HTTP headers of the frame. - Raise [Not_found] if it is not bound.*) - -val get_keepalive : Ocsigen_http_frame.Http_header.http_header -> bool -val parse_cookies : string -> string CookiesTable.t -val parse_mime_type : string -> string option * string option -val get_host_from_host_header : Ocsigen_http_frame.t -> - string option * int option -val get_user_agent : Ocsigen_http_frame.t -> string -val get_cookie_string : Ocsigen_http_frame.t -> string option -val get_expect : Ocsigen_http_frame.t -> string list -val get_if_modified_since : Ocsigen_http_frame.t -> float option -val get_if_unmodified_since : Ocsigen_http_frame.t -> float option -val get_if_none_match : Ocsigen_http_frame.t -> string list option -val get_if_match : Ocsigen_http_frame.t -> string list option -val get_content_type : Ocsigen_http_frame.t -> string option -val parse_content_type - : string option -> ((string * string) * (string * string) list) option -val get_content_length : Ocsigen_http_frame.t -> int64 option -val get_referer : Ocsigen_http_frame.t -> string option -val get_referrer : Ocsigen_http_frame.t -> string option - -val get_origin : Ocsigen_http_frame.t -> string option -val get_access_control_request_method : Ocsigen_http_frame.t -> string option -val get_access_control_request_headers : Ocsigen_http_frame.t -> string list option - -val get_accept : - Ocsigen_http_frame.t -> - ((string option * string option) * float option * (string * string) list) - list -val get_accept_charset : Ocsigen_http_frame.t -> (string option * float option) list -val get_accept_encoding : Ocsigen_http_frame.t -> (string option * float option) list -val get_accept_language : Ocsigen_http_frame.t -> (string * float option) list diff --git a/src/server/.depend b/src/server/.depend index 57d6d9e44..72fbf8696 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -14,13 +14,13 @@ ocsigen_socket.cmi : ocsigen_cohttp_server.cmo : ../migrate/to_cohttp.cmi \ ../baselib/ocsigen_stream.cmi ocsigen_socket.cmi \ ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_headers.cmi \ + ../http/ocsigen_http_frame.cmi \ ../http/ocsigen_cookies.cmi \ ../baselib/ocsigen_config.cmi ocsigen_cohttp_server.cmi ocsigen_cohttp_server.cmx : ../migrate/to_cohttp.cmx \ ../baselib/ocsigen_stream.cmx ocsigen_socket.cmx \ ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../http/ocsigen_headers.cmx \ + ../http/ocsigen_http_frame.cmx \ ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx ocsigen_cohttp_server.cmi ocsigen_command.cmo : ../baselib/ocsigen_messages.cmi ocsigen_command.cmi @@ -60,7 +60,7 @@ ocsigen_parseconfig.cmx : ocsigen_socket.cmx ../baselib/ocsigen_loader.cmx \ ocsigen_server.cmo : ocsigen_socket.cmi \ ocsigen_parseconfig.cmi ../baselib/ocsigen_messages.cmi \ ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_headers.cmi \ + ../http/ocsigen_http_frame.cmi \ ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ ../baselib/ocsigen_config.cmi ../baselib/ocsigen_commandline.cmo \ ocsigen_command.cmi ocsigen_cohttp_server.cmi \ @@ -69,7 +69,7 @@ ocsigen_server.cmo : ocsigen_socket.cmi \ ocsigen_server.cmx : ocsigen_socket.cmx \ ocsigen_parseconfig.cmx ../baselib/ocsigen_messages.cmx \ ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../http/ocsigen_headers.cmx \ + ../http/ocsigen_http_frame.cmx \ ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx ../baselib/ocsigen_commandline.cmx \ ocsigen_command.cmx ocsigen_cohttp_server.cmx \ From 5ba869cde5df680567107e30db3412aefaac280c Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 6 Feb 2017 15:10:36 +0100 Subject: [PATCH 020/111] Remove To_cohttp module --- src/Makefile | 6 - src/extensions/Makefile | 2 +- src/migrate/.depend | 6 - src/migrate/Makefile | 58 ---------- src/migrate/to_cohttp.ml | 167 ---------------------------- src/migrate/to_cohttp.mli | 48 -------- src/server/.depend | 4 +- src/server/Makefile | 4 +- src/server/ocsigen_cohttp_server.ml | 37 +++++- 9 files changed, 40 insertions(+), 292 deletions(-) delete mode 100644 src/migrate/.depend delete mode 100644 src/migrate/Makefile delete mode 100644 src/migrate/to_cohttp.ml delete mode 100644 src/migrate/to_cohttp.mli diff --git a/src/Makefile b/src/Makefile index 091ea432d..eadc5ae0c 100644 --- a/src/Makefile +++ b/src/Makefile @@ -3,21 +3,18 @@ include ../Makefile.config all: metas confs ${MAKE} -C baselib all ${MAKE} -C http all - ${MAKE} -C migrate all ${MAKE} -C server all ${MAKE} -C extensions all byte: metas confs ${MAKE} -C baselib byte ${MAKE} -C http byte - ${MAKE} -C migrate byte ${MAKE} -C server byte ${MAKE} -C extensions byte opt: metas confs ${MAKE} -C baselib opt ${MAKE} -C http opt - ${MAKE} -C migrate opt ${MAKE} -C server opt ${MAKE} -C extensions opt @@ -149,7 +146,6 @@ reinstall: uninstall install clean: clean.local ${MAKE} -C baselib clean ${MAKE} -C http clean - ${MAKE} -C migrate clean ${MAKE} -C server clean ${MAKE} -C extensions clean @@ -163,7 +159,6 @@ clean.local: distclean: clean.local ${MAKE} -C baselib distclean ${MAKE} -C http distclean - ${MAKE} -C migrate distclean ${MAKE} -C server distclean ${MAKE} -C extensions distclean -rm -f *~ \#* .\#* @@ -176,6 +171,5 @@ distclean: clean.local depend: ${MAKE} -C baselib depend ${MAKE} -C http depend - ${MAKE} -C migrate depend ${MAKE} -C server depend ${MAKE} -C extensions depend diff --git a/src/extensions/Makefile b/src/extensions/Makefile index e87457967..b9c8d39a6 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -11,7 +11,7 @@ PACKAGE := \ tyxml.parser \ cohttp.lwt -LIBS := -I ../baselib -I ../http -I ../migrate -I ../server \ +LIBS := -I ../baselib -I ../http -I ../server \ ${addprefix -package ,${PACKAGE}} OCAMLC := $(OCAMLFIND) ocamlc ${BYTEDBG} OCAMLOPT := $(OCAMLFIND) ocamlopt ${OPTDBG} diff --git a/src/migrate/.depend b/src/migrate/.depend deleted file mode 100644 index f0ba8dacc..000000000 --- a/src/migrate/.depend +++ /dev/null @@ -1,6 +0,0 @@ -to_cohttp.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi \ - ../http/http_headers.cmi to_cohttp.cmi -to_cohttp.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../http/ocsigen_cookies.cmx \ - ../http/http_headers.cmx to_cohttp.cmi diff --git a/src/migrate/Makefile b/src/migrate/Makefile deleted file mode 100644 index 327384cea..000000000 --- a/src/migrate/Makefile +++ /dev/null @@ -1,58 +0,0 @@ -include ../../Makefile.config - -LIBS := -package bytes,lwt,cohttp,netstring,re.emacs -I ../baselib -I ../http -OCAMLC := $(OCAMLFIND) ocamlc${BYTEDBG} -OCAMLOPT := $(OCAMLFIND) ocamlopt ${OPTDBG} -OCAMLDOC := $(OCAMLFIND) ocamldoc -OCAMLDEP := $(OCAMLFIND) ocamldep - -all: byte opt - -### Common files ### - -FILES := to_cohttp.ml - -PREDEP := \ - -byte: migrate.cma -opt: migrate.cmxa - -migrate.cma: $(FILES:.ml=.cmo) - ${OCAMLC} -a -o $@ $^ -migrate.cmxa: $(FILES:.ml=.cmx) - ${OCAMLOPT} -a -o $@ $^ - -########## - -%.ml: %.mll - $(OCAMLLEX) $< -%.cmi: %.mli - $(OCAMLC) ${LIBS} -c $< -%.cmo: %.ml - $(OCAMLC) ${LIBS} -c $< -%.cmx: %.ml - $(OCAMLOPT) ${LIBS} -c $< -%.cmxs: %.cmxa - $(OCAMLOPT) -shared -linkall -o $@ $< - -## Clean up - -clean: - -rm -f *.cm* *.o *.a *.annot - -rm -f ${PREDEP} -distclean: clean - -rm -f *~ \#* .\#* - -## Dependencies - -depend: ${PREDEP} - $(OCAMLDEP) ${LIBS} *.mli *.ml > .depend - -type: $(FILES:.ml=.gmli) - -%.gmli: %.ml - $(OCAMLC) ${LIBS} -i $< > $@ - - -FORCE: --include .depend diff --git a/src/migrate/to_cohttp.ml b/src/migrate/to_cohttp.ml deleted file mode 100644 index 994320169..000000000 --- a/src/migrate/to_cohttp.ml +++ /dev/null @@ -1,167 +0,0 @@ -module Cookie = struct - - open Ocsigen_cookies - open Ocsigen_lib - - let serialize_cookie_raw path exp name c secure = - Format.sprintf "%s=%s; path=/%s%s%s" - name c (Url.string_of_url_path ~encode:true path) - (if secure then "; secure" else "") - (match exp with - | Some s -> "; expires=" ^ - Netdate.format - "%a, %d-%b-%Y %H:%M:%S GMT" - (Netdate.create s) - | None -> "") - - let serialize_cookies path table headers = - CookiesTable.fold - (fun name c h -> - let exp, v, secure = match c with - | Ocsigen_cookies.OUnset -> (Some 0., "", false) - | Ocsigen_cookies.OSet (t, v, secure) -> (t, v, secure) - in - Http_headers.add - Http_headers.set_cookie (serialize_cookie_raw path exp name v secure) - h) - table - headers - - let serialize cookies headers = - Cookies.fold serialize_cookies cookies headers -end - -let to_version vrs = - let open Ocsigen_http_frame.Http_header in - match vrs with - | HTTP10 -> `HTTP_1_0 - | HTTP11 -> `HTTP_1_1 - -let to_meth meth = - let open Ocsigen_http_frame.Http_header in - match meth with - | GET -> `GET - | POST -> `POST - | HEAD -> `HEAD - | PUT -> `PUT - | DELETE -> `DELETE - | OPTIONS -> `OPTIONS - | PATCH -> `PATCH - | UNLINK -> `Other "UNLINK" - | LINK -> `Other "LINK" - | TRACE -> `Other "TRACE" - | CONNECT -> `Other "CONNECT" - -let to_headers : Http_headers.t -> Cohttp.Header.t = - fun x -> x - -let to_response ?encoding ?flush - { - Ocsigen_http_frame.Http_header.mode; - Ocsigen_http_frame.Http_header.proto; - Ocsigen_http_frame.Http_header.headers; - } = - let open Ocsigen_http_frame.Http_header in - match mode with - | Answer code -> - let version = to_version proto in - let status = Cohttp.Code.status_of_code code in - let headers = to_headers headers in - Cohttp.Response.make ~version ~status ?flush ?encoding ~headers () - | _ -> raise - (Invalid_argument "Ocsigen_http_frame.Http_header.to_cohttp_response") - -let to_request ?encoding - { - Ocsigen_http_frame.Http_header.mode; - Ocsigen_http_frame.Http_header.proto; - Ocsigen_http_frame.Http_header.headers; - } uri = - let open Ocsigen_http_frame.Http_header in - match mode with - | Query (meth, _) -> - let meth = to_meth meth in - let version = to_version proto in - let headers = to_headers headers in - Cohttp.Request.make ~meth ~version ?encoding ~headers uri - | _ -> raise - (Invalid_argument "Ocsigen_http_frame.Http_header.to_cohttp_request") - -let to_request_and_body ?encoding - { - Ocsigen_http_frame.frame_header; - Ocsigen_http_frame.frame_content; - } uri = - let stream = match frame_content with - | Some s -> Ocsigen_stream.to_lwt_stream - ~is_empty:(fun x -> String.length x = 0) - s - | None -> (Lwt_stream.from (fun () -> Lwt.return None) : string Lwt_stream.t) - in - (to_request ?encoding frame_header uri, Cohttp_lwt_body.of_stream stream) - -let to_date date = - let x = Netdate.mk_mail_date ~zone:0 date |> Bytes.unsafe_of_string in - try - let ind_plus = Bytes.index x '+' in - Bytes.set x ind_plus 'G'; - Bytes.set x (ind_plus + 1) 'M'; - Bytes.set x (ind_plus + 2) 'T'; - Bytes.sub x 0 (ind_plus + 3) - with Invalid_argument _ | Not_found -> (); x - -let to_type ty charset = - if String.length ty >= 4 then - match String.sub ty 0 4, charset with - | "text", Some "" -> ty - | "text", Some ch -> Format.sprintf "%s; charset=%s" ty ch - | _ -> - begin match String.sub ty (String.length ty - 4) 4, charset with - | ("+xml"|"/xml"), Some "" -> ty - | ("+xml"|"/xml"), Some ch -> Format.sprintf "%s; charset=%s" ty ch - | _ -> ty - end - else ty - -let to_response_and_body res = - let res_code = Ocsigen_http_frame.Result.code res in - let res_etag = Ocsigen_http_frame.Result.etag res in - let res_cookies = Ocsigen_http_frame.Result.cookies res in - let res_stream = Ocsigen_http_frame.Result.stream res in - let res_lastmodified = Ocsigen_http_frame.Result.lastmodified res in - let res_content_length = Ocsigen_http_frame.Result.content_length res in - let res_content_type = Ocsigen_http_frame.Result.content_type res in - let res_headers = Ocsigen_http_frame.Result.headers res in - let res_charset = Ocsigen_http_frame.Result.charset res in - let res_location = Ocsigen_http_frame.Result.location res in - let headers = - to_headers (Cookie.serialize res_cookies res_headers) in - let headers = match res_lastmodified with - | Some date -> Cohttp.Header.add headers "Last-Modified" (to_date date) - | None -> headers - in - let headers = match res_etag with - | Some etag -> Cohttp.Header.add headers "ETag" (Format.sprintf "\"%s\"" etag) - | None -> headers - in - let encoding = match res_content_length with - | Some length when length <= Int64.of_int max_int -> - Cohttp.Transfer.Fixed length - | _ -> Cohttp.Transfer.Chunked - in - let headers = match res_content_type with - | Some ty -> Cohttp.Header.add headers "Content-Type" (to_type ty res_charset) - | None -> headers - in - let headers = match res_location with - | Some location -> Cohttp.Header.add headers "Location" location - | None -> headers - in - (Cohttp.Response.make - ~status:(Cohttp.Code.status_of_code res_code) - ~encoding - ~headers - (), - Cohttp_lwt_body.of_stream (Ocsigen_stream.to_lwt_stream - ~is_empty:(fun x -> String.length x = 0) - (fst res_stream))) diff --git a/src/migrate/to_cohttp.mli b/src/migrate/to_cohttp.mli deleted file mode 100644 index 20a48f05a..000000000 --- a/src/migrate/to_cohttp.mli +++ /dev/null @@ -1,48 +0,0 @@ -(** Module to cast OcsigenServer value to Cohttp value *) - -(** Module to serialize cookie to Cohttp headers *) -module Cookie : - sig - val serialize : - Ocsigen_cookies.cookie Ocsigen_cookies.CookiesTable.t - Ocsigen_cookies.Cookies.t -> Cohttp.Header.t -> Cohttp.Header.t - end - -(** [to_version] cast version of protocol *) -val to_version : - Ocsigen_http_frame.Http_header.proto -> [> `HTTP_1_0 | `HTTP_1_1 ] - -(** [to_meth] cast method of request *) -val to_meth : - Ocsigen_http_frame.Http_header.http_method -> Cohttp.Code.meth - -(** [to_headers] cast OcsigenServer headers to Cohttp headers (this function is - [fun x -> x] with simply annotation) *) -val to_headers : Http_headers.t -> Cohttp.Header.t - -(** [to_response] injects only header of new Cohttp response *) -val to_response : - ?encoding:Cohttp.Transfer.encoding -> - ?flush:bool -> - Ocsigen_http_frame.Http_header.http_header -> Cohttp.Response.t - -(** [to_request] injects only headers to new Cohttp request *) -val to_request : - ?encoding:Cohttp.Transfer.encoding -> - Ocsigen_http_frame.Http_header.http_header -> Uri.t -> Cohttp.Request.t - -(** [to_request_and_body] cast a OcsigenServer request to Cohttp request *) -val to_request_and_body : - ?encoding:Cohttp.Transfer.encoding -> - Ocsigen_http_frame.t -> - Uri.t -> Cohttp.Request.t * Cohttp_lwt_body.t - -(** [to_date] cast a date (as timestamp) to a string *) -val to_date : float -> string - -val to_type : string -> string option -> string - -(** [to_response_and_body] cast a OcsigenServer response to Cohttp response *) -val to_response_and_body : - Ocsigen_http_frame.result -> - Cohttp.Response.t * Cohttp_lwt_body.t diff --git a/src/server/.depend b/src/server/.depend index 72fbf8696..1b0ca2504 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -11,13 +11,13 @@ ocsigen_local_files.cmi : ../http/ocsigen_http_frame.cmi \ ocsigen_parseconfig.cmi : ocsigen_socket.cmi ocsigen_extensions.cmi ocsigen_server.cmi : ocsigen_socket.cmi : -ocsigen_cohttp_server.cmo : ../migrate/to_cohttp.cmi \ +ocsigen_cohttp_server.cmo : \ ../baselib/ocsigen_stream.cmi ocsigen_socket.cmi \ ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_http_frame.cmi \ ../http/ocsigen_cookies.cmi \ ../baselib/ocsigen_config.cmi ocsigen_cohttp_server.cmi -ocsigen_cohttp_server.cmx : ../migrate/to_cohttp.cmx \ +ocsigen_cohttp_server.cmx : \ ../baselib/ocsigen_stream.cmx ocsigen_socket.cmx \ ../baselib/ocsigen_lib.cmx \ ../http/ocsigen_http_frame.cmx \ diff --git a/src/server/Makefile b/src/server/Makefile index 1e1c6694a..1af604080 100644 --- a/src/server/Makefile +++ b/src/server/Makefile @@ -3,8 +3,7 @@ include ../../Makefile.config all: byte opt PACKAGE := ${SERVER_PACKAGE} ## See ../../Makefile.options -LIBS := -I ../baselib -I ../http -I ../migrate \ - ${addprefix -package ,${PACKAGE}} +LIBS := -I ../baselib -I ../http ${addprefix -package ,${PACKAGE}} OCAMLC := $(OCAMLFIND) ocamlc ${BYTEDBG} ${THREAD} OCAMLOPT := $(OCAMLFIND) ocamlopt ${OPTDBG} ${THREAD} OCAMLDOC := $(OCAMLFIND) ocamldoc @@ -47,7 +46,6 @@ SERVERLIBS := ${PARSECOMMANDLINE} \ ../baselib/baselib.cma \ ../baselib/polytables.cma \ ../http/http.cma \ - ../migrate/migrate.cma \ ${PROJECTNAME}.cma \ SERVEROBJS := server_main.cmo diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml index 6ca5f9d74..3c631eee5 100644 --- a/src/server/ocsigen_cohttp_server.ml +++ b/src/server/ocsigen_cohttp_server.ml @@ -305,6 +305,41 @@ let waiters = Hashtbl.create 256 exception Ocsigen_Is_a_directory of (request -> Neturl.url) +module Cookie = struct + + let serialize_cookie_raw path exp name c secure = + Format.sprintf "%s=%s; path=/%s%s%s" + name c + (Ocsigen_lib.Url.string_of_url_path ~encode:true path) + (if secure then "; secure" else "") + (match exp with + | Some s -> + "; expires=" ^ + Netdate.format + "%a, %d-%b-%Y %H:%M:%S GMT" + (Netdate.create s) + | None -> + "") + + let serialize_cookies path table headers = + Ocsigen_cookies.CookiesTable.fold + (fun name c h -> + let exp, v, secure = match c with + | Ocsigen_cookies.OUnset -> (Some 0., "", false) + | Ocsigen_cookies.OSet (t, v, secure) -> (t, v, secure) + in + Http_headers.add + Http_headers.set_cookie + (serialize_cookie_raw path exp name v secure) + h) + table + headers + + let serialize cookies headers = + Ocsigen_cookies.Cookies.fold serialize_cookies cookies headers + +end + let handler ~address ~port ~connector (flow, conn) request body = Lwt_log.ign_info_f ~section @@ -340,7 +375,7 @@ let handler ~address ~port ~connector (flow, conn) request body = let headers, ret_code = match exn with | Ocsigen_http_error (cookies_to_set, code) -> let headers = - To_cohttp.Cookie.serialize cookies_to_set (Cohttp.Header.init ()) + Cookie.serialize cookies_to_set (Cohttp.Header.init ()) in Some headers, code | Ocsigen_stream.Interrupted Ocsigen_stream.Already_read -> From 44f0723a9662e51ed682d6152cb4dae5c793b5d9 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 6 Feb 2017 15:40:35 +0100 Subject: [PATCH 021/111] Throw-away much of src/http (WIP) --- .gitignore | 1 - doc/indexdoc | 3 - src/Makefile.filelist | 4 - src/extensions/.depend | 46 +- src/extensions/accesscontrol.ml | 1 - src/extensions/authbasic.ml | 4 +- src/extensions/cors.ml | 9 +- src/extensions/redirectmod.ml | 1 - src/extensions/staticmod.ml | 15 +- src/http/.depend | 43 -- src/http/LICENSE-multipart | 24 - src/http/Makefile | 14 +- src/http/framepp.ml | 136 ---- src/http/framepp.mli | 28 - src/http/http_lexer.mll | 121 ---- src/http/multipart.ml | 270 -------- src/http/multipart.mli | 8 - src/http/ocsigen_http_com.ml | 989 --------------------------- src/http/ocsigen_http_com.mli | 118 ---- src/http/ocsigen_http_frame.ml | 351 ---------- src/http/ocsigen_http_frame.mli | 153 ----- src/http/ocsigen_senders.ml | 558 --------------- src/http/ocsigen_senders.mli | 75 -- src/http/test_parser.ml | 30 - src/http/test_pp.ml | 35 - src/server/.depend | 25 +- src/server/ocsigen_cohttp_server.ml | 9 +- src/server/ocsigen_cohttp_server.mli | 6 + src/server/ocsigen_local_files.ml | 19 - src/server/ocsigen_local_files.mli | 8 - 30 files changed, 61 insertions(+), 3043 deletions(-) delete mode 100644 src/http/LICENSE-multipart delete mode 100644 src/http/framepp.ml delete mode 100644 src/http/framepp.mli delete mode 100644 src/http/http_lexer.mll delete mode 100644 src/http/multipart.ml delete mode 100644 src/http/multipart.mli delete mode 100644 src/http/ocsigen_http_com.ml delete mode 100644 src/http/ocsigen_http_com.mli delete mode 100644 src/http/ocsigen_http_frame.ml delete mode 100644 src/http/ocsigen_http_frame.mli delete mode 100644 src/http/ocsigen_senders.ml delete mode 100644 src/http/ocsigen_senders.mli delete mode 100644 src/http/test_parser.ml delete mode 100644 src/http/test_pp.ml diff --git a/.gitignore b/.gitignore index fcc2c5dd9..7dfada4dc 100644 --- a/.gitignore +++ b/.gitignore @@ -13,7 +13,6 @@ Makefile.config src/baselib/dynlink_wrapper.ml src/baselib/ocsigen_config.ml -src/http/http_lexer.ml src/http/http_parser.ml src/http/http_parser.mli src/server/ocsigenserver diff --git a/doc/indexdoc b/doc/indexdoc index 0e56003ca..d259d9467 100644 --- a/doc/indexdoc +++ b/doc/indexdoc @@ -16,10 +16,7 @@ Ocsigen_config Ocsigen_extensions Ocsigen_local_files Ocsigen_headers -Ocsigen_senders -Ocsigen_http_frame Ocsigen_http_client -Ocsigen_http_com Ocsigen_stream Ocsigen_comet Authbasic diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 1b82827b1..629464581 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -11,11 +11,7 @@ INTF_BASE := baselib/ocsigen_cache.cmi \ baselib/polytables.cmi \ \ http/http_headers.cmi \ - http/ocsigen_http_frame.cmi \ - http/framepp.cmi \ - http/ocsigen_http_com.cmi \ http/ocsigen_charset_mime.cmi \ - http/ocsigen_senders.cmi \ http/ocsigen_cookies.cmi \ \ server/ocsigen_extensions.cmi \ diff --git a/src/extensions/.depend b/src/extensions/.depend index 7da2fe4fd..1d47951f4 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -3,43 +3,37 @@ authbasic.cmi : ocsigen_comet.cmi : ../baselib/ocsigen_stream.cmi ocsipersist.cmi : accesscontrol.cmo : \ - ../baselib/ocsigen_lib.cmi ../http/ocsigen_http_frame.cmi \ + ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ - ../http/http_headers.cmi ../http/framepp.cmi accesscontrol.cmi + ../http/http_headers.cmi accesscontrol.cmi accesscontrol.cmx : \ - ../baselib/ocsigen_lib.cmx ../http/ocsigen_http_frame.cmx \ + ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ - ../http/http_headers.cmx ../http/framepp.cmx accesscontrol.cmi -authbasic.cmo : \ - ../http/ocsigen_http_frame.cmi ../server/ocsigen_extensions.cmi \ + ../http/http_headers.cmx accesscontrol.cmi +authbasic.cmo : ../server/ocsigen_extensions.cmi \ ../http/ocsigen_cookies.cmi ../http/http_headers.cmi authbasic.cmi -authbasic.cmx : \ - ../http/ocsigen_http_frame.cmx ../server/ocsigen_extensions.cmx \ +authbasic.cmx : ../server/ocsigen_extensions.cmx \ ../http/ocsigen_cookies.cmx ../http/http_headers.cmx authbasic.cmi -cgimod.cmo : ../baselib/ocsigen_stream.cmi ../http/ocsigen_senders.cmi \ +cgimod.cmo : ../baselib/ocsigen_stream.cmi \ ../server/ocsigen_request_info.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_http_com.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ - ../baselib/ocsigen_config.cmi ../http/http_headers.cmi \ - ../http/framepp.cmi -cgimod.cmx : ../baselib/ocsigen_stream.cmx ../http/ocsigen_senders.cmx \ + ../baselib/ocsigen_config.cmi ../http/http_headers.cmi +cgimod.cmx : ../baselib/ocsigen_stream.cmx \ ../server/ocsigen_request_info.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../http/ocsigen_http_com.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ - ../baselib/ocsigen_config.cmx ../http/http_headers.cmx \ - ../http/framepp.cmx + ../baselib/ocsigen_config.cmx ../http/http_headers.cmx cors.cmo : ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../server/ocsigen_extensions.cmi \ - ../http/http_headers.cmi ../http/framepp.cmi + ../server/ocsigen_extensions.cmi \ + ../http/http_headers.cmi cors.cmx : ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../server/ocsigen_extensions.cmx \ - ../http/http_headers.cmx ../http/framepp.cmx + ../server/ocsigen_extensions.cmx \ + ../http/http_headers.cmx deflatemod.cmo : ../baselib/ocsigen_stream.cmi \ - ../server/ocsigen_request_info.cmi ../http/ocsigen_http_frame.cmi \ + ../server/ocsigen_request_info.cmi \ ../server/ocsigen_extensions.cmi \ ../http/http_headers.cmi deflatemod.cmx : ../baselib/ocsigen_stream.cmx \ - ../server/ocsigen_request_info.cmx ../http/ocsigen_http_frame.cmx \ + ../server/ocsigen_request_info.cmx \ ../server/ocsigen_extensions.cmx \ ../http/http_headers.cmx extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ @@ -50,11 +44,11 @@ extendconfiguration.cmx : ../server/ocsigen_parseconfig.cmx \ ../baselib/ocsigen_config.cmx ../http/ocsigen_charset_mime.cmx ocsigen_comet.cmo : ../baselib/ocsigen_stream.cmi \ ../server/ocsigen_request_info.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../server/ocsigen_extensions.cmi \ + ../server/ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi ocsigen_comet.cmi ocsigen_comet.cmx : ../baselib/ocsigen_stream.cmx \ ../server/ocsigen_request_info.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../server/ocsigen_extensions.cmx \ + ../server/ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ocsigen_comet.cmi outputfilter.cmo : \ ../server/ocsigen_extensions.cmi \ @@ -66,11 +60,9 @@ redirectmod.cmo : ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi redirectmod.cmx : ../baselib/ocsigen_lib.cmx ../server/ocsigen_extensions.cmx revproxy.cmo : ../baselib/ocsigen_stream.cmi \ ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi \ ../server/ocsigen_extensions.cmi revproxy.cmx : ../baselib/ocsigen_stream.cmx \ ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx \ ../server/ocsigen_extensions.cmx rewritemod.cmo : \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi @@ -78,11 +70,9 @@ rewritemod.cmx : \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx staticmod.cmo : \ ../server/ocsigen_local_files.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_http_com.cmi \ ../server/ocsigen_extensions.cmi ../http/http_headers.cmi staticmod.cmx : \ ../server/ocsigen_local_files.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../http/ocsigen_http_com.cmx \ ../server/ocsigen_extensions.cmx ../http/http_headers.cmx userconf.cmo : ../server/ocsigen_request_info.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index 8bf308ed6..52369ecf3 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -23,7 +23,6 @@ open Ocsigen_lib open Simplexmlparser -open Ocsigen_http_frame let section = Lwt_log.Section.make "ocsigen:ext:access-control" diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index c22d3feec..47690636f 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -67,8 +67,8 @@ let gen ~realm ~auth rs = Http_headers.empty in Lwt_log.ign_info ~section "AUTH: invalid credentials!"; - Lwt.fail - (Ocsigen_http_frame.Http_error.Http_exception (401, None, Some h)) + Lwt.fail (Ocsigen_cohttp_server.Ext_http_error + (`Unauthorized, None, Some h)) and invalid_header () = Lwt_log.ign_info ~section diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index 0a4dacc47..236c572ad 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -30,7 +30,7 @@ let default_frame () = () type config = { - allowed_method : Ocsigen_http_frame.Http_header.http_method list option; + allowed_method : Cohttp.Code.meth list option; (* None means: all method are accepted *) allowed_credentials : bool; max_age : int option; @@ -67,10 +67,11 @@ let add_headers config r response = | Some request_method -> let allowed_method = match config.allowed_method with - | None -> true + | None -> + true | Some l -> try - List.mem (Framepp.method_of_string request_method) l + List.mem (Cohttp.Code.method_of_string request_method) l with _ -> false in @@ -176,7 +177,7 @@ let parse_config _ _ parse_fun config_elem = ~name:"methods" (fun s -> let s = Netstring_pcre.split comma_space_regexp s in - let s = Some (List.map Framepp.method_of_string s) in + let s = Some (List.map Cohttp.Code.method_of_string s) in config := { !config with allowed_method = s }); ] ()] diff --git a/src/extensions/redirectmod.ml b/src/extensions/redirectmod.ml index 27607d2fc..813d2630f 100644 --- a/src/extensions/redirectmod.ml +++ b/src/extensions/redirectmod.ml @@ -52,7 +52,6 @@ let attempt_redir dir err ri () = "YES! %s redirection to: %s" (if temp then "Temporary " else "Permanent ") redir; - let empty_result = Ocsigen_http_frame.Result.empty () in Lwt.return @@ Ocsigen_extensions.Ext_found (fun () -> let response = let headers = Cohttp.Header.(init_with "Location" redir) diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 2264ea8c6..b8d861616 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -112,6 +112,18 @@ let find_static_page ~request ~usermode ~dir ~(err : Cohttp.Code.status) ~pathst raise (Ocsigen_extensions.Error_in_user_config_file "Staticmod: cannot use '..' in user paths") +(* FIXME Cohttp transition: this used to be in Ocsigen_http_com; find + a better place? *) +let gmt_date d = + let x = Netdate.mk_mail_date ~zone:0 d in try + (*XXX !!!*) + let ind_plus = Bytes.index x '+' in + Bytes.set x ind_plus 'G'; + Bytes.set x (ind_plus + 1) 'M'; + Bytes.set x (ind_plus + 2) 'T'; + String.sub x 0 (ind_plus + 3) + with Invalid_argument _ | Not_found -> + Lwt_log.ign_debug ~section "no +"; x let gen ~usermode ?cache dir = function | Ocsigen_extensions.Req_found (_, r) -> @@ -153,8 +165,7 @@ let gen ~usermode ?cache dir = function "no-cache", "0" else "max-age=" ^ string_of_int duration, - Ocsigen_http_com.gmtdate - (Unix.time () +. float_of_int duration) + gmt_date (Unix.time () +. float_of_int duration) in Ocsigen_cohttp_server.Answer.replace_headers answer [ Http_headers.cache_control , cache_control ; diff --git a/src/http/.depend b/src/http/.depend index fcd69cfcd..82577926d 100644 --- a/src/http/.depend +++ b/src/http/.depend @@ -1,54 +1,11 @@ -framepp.cmi : ocsigen_http_frame.cmi http_headers.cmi : -multipart.cmi : ../baselib/ocsigen_stream.cmi ocsigen_charset_mime.cmi : ocsigen_cookies.cmi : ../baselib/ocsigen_lib.cmi -ocsigen_http_com.cmi : ../baselib/ocsigen_stream.cmi ocsigen_http_frame.cmi \ - http_headers.cmi -ocsigen_http_frame.cmi : ../baselib/ocsigen_stream.cmi \ - ../baselib/ocsigen_lib.cmi ocsigen_cookies.cmi http_headers.cmi -ocsigen_senders.cmi : ../baselib/ocsigen_stream.cmi ocsigen_http_frame.cmi \ - ocsigen_http_com.cmi ocsigen_cookies.cmi ocsigen_charset_mime.cmi \ - http_headers.cmi -framepp.cmo : ocsigen_http_frame.cmi http_headers.cmi framepp.cmi -framepp.cmx : ocsigen_http_frame.cmx http_headers.cmx framepp.cmi http_headers.cmo : http_headers.cmi http_headers.cmx : http_headers.cmi -http_lexer.cmo : ocsigen_http_frame.cmi http_headers.cmi -http_lexer.cmx : ocsigen_http_frame.cmx http_headers.cmx -multipart.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ - multipart.cmi -multipart.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ - multipart.cmi ocsigen_charset_mime.cmo : ../baselib/ocsigen_lib.cmi \ ../baselib/ocsigen_config.cmi ocsigen_charset_mime.cmi ocsigen_charset_mime.cmx : ../baselib/ocsigen_lib.cmx \ ../baselib/ocsigen_config.cmx ocsigen_charset_mime.cmi ocsigen_cookies.cmo : ocsigen_cookies.cmi ocsigen_cookies.cmx : ocsigen_cookies.cmi -ocsigen_http_com.cmo : ../baselib/ocsigen_stream.cmi \ - ../baselib/ocsigen_lib.cmi ocsigen_http_frame.cmi ocsigen_cookies.cmi \ - ../baselib/ocsigen_config.cmi http_lexer.cmo http_headers.cmi framepp.cmi \ - ocsigen_http_com.cmi -ocsigen_http_com.cmx : ../baselib/ocsigen_stream.cmx \ - ../baselib/ocsigen_lib.cmx ocsigen_http_frame.cmx ocsigen_cookies.cmx \ - ../baselib/ocsigen_config.cmx http_lexer.cmx http_headers.cmx framepp.cmx \ - ocsigen_http_com.cmi -ocsigen_http_frame.cmo : ../baselib/ocsigen_stream.cmi \ - ../baselib/ocsigen_lib.cmi ocsigen_cookies.cmi http_headers.cmi \ - ocsigen_http_frame.cmi -ocsigen_http_frame.cmx : ../baselib/ocsigen_stream.cmx \ - ../baselib/ocsigen_lib.cmx ocsigen_cookies.cmx http_headers.cmx \ - ocsigen_http_frame.cmi -ocsigen_senders.cmo : ../baselib/ocsigen_stream.cmi \ - ../baselib/ocsigen_lib.cmi ocsigen_http_frame.cmi ocsigen_http_com.cmi \ - ocsigen_cookies.cmi ../baselib/ocsigen_config.cmi \ - ocsigen_charset_mime.cmi http_headers.cmi ocsigen_senders.cmi -ocsigen_senders.cmx : ../baselib/ocsigen_stream.cmx \ - ../baselib/ocsigen_lib.cmx ocsigen_http_frame.cmx ocsigen_http_com.cmx \ - ocsigen_cookies.cmx ../baselib/ocsigen_config.cmx \ - ocsigen_charset_mime.cmx http_headers.cmx ocsigen_senders.cmi -test_parser.cmo : ocsigen_http_frame.cmi http_lexer.cmo -test_parser.cmx : ocsigen_http_frame.cmx http_lexer.cmx -test_pp.cmo : ocsigen_http_frame.cmi framepp.cmi -test_pp.cmx : ocsigen_http_frame.cmx framepp.cmx diff --git a/src/http/LICENSE-multipart b/src/http/LICENSE-multipart deleted file mode 100644 index aeb426dd9..000000000 --- a/src/http/LICENSE-multipart +++ /dev/null @@ -1,24 +0,0 @@ -The librarie "netlwtstream.ml", comes from ocamlnet, and is distributed -under the terms of the following license. - ====================================================================== - -Copyright (c) 2001 Patrick Doane and Gerd Stolpmann - -This software is provided 'as-is', without any express or implied -warranty. In no event will the authors be held liable for any damages -arising from the use of this software. - -Permission is granted to anyone to use this software for any purpose, -including commercial applications, and to alter it and redistribute it -freely, subject to the following restrictions: - -1. The origin of this software must not be misrepresented; you must -not claim that you wrote the original software. If you use this -software in a product, an acknowledgment in the product documentation -would be appreciated but is not required. - -2. Altered source versions must be plainly marked as such, and must -not be misrepresented as being the original software. - -3. This notice may not be removed or altered from any source -distribution. \ No newline at end of file diff --git a/src/http/Makefile b/src/http/Makefile index f6c4f111e..b41855021 100644 --- a/src/http/Makefile +++ b/src/http/Makefile @@ -17,17 +17,11 @@ all: byte opt ### Common files ### -FILES := multipart.ml \ - http_headers.ml \ +FILES := http_headers.ml \ ocsigen_cookies.ml \ - ocsigen_http_frame.ml \ - http_lexer.ml \ - framepp.ml \ - ocsigen_http_com.ml \ - ocsigen_charset_mime.ml \ - ocsigen_senders.ml \ - -PREDEP := http_lexer.ml \ + ocsigen_charset_mime.ml + +PREDEP := byte: http.cma opt: http.cmxa diff --git a/src/http/framepp.ml b/src/http/framepp.ml deleted file mode 100644 index 57a2421d7..000000000 --- a/src/http/framepp.ml +++ /dev/null @@ -1,136 +0,0 @@ -(* Ocsigen - * framepp.ml Copyright (C) 2005 Denis Berthod - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - -(** pretty printer for http frames*) -open Ocsigen_http_frame - -module H = Http_header - -(** converts the method into a string*) -let string_of_method = - function - | H.GET -> "GET" - | H.POST -> "POST" - | H.HEAD -> "HEAD" - | H.PUT -> "PUT" - | H.DELETE -> "DELETE" - | H.TRACE -> "TRACE" - | H.OPTIONS -> "OPTIONS" - | H.CONNECT -> "CONNECT" - | H.LINK -> "LINK" - | H.UNLINK -> "UNLINK" - | H.PATCH -> "PATCH" - -(** converts a string to a method *) -let method_of_string = - function - | "GET" -> H.GET - | "POST" -> H.POST - | "HEAD" -> H.HEAD - | "PUT" -> H.PUT - | "DELETE" -> H.DELETE - | "TRACE" -> H.TRACE - | "OPTIONS" -> H.OPTIONS - | "CONNECT" -> H.CONNECT - | "LINK" -> H.LINK - | "UNLINK" -> H.UNLINK - | "PATCH" -> H.PATCH - | _ -> failwith "method_of_string" - -(** converts the protocol into a string *) -let string_of_proto = function - | H.HTTP10 -> "HTTP/1.0" - | H.HTTP11 -> "HTTP/1.1" - -(** converts a string to a protocol *) -let proto_of_string = function - | "HTTP/1.0" -> H.HTTP10 - | "HTTP/1.1" -> H.HTTP11 - | _ -> failwith "proto_of_string" - -(** Write the first line of an HTTP frame to a string buffer *) -let fst_line buf header = - match header.H.mode with - | H.Nofirstline -> () - | H.Answer code -> - Printf.bprintf buf "%s %i %s\r\n" (string_of_proto header.H.proto) - code (Http_error.expl_of_code code) - | H.Query (meth, url) -> - Printf.bprintf buf "%s %s %s\r\n" - (string_of_method meth) url (string_of_proto header.H.proto) - - -(** Prints the content of a header. To prevent http header injection, - we insert spaces (' ') after CRLF, in case the user has not done this - himself. Also, if we find single CR or LF, we replace them by spaces . - (This is correct according to the RFC, as the headers content should not - contain single CR or LF anyway) *) -let print_header_content buf content = - let s = String.length content in - let rec aux prev i = - if i = s then - (if prev < s then - Buffer.add_substring buf content prev (s-prev)) - else - let add_prev () = Buffer.add_substring buf content prev (i-prev) in - match content.[i] with - | '\n' | '\r' as c -> - let i' = i+1 in - let escape_c () = - add_prev (); - Buffer.add_char buf c; - Buffer.add_char buf ' '; - aux i' i' - in - if i' < s then - (match content.[i'] with - | '\n' | '\r' as c' when c <> c' -> - add_prev (); - Buffer.add_char buf c; Buffer.add_char buf c'; - Buffer.add_char buf ' '; - aux (i+2) (i+2) - - | _ -> escape_c () - ) else - escape_c () - - | _ -> - aux prev (i+1) - in - aux 0 0 - -(* Debug *) -let test s = - let b = Buffer.create 0 in print_header_content b s; Buffer.contents b - - -(** Write the header lines to a string buffer *) -let headers buf header = - Http_headers.iter - (fun name value -> - Printf.bprintf buf "%s: %a\r\n" - (Http_headers.name_to_string name) print_header_content value) - header.H.headers - -(** Convert a HTTP header into a string *) -let string_of_header hds = - let buf = Buffer.create 200 in - fst_line buf hds; - headers buf hds; - Printf.bprintf buf "\r\n%!"; - Buffer.contents buf diff --git a/src/http/framepp.mli b/src/http/framepp.mli deleted file mode 100644 index 79b92a421..000000000 --- a/src/http/framepp.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Ocsigen - * framepp.mli Copyright (C) 2005 Denis Berthod - * Laboratoire PPS - CNRS Université Paris Diderot - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - -val string_of_header : Ocsigen_http_frame.Http_header.http_header -> string - -val string_of_method : Ocsigen_http_frame.Http_header.http_method -> string - -val method_of_string : string -> Ocsigen_http_frame.Http_header.http_method - -val string_of_proto : Ocsigen_http_frame.Http_header.proto -> string - -val proto_of_string : string -> Ocsigen_http_frame.Http_header.proto diff --git a/src/http/http_lexer.mll b/src/http/http_lexer.mll deleted file mode 100644 index 5be225ffa..000000000 --- a/src/http/http_lexer.mll +++ /dev/null @@ -1,121 +0,0 @@ -{ - (* Ocsigen - * http://www.ocsigen.org - * http_lexer.mll Copyright (C) 2005 Denis Berthod - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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 Ocsigen_http_frame -open Http_header - - -let meth_of_string = - function - | "GET" -> GET - | "POST" -> POST - | "HEAD" -> HEAD - | "PUT" -> PUT - | "DELETE" -> DELETE - | "TRACE" -> TRACE - | "OPTIONS" -> OPTIONS - | "CONNECT" -> CONNECT - | "LINK" -> LINK - | "UNLINK" -> UNLINK - | "PATCH" -> PATCH - | s -> raise (Http_error.Http_exception (405, Some ("unknown method "^s), None)) - -let proto_of_string s = match String.uppercase s with - | "HTTP/1.1" -> HTTP11 - | "HTTP/1.0" -> HTTP10 - | s -> raise (Http_error.Http_exception (505, None, None)) - -let add_header (n, v) h = - let field = String.concat " " (List.rev v) in - { h with headers = Http_headers.add n field h.headers } - -let handle_eof lexbuf = - raise (Http_error.Http_exception (400, Some "unexpected end of file", None)) -let handle_other lexbuf = - raise (Http_error.Http_exception - (400, Some ("unexpected character " ^ Lexing.lexeme lexbuf), None)) -} - -(* RFC 2616, sect. 2.2 *) -let char = ['\000'-'\127'] -let ctl = ['\000'-'\031' '\127'] -let lowalpha = ['a'-'z'] -let upalpha = ['A'-'Z'] -let alpha = upalpha | lowalpha -let digit = ['0'-'9'] -let alpha = lowalpha | upalpha -let blank = [' ' '\t'] -let crlf = "\r"? "\n" -let separators = - ['(' ')' '<' '>' '@' ',' ';' ':' '\\' '\"' - '/' '[' ']' '?' '=' '{' '}' ' ' '\t'] -let lws = crlf? [' ' '\t'] + - - let method_ = alpha* - - (* it is more general than what RFC request *) - let request_URI = (_ #ctl #[' '] )* - let http_version = ['h' 'H'] ['t' 'T'] ['t' 'T'] ['p' 'P'] "/" digit+ "." digit+ - - let token = ((char #separators) #ctl)+ - (* token = 1* *) - - let field_name = token -let field_content = (_ #ctl #[' '] )* - (* *) - - let status_code = digit digit digit -let reason_phrase = (_ #ctl)* - - let sp = blank+ - - rule header = parse - | (method_ as meth) sp (request_URI as uri) sp (http_version as version) crlf - {nofirstline - { proto = proto_of_string(version); - mode = Query ( meth_of_string(meth), uri ); - headers = Http_headers.empty } - lexbuf } - | (http_version as version) sp ( status_code as status_code ) sp reason_phrase crlf - {nofirstline - { proto = proto_of_string(version); - mode = Answer ( int_of_string status_code ); - headers = Http_headers.empty } - lexbuf } - | eof { handle_eof lexbuf } - | _ { handle_other lexbuf } - - and nofirstline h = parse - | crlf { h } - | (field_name as field_name) ":" { line field_name [] h lexbuf } - | eof { handle_eof lexbuf } - | _ { handle_other lexbuf } - - and line name content h = parse - | crlf crlf { add_header (Http_headers.name name,content) h } - | crlf (field_name as field_name) ":" - { line field_name [] (add_header (Http_headers.name name,content) h) lexbuf } - | lws { line name content h lexbuf } - | blank { line name content h lexbuf } - | ( field_content as c ) { line name (c::content) h lexbuf } - | eof { handle_eof lexbuf } - | _ { handle_other lexbuf } diff --git a/src/http/multipart.ml b/src/http/multipart.ml deleted file mode 100644 index 37735f10d..000000000 --- a/src/http/multipart.ml +++ /dev/null @@ -1,270 +0,0 @@ -(* This code is inspired by mimestring.ml from OcamlNet *) -(* Copyright Gerd Stolpmann, Patrick Doane *) -(* Modified for Ocsigen/Lwt by Nataliya Guts and Vincent Balat *) - -(*VVV Check wether we should support int64 for large files? *) - -open Ocsigen_lib - -module S = Netstring_pcre -open Lwt -open Ocsigen_stream - -exception Multipart_error of string - -let cr_or_lf_re = S.regexp "[\013\n]";; - -let header_stripped_re = - S.regexp "([^ \t\r\n:]+):[ \t]*((.*[^ \t\r\n])?([ \t\r]*\n[ \t](.*[^ \t\r\n])?)*)[ \t\r]*\n";; - -let header_unstripped_re = - S.regexp "([^ \t\r\n:]+):([ \t]*.*\n([ \t].*\n)*)";; -(* This much simpler expression returns the name and the unstripped - * value. -*) - -let empty_line_re = - S.regexp "\013?\n";; - -let end_of_header_re = - S.regexp "\n\013?\n";; - - -let scan_header ?(downcase=true) - ?(unfold=true) - ?(strip=false) - parstr ~start_pos:i0 ~end_pos:i1 = - let header_re = - if unfold || strip then header_stripped_re else header_unstripped_re in - let rec parse_header i l = - match S.string_match header_re parstr i with - Some r -> - let i' = S.match_end r in - if i' > i1 then - raise (Multipart_error "Mimestring.scan_header"); - let name = - if downcase then - String.lowercase(S.matched_group r 1 parstr) - else - S.matched_group r 1 parstr - in - let value_with_crlf = - S.matched_group r 2 parstr in - let value = - if unfold then - S.global_replace cr_or_lf_re "" value_with_crlf - else - value_with_crlf - in - parse_header i' ( (name,value) :: l) - | None -> - (* The header must end with an empty line *) - begin match S.string_match empty_line_re parstr i with - Some r' -> - List.rev l, S.match_end r' - | None -> - raise (Multipart_error "Mimestring.scan_header") - end - in - parse_header i0 [] -;; - - -let read_header ?downcase ?unfold ?strip s = - let rec find_end_of_header s = - catch - (fun () -> - let b = Ocsigen_stream.current_buffer s in - (* Maybe the header is empty. In this case, there is an empty line - * right at the beginning - *) - match S.string_match empty_line_re b 0 with - Some r -> - return (s, (S.match_end r)) - | None -> - (* Search the empty line: *) - return - (s, (S.match_end (snd (S.search_forward end_of_header_re b 0)))) - ) - (function - | Not_found -> - Ocsigen_stream.enlarge_stream s >>= - (function - Finished _ -> fail Stream_too_small - | Cont (stri, _) as s -> find_end_of_header s) - | e -> fail e) - in - find_end_of_header s >>= (fun (s, end_pos) -> - let b = Ocsigen_stream.current_buffer s in - let header, _ = - scan_header ?downcase ?unfold ?strip b ~start_pos:0 ~end_pos - in - Ocsigen_stream.skip s (Int64.of_int end_pos) >>= - (fun s -> return (s, header))) -;; - - -let lf_re = S.regexp "[\n]";; - - -let read_multipart_body decode_part boundary s = - - let rec search_window s re start = - try - return (s, snd (S.search_forward re (Ocsigen_stream.current_buffer s) start)) - with - Not_found -> - Ocsigen_stream.enlarge_stream s >>= - (function - | Finished _ -> fail Stream_too_small - | Cont (stri, _) as s -> search_window s re start) - in - let search_end_of_line s k = - (* Search LF beginning at position k *) - catch - (fun () -> (search_window s lf_re k) >>= - (fun (s, x) -> return (s, (S.match_end x)))) - (function - | Not_found -> - fail (Multipart_error - "read_multipart_body: MIME boundary without line end") - | e -> fail e) - in - - let search_first_boundary s = - (* Search boundary per regexp; return the position of the character - * immediately following the boundary (on the same line), or - * raise Not_found. - *) - let re = S.regexp ("\n--" ^ S.quote boundary) in - (search_window s re 0) >>= (fun (s, x) -> return (s, (S.match_end x))) - in - - let check_beginning_is_boundary s = - let del = "--" ^ boundary in - let ldel = String.length del in - Ocsigen_stream.stream_want s (ldel + 2) >>= (function - | Finished _ as str2 -> return (str2, false, false) - | Cont (ss, f) as str2 -> - let long = String.length ss in - let isdelim = (long >= ldel) && (String.sub ss 0 ldel = del) in - let islast = isdelim && (String.sub ss ldel 2 = "--") in - return (str2, isdelim, islast)) - in - - let rec parse_parts s uses_crlf = - (* PRE: [s] is at the beginning of the next part. - * [uses_crlf] must be true if CRLF is used as EOL sequence, and false - * if only LF is used as EOL sequence. - *) - let delimiter = (if uses_crlf then "\r" else "" ) ^ "\n--" ^ boundary in - Ocsigen_stream.substream delimiter s >>= fun a -> - decode_part a >>= fun (y, s) -> - (* Now the position of [s] is at the beginning of the delimiter. - * Check if there is a "--" after the delimiter (==> last part) - *) - let l_delimiter = String.length delimiter in - Ocsigen_stream.next s >>= fun s -> - Ocsigen_stream.stream_want s (l_delimiter+2) >>= fun s -> - let last_part = match s with - | Finished _ -> false - | Cont (ss, f) -> - let long = String.length ss in - (long >= (l_delimiter+2)) && - (ss.[l_delimiter] = '-') && - (ss.[l_delimiter+1] = '-') - in - if last_part then - return [ y ] - else begin - search_end_of_line s 2 >>= fun (s, k) -> - (* [k]: Beginning of next part *) - Ocsigen_stream.skip s (Int64.of_int k) >>= fun s -> - parse_parts s uses_crlf >>= fun l -> - return (y :: l) - end - in - - (* Check whether s directly begins with a boundary: *) - check_beginning_is_boundary s >>= fun (s, b, islast) -> - if islast then return [] - else - if b then begin - (* Move to the beginning of the next line: *) - search_end_of_line s 0 >>= (fun (s, k_eol) -> - let uses_crlf = (Ocsigen_stream.current_buffer s).[k_eol-2] = '\r' in - Ocsigen_stream.skip s (Int64.of_int k_eol) >>= fun s -> - (* Begin with first part: *) - parse_parts s uses_crlf) - end - else begin - (* Search the first boundary: *) - catch - (fun () -> - search_first_boundary s >>= fun (s, k_eob) -> (* or Not_found *) - (* Printf.printf "k_eob=%d\n" k_eob; *) - (* Move to the beginning of the next line: *) - search_end_of_line s k_eob >>= fun (s, k_eol) -> - let uses_crlf = (Ocsigen_stream.current_buffer s).[k_eol-2] = '\r' in - (* Printf.printf "k_eol=%d\n" k_eol; *) - Ocsigen_stream.skip s (Int64.of_int k_eol) >>= fun s -> - (* Begin with first part: *) - parse_parts s uses_crlf) - (function - | Not_found -> - (* No boundary at all: The body is empty. *) - return [] - | e -> fail e) - end -;; - -let empty_stream = - Ocsigen_stream.get (Ocsigen_stream.make (fun () -> Ocsigen_stream.empty None)) - -let scan_multipart_body_from_stream s ~boundary ~create ~add ~stop ~maxsize= - let decode_part stream = - read_header stream >>= (fun (s, header) -> - let p = create header in - let rec while_stream size = function - | Finished None -> return (size, empty_stream) - | Finished (Some ss) -> return (size, ss) - | Cont (stri, f) -> - let long = String.length stri in - let size2 = Int64.add size (Int64.of_int long) in - if - (match maxsize with - None -> false - | Some m -> - (Int64.compare size2 m) > 0) - then - fail Ocsigen_Request_too_long - else - if stri = "" - then Ocsigen_stream.next f >>= while_stream size - else ((* catch - (fun () -> - add p stri) - (fun e -> f () >>= - Ocsigen_stream.consume >>= - (fun () -> fail e)) *) - add p stri >>= fun () -> - Ocsigen_stream.next f >>= - while_stream size2) - in - catch - (fun () -> while_stream Int64.zero s >>= - (fun (size, s) -> stop size p >>= fun r -> return (r, s))) - (function - error -> stop Int64.zero p >>= fun _ -> fail error)) - in - catch - (fun () -> - (* read the multipart body: *) - Ocsigen_stream.next s >>= fun s -> - read_multipart_body decode_part boundary s >>= - (fun _ -> return ())) - (function - | Stream_too_small -> fail Ocsigen_Bad_Request - | e -> fail e) -;; - diff --git a/src/http/multipart.mli b/src/http/multipart.mli deleted file mode 100644 index b35219d1c..000000000 --- a/src/http/multipart.mli +++ /dev/null @@ -1,8 +0,0 @@ - -val scan_multipart_body_from_stream: - string Ocsigen_stream.stream -> - boundary:string -> - create:((string * string) list -> 'a) -> - add:('a -> string -> unit Lwt.t) -> - stop:(int64 -> 'a -> 'b Lwt.t) -> - maxsize:Int64.t option -> unit Lwt.t diff --git a/src/http/ocsigen_http_com.ml b/src/http/ocsigen_http_com.ml deleted file mode 100644 index d64e760e2..000000000 --- a/src/http/ocsigen_http_com.ml +++ /dev/null @@ -1,989 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * ocsigen_http_com.ml Copyright (C) 2005 - * Denis Berthod, Vincent Balat, Jérôme Vouillon - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - -(* -TODO -- server.ml -- shorter timeouts for keep-alive -- check the code against the HTTP spec -- defunctorize sender code -- rewrite HTTP parser -- check HTTP version (at the moment, we always respond with HTTP/1.1!!!) -- for possibly large reads/writes on the network (streaming of more - than a few kilobytes), we should use Lwt_unix.wait_read and - Lwt_unix.wait_write: this gives some time for other requests to be - handled, and the read/write is resumed only when necessary - -PERSISTENT CONNECTIONS -====================== -http://www.tools.ietf.org/html/draft-ietf-http-connection-00 -*) - -open Ocsigen_lib - -open Ocsigen_http_frame -open Ocsigen_cookies - -let section = Lwt_log.Section.make "ocsigen:http:com" - -(** this module provide a mecanism to communicate with some http frames *) - -let (>>=) = Lwt.(>>=) - -(****) - -(** Internal exceptions *) -exception Buffer_full - -(** Exported exceptions *) -exception Connection_closed -exception Lost_connection of exn -exception Timeout -exception Keepalive_timeout -exception Aborted - -(*XXX Provide the max size? *) -let request_too_large max = - Ocsigen_http_frame.Http_error.Http_exception - (413, Some "request contents too large", None) - -let convert_io_error e = - match e with - Unix.Unix_error(Unix.ECONNRESET,_,_) - | Ssl.Read_error (Ssl.Error_syscall | Ssl.Error_ssl) - | End_of_file - | Ssl.Write_error (Ssl.Error_zero_return | Ssl.Error_syscall | Ssl.Error_ssl) - | Unix.Unix_error (Unix.EPIPE, _, _) -> - Lost_connection e - | _ -> - e - -let catch_io_errors f = - Lwt.catch f (fun e -> Lwt.fail (convert_io_error e)) - -(****) - -type mode = Answer | Query | Nofirstline - -type waiter = - { w_wait : unit Lwt.t; - w_waker: unit Lwt.u option; - mutable w_did_wait : bool } - -let create_waiter block = - if block then - let (t, u) = Lwt.wait () in - { w_wait = t; w_waker = Some u; w_did_wait = false } - else - { w_wait = Lwt.return (); w_waker = None; w_did_wait = false } - -(** Communication buffer to receive messages. *) -type connection = - { id : int; - fd : Lwt_ssl.socket; - chan : Lwt_io.output_channel; - timeout : Lwt_timeout.t; - r_mode : mode; - closed : unit Lwt.t * unit Lwt.u; - mutable buf : string; - mutable read_pos : int; - mutable write_pos : int; - mutable read_mutex : Lwt_mutex.t; - mutable extension_mutex : Lwt_mutex.t; (* to keep requests in right order *) - mutable senders : waiter; - mutable sender_count : int } - -let connection_id x = x.id -let connection_fd x = x.fd - -let new_id = - let c = ref 0 in - fun () -> incr c; !c - -let create_receiver timeout mode fd = - let buffer_size = Ocsigen_config.get_netbuffersize () in - let timeout = - Lwt_timeout.create - timeout - (fun () -> Lwt_ssl.abort fd Timeout) - in - { id = new_id (); - fd = fd; - chan = - Lwt_io.make - ~mode:Lwt_io.output - ~buffer:(Lwt_bytes.create buffer_size) - (fun buf pos len -> - Lwt_timeout.start timeout; - Lwt.try_bind - (fun () -> Lwt_ssl.write_bytes fd buf pos len) - (fun l -> Lwt_timeout.stop timeout; Lwt.return l) - (fun e -> Lwt_timeout.stop timeout; - Lwt.fail (convert_io_error e))); - timeout = timeout; - r_mode = mode; - buf=Bytes.create buffer_size; - read_pos = 0; - write_pos = 0; - closed = Lwt.wait (); - read_mutex = Lwt_mutex.create (); - extension_mutex = Lwt_mutex.create (); - senders = create_waiter false; - sender_count = 0 } - - -(*XXX Do we really need to export this function? *) -let lock_receiver receiver = Lwt_mutex.lock receiver.read_mutex - -let unlock_receiver receiver = Lwt_mutex.unlock receiver.read_mutex - -let abort conn = - Lwt.wakeup (snd conn.closed) (); - Lwt_ssl.abort conn.fd Aborted - -let closed conn = fst conn.closed - -let wakeup_next_request conn = Lwt_mutex.unlock conn.extension_mutex - -let block_next_request conn = Lwt_mutex.lock conn.extension_mutex - -(****) - -(** the number of byte in the buffer*) -let buf_used buffer = buffer.write_pos - buffer.read_pos -let buf_size buffer = Bytes.length buffer.buf - -let buf_get_string buffer len = - let pos = buffer.read_pos in - assert (pos + len <= buffer.write_pos); - buffer.read_pos <- buffer.read_pos + len; - Bytes.sub buffer.buf pos len - -(** Receive some more data. *) -let receive receiver = - let used = buf_used receiver in - let free = buf_size receiver - used in - if free = 0 then - Lwt.fail Buffer_full - else begin - if receiver.read_pos > 0 then begin - Bytes.blit receiver.buf receiver.read_pos receiver.buf 0 used; - receiver.write_pos <- used; - receiver.read_pos <- 0 - end; - if receiver.sender_count = 0 then Lwt_timeout.start receiver.timeout; - Lwt_ssl.read receiver.fd receiver.buf receiver.write_pos free - >>= fun len -> - Lwt_timeout.stop receiver.timeout; - receiver.write_pos <- used + len; - if len = 0 then - Lwt.fail End_of_file - else begin - Lwt.return () - end - end - -(** Receive data until at least [len] chars are available *) -let rec fill receiver len = - if buf_used receiver >= len then - Lwt.return () - else begin - receive receiver >>= fun () -> - fill receiver len - end - -(****) - -type size = Exact of int64 | Bounded of int64 option - -let rec extract_aux receiver pos bound cont = - let avail = buf_used receiver in - if avail = 0 then - Lwt.try_bind - (fun () -> receive receiver) - (fun () -> extract_aux receiver pos bound cont) - (fun e -> - match e, bound with - End_of_file, Bounded _ -> - Ocsigen_stream.empty None - | _ -> - Lwt.fail (convert_io_error e)) - else - let pos' = Int64.add pos (Int64.of_int avail) in - match bound with - Exact l when pos' >= l -> - let len = Int64.to_int (Int64.sub l pos) in - let s = buf_get_string receiver len in - Ocsigen_stream.cont s cont - | Bounded (Some l) when pos' > l -> - Lwt.fail (request_too_large l) - | _ -> - let s = buf_get_string receiver avail in - Ocsigen_stream.cont s (fun () -> extract_aux receiver pos' bound cont) - -(** Stream from the receiver channel. *) -let extract receiver bound = - Ocsigen_stream.make (fun () -> - extract_aux receiver 0L bound - (fun () -> - Lwt_mutex.unlock receiver.read_mutex; - Ocsigen_stream.empty None)) - -type pat_res = Found of int | Retry of int - -(** Wait for a given pattern to be received *) -let rec wait_pattern find_pattern receiver cur_pos = - let read_pos = receiver.read_pos in - let avail = receiver.write_pos - (cur_pos + read_pos) in - match find_pattern receiver.buf (cur_pos + read_pos) avail with - Found end_pos -> - Lwt.return (end_pos - read_pos) - | Retry retry_pos -> - let pos = max 0 (retry_pos - read_pos) in - receive receiver >>= fun () -> - wait_pattern find_pattern receiver pos - -(** Find the first sequence crlfcrlf or lflf in the buffer *) -let rec find_header buf pos rem = - if rem < 2 then - Retry (pos - 3) - else if buf.[pos + 1] <> '\n' then - find_header buf (pos + 1) (rem - 1) - else if buf.[pos] = '\n' then - Found (pos + 2) - else if - rem >= 4 && buf.[pos] = '\r' && - buf.[pos + 2] = '\r' && buf.[pos + 3] = '\n' - then - Found (pos + 4) - else - find_header buf (pos + 1) (rem - 1) - -(** Wait until a full header is received. Returns the length of - the header *) -let wait_http_header receiver = - Lwt.catch - (fun () -> wait_pattern find_header receiver 0) - (fun e -> - Lwt.fail - (match e with - Buffer_full -> - Ocsigen_http_frame.Http_error.Http_exception - (413, Some "header too long", None) - | End_of_file when buf_used receiver = 0 -> - Connection_closed - | Timeout when buf_used receiver = 0 && receiver.sender_count = 0 -> - Keepalive_timeout - | _ -> - convert_io_error e)) - -(** Find an end of line crlf or lf in the buffer *) -let rec find_line buf pos rem = - if rem < 1 then Retry pos else - if buf.[pos] = '\n' then Found (pos + 1) else - find_line buf (pos + 1) (rem - 1) - -(** Wait until a full line is received. - Returns the length of the line *) -let wait_line receiver = wait_pattern find_line receiver 0 - -(** extract chunked data in destructive way from the buffer. - The optional [?finish] parameter is an action that - will be executed when the stream is finished. -*) -let extract_chunked receiver = - let ec_fail e = - let e = - if e = Buffer_full then - Ocsigen_http_frame.Http_error.Http_exception - (400, Some "bad chunked data", None) - else - convert_io_error e - in - Lwt.fail e - in - let extract_crlf receiver = - Lwt.catch - (fun () -> - fill receiver 2 >>= fun () -> - let pos = receiver.read_pos in - if - receiver.buf.[pos] = '\r' && receiver.buf.[pos + 1] = '\n' - then begin - receiver.read_pos <- pos + 2; - Lwt.return () - end else - Lwt.fail - (Ocsigen_http_frame.Http_error.Http_exception - (400, Some "bad chunked data", None))) - ec_fail - in - let rec aux () = - Lwt.try_bind (fun () -> wait_line receiver) - (fun len -> - let chunksize = buf_get_string receiver len in - (*XXX Should check that we really have chunked data *) - let chunksize = Scanf.sscanf chunksize "%x" (fun x -> x) in - if chunksize = 0 then begin - extract_crlf receiver >>= fun () -> - Lwt_mutex.unlock receiver.read_mutex; - Ocsigen_stream.empty None - end else - extract_aux receiver 0L (Exact (Int64.of_int chunksize)) - (fun () -> extract_crlf receiver >>= fun () -> aux ())) - ec_fail - in - Ocsigen_stream.make aux - -(* RFC2616, sect 4.3 *) -let code_without_message_body code = - (code >= 100 && code < 200) || code = 204 || code = 304 - -let parse_http_header mode s = - (*XXX Should check that the message corresponds to the mode *) - let lexbuf = Lexing.from_string s in - try - Lwt.return - (if mode = Nofirstline then - Http_lexer.nofirstline - { Ocsigen_http_frame.Http_header.mode = - Ocsigen_http_frame.Http_header.Nofirstline; - proto = - Ocsigen_http_frame.Http_header.HTTP11; - headers = Http_headers.empty } - lexbuf - else - Http_lexer.header lexbuf) - with Parsing.Parse_error -> - Lwt.fail (Ocsigen_http_frame.Http_error.Http_exception - (400, Some "parse error", None)) - -let get_maxsize = function - | Nofirstline - | Answer -> None (* Ocsigen_config.get_maxanswerbodysize () - Do we need a limit? - If yes, add an exception Ocsigen_Answer_too_long. - (like Ocsigen_Request_too_long) - *) - | Query -> Ocsigen_config.get_maxrequestbodysize () - - -let return_with_no_body receiver = Lwt.return None - - -(** get an http frame *) -let get_http_frame ?(head = false) receiver = - - Lwt_mutex.lock receiver.read_mutex >>= fun () -> - wait_http_header receiver >>= fun len -> - let string_header = buf_get_string receiver len in - parse_http_header receiver.r_mode string_header >>= fun header -> - (* RFC2616, sect 4.4 - 1. Any response message which "MUST NOT" include a message-body - (such as the 1xx, 204, and 304 responses and any response to a HEAD - request) is always terminated by the first empty line after the - header fields, regardless of the entity-header fields present in - the message. - *) - begin match header.Ocsigen_http_frame.Http_header.mode with - | Ocsigen_http_frame.Http_header.Answer code - when code_without_message_body code -> - return_with_no_body receiver - | _ -> - if head then begin - return_with_no_body receiver - end - else begin - (* RFC - 2. If a Transfer-Encoding header field (section 14.41) is present - and has any value other than "identity", then the transfer-length - is defined by use of the "chunked" transfer-coding (section 3.6), - unless the message is terminated by closing the connection. - *) - let chunked = - try - Ocsigen_http_frame.Http_header.get_headers_value - header Http_headers.transfer_encoding <> "identity" - with Not_found -> - false - in - if chunked then - Lwt.return (Some (extract_chunked receiver)) - else begin - (* RFC - 3. If a Content-Length header field (section 14.13) is present, its - decimal value in OCTETs represents both the entity-length and the - transfer-length. The Content-Length header field MUST NOT be sent - if these two lengths are different (i.e., if a Transfer-Encoding - header field is present). If a message is received with both a - Transfer-Encoding header field and a Content-Length header field, - the latter MUST be ignored. - *) - let content_length = - try - (*XXX Check for overflow/malformed field... *) - Some - (Int64.of_string - (Ocsigen_http_frame.Http_header.get_headers_value - header Http_headers.content_length)) - with Not_found -> - None - in - match content_length with - | Some cl -> - if cl < 0L then - (*XXX Malformed field!!!*) - Lwt.fail - (Ocsigen_http_frame.Http_error.Http_exception - (400, Some "ill-formed content-length header", None)) - else if cl = 0L then - return_with_no_body receiver - else - let max = get_maxsize receiver.r_mode in - begin match max with - Some m when cl > m -> - Lwt.fail (request_too_large m) - | _ -> - Lwt.return (Some (extract receiver (Exact cl))) - end - | None -> - (* RFC - 4. If the message uses the media type "multipart/byteranges", and - the transfer-length is not otherwise specified, then this self- - delimiting media type defines the transfer-length. This media type - MUST NOT be used unless the sender knows that the recipient can parse - it; the presence in a request of a Range header with multiple byte- - range specifiers from a 1.1 client implies that the client can parse - multipart/byteranges responses. - NOT IMPLEMENTED - - 5. By the server closing the connection. (Closing the connection - cannot be used to indicate the end of a request body, since that - would leave no possibility for the server to send back a response.) - *) - match header.Ocsigen_http_frame.Http_header.mode with - Ocsigen_http_frame.Http_header.Query (_, s) -> - return_with_no_body receiver - | _ -> - let st = - extract receiver - (Bounded (get_maxsize receiver.r_mode)) in - Lwt.return (Some st) - end - end - end >>= fun b -> - let la = - (match b with - | None -> Lwt_mutex.unlock receiver.read_mutex; None - | Some s -> - Ocsigen_stream.add_finalizer s (fun _ -> Ocsigen_stream.consume s); - Some s - ) - in - Lwt.return {Ocsigen_http_frame.frame_header = header; - frame_content = la; - frame_abort = - (fun () -> Lwt_ssl.close receiver.fd)} -(*VVV close or shutdown? *) - -(****) - -type slot = - { sl_waiter : waiter; - sl_chan : Lwt_io.output_channel; - sl_ssl : bool (* for secure cookies only *)} - -let create_slot conn = - { sl_waiter = conn.senders; - sl_chan = conn.chan; - sl_ssl = Lwt_ssl.is_ssl conn.fd} - -(****) - -let start_processing conn f = - let slot = create_slot conn in - let next_waiter = create_waiter true in - conn.senders <- next_waiter; - conn.sender_count <- conn.sender_count + 1; - Lwt_timeout.stop conn.timeout; - ignore (* We can ignore the thread as all the exceptions are caught *) - (Lwt.try_bind - (fun () -> - Lwt.finalize - (fun () -> - (* If we want to serialize query processing, we can call - [wait_previous_senders slot] here. But then, we should - also flush the channel sooner. *) - f slot >>= (fun () -> - (*XXX Check that we waited: slot.sl_did_wait = true *) - (*XXX It would be clearer to put this code at the end of the sender function, - but we don't have access to [next_slot] there *) - if not next_waiter.w_did_wait then - Lwt_io.flush conn.chan - else - Lwt.return ())) - (fun () -> - conn.sender_count <- conn.sender_count - 1; - if conn.sender_count = 0 then Lwt_timeout.start conn.timeout; - Lwt.return ())) - (fun () -> - (match next_waiter.w_waker with - | None -> () - | Some wk -> Lwt.wakeup wk ()) - ; Lwt.return () - ) - (fun e -> - (match next_waiter.w_waker with - | None -> () - | Some wk -> Lwt.wakeup_exn wk e) - ; Lwt.return () - )) - -let wait_previous_senders slot = - slot.sl_waiter.w_did_wait <- true; - slot.sl_waiter.w_wait - -let wait_all_senders conn = - Lwt.finalize - (fun () -> - Lwt.catch - (*XXX Do we need a flush here? Are we properly flushing in case of an error? *) - (fun () -> - conn.senders.w_wait >>= fun () -> - Lwt_io.flush conn.chan) - (fun e -> match e with Aborted -> Lwt.return () | _ -> Lwt.fail e)) - (fun () -> - Lwt_timeout.stop conn.timeout; - Lwt.return ()) - - - -let (<<) h (n, v) = Http_headers.replace n v h - -let (< h (* None means: do not change the value *) - | Some v -> Http_headers.replace n v h - -let gmtdate d = - let x = Netdate.mk_mail_date ~zone:0 d in try - (*XXX !!!*) - let ind_plus = Bytes.index x '+' in - Bytes.set x ind_plus 'G'; - Bytes.set x (ind_plus + 1) 'M'; - Bytes.set x (ind_plus + 2) 'T'; - String.sub x 0 (ind_plus + 3) - with Invalid_argument _ | Not_found -> Lwt_log.ign_debug ~section "no +"; x - -type sender_type = { - (** protocol to be used : HTTP/1.0 HTTP/1.1 *) - mutable s_proto: Ocsigen_http_frame.Http_header.proto; - (** the options to send with each frame, for exemple : server name , ... *) - mutable s_headers: Http_headers.t -} - -(** create a new sender *) -let create_sender - ?server_name - ?(headers=Http_headers.empty) - ?(proto=Ocsigen_http_frame.Http_header.HTTP11) - () = - let headers = - Http_headers.replace Http_headers.accept_ranges "none" headers in - let headers = - Http_headers.replace_opt Http_headers.server server_name headers in - { s_headers = headers; s_proto = proto } - - -let default_sender = create_sender ~server_name:Ocsigen_config.server_name () - -(* Old version - (* XXX Maybe we should merge small strings *) - (* XXX We should probably make sure that any exception raised by - the stream is properly caught *) - let rec write_stream_chunked out_ch stream = - Ocsigen_stream.next stream >>= fun e -> - match e with - Ocsigen_stream.Finished _ -> - Lwt_io.write out_ch "0\r\n\r\n" - | Ocsigen_stream.Cont (s, next) -> - let l = String.length s in - begin if l = 0 then - (* It is incorrect to send an empty chunk *) - Lwt.return () - else begin - Lwt_io.write out_ch (Format.sprintf "%x\r\n" l) >>= fun () -> - Lwt_io.write out_ch s >>= fun () -> - Lwt_io.write out_ch "\r\n" - end end >>= fun () -> - write_stream_chunked out_ch next -*) - -(* XXX We should probably make sure that any exception raised by - the stream is properly caught *) -(* 20071128 Current xhtml pretty printer is making lots of very small strings. - We bufferise them before creating a thunk. - Benchmarks cannot prove that it is better, but at least the network stream - is readable ... - It is then buffered again by Lwt_io. - Is there a way to have only one buffer? -*) -let write_stream_chunked out_ch stream = - let buf_size = 4096 in - let size_for_not_buffering = 900 in - let buffer = Bytes.create buf_size in - let rec aux stream len = - Ocsigen_stream.next stream >>= fun e -> - match e with - | Ocsigen_stream.Finished _ -> - (if len > 0 then begin - (* It is incorrect to send an empty chunk *) - Lwt_io.write - out_ch (Format.sprintf "%x\r\n" len) >>= fun () -> - Lwt_io.write_from_exactly out_ch buffer 0 len >>= fun () -> - Lwt_io.write out_ch "\r\n" - end else - Lwt.return ()) >>= fun () -> - Lwt_io.write out_ch "0\r\n\r\n" - | Ocsigen_stream.Cont (s, next) -> - let l = String.length s in - if l = 0 then - aux next len - else - if l >= size_for_not_buffering then begin - (if len > 0 then begin - Lwt_io.write - out_ch (Format.sprintf "%x\r\n" len) >>= fun () -> - Lwt_io.write_from_exactly out_ch buffer 0 len >>= fun () -> - Lwt_io.write out_ch "\r\n" - end else Lwt.return ()) >>= fun () -> - Lwt_io.write - out_ch (Format.sprintf "%x\r\n" l) >>= fun () -> - Lwt_io.write_from_exactly out_ch s 0 l >>= fun () -> - Lwt_io.write out_ch "\r\n" >>= fun () -> - aux next 0 - end else (* Will not work if l is very large: *) - let available = buf_size - len in - if l > available then begin - Lwt_io.write - out_ch (Format.sprintf "%x\r\n" buf_size) >>= fun () -> - Lwt_io.write_from_exactly out_ch buffer 0 len >>= fun () -> - Lwt_io.write_from_exactly out_ch s 0 available >>= fun () -> - Lwt_io.write out_ch "\r\n" >>= fun () -> - let newlen = l - available in - String.blit s available buffer 0 newlen; - aux next newlen - end - else begin - String.blit s 0 buffer len l; - aux next (len + l) - end - in - aux stream 0 - -let rec write_stream_raw out_ch stream = - Ocsigen_stream.next stream >>= fun e -> - match e with - | Ocsigen_stream.Finished _ -> - Lwt.return () - | Ocsigen_stream.Cont (s, next) -> - Lwt_io.write out_ch s >>= fun () -> - write_stream_raw out_ch next - -(*XXX We should check the length of the stream: - - do not send more than expected - - abort the connection before the right length is emitted so that - the client can know something wrong happened -*) -let write_stream ?(chunked=false) out_ch stream = - let stream = Ocsigen_stream.get stream in - if chunked then - write_stream_chunked out_ch stream - else - write_stream_raw out_ch stream - - - - -module H = Ocsigen_http_frame.Http_header - -let set_result_observer, observe_result = - let observer = ref (fun _ _ -> Lwt.return ()) in - ((fun f -> - let o = !observer in - observer := (fun a b -> o a b >>= fun () -> f a b)), - (fun a b -> !observer a b)) - -let send_100_continue slot = - wait_previous_senders slot >>= fun () -> - let out_ch = slot.sl_chan in - let hh = Framepp.string_of_header { - H.mode = H.Answer 100; - proto = H.HTTP11; - headers = Http_headers.empty - } in - Lwt_log.ign_info ~section "writing 100-continue"; - Lwt_log.ign_info ~section hh; - Lwt_io.write out_ch hh - -(** Sends the HTTP frame. - * The headers are merged with those of the sender, the priority - * being given to the newly defined header in case of conflict. - * code is the code of the http answer - * keep_alive is a boolean value that set the field Connection -*) -let send - ?reopen - slot - ~clientproto - ?mode - ?proto - ?keep_alive (* now (06/02/2008) used only - to request keep-alive while used as client *) - ~head (* send only the header *) - ~sender - res - = - - let send_aux ~mode hds = - Lwt.catch - (fun () -> - (* [slot] is here for pipelining: we must wait before - sending the page, because the previous one may not be sent. *) - wait_previous_senders slot >>= fun () -> - let out_ch = slot.sl_chan in - let empty_content = - match mode with - | H.Nofirstline -> false - | H.Answer code -> code_without_message_body code - | H.Query _ -> false - in - let chunked = - (Result.content_length res) = None && - clientproto <> Ocsigen_http_frame.Http_header.HTTP10 && - not empty_content && not head - in - (* if HTTP/1.0 we do not use chunked encoding - even if the client tells that it supports it, - because it may be an HTTP/1.0 proxy that - transmits the header by mistake. - In that case, we close the connection after the - answer. - *) - let with_default v default = - match v with None -> default | Some v -> v - in - (*XXX Make sure that there is no way to put wrong headers *) - (*VVV and that all required headers are here ... *) - let hds = - Http_headers.with_defaults hds sender.s_headers - in - let hds = - Http_headers.replace_opt Http_headers.transfer_encoding - (if chunked then Some "chunked" else None) hds - in - let hds = - Http_headers.replace_opt Http_headers.content_length - (match Result.content_length res with - | None -> None - | Some l -> Some (Int64.to_string l)) - hds - in - (* 06/02/2008 - We decided that we won't include a connection header at all - for answers. - If HTTP/1.0, we always close (which is the default). - If HTTP/1.1, we always keep alive, but if the client asked to close. - The default is to keep alive. But the client will close. *) - let hds = - match keep_alive with - | None -> hds - | Some ka -> - hds - < - Lwt.catch - (fun () -> - - let hh = Framepp.string_of_header hd in - Lwt_log.ign_info_f ~section "writing header\n%s" hh; - observe_result hd hh >>= fun () -> - Lwt_io.write out_ch hh >>= fun () -> - (if reopen <> None then - (* If we want to give a possibility to reopen if - it fails, we must detect the failure before - beginning to read the stream - *) - Lwt_io.flush out_ch - else Lwt.return ()) - ) - (fun e -> (* *** If we are doing a request, - we may want to retry once (in the case when - we reuse an old connection) *** *) - match reopen with - | None -> Lwt.fail e - | Some reopen -> - match convert_io_error e with - | Keepalive_timeout - | Timeout - | Connection_closed - | Unix.Unix_error (Unix.EBADF,_ ,_) - | Lost_connection _ -> - reopen () >>= fun () -> - Lwt.fail e - | _ -> - Lwt_log.ign_warning ~section ~exn:e - "reopening after exception (Is that right?) Please report this error."; - ignore (reopen ()); - Lwt.fail e - ) - ) - >>= fun () -> - (if empty_content || head then begin - Lwt.return () - end else begin - Lwt_log.ign_info ~section "writing body"; - write_stream ~chunked out_ch (fst (Result.stream res)) - end) >>= fun () -> - Lwt_io.flush out_ch (* Vincent: I add this otherwise HEAD answers - are not flushed by the reverse proxy *) - >>= fun () -> - Ocsigen_stream.finalize (fst (Result.stream res)) `Success - ) - (fun e -> - Ocsigen_stream.finalize (fst (Result.stream res)) `Failure >>= fun () -> - Lwt.fail e - ) - - in - - (*XXX Maybe we can compute this only at most once a second*) - (* Add options specific to the page. *) - let date = gmtdate (Unix.time ()) in - - let headers = - (Result.headers res) - < None (* We do not put last modified for dynamically - generated pages, otherwise it is not possible - to cache them. Without Last-Modified, ETag is - taken into account by proxies/browsers *) - | Some l -> Some (gmtdate l)) - in - let mode = - match mode with - | None -> Http_header.Answer (Result.code res) - | Some m -> m - in - let headers = - match mode with - | H.Query _ -> headers - (* We do not put date in headers for queries. - cf bug #134 in trac - "the header "Date" is sometime used to compute the signature of the REST - request, and it's value may change between the time you compute the - signature and the time the request is actually performed." - RFC 2616 says: - "Clients SHOULD only send a Date header field in messages that include - an entity-body, as in the case of the PUT and POST requests, and even - then it is optional. A client without a clock MUST NOT send a Date - header field in a request." *) - (*VVV What about Nofirstline? *) - | _ -> headers - << - (Http_headers.date, date) - in - let mkcook path exp name c secure = - Format.sprintf "%s=%s%s%s" name c - (*VVV encode = true? *) - ("; path=/" ^ Url.string_of_url_path ~encode:true path) - (if secure && slot.sl_ssl then "; secure" else "")^ - (match exp with - | Some s -> "; expires=" ^ - Netdate.format - "%a, %d-%b-%Y %H:%M:%S GMT" - (Netdate.create s) - | None -> "") - in - let mkcookl path t hds = - CookiesTable.fold - (fun name c h -> - let exp, v, secure = match c with - | Ocsigen_cookies.OUnset -> (Some 0., "", false) - | Ocsigen_cookies.OSet (t, v, secure) -> (t, v, secure) - in - Http_headers.add - Http_headers.set_cookie (mkcook path exp name v secure) h) - t - hds - in - let headers = - Cookies.fold mkcookl (Result.cookies res) headers - < None - | Some l -> Some (Format.sprintf "\"%s\"" l)) - (*XXX Is it the right place to perform quoting?*) - < None - | Some s -> - if String.length s >= 4 then - match String.sub s 0 4, Result.charset res with - | "text", Some "" -> Some s - | "text", Some c -> Some (Format.sprintf "%s; charset=%s" s c) - | _ -> - match String.sub s (String.length s - 4) 4, - Result.charset res with - | ("+xml"|"/xml"), Some "" -> Some s - | ("+xml"|"/xml"), Some c -> - Some (Format.sprintf "%s; charset=%s" s c) - | _ -> Result.content_type res - else - (Result.content_type res) - ) - in - send_aux ~mode headers diff --git a/src/http/ocsigen_http_com.mli b/src/http/ocsigen_http_com.mli deleted file mode 100644 index 4d29f2f1f..000000000 --- a/src/http/ocsigen_http_com.mli +++ /dev/null @@ -1,118 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * ocsigen_http_com.ml Copyright (C) 2005 - * Denis Berthod, Vincent Balat, Jérôme Vouillon - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - -(** Sending and receiving HTTP frames *) - -(* -Who can raise the exceptions: -R: receiver -r: receiver stream -S: sender -*) - -(** The other side has cleanly closed the connection after a message *) -exception Connection_closed (* R *) - -(** The connection has been unexpectedly broken *) -exception Lost_connection of exn (* RrS *) - -(** No activity on the other side *) -exception Timeout (* RrS *) -exception Keepalive_timeout (* R *) - -(** Connection killed *) -exception Aborted (* RrS *) - -type mode = Answer | Query | Nofirstline -type connection -val create_receiver : int -> mode -> Lwt_ssl.socket -> connection -val lock_receiver : connection -> unit Lwt.t -val unlock_receiver : connection -> unit -val wakeup_next_request : connection -> unit -val block_next_request : connection -> unit Lwt.t -val get_http_frame : ?head:bool -> connection -> Ocsigen_http_frame.t Lwt.t -val connection_id : connection -> int -val connection_fd : connection -> Lwt_ssl.socket - -(** [closed conn] is a thread waking up when the connection is - closed *) -val closed : connection -> unit Lwt.t - -(****) - -type slot - -val start_processing : connection -> (slot -> unit Lwt.t) -> unit -val wait_all_senders : connection -> unit Lwt.t - -(****) - -(** - This function may return any I/O error from the channel, or a - interrupted stream exception. -*) -val write_stream : - ?chunked:bool -> Lwt_chan.out_channel -> string Ocsigen_stream.t -> unit Lwt.t - -(****) - -type sender_type - -val create_sender : - ?server_name:string -> ?headers:Http_headers.t -> - ?proto:Ocsigen_http_frame.Http_header.proto -> unit -> sender_type - -(** Sender with only the server name, and HTTP/1.1 *) -val default_sender : sender_type - -(** send an HTTP/1.1 100 Continue message *) -val send_100_continue : slot -> unit Lwt.t - -(** send an HTTP message. - [send] may also fail with [Interrupted_stream] exception if the input - stream is interrupted. -*) -val send : - ?reopen:(unit -> unit Lwt.t) -> - slot -> - clientproto:Ocsigen_http_frame.Http_header.proto -> - ?mode:Ocsigen_http_frame.Http_header.http_mode -> - ?proto:Ocsigen_http_frame.Http_header.proto -> - ?keep_alive:bool -> - head:bool -> - sender:sender_type -> - Ocsigen_http_frame.result -> - unit Lwt.t - -val abort : connection -> unit - - -(** Use this function to make an action just before sending the result - (for example observe the headers that will be sent). - The parameter is a function taking the set of headers twice, - first as [Ocsigen_http_frame.Http_headers.http_header], - second as a [string]. -*) -val set_result_observer : - (Ocsigen_http_frame.Http_header.http_header -> string -> unit Lwt.t) -> unit - - -(**/**) -val gmtdate: float -> string diff --git a/src/http/ocsigen_http_frame.ml b/src/http/ocsigen_http_frame.ml deleted file mode 100644 index 4cffd767e..000000000 --- a/src/http/ocsigen_http_frame.ml +++ /dev/null @@ -1,351 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * ocsigen_http_frame.ml Copyright (C) 2005 - * Denis Berthod, Vincent Balat, Jérôme Vouillon - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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 Ocsigen_lib - -(** this set of modules discribes the http protocol and - the operation on this protocol*) - -(** this signature provides a template to discribe the content of a http - frame *) - -open Ocsigen_stream -open Ocsigen_cookies - -let section = Lwt_log.Section.make "ocsigen:http:frame" - -type etag = string - - -(* The following cookie function is not in Ocsigen_cookies - because ri is not used client side *) - - -(* [compute_new_ri_cookies now path ri_cookies cookies_to_set] - adds the cookies from [cookies_to_set] - to [ri_cookies], as if the cookies - had been send to the browser and the browser - was doing a new request to the url [path]. - Only the cookies that match [path] (current path) are added. *) -let compute_new_ri_cookies - now - ripath - ricookies - cookies_set_by_page = - - let prefix path p = - Url.is_prefix_skip_end_slash - (Url.remove_slash_at_beginning path) - (Url.remove_slash_at_beginning p) - in - Cookies.fold - (fun path ct t -> - if prefix path ripath then - String.Table.fold - (fun n v beg -> - match v with - | OSet (Some ti, v, _) when ti>now -> - String.Table.add n v t - | OSet (None, v, _) -> String.Table.add n v t - | OSet (_, _, _) - | OUnset -> String.Table.remove n t - ) - ct - t - else t - ) - cookies_set_by_page - ricookies - - -module Result = struct - (** The type of answers to send *) - type result = - {cookies: cookieset; (** cookies to set (with optional path) *) - lastmodified: float option; (** Default: [None] *) - etag: string option; - code: int; (** HTTP code, if not 200 *) - stream: string Ocsigen_stream.t * - (string Ocsigen_stream.t -> - int64 -> - string Ocsigen_stream.step Lwt.t) option - ; (** Default: empty stream. - The second field is (optionaly) - the function used to skip a part of the - stream, if you do not you want to use - a basic reading of the stream. - For example, for static files, you can optimize it by using - a [seek] function. - *) - (* It is not a new field of the record to remember to change it - if we change the stream. *) - content_length: int64 option; (** [None] means Transfer-encoding: chunked *) - content_type: string option; - headers: Http_headers.t; (** The headers you want to add *) - charset: string option; (** Default: None *) - location: string option; (** Default: None *) - } - - let cookies { cookies; _ } = cookies - let lastmodified { lastmodified; _ } = lastmodified - let etag { etag; _ } = etag - let code { code; _ } = code - let stream { stream; _ } = stream - let content_length { content_length; _ } = content_length - let content_type { content_type; _ } = content_type - let headers { headers; _ } = headers - let charset { charset; _ } = charset - let location { location; _ } = location - - (** Default [result] to use as a base for constructing others. *) - let default () = - { - cookies = Cookies.empty; - lastmodified = None; - (* No date => proxies use etag *) - etag = None; - code = 200; - stream = (Ocsigen_stream.make (fun () -> Ocsigen_stream.empty None), - None); - content_length = Some 0L; - content_type = None; - headers= Http_headers.empty; - charset= None; - location= None; - } - - let update result - ?(cookies=result.cookies) - ?(lastmodified=result.lastmodified) - ?(etag=result.etag) - ?(code=result.code) - ?(stream=result.stream) - ?(content_length=result.content_length) - ?(content_type=result.content_type) - ?(headers=result.headers) - ?(charset=result.charset) - ?(location=result.location) () = - { - cookies; - lastmodified; - etag; - code; - stream; - content_length; - content_type; - headers; - charset; - location; - } - - (** [result] for an empty page. *) - let empty () = - { - cookies = Cookies.empty; - lastmodified = None; - etag = None; - code = 204; (* No content *) - stream = (Ocsigen_stream.make (fun () -> Ocsigen_stream.empty None), - None); - content_length = Some 0L; - content_type = None; - headers= Http_headers.empty; - charset= None; - location= None; - } -end - -include Result - -module type HTTP_CONTENT = -sig - (** abstract type of the content *) - type t - - type options - - (** convert a content into a thread returning the default - [result] for this content *) - val result_of_content : ?options:options -> t -> Result.result Lwt.t - - (** compute etag for content *) - val get_etag : ?options:options -> t -> etag option -end - - -(** this module describes the type of an http header *) -module Http_header = -struct - - (** type of the http_method *) - type http_method = - | GET - | POST - | HEAD - | PUT - | DELETE - | TRACE - | OPTIONS - | CONNECT - | LINK - | UNLINK - | PATCH - - (** type of ocsigen_http_frame mode. The int is the HTTP answer code *) - type http_mode = - | Query of (http_method * string) - | Answer of int - | Nofirstline - - type proto = HTTP10 | HTTP11 - - (** type of the http headers *) - type http_header = - { - (** the mode of the header : Query or Answer *) - mode:http_mode; - (** protocol used for the Query or the Answer *) - proto: proto; - (** list of the headers options *) - headers: Http_headers.t; - } - - (* (** gets the url raise Not_found if Answer *) - let get_url header = - match header.mode with - | Query (_, s) -> s - | _ -> raise Not_found *) - - (** gets the firstline of the header *) - let get_firstline header = header.mode - - (** gets the headers *) - let get_headers header = header.headers - - (** gets the value of a given header's option *) - let get_headers_value header key = - Http_headers.find key header.headers - - (** gets all the values of a given header's option *) - let get_headers_values header key = - Http_headers.find_all key header.headers - - (** gets the value of the protocol used *) - let get_proto header = header.proto - - (* (** gets the value of the http method used *) - let get_method header = - match header.mode with - | Query (meth, _) -> meth - | _ -> raise Not_found *) - - (** adds an header option in the header option list*) - let add_headers header key value = - { header with - headers = Http_headers.add key value header.headers } -end - -module Http_error = -struct - - (** Exception raised on an http error. It is possible to pass the code of - the error, some comment, and some headers. *) - exception Http_exception of int * string option * Http_headers.t option - - (* this fonction provides the translation mecanisme between a code and - * its explanation *) - let expl_of_code = - function - | 100 -> "Continue" - | 101 -> "Switching Protocol" - | 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 -> "Moved Temporarily" - | 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 URL Too Long" - | 415 -> "Unsupported Media type" - | 416 -> "Request Range Not Satisfiable" - | 417 -> "Expectation Failed" - | 500 -> "Internal Server Error" - | 501 -> "Not Implemented" - | 502 -> "Bad Gateway" - | 503 -> "Service Unavailable" - | 504 -> "Gateway Time-out" - | 505 -> "Version Not Supported" - | _ -> "Unknown Error" (*!!!*) - - let display_http_exception e = - match e with - | Http_exception (n, Some s, Some _) -> - Lwt_log.ign_info_f ~section "%s: %s (with headers)" (expl_of_code n) s - | Http_exception (n, Some s, None) -> - Lwt_log.ign_info_f ~section "%s: %s" (expl_of_code n) s - | Http_exception (n, None, _) -> - Lwt_log.ign_info ~section (expl_of_code n) - | _ -> - raise e - - let string_of_http_exception e = - match e with - | Http_exception (n, Some s, Some _) -> - Format.sprintf "Error %d, %s: %s (with headers)" n (expl_of_code n) s - | Http_exception (n, Some s, None) -> - Format.sprintf "Error %d, %s: %s" n (expl_of_code n) s - | Http_exception (n, None, _) -> - Format.sprintf "Error %d, %s" n (expl_of_code n) - | _ -> - raise e - -end - -(** HTTP messages *) -type t = - { frame_header : Http_header.http_header; - frame_content : string Ocsigen_stream.t option; - frame_abort : unit -> unit Lwt.t - (*VVV abort looks like a hack. - It has been added for the reverse proxy, to enable closing the connection - if the request is cancelled ... - *) - } diff --git a/src/http/ocsigen_http_frame.mli b/src/http/ocsigen_http_frame.mli deleted file mode 100644 index 2c7cbad61..000000000 --- a/src/http/ocsigen_http_frame.mli +++ /dev/null @@ -1,153 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * ocsigen_http_frame.ml Copyright (C) 2005 - * Denis Berthod, Vincent Balat, Jérôme Vouillon - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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 Ocsigen_lib -open Ocsigen_cookies - -type etag = string - -(** [compute_new_ri_cookies now path ri_cookies cookies_to_set] - adds the cookies from [cookies_to_set] - to [ri_cookies], as if the cookies - had been send to the browser and the browser - was doing a new request to the url [path]. - Only the cookies that match [path] (current path) are added. *) -val compute_new_ri_cookies : - float -> - string list -> - string String.Table.t -> - cookie String.Table.t Cookies.t -> string String.Table.t - - -module Result : sig - (** The type of answers to send *) - type result - - (** accessor for cookies of result *) - val cookies : result -> Ocsigen_cookies.cookieset - - (** accessor for Last-Modified value of header of result *) - val lastmodified : result -> float option - - (** accessor for ETag value of header of result *) - val etag : result -> string option - - (** accessor for response code of result *) - val code : result -> int - - (** accessor for content of result *) - val stream : - result -> - string Ocsigen_stream.t * - (string Ocsigen_stream.t -> int64 -> string Ocsigen_stream.step Lwt.t) - option - - (** accessor for Content-Length value of header of result *) - val content_length : result -> int64 option - - (** accessor for Content-Type value of header of result *) - val content_type : result -> string option - - (** accessor for HTTP header of result *) - val headers : result -> Http_headers.t - - (** accessor for charset of result *) - val charset : result -> string option - - (** accessor for location of result *) - val location : result -> string option - - (** Default [result] to use as a base for constructing others. *) - val default : unit -> result - - (** Update [result] before sending. - If argument is unspecified, this function use old value of result. *) - val update : - result -> - ?cookies:Ocsigen_cookies.cookieset -> - ?lastmodified:float option -> - ?etag:string option -> - ?code:int -> - ?stream:string Ocsigen_stream.t * - (string Ocsigen_stream.t -> - int64 -> string Ocsigen_stream.step Lwt.t) - option -> - ?content_length:int64 option -> - ?content_type:string option -> - ?headers:Http_headers.t -> - ?charset:string option -> ?location:string option -> unit -> result - - (** [result] for an empty page. *) - val empty : unit -> result -end - -include (module type of Result - with type result = Result.result) - -module type HTTP_CONTENT = -sig - type t - type options - val result_of_content : ?options:options -> t -> Result.result Lwt.t - val get_etag : ?options:options -> t -> etag option -end -module Http_header : -sig - type http_method = - GET | POST | HEAD | PUT | DELETE | TRACE - | OPTIONS | CONNECT | LINK | UNLINK | PATCH - type http_mode = - Query of (http_method * string) - | Answer of int - | Nofirstline - type proto = HTTP10 | HTTP11 - type http_header = { - mode : http_mode; - proto : proto; - headers : Http_headers.t; - } - val get_firstline : http_header -> http_mode - val get_headers : http_header -> Http_headers.t - val get_headers_value : http_header -> Http_headers.name -> string - val get_headers_values : http_header -> Http_headers.name -> string list - val get_proto : http_header -> proto - val add_headers : http_header -> Http_headers.name -> string -> http_header -end -module Http_error : -sig - exception Http_exception of int * string option * Http_headers.t option - val expl_of_code : int -> string - val display_http_exception : exn -> unit - val string_of_http_exception : exn -> string -end - - -(** The type of HTTP frames. - The content may be void (no body) or a stream. - While sending, a stream will be sent with chunked encoding if no - content-length is supplied. - abort is the function to be called if you want to cancel the stream - reading (closes the connection). -*) -type t = - { frame_header : Http_header.http_header; - frame_content : string Ocsigen_stream.t option; - frame_abort : unit -> unit Lwt.t - } diff --git a/src/http/ocsigen_senders.ml b/src/http/ocsigen_senders.ml deleted file mode 100644 index 03ddb433f..000000000 --- a/src/http/ocsigen_senders.ml +++ /dev/null @@ -1,558 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * sender_helpers.ml Copyright (C) 2005 Denis Berthod - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) -(** This module provides predefined "senders" for usual types of pages to be - sent by the server: xhtml, files, ... *) - -open Ocsigen_lib -open Ocsigen_http_frame -open Ocsigen_http_com -open Lwt -open Ocsigen_stream - -let section = Lwt_log.Section.make "ocsigen:http:sender" - -(*****************************************************************************) -(** this module instantiate the HTTP_CONTENT signature for an Html content*) - -module Make_XML_Content(Xml : Xml_sigs.Iterable) - (Typed_xml : Xml_sigs.Typed_xml with module Xml := Xml) -= struct - - module Htmlprinter = Xml_print.Make_typed_fmt(Xml)(Typed_xml) - - type t = Typed_xml.doc - type options = Http_headers.accept Lazy.t - - let get_etag_aux x = None - - let get_etag ?options c = None - - let choose_content_type accepted alt default = - match accepted, alt with - | None, _ | _, [] -> default - | Some accepted, alt -> - try - List.find - (fun content_type -> - List.exists - (function - | ((Some a, Some b),_,_) -> a^"/"^b = content_type - | _ -> false) - (Lazy.force accepted)) - (default :: alt) - with Not_found -> default - - let result_of_content ?options c = - let content_type = - choose_content_type options - Typed_xml.Info.alternative_content_types - Typed_xml.Info.content_type in - let encode x = fst (Xml_print.Utf8.normalize_html x) in - let x = - Ocsigen_stream.of_string - (Format.asprintf "%a" (Htmlprinter.pp ~encode ~advert ()) c) in - let default_result = Result.default () in - Lwt.return - (Result.update default_result - ~content_length:None - ~content_type:(Some content_type) - ~etag:(get_etag c) - ~charset:(Some "utf-8") - ~headers:Http_headers.dyn_headers - ~stream:(x, None) ()) -end - -module Html_content = Make_XML_Content(Tyxml.Xml)(Tyxml.Html) - - -(*****************************************************************************) -module Text_content = -struct - type t = string (* content *) * string (* content-type *) - - type options = unit - - let get_etag ?options (x, _) = None - (* Some (Digest.to_hex (Digest.string x)) *) - (* We do not add etags here because the content is - probably generated and there are problemes with etags - and POST requests: - when doing POST request with etags, the semantinc - is not to do side effects on the server when the - etag match and respond with code 412 ( precondition failed ). - Since the etag is calculated from the content of the answer, - we cannot enforce this semantic correctly, so it is better not - to send etags with POST requests. Here, we cannot know wether - the request was in POST or GET, so the easiest way to fix that - is to never send etags *) - - - let result_of_content ?(options = ()) ((c, ct) as content) = - let md5 = get_etag content in - let default_result = Result.default () in - Lwt.return - (Result.update default_result - ~content_length:(Some (Int64.of_int (String.length c))) - ~etag:md5 - ~content_type:(Some ct) - ~headers:Http_headers.dyn_headers - ~stream: - (Ocsigen_stream.make - (fun () -> - Ocsigen_stream.cont c (fun () -> Ocsigen_stream.empty None)), - None) ()) -end - -(*****************************************************************************) -module Stream_content = -(* Used to send data from a stream *) -struct - type t = string Ocsigen_stream.t - - type options = unit - - let get_etag ?options c = None - - let result_of_content ?(options = ()) c = - let default_result = Result.default () in - Lwt.return - (Result.update default_result - ~content_length:None - ~headers:Http_headers.dyn_headers - ~stream:(c, None) ()) - -end - -(*****************************************************************************) -module Streamlist_content = -(* Used to send data from streams *) -struct - type t = (unit -> string Ocsigen_stream.t Lwt.t) list - * string (* content-type *) - - type options = unit - - let get_etag ?options c = None - - let result_of_content ?(options = ()) (c, ct) = - let finalizer = ref (fun _ -> Lwt.return ()) in - let finalize status = - let f = !finalizer in - finalizer := (fun _ -> Lwt.return ()); - f status - in - let rec next stream l = - Lwt.try_bind (fun () -> Ocsigen_stream.next stream) - (fun s -> - match s with - Ocsigen_stream.Finished None -> - finalize `Success >>= fun () -> - next_stream l - | Ocsigen_stream.Finished (Some stream) -> - next stream l - | Ocsigen_stream.Cont (v, stream) -> - Ocsigen_stream.cont v (fun () -> next stream l)) - (function Interrupted e | e -> -(*XXX string_of_exn should know how to print "Interrupted _" exceptions*) - exnhandler e l) - and next_stream l = - match l with - [] -> Ocsigen_stream.empty None - | f :: l -> - Lwt.try_bind f - (fun stream -> - finalizer := - (fun status -> Ocsigen_stream.finalize stream status); - next (Ocsigen_stream.get stream) l) - (fun e -> exnhandler e l) - and exnhandler e l = - Lwt_log.ign_warning ~section ~exn:e "Error while reading stream list"; - finalize `Failure >>= fun () -> - next_stream l - in - let default_result = Result.default () in - Lwt.return - (Result.update default_result - ~content_length:None - ~etag:(get_etag c) - ~stream: - (Ocsigen_stream.make ~finalize (fun _ -> next_stream c), None) - ~headers:(Http_headers.dyn_headers) - ~content_type:(Some ct) ()) -end - - -(*****************************************************************************) -module Empty_content = -struct - type t = unit - - type options = unit - - let get_etag ?options c = None - - let result_of_content ?(options = ()) c = Lwt.return (Result.empty ()) - -end - -(*****************************************************************************) -(* Files *) - -(** this module instanciate the HTTP_CONTENT signature for files *) -module File_content = -struct - type t = - string (* nom du fichier *) * - Ocsigen_charset_mime.charset_assoc * - Ocsigen_charset_mime.mime_assoc - - type options = unit - - let read_file ?buffer_size fd = - let buffer_size = match buffer_size with - | None -> Ocsigen_config.get_filebuffersize () - | Some s -> s - in - Lwt_log.ign_info ~section "start reading file (file opened)"; - let buf = Bytes.create buffer_size in - let rec read_aux () = - Lwt_unix.read fd buf 0 buffer_size >>= fun read -> - if read = 0 then - Ocsigen_stream.empty None - else begin - if read = buffer_size - then Ocsigen_stream.cont buf read_aux - else Ocsigen_stream.cont (String.sub buf 0 read) read_aux - end - in read_aux - - let get_etag_aux st = - Some (Printf.sprintf "%Lx-%x-%f" st.Unix.LargeFile.st_size - st.Unix.LargeFile.st_ino st.Unix.LargeFile.st_mtime) - - let get_etag ?options (f, _, _) = - let st = Unix.LargeFile.stat f in - get_etag_aux st - - let skip fd stream k = - try - ignore - (Unix.LargeFile.lseek (Lwt_unix.unix_file_descr fd) k Unix.SEEK_CUR); - Ocsigen_stream.next (Ocsigen_stream.get stream) - with e -> Lwt.fail e - - let result_of_content ?options (c, charset_assoc, mime_assoc) = - (* open the file *) - try - let fdu = Unix.openfile c [Unix.O_RDONLY;Unix.O_NONBLOCK] 0o666 in - let fd = Lwt_unix.of_unix_file_descr fdu in - try - let st = Unix.LargeFile.fstat fdu in - let etag = get_etag_aux st in - let buffer_size = - if st.Unix.LargeFile.st_size <= - Int64.of_int (Ocsigen_config.get_filebuffersize ()) then - Some (Int64.to_int st.Unix.LargeFile.st_size) - else - None in - let stream = read_file ?buffer_size fd in - let default_result = Result.default () in - Lwt.return - (Result.update default_result - ~content_length:(Some st.Unix.LargeFile.st_size) - ~content_type: - (Some (Ocsigen_charset_mime.find_mime c mime_assoc)) - ~charset: - (Some (Ocsigen_charset_mime.find_charset c charset_assoc)) - ~lastmodified:(Some st.Unix.LargeFile.st_mtime) - ~etag:etag - ~stream: - (Ocsigen_stream.make - ~finalize: - (fun _ -> - Lwt_log.ign_info ~section "closing file"; - Lwt_unix.close fd) - stream, - Some (skip fd)) ()) - with e -> Lwt_unix.close fd >>= fun () -> raise e - with e -> Lwt_log.ign_info ~section ~exn:e "Exc"; - fail e - -end - -(*****************************************************************************) -(* directory listing - by Gabriel Kerneis *) - -(** this module instanciate the HTTP_CONTENT signature for directories *) -module Directory_content = -struct - type t = string (* dir name *) * string list (* corresponding URL path *) - - type options = unit - - let get_etag_aux st = - Some (Printf.sprintf "%Lx-%x-%f" st.Unix.LargeFile.st_size - st.Unix.LargeFile.st_ino st.Unix.LargeFile.st_mtime) - - let get_etag ?options (f, _) = - let st = Unix.LargeFile.stat f in - get_etag_aux st - - let date fl = - let t = Unix.gmtime fl in - Printf.sprintf - "%02d-%02d-%04d %02d:%02d:%02d" - t.Unix.tm_mday - (t.Unix.tm_mon + 1) - (1900 + t.Unix.tm_year) - t.Unix.tm_hour - t.Unix.tm_min - t.Unix.tm_sec - - - let image_found fich = - if fich="README" || fich="README.Debian" - then "/ocsigenstuff/readme.png" - else - let reg=Netstring_pcre.regexp "([^//.]*)(.*)" - in match Netstring_pcre.global_replace reg "$2" fich with - | ".jpeg" | ".jpg" | ".gif" | ".tif" - | ".png" -> "/ocsigenstuff/image.png" - | ".ps" -> "/ocsigenstuff/postscript.png" - | ".pdf" -> "/ocsigenstuff/pdf.png" - | ".html" | ".htm" - | ".php" -> "/ocsigenstuff/html.png" - | ".mp3" - | ".wma" -> "/ocsigenstuff/sound.png" - | ".c" -> "/ocsigenstuff/source_c.png" - | ".java" -> "/ocsigenstuff/source_java.png" - | ".pl" -> "/ocsigenstuff/source_pl.png" - | ".py" -> "/ocsigenstuff/source_py.png" - | ".iso" | ".mds" | ".mdf" | ".cue" | ".nrg" - | ".cdd" -> "/ocsigenstuff/cdimage.png" - | ".deb" -> "/ocsigenstuff/deb.png" - | ".dvi" -> "/ocsigenstuff/dvi.png" - | ".rpm" -> "/ocsigenstuff/rpm.png" - | ".tar" | ".rar" -> "/ocsigenstuff/tar.png" - | ".gz" | ".tar.gz" | ".tgz" | ".zip" - | ".jar" -> "/ocsigenstuff/tgz.png" - | ".tex" -> "/ocsigenstuff/tex.png" - | ".avi" | ".mov" -> "/ocsigenstuff/video.png" - | ".txt" -> "/ocsigenstuff/txt.png" - | _ -> "/ocsigenstuff/unknown.png" - - - (* An html row for a file in the directory listing *) - let file_row name icon stat = Printf.sprintf " - - \"\" - %s - %Ld - %s -" - icon (Netencoding.Url.encode ~plus:false name) name - stat.Unix.LargeFile.st_size (date stat.Unix.LargeFile.st_mtime) - - - let directory filename = - let dir = Unix.opendir filename in - let rec aux d = - try - let f = Unix.readdir dir in - try - let stat = Unix.LargeFile.stat (filename^f) in - if stat.Unix.LargeFile.st_kind = Unix.S_DIR && f <> "." && f <> ".." - then - (`Dir, f, - file_row f "/ocsigenstuff/folder_open.png" stat) :: aux d - else - if stat.Unix.LargeFile.st_kind = Unix.S_REG && - f.[(String.length f) - 1] <> '~' - then - (`Reg, f, file_row f (image_found f) stat) :: aux d - else aux d - with _ (* Unix.stat can fail for a lot of reasons *) -> aux d - with - End_of_file -> Unix.closedir d;[] - - in - let trie li = - List.sort (fun (a1, b1, _) (a2, b2, _) -> match a1, a2 with - | `Dir, `Dir -> - if b1 0 - | _, `Dir -> 1 - | _, _-> - if b1 "" - | (_, _, i)::l -> i^(aux2 l) - in aux2 (trie (aux dir)) - - - - let result_of_content ?(options = ()) (filename, path) = - let stat = Unix.LargeFile.stat filename in - let rec back = function - | [] | [""] -> assert false - | [_] | [_ ; ""] -> [] - | i::j -> i :: (back j) - in - let parent = - if path = [] || path = [""] then - None - else - Some ("/"^Url.string_of_url_path ~encode:true (back path)) - in - let before = - let st = Url.string_of_url_path ~encode:false path in - "\n\ - \n\ - \n\ - Listing Directory: "^st^"\n\n\ -

"^st^"

\n\ - \n\ - \ - \n" - - and back = match parent with - | None -> "" - | Some parent -> - "\n\ - \n\ - \n\ - \n\ - \n\ - \n" - - and after= - "
NameSizeLast modified
\"\"Parent Directory"^(Int64.to_string stat.Unix.LargeFile.st_size)^""^(date stat.Unix.LargeFile.st_mtime)^"
\ -

Ocsigen Webserver

\ - " - in - let c = before^back^(directory filename)^after in - let etag = get_etag_aux stat in - Text_content.result_of_content (c, "text/html") >>= fun r -> - Lwt.return - (Result.update r - ~lastmodified:(Some stat.Unix.LargeFile.st_mtime) - ~etag:etag - ~charset:(Some "utf-8") ()) -end - - - -(*****************************************************************************) -module Error_content = -(** sends an error page that fit the error number *) -struct - type t = int option * exn option * Ocsigen_cookies.cookieset - - type options = unit - - let get_etag ?options c = None - - let error_page s msg c = - Tyxml.Html.html - (Tyxml.Html.head (Tyxml.Html.title (Tyxml.Html.pcdata s)) []) - (Tyxml.Html.body - (Tyxml.Html.h1 [Tyxml.Html.pcdata msg]:: - Tyxml.Html.p [Tyxml.Html.pcdata s]:: - c) - ) - - let result_of_content ?(options = ()) (code, exn, cookies_to_set) = - let code = match code with - | None -> 500 - | Some c -> c - in - let (error_code, error_msg, headers) = - match exn with - | Some (Http_error.Http_exception (errcode, msgs, h) as e) -> - let msg = Http_error.string_of_http_exception e in - let headers = match h with - | Some h -> h - | None -> Http_headers.dyn_headers - in (errcode, msg, headers) - | _ -> - let error_mes = Http_error.expl_of_code code in - (code, error_mes, Http_headers.empty) - in - let headers = - (* puts dynamic headers *) - let (<<) h (n, v) = Http_headers.replace n v h in - headers - << (Http_headers.cache_control, "no-cache") - << (Http_headers.expires, "0") - in - let str_code = string_of_int error_code in - let err_page = - match exn with - | Some exn when Ocsigen_config.get_debugmode () -> - error_page - ("Error "^str_code) - error_msg - [Tyxml.Html.p - [Tyxml.Html.pcdata (Printexc.to_string exn); - Tyxml.Html.br (); - Tyxml.Html.em - [Tyxml.Html.pcdata "(Ocsigen running in debug mode)"] - ]] - | _ -> - error_page - ("Error "^str_code) - error_msg - [] - in - Html_content.result_of_content err_page >>= fun r -> - Lwt.return - (Result.update r - ~cookies:cookies_to_set - ~code:error_code - ~charset:(Some "utf-8") - ~headers:headers ()) -end - - -let send_error - ?code - ?exn - slot - ~clientproto - ?mode - ?proto - ?(cookies = Ocsigen_cookies.Cookies.empty) - ~head - ~sender - () - = - Error_content.result_of_content (code, exn, cookies) >>= fun r -> - send - slot - ~clientproto - ?mode - ?proto - ~head - ~sender - r diff --git a/src/http/ocsigen_senders.mli b/src/http/ocsigen_senders.mli deleted file mode 100644 index 54364b0bd..000000000 --- a/src/http/ocsigen_senders.mli +++ /dev/null @@ -1,75 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * sender_helpers.ml Copyright (C) 2005 Denis Berthod - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) -(** Functions to create results for various kinds of documents *) - - -module File_content : Ocsigen_http_frame.HTTP_CONTENT - with type t = - string * Ocsigen_charset_mime.charset_assoc * Ocsigen_charset_mime.mime_assoc - -module Html_content : - Ocsigen_http_frame.HTTP_CONTENT with type t = Tyxml.Html.doc - -module Make_XML_Content(Xml : Xml_sigs.Iterable) - (Typed_xml : Xml_sigs.Typed_xml with module Xml := Xml) : - Ocsigen_http_frame.HTTP_CONTENT - with type t = Typed_xml.doc - and type options = Http_headers.accept Lazy.t - - -(** content * content-type *) -module Text_content : - Ocsigen_http_frame.HTTP_CONTENT with type t = string * string - -module Stream_content : - Ocsigen_http_frame.HTTP_CONTENT with type t = string Ocsigen_stream.t - -(** streams and content-type *) -module Streamlist_content : - Ocsigen_http_frame.HTTP_CONTENT - with type t = (unit -> string Ocsigen_stream.t Lwt.t) list - * string - -module Empty_content : - Ocsigen_http_frame.HTTP_CONTENT with type t = unit - -(** directory name and corresponding URL path *) -module Directory_content : - Ocsigen_http_frame.HTTP_CONTENT with type t = string * string list - -(** error code and/or exception *) -module Error_content : - Ocsigen_http_frame.HTTP_CONTENT - with type t = int option * exn option * Ocsigen_cookies.cookieset - - - -(** Sending an error page *) -val send_error : - ?code:int -> - ?exn:exn -> - Ocsigen_http_com.slot -> - clientproto:Ocsigen_http_frame.Http_header.proto -> - ?mode:Ocsigen_http_frame.Http_header.http_mode -> - ?proto:Ocsigen_http_frame.Http_header.proto -> - ?cookies:Ocsigen_cookies.cookieset -> - head:bool -> - sender:Ocsigen_http_com.sender_type -> - unit -> - unit Lwt.t diff --git a/src/http/test_parser.ml b/src/http/test_parser.ml deleted file mode 100644 index 2f99995e7..000000000 --- a/src/http/test_parser.ml +++ /dev/null @@ -1,30 +0,0 @@ -(* Ocsigen - * test_parser.ml Copyright (C) 2005 Denis Berthod - * Laboratoire PPS - CNRS Université Paris Diderot - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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 parse_file f = - let input = open_in f in - let lexbuf = Lexing.from_channel input in - try - Http_parser.header Http_lexer.token lexbuf - with - Parsing.Parse_error -> failwith ("erreur vers "^ (Lexing.lexeme lexbuf)) - |e -> Ocsigen_http_frame.Http_error.display_http_exception e;failwith "erreur" - -let _ = - parse_file Sys.argv.(1) diff --git a/src/http/test_pp.ml b/src/http/test_pp.ml deleted file mode 100644 index 50b449d21..000000000 --- a/src/http/test_pp.ml +++ /dev/null @@ -1,35 +0,0 @@ -open Ocsigen_http_frame -open Framepp - -module H = Http_header - -module C = -struct - type t = string - let string_of_content c = c - let content_of_string s = s -end - - -module Http = FHttp_frame (C) - -module PP = Fframepp(C) - -let hd1= - { - H.mode = H.Query; - H.meth = Some H.GET; - H.url = Some "pop"; - H.code = None; - H.proto = "HTML/1.0"; - headers = [] - } - - - - -let frame = {Http.header = hd1; Http.content = Some (C.content_of_string "Bonjour")} - -let _ = - print_endline (PP.string_of_http_frame frame) - diff --git a/src/server/.depend b/src/server/.depend index 1b0ca2504..825f3e780 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -1,39 +1,34 @@ -ocsigen_cohttp_server.cmi : \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi +ocsigen_cohttp_server.cmi : ../http/ocsigen_cookies.cmi ocsigen_command.cmi : ocsigen_extensions.cmi : ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi \ + ../http/ocsigen_cookies.cmi \ ocsigen_command.cmi ../http/ocsigen_charset_mime.cmi -ocsigen_http_client.cmi : ../http/ocsigen_http_frame.cmi \ - ../http/http_headers.cmi -ocsigen_local_files.cmi : ../http/ocsigen_http_frame.cmi \ - ocsigen_extensions.cmi +ocsigen_http_client.cmi : ../http/http_headers.cmi +ocsigen_local_files.cmi : ocsigen_extensions.cmi ocsigen_parseconfig.cmi : ocsigen_socket.cmi ocsigen_extensions.cmi ocsigen_server.cmi : ocsigen_socket.cmi : ocsigen_cohttp_server.cmo : \ ../baselib/ocsigen_stream.cmi ocsigen_socket.cmi \ ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi \ ../http/ocsigen_cookies.cmi \ ../baselib/ocsigen_config.cmi ocsigen_cohttp_server.cmi ocsigen_cohttp_server.cmx : \ ../baselib/ocsigen_stream.cmx ocsigen_socket.cmx \ ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx \ ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx ocsigen_cohttp_server.cmi ocsigen_command.cmo : ../baselib/ocsigen_messages.cmi ocsigen_command.cmi ocsigen_command.cmx : ../baselib/ocsigen_messages.cmx ocsigen_command.cmi ocsigen_extensions.cmo : \ ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi ../http/ocsigen_cookies.cmi \ + ../http/ocsigen_cookies.cmi \ ../baselib/ocsigen_config.cmi ocsigen_command.cmi \ ocsigen_cohttp_server.cmi ../http/ocsigen_charset_mime.cmi \ ocsigen_extensions.cmi ocsigen_extensions.cmx : \ ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx ../http/ocsigen_cookies.cmx \ + ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx ocsigen_command.cmx \ ocsigen_cohttp_server.cmx ../http/ocsigen_charset_mime.cmx \ ocsigen_extensions.cmi @@ -43,11 +38,9 @@ ocsigen_http_client.cmo : \ ocsigen_http_client.cmx : \ ../baselib/ocsigen_lib.cmx ../http/http_headers.cmx \ ocsigen_http_client.cmi -ocsigen_local_files.cmo : ../http/ocsigen_senders.cmi \ - ocsigen_extensions.cmi \ +ocsigen_local_files.cmo : ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi ocsigen_local_files.cmi -ocsigen_local_files.cmx : ../http/ocsigen_senders.cmx \ - ocsigen_extensions.cmx \ +ocsigen_local_files.cmx : ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ocsigen_local_files.cmi ocsigen_parseconfig.cmo : ocsigen_socket.cmi ../baselib/ocsigen_loader.cmi \ ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ @@ -60,7 +53,6 @@ ocsigen_parseconfig.cmx : ocsigen_socket.cmx ../baselib/ocsigen_loader.cmx \ ocsigen_server.cmo : ocsigen_socket.cmi \ ocsigen_parseconfig.cmi ../baselib/ocsigen_messages.cmi \ ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_http_frame.cmi \ ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ ../baselib/ocsigen_config.cmi ../baselib/ocsigen_commandline.cmo \ ocsigen_command.cmi ocsigen_cohttp_server.cmi \ @@ -69,7 +61,6 @@ ocsigen_server.cmo : ocsigen_socket.cmi \ ocsigen_server.cmx : ocsigen_socket.cmx \ ocsigen_parseconfig.cmx ../baselib/ocsigen_messages.cmx \ ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_http_frame.cmx \ ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx ../baselib/ocsigen_commandline.cmx \ ocsigen_command.cmx ocsigen_cohttp_server.cmx \ diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml index 3c631eee5..58e0dd7d1 100644 --- a/src/server/ocsigen_cohttp_server.ml +++ b/src/server/ocsigen_cohttp_server.ml @@ -6,6 +6,9 @@ exception Ocsigen_unsupported_media exception Ocsigen_http_error of Ocsigen_cookies.cookieset * Cohttp.Code.status +exception Ext_http_error of + Cohttp.Code.status * string option * Http_headers.t option + module Connection = struct exception Lost_connection of exn exception Aborted @@ -382,10 +385,8 @@ let handler ~address ~port ~connector (flow, conn) request body = None, `Internal_server_error | Unix.Unix_error (Unix.EACCES, _, _) -> None, `Forbidden - (* FIXME Cohttp transition - | Ocsigen_http_frame.Http_error.Http_exception - (code, _, headers) -> - headers, code *) + | Ext_http_error (code, _, headers) -> + headers, code | Ocsigen_lib.Ocsigen_Bad_Request -> None, `Bad_request | Ocsigen_unsupported_media -> diff --git a/src/server/ocsigen_cohttp_server.mli b/src/server/ocsigen_cohttp_server.mli index 083f0ec69..b3b2b524c 100644 --- a/src/server/ocsigen_cohttp_server.mli +++ b/src/server/ocsigen_cohttp_server.mli @@ -2,6 +2,12 @@ exception Ocsigen_unsupported_media exception Ocsigen_http_error of Ocsigen_cookies.cookieset * Cohttp.Code.status +(** Exception raised by exceptions to describe an HTTP error. It is + possible to pass the code of the error, an optional comment, and + optionally some headers. *) +exception Ext_http_error of + Cohttp.Code.status * string option * Cohttp.Header.t option + module Connection : sig exception Lost_connection of exn exception Aborted diff --git a/src/server/ocsigen_local_files.ml b/src/server/ocsigen_local_files.ml index 14a0a446c..40ed22856 100644 --- a/src/server/ocsigen_local_files.ml +++ b/src/server/ocsigen_local_files.ml @@ -220,22 +220,3 @@ let resolve (* We can get an EACCESS here, if are missing some rights on a directory *) | Unix.Unix_error (Unix.EACCES,_,_) -> raise Failed_403 | Unix.Unix_error (Unix.ENOENT,_,_) -> raise Failed_404 - - -(* Given a local file or directory, we retrieve its content *) -let content - ~request:{ Ocsigen_extensions.request_config = - { Ocsigen_extensions.charset_assoc ; mime_assoc } ; - request_info - } - ~file = - try - match file with - | RDir dirname -> - Ocsigen_senders.Directory_content.result_of_content - (dirname, Ocsigen_cohttp_server.Request.path request_info) - | RFile filename -> - Ocsigen_senders.File_content.result_of_content - (filename, charset_assoc, mime_assoc) - with - | Unix.Unix_error (Unix.EACCES,_,_) -> raise Failed_403 diff --git a/src/server/ocsigen_local_files.mli b/src/server/ocsigen_local_files.mli index a59c68d82..8e083357b 100644 --- a/src/server/ocsigen_local_files.mli +++ b/src/server/ocsigen_local_files.mli @@ -43,7 +43,6 @@ type resolved = | RFile of string | RDir of string - (** Finds [filename] in the filesystem, with a possible redirection if it is a directory. Takes into account the fact that [filename] does not exists, is a symlink or is a directory, and raises @@ -68,10 +67,3 @@ val resolve : ?no_check_for:string -> request:Ocsigen_extensions.request -> filename:string -> unit -> resolved - - -(** Given the local file [file], with a request originating at url - [url], returns a viewable content of [file]. Currently, the [url] - parameter is used only if [url] is a directory *) -val content: - request:Ocsigen_extensions.request -> file:resolved -> Ocsigen_http_frame.result Lwt.t From 91d834ce545c754eaeb452fc53e2468b4a79a5e4 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 6 Feb 2017 17:11:17 +0100 Subject: [PATCH 022/111] Remove Ocsigen_http_client --- doc/indexdoc | 1 - src/Makefile.filelist | 1 - src/extensions/revproxy.ml | 15 +---- src/server/.depend | 7 --- src/server/Makefile | 1 - src/server/ocsigen_http_client.ml | 70 ---------------------- src/server/ocsigen_http_client.mli | 95 ------------------------------ 7 files changed, 1 insertion(+), 189 deletions(-) delete mode 100644 src/server/ocsigen_http_client.ml delete mode 100644 src/server/ocsigen_http_client.mli diff --git a/doc/indexdoc b/doc/indexdoc index d259d9467..08519b160 100644 --- a/doc/indexdoc +++ b/doc/indexdoc @@ -16,7 +16,6 @@ Ocsigen_config Ocsigen_extensions Ocsigen_local_files Ocsigen_headers -Ocsigen_http_client Ocsigen_stream Ocsigen_comet Authbasic diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 629464581..fc81a2d0d 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -16,7 +16,6 @@ INTF_BASE := baselib/ocsigen_cache.cmi \ \ server/ocsigen_extensions.cmi \ server/ocsigen_parseconfig.cmi \ - server/ocsigen_http_client.cmi \ server/ocsigen_local_files.cmi \ server/ocsigen_server.cmi diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index 0ffee76bc..ed9255d49 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -20,20 +20,7 @@ (** Reverse proxy for Ocsigen - The reverse proxy is still experimental because it relies on the - experimental Ocsigen_http_client module. - - TODO - - Change the policy for trusted servers for pipelining? - (see ocsigen_http_client.ml) - - enhance pipelining - - HTTP/1.0 - - ... - - Enable returning for example (Ext_next 404) to allow other - extensions to take the request? There is a problem if the body - contains data (POST request) ... this data has been sent and is - lost ... *) + The reverse proxy is still experimental. *) open Lwt.Infix open Ocsigen_extensions diff --git a/src/server/.depend b/src/server/.depend index 825f3e780..cb41b7bb5 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -3,7 +3,6 @@ ocsigen_command.cmi : ocsigen_extensions.cmi : ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_cookies.cmi \ ocsigen_command.cmi ../http/ocsigen_charset_mime.cmi -ocsigen_http_client.cmi : ../http/http_headers.cmi ocsigen_local_files.cmi : ocsigen_extensions.cmi ocsigen_parseconfig.cmi : ocsigen_socket.cmi ocsigen_extensions.cmi ocsigen_server.cmi : @@ -32,12 +31,6 @@ ocsigen_extensions.cmx : \ ../baselib/ocsigen_config.cmx ocsigen_command.cmx \ ocsigen_cohttp_server.cmx ../http/ocsigen_charset_mime.cmx \ ocsigen_extensions.cmi -ocsigen_http_client.cmo : \ - ../baselib/ocsigen_lib.cmi ../http/http_headers.cmi \ - ocsigen_http_client.cmi -ocsigen_http_client.cmx : \ - ../baselib/ocsigen_lib.cmx ../http/http_headers.cmx \ - ocsigen_http_client.cmi ocsigen_local_files.cmo : ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi ocsigen_local_files.cmi ocsigen_local_files.cmx : ocsigen_extensions.cmx \ diff --git a/src/server/Makefile b/src/server/Makefile index 1af604080..91e09b7a9 100644 --- a/src/server/Makefile +++ b/src/server/Makefile @@ -18,7 +18,6 @@ FILES := ocsigen_socket.ml \ ocsigen_cohttp_server.ml \ ocsigen_extensions.ml \ ocsigen_parseconfig.ml \ - ocsigen_http_client.ml \ ocsigen_local_files.ml \ ocsigen_server.ml \ diff --git a/src/server/ocsigen_http_client.ml b/src/server/ocsigen_http_client.ml deleted file mode 100644 index ad98ac286..000000000 --- a/src/server/ocsigen_http_client.ml +++ /dev/null @@ -1,70 +0,0 @@ -open Lwt.Infix - -let target https host ?port uri = - let scheme = if https then "https" else "http" in - Uri.resolve scheme (Uri.make ~scheme ~host ?port ()) (Uri.of_string uri) - -let post_string ?(https = false) ?port ?(headers = Cohttp.Header.init ()) - ~host ~uri ~content ~content_type () = - let content_type = - String.concat "/" [ - fst content_type; - snd content_type - ] - in - let headers = - let add n v m = - Cohttp.Header.add m - (Http_headers.name_to_string n) - v - in - headers - |> add Http_headers.content_type content_type - |> add Http_headers.content_length (string_of_int (String.length content)) - in - Cohttp_lwt_unix.Client.post - ~body:(Cohttp_lwt_body.of_string content) - ~headers - (target https host ?port uri) - -let get ?(https = false) ?port ?headers ~host ~uri () = - Cohttp_lwt_unix.Client.get ?headers (target https host ?port uri) - -let post_urlencoded ?https ?port ?headers ~host ~uri ~content () = - post_string ?https ?port ?headers - ~host ~uri - ~content:(Netencoding.Url.mk_url_encoded_parameters content) - ~content_type:("application", "x-www-form-urlencoded") - () - -let basic_raw_request - ?(headers = Http_headers.empty) ?(https = false) ?port - ~content ?content_length - ~meth ~host ~inet_addr ~uri () = - ignore inet_addr; - let headers = - match content_length with - | Some len -> - Cohttp.Header.add headers - Http_headers.(name_to_string content_length) - (Int64.to_string len) - | None -> - headers - in - let body = - match content with - | Some c -> - Some (Cohttp_lwt_body.of_stream (Ocsigen_stream.to_lwt_stream c)) - | None -> - None - in - Cohttp_lwt_unix.Client.call ~headers ?body meth - (target https host ?port uri) - -let raw_request - ?keep_alive ?headers ?https ?port - ~content ?content_length ~meth ~host ~inet_addr ~uri () () = - ignore keep_alive; - basic_raw_request - ?headers ?https ?port ~content ?content_length - ~meth ~host ~inet_addr ~uri () diff --git a/src/server/ocsigen_http_client.mli b/src/server/ocsigen_http_client.mli deleted file mode 100644 index 7447f269a..000000000 --- a/src/server/ocsigen_http_client.mli +++ /dev/null @@ -1,95 +0,0 @@ -(** Using Ocsigen as a HTTP client *) - -(** Do a GET HTTP request. - - The default port is 80 for HTTP, 443 for HTTPS. - - The default protocol is http ([https=false]). *) -val get : - ?https: bool -> - ?port:int -> - ?headers: Cohttp.Header.t -> - host:string -> - uri:string -> - unit -> - (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t - -(** Do a POST HTTP request. - The default port is 80 for HTTP, 443 for HTTPS. - The default protocol is http ([https=false]). - Warning: the stream must be finalized manually after reading, using - {!Ocsigen_stream.finalize}, otherwise you will have fd leaks. -*) -val post_string : - ?https: bool -> - ?port:int -> - ?headers: Cohttp.Header.t -> - host:string -> - uri:string -> - content:string -> - content_type:(string * string) -> - unit -> - (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t - -(** Do a POST HTTP request with URL encoded parameters as content. - The default port is 80 for HTTP, 443 for HTTPS. - The default protocol is http ([https=false]). - Warning: the stream must be finalized manually after reading, using - {!Ocsigen_stream.finalize}, otherwise you will have fd leaks. -*) -val post_urlencoded : - ?https: bool -> - ?port:int -> - ?headers: Cohttp.Header.t -> - host:string -> - uri:string -> - content:(string * string) list -> - unit -> - (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t - -val raw_request : - ?keep_alive: bool -> - ?headers: Cohttp.Header.t -> - ?https: bool -> - ?port:int -> - content: string Ocsigen_stream.t option -> - ?content_length: int64 -> - meth:Cohttp.Code.meth -> - host:string -> - inet_addr:Unix.inet_addr -> - uri:string -> - unit -> - unit -> - (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t -(** - Do an HTTP request (low level). - - If the optional argument [headers] is present, no headers will be - added by Ocsigen, but those in this argument and host, and - [connection: close] or [connection: keep-alive]. - Be carefull to respect HTTP/1.1 in this case! - ([host] is the full Host HTTP field to send). - - The default port is 80 for HTTP, 443 for HTTPS. - - The default protocol is http ([https=false]). - - The parameters [?keep_alive] and [~inet_addr] are ignored. -*) - -val basic_raw_request : - ?headers: Cohttp.Header.t -> - ?https: bool -> - ?port:int -> - content: string Ocsigen_stream.t option -> - ?content_length: int64 -> - meth:Cohttp.Code.meth -> - host:string -> - inet_addr:Unix.inet_addr -> - uri:string -> - unit -> - (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t -(** Same as {!Ocsigen_http_client.raw_request}, - but does not try to reuse connections. - Opens a new connections for each request. Far less efficient. -*) From 3bcfa7198ec1514dc39469bf082a1535803a4033 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 6 Feb 2017 18:02:50 +0100 Subject: [PATCH 023/111] Ocsigen_cohttp_server split into multiple modules - Ocsigen_request - Ocsigen_response - Ocsigen_cohttp for what remains --- src/extensions/.depend | 110 +++--- src/extensions/accesscontrol.ml | 38 +- src/extensions/authbasic.ml | 6 +- src/extensions/cors.ml | 12 +- src/extensions/outputfilter.ml | 16 +- src/extensions/redirectmod.ml | 2 +- src/extensions/revproxy.ml | 23 +- src/extensions/rewritemod.ml | 10 +- src/extensions/staticmod.ml | 8 +- src/server/.depend | 89 +++-- src/server/Makefile | 4 +- src/server/ocsigen_cohttp.ml | 225 ++++++++++++ src/server/ocsigen_cohttp.mli | 29 ++ src/server/ocsigen_cohttp_server.ml | 502 --------------------------- src/server/ocsigen_cohttp_server.mli | 160 --------- src/server/ocsigen_extensions.ml | 75 ++-- src/server/ocsigen_extensions.mli | 22 +- src/server/ocsigen_request.ml | 147 ++++++++ src/server/ocsigen_request.mli | 73 ++++ src/server/ocsigen_response.ml | 100 ++++++ src/server/ocsigen_response.mli | 39 +++ src/server/ocsigen_server.ml | 37 +- 22 files changed, 822 insertions(+), 905 deletions(-) create mode 100644 src/server/ocsigen_cohttp.ml create mode 100644 src/server/ocsigen_cohttp.mli delete mode 100644 src/server/ocsigen_cohttp_server.ml delete mode 100644 src/server/ocsigen_cohttp_server.mli create mode 100644 src/server/ocsigen_request.ml create mode 100644 src/server/ocsigen_request.mli create mode 100644 src/server/ocsigen_response.ml create mode 100644 src/server/ocsigen_response.mli diff --git a/src/extensions/.depend b/src/extensions/.depend index 1d47951f4..2ad08d527 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -1,80 +1,74 @@ -accesscontrol.cmi : ../server/ocsigen_extensions.cmi -authbasic.cmi : -ocsigen_comet.cmi : ../baselib/ocsigen_stream.cmi -ocsipersist.cmi : -accesscontrol.cmo : \ - ../baselib/ocsigen_lib.cmi \ +accesscontrol.cmo : ../server/ocsigen_response.cmi \ + ../server/ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ ../http/http_headers.cmi accesscontrol.cmi -accesscontrol.cmx : \ - ../baselib/ocsigen_lib.cmx \ +accesscontrol.cmx : ../server/ocsigen_response.cmx \ + ../server/ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../http/http_headers.cmx accesscontrol.cmi -authbasic.cmo : ../server/ocsigen_extensions.cmi \ - ../http/ocsigen_cookies.cmi ../http/http_headers.cmi authbasic.cmi -authbasic.cmx : ../server/ocsigen_extensions.cmx \ - ../http/ocsigen_cookies.cmx ../http/http_headers.cmx authbasic.cmi -cgimod.cmo : ../baselib/ocsigen_stream.cmi \ - ../server/ocsigen_request_info.cmi ../baselib/ocsigen_lib.cmi \ +accesscontrol.cmi : +authbasic.cmo : ../server/ocsigen_request.cmi \ + ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ + ../server/ocsigen_cohttp.cmi ../http/http_headers.cmi \ + authbasic.cmi +authbasic.cmx : ../server/ocsigen_request.cmx \ + ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ + ../server/ocsigen_cohttp.cmx ../http/http_headers.cmx \ + authbasic.cmi +authbasic.cmi : +cgimod.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ ../baselib/ocsigen_config.cmi ../http/http_headers.cmi -cgimod.cmx : ../baselib/ocsigen_stream.cmx \ - ../server/ocsigen_request_info.cmx ../baselib/ocsigen_lib.cmx \ +cgimod.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx ../http/http_headers.cmx -cors.cmo : ../baselib/ocsigen_lib.cmi \ - ../server/ocsigen_extensions.cmi \ - ../http/http_headers.cmi -cors.cmx : ../baselib/ocsigen_lib.cmx \ - ../server/ocsigen_extensions.cmx \ - ../http/http_headers.cmx -deflatemod.cmo : ../baselib/ocsigen_stream.cmi \ - ../server/ocsigen_request_info.cmi \ - ../server/ocsigen_extensions.cmi \ - ../http/http_headers.cmi -deflatemod.cmx : ../baselib/ocsigen_stream.cmx \ - ../server/ocsigen_request_info.cmx \ - ../server/ocsigen_extensions.cmx \ - ../http/http_headers.cmx +cors.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ + ../server/ocsigen_extensions.cmi ../http/http_headers.cmi +cors.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ + ../server/ocsigen_extensions.cmx ../http/http_headers.cmx +deflatemod.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ + ../server/ocsigen_extensions.cmi ../http/http_headers.cmi +deflatemod.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ + ../server/ocsigen_extensions.cmx ../http/http_headers.cmx extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ ../baselib/ocsigen_config.cmi ../http/ocsigen_charset_mime.cmi extendconfiguration.cmx : ../server/ocsigen_parseconfig.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx ../http/ocsigen_charset_mime.cmx -ocsigen_comet.cmo : ../baselib/ocsigen_stream.cmi \ - ../server/ocsigen_request_info.cmi ../baselib/ocsigen_lib.cmi \ - ../server/ocsigen_extensions.cmi \ - ../baselib/ocsigen_config.cmi ocsigen_comet.cmi -ocsigen_comet.cmx : ../baselib/ocsigen_stream.cmx \ - ../server/ocsigen_request_info.cmx ../baselib/ocsigen_lib.cmx \ - ../server/ocsigen_extensions.cmx \ - ../baselib/ocsigen_config.cmx ocsigen_comet.cmi -outputfilter.cmo : \ - ../server/ocsigen_extensions.cmi \ - ../http/http_headers.cmi -outputfilter.cmx : \ - ../server/ocsigen_extensions.cmx \ - ../http/http_headers.cmx -redirectmod.cmo : ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi -redirectmod.cmx : ../baselib/ocsigen_lib.cmx ../server/ocsigen_extensions.cmx -revproxy.cmo : ../baselib/ocsigen_stream.cmi \ - ../baselib/ocsigen_lib.cmi \ +ocsigen_comet.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ + ../server/ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi \ + ocsigen_comet.cmi +ocsigen_comet.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ + ../server/ocsigen_extensions.cmx ../baselib/ocsigen_config.cmx \ + ocsigen_comet.cmi +ocsigen_comet.cmi : ../baselib/ocsigen_stream.cmi +ocsipersist.cmi : +outputfilter.cmo : ../server/ocsigen_response.cmi \ + ../server/ocsigen_extensions.cmi ../http/http_headers.cmi +outputfilter.cmx : ../server/ocsigen_response.cmx \ + ../server/ocsigen_extensions.cmx ../http/http_headers.cmx +redirectmod.cmo : ../server/ocsigen_response.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi -revproxy.cmx : ../baselib/ocsigen_stream.cmx \ - ../baselib/ocsigen_lib.cmx \ +redirectmod.cmx : ../server/ocsigen_response.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx -rewritemod.cmo : \ +revproxy.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ + ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi \ + ../http/http_headers.cmi +revproxy.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ + ../baselib/ocsigen_lib.cmx ../server/ocsigen_extensions.cmx \ + ../http/http_headers.cmx +rewritemod.cmo : ../server/ocsigen_request.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi -rewritemod.cmx : \ +rewritemod.cmx : ../server/ocsigen_request.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx -staticmod.cmo : \ +staticmod.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ ../server/ocsigen_local_files.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/http_headers.cmi -staticmod.cmx : \ +staticmod.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ ../server/ocsigen_local_files.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx ../http/http_headers.cmx -userconf.cmo : ../server/ocsigen_request_info.cmi ../baselib/ocsigen_lib.cmi \ - ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi -userconf.cmx : ../server/ocsigen_request_info.cmx ../baselib/ocsigen_lib.cmx \ - ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx +userconf.cmo : ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi \ + ../http/ocsigen_cookies.cmi +userconf.cmx : ../baselib/ocsigen_lib.cmx ../server/ocsigen_extensions.cmx \ + ../http/ocsigen_cookies.cmx diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index 52369ecf3..26405ecf8 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -43,17 +43,17 @@ let rec parse_condition = function (fun ri -> let r = Ipaddr.Prefix.mem - (Ocsigen_cohttp_server.Request.remote_ip_parsed ri) + (Ocsigen_request.remote_ip_parsed ri) prefix in if r then Lwt_log.ign_info_f ~section "IP: %a matches %s" - (fun () -> Ocsigen_cohttp_server.Request.remote_ip) ri s + (fun () -> Ocsigen_request.remote_ip) ri s else Lwt_log.ign_info_f ~section "IP: %a does not match %s" - (fun () -> Ocsigen_cohttp_server.Request.remote_ip) ri s; + (fun () -> Ocsigen_request.remote_ip) ri s; r) | Element ("ip" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s @@ -67,7 +67,7 @@ let rec parse_condition = function "Bad port [%s] in condition" s in (fun ri -> - let r = Ocsigen_cohttp_server.Request.port ri = port in + let r = Ocsigen_request.port ri = port in if r then Lwt_log.ign_info_f ~section "PORT: %d accepted" port @@ -75,7 +75,7 @@ let rec parse_condition = function Lwt_log.ign_info_f ~section "PORT: %a not accepted (%d expected)" (fun () ri -> - string_of_int (Ocsigen_cohttp_server.Request.port ri)) + string_of_int (Ocsigen_request.port ri)) ri port; r) | Element ("port" as s, _, _) -> @@ -83,7 +83,7 @@ let rec parse_condition = function | Element ("ssl", [], []) -> (fun ri -> - let r = Ocsigen_cohttp_server.Request.ssl ri in + let r = Ocsigen_request.ssl ri in if r then Lwt_log.ign_info ~section "SSL: accepted" else @@ -110,7 +110,7 @@ let rec parse_condition = function if r then Lwt_log.ign_info_f "HEADER: header %s matches %S" name reg; r) - (Ocsigen_cohttp_server.Request.header_multi ri + (Ocsigen_request.header_multi ri (Http_headers.name name)) in if not r @@ -121,7 +121,7 @@ let rec parse_condition = function | Element ("method", ["value", s], []) -> fun ri -> let m = Cohttp.Code.method_of_string s - and m' = Ocsigen_cohttp_server.Request.meth ri in + and m' = Ocsigen_request.meth ri in let s' = Cohttp.Code.string_of_method m' in let r = m = m' in if r then @@ -135,7 +135,7 @@ let rec parse_condition = function | Element ("protocol", ["value", s], []) -> fun ri -> let v = Cohttp.Code.version_of_string s - and v' = Ocsigen_cohttp_server.Request.version ri in + and v' = Ocsigen_request.version ri in let s' = Cohttp.Code.string_of_version v' in let r = v = v' in if r then @@ -156,7 +156,7 @@ let rec parse_condition = function "Bad regular expression [%s] in condition" s in fun ri -> - let sps = Ocsigen_cohttp_server.Request.sub_path_string ri in + let sps = Ocsigen_request.sub_path_string ri in let r = Netstring_pcre.string_match regexp sps 0 <> None in if r then Lwt_log.ign_info_f ~section "PATH: \"%s\" matches %S" sps s @@ -328,7 +328,7 @@ let parse_config parse_fun = function Lwt_log.ign_info ~section "Allowed proxy"; let request = let header = - Ocsigen_cohttp_server.Request.header + Ocsigen_request.header request_info Http_headers.x_forwarded_for in @@ -340,7 +340,7 @@ let parse_config parse_fun = function let proxy_ip = Ipaddr.of_string_exn last_proxy in let equal_ip = proxy_ip = - Ocsigen_cohttp_server.Request.remote_ip_parsed request_info + Ocsigen_request.remote_ip_parsed request_info in let need_equal_ip = match param with @@ -359,7 +359,7 @@ let parse_config parse_fun = function { request with Ocsigen_extensions.request_info = - Ocsigen_cohttp_server.Request.update + Ocsigen_request.update ~forward_ip:proxies ~remote_ip:original_ip request_info @@ -368,7 +368,7 @@ let parse_config parse_fun = function (Lwt_log.ign_warning_f ~section "X-Forwarded-For: host ip (%s) \ does not match the header (%s)" - (Ocsigen_cohttp_server.Request.remote_ip request_info) + (Ocsigen_request.remote_ip request_info) header; request) | _ -> @@ -386,7 +386,7 @@ let parse_config parse_fun = function in (function | Ocsigen_extensions.Req_found (request, resp) -> - apply request (Ocsigen_cohttp_server.Answer.status resp) + apply request (Ocsigen_response.status resp) | Ocsigen_extensions.Req_not_found (code, request) -> apply request code) @@ -395,7 +395,7 @@ let parse_config parse_fun = function Lwt_log.ign_info ~section "Allowed proxy for ssl"; let request_info = let header = - Ocsigen_cohttp_server.Request.header + Ocsigen_request.header request_info Http_headers.x_forwarded_proto in @@ -403,9 +403,9 @@ let parse_config parse_fun = function | Some header -> (match String.lowercase header with | "http" -> - Ocsigen_cohttp_server.Request.update ~ssl:false request_info + Ocsigen_request.update ~ssl:false request_info | "https" -> - Ocsigen_cohttp_server.Request.update ~ssl:true request_info + Ocsigen_request.update ~ssl:true request_info | _ -> Lwt_log.ign_info_f ~section "Malformed X-Forwarded-Proto field: %s" header; @@ -421,7 +421,7 @@ let parse_config parse_fun = function in (function | Ocsigen_extensions.Req_found (request, resp) -> - apply request (Ocsigen_cohttp_server.Answer.status resp) + apply request (Ocsigen_response.status resp) | Ocsigen_extensions.Req_not_found (code, request) -> apply request code) | Element (t, _, _) -> raise (Ocsigen_extensions.Bad_config_tag_for_extension t) diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index 47690636f..5131518dd 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -67,14 +67,14 @@ let gen ~realm ~auth rs = Http_headers.empty in Lwt_log.ign_info ~section "AUTH: invalid credentials!"; - Lwt.fail (Ocsigen_cohttp_server.Ext_http_error + Lwt.fail (Ocsigen_cohttp.Ext_http_error (`Unauthorized, None, Some h)) and invalid_header () = Lwt_log.ign_info ~section "AUTH: invalid Authorization header"; Lwt.fail - (Ocsigen_cohttp_server.Ocsigen_http_error + (Ocsigen_cohttp.Ocsigen_http_error (Ocsigen_cookies.Cookies.empty, `Bad_request)) in @@ -94,7 +94,7 @@ let gen ~realm ~auth rs = match rs with | Ocsigen_extensions.Req_not_found (err, ri) -> (match - Ocsigen_cohttp_server.Request.header + Ocsigen_request.header ri.Ocsigen_extensions.request_info Http_headers.authorization with diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index 236c572ad..01edc9961 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -25,7 +25,7 @@ let section = Lwt_log.Section.make "ocsigen:ext:cors" (*** MAIN FUNCTION ***) let default_frame () = - Ocsigen_cohttp_server.Answer.make + Ocsigen_response.make ~response:(Cohttp.Response.make ~status:`OK ()) () @@ -41,7 +41,7 @@ exception Refused let add_headers config r response = - match Ocsigen_cohttp_server.Request.header r Http_headers.origin with + match Ocsigen_request.header r Http_headers.origin with | None -> Lwt.return Ocsigen_extensions.Ext_do_nothing @@ -61,7 +61,7 @@ let add_headers config r response = let l = match - Ocsigen_cohttp_server.Request.header r + Ocsigen_request.header r Http_headers.access_control_request_method with | Some request_method -> @@ -86,7 +86,7 @@ let add_headers config r response = let l = match - Ocsigen_cohttp_server.Request.header r + Ocsigen_request.header r Http_headers.access_control_request_headers with | Some request_headers -> @@ -117,13 +117,13 @@ let add_headers config r response = Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return @@ - Ocsigen_cohttp_server.Answer.replace_headers response l)) + Ocsigen_response.replace_headers response l)) let main config = function | Ocsigen_extensions.Req_not_found (_, {Ocsigen_extensions.request_info}) -> - (match Ocsigen_cohttp_server.Request.meth request_info with + (match Ocsigen_request.meth request_info with | `OPTIONS -> (Lwt_log.ign_info ~section "OPTIONS request"; try diff --git a/src/extensions/outputfilter.ml b/src/extensions/outputfilter.ml index 98f417c84..c1baeeaed 100644 --- a/src/extensions/outputfilter.ml +++ b/src/extensions/outputfilter.ml @@ -35,30 +35,30 @@ let gen filter = function let l = List.map (Netstring_pcre.global_replace regexp dest) - (Ocsigen_cohttp_server.Answer.header_multi res header) - and a = Ocsigen_cohttp_server.Answer.remove_header res header in - Ocsigen_cohttp_server.Answer.add_header_multi a header l + (Ocsigen_response.header_multi res header) + and a = Ocsigen_response.remove_header res header in + Ocsigen_response.add_header_multi a header l with Not_found -> res) | Add_header (header, dest, replace) -> match replace with | None -> - (match Ocsigen_cohttp_server.Answer.header res header with + (match Ocsigen_response.header res header with | Some _ -> res | None -> - Ocsigen_cohttp_server.Answer.add_header res header dest) + Ocsigen_response.add_header res header dest) | Some false -> - Ocsigen_cohttp_server.Answer.add_header res header dest + Ocsigen_response.add_header res header dest | Some true -> - Ocsigen_cohttp_server.Answer.replace_header res header dest) + Ocsigen_response.replace_header res header dest) let gen_code code = function | Ocsigen_extensions.Req_not_found (code, _) -> Lwt.return (Ocsigen_extensions.Ext_next code) | Ocsigen_extensions.Req_found (ri, res) -> Lwt.return @@ Ocsigen_extensions.Ext_found (fun () -> - Lwt.return (Ocsigen_cohttp_server.Answer.set_status res code)) + Lwt.return (Ocsigen_response.set_status res code)) let parse_config config_elem = let header = ref None in diff --git a/src/extensions/redirectmod.ml b/src/extensions/redirectmod.ml index 813d2630f..1045a2d93 100644 --- a/src/extensions/redirectmod.ml +++ b/src/extensions/redirectmod.ml @@ -58,7 +58,7 @@ let attempt_redir dir err ri () = and status = if temp then `Found else `Moved_permanently in Cohttp.Response.make ~status ~headers () in - Lwt.return (Ocsigen_cohttp_server.Answer.make ~response ())) + Lwt.return (Ocsigen_response.make ~response ())) (** The function that will generate the pages from the request *) let gen dir = function diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index ed9255d49..fb0780744 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -98,7 +98,7 @@ let gen dir = function let host = match if dir.keephost then - Ocsigen_cohttp_server.Request.host request_info + Ocsigen_request.host request_info else None with @@ -109,16 +109,16 @@ let gen dir = function let do_request () = let address = Unix.string_of_inet_addr - (Ocsigen_cohttp_server.Request.address request_info) + (Ocsigen_request.address request_info) in let forward = String.concat ", " - (Ocsigen_cohttp_server.Request.remote_ip request_info - :: Ocsigen_cohttp_server.Request.forward_ip request_info + (Ocsigen_request.remote_ip request_info + :: Ocsigen_request.forward_ip request_info @ [address]) in let proto = - if Ocsigen_cohttp_server.Request.ssl request_info then + if Ocsigen_request.ssl request_info then "https" else "http" @@ -126,10 +126,10 @@ let gen dir = function let headers = let h = Cohttp.Request.headers - (Ocsigen_cohttp_server.Request.request request_info) + (Ocsigen_request.request request_info) in let h = - Ocsigen_cohttp_server.Request.version request_info + Ocsigen_request.version request_info |> Cohttp.Code.string_of_version |> Cohttp.Header.add h Http_headers.(name_to_string x_forwarded_proto) @@ -141,13 +141,12 @@ let gen dir = function in Cohttp.Header.remove h Http_headers.(name_to_string host) and uri = Printf.sprintf "%s://%s%s" proto host uri - and body = Ocsigen_cohttp_server.Request.body request_info - and meth = Ocsigen_cohttp_server.Request.meth request_info in + and body = Ocsigen_request.body request_info + and meth = Ocsigen_request.meth request_info in Client.call ~headers ~body meth (Uri.of_string uri) in - Lwt.return @@ Ext_found (fun () -> - do_request () >|= - Ocsigen_cohttp_server.Answer.of_cohttp)) + Lwt.return @@ + Ext_found (fun () -> do_request () >|= Ocsigen_response.of_cohttp)) (function | Not_concerned -> Lwt.return (Ext_next err) | e -> Lwt.fail e) diff --git a/src/extensions/rewritemod.ml b/src/extensions/rewritemod.ml index 575557a4d..7cf8cd477 100644 --- a/src/extensions/rewritemod.ml +++ b/src/extensions/rewritemod.ml @@ -54,11 +54,11 @@ let gen regexp continue = function let redir, full_rewrite = let ri = ri.Ocsigen_extensions.request_info in find_rewrite regexp - (match Ocsigen_cohttp_server.Request.query ri with + (match Ocsigen_request.query ri with | None -> - Ocsigen_cohttp_server.Request.sub_path_string ri + Ocsigen_request.sub_path_string ri | Some g -> - Ocsigen_cohttp_server.Request.sub_path_string ri + Ocsigen_request.sub_path_string ri ^ "?" ^ g) in Lwt_log.ign_info_f ~section "YES! rewrite to: %s" redir; @@ -66,7 +66,7 @@ let gen regexp continue = function Lwt.return @@ Ocsigen_extensions.Ext_continue_with ({ ri with Ocsigen_extensions.request_info = - Ocsigen_cohttp_server.Request.update_url + Ocsigen_request.update_url ~full_rewrite (Uri.of_string redir) ri.Ocsigen_extensions.request_info @@ -77,7 +77,7 @@ let gen regexp continue = function Lwt.return @@ Ocsigen_extensions.Ext_retry_with ({ ri with Ocsigen_extensions.request_info = - Ocsigen_cohttp_server.Request.update_url + Ocsigen_request.update_url ~full_rewrite (Uri.of_string redir) ri.Ocsigen_extensions.request_info }, diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index b8d861616..2b88d1392 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -136,7 +136,7 @@ let gen ~usermode ?cache dir = function let pathstring = Ocsigen_lib.Url.string_of_url_path ~encode:false - (Ocsigen_cohttp_server.Request.path request_info) + (Ocsigen_request.path request_info) in find_static_page ~request ~usermode ~dir ~err ~pathstring in @@ -148,12 +148,12 @@ let gen ~usermode ?cache dir = function failwith "FIXME: staticmod dirs not implemented" in Cohttp_lwt_unix.Server.respond_file ~fname () >>= fun answer -> - let answer = Ocsigen_cohttp_server.Answer.of_cohttp answer in + let answer = Ocsigen_response.of_cohttp answer in let answer = if not status_filter then answer else - Ocsigen_cohttp_server.Answer.set_status answer err + Ocsigen_response.set_status answer err in let answer = match cache with @@ -167,7 +167,7 @@ let gen ~usermode ?cache dir = function "max-age=" ^ string_of_int duration, gmt_date (Unix.time () +. float_of_int duration) in - Ocsigen_cohttp_server.Answer.replace_headers answer [ + Ocsigen_response.replace_headers answer [ Http_headers.cache_control , cache_control ; Http_headers.expires , expires ; ] diff --git a/src/server/.depend b/src/server/.depend index cb41b7bb5..f0b04014f 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -1,40 +1,32 @@ -ocsigen_cohttp_server.cmi : ../http/ocsigen_cookies.cmi -ocsigen_command.cmi : -ocsigen_extensions.cmi : ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_cookies.cmi \ - ocsigen_command.cmi ../http/ocsigen_charset_mime.cmi -ocsigen_local_files.cmi : ocsigen_extensions.cmi -ocsigen_parseconfig.cmi : ocsigen_socket.cmi ocsigen_extensions.cmi -ocsigen_server.cmi : -ocsigen_socket.cmi : -ocsigen_cohttp_server.cmo : \ - ../baselib/ocsigen_stream.cmi ocsigen_socket.cmi \ - ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_cookies.cmi \ - ../baselib/ocsigen_config.cmi ocsigen_cohttp_server.cmi -ocsigen_cohttp_server.cmx : \ - ../baselib/ocsigen_stream.cmx ocsigen_socket.cmx \ - ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_cookies.cmx \ - ../baselib/ocsigen_config.cmx ocsigen_cohttp_server.cmi +ocsigen_cohttp.cmo : ../baselib/ocsigen_stream.cmi ocsigen_socket.cmi \ + ocsigen_response.cmi ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ + ../http/ocsigen_cookies.cmi ../http/http_headers.cmi ocsigen_cohttp.cmi +ocsigen_cohttp.cmx : ../baselib/ocsigen_stream.cmx ocsigen_socket.cmx \ + ocsigen_response.cmx ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ + ../http/ocsigen_cookies.cmx ../http/http_headers.cmx ocsigen_cohttp.cmi +ocsigen_cohttp.cmi : ocsigen_socket.cmi ocsigen_response.cmi \ + ocsigen_request.cmi ../http/ocsigen_cookies.cmi ocsigen_command.cmo : ../baselib/ocsigen_messages.cmi ocsigen_command.cmi ocsigen_command.cmx : ../baselib/ocsigen_messages.cmx ocsigen_command.cmi -ocsigen_extensions.cmo : \ +ocsigen_command.cmi : +ocsigen_extensions.cmo : ocsigen_response.cmi ocsigen_request.cmi \ ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_cookies.cmi \ - ../baselib/ocsigen_config.cmi ocsigen_command.cmi \ - ocsigen_cohttp_server.cmi ../http/ocsigen_charset_mime.cmi \ + ../http/ocsigen_cookies.cmi ../baselib/ocsigen_config.cmi \ + ocsigen_command.cmi ../http/ocsigen_charset_mime.cmi \ ocsigen_extensions.cmi -ocsigen_extensions.cmx : \ +ocsigen_extensions.cmx : ocsigen_response.cmx ocsigen_request.cmx \ ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_cookies.cmx \ - ../baselib/ocsigen_config.cmx ocsigen_command.cmx \ - ocsigen_cohttp_server.cmx ../http/ocsigen_charset_mime.cmx \ + ../http/ocsigen_cookies.cmx ../baselib/ocsigen_config.cmx \ + ocsigen_command.cmx ../http/ocsigen_charset_mime.cmx \ ocsigen_extensions.cmi +ocsigen_extensions.cmi : ocsigen_response.cmi ocsigen_request.cmi \ + ../baselib/ocsigen_lib.cmi ../http/ocsigen_cookies.cmi \ + ocsigen_command.cmi ../http/ocsigen_charset_mime.cmi ocsigen_local_files.cmo : ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi ocsigen_local_files.cmi ocsigen_local_files.cmx : ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ocsigen_local_files.cmi +ocsigen_local_files.cmi : ocsigen_extensions.cmi ocsigen_parseconfig.cmo : ocsigen_socket.cmi ../baselib/ocsigen_loader.cmi \ ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi ../http/ocsigen_charset_mime.cmi \ @@ -43,25 +35,32 @@ ocsigen_parseconfig.cmx : ocsigen_socket.cmx ../baselib/ocsigen_loader.cmx \ ../baselib/ocsigen_lib.cmx ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ../http/ocsigen_charset_mime.cmx \ ocsigen_parseconfig.cmi -ocsigen_server.cmo : ocsigen_socket.cmi \ - ocsigen_parseconfig.cmi ../baselib/ocsigen_messages.cmi \ - ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ - ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ +ocsigen_parseconfig.cmi : ocsigen_socket.cmi ocsigen_extensions.cmi +ocsigen_request.cmo : ocsigen_socket.cmi ../baselib/ocsigen_lib.cmi \ + ../http/http_headers.cmi ocsigen_request.cmi +ocsigen_request.cmx : ocsigen_socket.cmx ../baselib/ocsigen_lib.cmx \ + ../http/http_headers.cmx ocsigen_request.cmi +ocsigen_request.cmi : ../http/http_headers.cmi +ocsigen_response.cmo : ../http/ocsigen_cookies.cmi ../http/http_headers.cmi \ + ocsigen_response.cmi +ocsigen_response.cmx : ../http/ocsigen_cookies.cmx ../http/http_headers.cmx \ + ocsigen_response.cmi +ocsigen_response.cmi : ../http/ocsigen_cookies.cmi ../http/http_headers.cmi +ocsigen_server.cmo : ocsigen_socket.cmi ocsigen_parseconfig.cmi \ + ../baselib/ocsigen_messages.cmi ../baselib/ocsigen_loader.cmi \ + ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi ../baselib/ocsigen_commandline.cmo \ - ocsigen_command.cmi ocsigen_cohttp_server.cmi \ - ../baselib/ocsigen_cache.cmi ../baselib/dynlink_wrapper.cmo \ - ocsigen_server.cmi -ocsigen_server.cmx : ocsigen_socket.cmx \ - ocsigen_parseconfig.cmx ../baselib/ocsigen_messages.cmx \ - ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ - ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ + ocsigen_command.cmi ../baselib/ocsigen_cache.cmi \ + ../baselib/dynlink_wrapper.cmo ocsigen_server.cmi +ocsigen_server.cmx : ocsigen_socket.cmx ocsigen_parseconfig.cmx \ + ../baselib/ocsigen_messages.cmx ../baselib/ocsigen_loader.cmx \ + ../baselib/ocsigen_lib.cmx ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ../baselib/ocsigen_commandline.cmx \ - ocsigen_command.cmx ocsigen_cohttp_server.cmx \ - ../baselib/ocsigen_cache.cmx ../baselib/dynlink_wrapper.cmx \ - ocsigen_server.cmi -ocsigen_socket.cmo : ../baselib/ocsigen_lib_base.cmi \ - ../baselib/ocsigen_lib.cmi ocsigen_socket.cmi -ocsigen_socket.cmx : ../baselib/ocsigen_lib_base.cmx \ - ../baselib/ocsigen_lib.cmx ocsigen_socket.cmi + ocsigen_command.cmx ../baselib/ocsigen_cache.cmx \ + ../baselib/dynlink_wrapper.cmx ocsigen_server.cmi +ocsigen_server.cmi : +ocsigen_socket.cmo : ../baselib/ocsigen_lib_base.cmi ocsigen_socket.cmi +ocsigen_socket.cmx : ../baselib/ocsigen_lib_base.cmx ocsigen_socket.cmi +ocsigen_socket.cmi : server_main.cmo : ocsigen_server.cmi server_main.cmx : ocsigen_server.cmx diff --git a/src/server/Makefile b/src/server/Makefile index 91e09b7a9..69d4bd75d 100644 --- a/src/server/Makefile +++ b/src/server/Makefile @@ -15,7 +15,9 @@ all: byte opt FILES := ocsigen_socket.ml \ ocsigen_command.ml \ - ocsigen_cohttp_server.ml \ + ocsigen_request.ml \ + ocsigen_response.ml \ + ocsigen_cohttp.ml \ ocsigen_extensions.ml \ ocsigen_parseconfig.ml \ ocsigen_local_files.ml \ diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml new file mode 100644 index 000000000..4b1627546 --- /dev/null +++ b/src/server/ocsigen_cohttp.ml @@ -0,0 +1,225 @@ +open Lwt.Infix + +let section = Lwt_log.Section.make "ocsigen:cohttp" + +exception Ocsigen_http_error of + Ocsigen_cookies.cookieset * Cohttp.Code.status + +exception Ext_http_error of + Cohttp.Code.status * string option * Http_headers.t option + +(** print_request Print request for debug + @param out_ch output for debug + @param request Cohttp request *) + +let print_request fmt request = + let print_list print_data out_ch lst = + let rec aux = function + | [] -> () + | [ x ] -> print_data out_ch x + | x :: r -> print_data out_ch x; aux r + in aux lst + in + + Format.fprintf fmt "%s [%s/%s]:\n" + (Uri.to_string (Cohttp.Request.uri request)) + (Cohttp.Code.string_of_version request.version) + (Cohttp.Code.string_of_method request.meth) ; + + Cohttp.Header.iter + (fun key values -> + Format.fprintf fmt "\t%s = %a\n" key + (print_list Format.pp_print_string) values) + request.headers + +let waiters = Hashtbl.create 256 + +exception Ocsigen_Is_a_directory of (Ocsigen_request.t -> Neturl.url) + +module Cookie = struct + + let serialize_cookie_raw path exp name c secure = + Format.sprintf "%s=%s; path=/%s%s%s" + name c + (Ocsigen_lib.Url.string_of_url_path ~encode:true path) + (if secure then "; secure" else "") + (match exp with + | Some s -> + "; expires=" ^ + Netdate.format + "%a, %d-%b-%Y %H:%M:%S GMT" + (Netdate.create s) + | None -> + "") + + let serialize_cookies path table headers = + Ocsigen_cookies.CookiesTable.fold + (fun name c h -> + let exp, v, secure = match c with + | Ocsigen_cookies.OUnset -> (Some 0., "", false) + | Ocsigen_cookies.OSet (t, v, secure) -> (t, v, secure) + in + Http_headers.add + Http_headers.set_cookie + (serialize_cookie_raw path exp name v secure) + h) + table + headers + + let serialize cookies headers = + Ocsigen_cookies.Cookies.fold serialize_cookies cookies headers + +end + +let handler ~address ~port ~connector (flow, conn) request body = + + Lwt_log.ign_info_f ~section + "Receiving the request: %s" + (Format.asprintf "%a" print_request request); + + let filenames = ref [] in + let edn = Conduit_lwt_unix.endp_of_flow flow in + let rec getsockname = function + | `TCP (ip, port) -> + Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) + | `Unix_domain_socket path -> + Unix.ADDR_UNIX path + | `TLS (_, edn) -> + getsockname edn + | `Unknown err -> + raise (Failure ("resolution failed: " ^ err)) + | `Vchan_direct _ -> + raise (Failure "VChan not supported") + | `Vchan_domain_socket _ -> + raise (Failure "VChan not supported") + in + + let sockaddr = getsockname edn in + let (waiter, wakener) = Lwt.wait () in + Hashtbl.add waiters conn wakener; + + let handle_error exn = + + Lwt_log.ign_debug ~section ~exn "Got exception while handling request." ; + + let headers, ret_code = match exn with + | Ocsigen_http_error (cookies_to_set, code) -> + let headers = + Cookie.serialize cookies_to_set (Cohttp.Header.init ()) + in + Some headers, code + | Ocsigen_stream.Interrupted Ocsigen_stream.Already_read -> + None, `Internal_server_error + | Unix.Unix_error (Unix.EACCES, _, _) -> + None, `Forbidden + | Ext_http_error (code, _, headers) -> + headers, code + | Ocsigen_lib.Ocsigen_Bad_Request -> + None, `Bad_request + | Neturl.Malformed_URL -> + None, `Bad_request + | Ocsigen_lib.Ocsigen_Request_too_long -> + None, `Request_entity_too_large + | exn -> + Lwt_log.ign_error ~section ~exn "Error while handling request." ; + None, `Internal_server_error + in + + Lwt_log.ign_warning_f ~section "Returning error code %i." + (Cohttp.Code.code_of_status (ret_code :> Cohttp.Code.status_code)); + + let body = + match ret_code with + | `Not_found -> "Not Found" + | _ -> Printexc.to_string exn in + + Cohttp_lwt_unix.Server.respond_error + ?headers ~status:(ret_code :> Cohttp.Code.status_code) ~body () + in + + if !filenames <> [] then + List.iter + (fun a -> + try + Unix.unlink a + with Unix.Unix_error _ as exn -> + Lwt_log.ign_warning_f ~section ~exn + "Error while removing file %s" a) + !filenames; + + (* TODO: equivalent of Ocsigen_range *) + (* TODO: handle cookies *) + + let request = + Ocsigen_request.make + ~address ~port ~filenames ~sockaddr ~request ~body ~waiter + () + + in + + Lwt.catch + (fun () -> + connector request >>= fun { Ocsigen_response.a_response ; a_body } -> + Lwt.return (a_response, a_body)) + (function + | Ocsigen_Is_a_directory fun_request -> + Cohttp_lwt_unix.Server.respond_redirect + ~uri: + (fun_request request + |> Neturl.string_of_url + |> Uri.of_string) + () + | exn -> + handle_error exn) + +let conn_closed (flow, conn) = + try + let wakener = Hashtbl.find waiters conn in + Lwt.wakeup wakener (); Hashtbl.remove waiters conn + with Not_found -> () + +let stop, stop_wakener = Lwt.wait () + +let shutdown timeout = + let process = + match timeout with + | Some f -> (fun () -> Lwt_unix.sleep f) + | None -> (fun () -> Lwt.return ()) + in + ignore (Lwt.pick [process (); stop] >>= fun () -> exit 0) + +let number_of_client () = 0 +let get_number_of_connected = number_of_client + +let service ?ssl ~address ~port ~connector () = + let tls_server_key = match ssl with + | Some (crt, key, Some password) -> + `TLS (`Crt_file_path crt, + `Key_file_path key, + `Password password) + | Some (crt, key, None) -> + `TLS (`Crt_file_path crt, + `Key_file_path key, + `No_password) + | None -> `None + in + (* We create a specific context for Conduit and Cohttp. *) + Conduit_lwt_unix.init + ~src:(Ocsigen_socket.string_of_socket_type address) + ~tls_server_key () >>= fun conduit_ctx -> + Lwt.return (Cohttp_lwt_unix_net.init ~ctx:conduit_ctx ()) >>= fun ctx -> + (* We catch the INET_ADDR of the server *) + let callback = + let address = Ocsigen_socket.to_inet_addr address in + handler ~address ~port ~connector + in + let config = Cohttp_lwt_unix.Server.make ~conn_closed ~callback () in + let mode = + match tls_server_key with + | `None -> `TCP (`Port port) + | `TLS (crt, key, pass) -> + `OpenSSL (crt, key, pass, `Port port) + in + Cohttp_lwt_unix.Server.create ~stop ~ctx ~mode config + >>= fun () -> + Lwt.return (Lwt.wakeup stop_wakener ()) diff --git a/src/server/ocsigen_cohttp.mli b/src/server/ocsigen_cohttp.mli new file mode 100644 index 000000000..6befce73d --- /dev/null +++ b/src/server/ocsigen_cohttp.mli @@ -0,0 +1,29 @@ +exception Ocsigen_http_error of + Ocsigen_cookies.cookieset * Cohttp.Code.status + +(** Exception raised by exceptions to describe an HTTP error. It is + possible to pass the code of the error, an optional comment, and + optionally some headers. *) +exception Ext_http_error of + Cohttp.Code.status * string option * Cohttp.Header.t option + +(** compute a redirection if path links to a directory *) +exception Ocsigen_Is_a_directory of (Ocsigen_request.t -> Neturl.url) + +(** accessor to get number of client (used by eliom monitoring) *) +val number_of_client : unit -> int + +(** alias of [number_of_client] *) +val get_number_of_connected : unit -> int + +(** Shutdown main loop of server *) +val shutdown : float option -> unit + +(** initialize a main loop of http server *) +val service : + ?ssl:string * string * (bool -> string) option -> + address:Ocsigen_socket.socket_type -> + port:int -> + connector:(Ocsigen_request.t -> Ocsigen_response.t Lwt.t) -> + unit -> + unit Lwt.t diff --git a/src/server/ocsigen_cohttp_server.ml b/src/server/ocsigen_cohttp_server.ml deleted file mode 100644 index 58e0dd7d1..000000000 --- a/src/server/ocsigen_cohttp_server.ml +++ /dev/null @@ -1,502 +0,0 @@ -open Lwt.Infix - -let section = Lwt_log.Section.make "ocsigen:cohttp" - -exception Ocsigen_unsupported_media -exception Ocsigen_http_error of - Ocsigen_cookies.cookieset * Cohttp.Code.status - -exception Ext_http_error of - Cohttp.Code.status * string option * Http_headers.t option - -module Connection = struct - exception Lost_connection of exn - exception Aborted - exception Timeout - exception Keepalive_timeout - exception Connection_closed -end - -module Request = struct - - type t = { - r_address : Unix.inet_addr ; - r_port : int ; - r_filenames : string list ref ; - r_sockaddr : Lwt_unix.sockaddr ; - r_remote_ip : string Lazy.t ; - r_remote_ip_parsed : Ipaddr.t Lazy.t ; - r_forward_ip : string list ; - r_request : Cohttp.Request.t ; - r_body : Cohttp_lwt_body.t ; - r_sub_path : string option ; - r_waiter : unit Lwt.t ; - mutable r_tries : int - } - - (* FIXME: old ocsigenserver used to store original_full_path. Do we - really need that? *) - - let make - ?(forward_ip = []) ?sub_path - ~address ~port ~filenames ~sockaddr ~request ~body ~waiter () = - let r_remote_ip = - lazy - (Unix.string_of_inet_addr - (Ocsigen_socket.ip_of_sockaddr sockaddr)) - in - let r_remote_ip_parsed = - lazy (Ipaddr.of_string_exn (Lazy.force r_remote_ip)) - in - { - r_address = address ; - r_port = port ; - r_filenames = filenames ; - r_sockaddr = sockaddr ; - r_remote_ip ; - r_remote_ip_parsed ; - r_forward_ip = forward_ip ; - r_request = request ; - r_body = body ; - r_sub_path = sub_path ; - r_waiter = waiter ; - r_tries = 0 - } - - let update - ?forward_ip ?remote_ip ?ssl ?request - ({ - r_request ; - r_forward_ip ; - r_remote_ip ; - r_remote_ip_parsed - } as r) = - (* FIXME : ssl *) - let r_request = - match request with - | Some request -> - request - | None -> - r_request - and r_forward_ip = - match forward_ip with - | Some forward_ip -> - forward_ip - | None -> - r_forward_ip - and r_remote_ip, r_remote_ip_parsed = - match remote_ip with - | Some remote_ip -> - lazy remote_ip, lazy (Ipaddr.of_string_exn remote_ip) - | None -> - r_remote_ip, r_remote_ip_parsed - in - { r with r_request ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed } - - let update_url ?(full_rewrite = false) url ({r_request} as r) = - let r_request = - let meth = Cohttp.Request.meth r_request - and version = Cohttp.Request.version r_request - and encoding = Cohttp.Request.encoding r_request - and headers = Cohttp.Request.headers r_request in - Cohttp.Request.make ~meth ~version ~encoding ~headers url - and r_sub_path = None in - { r with r_request ; r_sub_path } - - let request {r_request} = - r_request - - let body {r_body} = - r_body - - let map_cohttp_request ~f ({r_request} as r) = - {r with r_request = f r_request} - - let address {r_address} = - r_address - - let host {r_request} = - Uri.host (Cohttp.Request.uri r_request) - - let meth {r_request} = - Cohttp.Request.meth r_request - - let port {r_port} = - r_port - - let ssl _ = - (* FIXME *) - false - - let version {r_request} = - Cohttp.Request.version r_request - - let query {r_request} = - Uri.verbatim_query (Cohttp.Request.uri r_request) - - let path_string {r_request} = - Uri.path (Cohttp.Request.uri r_request) - - let path r = - Ocsigen_lib.Url.split_path (path_string r) - - let sub_path_string = function - | {r_sub_path = Some r_sub_path} -> - r_sub_path - | r -> - path_string r - - let sub_path r = - Ocsigen_lib.Url.split_path (sub_path_string r) - - let header {r_request} id = - let h = Cohttp.Request.headers r_request in - Cohttp.Header.get h (Http_headers.name_to_string id) - - let header_multi {r_request} id = - let h = Cohttp.Request.headers r_request in - Cohttp.Header.get_multi h (Http_headers.name_to_string id) - - let remote_ip {r_remote_ip} = Lazy.force r_remote_ip - - let remote_ip_parsed {r_remote_ip_parsed} = Lazy.force r_remote_ip_parsed - - let forward_ip {r_forward_ip} = r_forward_ip - - let tries {r_tries} = r_tries - - let incr_tries r = r.r_tries <- r.r_tries + 1 - -end - -module Answer = struct - - type t = { - a_response : Cohttp.Response.t ; - a_body : Cohttp_lwt_body.t ; - a_cookies : Ocsigen_cookies.cookieset - } - - let make - ?(cookies = Ocsigen_cookies.empty_cookieset) - ?(body = Cohttp_lwt_body.empty) - ~response () = - { a_response = response ; a_body = body ; a_cookies = cookies } - - let of_cohttp - ?(cookies = Ocsigen_cookies.empty_cookieset) - (a_response, a_body) = - { a_response ; a_body ; a_cookies = cookies } - - let to_cohttp { a_response ; a_body } = a_response, a_body - - let set_status ({ a_response } as a) status = - { a with - a_response = { - a_response with status = (status :> Cohttp.Code.status_code) - } - } - - let add_cookies ({ a_cookies } as a) cookies = - if cookies = Ocsigen_cookies.Cookies.empty then - a - else { - a with - a_cookies = Ocsigen_cookies.add_cookies a_cookies cookies - } - - let header {a_response} id = - let h = Cohttp.Response.headers a_response in - Cohttp.Header.get h (Http_headers.name_to_string id) - - let header_multi {a_response} id = - let h = Cohttp.Response.headers a_response in - Cohttp.Header.get_multi h (Http_headers.name_to_string id) - - let add_header - ({a_response = ({headers} as a_response)} as a) - id v = { - a with - a_response = { - a_response with - headers = - Cohttp.Header.add headers (Http_headers.name_to_string id) v - } - } - - let add_header_multi - ({a_response = ({headers} as a_response)} as a) - id l = - let id = Http_headers.name_to_string id in - let headers = - List.fold_left - (fun headers -> Cohttp.Header.add headers id) - headers - l - in - { a with a_response = { a_response with headers } } - - let remove_header ({a_response} as a) id = - let headers = Cohttp.Response.headers a_response - and id = Http_headers.name_to_string id in - let headers = Cohttp.Header.remove headers id in - { a with a_response = { a_response with headers } } - - let replace_header - ({a_response = ({headers} as a_response)} as a) - id v = { - a with - a_response = { - a_response with - headers = - Cohttp.Header.replace headers (Http_headers.name_to_string id) v - } - } - - let replace_headers ({a_response} as a) l = - let headers = - List.fold_left - (fun headers (id, content) -> - Cohttp.Header.replace headers - (Http_headers.name_to_string id) - content) - (Cohttp.Response.headers a_response) - l - in - { a with a_response = { a_response with headers } } - - let status { a_response = { Cohttp.Response.status } } = - match status with - | `Code _ -> - failwith "FIXME: Cohttp.Code.status_code -> status" - | #Cohttp.Code.status as a -> - a - -end - -type request = Request.t - -type answer = Answer.t - -(** print_cohttp_request Print request for debug - * @param out_ch output for debug - * @param request Cohttp request *) - -let print_cohttp_request fmt request = - let print_list print_data out_ch lst = - let rec aux = function - | [] -> () - | [ x ] -> print_data out_ch x - | x :: r -> print_data out_ch x; aux r - in aux lst - in - - let open Cohttp.Request in - - Format.fprintf fmt "%s [%s/%s]:\n" - (Uri.to_string (Cohttp.Request.uri request)) - (Cohttp.Code.string_of_version request.version) - (Cohttp.Code.string_of_method request.meth) ; - - Cohttp.Header.iter - (fun key values -> - Format.fprintf fmt "\t%s = %a\n" key - (print_list Format.pp_print_string) values) - request.headers - -let waiters = Hashtbl.create 256 - -exception Ocsigen_Is_a_directory of (request -> Neturl.url) - -module Cookie = struct - - let serialize_cookie_raw path exp name c secure = - Format.sprintf "%s=%s; path=/%s%s%s" - name c - (Ocsigen_lib.Url.string_of_url_path ~encode:true path) - (if secure then "; secure" else "") - (match exp with - | Some s -> - "; expires=" ^ - Netdate.format - "%a, %d-%b-%Y %H:%M:%S GMT" - (Netdate.create s) - | None -> - "") - - let serialize_cookies path table headers = - Ocsigen_cookies.CookiesTable.fold - (fun name c h -> - let exp, v, secure = match c with - | Ocsigen_cookies.OUnset -> (Some 0., "", false) - | Ocsigen_cookies.OSet (t, v, secure) -> (t, v, secure) - in - Http_headers.add - Http_headers.set_cookie - (serialize_cookie_raw path exp name v secure) - h) - table - headers - - let serialize cookies headers = - Ocsigen_cookies.Cookies.fold serialize_cookies cookies headers - -end - -let handler ~address ~port ~connector (flow, conn) request body = - - Lwt_log.ign_info_f ~section - "Receiving the request: %s" - (Format.asprintf "%a" print_cohttp_request request) - ; - - let filenames = ref [] in - let edn = Conduit_lwt_unix.endp_of_flow flow in - let rec getsockname = function - | `TCP (ip, port) -> - Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) - | `Unix_domain_socket path -> - Unix.ADDR_UNIX path - | `TLS (_, edn) -> - getsockname edn - | `Unknown err -> - raise (Failure ("resolution failed: " ^ err)) - | `Vchan_direct _ -> - raise (Failure "VChan not supported") - | `Vchan_domain_socket _ -> - raise (Failure "VChan not supported") - in - - let sockaddr = getsockname edn in - let (waiter, wakener) = Lwt.wait () in - Hashtbl.add waiters conn wakener; - - let handle_error exn = - - Lwt_log.ign_debug ~section ~exn "Got exception while handling request." ; - - let headers, ret_code = match exn with - | Ocsigen_http_error (cookies_to_set, code) -> - let headers = - Cookie.serialize cookies_to_set (Cohttp.Header.init ()) - in - Some headers, code - | Ocsigen_stream.Interrupted Ocsigen_stream.Already_read -> - None, `Internal_server_error - | Unix.Unix_error (Unix.EACCES, _, _) -> - None, `Forbidden - | Ext_http_error (code, _, headers) -> - headers, code - | Ocsigen_lib.Ocsigen_Bad_Request -> - None, `Bad_request - | Ocsigen_unsupported_media -> - None, `Unsupported_media_type - | Neturl.Malformed_URL -> - None, `Bad_request - | Ocsigen_lib.Ocsigen_Request_too_long -> - None, `Request_entity_too_large - | exn -> - Lwt_log.ign_error ~section ~exn "Error while handling request." ; - None, `Internal_server_error - in - - Lwt_log.ign_warning_f ~section "Returning error code %i." - (Cohttp.Code.code_of_status (ret_code :> Cohttp.Code.status_code)); - - let body = - match ret_code with - | `Not_found -> "Not Found" - | _ -> Printexc.to_string exn in - - Cohttp_lwt_unix.Server.respond_error - ?headers ~status:(ret_code :> Cohttp.Code.status_code) ~body () - in - - if !filenames <> [] then - List.iter - (fun a -> - try - Unix.unlink a - with Unix.Unix_error _ as exn -> - Lwt_log.ign_warning_f ~section ~exn - "Error while removing file %s" a) - !filenames; - - (* TODO: equivalent of Ocsigen_range *) - (* TODO: handle cookies *) - - let request = - Request.make - ~address ~port ~filenames ~sockaddr ~request ~body ~waiter - () - - in - - Lwt.catch - (fun () -> - connector request >>= fun { Answer.a_response ; a_body } -> - Lwt.return (a_response, a_body)) - (function - | Ocsigen_Is_a_directory fun_request -> - Cohttp_lwt_unix.Server.respond_redirect - ~uri: - (fun_request request - |> Neturl.string_of_url - |> Uri.of_string) - () - | exn -> - handle_error exn) - -let conn_closed (flow, conn) = - try let wakener = Hashtbl.find waiters conn in - Lwt.wakeup wakener (); Hashtbl.remove waiters conn - with Not_found -> () - -let stop, stop_wakener = Lwt.wait () - -let shutdown_server timeout = - let process = match timeout with - | Some f -> (fun () -> Lwt_unix.sleep f) - | None -> (fun () -> Lwt.return ()) - in ignore - begin - (Lwt.pick [process (); stop]) - >>= fun () -> exit 0 - (* XXX: actually, deadlock with Lwt, cf. Lwt#48 *) - end - -let number_of_client () = 0 -let get_number_of_connected = number_of_client - -let service ?ssl ~address ~port ~connector () = - let tls_server_key = match ssl with - | Some (crt, key, Some password) -> - `TLS (`Crt_file_path crt, - `Key_file_path key, - `Password password) - | Some (crt, key, None) -> - `TLS (`Crt_file_path crt, - `Key_file_path key, - `No_password) - | None -> `None - in - (* We create a specific context for Conduit and Cohttp. *) - Conduit_lwt_unix.init - ~src:(Ocsigen_socket.string_of_socket_type address) - ~tls_server_key () >>= fun conduit_ctx -> - Lwt.return (Cohttp_lwt_unix_net.init ~ctx:conduit_ctx ()) >>= fun ctx -> - (* We catch the INET_ADDR of the server *) - let callback = - let address = Ocsigen_socket.to_inet_addr address in - handler ~address ~port ~connector - in - let config = Cohttp_lwt_unix.Server.make ~conn_closed ~callback () in - let mode = - match tls_server_key with - | `None -> `TCP (`Port port) - | `TLS (crt, key, pass) -> - `OpenSSL (crt, key, pass, `Port port) - in - Cohttp_lwt_unix.Server.create ~stop ~ctx ~mode config - >>= fun () -> - Lwt.return (Lwt.wakeup stop_wakener ()) diff --git a/src/server/ocsigen_cohttp_server.mli b/src/server/ocsigen_cohttp_server.mli deleted file mode 100644 index b3b2b524c..000000000 --- a/src/server/ocsigen_cohttp_server.mli +++ /dev/null @@ -1,160 +0,0 @@ -exception Ocsigen_unsupported_media -exception Ocsigen_http_error of - Ocsigen_cookies.cookieset * Cohttp.Code.status - -(** Exception raised by exceptions to describe an HTTP error. It is - possible to pass the code of the error, an optional comment, and - optionally some headers. *) -exception Ext_http_error of - Cohttp.Code.status * string option * Cohttp.Header.t option - -module Connection : sig - exception Lost_connection of exn - exception Aborted - exception Timeout - exception Keepalive_timeout - exception Connection_closed -end - -module Request : sig - - type t - - val make : - ?forward_ip : string list -> - ?sub_path : string -> - address : Unix.inet_addr -> - port : int -> - filenames : string list ref -> - sockaddr : Lwt_unix.sockaddr -> - request : Cohttp.Request.t -> - body : Cohttp_lwt_body.t -> - waiter : unit Lwt.t -> - unit -> - t - - val update : - ?forward_ip : string list -> - ?remote_ip : string -> - ?ssl : bool -> - ?request : Cohttp.Request.t -> - t -> - t - - val update_url : - ?full_rewrite : bool -> - Uri.t -> - t -> - t - - val request : t -> Cohttp.Request.t - - val body : t -> Cohttp_lwt_body.t - - val map_cohttp_request : - f : (Cohttp.Request.t -> Cohttp.Request.t) -> - t -> - t - - val address : t -> Unix.inet_addr - - val host : t -> string option - - val meth : t -> Cohttp.Code.meth - - val port : t -> int - - val ssl : t -> bool - - val version : t -> Cohttp.Code.version - - val query : t -> string option - - val path : t -> string list - - val path_string : t -> string - - val sub_path : t -> string list - - val sub_path_string : t -> string - - val header : t -> Http_headers.name -> string option - - val header_multi : t -> Http_headers.name -> string list - - val remote_ip : t -> string - - val remote_ip_parsed : t -> Ipaddr.t - - val forward_ip : t -> string list - - val tries : t -> int - - val incr_tries : t -> unit - -end - -module Answer : sig - - type t = { - a_response : Cohttp.Response.t ; - a_body : Cohttp_lwt_body.t ; - a_cookies : Ocsigen_cookies.cookieset - } - - val make : - ?cookies : Ocsigen_cookies.cookieset -> - ?body : Cohttp_lwt_body.t -> - response : Cohttp.Response.t -> - unit -> - t - - val of_cohttp : - ?cookies : Ocsigen_cookies.cookieset -> - (Cohttp.Response.t * Cohttp_lwt_body.t) -> - t - - val to_cohttp : t -> Cohttp.Response.t * Cohttp_lwt_body.t - - val status : t -> Cohttp.Code.status - - val set_status : t -> Cohttp.Code.status -> t - - val add_cookies : t -> Ocsigen_cookies.cookieset -> t - - val header : t -> Http_headers.name -> string option - - val header_multi : t -> Http_headers.name -> string list - - val add_header : t -> Http_headers.name -> string -> t - - val add_header_multi : t -> Http_headers.name -> string list -> t - - val replace_header : t -> Http_headers.name -> string -> t - - val replace_headers : t -> (Http_headers.name * string) list -> t - - val remove_header : t -> Http_headers.name -> t - -end - -(** compute a redirection if path links to a directory *) -exception Ocsigen_Is_a_directory of (Request.t -> Neturl.url) - -(** accessor to get number of client (used by eliom monitoring) *) -val number_of_client : unit -> int - -(** alias of [number_of_client] *) -val get_number_of_connected : unit -> int - -(** shutdown main loop of server *) -val shutdown_server : float option -> unit - -(** initialize a main loop of http server *) -val service : - ?ssl:string * string * (bool -> string) option -> - address:Ocsigen_socket.socket_type -> - port:int -> - connector:(Request.t -> Answer.t Lwt.t) -> - unit -> - unit Lwt.t diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index d40d65bdc..27d4f7e20 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -26,11 +26,9 @@ open Lwt.Infix module Url = Ocsigen_lib.Url -module S = Ocsigen_cohttp_server - include Ocsigen_command -exception Ocsigen_http_error = S.Ocsigen_http_error +exception Ocsigen_http_error = Ocsigen_cohttp.Ocsigen_http_error exception Ocsigen_Looping_request (** Xml tag not recognized by an extension (usually not a real error) *) @@ -171,16 +169,16 @@ and follow_symlink = (* Requests *) type request = { - request_info : S.Request.t; + request_info : Ocsigen_request.t; request_config : config_info; } -exception Ocsigen_Is_a_directory = S.Ocsigen_Is_a_directory +exception Ocsigen_Is_a_directory = Ocsigen_cohttp.Ocsigen_Is_a_directory type answer = | Ext_do_nothing (** I don't want to do anything *) - | Ext_found of (unit -> Ocsigen_cohttp_server.Answer.t Lwt.t) + | Ext_found of (unit -> Ocsigen_response.t Lwt.t) (** "OK stop! I will take the page. You can start the following request of the same pipelined connection. Here is the function to generate the page". The extension must return Ext_found as @@ -190,7 +188,7 @@ type answer = handled in different order. (for example revproxy.ml starts its requests to another server before returning Ext_found, to ensure that all requests are done in same order). *) - | Ext_found_stop of (unit -> Ocsigen_cohttp_server.Answer.t Lwt.t) + | Ext_found_stop of (unit -> Ocsigen_response.t Lwt.t) (** Found but do not try next extensions *) | Ext_next of Cohttp.Code.status (** Page not found. Try next extension. The status is usually @@ -234,17 +232,16 @@ type answer = type [parse_fun]), that will return something of type [extension2]. *) | Ext_found_continue_with of - (unit -> (Ocsigen_cohttp_server.Answer.t * request) Lwt.t) + (unit -> (Ocsigen_response.t * request) Lwt.t) (** Same as [Ext_found] but may modify the request. *) - | Ext_found_continue_with' of - (Ocsigen_cohttp_server.Answer.t * request) + | Ext_found_continue_with' of (Ocsigen_response.t * request) (** Same as [Ext_found_continue_with] but does not allow to delay the computation of the page. You should probably not use it, but for output filters. *) and request_state = | Req_not_found of (Cohttp.Code.status * request) - | Req_found of (request * Ocsigen_cohttp_server.Answer.t) + | Req_found of (request * Ocsigen_response.t) and extension2 = Ocsigen_cookies.cookieset -> @@ -271,7 +268,7 @@ let get_hosts () = !hosts let update_path { request_info ; request_config } path = - let r = Ocsigen_cohttp_server.Request.request request_info in + let r = Ocsigen_request.request request_info in let request_info = let request = let meth = Cohttp.Request.meth r @@ -281,7 +278,7 @@ let update_path and uri = Uri.with_path (Cohttp.Request.uri r) path in Cohttp.Request.make ~meth ~version ~encoding ~headers uri in - Ocsigen_cohttp_server.Request.update ~request request_info + Ocsigen_request.update ~request request_info in { request_info ; request_config } @@ -291,7 +288,7 @@ let get_hostname {request_info ; request_config = {default_hostname}} = if Ocsigen_config.get_usedefaulthostname () then default_hostname else - match S.Request.host request_info with + match Ocsigen_request.host request_info with | None -> default_hostname | Some host -> host @@ -305,19 +302,19 @@ let get_port request_config = { default_httpport ; default_httpsport } } = if Ocsigen_config.get_usedefaulthostname () then - if S.Request.ssl request_info then + if Ocsigen_request.ssl request_info then default_httpsport else default_httpport else - Ocsigen_cohttp_server.Request.port request_info + Ocsigen_request.port request_info let http_url_syntax = Hashtbl.find Neturl.common_url_syntax "http" let new_url_of_directory_request request ri = Lwt_log.ign_info ~section "Sending 301 Moved permanently"; let port = get_port request in - let ssl = S.Request.ssl ri in + let ssl = Ocsigen_request.ssl ri in Neturl.make_url ~scheme:(if ssl then "https" else "http") ~host:(get_hostname request) @@ -327,8 +324,8 @@ let new_url_of_directory_request request ri = else Some port) ~path:("" :: (Url.add_end_slash_if_missing - (S.Request.path ri))) - ?query:(S.Request.query ri) + (Ocsigen_request.path ri))) + ?query:(Ocsigen_request.query ri) http_url_syntax (*****************************************************************************) @@ -370,16 +367,16 @@ let make_ext cookies_to_set req_state (genfun : extension) (genfun2 : extension2 in genfun2 Ocsigen_cookies.Cookies.empty - (Req_found (ri, S.Answer.add_cookies r' cookies_to_set)) + (Req_found (ri, Ocsigen_response.add_cookies r' cookies_to_set)) | Ext_found_continue_with r -> r () >>= fun (r', req) -> genfun2 Ocsigen_cookies.Cookies.empty - (Req_found (req, S.Answer.add_cookies r' cookies_to_set)) + (Req_found (req, Ocsigen_response.add_cookies r' cookies_to_set)) | Ext_found_continue_with' (r', req) -> genfun2 Ocsigen_cookies.Cookies.empty - (Req_found (req, S.Answer.add_cookies r' cookies_to_set)) + (Req_found (req, Ocsigen_response.add_cookies r' cookies_to_set)) | Ext_next e -> let ri = match req_state with | Req_found (ri, _) -> ri @@ -460,7 +457,7 @@ let rec default_parse_config in match site_match oldri path - (S.Request.path oldri.request_info) + (Ocsigen_request.path oldri.request_info) with | None -> Lwt_log.ign_info_f ~section @@ -469,7 +466,7 @@ let rec default_parse_config Url.string_of_url_path ~encode:true path) path (fun () oldri -> Url.string_of_url_path ~encode:true - (S.Request.path oldri.request_info)) + (Ocsigen_request.path oldri.request_info)) oldri; Lwt.return (Ext_next e, cookies_to_set) | Some sub_path -> @@ -477,7 +474,7 @@ let rec default_parse_config "site found: url \"%a\" matches \"%a\"." (fun () oldri -> Url.string_of_url_path ~encode:true - (S.Request.path oldri.request_info)) + (Ocsigen_request.path oldri.request_info)) oldri (fun () path -> Url.string_of_url_path ~encode:true path) path; let ri = @@ -871,8 +868,8 @@ let string_of_host (h : virtual_hosts) = let compute_result ?(previous_cookies = Ocsigen_cookies.Cookies.empty) ri = - let host = S.Request.host ri - and port = S.Request.port ri in + let host = Ocsigen_request.host ri + and port = Ocsigen_request.port ri in let string_of_host_option = function | None -> ":"^(string_of_int port) @@ -880,8 +877,8 @@ let compute_result ?(previous_cookies = Ocsigen_cookies.Cookies.empty) ri = in let rec do2 sites cookies_to_set ri = - S.Request.incr_tries ri; - if S.Request.tries ri > Ocsigen_config.get_maxretries () then + Ocsigen_request.incr_tries ri; + if Ocsigen_request.tries ri > Ocsigen_config.get_maxretries () then Lwt.fail Ocsigen_Looping_request else let rec aux_host @@ -905,14 +902,14 @@ let compute_result ?(previous_cookies = Ocsigen_cookies.Cookies.empty) ri = | Ext_found r | Ext_found_stop r -> r () >>= fun r' -> - Lwt.return (S.Answer.add_cookies r' cookies_to_set) + Lwt.return (Ocsigen_response.add_cookies r' cookies_to_set) | Ext_do_nothing -> aux_host ri prev_err cookies_to_set l | Ext_found_continue_with r -> r () >>= fun (r', _) -> - Lwt.return (S.Answer.add_cookies r' cookies_to_set) + Lwt.return (Ocsigen_response.add_cookies r' cookies_to_set) | Ext_found_continue_with' (r, _) -> - Lwt.return (S.Answer.add_cookies r cookies_to_set) + Lwt.return (Ocsigen_response.add_cookies r cookies_to_set) | Ext_next e -> aux_host ri e cookies_to_set l (* try next site *) @@ -1025,18 +1022,18 @@ let (>|!) v f = let find_redirection regexp full_url dest r = if full_url then - S.Request.host r >|! fun host -> + Ocsigen_request.host r >|! fun host -> let path = - let full_path = S.Request.path_string r in - match S.Request.query r with + let full_path = Ocsigen_request.path_string r in + match Ocsigen_request.query r with | None -> full_path | Some g -> full_path ^ "?" ^ g in let path = Url.make_absolute_url - (S.Request.ssl r) + (Ocsigen_request.ssl r) host - (S.Request.port r) + (Ocsigen_request.port r) ("/" ^ path) in Netstring_pcre.string_match regexp path 0 >|! fun _ -> @@ -1044,8 +1041,8 @@ let find_redirection regexp full_url dest r = Netstring_pcre.global_replace regexp dest path else let path = - let sub_path = S.Request.sub_path_string r in - match S.Request.query r with + let sub_path = Ocsigen_request.sub_path_string r in + match Ocsigen_request.query r with | None -> sub_path | Some g -> sub_path ^ "?" ^ g in diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 5e752235a..c821af826 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -120,17 +120,17 @@ and follow_symlink = (*****************************************************) type request = { - request_info: Ocsigen_cohttp_server.Request.t; + request_info: Ocsigen_request.t; request_config: config_info; } exception Ocsigen_Is_a_directory - of (Ocsigen_cohttp_server.Request.t -> Neturl.url) + of (Ocsigen_request.t -> Neturl.url) type answer = | Ext_do_nothing (** I don't want to do anything *) - | Ext_found of (unit -> Ocsigen_cohttp_server.Answer.t Lwt.t) + | Ext_found of (unit -> Ocsigen_response.t Lwt.t) (** "OK stop! I will take the page. You can start the following request of the same pipelined connection. Here is the function to generate the page". The extension must return Ext_found as @@ -140,7 +140,7 @@ type answer = handled in different order. (for example revproxy.ml starts its requests to another server before returning Ext_found, to ensure that all requests are done in same order). *) - | Ext_found_stop of (unit -> Ocsigen_cohttp_server.Answer.t Lwt.t) + | Ext_found_stop of (unit -> Ocsigen_response.t Lwt.t) (** Found but do not try next extensions *) | Ext_next of Cohttp.Code.status (** Page not found. Try next extension. The status is usually @@ -184,17 +184,17 @@ type answer = type [parse_fun]), that will return something of type [extension2]. *) | Ext_found_continue_with of - (unit -> (Ocsigen_cohttp_server.Answer.t * request) Lwt.t) + (unit -> (Ocsigen_response.t * request) Lwt.t) (** Same as [Ext_found] but may modify the request. *) | Ext_found_continue_with' of - (Ocsigen_cohttp_server.Answer.t * request) + (Ocsigen_response.t * request) (** Same as [Ext_found_continue_with] but does not allow to delay the computation of the page. You should probably not use it, but for output filters. *) and request_state = | Req_not_found of (Cohttp.Code.status * request) - | Req_found of (request * Ocsigen_cohttp_server.Answer.t) + | Req_found of (request * Ocsigen_response.t) and extension2 = Ocsigen_cookies.cookieset -> @@ -404,7 +404,7 @@ val get_port : request -> int @param request configuration of the server @param ri request *) val new_url_of_directory_request : - request -> Ocsigen_cohttp_server.Request.t -> Neturl.url + request -> Ocsigen_request.t -> Neturl.url (** {3 User directories} *) @@ -429,7 +429,7 @@ val find_redirection : Netstring_pcre.regexp -> bool -> string -> - Ocsigen_cohttp_server.Request.t -> + Ocsigen_request.t -> string (**/**) @@ -449,8 +449,8 @@ val get_hosts : unit -> (virtual_hosts * config_info * extension2) list extensions according the configuration file. *) val compute_result : ?previous_cookies:Ocsigen_cookies.cookieset -> - Ocsigen_cohttp_server.Request.t -> - Ocsigen_cohttp_server.Answer.t Lwt.t + Ocsigen_request.t -> + Ocsigen_response.t Lwt.t (** Profiling *) val get_number_of_connected : unit -> int diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml new file mode 100644 index 000000000..c39ea218b --- /dev/null +++ b/src/server/ocsigen_request.ml @@ -0,0 +1,147 @@ +type t = { + r_address : Unix.inet_addr ; + r_port : int ; + r_filenames : string list ref ; + r_sockaddr : Lwt_unix.sockaddr ; + r_remote_ip : string Lazy.t ; + r_remote_ip_parsed : Ipaddr.t Lazy.t ; + r_forward_ip : string list ; + r_request : Cohttp.Request.t ; + r_body : Cohttp_lwt_body.t ; + r_sub_path : string option ; + r_waiter : unit Lwt.t ; + mutable r_tries : int +} + +(* FIXME: old ocsigenserver used to store original_full_path. Do we + really need that? *) + +let make + ?(forward_ip = []) ?sub_path + ~address ~port ~filenames ~sockaddr ~request ~body ~waiter () = + let r_remote_ip = + lazy + (Unix.string_of_inet_addr + (Ocsigen_socket.ip_of_sockaddr sockaddr)) + in + let r_remote_ip_parsed = + lazy (Ipaddr.of_string_exn (Lazy.force r_remote_ip)) + in + { + r_address = address ; + r_port = port ; + r_filenames = filenames ; + r_sockaddr = sockaddr ; + r_remote_ip ; + r_remote_ip_parsed ; + r_forward_ip = forward_ip ; + r_request = request ; + r_body = body ; + r_sub_path = sub_path ; + r_waiter = waiter ; + r_tries = 0 + } + +let update + ?forward_ip ?remote_ip ?ssl ?request + ({ + r_request ; + r_forward_ip ; + r_remote_ip ; + r_remote_ip_parsed + } as r) = + (* FIXME : ssl *) + let r_request = + match request with + | Some request -> + request + | None -> + r_request + and r_forward_ip = + match forward_ip with + | Some forward_ip -> + forward_ip + | None -> + r_forward_ip + and r_remote_ip, r_remote_ip_parsed = + match remote_ip with + | Some remote_ip -> + lazy remote_ip, lazy (Ipaddr.of_string_exn remote_ip) + | None -> + r_remote_ip, r_remote_ip_parsed + in + { r with r_request ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed } + +let update_url ?(full_rewrite = false) url ({r_request} as r) = + let r_request = + let meth = Cohttp.Request.meth r_request + and version = Cohttp.Request.version r_request + and encoding = Cohttp.Request.encoding r_request + and headers = Cohttp.Request.headers r_request in + Cohttp.Request.make ~meth ~version ~encoding ~headers url + and r_sub_path = None in + { r with r_request ; r_sub_path } + +let request {r_request} = + r_request + +let body {r_body} = + r_body + +let map_cohttp_request ~f ({r_request} as r) = + {r with r_request = f r_request} + +let address {r_address} = + r_address + +let host {r_request} = + Uri.host (Cohttp.Request.uri r_request) + +let meth {r_request} = + Cohttp.Request.meth r_request + +let port {r_port} = + r_port + +let ssl _ = + (* FIXME *) + false + +let version {r_request} = + Cohttp.Request.version r_request + +let query {r_request} = + Uri.verbatim_query (Cohttp.Request.uri r_request) + +let path_string {r_request} = + Uri.path (Cohttp.Request.uri r_request) + +let path r = + Ocsigen_lib.Url.split_path (path_string r) + +let sub_path_string = function + | {r_sub_path = Some r_sub_path} -> + r_sub_path + | r -> + path_string r + +let sub_path r = + Ocsigen_lib.Url.split_path (sub_path_string r) + +let header {r_request} id = + let h = Cohttp.Request.headers r_request in + Cohttp.Header.get h (Http_headers.name_to_string id) + +let header_multi {r_request} id = + let h = Cohttp.Request.headers r_request in + Cohttp.Header.get_multi h (Http_headers.name_to_string id) + +let remote_ip {r_remote_ip} = Lazy.force r_remote_ip + +let remote_ip_parsed {r_remote_ip_parsed} = Lazy.force r_remote_ip_parsed + +let forward_ip {r_forward_ip} = r_forward_ip + +let tries {r_tries} = r_tries + +let incr_tries r = r.r_tries <- r.r_tries + 1 diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli new file mode 100644 index 000000000..56fc51e73 --- /dev/null +++ b/src/server/ocsigen_request.mli @@ -0,0 +1,73 @@ +type t + +val make : + ?forward_ip : string list -> + ?sub_path : string -> + address : Unix.inet_addr -> + port : int -> + filenames : string list ref -> + sockaddr : Lwt_unix.sockaddr -> + request : Cohttp.Request.t -> + body : Cohttp_lwt_body.t -> + waiter : unit Lwt.t -> + unit -> + t + +val update : + ?forward_ip : string list -> + ?remote_ip : string -> + ?ssl : bool -> + ?request : Cohttp.Request.t -> + t -> + t + +val update_url : + ?full_rewrite : bool -> + Uri.t -> + t -> + t + +val request : t -> Cohttp.Request.t + +val body : t -> Cohttp_lwt_body.t + +val map_cohttp_request : + f : (Cohttp.Request.t -> Cohttp.Request.t) -> + t -> + t + +val address : t -> Unix.inet_addr + +val host : t -> string option + +val meth : t -> Cohttp.Code.meth + +val port : t -> int + +val ssl : t -> bool + +val version : t -> Cohttp.Code.version + +val query : t -> string option + +val path : t -> string list + +val path_string : t -> string + +val sub_path : t -> string list + +val sub_path_string : t -> string + +val header : t -> Http_headers.name -> string option + +val header_multi : t -> Http_headers.name -> string list + +val remote_ip : t -> string + +val remote_ip_parsed : t -> Ipaddr.t + +val forward_ip : t -> string list + +val tries : t -> int + +val incr_tries : t -> unit diff --git a/src/server/ocsigen_response.ml b/src/server/ocsigen_response.ml new file mode 100644 index 000000000..41c5460dd --- /dev/null +++ b/src/server/ocsigen_response.ml @@ -0,0 +1,100 @@ +type t = { + a_response : Cohttp.Response.t ; + a_body : Cohttp_lwt_body.t ; + a_cookies : Ocsigen_cookies.cookieset +} + +let make + ?(cookies = Ocsigen_cookies.empty_cookieset) + ?(body = Cohttp_lwt_body.empty) + ~response () = + { a_response = response ; a_body = body ; a_cookies = cookies } + +let of_cohttp + ?(cookies = Ocsigen_cookies.empty_cookieset) + (a_response, a_body) = + { a_response ; a_body ; a_cookies = cookies } + +let to_cohttp { a_response ; a_body } = a_response, a_body + +let set_status ({ a_response } as a) status = + { a with + a_response = { + a_response with status = (status :> Cohttp.Code.status_code) + } + } + +let add_cookies ({ a_cookies } as a) cookies = + if cookies = Ocsigen_cookies.Cookies.empty then + a + else { + a with + a_cookies = Ocsigen_cookies.add_cookies a_cookies cookies + } + +let header {a_response} id = + let h = Cohttp.Response.headers a_response in + Cohttp.Header.get h (Http_headers.name_to_string id) + +let header_multi {a_response} id = + let h = Cohttp.Response.headers a_response in + Cohttp.Header.get_multi h (Http_headers.name_to_string id) + +let add_header + ({a_response = ({headers} as a_response)} as a) + id v = { + a with + a_response = { + a_response with + headers = + Cohttp.Header.add headers (Http_headers.name_to_string id) v + } +} + +let add_header_multi + ({a_response = ({headers} as a_response)} as a) + id l = + let id = Http_headers.name_to_string id in + let headers = + List.fold_left + (fun headers -> Cohttp.Header.add headers id) + headers + l + in + { a with a_response = { a_response with headers } } + +let remove_header ({a_response} as a) id = + let headers = Cohttp.Response.headers a_response + and id = Http_headers.name_to_string id in + let headers = Cohttp.Header.remove headers id in + { a with a_response = { a_response with headers } } + +let replace_header + ({a_response = ({headers} as a_response)} as a) + id v = { + a with + a_response = { + a_response with + headers = + Cohttp.Header.replace headers (Http_headers.name_to_string id) v + } +} + +let replace_headers ({a_response} as a) l = + let headers = + List.fold_left + (fun headers (id, content) -> + Cohttp.Header.replace headers + (Http_headers.name_to_string id) + content) + (Cohttp.Response.headers a_response) + l + in + { a with a_response = { a_response with headers } } + +let status { a_response = { Cohttp.Response.status } } = + match status with + | `Code _ -> + failwith "FIXME: Cohttp.Code.status_code -> status" + | #Cohttp.Code.status as a -> + a diff --git a/src/server/ocsigen_response.mli b/src/server/ocsigen_response.mli new file mode 100644 index 000000000..c6b60da76 --- /dev/null +++ b/src/server/ocsigen_response.mli @@ -0,0 +1,39 @@ +type t = { + a_response : Cohttp.Response.t ; + a_body : Cohttp_lwt_body.t ; + a_cookies : Ocsigen_cookies.cookieset +} + +val make : + ?cookies : Ocsigen_cookies.cookieset -> + ?body : Cohttp_lwt_body.t -> + response : Cohttp.Response.t -> + unit -> + t + +val of_cohttp : + ?cookies : Ocsigen_cookies.cookieset -> + (Cohttp.Response.t * Cohttp_lwt_body.t) -> + t + +val to_cohttp : t -> Cohttp.Response.t * Cohttp_lwt_body.t + +val status : t -> Cohttp.Code.status + +val set_status : t -> Cohttp.Code.status -> t + +val add_cookies : t -> Ocsigen_cookies.cookieset -> t + +val header : t -> Http_headers.name -> string option + +val header_multi : t -> Http_headers.name -> string list + +val add_header : t -> Http_headers.name -> string -> t + +val add_header_multi : t -> Http_headers.name -> string list -> t + +val replace_header : t -> Http_headers.name -> string -> t + +val replace_headers : t -> (Http_headers.name * string) list -> t + +val remove_header : t -> Http_headers.name -> t diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index 2cd5665f6..59d212dd5 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -126,9 +126,11 @@ let _ = Lwt.return () | ["reload"] -> reload (); Lwt.return () | ["reload"; file] -> reload ~file (); Lwt.return () - | ["shutdown"] -> Ocsigen_cohttp_server.shutdown_server None; Lwt.return () + | ["shutdown"] -> + Ocsigen_cohttp.shutdown None; + Lwt.return () | ["shutdown"; f] -> - Ocsigen_cohttp_server.shutdown_server (Some (float_of_string f)); + Ocsigen_cohttp.shutdown (Some (float_of_string f)); Lwt.return () | ["gc"] -> Gc.compact (); @@ -364,40 +366,13 @@ let start_server () = try Lwt_log.ign_error ~section ~exn:e "Uncaught Exception" ); - (* Lwt.wakeup wait_end_init_awakener (); *) - (* - let config = { - Server.callback = - Ocsigen_cohttp_server.service_cohttp - ~address - ~port - ~extensions_connector; - Server.conn_closed = (fun _ _ () -> ()) - } in - - let process = [ Server.create ~address ~port config ] in - let process = match ssl with - | Some (address, port) -> - let config = { - Server.callback = - Ocsigen_brouette.service_cohttp - ~address - ~port - ~extensions_connector; - Server.conn_closed = (fun _ _ () -> ()) - - } in Server.create ~address ~port config :: process - | None -> process - in Lwt.join process - *) - Lwt.join - ((List.map (fun (address, port) -> Ocsigen_cohttp_server.service + ((List.map (fun (address, port) -> Ocsigen_cohttp.service ~address ~port ~connector:extensions_connector ()) connection) @ - (List.map (fun (address, port, (crt, key)) -> Ocsigen_cohttp_server.service + (List.map (fun (address, port, (crt, key)) -> Ocsigen_cohttp.service ~ssl:(crt, key, Some (ask_for_passwd [(address, port)])) ~address ~port From 3f2890f52b09af72debf5f9050593502e9f9b48d Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 10 Feb 2017 13:49:51 +0100 Subject: [PATCH 024/111] Re-add multipart code (now Ocsigen_multipart) --- src/Makefile.filelist | 9 +- src/server/.depend | 27 +- src/server/Makefile | 16 +- src/server/ocsigen_extensions.ml | 1 + src/server/ocsigen_extensions.mli | 2 +- src/server/ocsigen_multipart.ml | 422 ++++++++++++++++++++++++++++++ src/server/ocsigen_multipart.mli | 22 ++ 7 files changed, 476 insertions(+), 23 deletions(-) create mode 100644 src/server/ocsigen_multipart.ml create mode 100644 src/server/ocsigen_multipart.mli diff --git a/src/Makefile.filelist b/src/Makefile.filelist index fc81a2d0d..ae25d1f6c 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -14,6 +14,8 @@ INTF_BASE := baselib/ocsigen_cache.cmi \ http/ocsigen_charset_mime.cmi \ http/ocsigen_cookies.cmi \ \ + server/ocsigen_request.cmi \ + server/ocsigen_response.cmi \ server/ocsigen_extensions.cmi \ server/ocsigen_parseconfig.cmi \ server/ocsigen_local_files.cmi \ @@ -48,10 +50,9 @@ endif PLUGINS_BIN := -PLUGINS_INTF := extensions/authbasic.cmi extensions/accesscontrol.cmi - # extensions/ocsigen_comet.cmi \ - # extensions/accesscontrol.cmi \ - # extensions/ocsipersist.cmi \ +PLUGINS_INTF := extensions/authbasic.cmi extensions/accesscontrol.cmi \ + extensions/ocsipersist.cmi + # extensions/ocsigen_comet.cmi PLUGINS_IMPL := extensions/accesscontrol.cmo extensions/authbasic.cmo \ extensions/cors.cmo extensions/outputfilter.cmo \ diff --git a/src/server/.depend b/src/server/.depend index f0b04014f..8f8ccaedb 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -10,15 +10,15 @@ ocsigen_command.cmo : ../baselib/ocsigen_messages.cmi ocsigen_command.cmi ocsigen_command.cmx : ../baselib/ocsigen_messages.cmx ocsigen_command.cmi ocsigen_command.cmi : ocsigen_extensions.cmo : ocsigen_response.cmi ocsigen_request.cmi \ - ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_cookies.cmi ../baselib/ocsigen_config.cmi \ - ocsigen_command.cmi ../http/ocsigen_charset_mime.cmi \ - ocsigen_extensions.cmi + ocsigen_multipart.cmi ../baselib/ocsigen_loader.cmi \ + ../baselib/ocsigen_lib.cmi ../http/ocsigen_cookies.cmi \ + ../baselib/ocsigen_config.cmi ocsigen_command.cmi ocsigen_cohttp.cmi \ + ../http/ocsigen_charset_mime.cmi ocsigen_extensions.cmi ocsigen_extensions.cmx : ocsigen_response.cmx ocsigen_request.cmx \ - ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_cookies.cmx ../baselib/ocsigen_config.cmx \ - ocsigen_command.cmx ../http/ocsigen_charset_mime.cmx \ - ocsigen_extensions.cmi + ocsigen_multipart.cmx ../baselib/ocsigen_loader.cmx \ + ../baselib/ocsigen_lib.cmx ../http/ocsigen_cookies.cmx \ + ../baselib/ocsigen_config.cmx ocsigen_command.cmx ocsigen_cohttp.cmx \ + ../http/ocsigen_charset_mime.cmx ocsigen_extensions.cmi ocsigen_extensions.cmi : ocsigen_response.cmi ocsigen_request.cmi \ ../baselib/ocsigen_lib.cmi ../http/ocsigen_cookies.cmi \ ocsigen_command.cmi ../http/ocsigen_charset_mime.cmi @@ -27,6 +27,13 @@ ocsigen_local_files.cmo : ocsigen_extensions.cmi \ ocsigen_local_files.cmx : ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ocsigen_local_files.cmi ocsigen_local_files.cmi : ocsigen_extensions.cmi +ocsigen_multipart.cmo : ../baselib/ocsigen_stream.cmi \ + ../baselib/ocsigen_lib.cmi ../baselib/ocsigen_config.cmi \ + ocsigen_multipart.cmi +ocsigen_multipart.cmx : ../baselib/ocsigen_stream.cmx \ + ../baselib/ocsigen_lib.cmx ../baselib/ocsigen_config.cmx \ + ocsigen_multipart.cmi +ocsigen_multipart.cmi : ../baselib/ocsigen_stream.cmi ocsigen_parseconfig.cmo : ocsigen_socket.cmi ../baselib/ocsigen_loader.cmi \ ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi ../http/ocsigen_charset_mime.cmi \ @@ -50,13 +57,13 @@ ocsigen_server.cmo : ocsigen_socket.cmi ocsigen_parseconfig.cmi \ ../baselib/ocsigen_messages.cmi ../baselib/ocsigen_loader.cmi \ ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi ../baselib/ocsigen_commandline.cmo \ - ocsigen_command.cmi ../baselib/ocsigen_cache.cmi \ + ocsigen_command.cmi ocsigen_cohttp.cmi ../baselib/ocsigen_cache.cmi \ ../baselib/dynlink_wrapper.cmo ocsigen_server.cmi ocsigen_server.cmx : ocsigen_socket.cmx ocsigen_parseconfig.cmx \ ../baselib/ocsigen_messages.cmx ../baselib/ocsigen_loader.cmx \ ../baselib/ocsigen_lib.cmx ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ../baselib/ocsigen_commandline.cmx \ - ocsigen_command.cmx ../baselib/ocsigen_cache.cmx \ + ocsigen_command.cmx ocsigen_cohttp.cmx ../baselib/ocsigen_cache.cmx \ ../baselib/dynlink_wrapper.cmx ocsigen_server.cmi ocsigen_server.cmi : ocsigen_socket.cmo : ../baselib/ocsigen_lib_base.cmi ocsigen_socket.cmi diff --git a/src/server/Makefile b/src/server/Makefile index 69d4bd75d..e3aaead6c 100644 --- a/src/server/Makefile +++ b/src/server/Makefile @@ -15,14 +15,14 @@ all: byte opt FILES := ocsigen_socket.ml \ ocsigen_command.ml \ - ocsigen_request.ml \ - ocsigen_response.ml \ - ocsigen_cohttp.ml \ - ocsigen_extensions.ml \ - ocsigen_parseconfig.ml \ - ocsigen_local_files.ml \ - ocsigen_server.ml \ - + ocsigen_request.ml \ + ocsigen_response.ml \ + ocsigen_cohttp.ml \ + ocsigen_extensions.ml \ + ocsigen_multipart.ml \ + ocsigen_parseconfig.ml \ + ocsigen_local_files.ml \ + ocsigen_server.ml byte:: ${PROJECTNAME}.cma opt:: ${PROJECTNAME}.cmxa diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 27d4f7e20..9b156b39b 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -40,6 +40,7 @@ exception Error_in_config_file of string (** Option incorrect in a userconf file *) exception Error_in_user_config_file of string +type file_info = Ocsigen_multipart.file_info let badconfig fmt = Printf.ksprintf (fun s -> raise (Error_in_config_file s)) fmt diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index c821af826..ecbd948a7 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -37,7 +37,7 @@ exception Error_in_config_file of string (** Option incorrect in a userconf file *) exception Error_in_user_config_file of string - +type file_info = Ocsigen_multipart.file_info val badconfig : ('a, unit, string, 'b) format4 -> 'a (** Convenient function for raising Error_in_config_file exceptions with diff --git a/src/server/ocsigen_multipart.ml b/src/server/ocsigen_multipart.ml new file mode 100644 index 000000000..469058170 --- /dev/null +++ b/src/server/ocsigen_multipart.ml @@ -0,0 +1,422 @@ +(* This code is inspired by mimestring.ml from OcamlNet *) +(* Copyright Gerd Stolpmann, Patrick Doane *) +(* Modified for Ocsigen/Lwt by Nataliya Guts and Vincent Balat *) + +(*VVV Check wether we should support int64 for large files? *) + +open Lwt.Infix +module S = Netstring_pcre + +let section = Lwt_log.Section.make "ocsigen:server:multipart" + +exception Multipart_error of string + +exception Ocsigen_upload_forbidden + +let cr_or_lf_re = S.regexp "[\013\n]" + +let header_stripped_re = + S.regexp + "([^ \t\r\n:]+):[ \t]*((.*[^ \t\r\n])?([ \t\r]*\n[ \t](.*[^ \t\r\n])?)*)[ \t\r]*\n" + +let header_unstripped_re = + S.regexp "([^ \t\r\n:]+):([ \t]*.*\n([ \t].*\n)*)" +(* This much simpler expression returns the name and the unstripped + value. *) + +let empty_line_re = S.regexp "\013?\n";; + +let end_of_header_re = S.regexp "\n\013?\n";; + +let scan_header + ?(downcase = true) + ?(unfold = true) + ?(strip = false) + parstr ~start_pos ~end_pos = + let header_re = + if unfold || strip then + header_stripped_re + else + header_unstripped_re + in + let rec parse_header i l = + match S.string_match header_re parstr i with + | Some r -> + let i' = S.match_end r in + if i' > end_pos then raise (Multipart_error "Mimestring.scan_header"); + let name = + if downcase then + String.lowercase (S.matched_group r 1 parstr) + else + S.matched_group r 1 parstr + in + let value_with_crlf = S.matched_group r 2 parstr in + let value = + if unfold then + S.global_replace cr_or_lf_re "" value_with_crlf + else + value_with_crlf + in + parse_header i' ((name, value) :: l) + | None -> + (* The header must end with an empty line *) + (match S.string_match empty_line_re parstr i with + | Some r' -> + List.rev l, S.match_end r' + | None -> + raise (Multipart_error "Mimestring.scan_header")) + in + parse_header start_pos [] + +let read_header ?downcase ?unfold ?strip s = + let rec find_end_of_header s = + Lwt.catch + (fun () -> + let b = Ocsigen_stream.current_buffer s in + (* Maybe the header is empty. In this case, there is an empty + line right at the beginning *) + match S.string_match empty_line_re b 0 with + | Some r -> + Lwt.return (s, (S.match_end r)) + | None -> + (* Search for an empty line *) + Lwt.return + (s, (S.match_end (snd (S.search_forward end_of_header_re b 0)))) + ) + (function + | Not_found -> + Ocsigen_stream.enlarge_stream s >>= + (function + | Ocsigen_stream.Finished _ -> + Lwt.fail Ocsigen_stream.Stream_too_small + | Ocsigen_stream.Cont (stri, _) as s -> + find_end_of_header s) + | e -> Lwt.fail e) + in + find_end_of_header s >>= fun (s, end_pos) -> + let b = Ocsigen_stream.current_buffer s in + let h, _ = scan_header ?downcase ?unfold ?strip b ~start_pos:0 ~end_pos in + Ocsigen_stream.skip s (Int64.of_int end_pos) >>= fun s -> + Lwt.return (s, h) + +let lf_re = S.regexp "[\n]" + +let rec search_window s re start = + try + Lwt.return + (s, snd (S.search_forward re (Ocsigen_stream.current_buffer s) start)) + with Not_found -> + Ocsigen_stream.enlarge_stream s >>= function + | Ocsigen_stream.Finished _ -> + Lwt.fail Ocsigen_stream.Stream_too_small + | Ocsigen_stream.Cont (stri, _) as s -> + search_window s re start + +let search_end_of_line s k = + (* Search LF beginning at position k *) + Lwt.catch + (fun () -> + search_window s lf_re k >>= fun (s, x) -> + Lwt.return (s, (S.match_end x))) + (function + | Not_found -> + Lwt.fail + (Multipart_error + "read_multipart_body: MIME boundary without line end") + | e -> + Lwt.fail e) + +let search_first_boundary ~boundary s = + (* Search boundary per regexp; return the position of the + character immediately following the boundary (on the same + line), or raise Not_found. *) + let re = S.regexp ("\n--" ^ S.quote boundary) in + search_window s re 0 >>= fun (s, x) -> + Lwt.return (s, (S.match_end x)) + +let check_beginning_is_boundary ~boundary s = + let del = "--" ^ boundary in + let ldel = String.length del in + Ocsigen_stream.stream_want s (ldel + 2) >>= function + | Ocsigen_stream.Finished _ as str2 -> + Lwt.return (str2, false, false) + | Ocsigen_stream.Cont (ss, f) as str2 -> + let long = String.length ss in + let isdelim = (long >= ldel) && (String.sub ss 0 ldel = del) in + let islast = isdelim && (String.sub ss ldel 2 = "--") in + Lwt.return (str2, isdelim, islast) + +let rec parse_parts ~boundary ~decode_part s uses_crlf = + (* PRE: [s] is at the beginning of the next part. [uses_crlf] must + be true if CRLF is used as EOL sequence, and false if only LF is + used as EOL sequence. *) + let delimiter = (if uses_crlf then "\r" else "" ) ^ "\n--" ^ boundary in + Ocsigen_stream.substream delimiter s >>= fun a -> + decode_part a >>= fun (y, s) -> + (* Now the position of [s] is at the beginning of the delimiter. + Check if there is a "--" after the delimiter (==> last part) *) + let l_delimiter = String.length delimiter in + Ocsigen_stream.next s >>= fun s -> + Ocsigen_stream.stream_want s (l_delimiter+2) >>= fun s -> + let last_part = match s with + | Ocsigen_stream.Finished _ -> + false + | Ocsigen_stream.Cont (ss, f) -> + let long = String.length ss in + long >= l_delimiter + 2 && + ss.[l_delimiter] = '-' && + ss.[l_delimiter + 1] = '-' + in + if last_part then + Lwt.return [y] + else + search_end_of_line s 2 >>= fun (s, k) -> + (* [k]: Beginning of next part *) + Ocsigen_stream.skip s (Int64.of_int k) >>= fun s -> + parse_parts ~boundary ~decode_part s uses_crlf >>= fun l -> + Lwt.return (y :: l) + +let read_multipart_body ~boundary ~decode_part s = + (* Check whether s directly begins with a boundary *) + check_beginning_is_boundary ~boundary s >>= fun (s, b, islast) -> + if islast then + Lwt.return [] + else if b then + (* Move to the beginning of the next line *) + search_end_of_line s 0 >>= fun (s, k_eol) -> + let uses_crlf = (Ocsigen_stream.current_buffer s).[k_eol-2] = '\r' in + Ocsigen_stream.skip s (Int64.of_int k_eol) >>= fun s -> + (* Begin with first part: *) + parse_parts ~boundary ~decode_part s uses_crlf + else + (* Look for the first boundary *) + Lwt.catch + (fun () -> + search_first_boundary ~boundary s >>= fun (s, k_eob) -> + search_end_of_line s k_eob >>= fun (s, k_eol) -> + let uses_crlf = (Ocsigen_stream.current_buffer s).[k_eol-2] = '\r' in + (* Printf.printf "k_eol=%d\n" k_eol; *) + Ocsigen_stream.skip s (Int64.of_int k_eol) >>= fun s -> + (* Begin with first part: *) + parse_parts ~boundary ~decode_part s uses_crlf) + (function + | Not_found -> + (* No boundary at all, empty body *) + Lwt.return [] + | e -> + Lwt.fail e) + +let empty_stream = + Ocsigen_stream.get + (Ocsigen_stream.make (fun () -> Ocsigen_stream.empty None)) + +let decode_part ~max_size ~create ~add ~stop stream = + read_header stream >>= fun (s, header) -> + let p = create header in + let rec while_stream size = function + | Ocsigen_stream.Finished None -> + Lwt.return (size, empty_stream) + | Ocsigen_stream.Finished (Some ss) -> + Lwt.return (size, ss) + | Ocsigen_stream.Cont (stri, f) -> + let long = String.length stri in + let size2 = Int64.add size (Int64.of_int long) in + if + match max_size with + | None -> + false + | Some m -> + Int64.compare size2 m > 0 + then + Lwt.fail Ocsigen_lib.Ocsigen_Request_too_long + else if stri = "" then + Ocsigen_stream.next f >>= while_stream size + else + add p stri >>= fun () -> + Ocsigen_stream.next f >>= + while_stream size2 + in + Lwt.catch + (fun () -> + while_stream Int64.zero s >>= fun (size, s) -> + stop size p >>= fun r -> + Lwt.return (r, s)) + (fun error -> + stop Int64.zero p >>= fun _ -> + Lwt.fail error) + +let scan_multipart_body_from_stream + ?max_size ~boundary ~create ~add ~stop + s = + let decode_part = decode_part ~max_size ~create ~add ~stop in + Lwt.catch + (fun () -> + (* read the multipart body: *) + Ocsigen_stream.next s >>= fun s -> + read_multipart_body ~boundary ~decode_part s >>= fun _ -> + Lwt.return ()) + (function + | Ocsigen_stream.Stream_too_small -> + Lwt.fail Ocsigen_lib.Ocsigen_Bad_Request + | e -> + Lwt.fail e) + +let get_boundary ctparams = List.assoc "boundary" ctparams + +let counter = + let c = ref (Random.int 1000000) in + fun () -> c := !c + 1 ; !c + +let field field content_disp = + let (_, res) = + Netstring_pcre.search_forward + (Netstring_pcre.regexp (field^"=.([^\"]*).;?")) content_disp 0 + in + Netstring_pcre.matched_group res 1 content_disp + +let parse_content_type = function + | None -> + None + | Some s -> + match Ocsigen_lib.String.split ';' s with + | [] -> None + | a :: l -> + try + let typ, subtype = Ocsigen_lib.String.sep '/' a in + let params = + try + List.map (Ocsigen_lib.String.sep '=') l + with Not_found -> + [] + in + (*VVV If syntax error, we return no parameter at all *) + Some ((typ, subtype), params) + (*VVV If syntax error in type, we return None *) + with Not_found -> + None + +type file_info = { + tmp_filename : string ; + filesize : int64 ; + raw_original_filename : string ; + file_content_type : ((string * string) * (string * string) list) option +} + +let post_params_form_urlencoded body_gen _ = + Lwt.catch + (fun () -> + let body = Ocsigen_stream.get body_gen in + (* BY, adapted from a previous comment. Should this stream be + consumed in case of error? *) + Ocsigen_stream.string_of_stream + (Ocsigen_config.get_maxrequestbodysizeinmemory ()) + body >>= fun r -> + let r = Ocsigen_lib.Url.fixup_url_string r in + Lwt.return ((Netencoding.Url.dest_url_encoded_parameters r), [])) + (function + | Ocsigen_stream.String_too_large -> + Lwt.fail Ocsigen_lib.Input_is_too_large + | e -> Lwt.fail e) + +let post_params_multipart_form_data body_gen ctparams + (upload_dir, max_size) = + (* Same question here, should this stream be consumed after an + error? *) + let body = Ocsigen_stream.get body_gen + and boundary = get_boundary ctparams + and params = ref [] + and files = ref [] + and filenames = ref [] in + + let rec add p s = + match p with + | _, `No_file to_buf -> + Buffer.add_string to_buf s; + Lwt.return () + | _, `Some_file (_, _, wh, _) -> + let len = String.length s in + let r = Unix.write wh s 0 len in + if r < len then + (*XXXX Inefficient if s is long *) + add p (String.sub s r (len - r)) + else + Lwt_unix.yield () + in + + let create hs = + let content_type = + try + let ct = List.assoc "content-type" hs in + parse_content_type (Some ct) + with _ -> + None + in + let cd = List.assoc "content-disposition" hs in + let p_name = field "name" cd in + try + let store = field "filename" cd in + match upload_dir with + | Some dname -> + let fname = + Printf.sprintf "%s/%f-%d" + dname + (Unix.gettimeofday ()) + (counter ()) + in + let fd = + Unix.openfile fname + [Unix.O_CREAT; Unix.O_TRUNC; Unix.O_WRONLY; Unix.O_NONBLOCK] + 0o666 + in + Lwt_log.ign_info ~section ("Upload file opened: " ^ fname); + filenames := fname :: !filenames; + p_name, `Some_file (fname, store, fd, content_type) + | None -> + raise Ocsigen_upload_forbidden + with Not_found -> + p_name, `No_file (Buffer.create 1024) + + and stop filesize = function + | p_name, `No_file to_buf -> + params := !params @ [p_name, Buffer.contents to_buf]; + Lwt.return () + (* in the end ? *) + | p_name, + `Some_file + (tmp_filename, raw_original_filename, wh, file_content_type) -> + let file_info = { + tmp_filename ; + filesize ; + raw_original_filename ; + file_content_type ; + } in + files := !files @ [p_name, file_info]; + Unix.close wh; + Lwt.return () + in + + scan_multipart_body_from_stream + ?max_size ~boundary ~create ~add ~stop body >>= fun () -> + (*VVV Does scan_multipart_body_from_stream read until the end or + only what it needs? If we do not consume here, the following + request will be read only when this one is finished ... *) + Ocsigen_stream.consume body_gen >>= fun () -> + Lwt.return (!params, !files) + +let post_params ?content_type body_gen = + let (ct, cst), ctparams = + match content_type with + (* RFC 2616, sect. 7.2.1: if the media type remains unknown, the + recipient SHOULD treat it as type "application/octet-stream" *) + | None -> + ("application", "octet-stream"), [] + | Some content_type -> + content_type + in + match String.lowercase ct, String.lowercase cst with + | "application", "x-www-form-urlencoded" -> + Some (post_params_form_urlencoded body_gen) + | "multipart", "form-data" -> + Some (post_params_multipart_form_data body_gen ctparams) + | _ -> + None diff --git a/src/server/ocsigen_multipart.mli b/src/server/ocsigen_multipart.mli new file mode 100644 index 000000000..dc064128f --- /dev/null +++ b/src/server/ocsigen_multipart.mli @@ -0,0 +1,22 @@ +val scan_multipart_body_from_stream: + ?max_size : Int64.t -> + boundary : string -> + create : ((string * string) list -> 'a) -> + add : ('a -> string -> unit Lwt.t) -> + stop : (int64 -> 'a -> 'b Lwt.t) -> + string Ocsigen_stream.stream -> + unit Lwt.t + +type file_info = { + tmp_filename : string ; + filesize : int64 ; + raw_original_filename : string ; + file_content_type : ((string * string) * (string * string) list) option +} + +val post_params : + ?content_type : ((string * string) * (string * string) list) -> + string Ocsigen_stream.t -> + (string option * + Int64.t option -> + ((string * string) list * (string * file_info) list) Lwt.t) option From 131acf0b62f8a059298231afe31274e6044afc4e Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 10 Feb 2017 15:57:00 +0100 Subject: [PATCH 025/111] Implement interfaces needed by Eliom (WIP) --- src/http/ocsigen_cookies.ml | 11 +++ src/http/ocsigen_cookies.mli | 5 +- src/server/.depend | 17 ++-- src/server/Makefile | 2 +- src/server/ocsigen_multipart.ml | 51 ++++++------ src/server/ocsigen_multipart.mli | 14 ++-- src/server/ocsigen_request.ml | 137 ++++++++++++++++++++++++++++--- src/server/ocsigen_request.mli | 44 ++++++++++ src/server/ocsigen_response.ml | 24 +++++- src/server/ocsigen_response.mli | 11 ++- 10 files changed, 263 insertions(+), 53 deletions(-) diff --git a/src/http/ocsigen_cookies.ml b/src/http/ocsigen_cookies.ml index 7d17fc62d..1bdc09051 100644 --- a/src/http/ocsigen_cookies.ml +++ b/src/http/ocsigen_cookies.ml @@ -66,3 +66,14 @@ let add_cookies newcookies oldcookies = newcookies oldcookies +let parse_cookies s = + let splitted = Ocsigen_lib.String.split ';' s in + try + List.fold_left + (fun beg a -> + let (n, v) = Ocsigen_lib.String.sep '=' a in + CookiesTable.add n v beg) + CookiesTable.empty + splitted + with _ -> + CookiesTable.empty diff --git a/src/http/ocsigen_cookies.mli b/src/http/ocsigen_cookies.mli index e4a8d3395..05e050855 100644 --- a/src/http/ocsigen_cookies.mli +++ b/src/http/ocsigen_cookies.mli @@ -41,7 +41,7 @@ type cookieset = cookie CookiesTable.t Cookies.t val empty_cookieset : 'a CookiesTable.t Cookies.t -(** [add_cookie path c v cookie_table] +(** [add_cookie path c v cookie_table] adds the cookie [c] to the table [cookie_table]. If the cookie is already bound, the previous binding disappear. *) val add_cookie : Url.path -> string -> 'a -> @@ -52,7 +52,7 @@ val add_cookie : Url.path -> string -> 'a -> from the table [cookie_table]. Warning: it is not equivalent to [add_cookie ... OUnset ...]). *) -val remove_cookie : Url.path -> string -> +val remove_cookie : Url.path -> string -> 'a CookiesTable.t Cookies.t -> 'a CookiesTable.t Cookies.t @@ -64,3 +64,4 @@ val add_cookies : cookie CookiesTable.t Cookies.t -> cookie CookiesTable.t Cookies.t +val parse_cookies : string -> string CookiesTable.t diff --git a/src/server/.depend b/src/server/.depend index 8f8ccaedb..9f3930655 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -20,8 +20,9 @@ ocsigen_extensions.cmx : ocsigen_response.cmx ocsigen_request.cmx \ ../baselib/ocsigen_config.cmx ocsigen_command.cmx ocsigen_cohttp.cmx \ ../http/ocsigen_charset_mime.cmx ocsigen_extensions.cmi ocsigen_extensions.cmi : ocsigen_response.cmi ocsigen_request.cmi \ - ../baselib/ocsigen_lib.cmi ../http/ocsigen_cookies.cmi \ - ocsigen_command.cmi ../http/ocsigen_charset_mime.cmi + ocsigen_multipart.cmi ../baselib/ocsigen_lib.cmi \ + ../http/ocsigen_cookies.cmi ocsigen_command.cmi \ + ../http/ocsigen_charset_mime.cmi ocsigen_local_files.cmo : ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi ocsigen_local_files.cmi ocsigen_local_files.cmx : ocsigen_extensions.cmx \ @@ -43,11 +44,13 @@ ocsigen_parseconfig.cmx : ocsigen_socket.cmx ../baselib/ocsigen_loader.cmx \ ../baselib/ocsigen_config.cmx ../http/ocsigen_charset_mime.cmx \ ocsigen_parseconfig.cmi ocsigen_parseconfig.cmi : ocsigen_socket.cmi ocsigen_extensions.cmi -ocsigen_request.cmo : ocsigen_socket.cmi ../baselib/ocsigen_lib.cmi \ - ../http/http_headers.cmi ocsigen_request.cmi -ocsigen_request.cmx : ocsigen_socket.cmx ../baselib/ocsigen_lib.cmx \ - ../http/http_headers.cmx ocsigen_request.cmi -ocsigen_request.cmi : ../http/http_headers.cmi +ocsigen_request.cmo : ../baselib/polytables.cmi \ + ../baselib/ocsigen_stream.cmi ocsigen_socket.cmi ocsigen_multipart.cmi \ + ../baselib/ocsigen_lib.cmi ../http/http_headers.cmi ocsigen_request.cmi +ocsigen_request.cmx : ../baselib/polytables.cmx \ + ../baselib/ocsigen_stream.cmx ocsigen_socket.cmx ocsigen_multipart.cmx \ + ../baselib/ocsigen_lib.cmx ../http/http_headers.cmx ocsigen_request.cmi +ocsigen_request.cmi : ../baselib/polytables.cmi ../http/http_headers.cmi ocsigen_response.cmo : ../http/ocsigen_cookies.cmi ../http/http_headers.cmi \ ocsigen_response.cmi ocsigen_response.cmx : ../http/ocsigen_cookies.cmx ../http/http_headers.cmx \ diff --git a/src/server/Makefile b/src/server/Makefile index e3aaead6c..c2ea26342 100644 --- a/src/server/Makefile +++ b/src/server/Makefile @@ -15,11 +15,11 @@ all: byte opt FILES := ocsigen_socket.ml \ ocsigen_command.ml \ + ocsigen_multipart.ml \ ocsigen_request.ml \ ocsigen_response.ml \ ocsigen_cohttp.ml \ ocsigen_extensions.ml \ - ocsigen_multipart.ml \ ocsigen_parseconfig.ml \ ocsigen_local_files.ml \ ocsigen_server.ml diff --git a/src/server/ocsigen_multipart.ml b/src/server/ocsigen_multipart.ml index 469058170..103131b82 100644 --- a/src/server/ocsigen_multipart.ml +++ b/src/server/ocsigen_multipart.ml @@ -274,26 +274,26 @@ let field field content_disp = in Netstring_pcre.matched_group res 1 content_disp -let parse_content_type = function - | None -> +let parse_content_type s = + match Ocsigen_lib.String.split ';' s with + | [] -> None - | Some s -> - match Ocsigen_lib.String.split ';' s with - | [] -> None - | a :: l -> - try - let typ, subtype = Ocsigen_lib.String.sep '/' a in - let params = - try - List.map (Ocsigen_lib.String.sep '=') l - with Not_found -> - [] - in - (*VVV If syntax error, we return no parameter at all *) - Some ((typ, subtype), params) - (*VVV If syntax error in type, we return None *) - with Not_found -> - None + | a :: l -> + try + let typ, subtype = Ocsigen_lib.String.sep '/' a in + let params = + try + List.map (Ocsigen_lib.String.sep '=') l + with Not_found -> + [] + in + (*VVV If syntax error, we return no parameter at all *) + Some ((typ, subtype), params) + (*VVV If syntax error in type, we return None *) + with Not_found -> + None + +type content_type = (string * string) * (string * string) list type file_info = { tmp_filename : string ; @@ -302,7 +302,9 @@ type file_info = { file_content_type : ((string * string) * (string * string) list) option } -let post_params_form_urlencoded body_gen _ = +type post_data = (string * string) list * (string * file_info) list + +let post_params_form_urlencoded body_gen _ _ = Lwt.catch (fun () -> let body = Ocsigen_stream.get body_gen in @@ -318,8 +320,7 @@ let post_params_form_urlencoded body_gen _ = Lwt.fail Ocsigen_lib.Input_is_too_large | e -> Lwt.fail e) -let post_params_multipart_form_data body_gen ctparams - (upload_dir, max_size) = +let post_params_multipart_form_data body_gen ctparams upload_dir max_size = (* Same question here, should this stream be consumed after an error? *) let body = Ocsigen_stream.get body_gen @@ -347,7 +348,7 @@ let post_params_multipart_form_data body_gen ctparams let content_type = try let ct = List.assoc "content-type" hs in - parse_content_type (Some ct) + parse_content_type ct with _ -> None in @@ -403,7 +404,9 @@ let post_params_multipart_form_data body_gen ctparams Ocsigen_stream.consume body_gen >>= fun () -> Lwt.return (!params, !files) -let post_params ?content_type body_gen = +let post_params + ?content_type + body_gen = let (ct, cst), ctparams = match content_type with (* RFC 2616, sect. 7.2.1: if the media type remains unknown, the diff --git a/src/server/ocsigen_multipart.mli b/src/server/ocsigen_multipart.mli index dc064128f..d41647f55 100644 --- a/src/server/ocsigen_multipart.mli +++ b/src/server/ocsigen_multipart.mli @@ -7,16 +7,20 @@ val scan_multipart_body_from_stream: string Ocsigen_stream.stream -> unit Lwt.t +type content_type = (string * string) * (string * string) list + type file_info = { tmp_filename : string ; filesize : int64 ; raw_original_filename : string ; - file_content_type : ((string * string) * (string * string) list) option + file_content_type : content_type option } +type post_data = (string * string) list * (string * file_info) list + val post_params : - ?content_type : ((string * string) * (string * string) list) -> + ?content_type : content_type -> string Ocsigen_stream.t -> - (string option * - Int64.t option -> - ((string * string) list * (string * file_info) list) Lwt.t) option + (string option -> Int64.t option -> post_data Lwt.t) option + +val parse_content_type : string -> content_type option diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index c39ea218b..c71974e1d 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -1,3 +1,21 @@ +open Lwt.Infix + +let post_data_of_body b = + Cohttp_lwt_body.to_stream b + |> Ocsigen_stream.of_lwt_stream + |> Ocsigen_multipart.post_params + +type content_type = Ocsigen_multipart.content_type + +type file_info = Ocsigen_multipart.file_info = { + tmp_filename : string ; + filesize : int64 ; + raw_original_filename : string ; + file_content_type : content_type option +} + +type post_data = (string * string) list * (string * file_info) list + type t = { r_address : Unix.inet_addr ; r_port : int ; @@ -8,16 +26,17 @@ type t = { r_forward_ip : string list ; r_request : Cohttp.Request.t ; r_body : Cohttp_lwt_body.t ; + mutable r_post_data : Ocsigen_multipart.post_data Lwt.t option option ; + r_original_full_path : string option ; r_sub_path : string option ; r_waiter : unit Lwt.t ; + mutable r_request_cache : Polytables.t ; mutable r_tries : int } -(* FIXME: old ocsigenserver used to store original_full_path. Do we - really need that? *) - let make - ?(forward_ip = []) ?sub_path + ?(forward_ip = []) ?sub_path ?original_full_path + ?(request_cache = Polytables.create ()) ~address ~port ~filenames ~sockaddr ~request ~body ~waiter () = let r_remote_ip = lazy @@ -26,8 +45,7 @@ let make in let r_remote_ip_parsed = lazy (Ipaddr.of_string_exn (Lazy.force r_remote_ip)) - in - { + in { r_address = address ; r_port = port ; r_filenames = filenames ; @@ -37,18 +55,22 @@ let make r_forward_ip = forward_ip ; r_request = request ; r_body = body ; + r_post_data = None ; r_sub_path = sub_path ; + r_original_full_path = original_full_path ; r_waiter = waiter ; + r_request_cache = request_cache ; r_tries = 0 } let update - ?forward_ip ?remote_ip ?ssl ?request + ?forward_ip ?remote_ip ?ssl ?request ?post_data ({ r_request ; r_forward_ip ; r_remote_ip ; - r_remote_ip_parsed + r_remote_ip_parsed ; + r_post_data } as r) = (* FIXME : ssl *) let r_request = @@ -69,8 +91,24 @@ let update lazy remote_ip, lazy (Ipaddr.of_string_exn remote_ip) | None -> r_remote_ip, r_remote_ip_parsed - in - { r with r_request ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed } + and r_post_data = + match post_data with + | Some (Some post_data) -> + Some (Some (Lwt.return post_data)) + | Some None -> + Some None + | None -> + r_post_data + in { + r with + r_request ; + r_forward_ip ; + r_remote_ip ; + r_remote_ip_parsed ; + r_post_data + } + +let uri {r_request} = Cohttp.Request.uri r_request let update_url ?(full_rewrite = false) url ({r_request} as r) = let r_request = @@ -79,8 +117,15 @@ let update_url ?(full_rewrite = false) url ({r_request} as r) = and encoding = Cohttp.Request.encoding r_request and headers = Cohttp.Request.headers r_request in Cohttp.Request.make ~meth ~version ~encoding ~headers url - and r_sub_path = None in - { r with r_request ; r_sub_path } + in + let r_sub_path = None + and r_original_full_path = + if full_rewrite then + Some (Uri.path (Cohttp.Request.uri r_request)) + else + None + in + { r with r_request ; r_sub_path ; r_original_full_path } let request {r_request} = r_request @@ -113,6 +158,9 @@ let version {r_request} = let query {r_request} = Uri.verbatim_query (Cohttp.Request.uri r_request) +let get_params {r_request} = + Uri.query (Cohttp.Request.uri r_request) + let path_string {r_request} = Uri.path (Cohttp.Request.uri r_request) @@ -128,6 +176,15 @@ let sub_path_string = function let sub_path r = Ocsigen_lib.Url.split_path (sub_path_string r) +let original_full_path_string = function + | {r_original_full_path = Some r_original_full_path} -> + r_original_full_path + | r -> + path_string r + +let original_full_path r = + Ocsigen_lib.Url.split_path (original_full_path_string r) + let header {r_request} id = let h = Cohttp.Request.headers r_request in Cohttp.Header.get h (Http_headers.name_to_string id) @@ -136,12 +193,68 @@ let header_multi {r_request} id = let h = Cohttp.Request.headers r_request in Cohttp.Header.get_multi h (Http_headers.name_to_string id) +let add_header r id v = + let f ({Cohttp.Request.headers} as r) = + let headers = + Cohttp.Header.add headers + (Http_headers.name_to_string id) + v + in + { r with Cohttp.Request.headers } + in + map_cohttp_request r ~f + +let cookies r = + match header r Http_headers.cookie with + | Some cookies -> + Ocsigen_cookies.parse_cookies cookies + | None -> + Ocsigen_cookies.CookiesTable.empty + +let force_post_data ({r_post_data ; r_body} as r) s i = + match r_post_data with + | Some r_post_data -> + r_post_data + | None -> + let v = + match post_data_of_body r_body with + | Some f -> + Some (f s i) + | None -> + None + in + r.r_post_data <- Some v; + v + +let post_params r s i = + match force_post_data r s i with + | Some v -> + Some (v >|= fst) + | None -> + None + +let files r s i = + match force_post_data r s i with + | Some v -> + Some (v >|= snd) + | None -> + None + let remote_ip {r_remote_ip} = Lazy.force r_remote_ip let remote_ip_parsed {r_remote_ip_parsed} = Lazy.force r_remote_ip_parsed let forward_ip {r_forward_ip} = r_forward_ip +let content_type r = + match header r Http_headers.content_type with + | Some content_type -> + Ocsigen_multipart.parse_content_type content_type + | None -> + None + +let request_cache {r_request_cache} = r_request_cache + let tries {r_tries} = r_tries let incr_tries r = r.r_tries <- r.r_tries + 1 diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli index 56fc51e73..fca2022ea 100644 --- a/src/server/ocsigen_request.mli +++ b/src/server/ocsigen_request.mli @@ -1,8 +1,21 @@ type t +type content_type = (string * string) * (string * string) list + +type file_info = Ocsigen_multipart.file_info = { + tmp_filename : string ; + filesize : int64 ; + raw_original_filename : string ; + file_content_type : content_type option +} + +type post_data = (string * string) list * (string * file_info) list + val make : ?forward_ip : string list -> ?sub_path : string -> + ?original_full_path : string -> + ?request_cache : Polytables.t -> address : Unix.inet_addr -> port : int -> filenames : string list ref -> @@ -18,9 +31,12 @@ val update : ?remote_ip : string -> ?ssl : bool -> ?request : Cohttp.Request.t -> + ?post_data : Ocsigen_multipart.post_data option -> t -> t +val uri : t -> Uri.t + val update_url : ?full_rewrite : bool -> Uri.t -> @@ -50,6 +66,8 @@ val version : t -> Cohttp.Code.version val query : t -> string option +val get_params : t -> (string * string list) list + val path : t -> string list val path_string : t -> string @@ -58,16 +76,42 @@ val sub_path : t -> string list val sub_path_string : t -> string +val original_full_path : t -> string list + +val original_full_path_string : t -> string + val header : t -> Http_headers.name -> string option val header_multi : t -> Http_headers.name -> string list +val add_header : t -> Http_headers.name -> string -> t + +val cookies : t -> string Ocsigen_cookies.CookiesTable.t + +(* FIXME: strange API for files, post_params *) + +val files : + t -> + string option -> + Int64.t option -> + (string * file_info) list Lwt.t option + +val post_params : + t -> + string option -> + Int64.t option -> + (string * string) list Lwt.t option + val remote_ip : t -> string val remote_ip_parsed : t -> Ipaddr.t val forward_ip : t -> string list +val content_type : t -> content_type option + +val request_cache : t -> Polytables.t + val tries : t -> int val incr_tries : t -> unit diff --git a/src/server/ocsigen_response.ml b/src/server/ocsigen_response.ml index 41c5460dd..1f8340302 100644 --- a/src/server/ocsigen_response.ml +++ b/src/server/ocsigen_response.ml @@ -5,11 +5,31 @@ type t = { } let make - ?(cookies = Ocsigen_cookies.empty_cookieset) ?(body = Cohttp_lwt_body.empty) + ?(cookies = Ocsigen_cookies.empty_cookieset) ~response () = { a_response = response ; a_body = body ; a_cookies = cookies } +let update + ?response + ?body + ?cookies + { a_response ; a_body ; a_cookies } = + let a_response = + match response with + | Some response -> response + | None -> a_response + and a_body = + match body with + | Some body -> body + | None -> a_body + and a_cookies = + match cookies with + | Some cookies -> cookies + | None -> a_cookies + in + { a_response ; a_body ; a_cookies } + let of_cohttp ?(cookies = Ocsigen_cookies.empty_cookieset) (a_response, a_body) = @@ -17,6 +37,8 @@ let of_cohttp let to_cohttp { a_response ; a_body } = a_response, a_body +let cookies {a_cookies} = a_cookies + let set_status ({ a_response } as a) status = { a with a_response = { diff --git a/src/server/ocsigen_response.mli b/src/server/ocsigen_response.mli index c6b60da76..5f2d10896 100644 --- a/src/server/ocsigen_response.mli +++ b/src/server/ocsigen_response.mli @@ -5,12 +5,19 @@ type t = { } val make : - ?cookies : Ocsigen_cookies.cookieset -> ?body : Cohttp_lwt_body.t -> + ?cookies : Ocsigen_cookies.cookieset -> response : Cohttp.Response.t -> unit -> t +val update : + ?response : Cohttp.Response.t -> + ?body : Cohttp_lwt_body.t -> + ?cookies : Ocsigen_cookies.cookieset -> + t -> + t + val of_cohttp : ?cookies : Ocsigen_cookies.cookieset -> (Cohttp.Response.t * Cohttp_lwt_body.t) -> @@ -20,6 +27,8 @@ val to_cohttp : t -> Cohttp.Response.t * Cohttp_lwt_body.t val status : t -> Cohttp.Code.status +val cookies : t -> Ocsigen_cookies.cookieset + val set_status : t -> Cohttp.Code.status -> t val add_cookies : t -> Ocsigen_cookies.cookieset -> t From e7910a33ac9078806874294301b0c95d99fe39ea Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 20 Feb 2017 18:00:20 +0100 Subject: [PATCH 026/111] Eliom_request: remove trailing slash from paths --- src/server/ocsigen_request.ml | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index c71974e1d..34c988080 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -165,7 +165,12 @@ let path_string {r_request} = Uri.path (Cohttp.Request.uri r_request) let path r = - Ocsigen_lib.Url.split_path (path_string r) + (* CHECKME *) + match Ocsigen_lib.Url.split_path (path_string r) with + | "" :: path -> + path + | path -> + path let sub_path_string = function | {r_sub_path = Some r_sub_path} -> @@ -174,7 +179,11 @@ let sub_path_string = function path_string r let sub_path r = - Ocsigen_lib.Url.split_path (sub_path_string r) + match Ocsigen_lib.Url.split_path (sub_path_string r) with + | "" :: path -> + path + | path -> + path let original_full_path_string = function | {r_original_full_path = Some r_original_full_path} -> From 65ca3e332b6e171d9c869e351cb11f7dbe638b5f Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 21 Feb 2017 18:04:04 +0100 Subject: [PATCH 027/111] Pass content_type for multipart parsing --- src/server/ocsigen_multipart.ml | 14 ++------------ src/server/ocsigen_multipart.mli | 2 +- src/server/ocsigen_request.ml | 30 ++++++++++++++++++------------ 3 files changed, 21 insertions(+), 25 deletions(-) diff --git a/src/server/ocsigen_multipart.ml b/src/server/ocsigen_multipart.ml index 103131b82..ecf219a9e 100644 --- a/src/server/ocsigen_multipart.ml +++ b/src/server/ocsigen_multipart.ml @@ -404,18 +404,8 @@ let post_params_multipart_form_data body_gen ctparams upload_dir max_size = Ocsigen_stream.consume body_gen >>= fun () -> Lwt.return (!params, !files) -let post_params - ?content_type - body_gen = - let (ct, cst), ctparams = - match content_type with - (* RFC 2616, sect. 7.2.1: if the media type remains unknown, the - recipient SHOULD treat it as type "application/octet-stream" *) - | None -> - ("application", "octet-stream"), [] - | Some content_type -> - content_type - in +let post_params ~content_type body_gen = + let (ct, cst), ctparams = content_type in match String.lowercase ct, String.lowercase cst with | "application", "x-www-form-urlencoded" -> Some (post_params_form_urlencoded body_gen) diff --git a/src/server/ocsigen_multipart.mli b/src/server/ocsigen_multipart.mli index d41647f55..7b42f476c 100644 --- a/src/server/ocsigen_multipart.mli +++ b/src/server/ocsigen_multipart.mli @@ -19,7 +19,7 @@ type file_info = { type post_data = (string * string) list * (string * file_info) list val post_params : - ?content_type : content_type -> + content_type : content_type -> string Ocsigen_stream.t -> (string option -> Int64.t option -> post_data Lwt.t) option diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 34c988080..3a2d6c90a 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -1,9 +1,9 @@ open Lwt.Infix -let post_data_of_body b = +let post_data_of_body ~content_type b = Cohttp_lwt_body.to_stream b |> Ocsigen_stream.of_lwt_stream - |> Ocsigen_multipart.post_params + |> Ocsigen_multipart.post_params ~content_type type content_type = Ocsigen_multipart.content_type @@ -220,15 +220,28 @@ let cookies r = | None -> Ocsigen_cookies.CookiesTable.empty +let content_type r = + match header r Http_headers.content_type with + | Some content_type -> + Ocsigen_multipart.parse_content_type content_type + | None -> + None + let force_post_data ({r_post_data ; r_body} as r) s i = match r_post_data with | Some r_post_data -> r_post_data | None -> let v = - match post_data_of_body r_body with - | Some f -> - Some (f s i) + match content_type r with + | Some content_type -> + (match + post_data_of_body ~content_type r_body + with + | Some f -> + Some (f s i) + | None -> + None) | None -> None in @@ -255,13 +268,6 @@ let remote_ip_parsed {r_remote_ip_parsed} = Lazy.force r_remote_ip_parsed let forward_ip {r_forward_ip} = r_forward_ip -let content_type r = - match header r Http_headers.content_type with - | Some content_type -> - Ocsigen_multipart.parse_content_type content_type - | None -> - None - let request_cache {r_request_cache} = r_request_cache let tries {r_tries} = r_tries From 34a4a03897364a9f1ae958409a879e4bfae72d74 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 21 Feb 2017 19:03:50 +0100 Subject: [PATCH 028/111] Move parse_cookies to Ocsigen_request We need Ocsigen_cookies on the client, but we don't want to link-in Ocsigen_lib. --- src/http/ocsigen_cookies.ml | 12 ------------ src/http/ocsigen_cookies.mli | 2 -- src/server/ocsigen_request.ml | 14 +++++++++++++- 3 files changed, 13 insertions(+), 15 deletions(-) diff --git a/src/http/ocsigen_cookies.ml b/src/http/ocsigen_cookies.ml index 1bdc09051..8f615c947 100644 --- a/src/http/ocsigen_cookies.ml +++ b/src/http/ocsigen_cookies.ml @@ -65,15 +65,3 @@ let add_cookies newcookies oldcookies = ) newcookies oldcookies - -let parse_cookies s = - let splitted = Ocsigen_lib.String.split ';' s in - try - List.fold_left - (fun beg a -> - let (n, v) = Ocsigen_lib.String.sep '=' a in - CookiesTable.add n v beg) - CookiesTable.empty - splitted - with _ -> - CookiesTable.empty diff --git a/src/http/ocsigen_cookies.mli b/src/http/ocsigen_cookies.mli index 05e050855..f774a25cd 100644 --- a/src/http/ocsigen_cookies.mli +++ b/src/http/ocsigen_cookies.mli @@ -63,5 +63,3 @@ val add_cookies : cookie CookiesTable.t Cookies.t -> cookie CookiesTable.t Cookies.t -> cookie CookiesTable.t Cookies.t - -val parse_cookies : string -> string CookiesTable.t diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 3a2d6c90a..3dfe048d8 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -213,10 +213,22 @@ let add_header r id v = in map_cohttp_request r ~f +let parse_cookies s = + let splitted = Ocsigen_lib.String.split ';' s in + try + List.fold_left + (fun beg a -> + let (n, v) = Ocsigen_lib.String.sep '=' a in + Ocsigen_cookies.CookiesTable.add n v beg) + Ocsigen_cookies.CookiesTable.empty + splitted + with _ -> + Ocsigen_cookies.CookiesTable.empty + let cookies r = match header r Http_headers.cookie with | Some cookies -> - Ocsigen_cookies.parse_cookies cookies + parse_cookies cookies | None -> Ocsigen_cookies.CookiesTable.empty From 3f3280e848923024c6c71008bda869d3e11f59f3 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 21 Feb 2017 20:18:40 +0100 Subject: [PATCH 029/111] Export file_info structure in Ocisgen_extensions --- src/server/ocsigen_extensions.ml | 7 ++++++- src/server/ocsigen_extensions.mli | 7 ++++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 9b156b39b..49957d8df 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -40,7 +40,12 @@ exception Error_in_config_file of string (** Option incorrect in a userconf file *) exception Error_in_user_config_file of string -type file_info = Ocsigen_multipart.file_info +type file_info = Ocsigen_multipart.file_info = { + tmp_filename : string ; + filesize : int64 ; + raw_original_filename : string ; + file_content_type : ((string * string) * (string * string) list) option +} let badconfig fmt = Printf.ksprintf (fun s -> raise (Error_in_config_file s)) fmt diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index ecbd948a7..5bf5f6719 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -37,7 +37,12 @@ exception Error_in_config_file of string (** Option incorrect in a userconf file *) exception Error_in_user_config_file of string -type file_info = Ocsigen_multipart.file_info +type file_info = Ocsigen_multipart.file_info = { + tmp_filename : string ; + filesize : int64 ; + raw_original_filename : string ; + file_content_type : ((string * string) * (string * string) list) option +} val badconfig : ('a, unit, string, 'b) format4 -> 'a (** Convenient function for raising Error_in_config_file exceptions with From c787d0fdf69be757fb534e5caa0e356a6682aac7 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 24 Feb 2017 14:43:12 +0100 Subject: [PATCH 030/111] Ocsigen_request : option to override cookies from raw request --- src/server/ocsigen_request.ml | 56 +++++++++++++++++++++------------- src/server/ocsigen_request.mli | 4 ++- 2 files changed, 38 insertions(+), 22 deletions(-) diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 3dfe048d8..c83c74fb8 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -26,10 +26,11 @@ type t = { r_forward_ip : string list ; r_request : Cohttp.Request.t ; r_body : Cohttp_lwt_body.t ; - mutable r_post_data : Ocsigen_multipart.post_data Lwt.t option option ; + mutable r_post_data_override : Ocsigen_multipart.post_data Lwt.t option option ; r_original_full_path : string option ; r_sub_path : string option ; r_waiter : unit Lwt.t ; + r_cookies_override : string Ocsigen_cookies.CookiesTable.t option ; mutable r_request_cache : Polytables.t ; mutable r_tries : int } @@ -37,6 +38,7 @@ type t = { let make ?(forward_ip = []) ?sub_path ?original_full_path ?(request_cache = Polytables.create ()) + ?cookies_override ~address ~port ~filenames ~sockaddr ~request ~body ~waiter () = let r_remote_ip = lazy @@ -55,22 +57,24 @@ let make r_forward_ip = forward_ip ; r_request = request ; r_body = body ; - r_post_data = None ; + r_post_data_override = None ; r_sub_path = sub_path ; r_original_full_path = original_full_path ; r_waiter = waiter ; + r_cookies_override = cookies_override ; r_request_cache = request_cache ; r_tries = 0 } let update - ?forward_ip ?remote_ip ?ssl ?request ?post_data + ?forward_ip ?remote_ip ?ssl ?request ?post_data_override ?cookies_override ({ r_request ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed ; - r_post_data + r_cookies_override ; + r_post_data_override } as r) = (* FIXME : ssl *) let r_request = @@ -91,21 +95,28 @@ let update lazy remote_ip, lazy (Ipaddr.of_string_exn remote_ip) | None -> r_remote_ip, r_remote_ip_parsed - and r_post_data = - match post_data with - | Some (Some post_data) -> - Some (Some (Lwt.return post_data)) + and r_post_data_override = + match post_data_override with + | Some (Some post_data_override) -> + Some (Some (Lwt.return post_data_override)) | Some None -> Some None | None -> - r_post_data + r_post_data_override + and r_cookies_override = + match cookies_override with + | Some _ -> + cookies_override + | None -> + r_cookies_override in { r with r_request ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed ; - r_post_data + r_post_data_override ; + r_cookies_override } let uri {r_request} = Cohttp.Request.uri r_request @@ -225,12 +236,15 @@ let parse_cookies s = with _ -> Ocsigen_cookies.CookiesTable.empty -let cookies r = - match header r Http_headers.cookie with - | Some cookies -> - parse_cookies cookies - | None -> - Ocsigen_cookies.CookiesTable.empty +let cookies = function + | {r_cookies_override = Some cookies} -> + cookies + | r -> + match header r Http_headers.cookie with + | Some cookies -> + parse_cookies cookies + | None -> + Ocsigen_cookies.CookiesTable.empty let content_type r = match header r Http_headers.content_type with @@ -239,10 +253,10 @@ let content_type r = | None -> None -let force_post_data ({r_post_data ; r_body} as r) s i = - match r_post_data with - | Some r_post_data -> - r_post_data +let force_post_data ({r_post_data_override ; r_body} as r) s i = + match r_post_data_override with + | Some r_post_data_override -> + r_post_data_override | None -> let v = match content_type r with @@ -257,7 +271,7 @@ let force_post_data ({r_post_data ; r_body} as r) s i = | None -> None in - r.r_post_data <- Some v; + r.r_post_data_override <- Some v; v let post_params r s i = diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli index fca2022ea..e59dcf489 100644 --- a/src/server/ocsigen_request.mli +++ b/src/server/ocsigen_request.mli @@ -16,6 +16,7 @@ val make : ?sub_path : string -> ?original_full_path : string -> ?request_cache : Polytables.t -> + ?cookies_override : string Ocsigen_cookies.CookiesTable.t -> address : Unix.inet_addr -> port : int -> filenames : string list ref -> @@ -31,7 +32,8 @@ val update : ?remote_ip : string -> ?ssl : bool -> ?request : Cohttp.Request.t -> - ?post_data : Ocsigen_multipart.post_data option -> + ?post_data_override : Ocsigen_multipart.post_data option -> + ?cookies_override : string Ocsigen_cookies.CookiesTable.t -> t -> t From 168ef6656fb2b2fbff877095b15d3ad58e642958 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 2 Mar 2017 16:52:49 +0100 Subject: [PATCH 031/111] Implement Ocsigen_request.{connection_closed,wakeup} --- src/server/ocsigen_request.ml | 15 ++++++++++----- src/server/ocsigen_request.mli | 4 ++++ 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index c83c74fb8..3ff949201 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -29,10 +29,10 @@ type t = { mutable r_post_data_override : Ocsigen_multipart.post_data Lwt.t option option ; r_original_full_path : string option ; r_sub_path : string option ; - r_waiter : unit Lwt.t ; r_cookies_override : string Ocsigen_cookies.CookiesTable.t option ; mutable r_request_cache : Polytables.t ; - mutable r_tries : int + mutable r_tries : int ; + r_connection_closed : unit Lwt.t * unit Lwt.u } let make @@ -47,7 +47,8 @@ let make in let r_remote_ip_parsed = lazy (Ipaddr.of_string_exn (Lazy.force r_remote_ip)) - in { + and r_connection_closed = Lwt.wait () in + { r_address = address ; r_port = port ; r_filenames = filenames ; @@ -60,10 +61,10 @@ let make r_post_data_override = None ; r_sub_path = sub_path ; r_original_full_path = original_full_path ; - r_waiter = waiter ; r_cookies_override = cookies_override ; r_request_cache = request_cache ; - r_tries = 0 + r_tries = 0 ; + r_connection_closed } let update @@ -299,3 +300,7 @@ let request_cache {r_request_cache} = r_request_cache let tries {r_tries} = r_tries let incr_tries r = r.r_tries <- r.r_tries + 1 + +let connection_closed {r_connection_closed = (wait, _)} = wait + +let wakeup {r_connection_closed = (_, wakeup)} = Lwt.wakeup wakeup () diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli index e59dcf489..b521d07af 100644 --- a/src/server/ocsigen_request.mli +++ b/src/server/ocsigen_request.mli @@ -117,3 +117,7 @@ val request_cache : t -> Polytables.t val tries : t -> int val incr_tries : t -> unit + +val connection_closed : t -> unit Lwt.t + +val wakeup : t -> unit From dcd55e47bc799466abd9d2a23834109e23086576 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 3 Mar 2017 14:25:22 +0100 Subject: [PATCH 032/111] Fuse Ocsigen_request.update_uri into update Also implement get_params_override to allow modifying get_params independently of URI (for Eliom). --- src/extensions/rewritemod.ml | 8 ++-- src/server/ocsigen_request.ml | 78 +++++++++++++++++++++++----------- src/server/ocsigen_request.mli | 11 ++--- 3 files changed, 61 insertions(+), 36 deletions(-) diff --git a/src/extensions/rewritemod.ml b/src/extensions/rewritemod.ml index 7cf8cd477..3268ff1d4 100644 --- a/src/extensions/rewritemod.ml +++ b/src/extensions/rewritemod.ml @@ -66,9 +66,9 @@ let gen regexp continue = function Lwt.return @@ Ocsigen_extensions.Ext_continue_with ({ ri with Ocsigen_extensions.request_info = - Ocsigen_request.update_url + Ocsigen_request.update ~full_rewrite - (Uri.of_string redir) + ~uri:(Uri.of_string redir) ri.Ocsigen_extensions.request_info }, Ocsigen_cookies.Cookies.empty, @@ -77,9 +77,9 @@ let gen regexp continue = function Lwt.return @@ Ocsigen_extensions.Ext_retry_with ({ ri with Ocsigen_extensions.request_info = - Ocsigen_request.update_url + Ocsigen_request.update ~full_rewrite - (Uri.of_string redir) + ~uri:(Uri.of_string redir) ri.Ocsigen_extensions.request_info }, Ocsigen_cookies.Cookies.empty) and catch_block = function diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 3ff949201..913f6c3fe 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -14,7 +14,7 @@ type file_info = Ocsigen_multipart.file_info = { file_content_type : content_type option } -type post_data = (string * string) list * (string * file_info) list +type post_data = Ocsigen_multipart.post_data type t = { r_address : Unix.inet_addr ; @@ -26,7 +26,8 @@ type t = { r_forward_ip : string list ; r_request : Cohttp.Request.t ; r_body : Cohttp_lwt_body.t ; - mutable r_post_data_override : Ocsigen_multipart.post_data Lwt.t option option ; + r_get_params_override : (string * string list) list option ; + mutable r_post_data_override : post_data Lwt.t option option ; r_original_full_path : string option ; r_sub_path : string option ; r_cookies_override : string Ocsigen_cookies.CookiesTable.t option ; @@ -58,6 +59,7 @@ let make r_forward_ip = forward_ip ; r_request = request ; r_body = body ; + r_get_params_override = None ; r_post_data_override = None ; r_sub_path = sub_path ; r_original_full_path = original_full_path ; @@ -67,15 +69,36 @@ let make r_connection_closed } +let update_uri_components ~full_rewrite ~request uri = + let request = + let meth = Cohttp.Request.meth request + and version = Cohttp.Request.version request + and encoding = Cohttp.Request.encoding request + and headers = Cohttp.Request.headers request in + Cohttp.Request.make ~meth ~version ~encoding ~headers uri + in + let original_full_path = + if full_rewrite then + Some (Uri.path (Cohttp.Request.uri request)) + else + None + in + request, original_full_path + let update - ?forward_ip ?remote_ip ?ssl ?request ?post_data_override ?cookies_override + ?forward_ip ?remote_ip ?ssl ?request + ?get_params_override ?post_data_override ?cookies_override + ?(full_rewrite = false) ?uri ({ r_request ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed ; + r_get_params_override ; r_cookies_override ; - r_post_data_override + r_post_data_override ; + r_sub_path ; + r_original_full_path } as r) = (* FIXME : ssl *) let r_request = @@ -110,38 +133,39 @@ let update cookies_override | None -> r_cookies_override - in { + and r_get_params_override = + match get_params_override with + | Some _ -> + get_params_override + | None -> + r_get_params_override + in + let r_request, r_original_full_path = + match uri with + | Some uri -> + update_uri_components ~full_rewrite ~request:r_request uri + | None -> + r_request, r_original_full_path + in + { r with r_request ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed ; + r_get_params_override ; r_post_data_override ; - r_cookies_override + r_cookies_override ; + r_sub_path ; + r_original_full_path } let uri {r_request} = Cohttp.Request.uri r_request -let update_url ?(full_rewrite = false) url ({r_request} as r) = - let r_request = - let meth = Cohttp.Request.meth r_request - and version = Cohttp.Request.version r_request - and encoding = Cohttp.Request.encoding r_request - and headers = Cohttp.Request.headers r_request in - Cohttp.Request.make ~meth ~version ~encoding ~headers url - in - let r_sub_path = None - and r_original_full_path = - if full_rewrite then - Some (Uri.path (Cohttp.Request.uri r_request)) - else - None - in - { r with r_request ; r_sub_path ; r_original_full_path } - let request {r_request} = r_request + let body {r_body} = r_body @@ -170,8 +194,12 @@ let version {r_request} = let query {r_request} = Uri.verbatim_query (Cohttp.Request.uri r_request) -let get_params {r_request} = - Uri.query (Cohttp.Request.uri r_request) +let get_params { r_request ; r_get_params_override } = + match r_get_params_override with + | Some r_get_params_override -> + r_get_params_override + | None -> + Uri.query (Cohttp.Request.uri r_request) let path_string {r_request} = Uri.path (Cohttp.Request.uri r_request) diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli index b521d07af..a29cfcab1 100644 --- a/src/server/ocsigen_request.mli +++ b/src/server/ocsigen_request.mli @@ -32,19 +32,16 @@ val update : ?remote_ip : string -> ?ssl : bool -> ?request : Cohttp.Request.t -> - ?post_data_override : Ocsigen_multipart.post_data option -> + ?get_params_override : (string * string list) list -> + ?post_data_override : post_data option -> ?cookies_override : string Ocsigen_cookies.CookiesTable.t -> + ?full_rewrite : bool -> + ?uri : Uri.t -> t -> t val uri : t -> Uri.t -val update_url : - ?full_rewrite : bool -> - Uri.t -> - t -> - t - val request : t -> Cohttp.Request.t val body : t -> Cohttp_lwt_body.t From f8a7a17d3c48c42659ff2460c1a5a7c664efb344 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 7 Mar 2017 16:24:47 +0100 Subject: [PATCH 033/111] Send cookies with Cohttp response --- src/server/ocsigen_cohttp.ml | 48 ++++++++++++++++++++++++++++++++++-- 1 file changed, 46 insertions(+), 2 deletions(-) diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index 4b1627546..ceec6c037 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -71,6 +71,38 @@ module Cookie = struct end +(* FIXME: secure *) +let make_cookies_header path exp name c secure = + Format.sprintf "%s=%s%s%s" name c + (*VVV encode = true? *) + ("; path=/" ^ Ocsigen_lib.Url.string_of_url_path ~encode:true path) + (* (if secure && slot.sl_ssl then "; secure" else "")^ *) + "" ^ + (match exp with + | Some s -> + "; expires=" ^ + Netdate.format + "%a, %d-%b-%Y %H:%M:%S GMT" + (Netdate.create s) + | None -> "") + +let make_cookies_headers path t hds = + Ocsigen_cookies.CookiesTable.fold + (fun name c h -> + let exp, v, secure = + match c with + | Ocsigen_cookies.OUnset -> + Some 0., "", false + | Ocsigen_cookies.OSet (t, v, secure) -> + t, v, secure + in + Cohttp.Header.add h + Http_headers.(name_to_string set_cookie) + (make_cookies_header path exp name v secure) + ) + t + hds + let handler ~address ~port ~connector (flow, conn) request body = Lwt_log.ign_info_f ~section @@ -148,7 +180,6 @@ let handler ~address ~port ~connector (flow, conn) request body = !filenames; (* TODO: equivalent of Ocsigen_range *) - (* TODO: handle cookies *) let request = Ocsigen_request.make @@ -159,8 +190,21 @@ let handler ~address ~port ~connector (flow, conn) request body = Lwt.catch (fun () -> - connector request >>= fun { Ocsigen_response.a_response ; a_body } -> + connector request >>= fun { Ocsigen_response.a_response ; + a_cookies ; + a_body } -> + + let a_response = + let headers = + Ocsigen_cookies.Cookies.fold + make_cookies_headers + a_cookies + (Cohttp.Response.headers a_response) + in + { a_response with Cohttp.Response.headers } + in Lwt.return (a_response, a_body)) + (function | Ocsigen_Is_a_directory fun_request -> Cohttp_lwt_unix.Server.respond_redirect From 57f1582c7879bf310f5a4dc588f1b25ba45fb6f0 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 8 Mar 2017 14:35:58 +0100 Subject: [PATCH 034/111] Extension for simple handler registration --- src/Makefile.filelist | 5 ++- src/baselib/.depend | 20 +++++----- src/extensions/.depend | 11 ++++-- src/extensions/Makefile | 2 +- src/extensions/handler.ml | 47 +++++++++++++++++++++++ src/extensions/handler.mli | 14 +++++++ src/extensions/ocsipersist-dbm/.depend | 4 +- src/extensions/ocsipersist-pgsql/.depend | 2 +- src/extensions/ocsipersist-sqlite/.depend | 2 +- src/files/META.in | 8 ++++ src/http/.depend | 6 +-- src/server/.depend | 9 +++-- 12 files changed, 103 insertions(+), 27 deletions(-) create mode 100644 src/extensions/handler.ml create mode 100644 src/extensions/handler.mli diff --git a/src/Makefile.filelist b/src/Makefile.filelist index ae25d1f6c..c2193e990 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -51,13 +51,14 @@ endif PLUGINS_BIN := PLUGINS_INTF := extensions/authbasic.cmi extensions/accesscontrol.cmi \ - extensions/ocsipersist.cmi + extensions/ocsipersist.cmi extensions/handler.cmi # extensions/ocsigen_comet.cmi PLUGINS_IMPL := extensions/accesscontrol.cmo extensions/authbasic.cmo \ extensions/cors.cmo extensions/outputfilter.cmo \ extensions/redirectmod.cmo extensions/revproxy.cmo \ - extensions/rewritemod.cmo extensions/staticmod.cmo + extensions/rewritemod.cmo extensions/staticmod.cmo \ + extensions/handler.cmo ifeq "$(CAMLZIP)" "YES" PLUGINS_IMPL += extensions/deflatemod.cmo diff --git a/src/baselib/.depend b/src/baselib/.depend index 48e2fd617..fdc97bcf9 100644 --- a/src/baselib/.depend +++ b/src/baselib/.depend @@ -1,10 +1,3 @@ -ocsigen_loader.cmi : -ocsigen_cache.cmi : -ocsigen_stream.cmi : -ocsigen_config.cmi : ocsigen_lib.cmi -ocsigen_messages.cmi : -ocsigen_getcommandline.cmi : -polytables.cmi : dynlink_wrapper.cmo : dynlink_wrapper.cmx : dynlink_wrapper.natdynlink.cmo : @@ -13,23 +6,30 @@ dynlink_wrapper.nonatdynlink.cmo : dynlink_wrapper.nonatdynlink.cmx : ocsigen_cache.cmo : ocsigen_cache.cmi ocsigen_cache.cmx : ocsigen_cache.cmi +ocsigen_cache.cmi : ocsigen_commandline.cmo : ocsigen_getcommandline.cmi ocsigen_config.cmi ocsigen_commandline.cmx : ocsigen_getcommandline.cmi ocsigen_config.cmx ocsigen_config.cmo : ocsigen_lib.cmi ocsigen_config.cmi ocsigen_config.cmx : ocsigen_lib.cmx ocsigen_config.cmi -ocsigen_lib_base.cmo : ocsigen_lib_base.cmi -ocsigen_lib_base.cmx : ocsigen_lib_base.cmi +ocsigen_config.cmi : ocsigen_lib.cmi +ocsigen_getcommandline.cmi : ocsigen_lib.cmo : ocsigen_lib_base.cmi ocsigen_lib.cmi ocsigen_lib.cmx : ocsigen_lib_base.cmx ocsigen_lib.cmi +ocsigen_lib_base.cmo : ocsigen_lib_base.cmi +ocsigen_lib_base.cmx : ocsigen_lib_base.cmi ocsigen_loader.cmo : ocsigen_lib.cmi ocsigen_config.cmi dynlink_wrapper.cmo \ ocsigen_loader.cmi ocsigen_loader.cmx : ocsigen_lib.cmx ocsigen_config.cmx dynlink_wrapper.cmx \ ocsigen_loader.cmi +ocsigen_loader.cmi : ocsigen_messages.cmo : ocsigen_config.cmi ocsigen_messages.cmi ocsigen_messages.cmx : ocsigen_config.cmx ocsigen_messages.cmi +ocsigen_messages.cmi : ocsigen_stream.cmo : ocsigen_lib.cmi ocsigen_config.cmi ocsigen_stream.cmi ocsigen_stream.cmx : ocsigen_lib.cmx ocsigen_config.cmx ocsigen_stream.cmi +ocsigen_stream.cmi : polytables.cmo : polytables.cmi polytables.cmx : polytables.cmi -ocsigen_lib_base.cmi : +polytables.cmi : ocsigen_lib.cmi : ocsigen_lib_base.cmi +ocsigen_lib_base.cmi : diff --git a/src/extensions/.depend b/src/extensions/.depend index 2ad08d527..c4fccd4e6 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -9,12 +9,10 @@ accesscontrol.cmx : ../server/ocsigen_response.cmx \ accesscontrol.cmi : authbasic.cmo : ../server/ocsigen_request.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ - ../server/ocsigen_cohttp.cmi ../http/http_headers.cmi \ - authbasic.cmi + ../server/ocsigen_cohttp.cmi ../http/http_headers.cmi authbasic.cmi authbasic.cmx : ../server/ocsigen_request.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ - ../server/ocsigen_cohttp.cmx ../http/http_headers.cmx \ - authbasic.cmi + ../server/ocsigen_cohttp.cmx ../http/http_headers.cmx authbasic.cmi authbasic.cmi : cgimod.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ @@ -36,6 +34,11 @@ extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ extendconfiguration.cmx : ../server/ocsigen_parseconfig.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx ../http/ocsigen_charset_mime.cmx +handler.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ + ../server/ocsigen_extensions.cmi handler.cmi +handler.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ + ../server/ocsigen_extensions.cmx handler.cmi +handler.cmi : ocsigen_comet.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi \ ocsigen_comet.cmi diff --git a/src/extensions/Makefile b/src/extensions/Makefile index b9c8d39a6..923bb3475 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -22,7 +22,7 @@ all: byte opt ### Extensions ### -FILES := accesscontrol.ml authbasic.ml cors.ml outputfilter.ml \ +FILES := accesscontrol.ml authbasic.ml cors.ml handler.ml outputfilter.ml \ redirectmod.ml revproxy.ml rewritemod.ml staticmod.ml # cgimod.ml \ # userconf.ml \ diff --git a/src/extensions/handler.ml b/src/extensions/handler.ml new file mode 100644 index 000000000..cf364ec3f --- /dev/null +++ b/src/extensions/handler.ml @@ -0,0 +1,47 @@ +open Lwt.Infix + +let name = "handler" + +type id = string list * (string * string list) list + +type result = [ + | `Response of Ocsigen_response.t + | `Fail of Cohttp.Code.status + | `Continue +] + +type t = + string list -> + (string * string list) list -> + Cohttp.Header.t -> + Cohttp_lwt_body.t -> + result Lwt.t + +let handlers : t list ref = ref [] + +let register f = handlers := f :: !handlers + +let rec fold_handlers ~request l = + match l with + | f :: l -> + (f (Ocsigen_request.path request) + (Ocsigen_request.get_params request) + (Cohttp.Request.headers (Ocsigen_request.request request)) + (Ocsigen_request.body request) >>= function + | `Response r -> + Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return r)) + | `Fail s -> + Lwt.return (Ocsigen_extensions.Ext_next s) + | `Continue -> + fold_handlers ~request l) + | [] -> + Lwt.return (Ocsigen_extensions.Ext_next `Not_found) + +let fun_site _ _ _ _ _ _ = function + | Ocsigen_extensions.Req_found _ -> + Lwt.return Ocsigen_extensions.Ext_do_nothing + | Ocsigen_extensions.Req_not_found + (_, {Ocsigen_extensions.request_info}) -> + fold_handlers ~request:request_info !handlers + +let () = Ocsigen_extensions.register_extension ~name ~fun_site () diff --git a/src/extensions/handler.mli b/src/extensions/handler.mli new file mode 100644 index 000000000..1901e028c --- /dev/null +++ b/src/extensions/handler.mli @@ -0,0 +1,14 @@ +type result = [ + | `Response of Ocsigen_response.t + | `Fail of Cohttp.Code.status + | `Continue +] + +type t = + string list -> + (string * string list) list -> + Cohttp.Header.t -> + Cohttp_lwt_body.t -> + result Lwt.t + +val register : t -> unit diff --git a/src/extensions/ocsipersist-dbm/.depend b/src/extensions/ocsipersist-dbm/.depend index f3f38103b..95d34f7c4 100644 --- a/src/extensions/ocsipersist-dbm/.depend +++ b/src/extensions/ocsipersist-dbm/.depend @@ -1,10 +1,10 @@ -ocsidbmtypes.cmi : -ocsipersist.cmi : ocsidbm.cmo : ocsidbmtypes.cmi ocsidbm.cmx : ocsidbmtypes.cmi +ocsidbmtypes.cmi : ocsipersist.cmo : ../../baselib/ocsigen_messages.cmi \ ../../server/ocsigen_extensions.cmi ../../baselib/ocsigen_config.cmi \ ocsidbmtypes.cmi ocsipersist.cmi ocsipersist.cmx : ../../baselib/ocsigen_messages.cmx \ ../../server/ocsigen_extensions.cmx ../../baselib/ocsigen_config.cmx \ ocsidbmtypes.cmi ocsipersist.cmi +ocsipersist.cmi : diff --git a/src/extensions/ocsipersist-pgsql/.depend b/src/extensions/ocsipersist-pgsql/.depend index bf15335eb..5594cd495 100644 --- a/src/extensions/ocsipersist-pgsql/.depend +++ b/src/extensions/ocsipersist-pgsql/.depend @@ -1,3 +1,3 @@ -ocsipersist.cmi : ocsipersist.cmo : ../../server/ocsigen_extensions.cmi ocsipersist.cmi ocsipersist.cmx : ../../server/ocsigen_extensions.cmx ocsipersist.cmi +ocsipersist.cmi : diff --git a/src/extensions/ocsipersist-sqlite/.depend b/src/extensions/ocsipersist-sqlite/.depend index 0577ff293..7a5fecd55 100644 --- a/src/extensions/ocsipersist-sqlite/.depend +++ b/src/extensions/ocsipersist-sqlite/.depend @@ -1,7 +1,7 @@ -ocsipersist.cmi : ocsipersist.cmo : ../../baselib/ocsigen_messages.cmi \ ../../server/ocsigen_extensions.cmi ../../baselib/ocsigen_config.cmi \ ocsipersist.cmi ocsipersist.cmx : ../../baselib/ocsigen_messages.cmx \ ../../server/ocsigen_extensions.cmx ../../baselib/ocsigen_config.cmx \ ocsipersist.cmi +ocsipersist.cmi : diff --git a/src/files/META.in b/src/files/META.in index 357047e0d..823413c92 100644 --- a/src/files/META.in +++ b/src/files/META.in @@ -142,6 +142,14 @@ package "ext" ( archive(native) = "cgimod.cmx" ) + package "handler" ( + exists_if = "handler.cmo,handler.cmx" + version = "[distributed with Ocsigen server]" + description = "Handler registry" + archive(byte) = "handler.cmo" + archive(native) = "handler.cmx" + ) + package "ocsipersist-sqlite" ( exists_if = "ocsipersist-sqlite.cma,ocsipersist-sqlite.cmxa" requires = "sqlite3" diff --git a/src/http/.depend b/src/http/.depend index 82577926d..7dec1b7a2 100644 --- a/src/http/.depend +++ b/src/http/.depend @@ -1,11 +1,11 @@ -http_headers.cmi : -ocsigen_charset_mime.cmi : -ocsigen_cookies.cmi : ../baselib/ocsigen_lib.cmi http_headers.cmo : http_headers.cmi http_headers.cmx : http_headers.cmi +http_headers.cmi : ocsigen_charset_mime.cmo : ../baselib/ocsigen_lib.cmi \ ../baselib/ocsigen_config.cmi ocsigen_charset_mime.cmi ocsigen_charset_mime.cmx : ../baselib/ocsigen_lib.cmx \ ../baselib/ocsigen_config.cmx ocsigen_charset_mime.cmi +ocsigen_charset_mime.cmi : ocsigen_cookies.cmo : ocsigen_cookies.cmi ocsigen_cookies.cmx : ocsigen_cookies.cmi +ocsigen_cookies.cmi : ../baselib/ocsigen_lib.cmi diff --git a/src/server/.depend b/src/server/.depend index 9f3930655..939d0f6f0 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -46,11 +46,14 @@ ocsigen_parseconfig.cmx : ocsigen_socket.cmx ../baselib/ocsigen_loader.cmx \ ocsigen_parseconfig.cmi : ocsigen_socket.cmi ocsigen_extensions.cmi ocsigen_request.cmo : ../baselib/polytables.cmi \ ../baselib/ocsigen_stream.cmi ocsigen_socket.cmi ocsigen_multipart.cmi \ - ../baselib/ocsigen_lib.cmi ../http/http_headers.cmi ocsigen_request.cmi + ../baselib/ocsigen_lib.cmi ../http/ocsigen_cookies.cmi \ + ../http/http_headers.cmi ocsigen_request.cmi ocsigen_request.cmx : ../baselib/polytables.cmx \ ../baselib/ocsigen_stream.cmx ocsigen_socket.cmx ocsigen_multipart.cmx \ - ../baselib/ocsigen_lib.cmx ../http/http_headers.cmx ocsigen_request.cmi -ocsigen_request.cmi : ../baselib/polytables.cmi ../http/http_headers.cmi + ../baselib/ocsigen_lib.cmx ../http/ocsigen_cookies.cmx \ + ../http/http_headers.cmx ocsigen_request.cmi +ocsigen_request.cmi : ../baselib/polytables.cmi ocsigen_multipart.cmi \ + ../http/ocsigen_cookies.cmi ../http/http_headers.cmi ocsigen_response.cmo : ../http/ocsigen_cookies.cmi ../http/http_headers.cmi \ ocsigen_response.cmi ocsigen_response.cmx : ../http/ocsigen_cookies.cmx ../http/http_headers.cmx \ From 830c54646e13b5209e701bc45f875840b1c7dd82 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 8 Mar 2017 16:10:26 +0100 Subject: [PATCH 035/111] Export Ocsigen_multipart --- src/Makefile.filelist | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Makefile.filelist b/src/Makefile.filelist index c2193e990..1af48ea6d 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -16,6 +16,7 @@ INTF_BASE := baselib/ocsigen_cache.cmi \ \ server/ocsigen_request.cmi \ server/ocsigen_response.cmi \ + server/ocsigen_multipart.cmi \ server/ocsigen_extensions.cmi \ server/ocsigen_parseconfig.cmi \ server/ocsigen_local_files.cmi \ From c9b44682c1cfe6b71607b51efb330db23da11409 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 9 Mar 2017 13:40:12 +0100 Subject: [PATCH 036/111] Share Ocsigen_request.r_post_data_override ref after update --- src/server/ocsigen_request.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 913f6c3fe..d0d9fc9fd 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -27,7 +27,7 @@ type t = { r_request : Cohttp.Request.t ; r_body : Cohttp_lwt_body.t ; r_get_params_override : (string * string list) list option ; - mutable r_post_data_override : post_data Lwt.t option option ; + r_post_data_override : post_data Lwt.t option option ref ; r_original_full_path : string option ; r_sub_path : string option ; r_cookies_override : string Ocsigen_cookies.CookiesTable.t option ; @@ -60,7 +60,7 @@ let make r_request = request ; r_body = body ; r_get_params_override = None ; - r_post_data_override = None ; + r_post_data_override = ref None ; r_sub_path = sub_path ; r_original_full_path = original_full_path ; r_cookies_override = cookies_override ; @@ -122,9 +122,9 @@ let update and r_post_data_override = match post_data_override with | Some (Some post_data_override) -> - Some (Some (Lwt.return post_data_override)) + ref (Some (Some (Lwt.return post_data_override))) | Some None -> - Some None + ref (Some None) | None -> r_post_data_override and r_cookies_override = @@ -283,7 +283,7 @@ let content_type r = None let force_post_data ({r_post_data_override ; r_body} as r) s i = - match r_post_data_override with + match !r_post_data_override with | Some r_post_data_override -> r_post_data_override | None -> @@ -300,7 +300,7 @@ let force_post_data ({r_post_data_override ; r_body} as r) s i = | None -> None in - r.r_post_data_override <- Some v; + r.r_post_data_override := Some v; v let post_params r s i = From 5d9f037ca76d164c82b12912db38c83978de8294 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 21 Mar 2017 12:27:28 +0100 Subject: [PATCH 037/111] Compile userconf against Cohttp --- src/extensions/.depend | 2 +- src/extensions/Makefile | 3 +- src/extensions/userconf.ml | 207 +++++++++++++++++-------------------- 3 files changed, 97 insertions(+), 115 deletions(-) diff --git a/src/extensions/.depend b/src/extensions/.depend index c4fccd4e6..7351baafb 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -38,7 +38,7 @@ handler.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ ../server/ocsigen_extensions.cmi handler.cmi handler.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ ../server/ocsigen_extensions.cmx handler.cmi -handler.cmi : +handler.cmi : ../server/ocsigen_response.cmi ocsigen_comet.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi \ ocsigen_comet.cmi diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 923bb3475..1fc3cd62b 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -23,9 +23,8 @@ all: byte opt ### Extensions ### FILES := accesscontrol.ml authbasic.ml cors.ml handler.ml outputfilter.ml \ - redirectmod.ml revproxy.ml rewritemod.ml staticmod.ml + redirectmod.ml revproxy.ml rewritemod.ml staticmod.ml userconf.ml # cgimod.ml \ - # userconf.ml \ # extendconfiguration.ml \ # ocsigen_comet.ml \ diff --git a/src/extensions/userconf.ml b/src/extensions/userconf.ml index ec51109db..f7911ec82 100644 --- a/src/extensions/userconf.ml +++ b/src/extensions/userconf.ml @@ -16,146 +16,130 @@ * You should have received a copy of the GNU Lesser 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. -*) -(*****************************************************************************) -(*****************************************************************************) -(* Ocsigen module to allow local (users) config files *) -(*****************************************************************************) -(*****************************************************************************) + *) +(* Local (users) config files *) -open Lwt -open Ocsigen_lib -open Ocsigen_extensions +open Lwt.Infix exception NoConfFile let section = Lwt_log.Section.make "ocsigen:ext:userconf" -(*****************************************************************************) let err_500 = - Ocsigen_extensions.Ext_stop_site (Ocsigen_cookies.Cookies.empty, 500) + Ocsigen_extensions.Ext_stop_site + (Ocsigen_cookies.Cookies.empty, `Internal_server_error) - -(* Catch invalid userconf files and report an error *) -let handle_parsing_error req = function +let handle_parsing_error {Ocsigen_extensions.request_info} = function | Ocsigen_extensions.Error_in_config_file s -> Lwt_log.ign_error_f ~section "Syntax error in userconf configuration file for url %s: %s" - (Ocsigen_request_info.url_string req.request_info) s; + (Uri.to_string (Ocsigen_request.uri request_info)) s; Lwt.return err_500 - | Ocsigen_extensions.Error_in_user_config_file s -> Lwt_log.ign_error_f ~section "Unauthorized option in user configuration for url %s: %s" - (Ocsigen_request_info.url_string req.request_info) s; + (Uri.to_string (Ocsigen_request.uri request_info)) s; Lwt.return err_500 - - | e -> Lwt.fail e - + | e -> + Lwt.fail e (* Answer returned by userconf when the url matches *) let subresult new_req user_parse_site conf previous_err req req_state = - Ext_sub_result - (fun cookies_to_set rs -> - (* XXX why is rs above never used ?? *) - Lwt.catch - (fun () -> - user_parse_site conf cookies_to_set - (Ocsigen_extensions.Req_not_found (previous_err, new_req)) - >>= fun (answer, cookies) -> - (* If the request is not satisfied by userconf, the changes - in configuration (in request_config) are preserved for the - remainder of the enclosing (in the Ext_continue - and Ext_found_continue cases below) *) - let rec aux ((answer, cts) as r) = match answer with - | Ext_sub_result sr -> - (* XXX Are these the good cookies ?? *) - sr cookies_to_set req_state - >>= aux - | Ext_continue_with (newreq, cookies, err) -> - Lwt.return - ((Ext_continue_with - ({req with request_config = newreq.request_config }, - cookies, err)), cts) - | Ext_found_continue_with r -> - (* We keep config information outside userconf! *) - Lwt.return - (Ext_found_continue_with - (fun () -> - r () >>= fun (r, newreq) -> Lwt.return - (r, - { req with request_config = newreq.request_config }) - ), cts) - | _ -> Lwt.return r - in aux (answer, cookies) - ) - (fun e -> - handle_parsing_error req e >>= - fun answer -> - Lwt.return (answer, Ocsigen_cookies.Cookies.empty)) - ) - + Ocsigen_extensions.Ext_sub_result (fun cookies_to_set rs -> + (* XXX why is rs above never used ?? *) + Lwt.catch + (fun () -> + user_parse_site conf cookies_to_set + (Ocsigen_extensions.Req_not_found (previous_err, new_req)) + >>= fun (answer, cookies) -> + (* If the request is not satisfied by userconf, the + changes in configuration (in request_config) are + preserved for the remainder of the enclosing (in + the Ext_continue and Ext_found_continue cases below) *) + let rec aux ((answer, cts) as r) = match answer with + | Ocsigen_extensions.Ext_sub_result sr -> + (* XXX Are these the good cookies ?? *) + sr cookies_to_set req_state + >>= aux + | Ocsigen_extensions.Ext_continue_with + ({Ocsigen_extensions.request_config}, cookies, err) -> + Lwt.return + ((Ocsigen_extensions.Ext_continue_with + ({req with Ocsigen_extensions.request_config}, + cookies, err)), cts) + | Ocsigen_extensions.Ext_found_continue_with r -> + (* We keep config information outside userconf! *) + Lwt.return + (Ocsigen_extensions.Ext_found_continue_with + (fun () -> + r () >|= fun (r, {Ocsigen_extensions.request_config}) -> + r, { req with Ocsigen_extensions.request_config } + ), cts) + | _ -> + Lwt.return r + in aux (answer, cookies) + ) + (fun e -> + handle_parsing_error req e >>= + fun answer -> + Lwt.return (answer, Ocsigen_cookies.Cookies.empty)) + ) let conf_to_xml conf = - try Simplexmlparser.xmlparser_file conf - with - | Sys_error _ -> raise NoConfFile + try Simplexmlparser.xmlparser_file conf with + | Sys_error _ -> + raise NoConfFile | Simplexmlparser.Xml_parser_error s -> raise (Ocsigen_extensions.Error_in_config_file s) - -let gen hostpattern sitepath (regexp, conf, url, prefix, localpath) = function - | Req_found _ -> +let gen hostpattern sitepath (regexp, conf, url, prefix, localpath) = + function + | Ocsigen_extensions.Req_found _ -> (* We do not allow setting filters through userconf files right now *) - Lwt.return Ext_do_nothing - - | Req_not_found (previous_err, req) as req_state-> - let path = (Ocsigen_request_info.sub_path_string req.request_info) in - match Netstring_pcre.string_match regexp path 0 with - | None -> Lwt.return (Ext_next previous_err) - | Some _ -> - try - Lwt_log.ign_info ~section "Using user configuration"; - let conf0 = Ocsigen_extensions.replace_user_dir regexp conf path in - let url = Netstring_pcre.global_replace regexp url path - and prefix = Netstring_pcre.global_replace regexp prefix path - and userconf_options = { - Ocsigen_extensions.localfiles_root = - Ocsigen_extensions.replace_user_dir regexp localpath path } - and conf = conf_to_xml conf0 - in - let user_parse_host = Ocsigen_extensions.parse_user_site_item - userconf_options hostpattern req.request_config in - (* Inside userconf, we create a new virtual site starting - after [prefix], and use a request modified accordingly*) - let user_parse_site = Ocsigen_extensions.make_parse_config - (sitepath@[prefix]) user_parse_host - and path = - Url.remove_slash_at_beginning - (Url.remove_dotdot (Neturl.split_path url)) - in - let new_req = - { req with request_info = - (Ocsigen_request_info.update req.request_info - ~sub_path:path - ~sub_path_string:url ())} - in - Lwt.return - (subresult new_req user_parse_site conf previous_err req req_state) - + Lwt.return Ocsigen_extensions.Ext_do_nothing + | Ocsigen_extensions.Req_not_found + (previous_err, + ({Ocsigen_extensions.request_info ; + request_config} as req)) as req_state -> + let path = (Ocsigen_request.sub_path_string request_info) in + match Netstring_pcre.string_match regexp path 0 with + | None -> Lwt.return (Ocsigen_extensions.Ext_next previous_err) + | Some _ -> + try + Lwt_log.ign_info ~section "Using user configuration"; + let conf0 = Ocsigen_extensions.replace_user_dir regexp conf path in + let uri = + Uri.of_string + (Netstring_pcre.global_replace regexp url path) + and prefix = Netstring_pcre.global_replace regexp prefix path + and userconf_options = { + Ocsigen_extensions.localfiles_root = + Ocsigen_extensions.replace_user_dir regexp localpath path } + and conf = conf_to_xml conf0 in + let user_parse_host = + Ocsigen_extensions.parse_user_site_item + userconf_options hostpattern request_config in + (* Inside userconf, we create a new virtual site starting + after [prefix], and use a request modified accordingly*) + let user_parse_site = + Ocsigen_extensions.make_parse_config + (sitepath @ [prefix]) user_parse_host + and req = + { req with + Ocsigen_extensions.request_info = + Ocsigen_request.update ~uri request_info } + in + Lwt.return + (subresult req user_parse_site conf previous_err req req_state) with | Ocsigen_extensions.NoSuchUser | NoConfFile | Unix.Unix_error (Unix.EACCES,_,_) | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return (Ocsigen_extensions.Ext_next previous_err) - | e -> handle_parsing_error req e - - - -(*****************************************************************************) -(** Parsing of config file *) + | e -> + handle_parsing_error req e let parse_config hostpattern _ path _ _ config_elem = let regexp = ref None in @@ -204,13 +188,12 @@ let parse_config hostpattern _ path _ _ config_elem = let info = match !regexp, !conf, !url, !prefix, !localpath with | (Some r, Some t, Some u, Some p, Some p') -> (r, t, u, p, p') - | _ -> badconfig "Missing attributes for " + | _ -> Ocsigen_extensions.badconfig "Missing attributes for " in gen hostpattern path info -(*****************************************************************************) -(** extension registration *) -let () = register_extension +let () = + Ocsigen_extensions.register_extension ~name:"userconf" ~fun_site:parse_config () From 0c005b55bf667bc16185bceb78e06af66ecc6af8 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 21 Mar 2017 12:52:53 +0100 Subject: [PATCH 038/111] Re-enable extendconfiguration and partially fix style --- src/extensions/Makefile | 10 +- src/extensions/extendconfiguration.ml | 283 ++++++++++++++------------ 2 files changed, 160 insertions(+), 133 deletions(-) diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 1fc3cd62b..a5f1d9f69 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -22,11 +22,11 @@ all: byte opt ### Extensions ### -FILES := accesscontrol.ml authbasic.ml cors.ml handler.ml outputfilter.ml \ - redirectmod.ml revproxy.ml rewritemod.ml staticmod.ml userconf.ml - # cgimod.ml \ - # extendconfiguration.ml \ - # ocsigen_comet.ml \ +FILES := accesscontrol.ml authbasic.ml cors.ml extendconfiguration.ml \ + handler.ml outputfilter.ml redirectmod.ml revproxy.ml \ + rewritemod.ml staticmod.ml userconf.ml +# cgimod.ml \ +# ocsigen_comet.ml \ ifeq "$(CAMLZIP)" "YES" FILES += deflatemod.ml diff --git a/src/extensions/extendconfiguration.ml b/src/extensions/extendconfiguration.ml index 8de0e7dd7..b36536c15 100644 --- a/src/extensions/extendconfiguration.ml +++ b/src/extensions/extendconfiguration.ml @@ -16,31 +16,29 @@ * You should have received a copy of the GNU Lesser 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 Lwt -open Ocsigen_extensions -open Simplexmlparser -open Ocsigen_charset_mime + *) +open Lwt.Infix -let bad_config s = raise (Error_in_config_file s) +let bad_config s = raise (Ocsigen_extensions.Error_in_config_file s) let gen configfun = function | Ocsigen_extensions.Req_found _ -> Lwt.return Ocsigen_extensions.Ext_do_nothing - | Ocsigen_extensions.Req_not_found (err, request) -> + | Ocsigen_extensions.Req_not_found + (err, ({Ocsigen_extensions.request_config} as request)) -> Lwt_log.ign_info "Updating configuration"; - let updated_request = { request with request_config = - configfun request.request_config } + let request = + { request with + Ocsigen_extensions.request_config = + configfun request_config } in Lwt.return (Ocsigen_extensions.Ext_continue_with - (updated_request, + (request, Ocsigen_cookies.Cookies.empty, - err - )) - + err)) let gather_do_not_serve_files tag = let rec aux (regexps, files, extensions) = function @@ -49,176 +47,205 @@ let gather_do_not_serve_files tag = do_not_serve_files = files; do_not_serve_extensions = extensions } - - | Element ("regexp", ["regexp", f], []) :: q -> + | Simplexmlparser.Element ("regexp", ["regexp", f], []) :: q -> aux (f :: regexps, files, extensions) q - | Element ("file", ["file", f], []) :: q -> + | Simplexmlparser.Element ("file", ["file", f], []) :: q -> aux (regexps, f :: files, extensions) q - | Element ("extension", ["ext", f], []) :: q -> + | Simplexmlparser.Element ("extension", ["ext", f], []) :: q -> aux (regexps, files, f :: extensions) q | _ :: q -> bad_config ("invalid options in tag " ^ tag) - in aux ([], [], []) - - + in + aux ([], [], []) exception Bad_regexp of string let check_regexp_list = let hashtbl = Hashtbl.create 17 in - let aux r = - try Hashtbl.find hashtbl r - with Not_found -> - try - ignore (Netstring_pcre.regexp r); - Hashtbl.add hashtbl r () - with _ -> raise (Bad_regexp r) - in - (fun l -> List.iter aux l) - - -let update_config usermode = function - | Element ("listdirs", ["value", "true"], []) -> - gen (fun config -> { config with list_directory_content = true }) - | Element ("listdirs", ["value", "false"], []) -> - gen (fun config -> { config with list_directory_content = false }) - | Element ("listdirs" as s, _, _) -> badconfig "Bad syntax for tag %s" s - - - | Element ("followsymlinks", ["value", s], []) -> + List.iter @@ fun r -> + try Hashtbl.find hashtbl r + with Not_found -> + try + ignore (Netstring_pcre.regexp r); + Hashtbl.add hashtbl r () + with _ -> raise (Bad_regexp r) + +let parse_config usermode _ _ _ = function + | Simplexmlparser.Element ("listdirs", ["value", "true"], []) -> + gen @@ fun config -> + { config with Ocsigen_extensions.list_directory_content = true } + | Simplexmlparser.Element ("listdirs", ["value", "false"], []) -> + gen @@ fun config -> + { config with Ocsigen_extensions.list_directory_content = false } + | Simplexmlparser.Element ("listdirs" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + | Simplexmlparser.Element ("followsymlinks", ["value", s], []) -> let v = match s with - | "never" -> DoNotFollowSymlinks + | "never" -> + Ocsigen_extensions.DoNotFollowSymlinks | "always" -> - if usermode = false then - AlwaysFollowSymlinks + if not usermode then + Ocsigen_extensions.AlwaysFollowSymlinks else - raise (Error_in_user_config_file - "Cannot specify value 'always' for option \ - 'followsymlinks' in userconf files") - | "ownermatch" -> FollowSymlinksIfOwnerMatch + raise + (Ocsigen_extensions.Error_in_user_config_file + "Cannot specify value 'always' for option \ + 'followsymlinks' in userconf files") + | "ownermatch" -> + Ocsigen_extensions.FollowSymlinksIfOwnerMatch | _ -> bad_config ("Wrong value \""^s^"\" for option \"followsymlinks\"") in - gen (fun config -> { config with follow_symlinks = v }) - | Element ("followsymlinks" as s, _, _) -> badconfig "Bad syntax for tag %s" s - - - | Element ("charset", attrs, exts) -> + gen @@ fun config -> + { config with Ocsigen_extensions.follow_symlinks = v } + | Simplexmlparser.Element ("followsymlinks" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + | Simplexmlparser.Element ("charset", attrs, exts) -> let rec aux charset_assoc = function | [] -> charset_assoc - | Element ("extension", ["ext", extension; "value", charset], []) :: q -> - aux (update_charset_ext charset_assoc extension charset) q - | Element ("file", ["file", file; "value", charset], []) :: q -> - aux (update_charset_file charset_assoc file charset) q - | Element ("regexp", ["regexp", regexp; "value", charset], []) :: q -> + | Simplexmlparser.Element + ("extension", ["ext", extension; "value", charset], []) :: q -> + aux + (Ocsigen_charset_mime.update_charset_ext + charset_assoc extension charset) q + | Simplexmlparser.Element + ("file", ["file", file; "value", charset], []) :: q -> + aux + (Ocsigen_charset_mime.update_charset_file + charset_assoc file charset) + q + | Simplexmlparser.Element + ("regexp", ["regexp", regexp; "value", charset], []) :: q -> (try let r = Netstring_pcre.regexp regexp in - aux (update_charset_regexp charset_assoc r charset) q + aux + (Ocsigen_charset_mime.update_charset_regexp + charset_assoc r charset) + q with _ -> bad_config "invalid regexp '%s' in ") | _ :: q -> bad_config "invalid subtag in option charset" in gen (fun config -> - let config = match attrs with - | ["default", s] -> - { config with charset_assoc = - set_default_charset config.charset_assoc s } - | [] -> config - | _ -> bad_config "Only attribute \"default\" is permitted \ - for option \"charset\"" - in - { config with charset_assoc = aux config.charset_assoc exts }) - - - | Element ("contenttype", attrs, exts) -> + let config = match attrs with + | ["default", s] -> + { config with + Ocsigen_extensions.charset_assoc = + Ocsigen_charset_mime.set_default_charset + config.Ocsigen_extensions.charset_assoc s } + | [] -> + config + | _ -> + bad_config "Only attribute \"default\" is permitted \ + for option \"charset\"" + in + { config with + Ocsigen_extensions.charset_assoc = + aux config.Ocsigen_extensions.charset_assoc exts }) + | Simplexmlparser.Element ("contenttype", attrs, exts) -> let rec aux mime_assoc = function | [] -> mime_assoc - | Element ("extension", ["ext", extension; "value", mime], []) :: q -> - aux (update_mime_ext mime_assoc extension mime) q - | Element ("file", ["file", file; "value", mime], []) :: q -> - aux (update_mime_file mime_assoc file mime) q - | Element ("regexp", ["regexp", regexp; "value", mime], []) :: q -> + | Simplexmlparser.Element + ("extension", ["ext", extension; "value", mime], []) :: q -> + aux + (Ocsigen_charset_mime.update_mime_ext mime_assoc extension mime) + q + | Simplexmlparser.Element + ("file", ["file", file; "value", mime], []) :: q -> + aux (Ocsigen_charset_mime.update_mime_file mime_assoc file mime) q + | Simplexmlparser.Element + ("regexp", ["regexp", regexp; "value", mime], []) :: q -> (try let r = Netstring_pcre.regexp regexp in - aux (update_mime_regexp mime_assoc r mime) q + aux (Ocsigen_charset_mime.update_mime_regexp mime_assoc r mime) q with _ -> bad_config "invalid regexp '%s' in ") | _ :: q -> bad_config "invalid subtag in option mime" in gen (fun config -> - let config = match attrs with - | ["default", s] -> - { config with mime_assoc = - set_default_mime config.mime_assoc s } - | [] -> config - | _ -> bad_config "Only attribute \"default\" is permitted \ - for option \"contenttype\"" - in - { config with mime_assoc = aux config.mime_assoc exts }) - - - | Element ("defaultindex", [], l) -> + let config = match attrs with + | ["default", s] -> + { config with + Ocsigen_extensions.mime_assoc = + Ocsigen_charset_mime.set_default_mime + config.Ocsigen_extensions.mime_assoc s } + | [] -> config + | _ -> bad_config "Only attribute \"default\" is permitted \ + for option \"contenttype\"" + in + { config with + Ocsigen_extensions.mime_assoc = + aux config.Ocsigen_extensions.mime_assoc exts }) + | Simplexmlparser.Element ("defaultindex", [], l) -> let rec aux indexes = function | [] -> List.rev indexes - | Element ("index", [], [PCData f]) :: q -> + | Simplexmlparser.Element + ("index", [], [Simplexmlparser.PCData f]) :: q -> aux (f :: indexes) q | _ :: q -> bad_config "subtags must be of the form \ ... \ in option defaultindex" in gen (fun config -> - { config with default_directory_index = aux [] l }) - | Element ("defaultindex" as s, _, _) -> badconfig "Bad syntax for tag %s" s - - | Element ("hidefile", [], l) -> + { config with + Ocsigen_extensions.default_directory_index = aux [] l }) + | Simplexmlparser.Element ("defaultindex" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + | Simplexmlparser.Element ("hidefile", [], l) -> let do_not_serve = gather_do_not_serve_files "hidefile" l in (try - check_regexp_list do_not_serve.do_not_serve_regexps; + check_regexp_list + do_not_serve.Ocsigen_extensions.do_not_serve_regexps; gen (fun config -> - { config with do_not_serve_404 = - join_do_not_serve do_not_serve config.do_not_serve_404 }) + { config with + Ocsigen_extensions.do_not_serve_404 = + Ocsigen_extensions.join_do_not_serve + do_not_serve + config.Ocsigen_extensions.do_not_serve_404 }) with Bad_regexp r -> - badconfig "Invalid regexp %s in %s" r "hidefile") - | Element ("hidefile" as s, _, _) -> badconfig "Bad syntax for tag %s" s - - | Element ("forbidfile", [], l) -> + Ocsigen_extensions.badconfig "Invalid regexp %s in %s" r "hidefile") + | Simplexmlparser.Element ("hidefile" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + | Simplexmlparser.Element ("forbidfile", [], l) -> let do_not_serve = gather_do_not_serve_files "forbidfile" l in (try - check_regexp_list do_not_serve.do_not_serve_regexps; + check_regexp_list + do_not_serve.Ocsigen_extensions.do_not_serve_regexps; gen (fun config -> - { config with do_not_serve_403 = - join_do_not_serve do_not_serve config.do_not_serve_403 }) + { config with + Ocsigen_extensions.do_not_serve_403 = + Ocsigen_extensions.join_do_not_serve + do_not_serve config.Ocsigen_extensions.do_not_serve_403 + }) with Bad_regexp r -> - badconfig "Invalid regexp %s in %s" r "forbidfile") - | Element ("forbidfile" as s, _, _) -> badconfig "Bad syntax for tag %s" s - - | Element ("uploaddir", [], [PCData s]) -> - if s = "" then - gen (fun config -> { config with uploaddir = None }) + Ocsigen_extensions.badconfig "Invalid regexp %s in %s" r "forbidfile") + | Simplexmlparser.Element ("forbidfile" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + | Simplexmlparser.Element + ("uploaddir", [], [Simplexmlparser.PCData s]) -> + gen @@ if s = "" then + fun config -> { config with Ocsigen_extensions.uploaddir = None } else - gen (fun config -> { config with uploaddir = Some s }) - | Element ("uploaddir" as s, _, _) -> - badconfig "Bad syntax for tag %s" s - - | Element ("maxuploadfilesize" as tag, [], [PCData s]) -> + fun config -> { config with Ocsigen_extensions.uploaddir = Some s } + | Simplexmlparser.Element ("uploaddir" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + | Simplexmlparser.Element + ("maxuploadfilesize" as tag, [], [Simplexmlparser.PCData s]) -> let s = try Ocsigen_parseconfig.parse_size_tag "uploaddir" s with Ocsigen_config.Config_file_error _ -> - badconfig "Bad syntax for tag %s" tag + Ocsigen_extensions.badconfig "Bad syntax for tag %s" tag in - gen (fun config -> { config with maxuploadfilesize = s }) - | Element ("maxuploadfilesize" as s, _, _) -> - badconfig "Bad syntax for tag %s" s - - - | Element (t, _, _) -> raise (Bad_config_tag_for_extension t) + gen @@ fun config -> + { config with Ocsigen_extensions.maxuploadfilesize = s } + | Simplexmlparser.Element ("maxuploadfilesize" as s, _, _) -> + Ocsigen_extensions.badconfig "Bad syntax for tag %s" s + | Simplexmlparser.Element (t, _, _) -> + raise (Ocsigen_extensions.Bad_config_tag_for_extension t) | _ -> - raise (Error_in_config_file "Unexpected data in config file") - - -let parse_config usermode : parse_config_aux = fun _ _ _ xml -> - update_config usermode xml - + raise (Ocsigen_extensions.Error_in_config_file + "Unexpected data in config file") -let () = register_extension +let () = + Ocsigen_extensions.register_extension ~name:"extendconfiguration" ~fun_site:(fun _ _ -> parse_config false) ~user_fun_site:(fun path _ _ -> parse_config true) From e4e2415fbf6f95c4183439a8d0ddca602f3192df Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 21 Mar 2017 15:47:14 +0100 Subject: [PATCH 039/111] Http_headers becomes Ocsigen_header (& reorg) --- src/Makefile.filelist | 2 +- src/extensions/.depend | 56 ++++++------ src/extensions/accesscontrol.ml | 6 +- src/extensions/authbasic.ml | 7 +- src/extensions/cors.ml | 22 +++-- src/extensions/outputfilter.ml | 10 ++- src/extensions/revproxy.ml | 8 +- src/extensions/staticmod.ml | 4 +- src/http/.depend | 6 +- src/http/Makefile | 4 +- src/http/http_headers.ml | 140 ----------------------------- src/http/http_headers.mli | 121 ------------------------- src/http/ocsigen_header.ml | 152 ++++++++++++++++++++++++++++++++ src/http/ocsigen_header.mli | 93 +++++++++++++++++++ src/server/.depend | 25 +++--- src/server/ocsigen_cohttp.ml | 11 ++- src/server/ocsigen_request.ml | 10 +-- src/server/ocsigen_request.mli | 6 +- src/server/ocsigen_response.ml | 14 +-- src/server/ocsigen_response.mli | 14 +-- 20 files changed, 349 insertions(+), 362 deletions(-) delete mode 100644 src/http/http_headers.ml delete mode 100644 src/http/http_headers.mli create mode 100644 src/http/ocsigen_header.ml create mode 100644 src/http/ocsigen_header.mli diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 1af48ea6d..c2ec568dc 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -10,9 +10,9 @@ INTF_BASE := baselib/ocsigen_cache.cmi \ baselib/ocsigen_loader.cmi \ baselib/polytables.cmi \ \ - http/http_headers.cmi \ http/ocsigen_charset_mime.cmi \ http/ocsigen_cookies.cmi \ + http/ocsigen_header.cmi \ \ server/ocsigen_request.cmi \ server/ocsigen_response.cmi \ diff --git a/src/extensions/.depend b/src/extensions/.depend index 7351baafb..4799b0df7 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -1,33 +1,33 @@ accesscontrol.cmo : ../server/ocsigen_response.cmi \ ../server/ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ - ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ - ../http/http_headers.cmi accesscontrol.cmi + ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi \ + ../http/ocsigen_cookies.cmi accesscontrol.cmi accesscontrol.cmx : ../server/ocsigen_response.cmx \ ../server/ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ - ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ - ../http/http_headers.cmx accesscontrol.cmi + ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx \ + ../http/ocsigen_cookies.cmx accesscontrol.cmi accesscontrol.cmi : -authbasic.cmo : ../server/ocsigen_request.cmi \ +authbasic.cmo : ../server/ocsigen_request.cmi ../http/ocsigen_header.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ - ../server/ocsigen_cohttp.cmi ../http/http_headers.cmi authbasic.cmi -authbasic.cmx : ../server/ocsigen_request.cmx \ + ../server/ocsigen_cohttp.cmi authbasic.cmi +authbasic.cmx : ../server/ocsigen_request.cmx ../http/ocsigen_header.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ - ../server/ocsigen_cohttp.cmx ../http/http_headers.cmx authbasic.cmi + ../server/ocsigen_cohttp.cmx authbasic.cmi authbasic.cmi : cgimod.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ - ../baselib/ocsigen_config.cmi ../http/http_headers.cmi + ../baselib/ocsigen_config.cmi cgimod.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ - ../baselib/ocsigen_config.cmx ../http/http_headers.cmx + ../baselib/ocsigen_config.cmx cors.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ - ../server/ocsigen_extensions.cmi ../http/http_headers.cmi + ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi cors.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ - ../server/ocsigen_extensions.cmx ../http/http_headers.cmx + ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx deflatemod.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ - ../server/ocsigen_extensions.cmi ../http/http_headers.cmi + ../server/ocsigen_extensions.cmi deflatemod.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ - ../server/ocsigen_extensions.cmx ../http/http_headers.cmx + ../server/ocsigen_extensions.cmx extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ ../baselib/ocsigen_config.cmi ../http/ocsigen_charset_mime.cmi @@ -47,31 +47,31 @@ ocsigen_comet.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ ocsigen_comet.cmi ocsigen_comet.cmi : ../baselib/ocsigen_stream.cmi ocsipersist.cmi : -outputfilter.cmo : ../server/ocsigen_response.cmi \ - ../server/ocsigen_extensions.cmi ../http/http_headers.cmi -outputfilter.cmx : ../server/ocsigen_response.cmx \ - ../server/ocsigen_extensions.cmx ../http/http_headers.cmx +outputfilter.cmo : ../server/ocsigen_response.cmi ../http/ocsigen_header.cmi \ + ../server/ocsigen_extensions.cmi +outputfilter.cmx : ../server/ocsigen_response.cmx ../http/ocsigen_header.cmx \ + ../server/ocsigen_extensions.cmx redirectmod.cmo : ../server/ocsigen_response.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi redirectmod.cmx : ../server/ocsigen_response.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx revproxy.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ - ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi \ - ../http/http_headers.cmi + ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ + ../server/ocsigen_extensions.cmi revproxy.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ - ../baselib/ocsigen_lib.cmx ../server/ocsigen_extensions.cmx \ - ../http/http_headers.cmx + ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ + ../server/ocsigen_extensions.cmx rewritemod.cmo : ../server/ocsigen_request.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi rewritemod.cmx : ../server/ocsigen_request.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx staticmod.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ ../server/ocsigen_local_files.cmi ../baselib/ocsigen_lib.cmi \ - ../server/ocsigen_extensions.cmi ../http/http_headers.cmi + ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi staticmod.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ ../server/ocsigen_local_files.cmx ../baselib/ocsigen_lib.cmx \ - ../server/ocsigen_extensions.cmx ../http/http_headers.cmx -userconf.cmo : ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi \ - ../http/ocsigen_cookies.cmi -userconf.cmx : ../baselib/ocsigen_lib.cmx ../server/ocsigen_extensions.cmx \ - ../http/ocsigen_cookies.cmx + ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx +userconf.cmo : ../server/ocsigen_request.cmi \ + ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi +userconf.cmx : ../server/ocsigen_request.cmx \ + ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index 26405ecf8..4a4b12816 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -111,7 +111,7 @@ let rec parse_condition = function Lwt_log.ign_info_f "HEADER: header %s matches %S" name reg; r) (Ocsigen_request.header_multi ri - (Http_headers.name name)) + (Ocsigen_header.Name.of_string name)) in if not r then Lwt_log.ign_info_f "HEADER: header %s does not match %S" name reg; @@ -330,7 +330,7 @@ let parse_config parse_fun = function let header = Ocsigen_request.header request_info - Http_headers.x_forwarded_for + Ocsigen_header.Name.x_forwarded_for in match header with | Some header -> @@ -397,7 +397,7 @@ let parse_config parse_fun = function let header = Ocsigen_request.header request_info - Http_headers.x_forwarded_proto + Ocsigen_header.Name.x_forwarded_proto in match header with | Some header -> diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index 5131518dd..dd35e2677 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -61,10 +61,9 @@ let gen ~realm ~auth rs = let reject () = let h = - Http_headers.add - (Http_headers.name "WWW-Authenticate") + Cohttp.Header.init_with + "WWW-Authenticate" (Printf.sprintf "Basic realm=\"%s\"" realm) - Http_headers.empty in Lwt_log.ign_info ~section "AUTH: invalid credentials!"; Lwt.fail (Ocsigen_cohttp.Ext_http_error @@ -96,7 +95,7 @@ let gen ~realm ~auth rs = (match Ocsigen_request.header ri.Ocsigen_extensions.request_info - Http_headers.authorization + Ocsigen_header.Name.authorization with | Some s -> validate ~err s diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index 01edc9961..04e707023 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -41,7 +41,7 @@ exception Refused let add_headers config r response = - match Ocsigen_request.header r Http_headers.origin with + match Ocsigen_request.header r Ocsigen_header.Name.origin with | None -> Lwt.return Ocsigen_extensions.Ext_do_nothing @@ -50,11 +50,11 @@ let add_headers config r response = Lwt_log.ign_info_f ~section "request with origin: %s" origin; - let l = [Http_headers.origin, origin] in + let l = [Ocsigen_header.Name.origin, origin] in let l = if config.allowed_credentials then - (Http_headers.access_control_allow_credentials, "true") :: l + (Ocsigen_header.Name.access_control_allow_credentials, "true") :: l else l in @@ -62,7 +62,7 @@ let add_headers config r response = let l = match Ocsigen_request.header r - Http_headers.access_control_request_method + Ocsigen_header.Name.access_control_request_method with | Some request_method -> let allowed_method = @@ -76,7 +76,9 @@ let add_headers config r response = false in if allowed_method then - (Http_headers.access_control_allow_methods, request_method) :: l + (Ocsigen_header.Name.access_control_allow_methods, + request_method) + :: l else (Lwt_log.ign_info ~section "Method refused"; raise Refused) @@ -87,10 +89,11 @@ let add_headers config r response = let l = match Ocsigen_request.header r - Http_headers.access_control_request_headers + Ocsigen_header.Name.access_control_request_headers with | Some request_headers -> - (Http_headers.access_control_request_headers, request_headers) :: l + (Ocsigen_header.Name.access_control_request_headers, + request_headers) :: l | None -> l in @@ -98,7 +101,8 @@ let add_headers config r response = let l = match config.max_age with | Some max_age -> - (Http_headers.access_control_max_age, string_of_int max_age) :: l + (Ocsigen_header.Name.access_control_max_age, + string_of_int max_age) :: l | None -> l in @@ -108,7 +112,7 @@ let add_headers config r response = | [] -> l | exposed_headers -> - (Http_headers.access_control_expose_headers, + (Ocsigen_header.Name.access_control_expose_headers, String.concat ", " exposed_headers) :: l diff --git a/src/extensions/outputfilter.ml b/src/extensions/outputfilter.ml index c1baeeaed..41b59149f 100644 --- a/src/extensions/outputfilter.ml +++ b/src/extensions/outputfilter.ml @@ -21,8 +21,10 @@ (* This module enables rewritting the server output *) type outputfilter = - | Rewrite_header of (Http_headers.name * Netstring_pcre.regexp * string) - | Add_header of (Http_headers.name * string * bool option) + | Rewrite_header of + (Ocsigen_header.Name.t * Netstring_pcre.regexp * string) + | Add_header of + (Ocsigen_header.Name.t * string * bool option) let gen filter = function | Ocsigen_extensions.Req_not_found (code, _) -> @@ -123,9 +125,9 @@ let parse_config config_elem = "Wrong attributes for : attributes regexp and \ replace can't be set simultaneously" | (Some h, Some r, Some d, None) -> - gen (Rewrite_header (Http_headers.name h, r, d)) + gen (Rewrite_header (Ocsigen_header.Name.of_string h, r, d)) | (Some h, None, Some d, rep) -> - gen (Add_header (Http_headers.name h, d, rep)) + gen (Add_header (Ocsigen_header.Name.of_string h, d, rep)) | _ -> Ocsigen_extensions.badconfig "Wrong attributes for Cohttp.Code.string_of_version - |> Cohttp.Header.add h Http_headers.(name_to_string - x_forwarded_proto) + |> Cohttp.Header.add h + Ocsigen_header.Name.(to_string x_forwarded_proto) in let h = Cohttp.Header.add h - Http_headers.(name_to_string x_forwarded_for) + Ocsigen_header.Name.(to_string x_forwarded_for) forward in - Cohttp.Header.remove h Http_headers.(name_to_string host) + Cohttp.Header.remove h Ocsigen_header.Name.(to_string host) and uri = Printf.sprintf "%s://%s%s" proto host uri and body = Ocsigen_request.body request_info and meth = Ocsigen_request.meth request_info in diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 2b88d1392..92afa226a 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -168,8 +168,8 @@ let gen ~usermode ?cache dir = function gmt_date (Unix.time () +. float_of_int duration) in Ocsigen_response.replace_headers answer [ - Http_headers.cache_control , cache_control ; - Http_headers.expires , expires ; + Ocsigen_header.Name.cache_control , cache_control ; + Ocsigen_header.Name.expires , expires ; ] in Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return answer)) diff --git a/src/http/.depend b/src/http/.depend index 7dec1b7a2..5c9d195f0 100644 --- a/src/http/.depend +++ b/src/http/.depend @@ -1,6 +1,3 @@ -http_headers.cmo : http_headers.cmi -http_headers.cmx : http_headers.cmi -http_headers.cmi : ocsigen_charset_mime.cmo : ../baselib/ocsigen_lib.cmi \ ../baselib/ocsigen_config.cmi ocsigen_charset_mime.cmi ocsigen_charset_mime.cmx : ../baselib/ocsigen_lib.cmx \ @@ -9,3 +6,6 @@ ocsigen_charset_mime.cmi : ocsigen_cookies.cmo : ocsigen_cookies.cmi ocsigen_cookies.cmx : ocsigen_cookies.cmi ocsigen_cookies.cmi : ../baselib/ocsigen_lib.cmi +ocsigen_header.cmo : ../baselib/ocsigen_lib.cmi ocsigen_header.cmi +ocsigen_header.cmx : ../baselib/ocsigen_lib.cmx ocsigen_header.cmi +ocsigen_header.cmi : diff --git a/src/http/Makefile b/src/http/Makefile index b41855021..df473540c 100644 --- a/src/http/Makefile +++ b/src/http/Makefile @@ -17,9 +17,7 @@ all: byte opt ### Common files ### -FILES := http_headers.ml \ - ocsigen_cookies.ml \ - ocsigen_charset_mime.ml +FILES := ocsigen_cookies.ml ocsigen_charset_mime.ml ocsigen_header.ml PREDEP := diff --git a/src/http/http_headers.ml b/src/http/http_headers.ml deleted file mode 100644 index ee58e0b86..000000000 --- a/src/http/http_headers.ml +++ /dev/null @@ -1,140 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * Module http_headers.mli - * Copyright (C) 2007 Jérôme Vouillon - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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 name = string -let name : string -> name = String.lowercase -let name_to_string (nm : name) : string = nm - -let accept = name "Accept" -let accept_charset = name "Accept-Charset" -let accept_encoding = name "Accept-Encoding" -let accept_language = name "Accept-Language" -let accept_ranges = name "Accept-Ranges" -let authorization = name "Authorization" -let cache_control = name "Cache-Control" -let connection = name "Connection" -let content_disposition = name "Content-Disposition" -let content_encoding = name "Content-Encoding" -let content_range = name "Content-Range" -let content_length = name "Content-Length" -let content_type = name "Content-Type" -let cookie = name "Cookie" -let date = name "Date" -let etag = name "ETag" -let expect = name "Expect" -let expires = name "Expires" -let host = name "Host" -let if_match = name "If-Match" -let if_modified_since = name "If-Modified-Since" -let if_none_match = name "If-None-Match" -let if_unmodified_since = name "If-Unmodified-Since" -let if_range = name "If-Range" -let last_modified = name "Last-Modified" -let location = name "Location" -let pragma = name "Pragma" -let server = name "Server" -let set_cookie = name "Set-Cookie" -let status = name "Status" -let transfer_encoding = name "Transfer-Encoding" -let user_agent = name "User-Agent" -let referer = name "Referer" -let range = name "Range" -let x_forwarded_for = name "X-Forwarded-For" -let x_forwarded_proto = name "X-Forwarded-Proto" - -(* CORS headers *) -let origin = name "Origin" -let access_control_request_method = name "Access-Control-Request-Method" -let access_control_request_headers = name "Access-Control-Request-Headers" - -let access_control_allow_origin = name "Access-Control-Allow-Origin" -let access_control_allow_credentials = name "Access-Control-Allow-Credentials" -let access_control_expose_headers = name "Access-Control-Expose-Headers" -let access_control_max_age = name "Access-Control-Max-Age" -let access_control_allow_methods = name "Access-Control-Allow-Methods" -let access_control_allow_headers = name "Access-Control-Allow-Headers" - -module NameHtbl = - Hashtbl.Make - (struct - type t = name - let equal n n' = n = n' - let hash n = Hashtbl.hash n - end) - -(****) - -type t = Cohttp.Header.t - -let empty = Cohttp.Header.init () - -let find_all name map = - let l = List.rev (Cohttp.Header.get_multi map name) in - if l = [] then raise Not_found; - l - -(*XXX We currently return the last header. - Should we fail if there is more than one? *) - -let find name map = match Cohttp.Header.get_multi map name with - | value :: _ -> value - | _ -> raise Not_found - -let replace name value map = Cohttp.Header.replace map name value -let replace_opt name value map = match value with - | None -> Cohttp.Header.remove map name - | Some value -> replace name value map - -let add name value map = Cohttp.Header.add map name value - -let iter func map = - Cohttp.Header.iter - (fun name values -> List.iter (func name) values) - map - -(* XXX: - * old fold: (name -> string list -> 'a -> 'a) -> t -> 'a -> 'a - * new fold: (string -> string -> 'a -> 'a) -> t -> 'a -> 'a *) -let fold' func map acc = Cohttp.Header.fold func map acc - -let fold func map acc = - let ( |> ) a f = f a in - let garbage = Cohttp.Header.fold - (fun key value garbage -> - try List.assoc key garbage - |> fun rest -> - (key, value :: rest) :: (List.remove_assoc key garbage) - with Not_found -> (key, [ value ]) :: garbage) - map [] - in List.fold_left (fun acc (key, values) -> func key values acc) acc garbage - -let with_defaults h h' = fold' add h h' - -let (<<) h (n, v) = replace n v h - -let dyn_headers = - empty - << (cache_control, "no-cache") - << (expires, "0") - -type accept = - ( (string option * string option) - * float option - * (string * string) list ) list diff --git a/src/http/http_headers.mli b/src/http/http_headers.mli deleted file mode 100644 index 0c21528f0..000000000 --- a/src/http/http_headers.mli +++ /dev/null @@ -1,121 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * Module http_headers.mli - * Copyright (C) 2007 Jérôme Vouillon - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - - -(*XXX Can have multiple headers with the same name...*) -type name - -val name : string -> name -val name_to_string : name -> string - -module NameHtbl : Hashtbl.S with type key = name - -(****) - -val accept : name -val accept_charset : name -val accept_encoding : name -val accept_language : name -val accept_ranges : name -val authorization : name -val cache_control : name -val connection : name -val content_disposition : name -val content_encoding : name -val content_length : name -val content_type : name -val content_range : name -val cookie : name -val date : name -val etag : name -val expect: name -val expires : name -val host : name -val if_match : name -val if_modified_since : name -val if_none_match : name -val if_unmodified_since : name -val if_range : name -val last_modified : name -val location : name -val pragma : name -val server : name -val set_cookie : name -val status : name -val transfer_encoding : name -val user_agent : name -val referer : name -val range : name -val x_forwarded_for : name -val x_forwarded_proto : name - -val origin : name -val access_control_request_method : name -val access_control_request_headers : name - -val access_control_allow_origin : name -val access_control_allow_credentials : name -val access_control_expose_headers : name -val access_control_max_age : name -val access_control_allow_methods : name -val access_control_allow_headers : name - -(****) - -type t = Cohttp.Header.t - -val empty : t -(** returns an empty set of HTTP headers *) - -val add : name -> string -> t -> t -(** [add name s h] adds the header [name: s] to [h]. *) - -val replace : name -> string -> t -> t -(** replace a header by another one. If it does not exist, adds it. *) - -val replace_opt : name -> string option -> t -> t -(** replace or remove a header. *) - -val find : name -> t -> string -(** find one of the values bound to [name] in the HTTP header [t]. - Raise [Not_found] if it is not bound. -*) - -val find_all : name -> t -> string list -(** find all the values bound to [name] in the HTTP header [t]. - Raise [Not_found] if it is not bound. *) - -val iter : (name -> string -> unit) -> t -> unit -val fold : (name -> string list -> 'a -> 'a) -> t -> 'a -> 'a - -val with_defaults : t -> t -> t -(** [with_defaults h1 h2] adds headers from [h1] to [h2]. - If some headers were present, the are replaced by those from [h1]. -*) - - -val dyn_headers : t -(** Headers for dynamic pages (non cachable) *) - -type accept = - ( (string option * string option) - * float option - * (string * string) list ) list - diff --git a/src/http/ocsigen_header.ml b/src/http/ocsigen_header.ml new file mode 100644 index 000000000..45e119014 --- /dev/null +++ b/src/http/ocsigen_header.ml @@ -0,0 +1,152 @@ +(* Ocsigen + * http://www.ocsigen.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser 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 t = Cohttp.Header.t + +let of_option = function Some h -> h | None -> Cohttp.Header.init () + +module Name = struct + + type t = string + + let of_string = String.lowercase + let to_string s = s + + let accept = of_string "Accept" + let accept_charset = of_string "Accept-Charset" + let accept_encoding = of_string "Accept-Encoding" + let accept_language = of_string "Accept-Language" + let accept_ranges = of_string "Accept-Ranges" + let authorization = of_string "Authorization" + let cache_control = of_string "Cache-Control" + let connection = of_string "Connection" + let content_disposition = of_string "Content-Disposition" + let content_encoding = of_string "Content-Encoding" + let content_range = of_string "Content-Range" + let content_length = of_string "Content-Length" + let content_type = of_string "Content-Type" + let cookie = of_string "Cookie" + let date = of_string "Date" + let etag = of_string "ETag" + let expect = of_string "Expect" + let expires = of_string "Expires" + let host = of_string "Host" + let if_match = of_string "If-Match" + let if_modified_since = of_string "If-Modified-Since" + let if_none_match = of_string "If-None-Match" + let if_unmodified_since = of_string "If-Unmodified-Since" + let if_range = of_string "If-Range" + let last_modified = of_string "Last-Modified" + let location = of_string "Location" + let pragma = of_string "Pragma" + let server = of_string "Server" + let set_cookie = of_string "Set-Cookie" + let status = of_string "Status" + let transfer_encoding = of_string "Transfer-Encoding" + let user_agent = of_string "User-Agent" + let referer = of_string "Referer" + let range = of_string "Range" + let x_forwarded_for = of_string "X-Forwarded-For" + let x_forwarded_proto = of_string "X-Forwarded-Proto" + + (* CORS headers *) + let origin = of_string "Origin" + let access_control_request_method = + of_string "Access-Control-Request-Method" + let access_control_request_headers = + of_string "Access-Control-Request-Headers" + let access_control_allow_origin = + of_string "Access-Control-Allow-Origin" + let access_control_allow_credentials = + of_string "Access-Control-Allow-Credentials" + let access_control_expose_headers = + of_string "Access-Control-Expose-Headers" + let access_control_max_age = + of_string "Access-Control-Max-Age" + let access_control_allow_methods = + of_string "Access-Control-Allow-Methods" + let access_control_allow_headers = + of_string "Access-Control-Allow-Headers" + +end + +module Accept = struct + + type t = + ((string option * string option) * + float option * + (string * string) list) list + + let parse_star a = + if a = "*" then + None + else + Some a + + let parse_mime_type a = + let b, c = Ocsigen_lib.String.sep '/' a in + parse_star b, parse_star c + + let parse_extensions parse_name s = + try + let a, b = Ocsigen_lib.String.sep ';' s in + parse_name a, + List.map + (Ocsigen_lib.String.sep '=') + (Ocsigen_lib.String.split ';' b) + with _ -> + parse_name s, [] + + let parse_list_with_extensions parse_name s = + List.map (Ocsigen_lib.String.split ',') s + |> List.flatten + |> List.map (parse_extensions parse_name) + + let parse s = + try + let l = parse_list_with_extensions parse_mime_type s in + let change_quality (a, l) = + try + let q, ll = Ocsigen_lib.List.assoc_remove "q" l in + a, Some (float_of_string q), ll + with _ -> + a, None, l + in + List.map change_quality l + with _ -> [] + +end + +module Content_type = struct + + let choose accept default alt = + try + List.find + (fun content_type -> + let f = function + | (Some a, Some b), _, _ -> + a ^ "/" ^ b = content_type + | _ -> + false + in + List.exists f accept) + (default :: alt) + with Not_found -> + default + +end diff --git a/src/http/ocsigen_header.mli b/src/http/ocsigen_header.mli new file mode 100644 index 000000000..5a75d55b7 --- /dev/null +++ b/src/http/ocsigen_header.mli @@ -0,0 +1,93 @@ +(* Ocsigen + * http://www.ocsigen.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser 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 t = Cohttp.Header.t + +val of_option : t option -> t + +module Name : sig + + type t + + val to_string : t -> string + val of_string : string -> t + + val accept : t + val accept_charset : t + val accept_encoding : t + val accept_language : t + val accept_ranges : t + val authorization : t + val cache_control : t + val connection : t + val content_disposition : t + val content_encoding : t + val content_length : t + val content_type : t + val content_range : t + val cookie : t + val date : t + val etag : t + val expect: t + val expires : t + val host : t + val if_match : t + val if_modified_since : t + val if_none_match : t + val if_unmodified_since : t + val if_range : t + val last_modified : t + val location : t + val pragma : t + val server : t + val set_cookie : t + val status : t + val transfer_encoding : t + val user_agent : t + val referer : t + val range : t + val x_forwarded_for : t + val x_forwarded_proto : t + val origin : t + val access_control_request_method : t + val access_control_request_headers : t + val access_control_allow_origin : t + val access_control_allow_credentials : t + val access_control_expose_headers : t + val access_control_max_age : t + val access_control_allow_methods : t + val access_control_allow_headers : t + +end + +module Accept : sig + + type t = + ((string option * string option) + * float option + * (string * string) list) list + + val parse : string list -> t + +end + +module Content_type : sig + + val choose : Accept.t -> string -> string list -> string + +end diff --git a/src/server/.depend b/src/server/.depend index 939d0f6f0..7bc9e7f51 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -1,9 +1,9 @@ ocsigen_cohttp.cmo : ../baselib/ocsigen_stream.cmi ocsigen_socket.cmi \ ocsigen_response.cmi ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_cookies.cmi ../http/http_headers.cmi ocsigen_cohttp.cmi + ../http/ocsigen_header.cmi ../http/ocsigen_cookies.cmi ocsigen_cohttp.cmi ocsigen_cohttp.cmx : ../baselib/ocsigen_stream.cmx ocsigen_socket.cmx \ ocsigen_response.cmx ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_cookies.cmx ../http/http_headers.cmx ocsigen_cohttp.cmi + ../http/ocsigen_header.cmx ../http/ocsigen_cookies.cmx ocsigen_cohttp.cmi ocsigen_cohttp.cmi : ocsigen_socket.cmi ocsigen_response.cmi \ ocsigen_request.cmi ../http/ocsigen_cookies.cmi ocsigen_command.cmo : ../baselib/ocsigen_messages.cmi ocsigen_command.cmi @@ -46,19 +46,20 @@ ocsigen_parseconfig.cmx : ocsigen_socket.cmx ../baselib/ocsigen_loader.cmx \ ocsigen_parseconfig.cmi : ocsigen_socket.cmi ocsigen_extensions.cmi ocsigen_request.cmo : ../baselib/polytables.cmi \ ../baselib/ocsigen_stream.cmi ocsigen_socket.cmi ocsigen_multipart.cmi \ - ../baselib/ocsigen_lib.cmi ../http/ocsigen_cookies.cmi \ - ../http/http_headers.cmi ocsigen_request.cmi + ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ + ../http/ocsigen_cookies.cmi ocsigen_request.cmi ocsigen_request.cmx : ../baselib/polytables.cmx \ ../baselib/ocsigen_stream.cmx ocsigen_socket.cmx ocsigen_multipart.cmx \ - ../baselib/ocsigen_lib.cmx ../http/ocsigen_cookies.cmx \ - ../http/http_headers.cmx ocsigen_request.cmi + ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ + ../http/ocsigen_cookies.cmx ocsigen_request.cmi ocsigen_request.cmi : ../baselib/polytables.cmi ocsigen_multipart.cmi \ - ../http/ocsigen_cookies.cmi ../http/http_headers.cmi -ocsigen_response.cmo : ../http/ocsigen_cookies.cmi ../http/http_headers.cmi \ - ocsigen_response.cmi -ocsigen_response.cmx : ../http/ocsigen_cookies.cmx ../http/http_headers.cmx \ - ocsigen_response.cmi -ocsigen_response.cmi : ../http/ocsigen_cookies.cmi ../http/http_headers.cmi + ../http/ocsigen_header.cmi ../http/ocsigen_cookies.cmi +ocsigen_response.cmo : ../http/ocsigen_header.cmi \ + ../http/ocsigen_cookies.cmi ocsigen_response.cmi +ocsigen_response.cmx : ../http/ocsigen_header.cmx \ + ../http/ocsigen_cookies.cmx ocsigen_response.cmi +ocsigen_response.cmi : ../http/ocsigen_header.cmi \ + ../http/ocsigen_cookies.cmi ocsigen_server.cmo : ocsigen_socket.cmi ocsigen_parseconfig.cmi \ ../baselib/ocsigen_messages.cmi ../baselib/ocsigen_loader.cmi \ ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index ceec6c037..ec289b727 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -6,7 +6,7 @@ exception Ocsigen_http_error of Ocsigen_cookies.cookieset * Cohttp.Code.status exception Ext_http_error of - Cohttp.Code.status * string option * Http_headers.t option + Cohttp.Code.status * string option * Cohttp.Header.t option (** print_request Print request for debug @param out_ch output for debug @@ -59,10 +59,9 @@ module Cookie = struct | Ocsigen_cookies.OUnset -> (Some 0., "", false) | Ocsigen_cookies.OSet (t, v, secure) -> (t, v, secure) in - Http_headers.add - Http_headers.set_cookie - (serialize_cookie_raw path exp name v secure) - h) + Cohttp.Header.add h + Ocsigen_header.Name.(to_string set_cookie) + (serialize_cookie_raw path exp name v secure)) table headers @@ -97,7 +96,7 @@ let make_cookies_headers path t hds = t, v, secure in Cohttp.Header.add h - Http_headers.(name_to_string set_cookie) + Ocsigen_header.Name.(to_string set_cookie) (make_cookies_header path exp name v secure) ) t diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index d0d9fc9fd..fe8abcc05 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -236,17 +236,17 @@ let original_full_path r = let header {r_request} id = let h = Cohttp.Request.headers r_request in - Cohttp.Header.get h (Http_headers.name_to_string id) + Cohttp.Header.get h (Ocsigen_header.Name.to_string id) let header_multi {r_request} id = let h = Cohttp.Request.headers r_request in - Cohttp.Header.get_multi h (Http_headers.name_to_string id) + Cohttp.Header.get_multi h (Ocsigen_header.Name.to_string id) let add_header r id v = let f ({Cohttp.Request.headers} as r) = let headers = Cohttp.Header.add headers - (Http_headers.name_to_string id) + (Ocsigen_header.Name.to_string id) v in { r with Cohttp.Request.headers } @@ -269,14 +269,14 @@ let cookies = function | {r_cookies_override = Some cookies} -> cookies | r -> - match header r Http_headers.cookie with + match header r Ocsigen_header.Name.cookie with | Some cookies -> parse_cookies cookies | None -> Ocsigen_cookies.CookiesTable.empty let content_type r = - match header r Http_headers.content_type with + match header r Ocsigen_header.Name.content_type with | Some content_type -> Ocsigen_multipart.parse_content_type content_type | None -> diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli index a29cfcab1..90dc1ea11 100644 --- a/src/server/ocsigen_request.mli +++ b/src/server/ocsigen_request.mli @@ -79,11 +79,11 @@ val original_full_path : t -> string list val original_full_path_string : t -> string -val header : t -> Http_headers.name -> string option +val header : t -> Ocsigen_header.Name.t -> string option -val header_multi : t -> Http_headers.name -> string list +val header_multi : t -> Ocsigen_header.Name.t -> string list -val add_header : t -> Http_headers.name -> string -> t +val add_header : t -> Ocsigen_header.Name.t -> string -> t val cookies : t -> string Ocsigen_cookies.CookiesTable.t diff --git a/src/server/ocsigen_response.ml b/src/server/ocsigen_response.ml index 1f8340302..a53375f3b 100644 --- a/src/server/ocsigen_response.ml +++ b/src/server/ocsigen_response.ml @@ -56,11 +56,11 @@ let add_cookies ({ a_cookies } as a) cookies = let header {a_response} id = let h = Cohttp.Response.headers a_response in - Cohttp.Header.get h (Http_headers.name_to_string id) + Cohttp.Header.get h (Ocsigen_header.Name.to_string id) let header_multi {a_response} id = let h = Cohttp.Response.headers a_response in - Cohttp.Header.get_multi h (Http_headers.name_to_string id) + Cohttp.Header.get_multi h (Ocsigen_header.Name.to_string id) let add_header ({a_response = ({headers} as a_response)} as a) @@ -69,14 +69,14 @@ let add_header a_response = { a_response with headers = - Cohttp.Header.add headers (Http_headers.name_to_string id) v + Cohttp.Header.add headers (Ocsigen_header.Name.to_string id) v } } let add_header_multi ({a_response = ({headers} as a_response)} as a) id l = - let id = Http_headers.name_to_string id in + let id = Ocsigen_header.Name.to_string id in let headers = List.fold_left (fun headers -> Cohttp.Header.add headers id) @@ -87,7 +87,7 @@ let add_header_multi let remove_header ({a_response} as a) id = let headers = Cohttp.Response.headers a_response - and id = Http_headers.name_to_string id in + and id = Ocsigen_header.Name.to_string id in let headers = Cohttp.Header.remove headers id in { a with a_response = { a_response with headers } } @@ -98,7 +98,7 @@ let replace_header a_response = { a_response with headers = - Cohttp.Header.replace headers (Http_headers.name_to_string id) v + Cohttp.Header.replace headers (Ocsigen_header.Name.to_string id) v } } @@ -107,7 +107,7 @@ let replace_headers ({a_response} as a) l = List.fold_left (fun headers (id, content) -> Cohttp.Header.replace headers - (Http_headers.name_to_string id) + (Ocsigen_header.Name.to_string id) content) (Cohttp.Response.headers a_response) l diff --git a/src/server/ocsigen_response.mli b/src/server/ocsigen_response.mli index 5f2d10896..f61398699 100644 --- a/src/server/ocsigen_response.mli +++ b/src/server/ocsigen_response.mli @@ -33,16 +33,16 @@ val set_status : t -> Cohttp.Code.status -> t val add_cookies : t -> Ocsigen_cookies.cookieset -> t -val header : t -> Http_headers.name -> string option +val header : t -> Ocsigen_header.Name.t -> string option -val header_multi : t -> Http_headers.name -> string list +val header_multi : t -> Ocsigen_header.Name.t -> string list -val add_header : t -> Http_headers.name -> string -> t +val add_header : t -> Ocsigen_header.Name.t -> string -> t -val add_header_multi : t -> Http_headers.name -> string list -> t +val add_header_multi : t -> Ocsigen_header.Name.t -> string list -> t -val replace_header : t -> Http_headers.name -> string -> t +val replace_header : t -> Ocsigen_header.Name.t -> string -> t -val replace_headers : t -> (Http_headers.name * string) list -> t +val replace_headers : t -> (Ocsigen_header.Name.t * string) list -> t -val remove_header : t -> Http_headers.name -> t +val remove_header : t -> Ocsigen_header.Name.t -> t From 92c03f458df47a9b58f579fb56daa50e5d8c88ba Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 28 Mar 2017 22:55:11 +0200 Subject: [PATCH 040/111] Fix original_full_path and sub_path fields in Ocsigen_request --- src/extensions/staticmod.ml | 2 +- src/server/ocsigen_extensions.ml | 28 ++++----------- src/server/ocsigen_request.ml | 59 +++++++++++++++++++------------- src/server/ocsigen_request.mli | 1 + 4 files changed, 44 insertions(+), 46 deletions(-) diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 92afa226a..898cd8fbe 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -136,7 +136,7 @@ let gen ~usermode ?cache dir = function let pathstring = Ocsigen_lib.Url.string_of_url_path ~encode:false - (Ocsigen_request.path request_info) + (Ocsigen_request.sub_path request_info) in find_static_page ~request ~usermode ~dir ~err ~pathstring in diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 49957d8df..148a18f21 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -271,23 +271,6 @@ let (hosts : (virtual_hosts * config_info * extension2) list ref) = let set_hosts v = hosts := v let get_hosts () = !hosts -let update_path - { request_info ; request_config } - path = - let r = Ocsigen_request.request request_info in - let request_info = - let request = - let meth = Cohttp.Request.meth r - and version = Cohttp.Request.version r - and encoding = Cohttp.Request.encoding r - and headers = Cohttp.Request.headers r - and uri = Uri.with_path (Cohttp.Request.uri r) path in - Cohttp.Request.make ~meth ~version ~encoding ~headers uri - in - Ocsigen_request.update ~request request_info - in - { request_info ; request_config } - (* Default hostname is either the Host header or the hostname set in the configuration file. *) let get_hostname {request_info ; request_config = {default_hostname}} = @@ -483,10 +466,13 @@ let rec default_parse_config (Ocsigen_request.path oldri.request_info)) oldri (fun () path -> Url.string_of_url_path ~encode:true path) path; - let ri = - update_path oldri - (Url.string_of_url_path ~encode:true sub_path) - in + let ri = + {oldri with + request_info = + Ocsigen_request.update oldri.request_info + ~sub_path: + (Url.string_of_url_path ~encode:true sub_path) + } in parse_config cookies_to_set (Req_not_found (e, ri)) >>= function (* After a site, we turn back to old ri *) diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index fe8abcc05..8566b7919 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -69,24 +69,41 @@ let make r_connection_closed } -let update_uri_components ~full_rewrite ~request uri = +let path_string {r_request} = + Uri.path (Cohttp.Request.uri r_request) + +let path r = + (* CHECKME *) + match Ocsigen_lib.Url.split_path (path_string r) with + | "" :: path -> + path + | path -> + path + +let update_uri_components + ~full_rewrite + r_request + r_original_full_path + uri = let request = - let meth = Cohttp.Request.meth request - and version = Cohttp.Request.version request - and encoding = Cohttp.Request.encoding request - and headers = Cohttp.Request.headers request in + let meth = Cohttp.Request.meth r_request + and version = Cohttp.Request.version r_request + and encoding = Cohttp.Request.encoding r_request + and headers = Cohttp.Request.headers r_request in Cohttp.Request.make ~meth ~version ~encoding ~headers uri - in - let original_full_path = - if full_rewrite then - Some (Uri.path (Cohttp.Request.uri request)) - else + and original_full_path = + match full_rewrite, r_original_full_path with + | true, _ -> None + | false, Some _ -> + r_original_full_path + | false, _ -> + Some (Uri.path (Cohttp.Request.uri r_request)) in request, original_full_path let update - ?forward_ip ?remote_ip ?ssl ?request + ?forward_ip ?remote_ip ?ssl ?sub_path ?request ?get_params_override ?post_data_override ?cookies_override ?(full_rewrite = false) ?uri ({ @@ -139,11 +156,17 @@ let update get_params_override | None -> r_get_params_override + and r_sub_path = + match sub_path with + | Some _ -> + sub_path + | None -> + r_sub_path in let r_request, r_original_full_path = match uri with | Some uri -> - update_uri_components ~full_rewrite ~request:r_request uri + update_uri_components ~full_rewrite r_request r_original_full_path uri | None -> r_request, r_original_full_path in @@ -165,7 +188,6 @@ let uri {r_request} = Cohttp.Request.uri r_request let request {r_request} = r_request - let body {r_body} = r_body @@ -201,17 +223,6 @@ let get_params { r_request ; r_get_params_override } = | None -> Uri.query (Cohttp.Request.uri r_request) -let path_string {r_request} = - Uri.path (Cohttp.Request.uri r_request) - -let path r = - (* CHECKME *) - match Ocsigen_lib.Url.split_path (path_string r) with - | "" :: path -> - path - | path -> - path - let sub_path_string = function | {r_sub_path = Some r_sub_path} -> r_sub_path diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli index 90dc1ea11..04e46c298 100644 --- a/src/server/ocsigen_request.mli +++ b/src/server/ocsigen_request.mli @@ -31,6 +31,7 @@ val update : ?forward_ip : string list -> ?remote_ip : string -> ?ssl : bool -> + ?sub_path : string -> ?request : Cohttp.Request.t -> ?get_params_override : (string * string list) list -> ?post_data_override : post_data option -> From ba0eba9cfc3d8f4ff9c949bd6ac7e26c3688cd49 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 29 Mar 2017 15:32:06 +0200 Subject: [PATCH 041/111] Restructure Ocsigen_request - Laziness for fields derived from request URI - Prevent direct manipulation of Cohttp request from outside --- src/server/ocsigen_request.ml | 187 ++++++++++++++++++++------------- src/server/ocsigen_request.mli | 17 ++- 2 files changed, 123 insertions(+), 81 deletions(-) diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 8566b7919..4cf4dc4a2 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -16,6 +16,44 @@ type file_info = Ocsigen_multipart.file_info = { type post_data = Ocsigen_multipart.post_data +(* Wrapper around Uri providing our derived fields. + + Is the laziness too fine-grained? *) +type uri = { + u_uri : Uri.t Lazy.t ; + u_get_params : (string * string list) list Lazy.t ; + u_get_params_flat : (string * string) list Lazy.t ; + u_path_string : string Lazy.t ; + u_path : string list Lazy.t ; +} + +let unflatten_get_params l = + let module M = Ocsigen_lib.String.Table in + M.bindings + (List.fold_left + (fun acc (id, v) -> + M.add id (try v :: M.find id acc with Not_found -> [v]) acc) + M.empty + l) + +let flatten_get_params l = + List.concat (List.map (fun (s, l) -> List.map (fun v -> s, v) l) l) + +let make_uri u = + let u_uri = lazy u + and u_get_params = lazy (Uri.query u) + and u_path_string = lazy (Uri.path u) in + let u_path = lazy ( + match Ocsigen_lib.Url.split_path (Lazy.force u_path_string) with + | "" :: path -> + path + | path -> + path + ) and u_get_params_flat = lazy ( + flatten_get_params (Lazy.force u_get_params) + ) in + { u_uri ; u_get_params ; u_get_params_flat ; u_path ; u_path_string } + type t = { r_address : Unix.inet_addr ; r_port : int ; @@ -24,9 +62,9 @@ type t = { r_remote_ip : string Lazy.t ; r_remote_ip_parsed : Ipaddr.t Lazy.t ; r_forward_ip : string list ; - r_request : Cohttp.Request.t ; + r_uri : uri ; + r_request : Cohttp.Request.t Lazy.t ; r_body : Cohttp_lwt_body.t ; - r_get_params_override : (string * string list) list option ; r_post_data_override : post_data Lwt.t option option ref ; r_original_full_path : string option ; r_sub_path : string option ; @@ -57,9 +95,9 @@ let make r_remote_ip ; r_remote_ip_parsed ; r_forward_ip = forward_ip ; - r_request = request ; + r_uri = make_uri (Cohttp.Request.uri request) ; + r_request = lazy request ; r_body = body ; - r_get_params_override = None ; r_post_data_override = ref None ; r_sub_path = sub_path ; r_original_full_path = original_full_path ; @@ -69,62 +107,42 @@ let make r_connection_closed } -let path_string {r_request} = - Uri.path (Cohttp.Request.uri r_request) +let path_string {r_uri = {u_path_string}} = + Lazy.force u_path_string -let path r = - (* CHECKME *) - match Ocsigen_lib.Url.split_path (path_string r) with - | "" :: path -> - path - | path -> - path +let path {r_uri = {u_path}} = + Lazy.force u_path -let update_uri_components - ~full_rewrite - r_request - r_original_full_path - uri = - let request = - let meth = Cohttp.Request.meth r_request - and version = Cohttp.Request.version r_request - and encoding = Cohttp.Request.encoding r_request - and headers = Cohttp.Request.headers r_request in - Cohttp.Request.make ~meth ~version ~encoding ~headers uri - and original_full_path = - match full_rewrite, r_original_full_path with - | true, _ -> - None - | false, Some _ -> - r_original_full_path - | false, _ -> - Some (Uri.path (Cohttp.Request.uri r_request)) - in - request, original_full_path +let update_cohttp_uri ?meth r u = + let meth = + match meth with + | Some meth -> meth + | None -> Cohttp.Request.meth r + and version = Cohttp.Request.version r + and encoding = Cohttp.Request.encoding r + and headers = Cohttp.Request.headers r in + Cohttp.Request.make ~meth ~version ~encoding ~headers u let update - ?forward_ip ?remote_ip ?ssl ?sub_path ?request - ?get_params_override ?post_data_override ?cookies_override + ?forward_ip ?remote_ip ?ssl ?sub_path + ?meth + ?get_params_flat + ?post_data_override + ?cookies_override ?(full_rewrite = false) ?uri ({ + r_uri ; r_request ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed ; - r_get_params_override ; r_cookies_override ; r_post_data_override ; r_sub_path ; r_original_full_path } as r) = (* FIXME : ssl *) - let r_request = - match request with - | Some request -> - request - | None -> - r_request - and r_forward_ip = + let r_forward_ip = match forward_ip with | Some forward_ip -> forward_ip @@ -150,12 +168,6 @@ let update cookies_override | None -> r_cookies_override - and r_get_params_override = - match get_params_override with - | Some _ -> - get_params_override - | None -> - r_get_params_override and r_sub_path = match sub_path with | Some _ -> @@ -163,45 +175,77 @@ let update | None -> r_sub_path in - let r_request, r_original_full_path = + let r_request, r_original_full_path, r_uri = match uri with | Some uri -> - update_uri_components ~full_rewrite r_request r_original_full_path uri + lazy (update_cohttp_uri (Lazy.force r_request) uri), + (match full_rewrite, r_original_full_path with + | true, _ -> + None + | false, Some _ -> + r_original_full_path + | false, _ -> + Some (Uri.path (Cohttp.Request.uri (Lazy.force r_request)))), + make_uri uri | None -> - r_request, r_original_full_path + r_request, r_original_full_path, r_uri in - { + let r_request, r_uri = + match get_params_flat, meth with + | Some l, _ -> + let u_get_params = lazy (unflatten_get_params l) in + let u_uri = lazy ( + Uri.with_query + (Lazy.force r_uri.u_uri) + (Lazy.force u_get_params) + ) in + lazy ( + update_cohttp_uri ?meth + (Lazy.force r_request) + (Lazy.force u_uri) + ), + { r_uri with + u_uri ; + u_get_params ; + u_get_params_flat = lazy l + } + | None, Some meth -> + lazy {(Lazy.force r_request) with Cohttp.Request.meth = meth}, + r_uri + | None, None -> + r_request, r_uri + in { r with + r_uri ; r_request ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed ; - r_get_params_override ; r_post_data_override ; r_cookies_override ; r_sub_path ; r_original_full_path } -let uri {r_request} = Cohttp.Request.uri r_request +let uri {r_uri = {u_uri}} = Lazy.force u_uri let request {r_request} = - r_request + Lazy.force r_request let body {r_body} = r_body let map_cohttp_request ~f ({r_request} as r) = - {r with r_request = f r_request} + {r with r_request = lazy (f (Lazy.force r_request))} let address {r_address} = r_address -let host {r_request} = - Uri.host (Cohttp.Request.uri r_request) +let host {r_uri = {u_uri}} = + Uri.host (Lazy.force u_uri) let meth {r_request} = - Cohttp.Request.meth r_request + Cohttp.Request.meth (Lazy.force r_request) let port {r_port} = r_port @@ -211,17 +255,16 @@ let ssl _ = false let version {r_request} = - Cohttp.Request.version r_request + Cohttp.Request.version (Lazy.force r_request) -let query {r_request} = - Uri.verbatim_query (Cohttp.Request.uri r_request) +let query {r_uri = {u_uri}} = + Uri.verbatim_query (Lazy.force u_uri) -let get_params { r_request ; r_get_params_override } = - match r_get_params_override with - | Some r_get_params_override -> - r_get_params_override - | None -> - Uri.query (Cohttp.Request.uri r_request) +let get_params {r_uri = { u_get_params }} = + Lazy.force u_get_params + +let get_params_flat {r_uri = { u_get_params_flat }} = + Lazy.force u_get_params_flat let sub_path_string = function | {r_sub_path = Some r_sub_path} -> @@ -246,11 +289,11 @@ let original_full_path r = Ocsigen_lib.Url.split_path (original_full_path_string r) let header {r_request} id = - let h = Cohttp.Request.headers r_request in + let h = Cohttp.Request.headers (Lazy.force r_request) in Cohttp.Header.get h (Ocsigen_header.Name.to_string id) let header_multi {r_request} id = - let h = Cohttp.Request.headers r_request in + let h = Cohttp.Request.headers (Lazy.force r_request) in Cohttp.Header.get_multi h (Ocsigen_header.Name.to_string id) let add_header r id v = diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli index 04e46c298..07fd376f8 100644 --- a/src/server/ocsigen_request.mli +++ b/src/server/ocsigen_request.mli @@ -32,8 +32,8 @@ val update : ?remote_ip : string -> ?ssl : bool -> ?sub_path : string -> - ?request : Cohttp.Request.t -> - ?get_params_override : (string * string list) list -> + ?meth : Cohttp.Code.meth -> + ?get_params_flat : (string * string) list -> ?post_data_override : post_data option -> ?cookies_override : string Ocsigen_cookies.CookiesTable.t -> ?full_rewrite : bool -> @@ -43,15 +43,8 @@ val update : val uri : t -> Uri.t -val request : t -> Cohttp.Request.t - val body : t -> Cohttp_lwt_body.t -val map_cohttp_request : - f : (Cohttp.Request.t -> Cohttp.Request.t) -> - t -> - t - val address : t -> Unix.inet_addr val host : t -> string option @@ -68,6 +61,8 @@ val query : t -> string option val get_params : t -> (string * string list) list +val get_params_flat : t -> (string * string) list + val path : t -> string list val path_string : t -> string @@ -119,3 +114,7 @@ val incr_tries : t -> unit val connection_closed : t -> unit Lwt.t val wakeup : t -> unit + +(**/**) + +val request : t -> Cohttp.Request.t From 8b2a941880344d6b9d8f5930774552f194eef7d9 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 29 Mar 2017 22:09:03 +0200 Subject: [PATCH 042/111] Do not maintain Cohttp.Request.t object in Ocsigen_request Simpler to rebuild if needed. --- src/server/ocsigen_request.ml | 98 ++++++++++++++++------------------- 1 file changed, 45 insertions(+), 53 deletions(-) diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 4cf4dc4a2..7d9d1cde8 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -63,7 +63,10 @@ type t = { r_remote_ip_parsed : Ipaddr.t Lazy.t ; r_forward_ip : string list ; r_uri : uri ; - r_request : Cohttp.Request.t Lazy.t ; + r_meth : Cohttp.Code.meth ; + r_encoding : Cohttp.Transfer.encoding ; + r_version : Cohttp.Code.version ; + r_headers : Cohttp.Header.t ; r_body : Cohttp_lwt_body.t ; r_post_data_override : post_data Lwt.t option option ref ; r_original_full_path : string option ; @@ -96,7 +99,10 @@ let make r_remote_ip_parsed ; r_forward_ip = forward_ip ; r_uri = make_uri (Cohttp.Request.uri request) ; - r_request = lazy request ; + r_encoding = Cohttp.Request.encoding request ; + r_meth = Cohttp.Request.meth request ; + r_version = Cohttp.Request.version request ; + r_headers = Cohttp.Request.headers request ; r_body = body ; r_post_data_override = ref None ; r_sub_path = sub_path ; @@ -131,8 +137,8 @@ let update ?cookies_override ?(full_rewrite = false) ?uri ({ - r_uri ; - r_request ; + r_uri = {u_uri} as r_uri; + r_meth ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed ; @@ -174,88 +180,79 @@ let update sub_path | None -> r_sub_path - in - let r_request, r_original_full_path, r_uri = + and r_meth = + match meth with + | Some meth -> + meth + | None -> + r_meth + and r_original_full_path, r_uri = match uri with | Some uri -> - lazy (update_cohttp_uri (Lazy.force r_request) uri), (match full_rewrite, r_original_full_path with | true, _ -> None | false, Some _ -> r_original_full_path | false, _ -> - Some (Uri.path (Cohttp.Request.uri (Lazy.force r_request)))), + Some (Uri.path (Lazy.force u_uri))), make_uri uri | None -> - r_request, r_original_full_path, r_uri + r_original_full_path, r_uri in - let r_request, r_uri = - match get_params_flat, meth with - | Some l, _ -> + let r_uri = + match get_params_flat with + | Some l -> let u_get_params = lazy (unflatten_get_params l) in let u_uri = lazy ( Uri.with_query (Lazy.force r_uri.u_uri) (Lazy.force u_get_params) ) in - lazy ( - update_cohttp_uri ?meth - (Lazy.force r_request) - (Lazy.force u_uri) - ), { r_uri with u_uri ; u_get_params ; u_get_params_flat = lazy l } - | None, Some meth -> - lazy {(Lazy.force r_request) with Cohttp.Request.meth = meth}, + | None -> r_uri - | None, None -> - r_request, r_uri in { r with r_uri ; - r_request ; + r_meth ; r_forward_ip ; r_remote_ip ; r_remote_ip_parsed ; r_post_data_override ; r_cookies_override ; r_sub_path ; - r_original_full_path + r_original_full_path ; } -let uri {r_uri = {u_uri}} = Lazy.force u_uri +let uri {r_uri = {u_uri}} = + Lazy.force u_uri -let request {r_request} = - Lazy.force r_request +let request ({ r_meth ; r_encoding ; r_version ; r_headers } as r) = + Cohttp.Request.make + ~meth:r_meth ~encoding:r_encoding ~version:r_version ~headers:r_headers + (uri r) -let body {r_body} = - r_body +let body {r_body} = r_body -let map_cohttp_request ~f ({r_request} as r) = - {r with r_request = lazy (f (Lazy.force r_request))} - -let address {r_address} = - r_address +let address {r_address} = r_address let host {r_uri = {u_uri}} = Uri.host (Lazy.force u_uri) -let meth {r_request} = - Cohttp.Request.meth (Lazy.force r_request) +let meth {r_meth} = r_meth -let port {r_port} = - r_port +let port {r_port} = r_port let ssl _ = (* FIXME *) false -let version {r_request} = - Cohttp.Request.version (Lazy.force r_request) +let version {r_version} = r_version let query {r_uri = {u_uri}} = Uri.verbatim_query (Lazy.force u_uri) @@ -288,24 +285,19 @@ let original_full_path_string = function let original_full_path r = Ocsigen_lib.Url.split_path (original_full_path_string r) -let header {r_request} id = - let h = Cohttp.Request.headers (Lazy.force r_request) in - Cohttp.Header.get h (Ocsigen_header.Name.to_string id) +let header {r_headers} id = + Cohttp.Header.get r_headers (Ocsigen_header.Name.to_string id) -let header_multi {r_request} id = - let h = Cohttp.Request.headers (Lazy.force r_request) in - Cohttp.Header.get_multi h (Ocsigen_header.Name.to_string id) +let header_multi {r_headers} id = + Cohttp.Header.get_multi r_headers (Ocsigen_header.Name.to_string id) -let add_header r id v = - let f ({Cohttp.Request.headers} as r) = - let headers = - Cohttp.Header.add headers +let add_header ({r_headers} as r) id v = + { r with + r_headers = + Cohttp.Header.add r_headers (Ocsigen_header.Name.to_string id) v - in - { r with Cohttp.Request.headers } - in - map_cohttp_request r ~f + } let parse_cookies s = let splitted = Ocsigen_lib.String.split ';' s in From 9ca67359fc954f796830cde1155e1fa491f00c84 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 30 Mar 2017 13:01:47 +0200 Subject: [PATCH 043/111] Revert "Extension for simple handler registration" This reverts commit 1c19a2bff969f9dd648edefee10a770a7eb92e3b. --- src/Makefile.filelist | 5 ++-- src/extensions/.depend | 5 ---- src/extensions/Makefile | 6 ++--- src/extensions/handler.ml | 47 -------------------------------------- src/extensions/handler.mli | 14 ------------ src/files/META.in | 8 ------- 6 files changed, 4 insertions(+), 81 deletions(-) delete mode 100644 src/extensions/handler.ml delete mode 100644 src/extensions/handler.mli diff --git a/src/Makefile.filelist b/src/Makefile.filelist index c2ec568dc..5369e643b 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -52,14 +52,13 @@ endif PLUGINS_BIN := PLUGINS_INTF := extensions/authbasic.cmi extensions/accesscontrol.cmi \ - extensions/ocsipersist.cmi extensions/handler.cmi + extensions/ocsipersist.cmi # extensions/ocsigen_comet.cmi PLUGINS_IMPL := extensions/accesscontrol.cmo extensions/authbasic.cmo \ extensions/cors.cmo extensions/outputfilter.cmo \ extensions/redirectmod.cmo extensions/revproxy.cmo \ - extensions/rewritemod.cmo extensions/staticmod.cmo \ - extensions/handler.cmo + extensions/rewritemod.cmo extensions/staticmod.cmo ifeq "$(CAMLZIP)" "YES" PLUGINS_IMPL += extensions/deflatemod.cmo diff --git a/src/extensions/.depend b/src/extensions/.depend index 4799b0df7..4b2f26891 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -34,11 +34,6 @@ extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ extendconfiguration.cmx : ../server/ocsigen_parseconfig.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx ../http/ocsigen_charset_mime.cmx -handler.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ - ../server/ocsigen_extensions.cmi handler.cmi -handler.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ - ../server/ocsigen_extensions.cmx handler.cmi -handler.cmi : ../server/ocsigen_response.cmi ocsigen_comet.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi \ ocsigen_comet.cmi diff --git a/src/extensions/Makefile b/src/extensions/Makefile index a5f1d9f69..98d9cf1d1 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -22,11 +22,9 @@ all: byte opt ### Extensions ### -FILES := accesscontrol.ml authbasic.ml cors.ml extendconfiguration.ml \ - handler.ml outputfilter.ml redirectmod.ml revproxy.ml \ +FILES := accesscontrol.ml authbasic.ml cors.ml extendconfiguration.ml \ + outputfilter.ml redirectmod.ml revproxy.ml \ rewritemod.ml staticmod.ml userconf.ml -# cgimod.ml \ -# ocsigen_comet.ml \ ifeq "$(CAMLZIP)" "YES" FILES += deflatemod.ml diff --git a/src/extensions/handler.ml b/src/extensions/handler.ml deleted file mode 100644 index cf364ec3f..000000000 --- a/src/extensions/handler.ml +++ /dev/null @@ -1,47 +0,0 @@ -open Lwt.Infix - -let name = "handler" - -type id = string list * (string * string list) list - -type result = [ - | `Response of Ocsigen_response.t - | `Fail of Cohttp.Code.status - | `Continue -] - -type t = - string list -> - (string * string list) list -> - Cohttp.Header.t -> - Cohttp_lwt_body.t -> - result Lwt.t - -let handlers : t list ref = ref [] - -let register f = handlers := f :: !handlers - -let rec fold_handlers ~request l = - match l with - | f :: l -> - (f (Ocsigen_request.path request) - (Ocsigen_request.get_params request) - (Cohttp.Request.headers (Ocsigen_request.request request)) - (Ocsigen_request.body request) >>= function - | `Response r -> - Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return r)) - | `Fail s -> - Lwt.return (Ocsigen_extensions.Ext_next s) - | `Continue -> - fold_handlers ~request l) - | [] -> - Lwt.return (Ocsigen_extensions.Ext_next `Not_found) - -let fun_site _ _ _ _ _ _ = function - | Ocsigen_extensions.Req_found _ -> - Lwt.return Ocsigen_extensions.Ext_do_nothing - | Ocsigen_extensions.Req_not_found - (_, {Ocsigen_extensions.request_info}) -> - fold_handlers ~request:request_info !handlers - -let () = Ocsigen_extensions.register_extension ~name ~fun_site () diff --git a/src/extensions/handler.mli b/src/extensions/handler.mli deleted file mode 100644 index 1901e028c..000000000 --- a/src/extensions/handler.mli +++ /dev/null @@ -1,14 +0,0 @@ -type result = [ - | `Response of Ocsigen_response.t - | `Fail of Cohttp.Code.status - | `Continue -] - -type t = - string list -> - (string * string list) list -> - Cohttp.Header.t -> - Cohttp_lwt_body.t -> - result Lwt.t - -val register : t -> unit diff --git a/src/files/META.in b/src/files/META.in index 823413c92..357047e0d 100644 --- a/src/files/META.in +++ b/src/files/META.in @@ -142,14 +142,6 @@ package "ext" ( archive(native) = "cgimod.cmx" ) - package "handler" ( - exists_if = "handler.cmo,handler.cmx" - version = "[distributed with Ocsigen server]" - description = "Handler registry" - archive(byte) = "handler.cmo" - archive(native) = "handler.cmx" - ) - package "ocsipersist-sqlite" ( exists_if = "ocsipersist-sqlite.cma,ocsipersist-sqlite.cmxa" requires = "sqlite3" From a68fe1911fdb64988bd5042381dd8013915b8135 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 30 Mar 2017 13:47:23 +0200 Subject: [PATCH 044/111] Ocsigen_request and Ocsigen_response cleanup --- src/extensions/cors.ml | 4 +- src/extensions/redirectmod.ml | 11 +++-- src/extensions/revproxy.ml | 2 +- src/server/ocsigen_cohttp.ml | 24 +++++------ src/server/ocsigen_request.ml | 74 ++++++++++++++++----------------- src/server/ocsigen_request.mli | 17 +++----- src/server/ocsigen_response.ml | 30 ++++++------- src/server/ocsigen_response.mli | 13 ++---- 8 files changed, 76 insertions(+), 99 deletions(-) diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index 04e707023..b1ad13d5d 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -25,9 +25,7 @@ let section = Lwt_log.Section.make "ocsigen:ext:cors" (*** MAIN FUNCTION ***) let default_frame () = - Ocsigen_response.make - ~response:(Cohttp.Response.make ~status:`OK ()) - () + Ocsigen_response.make (Cohttp.Response.make ~status:`OK ()) type config = { allowed_method : Cohttp.Code.meth list option; diff --git a/src/extensions/redirectmod.ml b/src/extensions/redirectmod.ml index 1045a2d93..efbdcd8bf 100644 --- a/src/extensions/redirectmod.ml +++ b/src/extensions/redirectmod.ml @@ -53,12 +53,11 @@ let attempt_redir dir err ri () = (if temp then "Temporary " else "Permanent ") redir; Lwt.return @@ Ocsigen_extensions.Ext_found (fun () -> - let response = - let headers = Cohttp.Header.(init_with "Location" redir) - and status = if temp then `Found else `Moved_permanently in - Cohttp.Response.make ~status ~headers () - in - Lwt.return (Ocsigen_response.make ~response ())) + Lwt.return @@ + Ocsigen_response.make @@ + let headers = Cohttp.Header.(init_with "Location" redir) + and status = if temp then `Found else `Moved_permanently in + Cohttp.Response.make ~status ~headers ()) (** The function that will generate the pages from the request *) let gen dir = function diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index 9e0cb8d57..641932797 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -126,7 +126,7 @@ let gen dir = function let headers = let h = Cohttp.Request.headers - (Ocsigen_request.request request_info) + (Ocsigen_request.to_cohttp request_info) in let h = Ocsigen_request.version request_info diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index ec289b727..bf4ed7997 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -126,7 +126,7 @@ let handler ~address ~port ~connector (flow, conn) request body = in let sockaddr = getsockname edn in - let (waiter, wakener) = Lwt.wait () in + let (connection_closed, wakener) = Lwt.wait () in Hashtbl.add waiters conn wakener; let handle_error exn = @@ -182,28 +182,24 @@ let handler ~address ~port ~connector (flow, conn) request body = let request = Ocsigen_request.make - ~address ~port ~filenames ~sockaddr ~request ~body ~waiter - () - + ~address ~port ~filenames ~sockaddr ~body ~connection_closed request in Lwt.catch (fun () -> - connector request >>= fun { Ocsigen_response.a_response ; - a_cookies ; - a_body } -> - - let a_response = + connector request >>= fun response -> + let response, body = Ocsigen_response.to_cohttp response + and cookies = Ocsigen_response.cookies response in + let response = let headers = Ocsigen_cookies.Cookies.fold make_cookies_headers - a_cookies - (Cohttp.Response.headers a_response) + cookies + (Cohttp.Response.headers response) in - { a_response with Cohttp.Response.headers } + { response with Cohttp.Response.headers } in - Lwt.return (a_response, a_body)) - + Lwt.return (response, body)) (function | Ocsigen_Is_a_directory fun_request -> Cohttp_lwt_unix.Server.respond_redirect diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 7d9d1cde8..94b003b4b 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -16,6 +16,11 @@ type file_info = Ocsigen_multipart.file_info = { type post_data = Ocsigen_multipart.post_data +type body = [ + | `Unparsed of Cohttp_lwt_body.t + | `Parsed of post_data Lwt.t option +] + (* Wrapper around Uri providing our derived fields. Is the laziness too fine-grained? *) @@ -67,21 +72,21 @@ type t = { r_encoding : Cohttp.Transfer.encoding ; r_version : Cohttp.Code.version ; r_headers : Cohttp.Header.t ; - r_body : Cohttp_lwt_body.t ; - r_post_data_override : post_data Lwt.t option option ref ; + r_body : body ref ; r_original_full_path : string option ; r_sub_path : string option ; r_cookies_override : string Ocsigen_cookies.CookiesTable.t option ; mutable r_request_cache : Polytables.t ; mutable r_tries : int ; - r_connection_closed : unit Lwt.t * unit Lwt.u + r_connection_closed : unit Lwt.t } let make ?(forward_ip = []) ?sub_path ?original_full_path ?(request_cache = Polytables.create ()) ?cookies_override - ~address ~port ~filenames ~sockaddr ~request ~body ~waiter () = + ~address ~port ~filenames ~sockaddr ~body ~connection_closed + request = let r_remote_ip = lazy (Unix.string_of_inet_addr @@ -89,7 +94,7 @@ let make in let r_remote_ip_parsed = lazy (Ipaddr.of_string_exn (Lazy.force r_remote_ip)) - and r_connection_closed = Lwt.wait () in + in { r_address = address ; r_port = port ; @@ -103,14 +108,13 @@ let make r_meth = Cohttp.Request.meth request ; r_version = Cohttp.Request.version request ; r_headers = Cohttp.Request.headers request ; - r_body = body ; - r_post_data_override = ref None ; + r_body = ref (`Unparsed body); r_sub_path = sub_path ; r_original_full_path = original_full_path ; r_cookies_override = cookies_override ; r_request_cache = request_cache ; r_tries = 0 ; - r_connection_closed + r_connection_closed = connection_closed } let path_string {r_uri = {u_path_string}} = @@ -119,21 +123,11 @@ let path_string {r_uri = {u_path_string}} = let path {r_uri = {u_path}} = Lazy.force u_path -let update_cohttp_uri ?meth r u = - let meth = - match meth with - | Some meth -> meth - | None -> Cohttp.Request.meth r - and version = Cohttp.Request.version r - and encoding = Cohttp.Request.encoding r - and headers = Cohttp.Request.headers r in - Cohttp.Request.make ~meth ~version ~encoding ~headers u - let update ?forward_ip ?remote_ip ?ssl ?sub_path ?meth ?get_params_flat - ?post_data_override + ?post_data ?cookies_override ?(full_rewrite = false) ?uri ({ @@ -143,7 +137,7 @@ let update r_remote_ip ; r_remote_ip_parsed ; r_cookies_override ; - r_post_data_override ; + r_body ; r_sub_path ; r_original_full_path } as r) = @@ -160,14 +154,14 @@ let update lazy remote_ip, lazy (Ipaddr.of_string_exn remote_ip) | None -> r_remote_ip, r_remote_ip_parsed - and r_post_data_override = - match post_data_override with - | Some (Some post_data_override) -> - ref (Some (Some (Lwt.return post_data_override))) + and r_body = + match post_data with + | Some (Some post_data) -> + ref (`Parsed (Some (Lwt.return post_data))) | Some None -> - ref (Some None) + ref (`Parsed None) | None -> - r_post_data_override + r_body and r_cookies_override = match cookies_override with | Some _ -> @@ -223,7 +217,7 @@ let update r_forward_ip ; r_remote_ip ; r_remote_ip_parsed ; - r_post_data_override ; + r_body ; r_cookies_override ; r_sub_path ; r_original_full_path ; @@ -232,12 +226,16 @@ let update let uri {r_uri = {u_uri}} = Lazy.force u_uri -let request ({ r_meth ; r_encoding ; r_version ; r_headers } as r) = +let to_cohttp ({ r_meth ; r_encoding ; r_version ; r_headers } as r) = Cohttp.Request.make ~meth:r_meth ~encoding:r_encoding ~version:r_version ~headers:r_headers (uri r) -let body {r_body} = r_body +let body = function + | {r_body = {contents = `Unparsed body}} -> + body + | _ -> + failwith "Ocsigen_request.body: body has already been parsed" let address {r_address} = r_address @@ -328,16 +326,16 @@ let content_type r = | None -> None -let force_post_data ({r_post_data_override ; r_body} as r) s i = - match !r_post_data_override with - | Some r_post_data_override -> - r_post_data_override - | None -> +let force_post_data ({r_body} as r) s i = + match !r_body with + | `Parsed post_data -> + post_data + | `Unparsed body -> let v = match content_type r with | Some content_type -> (match - post_data_of_body ~content_type r_body + post_data_of_body ~content_type body with | Some f -> Some (f s i) @@ -346,7 +344,7 @@ let force_post_data ({r_post_data_override ; r_body} as r) s i = | None -> None in - r.r_post_data_override := Some v; + r.r_body := `Parsed v; v let post_params r s i = @@ -375,6 +373,4 @@ let tries {r_tries} = r_tries let incr_tries r = r.r_tries <- r.r_tries + 1 -let connection_closed {r_connection_closed = (wait, _)} = wait - -let wakeup {r_connection_closed = (_, wakeup)} = Lwt.wakeup wakeup () +let connection_closed {r_connection_closed} = r_connection_closed diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli index 07fd376f8..4215c1b84 100644 --- a/src/server/ocsigen_request.mli +++ b/src/server/ocsigen_request.mli @@ -21,10 +21,9 @@ val make : port : int -> filenames : string list ref -> sockaddr : Lwt_unix.sockaddr -> - request : Cohttp.Request.t -> body : Cohttp_lwt_body.t -> - waiter : unit Lwt.t -> - unit -> + connection_closed : unit Lwt.t -> + Cohttp.Request.t -> t val update : @@ -34,13 +33,15 @@ val update : ?sub_path : string -> ?meth : Cohttp.Code.meth -> ?get_params_flat : (string * string) list -> - ?post_data_override : post_data option -> + ?post_data : post_data option -> ?cookies_override : string Ocsigen_cookies.CookiesTable.t -> ?full_rewrite : bool -> ?uri : Uri.t -> t -> t +val to_cohttp : t -> Cohttp.Request.t + val uri : t -> Uri.t val body : t -> Cohttp_lwt_body.t @@ -83,8 +84,6 @@ val add_header : t -> Ocsigen_header.Name.t -> string -> t val cookies : t -> string Ocsigen_cookies.CookiesTable.t -(* FIXME: strange API for files, post_params *) - val files : t -> string option -> @@ -112,9 +111,3 @@ val tries : t -> int val incr_tries : t -> unit val connection_closed : t -> unit Lwt.t - -val wakeup : t -> unit - -(**/**) - -val request : t -> Cohttp.Request.t diff --git a/src/server/ocsigen_response.ml b/src/server/ocsigen_response.ml index a53375f3b..a138916fd 100644 --- a/src/server/ocsigen_response.ml +++ b/src/server/ocsigen_response.ml @@ -7,8 +7,8 @@ type t = { let make ?(body = Cohttp_lwt_body.empty) ?(cookies = Ocsigen_cookies.empty_cookieset) - ~response () = - { a_response = response ; a_body = body ; a_cookies = cookies } + a_response = + { a_response ; a_body = body ; a_cookies = cookies } let update ?response @@ -37,7 +37,12 @@ let of_cohttp let to_cohttp { a_response ; a_body } = a_response, a_body -let cookies {a_cookies} = a_cookies +let status { a_response = { Cohttp.Response.status } } = + match status with + | `Code _ -> + failwith "FIXME: Cohttp.Code.status_code -> status" + | #Cohttp.Code.status as a -> + a let set_status ({ a_response } as a) status = { a with @@ -46,6 +51,8 @@ let set_status ({ a_response } as a) status = } } +let cookies {a_cookies} = a_cookies + let add_cookies ({ a_cookies } as a) cookies = if cookies = Ocsigen_cookies.Cookies.empty then a @@ -85,12 +92,6 @@ let add_header_multi in { a with a_response = { a_response with headers } } -let remove_header ({a_response} as a) id = - let headers = Cohttp.Response.headers a_response - and id = Ocsigen_header.Name.to_string id in - let headers = Cohttp.Header.remove headers id in - { a with a_response = { a_response with headers } } - let replace_header ({a_response = ({headers} as a_response)} as a) id v = { @@ -114,9 +115,8 @@ let replace_headers ({a_response} as a) l = in { a with a_response = { a_response with headers } } -let status { a_response = { Cohttp.Response.status } } = - match status with - | `Code _ -> - failwith "FIXME: Cohttp.Code.status_code -> status" - | #Cohttp.Code.status as a -> - a +let remove_header ({a_response} as a) id = + let headers = Cohttp.Response.headers a_response + and id = Ocsigen_header.Name.to_string id in + let headers = Cohttp.Header.remove headers id in + { a with a_response = { a_response with headers } } diff --git a/src/server/ocsigen_response.mli b/src/server/ocsigen_response.mli index f61398699..feb29bb67 100644 --- a/src/server/ocsigen_response.mli +++ b/src/server/ocsigen_response.mli @@ -1,14 +1,9 @@ -type t = { - a_response : Cohttp.Response.t ; - a_body : Cohttp_lwt_body.t ; - a_cookies : Ocsigen_cookies.cookieset -} +type t val make : ?body : Cohttp_lwt_body.t -> ?cookies : Ocsigen_cookies.cookieset -> - response : Cohttp.Response.t -> - unit -> + Cohttp.Response.t -> t val update : @@ -27,10 +22,10 @@ val to_cohttp : t -> Cohttp.Response.t * Cohttp_lwt_body.t val status : t -> Cohttp.Code.status -val cookies : t -> Ocsigen_cookies.cookieset - val set_status : t -> Cohttp.Code.status -> t +val cookies : t -> Ocsigen_cookies.cookieset + val add_cookies : t -> Ocsigen_cookies.cookieset -> t val header : t -> Ocsigen_header.Name.t -> string option From 9c88278f3d437b7db45f7f90f755f80f1d5ad8dd Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 30 Mar 2017 14:59:04 +0200 Subject: [PATCH 045/111] Implement Ocsigen_header.Accept_language --- src/http/ocsigen_header.ml | 24 ++++++++++++++++++++++++ src/http/ocsigen_header.mli | 6 ++++++ 2 files changed, 30 insertions(+) diff --git a/src/http/ocsigen_header.ml b/src/http/ocsigen_header.ml index 45e119014..9f8d20277 100644 --- a/src/http/ocsigen_header.ml +++ b/src/http/ocsigen_header.ml @@ -132,6 +132,30 @@ module Accept = struct end + +module Accept_language = struct + + let parse_quality s = + try + let a, b = Ocsigen_lib.String.sep ';' s in + let q, qv = Ocsigen_lib.String.sep '=' b in + if q = "q" then + a, Some (float_of_string qv) + else + failwith "Parse error" + with _ -> + s, None + + let parse s = + try + List.map (Ocsigen_lib.String.split ',') s + |> List.flatten + |> List.map parse_quality + with _ -> + [] + +end + module Content_type = struct let choose accept default alt = diff --git a/src/http/ocsigen_header.mli b/src/http/ocsigen_header.mli index 5a75d55b7..c31162150 100644 --- a/src/http/ocsigen_header.mli +++ b/src/http/ocsigen_header.mli @@ -86,6 +86,12 @@ module Accept : sig end +module Accept_language : sig + + val parse : string list -> (string * float option) list + +end + module Content_type : sig val choose : Accept.t -> string -> string list -> string From 5598fcec5f8d9bef5259383c449cf4209098e230 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 30 Mar 2017 21:50:53 +0200 Subject: [PATCH 046/111] Fix Ocsigen_request SSL flag --- src/server/ocsigen_cohttp.ml | 15 +++++++++------ src/server/ocsigen_request.ml | 33 ++++++++++++++++++++------------- src/server/ocsigen_request.mli | 3 ++- 3 files changed, 31 insertions(+), 20 deletions(-) diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index bf4ed7997..eabd8b424 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -102,7 +102,7 @@ let make_cookies_headers path t hds = t hds -let handler ~address ~port ~connector (flow, conn) request body = +let handler ~ssl ~address ~port ~connector (flow, conn) request body = Lwt_log.ign_info_f ~section "Receiving the request: %s" @@ -182,7 +182,8 @@ let handler ~address ~port ~connector (flow, conn) request body = let request = Ocsigen_request.make - ~address ~port ~filenames ~sockaddr ~body ~connection_closed request + ~address ~port ~ssl + ~filenames ~sockaddr ~body ~connection_closed request in Lwt.catch @@ -231,7 +232,8 @@ let number_of_client () = 0 let get_number_of_connected = number_of_client let service ?ssl ~address ~port ~connector () = - let tls_server_key = match ssl with + let tls_server_key = + match ssl with | Some (crt, key, Some password) -> `TLS (`Crt_file_path crt, `Key_file_path key, @@ -249,8 +251,9 @@ let service ?ssl ~address ~port ~connector () = Lwt.return (Cohttp_lwt_unix_net.init ~ctx:conduit_ctx ()) >>= fun ctx -> (* We catch the INET_ADDR of the server *) let callback = - let address = Ocsigen_socket.to_inet_addr address in - handler ~address ~port ~connector + let address = Ocsigen_socket.to_inet_addr address + and ssl = match ssl with Some _ -> true | None -> false in + handler ~ssl ~address ~port ~connector in let config = Cohttp_lwt_unix.Server.make ~conn_closed ~callback () in let mode = @@ -259,6 +262,6 @@ let service ?ssl ~address ~port ~connector () = | `TLS (crt, key, pass) -> `OpenSSL (crt, key, pass, `Port port) in - Cohttp_lwt_unix.Server.create ~stop ~ctx ~mode config + Cohttp_lwt_unix.Server.create ~stop ~ctx ~mode config >>= fun () -> Lwt.return (Lwt.wakeup stop_wakener ()) diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 94b003b4b..253dbe67e 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -62,6 +62,7 @@ let make_uri u = type t = { r_address : Unix.inet_addr ; r_port : int ; + r_ssl : bool ; r_filenames : string list ref ; r_sockaddr : Lwt_unix.sockaddr ; r_remote_ip : string Lazy.t ; @@ -85,7 +86,7 @@ let make ?(forward_ip = []) ?sub_path ?original_full_path ?(request_cache = Polytables.create ()) ?cookies_override - ~address ~port ~filenames ~sockaddr ~body ~connection_closed + ~address ~port ~ssl ~filenames ~sockaddr ~body ~connection_closed request = let r_remote_ip = lazy @@ -98,6 +99,7 @@ let make { r_address = address ; r_port = port ; + r_ssl = ssl ; r_filenames = filenames ; r_sockaddr = sockaddr ; r_remote_ip ; @@ -124,13 +126,14 @@ let path {r_uri = {u_path}} = Lazy.force u_path let update - ?forward_ip ?remote_ip ?ssl ?sub_path + ?ssl ?forward_ip ?remote_ip ?sub_path ?meth ?get_params_flat ?post_data ?cookies_override ?(full_rewrite = false) ?uri ({ + r_ssl ; r_uri = {u_uri} as r_uri; r_meth ; r_forward_ip ; @@ -141,8 +144,13 @@ let update r_sub_path ; r_original_full_path } as r) = - (* FIXME : ssl *) - let r_forward_ip = + let r_ssl = + match ssl with + | Some ssl -> + ssl + | None -> + r_ssl + and r_forward_ip = match forward_ip with | Some forward_ip -> forward_ip @@ -154,6 +162,12 @@ let update lazy remote_ip, lazy (Ipaddr.of_string_exn remote_ip) | None -> r_remote_ip, r_remote_ip_parsed + and r_sub_path = + match sub_path with + | Some _ -> + sub_path + | None -> + r_sub_path and r_body = match post_data with | Some (Some post_data) -> @@ -168,12 +182,6 @@ let update cookies_override | None -> r_cookies_override - and r_sub_path = - match sub_path with - | Some _ -> - sub_path - | None -> - r_sub_path and r_meth = match meth with | Some meth -> @@ -212,6 +220,7 @@ let update r_uri in { r with + r_ssl ; r_uri ; r_meth ; r_forward_ip ; @@ -246,9 +255,7 @@ let meth {r_meth} = r_meth let port {r_port} = r_port -let ssl _ = - (* FIXME *) - false +let ssl {r_ssl} = r_ssl let version {r_version} = r_version diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli index 4215c1b84..36061cb19 100644 --- a/src/server/ocsigen_request.mli +++ b/src/server/ocsigen_request.mli @@ -19,6 +19,7 @@ val make : ?cookies_override : string Ocsigen_cookies.CookiesTable.t -> address : Unix.inet_addr -> port : int -> + ssl : bool -> filenames : string list ref -> sockaddr : Lwt_unix.sockaddr -> body : Cohttp_lwt_body.t -> @@ -27,9 +28,9 @@ val make : t val update : + ?ssl : bool -> ?forward_ip : string list -> ?remote_ip : string -> - ?ssl : bool -> ?sub_path : string -> ?meth : Cohttp.Code.meth -> ?get_params_flat : (string * string) list -> From 5245ba33f91afc0ba3eee8185627bf19b1c1da3e Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 31 Mar 2017 14:40:00 +0200 Subject: [PATCH 047/111] Log connection close --- src/server/ocsigen_cohttp.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index eabd8b424..fe3ef2281 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -105,8 +105,9 @@ let make_cookies_headers path t hds = let handler ~ssl ~address ~port ~connector (flow, conn) request body = Lwt_log.ign_info_f ~section - "Receiving the request: %s" - (Format.asprintf "%a" print_request request); + "Receiving the request: %s\nConnection ID: %s" + (Format.asprintf "%a" print_request request) + (Cohttp.Connection.to_string conn); let filenames = ref [] in let edn = Conduit_lwt_unix.endp_of_flow flow in @@ -214,8 +215,12 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body = let conn_closed (flow, conn) = try + Lwt_log.ign_info_f ~section + "Connection closed:\n%s" + (Cohttp.Connection.to_string conn); let wakener = Hashtbl.find waiters conn in - Lwt.wakeup wakener (); Hashtbl.remove waiters conn + Lwt.wakeup wakener (); + Hashtbl.remove waiters conn with Not_found -> () let stop, stop_wakener = Lwt.wait () From ed180bc3753a7f0a4ca3ab860a0d8a9f5940843c Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 5 Apr 2017 16:40:51 +0200 Subject: [PATCH 048/111] Compile Deflatemod against Cohttp APIs --- src/extensions/deflatemod.ml | 173 ++++++++++++++++++++--------------- src/http/ocsigen_header.ml | 65 ++++++++----- src/http/ocsigen_header.mli | 22 ++++- 3 files changed, 160 insertions(+), 100 deletions(-) diff --git a/src/extensions/deflatemod.ml b/src/extensions/deflatemod.ml index 6da3254d8..b31398b38 100644 --- a/src/extensions/deflatemod.ml +++ b/src/extensions/deflatemod.ml @@ -16,43 +16,36 @@ * You should have received a copy of the GNU Lesser 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. -*) -(*****************************************************************************) -(*****************************************************************************) -(* This module allows to compress output sent by the server *) -(*****************************************************************************) -(*****************************************************************************) + *) + +(* Compress output sent by the server *) -open Ocsigen_lib -open Lwt -open Ocsigen_extensions -open Simplexmlparser -open Ocsigen_headers +open Lwt.Infix let section = Lwt_log.Section.make "ocsigen:ext:deflate" (* Content-type *) -type filter = Type of string option * string option | Extension of string -type compress_choice = All_but of filter list | - Compress_only of filter list +type filter = + | Type of string option * string option + | Extension of string + +type compress_choice = + | All_but of filter list + | Compress_only of filter list let should_compress (t, t') url choice_list = let check = function - |Type (None, None) -> true - |Type (None, Some x') -> x' = t' - |Type (Some x, None) -> x = t - |Type (Some x, Some x') -> x = t && x' = t' - |Extension suff -> Filename.check_suffix url suff + | Type (None, None) -> true + | Type (None, Some x') -> x' = t' + | Type (Some x, None) -> x = t + | Type (Some x, Some x') -> x = t && x' = t' + | Extension suff -> Filename.check_suffix url suff in match choice_list with - |Compress_only l -> List.exists check l - |All_but l -> List.for_all (fun c -> not (check c)) l + | Compress_only l -> List.exists check l + | All_but l -> List.for_all (fun c -> not (check c)) l -(* Pas de filtre global pour l'instant - let choice_list = ref (All_but []) -*) - -(** Compression *) +(* Compression *) let buffer_size = ref 8192 @@ -68,7 +61,6 @@ let () = Bytes.set gzip_header 2 @@ Char.chr 8; Bytes.set gzip_header 9 @@ Char.chr 0xFF - (* inspired by an auxiliary function from camlzip, by Xavier Leroy *) type output_buffer = { @@ -176,11 +168,11 @@ let compress deflate stream = let finalize status = Ocsigen_stream.finalize stream status >>= fun e -> (try - Zlib.deflate_end zstream - with - (* ignore errors, deflate_end cleans everything anyway *) - Zlib.Error _ -> ()); - return (Lwt_log.ign_info ~section "Zlib stream closed") in + Zlib.deflate_end zstream + with + (* ignore errors, deflate_end cleans everything anyway *) + Zlib.Error _ -> ()); + Lwt.return (Lwt_log.ign_info ~section "Zlib stream closed") in let oz = { stream = zstream ; buf = Bytes.create !buffer_size; @@ -248,64 +240,92 @@ let select_encoding accept_header = in aux accept -exception No_compress - (* deflate = true -> mode deflate - * deflate = false -> mode gzip *) + deflate = false -> mode gzip *) let stream_filter contentencoding url deflate choice res = - return (Ext_found (fun () -> - try ( - match Ocsigen_http_frame.Result.content_type res with - | None -> raise No_compress (* il faudrait défaut ? *) - | Some contenttype -> - match Ocsigen_headers.parse_mime_type contenttype with - | None, _ | _, None -> raise No_compress (* should never happen? *) - | (Some a, Some b) - when should_compress (a, b) url choice -> - return - (Ocsigen_http_frame.Result.update res - ~content_length:None - ~etag: - (match Ocsigen_http_frame.Result.etag res with - | Some e -> - Some ((if deflate then "Ddeflatemod" else "Gdeflatemod")^e) - | None -> None) - ~stream: - (compress deflate (fst (Ocsigen_http_frame.Result.stream res)), None) - ~headers: - (Http_headers.replace - Http_headers.content_encoding - contentencoding (Ocsigen_http_frame.Result.headers res)) ()) - | _ -> raise No_compress) - with Not_found | No_compress -> return res)) + Lwt.return (Ocsigen_extensions.Ext_found (fun () -> + try ( + match + Ocsigen_response.header res + Ocsigen_header.Name.content_type + with + | None -> + Lwt.return res + | Some contenttype -> + match Ocsigen_header.Mime_type.parse contenttype with + | None, _ | _, None -> + Lwt.return res + | Some a, Some b when should_compress (a, b) url choice -> + let response, body = Ocsigen_response.to_cohttp res in + let response = + let headers = Cohttp.Response.headers response in + let headers = + let name = Ocsigen_header.Name.(to_string etag) in + match Cohttp.Header.get headers name with + | Some e -> + Cohttp.Header.replace headers name + ((if deflate then "Ddeflatemod" else "Gdeflatemod") ^ e) + | None -> + Cohttp.Header.remove headers name + in + let headers = + Cohttp.Header.replace headers + Ocsigen_header.Name.(to_string content_encoding) + contentencoding + in + {response with Cohttp.Response.headers} + and body = + Cohttp_lwt_body.to_stream body + |> Ocsigen_stream.of_lwt_stream + |> compress deflate + |> Ocsigen_stream.to_lwt_stream + |> Cohttp_lwt_body.of_stream + in + Lwt.return (Ocsigen_response.update res ~body ~response) + | _ -> + Lwt.return res) + with Not_found -> + Lwt.return res)) let filter choice_list = function - | Req_not_found (code,_) -> return (Ext_next code) - | Req_found ({ request_info = ri }, res) -> - match select_encoding (Lazy.force(Ocsigen_request_info.accept_encoding ri)) with + | Ocsigen_extensions.Req_not_found (code,_) -> + Lwt.return (Ocsigen_extensions.Ext_next code) + | Ocsigen_extensions.Req_found + ({ Ocsigen_extensions.request_info = ri }, res) -> + match + Ocsigen_request.header_multi ri Ocsigen_header.Name.accept_encoding + |> Ocsigen_header.Accept_encoding.parse + |> select_encoding + with | Deflate -> - stream_filter "deflate" (Ocsigen_request_info.sub_path_string ri) true choice_list res + stream_filter "deflate" + (Ocsigen_request.sub_path_string ri) true choice_list res | Gzip -> - stream_filter "gzip" (Ocsigen_request_info.sub_path_string ri) false choice_list res - | Id | Star -> return (Ext_found (fun () -> return res)) + stream_filter "gzip" + (Ocsigen_request.sub_path_string ri) false choice_list res + | Id | Star -> + Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return res)) | Not_acceptable -> - return (Ext_stop_all (Ocsigen_http_frame.Result.cookies res,406)) + Lwt.return + (Ocsigen_extensions.Ext_stop_all + (Ocsigen_response.cookies res, `Not_acceptable)) (*****************************************************************************) let rec parse_global_config = function | [] -> () - | (Element ("compress", [("level", l)], []))::ll -> + | (Simplexmlparser.Element ("compress", [("level", l)], []))::ll -> let l = try int_of_string l - with Failure _ -> raise (Error_in_config_file + with Failure _ -> raise (Ocsigen_extensions.Error_in_config_file "Compress level should be an integer between 0 and 9") in compress_level := if (l <= 9 && l >= 0) then l else 6 ; parse_global_config ll - | (Element ("buffer", [("size", s)], []))::ll -> + | (Simplexmlparser.Element ("buffer", [("size", s)], []))::ll -> let s = (try int_of_string s - with Failure _ -> raise (Error_in_config_file - "Buffer size should be a positive integer")) in + with Failure _ -> + raise (Ocsigen_extensions.Error_in_config_file + "Buffer size should be a positive integer")) in buffer_size := if s > 0 then s else 8192 ; parse_global_config ll (* TODO: Pas de filtre global pour l'instant @@ -321,7 +341,7 @@ let rec parse_global_config = function "Attribute \"compress\" should be \"allbut\" or \"only\"")); parse_global_config ll *) - | _ -> raise (Error_in_config_file + | _ -> raise (Ocsigen_extensions.Error_in_config_file "Unexpected content inside deflatemod config") (*****************************************************************************) @@ -352,7 +372,7 @@ let parse_config config_elem = Configuration.element ~name:"type" ~pcdata:(fun s -> - let (a, b) = Ocsigen_headers.parse_mime_type s in + let (a, b) = Ocsigen_header.Mime_type.parse s in pages := Type (a, b) :: !pages) (); Configuration.element ~name:"extension" @@ -365,7 +385,7 @@ let parse_config config_elem = ); match !pages with | [] -> - badconfig + Ocsigen_extensions.badconfig "Unexpected element inside contenttype (should be or )" | l -> let mode = match !mode with @@ -375,7 +395,8 @@ let parse_config config_elem = (*****************************************************************************) (** Registration of the extension *) -let () = Ocsigen_extensions.register_extension +let () = + Ocsigen_extensions.register_extension ~name:"deflatemod" ~fun_site:(fun _ _ _ _ _ -> parse_config) ~init_fun:parse_global_config diff --git a/src/http/ocsigen_header.ml b/src/http/ocsigen_header.ml index 9f8d20277..729832e8a 100644 --- a/src/http/ocsigen_header.ml +++ b/src/http/ocsigen_header.ml @@ -85,23 +85,40 @@ module Name = struct end -module Accept = struct +let parse_star a = + if a = "*" then + None + else + Some a + +let parse_quality f s = + try + let a, b = Ocsigen_lib.String.sep ';' s in + let q, qv = Ocsigen_lib.String.sep '=' b in + if q = "q" then + f a, Some (float_of_string qv) + else + failwith "Parse error" + with _ -> + f s, None - type t = - ((string option * string option) * - float option * - (string * string) list) list +module Mime_type = struct - let parse_star a = - if a = "*" then - None - else - Some a + type t = string option * string option - let parse_mime_type a = + let parse a = let b, c = Ocsigen_lib.String.sep '/' a in parse_star b, parse_star c +end + +module Accept = struct + + type t = + (Mime_type.t * + float option * + (string * string) list) list + let parse_extensions parse_name s = try let a, b = Ocsigen_lib.String.sep ';' s in @@ -119,7 +136,7 @@ module Accept = struct let parse s = try - let l = parse_list_with_extensions parse_mime_type s in + let l = parse_list_with_extensions Mime_type.parse s in let change_quality (a, l) = try let q, ll = Ocsigen_lib.List.assoc_remove "q" l in @@ -132,25 +149,29 @@ module Accept = struct end +module Accept_encoding = struct -module Accept_language = struct + type t = (string option * float option) list - let parse_quality s = + let parse s = try - let a, b = Ocsigen_lib.String.sep ';' s in - let q, qv = Ocsigen_lib.String.sep '=' b in - if q = "q" then - a, Some (float_of_string qv) - else - failwith "Parse error" + List.map (Ocsigen_lib.String.split ',') s + |> List.flatten + |> List.map (parse_quality parse_star) with _ -> - s, None + [] + +end + +module Accept_language = struct + + type t = (string * float option) list let parse s = try List.map (Ocsigen_lib.String.split ',') s |> List.flatten - |> List.map parse_quality + |> List.map (parse_quality (fun x -> x)) with _ -> [] diff --git a/src/http/ocsigen_header.mli b/src/http/ocsigen_header.mli index c31162150..7ede88425 100644 --- a/src/http/ocsigen_header.mli +++ b/src/http/ocsigen_header.mli @@ -75,10 +75,18 @@ module Name : sig end +module Mime_type : sig + + type t = string option * string option + + val parse : string -> t + +end + module Accept : sig type t = - ((string option * string option) + (Mime_type.t * float option * (string * string) list) list @@ -86,9 +94,19 @@ module Accept : sig end +module Accept_encoding : sig + + type t = (string option * float option) list + + val parse : string list -> t + +end + module Accept_language : sig - val parse : string list -> (string * float option) list + type t = (string * float option) list + + val parse : string list -> t end From da92c9d364d6d09987db73d7d6594586a3f3f5eb Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 10 Apr 2017 14:33:38 +0200 Subject: [PATCH 049/111] We need chunked encoding in deflatemod --- src/extensions/deflatemod.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/extensions/deflatemod.ml b/src/extensions/deflatemod.ml index b31398b38..98a4ab976 100644 --- a/src/extensions/deflatemod.ml +++ b/src/extensions/deflatemod.ml @@ -266,14 +266,17 @@ let stream_filter contentencoding url deflate choice res = Cohttp.Header.replace headers name ((if deflate then "Ddeflatemod" else "Gdeflatemod") ^ e) | None -> - Cohttp.Header.remove headers name + headers in let headers = Cohttp.Header.replace headers Ocsigen_header.Name.(to_string content_encoding) contentencoding in - {response with Cohttp.Response.headers} + { response with + Cohttp.Response.headers ; + Cohttp.Response.encoding = Cohttp.Transfer.Chunked + } and body = Cohttp_lwt_body.to_stream body |> Ocsigen_stream.of_lwt_stream From 060f644d0269cb162d6ac19b7e0d4d1d792779cb Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 10 Apr 2017 22:42:45 +0200 Subject: [PATCH 050/111] Remove Ocsigen_request.path_string leading slash --- src/server/ocsigen_request.ml | 35 +++++++++++++++++------------------ 1 file changed, 17 insertions(+), 18 deletions(-) diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 253dbe67e..b6c22c422 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -44,17 +44,18 @@ let unflatten_get_params l = let flatten_get_params l = List.concat (List.map (fun (s, l) -> List.map (fun v -> s, v) l) l) +let remove_trailing_slash_string s = + if String.length s > 0 && String.get s 0 = '/' then + String.sub s 1 (String.length s - 1) + else + s + let make_uri u = let u_uri = lazy u and u_get_params = lazy (Uri.query u) - and u_path_string = lazy (Uri.path u) in - let u_path = lazy ( - match Ocsigen_lib.Url.split_path (Lazy.force u_path_string) with - | "" :: path -> - path - | path -> - path - ) and u_get_params_flat = lazy ( + and u_path_string = lazy (remove_trailing_slash_string (Uri.path u)) in + let u_path = lazy (Ocsigen_lib.Url.split_path (Lazy.force u_path_string)) + and u_get_params_flat = lazy ( flatten_get_params (Lazy.force u_get_params) ) in { u_uri ; u_get_params ; u_get_params_flat ; u_path ; u_path_string } @@ -268,18 +269,16 @@ let get_params {r_uri = { u_get_params }} = let get_params_flat {r_uri = { u_get_params_flat }} = Lazy.force u_get_params_flat -let sub_path_string = function - | {r_sub_path = Some r_sub_path} -> - r_sub_path - | r -> - path_string r +let sub_path_string req = + remove_trailing_slash_string + (match req with + | {r_sub_path = Some r_sub_path} -> + r_sub_path + | r -> + path_string r) let sub_path r = - match Ocsigen_lib.Url.split_path (sub_path_string r) with - | "" :: path -> - path - | path -> - path + Ocsigen_lib.Url.split_path (sub_path_string r) let original_full_path_string = function | {r_original_full_path = Some r_original_full_path} -> From 2c4f2ed2b3ac78a0d29d545a7f9c3cb7b9b6f449 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 11 Apr 2017 19:16:28 +0200 Subject: [PATCH 051/111] Fix revproxy Cohttp.Client calls --- src/extensions/revproxy.ml | 71 +++++++++++++++++++------------------- 1 file changed, 36 insertions(+), 35 deletions(-) diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index 641932797..1f39eed2a 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -65,15 +65,17 @@ let gen dir = function try fi false with Ocsigen_extensions.Not_concerned -> fi true in - let (https, host, port, uri) = + let (https, host, port, path) = try + (* FIXME: we do not seem to handle GET + parameters. Why? *) match Ocsigen_lib.Url.parse dest with - | (Some https, Some host, port, uri, _, _, _) -> + | (Some https, Some host, port, path, _, _, _) -> let port = match port with | None -> if https then 443 else 80 | Some p -> p in - (https, host, port, uri) + (https, host, port, path) | _ -> raise (Ocsigen_extensions.Error_in_config_file ("Revproxy : error in destination URL "^dest)) @@ -83,10 +85,10 @@ let gen dir = function ("Revproxy : error in destination URL "^dest^" - "^ Printexc.to_string e)) in - let uri = "/"^uri in + Lwt_log.ign_info_f ~section - "YES! Redirection to http%s://%s:%d%s" - (if https then "s" else "") host port uri; + "YES! Redirection to http%s://%s:%d/%s" + (if https then "s" else "") host port path; Ocsigen_lib.Ip_address.get_inet_addr host >>= fun inet_addr -> @@ -95,34 +97,7 @@ let gen dir = function We are sure that the request won't be taken in disorder, so we return. *) - let host = - match - if dir.keephost then - Ocsigen_request.host request_info - else - None - with - | Some h -> h - | None -> host - in - let do_request () = - let address = - Unix.string_of_inet_addr - (Ocsigen_request.address request_info) - in - let forward = - String.concat ", " - (Ocsigen_request.remote_ip request_info - :: Ocsigen_request.forward_ip request_info - @ [address]) - in - let proto = - if Ocsigen_request.ssl request_info then - "https" - else - "http" - in let headers = let h = Cohttp.Request.headers @@ -135,15 +110,41 @@ let gen dir = function Ocsigen_header.Name.(to_string x_forwarded_proto) in let h = + let forward = + let address = + Unix.string_of_inet_addr + (Ocsigen_request.address request_info) + in + String.concat ", " + (Ocsigen_request.remote_ip request_info + :: Ocsigen_request.forward_ip request_info + @ [address]) + in Cohttp.Header.add h Ocsigen_header.Name.(to_string x_forwarded_for) forward in Cohttp.Header.remove h Ocsigen_header.Name.(to_string host) - and uri = Printf.sprintf "%s://%s%s" proto host uri + and uri = + let scheme = + if Ocsigen_request.ssl request_info then + "https" + else + "http" + and host = + match + if dir.keephost then + Ocsigen_request.host request_info + else + None + with + | Some host -> host + | None -> host + in + Uri.make ~scheme ~host ~port ~path () and body = Ocsigen_request.body request_info and meth = Ocsigen_request.meth request_info in - Client.call ~headers ~body meth (Uri.of_string uri) + Client.call ~headers ~body meth uri in Lwt.return @@ Ext_found (fun () -> do_request () >|= Ocsigen_response.of_cohttp)) From ecc42ad5a835dd9a0d397326c64b5b27e3aa7a52 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 13 Apr 2017 11:43:06 +0200 Subject: [PATCH 052/111] Clearer pp of multiple header instances --- src/server/ocsigen_cohttp.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index fe3ef2281..acca3c79e 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -13,6 +13,7 @@ exception Ext_http_error of @param request Cohttp request *) let print_request fmt request = + let print_list print_data out_ch lst = let rec aux = function | [] -> () @@ -28,8 +29,10 @@ let print_request fmt request = Cohttp.Header.iter (fun key values -> - Format.fprintf fmt "\t%s = %a\n" key - (print_list Format.pp_print_string) values) + (print_list + (fun fmt value -> Format.fprintf fmt "\t%s = %s\n" key value) + fmt + values)) request.headers let waiters = Hashtbl.create 256 From a9b309b54ce58c2e70b62026d8520b42058d1534 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 13 Apr 2017 12:24:19 +0200 Subject: [PATCH 053/111] Revproxy: only one X-Forwarded-* header --- src/extensions/revproxy.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index 1f39eed2a..c3b44f265 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -106,7 +106,7 @@ let gen dir = function let h = Ocsigen_request.version request_info |> Cohttp.Code.string_of_version - |> Cohttp.Header.add h + |> Cohttp.Header.replace h Ocsigen_header.Name.(to_string x_forwarded_proto) in let h = @@ -120,7 +120,7 @@ let gen dir = function :: Ocsigen_request.forward_ip request_info @ [address]) in - Cohttp.Header.add h + Cohttp.Header.replace h Ocsigen_header.Name.(to_string x_forwarded_for) forward in From 4bea2bf44d07574547d3ff601585e1a3d88b1b61 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 21 Apr 2017 13:27:05 +0200 Subject: [PATCH 054/111] Un-open modules in revproxy --- src/extensions/revproxy.ml | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index c3b44f265..46d0ad3a5 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -23,10 +23,7 @@ The reverse proxy is still experimental. *) open Lwt.Infix -open Ocsigen_extensions open Simplexmlparser -open Cohttp -open Cohttp_lwt_unix let section = Lwt_log.Section.make "ocsigen:ext:revproxy" @@ -45,7 +42,8 @@ type redir = { let gen dir = function | Ocsigen_extensions.Req_found _ -> Lwt.return Ocsigen_extensions.Ext_do_nothing - | Ocsigen_extensions.Req_not_found (err, {request_info}) -> + | Ocsigen_extensions.Req_not_found + (err, {Ocsigen_extensions.request_info}) -> Lwt.catch (* Is it a redirection? *) (fun () -> @@ -144,12 +142,14 @@ let gen dir = function Uri.make ~scheme ~host ~port ~path () and body = Ocsigen_request.body request_info and meth = Ocsigen_request.meth request_info in - Client.call ~headers ~body meth uri + Cohttp_lwt_unix.Client.call ~headers ~body meth uri in Lwt.return @@ - Ext_found (fun () -> do_request () >|= Ocsigen_response.of_cohttp)) + Ocsigen_extensions.Ext_found + (fun () -> do_request () >|= Ocsigen_response.of_cohttp)) (function - | Not_concerned -> Lwt.return (Ext_next err) + | Ocsigen_extensions.Not_concerned -> + Lwt.return (Ocsigen_extensions.Ext_next err) | e -> Lwt.fail e) let parse_config config_elem = @@ -198,9 +198,11 @@ let parse_config config_elem = ); match !regexp, !full_url, !dest, !pipeline, !keephost with | (None, _, _, _, _) -> - badconfig "Missing attribute 'regexp' for " + Ocsigen_extensions.badconfig + "Missing attribute 'regexp' for " | (_, _, None, _, _) -> - badconfig "Missing attribute 'dest' for " + Ocsigen_extensions.badconfig + "Missing attribute 'dest' for " | (Some regexp, full_url, Some dest, pipeline, keephost) -> gen { regexp = Netstring_pcre.regexp ("^" ^ regexp ^ "$"); @@ -210,7 +212,8 @@ let parse_config config_elem = keephost; } -let () = register_extension +let () = + Ocsigen_extensions.register_extension ~name:"revproxy" ~fun_site:(fun _ _ _ _ _ -> parse_config) ~user_fun_site:(fun _ _ _ _ _ _ -> parse_config) From 4a0a6c3b9f0272dc079db94dc11b0255ed33d49b Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 21 Apr 2017 15:43:12 +0200 Subject: [PATCH 055/111] Do not use Netdate --- src/baselib/ocsigen_lib_base.ml | 40 ++++++++++++++++++++++++++++++++ src/baselib/ocsigen_lib_base.mli | 7 ++++++ src/extensions/staticmod.ml | 16 ++----------- src/server/ocsigen_cohttp.ml | 10 ++------ 4 files changed, 51 insertions(+), 22 deletions(-) diff --git a/src/baselib/ocsigen_lib_base.ml b/src/baselib/ocsigen_lib_base.ml index 9ccaa9c3c..d9888d89e 100644 --- a/src/baselib/ocsigen_lib_base.ml +++ b/src/baselib/ocsigen_lib_base.ml @@ -464,3 +464,43 @@ end (*****************************************************************************) let debug = prerr_endline + +module Date = struct + + let name_of_day = function + | 0 -> "Sun" + | 1 -> "Mon" + | 2 -> "Tue" + | 3 -> "Wed" + | 4 -> "Thu" + | 5 -> "Fri" + | 6 -> "Sat" + | _ -> failwith "name_of_day" + + let name_of_month = function + | 0 -> "Jan" + | 1 -> "Feb" + | 2 -> "Mar" + | 3 -> "Apr" + | 4 -> "May" + | 5 -> "Jun" + | 6 -> "Jul" + | 7 -> "Aug" + | 8 -> "Sep" + | 9 -> "Oct" + | 10 -> "Nov" + | 11 -> "Dec" + | _ -> failwith "name_of_month" + + let to_string d = + let { + Unix.tm_wday ; + tm_mday ; tm_mon ; tm_year ; + tm_hour ; tm_min ; tm_sec + } = Unix.gmtime d in + Printf.sprintf "%s, %02d %s %d %2d:%2d:%2d GMT" + (name_of_day tm_wday) + tm_mday (name_of_month tm_mon) (tm_year + 1900) + tm_hour tm_min tm_sec + +end diff --git a/src/baselib/ocsigen_lib_base.mli b/src/baselib/ocsigen_lib_base.mli index 1c158faed..63d08a0b1 100644 --- a/src/baselib/ocsigen_lib_base.mli +++ b/src/baselib/ocsigen_lib_base.mli @@ -198,3 +198,10 @@ module Printexc : sig end val debug : string -> unit + +module Date : sig + + (** Converts Unix GMT date to string *) + val to_string : float -> string + +end diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 898cd8fbe..624c73c45 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -112,19 +112,6 @@ let find_static_page ~request ~usermode ~dir ~(err : Cohttp.Code.status) ~pathst raise (Ocsigen_extensions.Error_in_user_config_file "Staticmod: cannot use '..' in user paths") -(* FIXME Cohttp transition: this used to be in Ocsigen_http_com; find - a better place? *) -let gmt_date d = - let x = Netdate.mk_mail_date ~zone:0 d in try - (*XXX !!!*) - let ind_plus = Bytes.index x '+' in - Bytes.set x ind_plus 'G'; - Bytes.set x (ind_plus + 1) 'M'; - Bytes.set x (ind_plus + 2) 'T'; - String.sub x 0 (ind_plus + 3) - with Invalid_argument _ | Not_found -> - Lwt_log.ign_debug ~section "no +"; x - let gen ~usermode ?cache dir = function | Ocsigen_extensions.Req_found (_, r) -> Lwt.return (Ocsigen_extensions.Ext_do_nothing) @@ -165,7 +152,8 @@ let gen ~usermode ?cache dir = function "no-cache", "0" else "max-age=" ^ string_of_int duration, - gmt_date (Unix.time () +. float_of_int duration) + Ocsigen_lib.Date.to_string + (Unix.time () +. float_of_int duration) in Ocsigen_response.replace_headers answer [ Ocsigen_header.Name.cache_control , cache_control ; diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index acca3c79e..5b52c4e86 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -48,10 +48,7 @@ module Cookie = struct (if secure then "; secure" else "") (match exp with | Some s -> - "; expires=" ^ - Netdate.format - "%a, %d-%b-%Y %H:%M:%S GMT" - (Netdate.create s) + "; expires=" ^ (Ocsigen_lib.Date.to_string s) | None -> "") @@ -82,10 +79,7 @@ let make_cookies_header path exp name c secure = "" ^ (match exp with | Some s -> - "; expires=" ^ - Netdate.format - "%a, %d-%b-%Y %H:%M:%S GMT" - (Netdate.create s) + "; expires=" ^ Ocsigen_lib.Date.to_string s | None -> "") let make_cookies_headers path t hds = From c4637e3851373baedba12cc8da1597af9d777460 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 21 Apr 2017 16:41:44 +0200 Subject: [PATCH 056/111] Mostly eliminate Neturl dependency We only need Neturl.norm_path . Copy it? --- src/baselib/ocsigen_lib.ml | 4 +--- src/baselib/ocsigen_lib.mli | 3 --- src/baselib/ocsigen_lib_base.ml | 23 +++++++++++++++++++++ src/baselib/ocsigen_lib_base.mli | 4 ++++ src/extensions/revproxy.ml | 2 +- src/server/ocsigen_cohttp.ml | 14 ++++--------- src/server/ocsigen_cohttp.mli | 2 +- src/server/ocsigen_extensions.ml | 33 ++++++++++++++----------------- src/server/ocsigen_extensions.mli | 6 ++---- src/server/ocsigen_local_files.ml | 10 +++++++--- src/server/ocsigen_server.ml | 2 -- 11 files changed, 58 insertions(+), 45 deletions(-) diff --git a/src/baselib/ocsigen_lib.ml b/src/baselib/ocsigen_lib.ml index d645e32eb..80887a953 100644 --- a/src/baselib/ocsigen_lib.ml +++ b/src/baselib/ocsigen_lib.ml @@ -244,7 +244,7 @@ module Url = struct end in - let path = List.map (Netencoding.Url.decode ~plus:false) (Neturl.split_path pathstring) in + let path = List.map (Netencoding.Url.decode ~plus:false) (split_path pathstring) in let path = remove_dotdot path (* and remove "//" *) (* here we remove .. from paths, as it is dangerous. But in some very particular cases, we may want them? @@ -257,6 +257,4 @@ module Url = struct (https, host, port, uri_string, path, query, get_params) - let split_path = Neturl.split_path - end diff --git a/src/baselib/ocsigen_lib.mli b/src/baselib/ocsigen_lib.mli index 6f2905e3e..30635adc6 100644 --- a/src/baselib/ocsigen_lib.mli +++ b/src/baselib/ocsigen_lib.mli @@ -75,7 +75,4 @@ module Url : sig string list * string option * (string * string) list Lazy.t - (** alias of (Ocamlnet) [Neturl.split_path] *) - val split_path : string -> string list - end diff --git a/src/baselib/ocsigen_lib_base.ml b/src/baselib/ocsigen_lib_base.ml index d9888d89e..17028c69c 100644 --- a/src/baselib/ocsigen_lib_base.ml +++ b/src/baselib/ocsigen_lib_base.ml @@ -439,6 +439,29 @@ module Url_base = struct Some (String.sub s (pos+1) (String.length s - 1 - pos)) with Not_found -> s, None + let join_path = function [""] -> "/" | l -> String.concat "/" l + + (* Taken from Ocamlnet 4.1.2 *) + let split_path s = + let l = String.length s in + let rec collect_words k = + let k' = + try + String.index_from s k '/' + with + Not_found -> l + in + let word = String.sub s k (k'-k) in + if k' >= l then + [word] + else + word :: collect_words (k'+1) + in + match collect_words 0 with + | [ "" ] -> [] + | [ "";"" ] -> [ "" ] + | other -> other + end (************************************************************************) diff --git a/src/baselib/ocsigen_lib_base.mli b/src/baselib/ocsigen_lib_base.mli index 63d08a0b1..f03ab11fd 100644 --- a/src/baselib/ocsigen_lib_base.mli +++ b/src/baselib/ocsigen_lib_base.mli @@ -187,6 +187,10 @@ module Url_base : sig (** [split_fragment str] splits [str] at first '#' *) val split_fragment : string -> string * string option + val join_path : path -> string + + val split_path : string -> path + end module Printexc : sig diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index 46d0ad3a5..049077a40 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -77,7 +77,7 @@ let gen dir = function | _ -> raise (Ocsigen_extensions.Error_in_config_file ("Revproxy : error in destination URL "^dest)) - (*VVV catch only Neturl exceptions! *) + (*VVV catch only URL-related exceptions? *) with e -> raise (Ocsigen_extensions.Error_in_config_file ("Revproxy : error in destination URL "^dest^" - "^ diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index 5b52c4e86..e9af7c468 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -37,7 +37,7 @@ let print_request fmt request = let waiters = Hashtbl.create 256 -exception Ocsigen_Is_a_directory of (Ocsigen_request.t -> Neturl.url) +exception Ocsigen_is_dir of (Ocsigen_request.t -> Uri.t) module Cookie = struct @@ -145,8 +145,6 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body = headers, code | Ocsigen_lib.Ocsigen_Bad_Request -> None, `Bad_request - | Neturl.Malformed_URL -> - None, `Bad_request | Ocsigen_lib.Ocsigen_Request_too_long -> None, `Request_entity_too_large | exn -> @@ -200,13 +198,9 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body = in Lwt.return (response, body)) (function - | Ocsigen_Is_a_directory fun_request -> - Cohttp_lwt_unix.Server.respond_redirect - ~uri: - (fun_request request - |> Neturl.string_of_url - |> Uri.of_string) - () + | Ocsigen_is_dir fun_request -> + Cohttp_lwt_unix.Server.respond_redirect () + ~uri:(fun_request request) | exn -> handle_error exn) diff --git a/src/server/ocsigen_cohttp.mli b/src/server/ocsigen_cohttp.mli index 6befce73d..994623e05 100644 --- a/src/server/ocsigen_cohttp.mli +++ b/src/server/ocsigen_cohttp.mli @@ -8,7 +8,7 @@ exception Ext_http_error of Cohttp.Code.status * string option * Cohttp.Header.t option (** compute a redirection if path links to a directory *) -exception Ocsigen_Is_a_directory of (Ocsigen_request.t -> Neturl.url) +exception Ocsigen_is_dir of (Ocsigen_request.t -> Uri.t) (** accessor to get number of client (used by eliom monitoring) *) val number_of_client : unit -> int diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 148a18f21..a4b30ec2d 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -179,7 +179,7 @@ type request = { request_config : config_info; } -exception Ocsigen_Is_a_directory = Ocsigen_cohttp.Ocsigen_Is_a_directory +exception Ocsigen_is_dir = Ocsigen_cohttp.Ocsigen_is_dir type answer = | Ext_do_nothing @@ -298,24 +298,22 @@ let get_port else Ocsigen_request.port request_info -let http_url_syntax = Hashtbl.find Neturl.common_url_syntax "http" - let new_url_of_directory_request request ri = Lwt_log.ign_info ~section "Sending 301 Moved permanently"; - let port = get_port request in - let ssl = Ocsigen_request.ssl ri in - Neturl.make_url + let port = get_port request + and ssl = Ocsigen_request.ssl ri in + Uri.make ~scheme:(if ssl then "https" else "http") ~host:(get_hostname request) - ?port:(if (port = 80 && not ssl) - || (ssl && port = 443) - then None - else Some port) - ~path:("" :: - (Url.add_end_slash_if_missing - (Ocsigen_request.path ri))) - ?query:(Ocsigen_request.query ri) - http_url_syntax + ?port:( + if (port = 80 && not ssl) || (ssl && port = 443) then + None + else + Some port + ) + ~path:(Ocsigen_request.path_string ri) + ~query:(Ocsigen_request.get_params ri) + () (*****************************************************************************) (* To give parameters to extensions: *) @@ -333,8 +331,7 @@ let site_match request (site_path : string list) url = let rec aux site_path url = match site_path, url with | [], [] -> - raise (Ocsigen_Is_a_directory - (new_url_of_directory_request request)) + raise (Ocsigen_is_dir (new_url_of_directory_request request)) | [], p -> Some p | a::l, aa::ll when a = aa -> aux l ll | _ -> None @@ -428,7 +425,7 @@ let rec default_parse_config prevpath@ Url.remove_slash_at_end (Url.remove_slash_at_beginning - (Url.remove_dotdot (Neturl.split_path dir))) + (Url.remove_dotdot (Ocsigen_lib.Url.split_path dir))) in let parse_config = make_parse_config path parse_host l in let ext cookies_to_set = diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 5bf5f6719..d5f112b67 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -129,8 +129,7 @@ type request = { request_config: config_info; } -exception Ocsigen_Is_a_directory - of (Ocsigen_request.t -> Neturl.url) +exception Ocsigen_is_dir of (Ocsigen_request.t -> Uri.t) type answer = | Ext_do_nothing @@ -408,8 +407,7 @@ val get_port : request -> int for the client (depending on the server configuration and request) @param request configuration of the server @param ri request *) -val new_url_of_directory_request : - request -> Ocsigen_request.t -> Neturl.url +val new_url_of_directory_request : request -> Ocsigen_request.t -> Uri.t (** {3 User directories} *) diff --git a/src/server/ocsigen_local_files.ml b/src/server/ocsigen_local_files.ml index 40ed22856..698b76772 100644 --- a/src/server/ocsigen_local_files.ml +++ b/src/server/ocsigen_local_files.ml @@ -106,7 +106,10 @@ let check_dotdot = let can_send filename request = let filename = - Neturl.join_path (Neturl.norm_path (Neturl.split_path filename)) in + Ocsigen_lib.Url.split_path filename + |> Neturl.norm_path + |> Ocsigen_lib.Url.join_path + in Lwt_log.ign_info_f ~section "checking if file %s can be sent" filename; let matches arg = Netstring_pcre.string_match (Ocsigen_extensions.do_not_serve_to_regexp arg) @@ -166,8 +169,9 @@ let resolve its name as there is no final slash. We signal this fact to Ocsigen, which will then issue a 301 redirection to "filename/" *) Lwt_log.ign_info_f ~section "LocalFiles: %s is a directory" filename; - raise (Ocsigen_extensions.Ocsigen_Is_a_directory - (Ocsigen_extensions.new_url_of_directory_request request)) + raise + (Ocsigen_extensions.Ocsigen_is_dir + (Ocsigen_extensions.new_url_of_directory_request request)) end else diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index 59d212dd5..33a62e8e8 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -51,8 +51,6 @@ let dbg sockaddr s = (Ocsigen_socket.ip_of_sockaddr sockaddr)) sockaddr s -let http_url_syntax = Hashtbl.find Neturl.common_url_syntax "http" - let try_bind' f g h = Lwt.try_bind f h g (* fatal errors messages *) From ebe9a6079cdd76641d873dce85765f6d465ac35c Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 25 Apr 2017 22:45:38 +0200 Subject: [PATCH 057/111] Get rid of Netstring_pcre --- src/baselib/ocsigen_lib.ml | 130 +++++++++++++++++++++++++- src/baselib/ocsigen_lib.mli | 24 +++++ src/baselib/ocsigen_loader.ml | 7 +- src/baselib/ocsigen_stream.ml | 8 +- src/extensions/accesscontrol.ml | 5 +- src/extensions/cors.ml | 12 ++- src/extensions/extendconfiguration.ml | 6 +- src/extensions/outputfilter.ml | 8 +- src/extensions/redirectmod.ml | 5 +- src/extensions/staticmod.ml | 22 ++--- src/extensions/userconf.ml | 10 +- src/http/ocsigen_charset_mime.ml | 2 +- src/http/ocsigen_charset_mime.mli | 11 +-- src/server/ocsigen_extensions.ml | 62 ++++++------ src/server/ocsigen_extensions.mli | 8 +- src/server/ocsigen_local_files.ml | 13 ++- src/server/ocsigen_multipart.ml | 31 +++--- src/server/ocsigen_parseconfig.ml | 12 ++- 18 files changed, 279 insertions(+), 97 deletions(-) diff --git a/src/baselib/ocsigen_lib.ml b/src/baselib/ocsigen_lib.ml index 80887a953..645936c64 100644 --- a/src/baselib/ocsigen_lib.ml +++ b/src/baselib/ocsigen_lib.ml @@ -102,6 +102,90 @@ let make_cryptographic_safe_string = ID collision if the server were to be restarted. *) +module Netstring_pcre = struct + + let regexp s = Pcre.regexp ~flags:[`MULTILINE] s + + let templ_re = Pcre.regexp "(?:\\\\\\d)|[\\$\\\\]" ;; + + let tr_templ s = + (* Convert \n to $n etc. *) + (* Unfortunately we cannot just replace \ by $. *) + let rec tr l = + match l with + Pcre.Delim "$" :: l' -> "$$" :: tr l' + | Pcre.Delim "\\" :: Pcre.Delim "$" :: l' -> "$$" :: tr l' + | Pcre.Delim "\\" :: Pcre.Delim s :: l' -> s :: tr l' + | Pcre.Delim "\\" :: Pcre.Text s :: l' -> s :: tr l' + | [ Pcre.Delim "\\" ] -> failwith "trailing backslash" + | Pcre.Delim d :: l' -> + assert(d.[0] = '\\'); + let n = Char.code d.[1] - Char.code '0' in + if n = 0 then + "$&" :: tr l' + else + ("$" ^ string_of_int n ^ "$!") :: tr l' + | Pcre.Text t :: l' -> t :: tr l' + | Pcre.Group(_,_) :: _ -> assert false + | Pcre.NoGroup :: _ -> assert false + | [] -> [] + in + let l = Pcre.full_split ~rex:templ_re ~max:(-1) s in + String.concat "" (tr l) + + let matched_group result n _ = + if n < 0 || n >= Pcre.num_of_subs result then raise Not_found; + ignore (Pcre.get_substring_ofs result n); + Pcre.get_substring result n + + let matched_string result _ = + ignore (Pcre.get_substring_ofs result 0); + Pcre.get_substring result 0 + + let global_replace pat templ s = + Pcre.replace ~rex:pat ~itempl:(Pcre.subst (tr_templ templ)) s + + let global_substitute pat subst s = + Pcre.substitute_substrings ~rex:pat ~subst:(fun r -> subst r s) s + + let search_forward pat s pos = + let result = Pcre.exec ~rex:pat ~pos s in + fst (Pcre.get_substring_ofs result 0), result + + let string_after s n = + String.sub s n (String.length s - n) + + let bounded_split expr text num = + let start = + try + let start_substrs = Pcre.exec ~rex:expr ~flags:[`ANCHORED] text in + (* or Not_found *) + let (_,match_end) = Pcre.get_substring_ofs start_substrs 0 in + match_end + with + Not_found -> 0 + in + let rec split start n = + if start >= String.length text then [] else + if n = 1 then [string_after text start] else + try + let next_substrs = Pcre.exec ~rex:expr ~pos:start text + in (* or Not_found *) + let pos, match_end = Pcre.get_substring_ofs next_substrs 0 in + String.sub text start (pos-start) :: split match_end (n-1) + with Not_found -> + [string_after text start] in + split start num + + let split sep s = bounded_split sep s 0 + + let string_match pat s pos = + try + let result = Pcre.exec ~rex:pat ~flags:[`ANCHORED] ~pos s in + Some result + with Not_found -> None + +end module Url = struct @@ -115,7 +199,7 @@ module Url = struct problem_re1 (fun m s -> Printf.sprintf "%%%02x" - (Char.code s.[Netstring_pcre.match_beginning m])) + (Char.code s.[fst (Pcre.get_substring_ofs m 0)])) (* I add this fixup to handle %uxxxx sent by browsers. Translated to %xx%xx *) @@ -163,8 +247,48 @@ module Url = struct end + let url_decoding_re = + Netstring_pcre.regexp "\\+\\|%..\\|%.\\|%";; + + let of_hex1 c = + match c with + | ('0'..'9') -> Char.code c - Char.code '0' + | ('A'..'F') -> Char.code c - Char.code 'A' + 10 + | ('a'..'f') -> Char.code c - Char.code 'a' + 10 + | _ -> + raise Not_found + let encode = MyUrl.encode - let decode ?plus a = Netencoding.Url.decode ?plus a + let decode ?(plus = true) s = + let pos = 0 and len = None in + let s_l = String.length s in + let s1 = + if pos = 0 && len=None then s else + let len = match len with Some n -> n | None -> s_l in + String.sub s pos len in + let l = String.length s1 in + Netstring_pcre.global_substitute + url_decoding_re + (fun r _ -> + match Netstring_pcre.matched_string r s1 with + | "+" -> if plus then " " else "+" + | _ -> + let i = fst (Pcre.get_substring_ofs r 0) in + (* Assertion: s1.[i] = '%' *) + if i+2 >= l then failwith "decode"; + let c1 = s1.[i+1] in + let c2 = s1.[i+2] in + begin + try + let k1 = of_hex1 c1 in + let k2 = of_hex1 c2 in + String.make 1 (Char.chr((k1 lsl 4) lor k2)) + with + Not_found -> + failwith "decode" + end + ) + s1 let make_encoded_parameters params = String.concat "&" @@ -244,7 +368,7 @@ module Url = struct end in - let path = List.map (Netencoding.Url.decode ~plus:false) (split_path pathstring) in + let path = List.map (decode ~plus:false) (split_path pathstring) in let path = remove_dotdot path (* and remove "//" *) (* here we remove .. from paths, as it is dangerous. But in some very particular cases, we may want them? diff --git a/src/baselib/ocsigen_lib.mli b/src/baselib/ocsigen_lib.mli index 30635adc6..e0626b22b 100644 --- a/src/baselib/ocsigen_lib.mli +++ b/src/baselib/ocsigen_lib.mli @@ -76,3 +76,27 @@ module Url : sig (string * string) list Lazy.t end + +(**/**) + +(* This exists to facilitate transition away from Ocamlnet. Do not use + for new code! *) +module Netstring_pcre : sig + + val regexp : string -> Pcre.regexp + + val matched_group : Pcre.substrings -> int -> string -> string + + val matched_string : Pcre.substrings -> string -> string + + val global_replace : Pcre.regexp -> string -> string -> string + + val search_forward: + Pcre.regexp -> string -> int -> int * Pcre.substrings + + val split : Pcre.regexp -> string -> string list + + val string_match : + Pcre.regexp -> string -> int -> Pcre.substrings option + +end diff --git a/src/baselib/ocsigen_loader.ml b/src/baselib/ocsigen_loader.ml index 188422600..c4a2329b6 100644 --- a/src/baselib/ocsigen_loader.ml +++ b/src/baselib/ocsigen_loader.ml @@ -163,7 +163,7 @@ let add_ocamlpath p = (* Using Findlib to locate files *) let findfiles = - let cmx = Netstring_pcre.regexp_case_fold "\\.cmx($| |a)" in + let cmx = Pcre.regexp ~flags:[`MULTILINE; `CASELESS] "\\.cmx($| |a)" in fun package -> try let preds = [(if Ocsigen_config.is_native then "native" else "byte"); "plugin"; "mt"] in @@ -179,7 +179,10 @@ let findfiles = try let raw = Findlib.package_property preds a "archive" in (* Replacing .cmx/.cmxa by .cmxs *) - let raw = Netstring_pcre.global_replace cmx ".cmxs " raw in + let raw = + Ocsigen_lib.Netstring_pcre.global_replace + cmx ".cmxs " raw + in List.filter ((<>) "") (String.split ~multisep:true ' ' raw) with | Not_found -> [] diff --git a/src/baselib/ocsigen_stream.ml b/src/baselib/ocsigen_stream.ml index da980669d..9449f1c2f 100644 --- a/src/baselib/ocsigen_stream.ml +++ b/src/baselib/ocsigen_stream.ml @@ -183,7 +183,7 @@ let rec skip s k = match s with let len = String.length s in let len64 = Int64.of_int len in if Int64.compare k len64 <= 0 - then + then let k = Int64.to_int k in Lwt.return (Cont (String.sub s k (len - k), f)) else (enlarge_stream (Cont ("", f)) >>= @@ -193,7 +193,7 @@ let substream delim s = let ldelim = String.length delim in if ldelim = 0 then Lwt.fail (Stream_error "Empty delimiter") else - let rdelim = Netstring_pcre.regexp_string delim in + let rdelim = Pcre.(regexp (quote delim)) in let rec aux = function | Finished _ -> Lwt.fail Stream_too_small @@ -202,7 +202,7 @@ let substream delim s = if len < ldelim then enlarge_stream stre >>= aux else try - let p,_ = Netstring_pcre.search_forward rdelim s 0 in + let p,_ = Ocsigen_lib.Netstring_pcre.search_forward rdelim s 0 in cont (String.sub s 0 p) (fun () -> empty @@ -211,7 +211,7 @@ let substream delim s = with Not_found -> let pos = (len + 1 - ldelim) in cont (String.sub s 0 pos) - (fun () -> + (fun () -> next f >>= function | Finished _ -> Lwt.fail Stream_too_small | Cont (s', f') -> diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index 4a4b12816..f0b8d4120 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -334,7 +334,10 @@ let parse_config parse_fun = function in match header with | Some header -> - (match Netstring_pcre.split comma_space_regexp header with + (match + Ocsigen_lib.Netstring_pcre.split + comma_space_regexp header + with | original_ip :: proxies -> let last_proxy = List.last proxies in let proxy_ip = Ipaddr.of_string_exn last_proxy in diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index b1ad13d5d..5672a2204 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -143,7 +143,7 @@ let main config = function (* Register extension *) let comma_space_regexp = - Netstring_pcre.regexp "[[:blank:]\n]*,[[:blank:]\n]*" + Ocsigen_lib.Netstring_pcre.regexp "[[:blank:]\n]*,[[:blank:]\n]*" let parse_config _ _ parse_fun config_elem = let config = ref { @@ -173,12 +173,18 @@ let parse_config _ _ parse_fun config_elem = Configuration.attribute ~name:"exposed_headers" (fun s -> - let s = Netstring_pcre.split comma_space_regexp s in + let s = + Ocsigen_lib.Netstring_pcre.split + comma_space_regexp s + in config := { !config with exposed_headers = s }); Configuration.attribute ~name:"methods" (fun s -> - let s = Netstring_pcre.split comma_space_regexp s in + let s = + Ocsigen_lib.Netstring_pcre.split + comma_space_regexp s + in let s = Some (List.map Cohttp.Code.method_of_string s) in config := { !config with allowed_method = s }); ] diff --git a/src/extensions/extendconfiguration.ml b/src/extensions/extendconfiguration.ml index b36536c15..df6eae6f1 100644 --- a/src/extensions/extendconfiguration.ml +++ b/src/extensions/extendconfiguration.ml @@ -66,7 +66,7 @@ let check_regexp_list = try Hashtbl.find hashtbl r with Not_found -> try - ignore (Netstring_pcre.regexp r); + ignore (Ocsigen_lib.Netstring_pcre.regexp r); Hashtbl.add hashtbl r () with _ -> raise (Bad_regexp r) @@ -117,7 +117,7 @@ let parse_config usermode _ _ _ = function | Simplexmlparser.Element ("regexp", ["regexp", regexp; "value", charset], []) :: q -> (try - let r = Netstring_pcre.regexp regexp in + let r = Ocsigen_lib.Netstring_pcre.regexp regexp in aux (Ocsigen_charset_mime.update_charset_regexp charset_assoc r charset) @@ -155,7 +155,7 @@ let parse_config usermode _ _ _ = function | Simplexmlparser.Element ("regexp", ["regexp", regexp; "value", mime], []) :: q -> (try - let r = Netstring_pcre.regexp regexp in + let r = Ocsigen_lib.Netstring_pcre.regexp regexp in aux (Ocsigen_charset_mime.update_mime_regexp mime_assoc r mime) q with _ -> bad_config "invalid regexp '%s' in ") | _ :: q -> bad_config "invalid subtag in option mime" diff --git a/src/extensions/outputfilter.ml b/src/extensions/outputfilter.ml index 41b59149f..232249cd3 100644 --- a/src/extensions/outputfilter.ml +++ b/src/extensions/outputfilter.ml @@ -22,7 +22,7 @@ type outputfilter = | Rewrite_header of - (Ocsigen_header.Name.t * Netstring_pcre.regexp * string) + (Ocsigen_header.Name.t * Pcre.regexp * string) | Add_header of (Ocsigen_header.Name.t * string * bool option) @@ -36,7 +36,7 @@ let gen filter = function (try let l = List.map - (Netstring_pcre.global_replace regexp dest) + (Ocsigen_lib.Netstring_pcre.global_replace regexp dest) (Ocsigen_response.header_multi res header) and a = Ocsigen_response.remove_header res header in Ocsigen_response.add_header_multi a header l @@ -81,7 +81,9 @@ let parse_config config_elem = (fun s -> header := Some s); Configuration.attribute ~name:"regexp" - (fun s -> regexp := Some (Netstring_pcre.regexp s)); + (fun s -> + regexp := + Some (Ocsigen_lib.Netstring_pcre.regexp s)); Configuration.attribute ~name:"dest" (fun s -> dest := Some s); diff --git a/src/extensions/redirectmod.ml b/src/extensions/redirectmod.ml index efbdcd8bf..4b3982011 100644 --- a/src/extensions/redirectmod.ml +++ b/src/extensions/redirectmod.ml @@ -24,7 +24,7 @@ let section = Lwt_log.Section.make "ocsigen:ext:redirectmod" (* The table of redirections for each virtual server *) type assockind = Regexp of - Netstring_pcre.regexp * + Pcre.regexp * string * Ocsigen_lib.yesnomaybe * (* full url *) bool (* temporary *) @@ -113,7 +113,8 @@ let parse_config config_elem = | None -> Ocsigen_extensions.badconfig "Missing attribute regexp for " | Some regexp -> - gen (Regexp (Netstring_pcre.regexp regexp, !dest, !mode, !temporary)) + gen (Regexp (Ocsigen_lib.Netstring_pcre.regexp regexp, + !dest, !mode, !temporary)) let () = Ocsigen_extensions.register_extension diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 624c73c45..8b2eb10f9 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -34,9 +34,9 @@ type static_site_kind = | Regexp of regexp_site and regexp_site = { - source_regexp: Netstring_pcre.regexp; + source_regexp: Pcre.regexp; dest: Ocsigen_extensions.ud_string; - http_status_filter: Netstring_pcre.regexp option; + http_status_filter: Pcre.regexp option; root_checks: Ocsigen_extensions.ud_string option; } @@ -47,7 +47,7 @@ let http_status_match status_filter status = match status_filter with | None -> true | Some r -> - Netstring_pcre.string_match r + Ocsigen_lib.Netstring_pcre.string_match r (string_of_int Cohttp.Code.(code_of_status (status :> status_code))) 0 <> None @@ -55,9 +55,9 @@ let http_status_match status_filter status = (* Checks that the path specified in a userconf is correct. Currently, we check that the path does not contain ".." *) let correct_user_local_file = - let regexp = Netstring_pcre.regexp "(/\\.\\./)|(/\\.\\.$)" in + let regexp = Ocsigen_lib.Netstring_pcre.regexp "(/\\.\\./)|(/\\.\\.$)" in fun path -> - try ignore(Netstring_pcre.search_forward regexp path 0); false + try ignore(Ocsigen_lib.Netstring_pcre.search_forward regexp path 0); false with Not_found -> true (* Find the local file corresponding to [path] in the static site [dir], @@ -85,7 +85,7 @@ let find_static_page ~request ~usermode ~dir ~(err : Cohttp.Code.status) ~pathst when http_status_match status_filter err -> let status_filter = status_filter <> None and file = - match Netstring_pcre.string_match source pathstring 0 with + match Ocsigen_lib.Netstring_pcre.string_match source pathstring 0 with | None -> raise Not_concerned | Some _ -> Ocsigen_extensions.replace_user_dir source dest pathstring @@ -189,8 +189,8 @@ let rewrite_local_path userconf path = type options = { opt_dir: string option; - opt_regexp: Netstring_pcre.regexp option; - opt_code: Netstring_pcre.regexp option; + opt_regexp: Pcre.regexp option; + opt_code: Pcre.regexp option; opt_dest: Ocsigen_extensions.ud_string option; opt_root_checks: Ocsigen_extensions.ud_string option; opt_cache: int option; @@ -226,7 +226,7 @@ let parse_config userconf _ ~name:"regexp" (fun s -> let s = - try Netstring_pcre.regexp ("^"^s^"$") + try Ocsigen_lib.Netstring_pcre.regexp ("^"^s^"$") with Pcre.Error (Pcre.BadPattern _) -> badconfig "Bad regexp \"%s\" in " s @@ -235,7 +235,7 @@ let parse_config userconf _ Configuration.attribute ~name:"code" (fun s -> - let c = try Netstring_pcre.regexp ("^" ^ s ^"$") + let c = try Ocsigen_lib.Netstring_pcre.regexp ("^" ^ s ^"$") with Pcre.Error (Pcre.BadPattern _) -> badconfig "Bad regexp \"%s\" in " s @@ -293,7 +293,7 @@ let parse_config userconf _ | (None, None, (Some _ as code), Some t, None) -> Regexp { dest = t; http_status_filter = code; root_checks = None; - source_regexp = Netstring_pcre.regexp "^.*$" } + source_regexp = Ocsigen_lib.Netstring_pcre.regexp "^.*$" } | _ -> Ocsigen_extensions.badconfig "Wrong attributes for " diff --git a/src/extensions/userconf.ml b/src/extensions/userconf.ml index f7911ec82..8f06dec37 100644 --- a/src/extensions/userconf.ml +++ b/src/extensions/userconf.ml @@ -103,7 +103,7 @@ let gen hostpattern sitepath (regexp, conf, url, prefix, localpath) = ({Ocsigen_extensions.request_info ; request_config} as req)) as req_state -> let path = (Ocsigen_request.sub_path_string request_info) in - match Netstring_pcre.string_match regexp path 0 with + match Ocsigen_lib.Netstring_pcre.string_match regexp path 0 with | None -> Lwt.return (Ocsigen_extensions.Ext_next previous_err) | Some _ -> try @@ -111,8 +111,10 @@ let gen hostpattern sitepath (regexp, conf, url, prefix, localpath) = let conf0 = Ocsigen_extensions.replace_user_dir regexp conf path in let uri = Uri.of_string - (Netstring_pcre.global_replace regexp url path) - and prefix = Netstring_pcre.global_replace regexp prefix path + (Ocsigen_lib.Netstring_pcre.global_replace regexp url path) + and prefix = + Ocsigen_lib.Netstring_pcre.global_replace + regexp prefix path and userconf_options = { Ocsigen_extensions.localfiles_root = Ocsigen_extensions.replace_user_dir regexp localpath path } @@ -159,7 +161,7 @@ let parse_config hostpattern _ path _ _ config_elem = ~name:"regexp" ~obligatory:true (fun s -> - let s = Netstring_pcre.regexp ("^" ^ s ^ "$") in + let s = Ocsigen_lib.Netstring_pcre.regexp ("^" ^ s ^ "$") in regexp := Some s); Configuration.attribute ~name:"conf" diff --git a/src/http/ocsigen_charset_mime.ml b/src/http/ocsigen_charset_mime.ml index a1cc976c1..b96dc7c41 100644 --- a/src/http/ocsigen_charset_mime.ml +++ b/src/http/ocsigen_charset_mime.ml @@ -31,7 +31,7 @@ let section = Lwt_log.Section.make "ocsigen:mimetype" type 'a assoc_item = | Extension of extension * 'a | File of filename * 'a - | Regexp of Netstring_pcre.regexp * 'a + | Regexp of Pcre.regexp * 'a | Map of 'a MapString.t type 'a assoc = { diff --git a/src/http/ocsigen_charset_mime.mli b/src/http/ocsigen_charset_mime.mli index 454d21dcf..2fa27dbcf 100644 --- a/src/http/ocsigen_charset_mime.mli +++ b/src/http/ocsigen_charset_mime.mli @@ -51,7 +51,7 @@ val set_default_charset : charset_assoc -> charset -> charset_assoc val update_charset_ext : charset_assoc -> extension -> charset -> charset_assoc val update_charset_file : charset_assoc -> filename -> charset -> charset_assoc val update_charset_regexp : - charset_assoc -> Netstring_pcre.regexp -> charset -> charset_assoc + charset_assoc -> Pcre.regexp -> charset -> charset_assoc @@ -82,11 +82,4 @@ val set_default_mime : mime_assoc -> mime_type -> mime_assoc val update_mime_ext : mime_assoc -> extension -> mime_type -> mime_assoc val update_mime_file : mime_assoc -> filename -> mime_type -> mime_assoc val update_mime_regexp : - mime_assoc -> Netstring_pcre.regexp -> mime_type -> mime_assoc - - - - - - - + mime_assoc -> Pcre.regexp -> mime_type -> mime_assoc diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index a4b30ec2d..154678373 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -51,7 +51,7 @@ let badconfig fmt = Printf.ksprintf (fun s -> raise (Error_in_config_file s)) fm (*****************************************************************************) (* virtual hosts: *) -type virtual_hosts = (string * Netstring_pcre.regexp * int option) list +type virtual_hosts = (string * Pcre.regexp * int option) list (* We cannot use generic comparison, as regexpes are abstract values that cannot be compared or hashed. However the string essentially contains @@ -100,8 +100,8 @@ let do_not_serve_to_regexp d = wrap d.do_not_serve_regexps in let paren_quote l = - String.concat "|" (List.map (fun s -> Printf.sprintf "(%s)" - (Netstring_pcre.quote s)) l) + String.concat "|" + (List.map (fun s -> Printf.sprintf "(%s)" (Pcre.quote s)) l) and paren l = String.concat "|" (List.map (fun s -> Printf.sprintf "(%s)" s) l) in @@ -123,7 +123,7 @@ let do_not_serve_to_regexp d = in (try Lwt_log.ign_info_f ~section "Compiling exclusion regexp %s" regexp; - let r = Netstring_pcre.regexp regexp in + let r = Ocsigen_lib.Netstring_pcre.regexp regexp in Hashtbl.add hash_consed_do_not_serve d r; r with _ -> raise (IncorrectRegexpes d) @@ -837,7 +837,7 @@ let host_match ~(virtual_hosts : virtual_hosts) ~host ~port = we take the first one, even if it doesn't match! *) | Some host -> let host_match regexp = - (Netstring_pcre.string_match regexp host 0 <> None) + (Ocsigen_lib.Netstring_pcre.string_match regexp host 0 <> None) in let rec aux = function | [] -> false @@ -972,14 +972,15 @@ exception NoSuchUser type ud_string = Nodir of string | Withdir of string * string * string -let user_dir_regexp = Netstring_pcre.regexp "(.*)\\$u\\(([^\\)]*)\\)(.*)" +let user_dir_regexp = + Ocsigen_lib.Netstring_pcre.regexp "(.*)\\$u\\(([^\\)]*)\\)(.*)" let parse_user_dir s = - match Netstring_pcre.full_split user_dir_regexp s with - | [ Netstring_pcre.Delim _; - Netstring_pcre.Group (1, s1); - Netstring_pcre.Group (2, u); - Netstring_pcre.Group (3, s2)] -> + match Pcre.full_split ~rex:user_dir_regexp ~max:(-1) s with + | [ Pcre.Delim _; + Pcre.Group (1, s1); + Pcre.Group (2, u); + Pcre.Group (3, s2)] -> Withdir (s1, u, s2) | _ -> Nodir s @@ -987,18 +988,27 @@ let parse_user_dir s = let replace_user_dir regexp dest pathstring = match dest with | Nodir dest -> - Netstring_pcre.global_replace regexp dest pathstring + Ocsigen_lib.Netstring_pcre.global_replace regexp dest pathstring | Withdir (s1, u, s2) -> - try - let s1 = Netstring_pcre.global_replace regexp s1 pathstring in - let u = Netstring_pcre.global_replace regexp u pathstring in - let s2 = Netstring_pcre.global_replace regexp s2 pathstring in - let userdir = (Unix.getpwnam u).Unix.pw_dir in - Lwt_log.ign_info_f ~section "User %s" u; - s1^userdir^s2 - with Not_found -> - Lwt_log.ign_info_f ~section "No such user %s" u; - raise NoSuchUser + try + let s1 = + Ocsigen_lib.Netstring_pcre.global_replace + regexp s1 pathstring + in + let u = + Ocsigen_lib.Netstring_pcre.global_replace + regexp u pathstring + in + let s2 = + Ocsigen_lib.Netstring_pcre.global_replace + regexp s2 pathstring + in + let userdir = (Unix.getpwnam u).Unix.pw_dir in + Lwt_log.ign_info_f ~section "User %s" u; + s1^userdir^s2 + with Not_found -> + Lwt_log.ign_info_f ~section "No such user %s" u; + raise NoSuchUser exception Not_concerned @@ -1025,9 +1035,9 @@ let find_redirection regexp full_url dest r = (Ocsigen_request.port r) ("/" ^ path) in - Netstring_pcre.string_match regexp path 0 >|! fun _ -> + Ocsigen_lib.Netstring_pcre.string_match regexp path 0 >|! fun _ -> (* Matching regexp found! *) - Netstring_pcre.global_replace regexp dest path + Ocsigen_lib.Netstring_pcre.global_replace regexp dest path else let path = let sub_path = Ocsigen_request.sub_path_string r in @@ -1035,6 +1045,6 @@ let find_redirection regexp full_url dest r = | None -> sub_path | Some g -> sub_path ^ "?" ^ g in - Netstring_pcre.string_match regexp path 0 >|! fun _ -> + Ocsigen_lib.Netstring_pcre.string_match regexp path 0 >|! fun _ -> (* Matching regexp found! *) - Netstring_pcre.global_replace regexp dest path + Ocsigen_lib.Netstring_pcre.global_replace regexp dest path diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index d5f112b67..880482708 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -55,7 +55,7 @@ val badconfig : ('a, unit, string, 'b) format4 -> 'a (which is a glob-like pattern that can contains [*]), a regexp parsing this pattern, and optionnaly a port. *) -type virtual_hosts = (string * Netstring_pcre.regexp * int option) list +type virtual_hosts = (string * Pcre.regexp * int option) list val hash_virtual_hosts : virtual_hosts -> int val equal_virtual_hosts : virtual_hosts -> virtual_hosts -> bool @@ -78,7 +78,7 @@ exception IncorrectRegexpes of do_not_serve (** Compile a do_not_serve structure into a regexp. Raises [IncorrectRegexpes] if the compilation fails. The result is memoized for subsequent calls with the same argument *) -val do_not_serve_to_regexp: do_not_serve -> Netstring_pcre.regexp +val do_not_serve_to_regexp: do_not_serve -> Pcre.regexp val join_do_not_serve : do_not_serve -> do_not_serve -> do_not_serve @@ -420,7 +420,7 @@ type ud_string val parse_user_dir : string -> ud_string -val replace_user_dir : Netstring_pcre.regexp -> ud_string -> string -> string +val replace_user_dir : Pcre.regexp -> ud_string -> string -> string (** raises [Not_found] is the directory does not exist *) @@ -429,7 +429,7 @@ val replace_user_dir : Netstring_pcre.regexp -> ud_string -> string -> string exception Not_concerned val find_redirection : - Netstring_pcre.regexp -> + Pcre.regexp -> bool -> string -> Ocsigen_request.t -> diff --git a/src/server/ocsigen_local_files.ml b/src/server/ocsigen_local_files.ml index 698b76772..1249e239f 100644 --- a/src/server/ocsigen_local_files.ml +++ b/src/server/ocsigen_local_files.ml @@ -96,12 +96,15 @@ let check_symlinks ~no_check_for ~filename policy = aux follow_symlinks_if_owner_match let check_dotdot = - let regexp = Netstring_pcre.regexp "(/\\.\\./)|(/\\.\\.$)" in + let regexp = Ocsigen_lib.Netstring_pcre.regexp "(/\\.\\./)|(/\\.\\.$)" in fun ~filename -> (* We always reject .. in filenames. In URLs, .. have already been removed by the server, but the filename may come from somewhere else than URLs ... *) - try ignore (Netstring_pcre.search_forward regexp filename 0); false + try + ignore + (Ocsigen_lib.Netstring_pcre.search_forward regexp filename 0); + false with Not_found -> true let can_send filename request = @@ -112,8 +115,10 @@ let can_send filename request = in Lwt_log.ign_info_f ~section "checking if file %s can be sent" filename; let matches arg = - Netstring_pcre.string_match (Ocsigen_extensions.do_not_serve_to_regexp arg) - filename 0 <> None + Ocsigen_lib.Netstring_pcre.string_match + (Ocsigen_extensions.do_not_serve_to_regexp arg) + filename 0 <> + None in if matches request.Ocsigen_extensions.do_not_serve_403 then ( Lwt_log.ign_info ~section "this file is forbidden"; diff --git a/src/server/ocsigen_multipart.ml b/src/server/ocsigen_multipart.ml index ecf219a9e..8fdaf1682 100644 --- a/src/server/ocsigen_multipart.ml +++ b/src/server/ocsigen_multipart.ml @@ -5,7 +5,7 @@ (*VVV Check wether we should support int64 for large files? *) open Lwt.Infix -module S = Netstring_pcre +module S = Ocsigen_lib.Netstring_pcre let section = Lwt_log.Section.make "ocsigen:server:multipart" @@ -13,6 +13,8 @@ exception Multipart_error of string exception Ocsigen_upload_forbidden +let match_end result = snd (Pcre.get_substring_ofs result 0) + let cr_or_lf_re = S.regexp "[\013\n]" let header_stripped_re = @@ -42,7 +44,7 @@ let scan_header let rec parse_header i l = match S.string_match header_re parstr i with | Some r -> - let i' = S.match_end r in + let i' = match_end r in if i' > end_pos then raise (Multipart_error "Mimestring.scan_header"); let name = if downcase then @@ -62,7 +64,7 @@ let scan_header (* The header must end with an empty line *) (match S.string_match empty_line_re parstr i with | Some r' -> - List.rev l, S.match_end r' + List.rev l, match_end r' | None -> raise (Multipart_error "Mimestring.scan_header")) in @@ -77,11 +79,11 @@ let read_header ?downcase ?unfold ?strip s = line right at the beginning *) match S.string_match empty_line_re b 0 with | Some r -> - Lwt.return (s, (S.match_end r)) + Lwt.return (s, match_end r) | None -> (* Search for an empty line *) Lwt.return - (s, (S.match_end (snd (S.search_forward end_of_header_re b 0)))) + (s, match_end (snd (S.search_forward end_of_header_re b 0))) ) (function | Not_found -> @@ -117,7 +119,7 @@ let search_end_of_line s k = Lwt.catch (fun () -> search_window s lf_re k >>= fun (s, x) -> - Lwt.return (s, (S.match_end x))) + Lwt.return (s, match_end x)) (function | Not_found -> Lwt.fail @@ -130,9 +132,9 @@ let search_first_boundary ~boundary s = (* Search boundary per regexp; return the position of the character immediately following the boundary (on the same line), or raise Not_found. *) - let re = S.regexp ("\n--" ^ S.quote boundary) in + let re = S.regexp ("\n--" ^ Pcre.quote boundary) in search_window s re 0 >>= fun (s, x) -> - Lwt.return (s, (S.match_end x)) + Lwt.return (s, match_end x) let check_beginning_is_boundary ~boundary s = let del = "--" ^ boundary in @@ -269,10 +271,10 @@ let counter = let field field content_disp = let (_, res) = - Netstring_pcre.search_forward - (Netstring_pcre.regexp (field^"=.([^\"]*).;?")) content_disp 0 + S.search_forward + (S.regexp (field^"=.([^\"]*).;?")) content_disp 0 in - Netstring_pcre.matched_group res 1 content_disp + S.matched_group res 1 content_disp let parse_content_type s = match Ocsigen_lib.String.split ';' s with @@ -314,7 +316,12 @@ let post_params_form_urlencoded body_gen _ _ = (Ocsigen_config.get_maxrequestbodysizeinmemory ()) body >>= fun r -> let r = Ocsigen_lib.Url.fixup_url_string r in - Lwt.return ((Netencoding.Url.dest_url_encoded_parameters r), [])) + let l = + Uri.query_of_encoded r + |> List.map (fun (s, l) -> List.map (fun v -> s, v) l) + |> List.concat + in + Lwt.return (l, [])) (function | Ocsigen_stream.String_too_large -> Lwt.fail Ocsigen_lib.Input_is_too_large diff --git a/src/server/ocsigen_parseconfig.ml b/src/server/ocsigen_parseconfig.ml index 4313d9f8d..a20ce2a7d 100644 --- a/src/server/ocsigen_parseconfig.ml +++ b/src/server/ocsigen_parseconfig.ml @@ -25,6 +25,8 @@ open Ocsigen_socket open Simplexmlparser open Ocsigen_config +module Netstring_pcre = Ocsigen_lib.Netstring_pcre + let section = Lwt_log.Section.make "ocsigen:config" let blah_of_string f tag s = @@ -252,19 +254,19 @@ let parse_host_field = raise (Config_file_error "bad port number") in let split_host = function - | Netstring_str.Delim _ -> ".*" - | Netstring_str.Text t -> Netstring_pcre.quote t + | Str.Delim _ -> ".*" + | Str.Text t -> Pcre.quote t in (host, Netstring_pcre.regexp (String.concat "" ((List.map split_host - (Netstring_str.full_split - (Netstring_str.regexp "[*]+") host))@["$"])), + (Str.full_split + (Str.regexp "[*]+") host))@["$"])), port) in List.map parse_one_host - (Netstring_str.split (Netstring_str.regexp "[ \t]+") s) + (Str.split (Str.regexp "[ \t]+") s) in Hashtbl.add h hostfilter r; (r : Ocsigen_extensions.virtual_hosts) From aecb16341cf5930726251405dd5b0236c9351178 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 25 Apr 2017 23:46:42 +0200 Subject: [PATCH 058/111] Remove ocamlnet dependency For now, we have copied some Ocamlnet code to Ocsigen_lib{_base} . To be cleaned-up progressively, e.g., by using Uri . --- Makefile.options | 4 +-- configure | 8 ----- doc/Makefile | 3 +- opam | 1 - src/baselib/Makefile | 3 +- src/baselib/ocsigen_lib.ml | 28 +++++++++++++++- src/baselib/ocsigen_lib_base.ml | 55 +++++++++++++++++++++++++++++++ src/baselib/ocsigen_lib_base.mli | 3 ++ src/extensions/Makefile | 3 +- src/extensions/revproxy.ml | 4 +-- src/extensions/rewritemod.ml | 8 ++--- src/http/Makefile | 3 +- src/server/ocsigen_local_files.ml | 2 +- 13 files changed, 98 insertions(+), 27 deletions(-) diff --git a/Makefile.options b/Makefile.options index 0524aa087..c949e55fd 100644 --- a/Makefile.options +++ b/Makefile.options @@ -34,10 +34,10 @@ SERVER_PACKAGE := lwt.ssl \ bytes \ ${LWT_PREEMPTIVE_PACKAGE} \ ipaddr \ - netstring \ - netstring-pcre \ findlib \ cryptokit \ + pcre \ + str \ tyxml \ tyxml.parser \ dynlink \ diff --git a/configure b/configure index 45300869d..84a036c7a 100755 --- a/configure +++ b/configure @@ -414,13 +414,6 @@ check_library lwt.react "Missing support for 'react' in lwt." check_library lwt.ssl "Missing support for 'ssl' in lwt." check_library lwt.preemptive "Missing support for 'preemptive' in lwt." -check_library netstring \ - "See ocamlnet: http://projects.camlcity.org/projects/ocamlnet.html" -check_library netstring-pcre \ - "See ocamlnet: http://projects.camlcity.org/projects/ocamlnet.html" -check_library netsys \ - "See ocamlnet: http://projects.camlcity.org/projects/ocamlnet.html" - check_library pcre "See: http://ocaml.info/home/ocaml_sources.html" check_library cryptokit "See: http://pauillac.inria.fr/~xleroy/software.html#cryptokit" @@ -668,4 +661,3 @@ echo echo " make install" echo " make install.doc" echo - diff --git a/doc/Makefile b/doc/Makefile index 79d087d91..33e05ec0c 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -4,7 +4,7 @@ include ../src/Makefile.filelist OCAMLDOC := ${OCAMLFIND} ocamldoc ODOC_WIKI := odoc_wiki.cma -LIBS := -package lwt,tyxml,ssl,netstring,netstring-pcre,ipaddr \ +LIBS := -package lwt,tyxml,ssl,ipaddr \ ${addprefix -I ../src/, baselib http server extensions } doc: api-html/index.html @@ -29,4 +29,3 @@ uninstall: clean: -rm -f api-html/* api-wiki/* -rm -f *~ \#* .\#* - diff --git a/opam b/opam index 253f23110..4b46f737f 100644 --- a/opam +++ b/opam @@ -49,7 +49,6 @@ depends: [ "react" "ssl" "lwt" {>= "2.5.0" & < "3.0.0"} - "ocamlnet" {>= "4.0.2"} "pcre" "cryptokit" "tyxml" {>= "4.0.0"} diff --git a/src/baselib/Makefile b/src/baselib/Makefile index 30335b67a..6da016980 100644 --- a/src/baselib/Makefile +++ b/src/baselib/Makefile @@ -3,10 +3,9 @@ include ../../Makefile.config PACKAGE := \ bytes \ lwt.unix \ - netstring \ - netstring-pcre \ cryptokit \ findlib \ + pcre \ tyxml \ ${LWT_PREEMPTIVE_PACKAGE} \ ipaddr diff --git a/src/baselib/ocsigen_lib.ml b/src/baselib/ocsigen_lib.ml index 645936c64..4c31c793d 100644 --- a/src/baselib/ocsigen_lib.ml +++ b/src/baselib/ocsigen_lib.ml @@ -303,6 +303,32 @@ module Url = struct (* ' ' are not encoded to '+' in paths *) else String.concat "/" l (* BYXXX : check illicit characters *) + let url_split_re = Str.regexp "[&=]";; + + (* taken from Ocamlnet 4.1.2 *) + let dest_url_encoded_parameters parstr = + let rec parse_after_amp tl = + match tl with + | Str.Text name :: Str.Delim "=" :: Str.Text value :: tl' -> + (decode name, decode value) :: parse_next tl' + | Str.Text name :: Str.Delim "=" :: Str.Delim "&" :: tl' -> + (decode name, "") :: parse_after_amp tl' + | Str.Text name :: Str.Delim "=" :: [] -> + [decode name, ""] + | _ -> + failwith "dest_url_encoded_parameters" + and parse_next tl = + match tl with + | [] -> [] + | Str.Delim "&" :: tl' -> + parse_after_amp tl' + | _ -> + failwith "dest_url_encoded_parameters" + in + let toklist = Str.full_split url_split_re parstr in + match toklist with + | [] -> [] + | _ -> parse_after_amp toklist let parse = @@ -363,7 +389,7 @@ module Url = struct lazy begin let params_string = match query with None -> "" | Some s -> s in try - Netencoding.Url.dest_url_encoded_parameters params_string + dest_url_encoded_parameters params_string with Failure _ -> raise Ocsigen_Bad_Request end in diff --git a/src/baselib/ocsigen_lib_base.ml b/src/baselib/ocsigen_lib_base.ml index 17028c69c..a02796328 100644 --- a/src/baselib/ocsigen_lib_base.ml +++ b/src/baselib/ocsigen_lib_base.ml @@ -462,6 +462,61 @@ module Url_base = struct | [ "";"" ] -> [ "" ] | other -> other + (* Taken from Ocamlnet 4.1.2 *) + let norm_path l = + + let rec remove_slash_slash l first = + match l with + | [ "" ] -> + [ "" ] + | [ ""; "" ] when first -> + [ "" ] + | "" :: l' when not first -> + remove_slash_slash l' false + | x :: l' -> + x :: remove_slash_slash l' false + | [] -> + [] + in + + let rec remove_dot l first = + match l with + | ([ "." ] | ["."; ""]) -> + if first then [] else [ "" ] + | "." :: x :: l' -> + remove_dot (x :: l') false + | x :: l' -> + x :: remove_dot l' false + | [] -> + [] + in + + let rec remove_dot_dot_once l first = + match l with + x :: ".." :: [] when x <> "" && x <> ".." && not first -> + [ "" ] + | x :: ".." :: l' when x <> "" && x <> ".." -> + l' + | x :: l' -> + x :: remove_dot_dot_once l' false + | [] -> + raise Not_found + in + + let rec remove_dot_dot l = + try + let l' = remove_dot_dot_once l true in + remove_dot_dot l' + with + Not_found -> l + in + + let l' = remove_dot_dot (remove_dot (remove_slash_slash l true) true) in + match l' with + [".."] -> [".."; ""] + | ["";""] -> [ "" ] + | _ -> l' + end (************************************************************************) diff --git a/src/baselib/ocsigen_lib_base.mli b/src/baselib/ocsigen_lib_base.mli index f03ab11fd..bca337a76 100644 --- a/src/baselib/ocsigen_lib_base.mli +++ b/src/baselib/ocsigen_lib_base.mli @@ -189,8 +189,11 @@ module Url_base : sig val join_path : path -> string + (**/**) val split_path : string -> path + val norm_path : path -> path + end module Printexc : sig diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 98d9cf1d1..7a77b5dd2 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -6,8 +6,7 @@ PACKAGE := \ ipaddr \ lwt.ssl \ lwt.react \ - netstring \ - netstring-pcre \ + pcre \ tyxml.parser \ cohttp.lwt diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index 049077a40..310d2058f 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -31,7 +31,7 @@ exception Bad_answer_from_http_server (** The table of redirections for each virtual server *) type redir = { - regexp : Netstring_pcre.regexp ; + regexp : Pcre.regexp ; full_url : Ocsigen_lib.yesnomaybe ; dest : string ; pipeline : bool ; @@ -205,7 +205,7 @@ let parse_config config_elem = "Missing attribute 'dest' for " | (Some regexp, full_url, Some dest, pipeline, keephost) -> gen { - regexp = Netstring_pcre.regexp ("^" ^ regexp ^ "$"); + regexp = Ocsigen_lib.Netstring_pcre.regexp ("^" ^ regexp ^ "$"); full_url; dest; pipeline; diff --git a/src/extensions/rewritemod.ml b/src/extensions/rewritemod.ml index 3268ff1d4..fba712fee 100644 --- a/src/extensions/rewritemod.ml +++ b/src/extensions/rewritemod.ml @@ -34,14 +34,14 @@ let section = Lwt_log.Section.make "ocsigen:ext:rewritemod" exception Not_concerned (* The table of rewrites for each virtual server *) -type assockind = Regexp of Netstring_pcre.regexp * string * bool +type assockind = Regexp of Pcre.regexp * string * bool let find_rewrite (Regexp (regexp, dest, fullrewrite)) suburl = - (match Netstring_pcre.string_match regexp suburl 0 with + (match Ocsigen_lib.Netstring_pcre.string_match regexp suburl 0 with | None -> raise Not_concerned | Some _ -> (* Matching regexp found! *) - Netstring_pcre.global_replace regexp dest suburl), + Ocsigen_lib.Netstring_pcre.global_replace regexp dest suburl), fullrewrite (* The function that will generate the pages from the request *) @@ -131,7 +131,7 @@ let parse_config element = | Some dest -> gen (Regexp - ((Netstring_pcre.regexp ("^" ^ !regexp ^ "$")), + ((Ocsigen_lib.Netstring_pcre.regexp ("^" ^ !regexp ^ "$")), dest, !fullrewrite)) !continue diff --git a/src/http/Makefile b/src/http/Makefile index df473540c..f357a5b32 100644 --- a/src/http/Makefile +++ b/src/http/Makefile @@ -1,9 +1,8 @@ include ../../Makefile.config PACKAGE := \ bytes \ - netstring \ - netstring-pcre \ lwt.ssl \ + pcre \ tyxml \ cohttp diff --git a/src/server/ocsigen_local_files.ml b/src/server/ocsigen_local_files.ml index 1249e239f..1686dff32 100644 --- a/src/server/ocsigen_local_files.ml +++ b/src/server/ocsigen_local_files.ml @@ -110,7 +110,7 @@ let check_dotdot = let can_send filename request = let filename = Ocsigen_lib.Url.split_path filename - |> Neturl.norm_path + |> Ocsigen_lib.Url.norm_path |> Ocsigen_lib.Url.join_path in Lwt_log.ign_info_f ~section "checking if file %s can be sent" filename; From bec12ec4f61160b3de63caf90c39bb264bcf9e49 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 27 Apr 2017 14:26:06 +0200 Subject: [PATCH 059/111] Fix many warnings --- src/extensions/accesscontrol.ml | 2 +- src/extensions/cors.ml | 3 ++- .../ocsipersist-pgsql/ocsipersist.ml | 3 ++- src/extensions/redirectmod.ml | 15 ++++++++------- src/server/ocsigen_cohttp.ml | 6 +++--- src/server/ocsigen_response.ml | 19 ++++++++++--------- 6 files changed, 26 insertions(+), 22 deletions(-) diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index f0b8d4120..e8485df88 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -418,7 +418,7 @@ let parse_config parse_fun = function in Lwt.return (Ocsigen_extensions.Ext_continue_with - ( { request with request_info }, + ( { request with Ocsigen_extensions.request_info }, Ocsigen_cookies.Cookies.empty, code )) in diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index 5672a2204..56abe7533 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -136,7 +136,8 @@ let main config = function | _ -> Lwt.return Ocsigen_extensions.Ext_do_nothing) - | Ocsigen_extensions.Req_found ({request_info}, response) -> + | Ocsigen_extensions.Req_found + ({Ocsigen_extensions.request_info}, response) -> Lwt_log.ign_info ~section "answered request"; add_headers config request_info response diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index df247534c..c60db6af2 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -79,7 +79,8 @@ let cursor db query params f = let (key,value) = key_value_of_row row in f key (unmarshal value) with exn -> - Lwt_log.error ~exn ~section "exception while evaluating cursor argument"; + Lwt_log.ign_error ~exn ~section + "exception while evaluating cursor argument"; error := Some exn; Lwt.return () in match !error with diff --git a/src/extensions/redirectmod.ml b/src/extensions/redirectmod.ml index 4b3982011..370f243ae 100644 --- a/src/extensions/redirectmod.ml +++ b/src/extensions/redirectmod.ml @@ -38,11 +38,11 @@ let attempt_redir dir err ri () = regexp full dest ri in match full with - | Yes -> + | Ocsigen_lib.Yes -> find true - | No -> + | Ocsigen_lib.No -> find false - | Maybe -> + | Ocsigen_lib.Maybe -> try find false with Ocsigen_extensions.Not_concerned -> @@ -63,7 +63,8 @@ let attempt_redir dir err ri () = let gen dir = function | Ocsigen_extensions.Req_found _ -> Lwt.return Ocsigen_extensions.Ext_do_nothing - | Ocsigen_extensions.Req_not_found (err, {request_info}) -> + | Ocsigen_extensions.Req_not_found + (err, {Ocsigen_extensions.request_info}) -> Lwt.catch (attempt_redir dir err request_info) @@ function | Ocsigen_extensions.Not_concerned -> Lwt.return (Ocsigen_extensions.Ext_next err) @@ -87,17 +88,17 @@ let parse_config config_elem = ~name:"regexp" (fun s -> pattern := Some ("^" ^ s ^ "$"); - mode := Maybe); + mode := Ocsigen_lib.Maybe); Configuration.attribute ~name:"fullurl" (fun s -> pattern := Some ("^" ^ s ^ "$"); - mode := Yes); + mode := Ocsigen_lib.Yes); Configuration.attribute ~name:"suburl" (fun s -> pattern := Some ("^" ^ s ^ "$"); - mode := No); + mode := Ocsigen_lib.No); Configuration.attribute ~name:"dest" ~obligatory:true diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index e9af7c468..b94d15372 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -24,8 +24,8 @@ let print_request fmt request = Format.fprintf fmt "%s [%s/%s]:\n" (Uri.to_string (Cohttp.Request.uri request)) - (Cohttp.Code.string_of_version request.version) - (Cohttp.Code.string_of_method request.meth) ; + Cohttp.(Code.string_of_version (Request.version request)) + Cohttp.(Code.string_of_method (Request.meth request)); Cohttp.Header.iter (fun key values -> @@ -33,7 +33,7 @@ let print_request fmt request = (fun fmt value -> Format.fprintf fmt "\t%s = %s\n" key value) fmt values)) - request.headers + (Cohttp.Request.headers request) let waiters = Hashtbl.create 256 diff --git a/src/server/ocsigen_response.ml b/src/server/ocsigen_response.ml index a138916fd..c94ccf46a 100644 --- a/src/server/ocsigen_response.ml +++ b/src/server/ocsigen_response.ml @@ -47,7 +47,8 @@ let status { a_response = { Cohttp.Response.status } } = let set_status ({ a_response } as a) status = { a with a_response = { - a_response with status = (status :> Cohttp.Code.status_code) + a_response with + Cohttp.Response.status = (status :> Cohttp.Code.status_code) } } @@ -70,18 +71,18 @@ let header_multi {a_response} id = Cohttp.Header.get_multi h (Ocsigen_header.Name.to_string id) let add_header - ({a_response = ({headers} as a_response)} as a) + ({a_response = ({Cohttp.Response.headers} as a_response)} as a) id v = { a with a_response = { a_response with - headers = + Cohttp.Response.headers = Cohttp.Header.add headers (Ocsigen_header.Name.to_string id) v } } let add_header_multi - ({a_response = ({headers} as a_response)} as a) + ({a_response = ({Cohttp.Response.headers} as a_response)} as a) id l = let id = Ocsigen_header.Name.to_string id in let headers = @@ -90,15 +91,15 @@ let add_header_multi headers l in - { a with a_response = { a_response with headers } } + { a with a_response = { a_response with Cohttp.Response.headers } } let replace_header - ({a_response = ({headers} as a_response)} as a) + ({a_response = ({Cohttp.Response.headers} as a_response)} as a) id v = { a with a_response = { a_response with - headers = + Cohttp.Response.headers = Cohttp.Header.replace headers (Ocsigen_header.Name.to_string id) v } } @@ -113,10 +114,10 @@ let replace_headers ({a_response} as a) l = (Cohttp.Response.headers a_response) l in - { a with a_response = { a_response with headers } } + { a with a_response = { a_response with Cohttp.Response.headers } } let remove_header ({a_response} as a) id = let headers = Cohttp.Response.headers a_response and id = Ocsigen_header.Name.to_string id in let headers = Cohttp.Header.remove headers id in - { a with a_response = { a_response with headers } } + { a with a_response = { a_response with Cohttp.Response.headers } } From 6feeb2f3b5150f953edd89189faf53df493e7b79 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 27 Apr 2017 15:23:19 +0200 Subject: [PATCH 060/111] Remove unmaintained Ocsigen_comet & Lwt_react dependency --- configure | 1 - src/extensions/Makefile | 1 - src/extensions/ocsigen_comet.ml | 569 ------------------------------- src/extensions/ocsigen_comet.mli | 195 ----------- src/files/META.in | 9 - 5 files changed, 775 deletions(-) delete mode 100644 src/extensions/ocsigen_comet.ml delete mode 100644 src/extensions/ocsigen_comet.mli diff --git a/configure b/configure index 84a036c7a..da5667036 100755 --- a/configure +++ b/configure @@ -410,7 +410,6 @@ check_library ssl "See: http://sourceforge.net/projects/savonet/files/ocaml-ssl" check_library lwt "See: http://ocsigen.org/lwt" check_library lwt.unix "Missing support for 'unix' in lwt." -check_library lwt.react "Missing support for 'react' in lwt." check_library lwt.ssl "Missing support for 'ssl' in lwt." check_library lwt.preemptive "Missing support for 'preemptive' in lwt." diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 7a77b5dd2..645551e72 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -5,7 +5,6 @@ PACKAGE := \ lwt.unix \ ipaddr \ lwt.ssl \ - lwt.react \ pcre \ tyxml.parser \ cohttp.lwt diff --git a/src/extensions/ocsigen_comet.ml b/src/extensions/ocsigen_comet.ml deleted file mode 100644 index b12f78238..000000000 --- a/src/extensions/ocsigen_comet.ml +++ /dev/null @@ -1,569 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * Copyright (C) 2010 - * Raphaël Proust - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - -(* Comet extension for Ocsigen server - * ``Comet'' is a set of hacks techniques providing basic - * server-to-client communication. Using HTTP, it is not possible for the server - * to send a message to the client, it is only possible to answer a client's - * request. - * - * This implementation is to evolve and will change a lot with HTML5's - * WebSockets support. -*) - -open Ocsigen_lib - -let section = Lwt_log.Section.make "ocsigen:ext:comet" -(*** PREAMBLE ***) - -(* small addition to the standard library *) -let map_rev_accu_split func lst accu1 accu2 = - let rec aux accu1 accu2 = function - | [] -> (accu1, accu2) - | x :: xs -> match func x with - | Left y -> aux (y :: accu1) accu2 xs - | Right y -> aux accu1 (y :: accu2) xs - in - aux accu1 accu2 lst - -(*** EXTENSION OPTIONS ***) - - -(* timeout for comet connections : if no value has been written in the ellapsed - * time, connection will be closed. Should be equal to client timeout. *) -let timeout_ref = ref 20. -let get_timeout () = !timeout_ref - -(* the size initialization for the channel hashtable *) -let tbl_initial_size = 16 - -let max_virtual_channels_ref = ref None -let get_max_virtual_channels () = !max_virtual_channels_ref - -(*** CORE ***) - -module Channels : -sig - - exception Too_many_virtual_channels - (* raised when calling [create] while [max_virtual_channels] is [Some x] and - * creating a new channel would make the virtual channel count greater than - * [x]. *) - exception Non_unique_channel_name - (* raised when creating a channel with a name already associated. *) - - type t - (* the type of channels : - * channels can be written on or read from using the following functions - *) - type chan_id = string - - val create : ?name:string -> unit -> t - val read : t -> (string * Ocsigen_stream.outcome Lwt.u option) Lwt.t - val write : t -> (string * Ocsigen_stream.outcome Lwt.u option) -> unit - - val listeners : t -> int - (* The up-to-date count of registered clients *) - val send_listeners : t -> int -> unit - (* [send_listeners c i] adds [i] to [listeners c]. [i] may be negative. *) - - val find_channel : chan_id -> t - (* may raise Not_found if the channel was collected or never created. - * Basically ids are meant for clients to tell a server to start listening - * to it. *) - val get_id : t -> chan_id - (* [find_channel (get_id ch)] returns [ch] if the channel wasn't destroyed - * that is. *) - -end = struct - - exception Too_many_virtual_channels - exception Non_unique_channel_name - - type chan_id = string - type t = - { - ch_id : chan_id ; - mutable ch_read : (string * Ocsigen_stream.outcome Lwt.u option) Lwt.t ; - mutable ch_write : (string * Ocsigen_stream.outcome Lwt.u option) Lwt.u; - mutable ch_listeners : int ; - } - module Dummy = struct - (*module added to avoid Ctbl.t cyclicity*) - type tt = t - end - - let get_id ch = ch.ch_id - - (* In order to being able to retrieve channels by there IDs, let's have a map - * *) - module CTbl = - Weak.Make - (struct - type t = Dummy.tt - let equal { ch_id = i } { ch_id = j } = i = j - let hash { ch_id = c } = Hashtbl.hash c - end) - - (* storage and ID manipulation *) - let ctbl = CTbl.create tbl_initial_size - - let new_id = Ocsigen_lib.make_cryptographic_safe_string - - (* because Hashtables allow search for elements with a corresponding hash, we - * have to create a dummy channel in order to retreive the original channel. - * Is there a KISSer way to do that ? *) - let (dummy1, dummy2) = Lwt.task () - let dummy_chan i = - { - ch_id = i ; - ch_read = dummy1 ; - ch_write = dummy2 ; - ch_listeners = 0 ; - } - - (* May raise Not_found *) - let find_channel i = - CTbl.find ctbl (dummy_chan i) - - (* virtual channel count *) - let (chan_count, incr_chan_count, decr_chan_count) = - let cc = ref 0 in - ((fun () -> !cc), (fun () -> incr cc), (fun _ -> decr cc)) - let maxed_out_virtual_channels () = match get_max_virtual_channels () with - | None -> false - | Some y -> chan_count () >= y - - - (* creation : newly created channel is stored in the map as a side effect *) - let do_create name = - if maxed_out_virtual_channels () - then begin - Lwt_log.ign_warning ~section - "Too many virtual channels, associated exception raised"; - raise Too_many_virtual_channels - end else - let (read , write) = Lwt.task () in - let ch = - { - ch_id = name ; - ch_read = read ; - ch_write = write ; - ch_listeners = 0 ; - } - in - incr_chan_count (); - CTbl.add ctbl ch; - Gc.finalise decr_chan_count ch; - ch - - let write ch x = - let (read, write) = Lwt.task () in - let old_write = ch.ch_write in - ch.ch_write <- write ; - ch.ch_read <- read ; - Lwt.wakeup old_write x - - let create ?name () = match name with - | None -> do_create (new_id ()) - | Some n -> - try ignore (find_channel n) ; raise Non_unique_channel_name - with Not_found -> do_create n - - (* reading a channel : just getting a hang on the reader thread *) - let read ch = ch.ch_read - - (* listeners *) - let listeners ch = ch.ch_listeners - let send_listeners ch x = ch.ch_listeners <- ch.ch_listeners + x - -end - - -module Messages : - (* All about messages from between clients and server *) - (* - * The client sends a POST request with a "registration" parameter containing - * a list of channel ids. Separator for the list are semi-colon : ';'. - * - * The server sends result to the client in the form of a list of : - * channel_id ^ ":" ^ value ^ { ";" ^ channel_id ^ " " ^ value }* - * where channel_id is the id of a channel that the client registered upon and - * value is the string that was written upon the associated channel. - * *) -sig - - val decode_upcomming : - Ocsigen_extensions.request -> (Channels.t list * Channels.chan_id list) Lwt.t - (* decode incomming message : the result is the list of channels to listen - to (on the left) or to signal non existence (on the right). *) - - val encode_downgoing : - Channels.chan_id list - -> (Channels.t * string * Ocsigen_stream.outcome Lwt.u option) list option - -> string Ocsigen_stream.t - (* Encode outgoing messages : the first argument is the list of channels - * that have already been collected. - * The results is the stream to send to the client*) - - val encode_ended : Channels.chan_id list -> string - -end = struct - - (* constants *) - let channel_separator = "\n" - let field_separator = ":" - let ended_message = "ENDED_CHANNEL" - let channel_separator_regexp = Netstring_pcre.regexp channel_separator - let url_encode x = Url.encode ~plus:false x - - let decode_string s accu1 accu2 = - map_rev_accu_split - (fun s -> - try Left (Channels.find_channel s) - with | Not_found -> Right s - ) - (Netstring_pcre.split channel_separator_regexp s) - accu1 - accu2 - - let decode_param_list params = - let rec aux ((tmp_reg, tmp_end) as tmp) = function - | [] -> (tmp_reg, tmp_end) - | ("registration", s) :: tl -> aux (decode_string s tmp_reg tmp_end) tl - | _ :: tl -> aux tmp tl - in - aux ([], []) params - - let decode_upcomming r = - (* RRR This next line makes it fail with Ocsigen_unsupported_media, hence - * the http_frame low level version *) - (* r.Ocsigen_extensions.request_info - * .Ocsigen_extensions - * .ri_post_params r.Ocsigen_extensions.request_config *) - Lwt.catch - (fun () -> - match (Ocsigen_request_info.http_frame - r.Ocsigen_extensions.request_info) - .Ocsigen_http_frame.frame_content with - | None -> - Lwt.return [] - | Some body -> - Lwt.return (Ocsigen_stream.get body) >>= - Ocsigen_stream.string_of_stream - (Ocsigen_config.get_maxrequestbodysizeinmemory ()) >|= - Url.fixup_url_string >|= - Netencoding.Url.dest_url_encoded_parameters - ) - (function - | Ocsigen_stream.String_too_large -> Lwt.fail Input_is_too_large - | e -> Lwt.fail e - ) - >|= decode_param_list - - let encode1 (c, s, _) = - Channels.get_id c ^ field_separator ^ url_encode s - - let encode l = String.concat channel_separator (List.map encode1 l) - - let encode_ended l = - String.concat - channel_separator - (List.map (fun c -> c ^ field_separator ^ ended_message) l) - - let stream_result_notification s outcome = - Lwt_list.iter_p - (function - (*when write has been made with outcome notifier*) - | (c, _, Some x) -> (Lwt.wakeup x outcome ; Lwt.return ()) - (*when it hasn't*) - | (_, _, None) -> Lwt.return () - ) - s - - let encode_downgoing e = function - | None -> Ocsigen_stream.of_string (encode_ended e) - | Some s -> - let stream = - Ocsigen_stream.of_string - (match e with - | [] -> encode s - | e -> encode_ended e - ^ field_separator - ^ encode s - ) - in - Ocsigen_stream.add_finalizer stream (stream_result_notification s) ; - stream - -end - -module Security : -sig - - val set_timeout : ?reset:bool -> float -> unit - (* Set the [timeout] constant for new connections. Existing connections are - * not affected unless [?reset] is [Some true] *) - - val deactivate : unit -> unit - (* Stop serving comet connections and kill all current connections. *) - - val activate : unit -> unit - (* (Re)start serving connections *) - - val activated : unit -> bool - (* activation state *) - - val kill : unit React.E.t - (* The event reflecting willingness to kill connections *) - - val command_function : string -> string list -> unit Lwt.t - (* To be registered with Ocsigen_extension.register_command_function *) - -end = struct - - let (kill, kill_all_connections) = React.E.create () - - let activated, activate, deactivate = - let activated = ref true in - ((fun () -> !activated), - (fun () -> - if !activated then - () - else begin - Lwt_log.ign_warning ~section "Comet is being activated"; - activated := true - end - ), - (fun () -> - if !activated then begin - Lwt_log.ign_warning ~section "Comet is being deactivated"; - activated := false; - kill_all_connections () - end else - () - ) - ) - - let warn_kill = - React.E.map - (fun () -> Lwt_log.ign_warning "Comet connections kill notice is being sent.") - kill - let `R _ = React.E.retain kill (fun () -> ignore warn_kill) - - let set_timeout ?(reset=false) f = - timeout_ref := f ; - if reset - then kill_all_connections () - else () - - let command_function_ _ = function - | ["deactivate"] -> deactivate () - | ["activate"] -> activate () - | "set_timeout" :: f :: tl -> - (try - set_timeout - ~reset:(match tl with - | ["KILL"] -> true - | [] -> false - | _ -> raise Ocsigen_extensions.Unknown_command - ) - (float_of_string f) - with Failure _ -> raise Ocsigen_extensions.Unknown_command) - | _ -> raise Ocsigen_extensions.Unknown_command - - let command_function x y = command_function_ x y; Lwt.return () - -end - -module Main : - (* a client can wait for all the channels on which it - * is registered and return with the first result. *) -sig - - val main : Ocsigen_extensions.request -> unit -> Ocsigen_http_frame.result Lwt.t - (* treat an incoming request from a client. The unit part is for partial - * application in Ext_found parameter. *) - -end = struct - - let frame_503 () = - Lwt.return - (Ocsigen_http_frame.Result.update (Ocsigen_http_frame.Result.default ()) - ~stream:(Ocsigen_stream.of_string "", None) - ~code:503 (*Service Unavailable*) - ~content_length:None - ~content_type:(Some "text/plain") ()) - - exception Kill - - (* Once channel list is obtain, use this function to return a thread that - * terminates when one of the channel is written upon. *) - let treat_decoded = function - | [], [] -> (* error : empty request *) - Lwt_log.ign_info ~section "Incorrect or empty Comet request"; - Lwt.return - (Ocsigen_http_frame.Result.update (Ocsigen_http_frame.Result.default ()) - ~stream: - (Ocsigen_stream.of_string "Empty or incorrect registration", None) - ~code:400(* BAD REQUEST *) - ~content_type:(Some "text/plain") - ~content_length:None ()) - | [], (_::_ as ended) -> (* All channels are closed *) - let end_notice = Messages.encode_ended ended in - Lwt_log.ign_info ~section "Comet request served"; - Lwt.return - (Ocsigen_http_frame.Result.update (Ocsigen_http_frame.Result.default ()) - ~stream:(Ocsigen_stream.of_string end_notice, None) - ~content_length:None - ~content_type:(Some "text/plain") ()) - | (_::_ as active), ended -> (* generic case *) - let choosed = - let readings = - (List.map - (fun c -> Channels.read c >|= fun (v,x) -> (c, v, x)) - active - ) - in - (*wait for one thread to terminate and get all terminated threads *) - Lwt.choose readings >>= fun _ -> Lwt.nchoose readings - in - - List.iter (fun c -> Channels.send_listeners c 1) active ; - Lwt.catch - (fun () -> - Lwt.choose - [ (choosed >|= fun x -> Some x); - (Lwt_unix.sleep (get_timeout ()) >|= fun () -> None); - (Lwt_react.E.next Security.kill >>= fun () -> Lwt.fail Kill); - ] >|= fun x -> - List.iter (fun c -> Channels.send_listeners c (-1)) active ; - let s = Messages.encode_downgoing ended x in - Lwt_log.ign_info ~section "Comet request served"; - - (Ocsigen_http_frame.Result.update (Ocsigen_http_frame.Result.default ()) - ~stream:(s, None) - ~content_length:None - ~content_type:(Some "text/plain") ()) - ) - (function - | Kill -> (* Comet stopped for security *) - List.iter (fun c -> Channels.send_listeners c (-1)) active ; - Lwt_log.ign_info ~section "Killed Comet request handling"; - frame_503 () - | e -> Lwt.fail e - ) - - - (* This is just a mashup of the other functions in the module. *) - let main r () = - if Security.activated () - then - (Lwt_log.ign_info ~section "Serving Comet request"; - Messages.decode_upcomming r >>= treat_decoded) - else - (Lwt_log.ign_info ~section "Refusing Comet request (Comet deactivated)"; - frame_503 ()) - -end - -let rec has_comet_content_type = function - | [] -> false - | ("application", "x-ocsigen-comet") :: _ -> true - | _ :: tl -> has_comet_content_type tl - -(*Only for debugging purpose*) -let rec debug_content_type = function - | [] -> "" - | (s1,s2) :: tl -> s1 ^ "/" ^ s2 ^ "\n" ^ debug_content_type tl - - - -(*** MAIN FUNCTION ***) - -let main = function - - | Ocsigen_extensions.Req_not_found (_, rq) -> (* Else check for content type *) - begin match (Ocsigen_request_info.content_type - rq.Ocsigen_extensions.request_info) with - | Some (hd, tl) when has_comet_content_type (hd :: tl) -> - Lwt_log.ign_info_f ~section - "Comet message: %a" (fun () -> debug_content_type) (hd :: tl); - Lwt.return (Ocsigen_extensions.Ext_found (Main.main rq)) - - | Some (hd, tl) -> - Lwt_log.ign_info_f ~section - "Non comet message: %a" (fun () -> debug_content_type) (hd :: tl); - Lwt.return Ocsigen_extensions.Ext_do_nothing - | None -> - Lwt_log.ign_info ~section - "Non comet message: no content type"; - Lwt.return Ocsigen_extensions.Ext_do_nothing - end - - | Ocsigen_extensions.Req_found _ -> (* If recognized by some other extension... *) - Lwt.return Ocsigen_extensions.Ext_do_nothing (* ...do nothing *) - - - - -(*** EPILOGUE ***) - -let parse_config _ _ _ config_elem = - max_virtual_channels_ref := None; - Ocsigen_extensions.( - Configuration.process_element - ~in_tag:"host" - ~other_elements:(fun t _ _ -> raise (Bad_config_tag_for_extension t)) - ~elements:[ - Configuration.element - ~name:"comet" - ~attributes:[ - Configuration.attribute - ~name:"max_virtual_channels" - (function - | "" -> max_virtual_channels_ref := None - | s -> - try max_virtual_channels_ref := Some (int_of_string s) - with _ -> - badconfig - "Wrong value for attribute max_virtual_channels\ - of : %s. It should be \"\" or an integer" - s - ) - ] - ()] - config_elem - ); - main - - -let site_creator (_ : Ocsigen_extensions.virtual_hosts) _ = parse_config -let user_site_creator (_ : Ocsigen_extensions.userconf_info) = site_creator - -(* registering extension *) -let () = Ocsigen_extensions.register_extension - ~name:"comet" - ~fun_site:site_creator - ~user_fun_site:user_site_creator - () -let () = Ocsigen_extensions.register_command_function - ~prefix:"comet" - Security.command_function diff --git a/src/extensions/ocsigen_comet.mli b/src/extensions/ocsigen_comet.mli deleted file mode 100644 index ea6a5fb0c..000000000 --- a/src/extensions/ocsigen_comet.mli +++ /dev/null @@ -1,195 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * Copyright (C) 2010 - * Raphaël Proust - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - -(** Ocsigen_comet server extension : provides low-level server to client communication - scheme. *) - -module Channels : - (** A module with all the base primitive needed for server push. *) -sig - - exception Too_many_virtual_channels - (** An exception that may be raised when trying to create a new channel while - the channel count exceed [max_virtual_channels]. Note that by default - [max_virtual_channels] is set to [None] so that the exception is never - raised. *) - - exception Non_unique_channel_name - (** An exception raised when creating a channel with a name already associated - to another channel. It is strictly forbidden to name several channels with - the same string. *) - - type t - (** The abstract type of server-to-client communication channels. *) - - type chan_id = string - (** The type of channel identifier. Channels are uniquely identified by there - chan_id value. *) - - val create : ?name:string -> unit -> t - (** [create ()] returns a channel with a freshly baked identifier while - [create ~name ()] returns a channel with the identifier [name] after - checking for uniqueness. If [name] is the identifier of an existing - channel, the exception [Non_unique_channel_name] is raised. *) - - val write : t -> (string * Ocsigen_stream.outcome Lwt.u option) -> unit - (** [write c (s, u)] sends the string [s] on the channel [c]. The argument [u] - allow one to observe the result of the operation. If [u] is [None], there - is no way to tell if the sending worked as expected. However if [u] is - [Some u'] then [u'] will be woken up with the outcome (either [`Falure] or - [`Success]) of the stream writing process. *) - - val listeners : t -> int - (** [listeners c] returns the number of clients currently registered on [c] - A client is "currently registered" on a channel if an actual - connection is open for the server to push a message onto. Note that this - information is server-based only, and that because it is so, some clients - may still be registered as active while they have in fact closed the - connection. In such a case, the outcome mechanism in [write] will report - the failure. *) - - val get_id : t -> chan_id - (** [get_id c] returns the unique identifier associated to [c]. The client can - register to [c] using the returned identifier. *) - -end - -module Security : - (** This module is to be used carefully, it provides functions to interrupt and - restart Comet related connections. It is however useful to prevent Comet - based DOS attacks. These functions can also be called from the Ocsigen - command pipe. *) -sig - - val set_timeout : ?reset:bool -> float -> unit - (** [set_timeout ?reset f] sets the timeout value for future Comet connections - to [f]. If [reset] is [true] then current connections are closed and the - new timeout value will apply to the reopened connections. Default value - for [reset] is false. *) - - val deactivate : unit -> unit - (** [deactivate ()] ceases all Comet related activity. Each opened connection - is closed. Further attempts to connect to the server with a Comet specific - content type will result in a HTTP status code 503 (Unavailable). - If called when Comet is not activated it does nothing (not even logging - the deactivation attempt. *) - - val activate : unit -> unit - (** [activate ()] starts serving Comet requests. It is the client's own - responsibility to reopen a connection. If Comet was already activated it - keeps going and nothing happens. *) - - val activated : unit -> bool - (** [activated ()] reflects the activation state of the Comet - module. If [false] it indicates that Comet connections are answered with a - HTTP status code 503. If [true] it indicates that Comet connections are - handled in a standard fashion by the server. *) - -end - -(** Usage: - - On the server side : - 1) create needed channels - 2) transmit their identifiers to clients - 3) write when appropriate (using the outcome mechanism if necessary - - On the client : - 1) make a XmlHttpRequest (XHR) with a list of channel identifiers. - 2) wait for the reply - 3) GOTO 1 - - Encoding for client-to-server requests: - * The content type header should be set to [application/x-ocsigen-comet] - (without quotes) - * A POST parameter is required. Its name should be [registration] and its - content should be a list of channel identifiers separated by [\n] - (newline) characters. - * Name and content of the said POST parameter should be encoded according to - the [escape] JavaScript primitive - - - Encoding for server-to-client answer: - * The server answer is either empty (when no channel was written upon before - timeout) or a list of pairs of channel identifiers and message content. - The pairs are separated by [:] (colon) while the list elements are - separated by [\n] (newline) characters. - * In the list, channels that no longer exists on the server side are marked - as pairs of channel identifier and the special string [ENDED_CHANNEL]. - When receiving such a message, the client should lose hope of ever - connecting to that particular channel ever again. - -*) -(** Conf-file options: - - One can use the configuration file to tweak Ocsigen_comet settings. The supported - options are: - - * max_virtual_channels: - * default: [None] - * syntax: "" is for [None], "i" is for [Some (int_of_string i)] - * [max_virtual_channels] is an upper limit to the number of active - channels. It does not limit the number of connections but the number of - values of type [Ocsigen_comet.Channels.t] that can be used simultaneously. If - one calls [Ocsigen_comet.Channels.create] while the number of channels is - already maxed out, the exception - [Ocsigen_comet.Channels.Too_many_virtual_channels] is raised. - -*) -(** Commands: - - Comet provides commands (to be piped into Ocsigen's command pipe). The - complete list of commands is described here. Don't forget to use the Comet - prefix: each command is to be prefixed by "comet:" (without quotes). - - * deactivate: - * deactivate is a command that stops all Comet activity. It is equivalent - to a call to [Ocsigen_comet.Security.deactivate]. - - * activate: - * activate is the dual command to deactivate. It resumes Comet activity - (or do nothing is Comet is already activated) with exactly the same - effect as a call to [Ocsigen_comet.Security.activate] would have. - - * set_timeout: - * parameter: f (float) - * optional parameter: s ("KILL") - * set_timeout allows one to dynamically change the value of Comet - connections timeout to [f]. Previously activated connections are closed - if the second optional parameter is used. If not, connections are - carried out with their old timeout unchanged. - -*) - - -(** Note to Eliom users: - Although it is possible to use Ocsigen_comet as an extension to the Ocsigen Server, - it is recommended to use the higher level Eliom modules, namely Eliom_comet - (for server side) and Eliom_client_comet (for client side). The former - provides typed channels (with automatic marshaling) and channel wrapping, - the later automates decoding and demarshaling and manages channel - registration and deregistration. - - The low level Ocisgen server extension can however be used with classic - Javascript clients (whereas the high level Eliom module requires Ocaml - compatible unmarshalling which may be difficult to find in a non - js_of_ocaml/O'browser based client). It may also be used to add your own - high level wrapper with a custom communication protocol. -*) diff --git a/src/files/META.in b/src/files/META.in index 357047e0d..81cf1a8a3 100644 --- a/src/files/META.in +++ b/src/files/META.in @@ -186,13 +186,4 @@ package "ext" ( archive(native) = "rewritemod.cmx" ) - package "comet" ( - exists_if = "ocsigen_comet.cmo,ocsigen_comet.cmx" - requires = "ocsigenserver,lwt.react" - version = "[distributed with Ocsigen server]" - description = "Comet server-to-client communication" - archive(byte) = "ocsigen_comet.cmo" - archive(native) = "ocsigen_comet.cmx" - ) - ) From 9fb006a1fe3d4158f64d14dc6b4ecdb5c1e9c074 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 27 Apr 2017 15:27:59 +0200 Subject: [PATCH 061/111] Add ocsipersist-pgsql/ocsipersist.mli to .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 7dfada4dc..650df45fe 100644 --- a/.gitignore +++ b/.gitignore @@ -22,6 +22,7 @@ src/extensions/ocsipersist-dbm/ocsidbm src/extensions/ocsipersist-dbm/ocsidbm.opt src/extensions/ocsipersist-dbm/ocsipersist.mli src/extensions/ocsipersist-sqlite/ocsipersist.mli +src/extensions/ocsipersist-pgsql/ocsipersist.mli src/files/META src/files/META.ocsigenserver src/extensions/files/META From 2c32bd4b8331ab2b9d479c85d626ef72f711dc27 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 27 Apr 2017 17:03:11 +0200 Subject: [PATCH 062/111] Lwt_chan -> Lwt_io --- src/baselib/ocsigen_stream.ml | 4 ++-- src/extensions/ocsipersist-dbm/ocsidbm.ml | 11 +++++------ src/extensions/ocsipersist-dbm/ocsipersist.ml | 14 +++++++------- src/extensions/ocsipersist-pgsql/ocsipersist.ml | 12 +++++++++++- src/server/ocsigen_server.ml | 11 ++++++----- 5 files changed, 31 insertions(+), 21 deletions(-) diff --git a/src/baselib/ocsigen_stream.ml b/src/baselib/ocsigen_stream.ml index 9449f1c2f..9ab364cfb 100644 --- a/src/baselib/ocsigen_stream.ml +++ b/src/baselib/ocsigen_stream.ml @@ -229,10 +229,10 @@ let of_file filename = let fd = Lwt_unix.of_unix_file_descr (Unix.openfile filename [Unix.O_RDONLY;Unix.O_NONBLOCK] 0o666) in - let ch = Lwt_chan.in_channel_of_descr fd in + let ch = Lwt_io.(of_fd ~mode:input) fd in let buf = Bytes.create 1024 in let rec aux () = - Lwt_chan.input ch buf 0 1024 >>= fun n -> + Lwt_io.read_into ch buf 0 1024 >>= fun n -> if n = 0 then empty None else (* Streams should be immutable, thus we always make a copy of the buffer *) diff --git a/src/extensions/ocsipersist-dbm/ocsidbm.ml b/src/extensions/ocsipersist-dbm/ocsidbm.ml index 1b82e9785..e6e4d23a3 100644 --- a/src/extensions/ocsipersist-dbm/ocsidbm.ml +++ b/src/extensions/ocsipersist-dbm/ocsidbm.ml @@ -198,8 +198,8 @@ let _ = Unix.setsid () (** Communication functions: *) let send outch v = - Lwt_chan.output_value outch v >>= - (fun () -> Lwt_chan.flush outch) + Lwt_io.write_value outch v >>= + (fun () -> Lwt_io.flush outch) let execute outch = let handle_errors f = try f () with e -> send outch (Error e) in @@ -241,7 +241,7 @@ let execute outch = let nb_clients = ref 0 let rec listen_client inch outch = - Lwt_chan.input_value inch >>= + Lwt_io.read_value inch >>= (fun v -> execute outch v) >>= (fun () -> listen_client inch outch) @@ -260,8 +260,8 @@ let rec loop socket = ignore ( b := true; nb_clients := !nb_clients + 1; - let inch = Lwt_chan.in_channel_of_descr indescr in - let outch = Lwt_chan.out_channel_of_descr indescr in + let inch = Lwt_io.(of_fd ~mode:input) indescr in + let outch = Lwt_io.(of_fd ~mode:output) indescr in catch (fun () -> listen_client inch outch >>= finish) finish); @@ -341,4 +341,3 @@ let _ = Lwt_main.run in ignore (f ()) *) - diff --git a/src/extensions/ocsipersist-dbm/ocsipersist.ml b/src/extensions/ocsipersist-dbm/ocsipersist.ml index b6e52ffae..8977995eb 100644 --- a/src/extensions/ocsipersist-dbm/ocsipersist.ml +++ b/src/extensions/ocsipersist-dbm/ocsipersist.ml @@ -151,12 +151,12 @@ let init_fun config = Lwt_log.ign_warning ~section "Initializing ..."); let indescr = get_indescr 2 in if delay_loading then ( - inch := (indescr >>= fun r -> return (Lwt_chan.in_channel_of_descr r)); - outch := (indescr >>= fun r -> return (Lwt_chan.out_channel_of_descr r)); + inch := (indescr >>= fun r -> return (Lwt_io.(of_fd ~mode:input) r)); + outch := (indescr >>= fun r -> return (Lwt_io.(of_fd ~mode:output) r)); ) else ( let r = Lwt_main.run indescr in - inch := return (Lwt_chan.in_channel_of_descr r); - outch := return (Lwt_chan.out_channel_of_descr r); + inch := return (Lwt_io.(of_fd ~mode:input) r); + outch := return (Lwt_io.(of_fd ~mode:output) r); Lwt_log.ign_warning ~section "...Initialization complete"; ) @@ -171,9 +171,9 @@ let send = !inch >>= fun inch -> !outch >>= fun outch -> previous := - (Lwt_chan.output_value outch v >>= fun () -> - Lwt_chan.flush outch >>= fun () -> - Lwt_chan.input_value inch); + (Lwt_io.write_value outch v >>= fun () -> + Lwt_io.flush outch >>= fun () -> + Lwt_io.read_value inch); !previous) let db_get (store, name) = diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index c60db6af2..c08e84be5 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -4,7 +4,17 @@ let section = Lwt_log.Section.make "ocsipersist:pgsql" module Lwt_thread = struct include Lwt - include Lwt_chan + let close_in = Lwt_io.close + let really_input = Lwt_io.read_into_exactly + let input_binary_int = Lwt_io.BE.read_int + let input_char = Lwt_io.read_char + let output_string = Lwt_io.write + let output_binary_int = Lwt_io.BE.write_int + let output_char = Lwt_io.write_char + let flush = Lwt_io.flush + let open_connection a = Lwt_io.open_connection a + type in_channel = Lwt_io.input_channel + type out_channel = Lwt_io.output_channel end module PGOCaml = PGOCaml_generic.Make(Lwt_thread) open Lwt diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index 33a62e8e8..f7a546594 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -328,13 +328,14 @@ let start_server () = try Ocsigen_extensions.end_initialisation (); - let pipe = Lwt_chan.in_channel_of_descr - (Lwt_unix.of_unix_file_descr - (Unix.openfile commandpipe - [Unix.O_RDWR; Unix.O_NONBLOCK; Unix.O_APPEND] 0o660)) in + let pipe = + Unix.(openfile commandpipe [O_RDWR; O_NONBLOCK; O_APPEND]) 0o660 + |> Lwt_unix.of_unix_file_descr + |> Lwt_io.(of_fd ~mode:input) + in let rec f () = - Lwt_chan.input_line pipe >>= fun s -> + Lwt_io.read_line pipe >>= fun s -> Ocsigen_messages.warning ("Command received: "^s); (Lwt.catch (fun () -> From be72e73d7898f6adddeedcc1a30893f7d9645a3e Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 2 May 2017 13:59:23 +0200 Subject: [PATCH 063/111] configure: check existence of cohttp --- configure | 2 ++ 1 file changed, 2 insertions(+) diff --git a/configure b/configure index da5667036..ec836668c 100755 --- a/configure +++ b/configure @@ -405,6 +405,8 @@ check_ocamlversion check_binary ocamlfind "See: http://projects.camlcity.org/projects/findlib.html" +check_library cohttp "See: https://github.com/mirage/ocaml-cohttp" +check_library cohttp.lwt "Missing support for 'lwt' in cohttp." check_library react "See: http://erratique.ch/software/react" check_library ssl "See: http://sourceforge.net/projects/savonet/files/ocaml-ssl" From bf635940bec184931fab66138a4db8d023a07211 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 2 May 2017 15:46:46 +0200 Subject: [PATCH 064/111] Parse config files with xml-light (WIP) The TyXML dependency goes away. --- .merlin | 1 - Makefile.options | 3 +- configure | 4 +- opam | 3 +- src/baselib/Makefile | 1 - src/extensions/Makefile | 2 +- src/extensions/accesscontrol.ml | 2 +- src/extensions/authbasic.ml | 4 +- src/extensions/authbasic.mli | 4 +- src/extensions/deflatemod.ml | 4 +- src/extensions/extendconfiguration.ml | 62 +++++++++---------- src/extensions/ocsipersist-dbm/Makefile | 5 +- src/extensions/ocsipersist-dbm/ocsipersist.ml | 9 ++- src/extensions/ocsipersist-pgsql/Makefile | 2 +- .../ocsipersist-pgsql/ocsipersist.ml | 4 +- src/extensions/ocsipersist-sqlite/Makefile | 4 +- .../ocsipersist-sqlite/ocsipersist.ml | 3 +- src/extensions/revproxy.ml | 2 +- src/extensions/userconf.ml | 10 ++- src/files/META.in | 2 +- src/http/Makefile | 1 - src/server/ocsigen_extensions.ml | 24 +++---- src/server/ocsigen_extensions.mli | 18 +++--- src/server/ocsigen_parseconfig.ml | 14 ++--- src/server/ocsigen_parseconfig.mli | 12 ++-- src/server/ocsigen_server.ml | 10 ++- 26 files changed, 99 insertions(+), 111 deletions(-) diff --git a/.merlin b/.merlin index 73aa7401d..1a05d2fe6 100644 --- a/.merlin +++ b/.merlin @@ -7,7 +7,6 @@ PKG cryptokit PKG netstring PKG netstring-pcre PKG ipaddr -PKG tyxml tyxml.parser PKG camlzip PKG dynlink PKG cohttp conduit.lwt-unix diff --git a/Makefile.options b/Makefile.options index c949e55fd..239609380 100644 --- a/Makefile.options +++ b/Makefile.options @@ -38,8 +38,7 @@ SERVER_PACKAGE := lwt.ssl \ cryptokit \ pcre \ str \ - tyxml \ - tyxml.parser \ + xml-light \ dynlink \ cohttp.lwt \ ppx_deriving.std diff --git a/configure b/configure index ec836668c..3234971ee 100755 --- a/configure +++ b/configure @@ -418,11 +418,11 @@ check_library lwt.preemptive "Missing support for 'preemptive' in lwt." check_library pcre "See: http://ocaml.info/home/ocaml_sources.html" check_library cryptokit "See: http://pauillac.inria.fr/~xleroy/software.html#cryptokit" -check_library tyxml "See: http://ocsigen.org/tyxml/" +check_library xml-light "See: https://github.com/ncannasse/xml-light" # Check PostgreSQL case "$with_pgsql" in - 1) if test_library pgocaml; then with_pgsql=1; else with_pgsql=0; fi;; + 1) if test_library pgocaml && test_library pgocaml.syntax; then with_pgsql=1; else with_pgsql=0; fi;; 2) check_library pgocaml "https://github.com/darioteixeira/pgocaml";; esac diff --git a/opam b/opam index 4b46f737f..8f466ea2c 100644 --- a/opam +++ b/opam @@ -51,10 +51,9 @@ depends: [ "lwt" {>= "2.5.0" & < "3.0.0"} "pcre" "cryptokit" - "tyxml" {>= "4.0.0"} + "xml-light" ("dbm" | "sqlite3" | "pgocaml") "ipaddr" {>= "2.1"} - "camlp4" "cohttp" {>= "0.17.0"} # REMOVE AFTER DEBUGGING diff --git a/src/baselib/Makefile b/src/baselib/Makefile index 6da016980..5690cab0e 100644 --- a/src/baselib/Makefile +++ b/src/baselib/Makefile @@ -6,7 +6,6 @@ PACKAGE := \ cryptokit \ findlib \ pcre \ - tyxml \ ${LWT_PREEMPTIVE_PACKAGE} \ ipaddr diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 645551e72..e7667d9c1 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -6,7 +6,7 @@ PACKAGE := \ ipaddr \ lwt.ssl \ pcre \ - tyxml.parser \ + xml-light \ cohttp.lwt LIBS := -I ../baselib -I ../http -I ../server \ diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index e8485df88..774d9fc36 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -22,7 +22,7 @@ open Ocsigen_lib -open Simplexmlparser +open Xml let section = Lwt_log.Section.make "ocsigen:ext:access-control" diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index dd35e2677..7e6d04389 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -49,7 +49,7 @@ let register_basic_authentication_method, get_basic_authentication_method = (* Basic authentication with a predefined login/password (example) *) let _ = - let open Simplexmlparser in + let open Xml in register_basic_authentication_method @@ function | Element ("plain", ["login", login; "password", password], _) -> (fun l p -> Lwt.return (login = l && password = p)) @@ -122,7 +122,7 @@ let parse_config element = ] ~other_elements:(fun name attrs content -> rest_ref := - Simplexmlparser.Element (name, attrs, content) :: !rest_ref) + Xml.Element (name, attrs, content) :: !rest_ref) ()] element ); diff --git a/src/extensions/authbasic.mli b/src/extensions/authbasic.mli index 60b14ba7a..a00c9e32a 100644 --- a/src/extensions/authbasic.mli +++ b/src/extensions/authbasic.mli @@ -34,7 +34,7 @@ val register_basic_authentication_method : - (Simplexmlparser.xml -> string -> string -> bool Lwt.t) -> unit + (Xml.xml -> string -> string -> bool Lwt.t) -> unit (** This function registers an authentication plugin: it adds a new parser to the list of available authentication schemes. @@ -55,7 +55,7 @@ val register_basic_authentication_method : val get_basic_authentication_method : - Simplexmlparser.xml -> string -> string -> bool Lwt.t + Xml.xml -> string -> string -> bool Lwt.t (** This function combines all the parsers registered with [register_basic_authentication_method]. It might be useful for other extensions. Not for the casual user. *) diff --git a/src/extensions/deflatemod.ml b/src/extensions/deflatemod.ml index 98a4ab976..e15e5134f 100644 --- a/src/extensions/deflatemod.ml +++ b/src/extensions/deflatemod.ml @@ -318,13 +318,13 @@ let filter choice_list = function let rec parse_global_config = function | [] -> () - | (Simplexmlparser.Element ("compress", [("level", l)], []))::ll -> + | (Xml.Element ("compress", [("level", l)], []))::ll -> let l = try int_of_string l with Failure _ -> raise (Ocsigen_extensions.Error_in_config_file "Compress level should be an integer between 0 and 9") in compress_level := if (l <= 9 && l >= 0) then l else 6 ; parse_global_config ll - | (Simplexmlparser.Element ("buffer", [("size", s)], []))::ll -> + | (Xml.Element ("buffer", [("size", s)], []))::ll -> let s = (try int_of_string s with Failure _ -> raise (Ocsigen_extensions.Error_in_config_file diff --git a/src/extensions/extendconfiguration.ml b/src/extensions/extendconfiguration.ml index df6eae6f1..ab22b647c 100644 --- a/src/extensions/extendconfiguration.ml +++ b/src/extensions/extendconfiguration.ml @@ -47,11 +47,11 @@ let gather_do_not_serve_files tag = do_not_serve_files = files; do_not_serve_extensions = extensions } - | Simplexmlparser.Element ("regexp", ["regexp", f], []) :: q -> + | Xml.Element ("regexp", ["regexp", f], []) :: q -> aux (f :: regexps, files, extensions) q - | Simplexmlparser.Element ("file", ["file", f], []) :: q -> + | Xml.Element ("file", ["file", f], []) :: q -> aux (regexps, f :: files, extensions) q - | Simplexmlparser.Element ("extension", ["ext", f], []) :: q -> + | Xml.Element ("extension", ["ext", f], []) :: q -> aux (regexps, files, f :: extensions) q | _ :: q -> bad_config ("invalid options in tag " ^ tag) @@ -71,15 +71,15 @@ let check_regexp_list = with _ -> raise (Bad_regexp r) let parse_config usermode _ _ _ = function - | Simplexmlparser.Element ("listdirs", ["value", "true"], []) -> + | Xml.Element ("listdirs", ["value", "true"], []) -> gen @@ fun config -> { config with Ocsigen_extensions.list_directory_content = true } - | Simplexmlparser.Element ("listdirs", ["value", "false"], []) -> + | Xml.Element ("listdirs", ["value", "false"], []) -> gen @@ fun config -> { config with Ocsigen_extensions.list_directory_content = false } - | Simplexmlparser.Element ("listdirs" as s, _, _) -> + | Xml.Element ("listdirs" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s - | Simplexmlparser.Element ("followsymlinks", ["value", s], []) -> + | Xml.Element ("followsymlinks", ["value", s], []) -> let v = match s with | "never" -> Ocsigen_extensions.DoNotFollowSymlinks @@ -98,23 +98,23 @@ let parse_config usermode _ _ _ = function in gen @@ fun config -> { config with Ocsigen_extensions.follow_symlinks = v } - | Simplexmlparser.Element ("followsymlinks" as s, _, _) -> + | Xml.Element ("followsymlinks" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s - | Simplexmlparser.Element ("charset", attrs, exts) -> + | Xml.Element ("charset", attrs, exts) -> let rec aux charset_assoc = function | [] -> charset_assoc - | Simplexmlparser.Element + | Xml.Element ("extension", ["ext", extension; "value", charset], []) :: q -> aux (Ocsigen_charset_mime.update_charset_ext charset_assoc extension charset) q - | Simplexmlparser.Element + | Xml.Element ("file", ["file", file; "value", charset], []) :: q -> aux (Ocsigen_charset_mime.update_charset_file charset_assoc file charset) q - | Simplexmlparser.Element + | Xml.Element ("regexp", ["regexp", regexp; "value", charset], []) :: q -> (try let r = Ocsigen_lib.Netstring_pcre.regexp regexp in @@ -141,18 +141,18 @@ let parse_config usermode _ _ _ = function { config with Ocsigen_extensions.charset_assoc = aux config.Ocsigen_extensions.charset_assoc exts }) - | Simplexmlparser.Element ("contenttype", attrs, exts) -> + | Xml.Element ("contenttype", attrs, exts) -> let rec aux mime_assoc = function | [] -> mime_assoc - | Simplexmlparser.Element + | Xml.Element ("extension", ["ext", extension; "value", mime], []) :: q -> aux (Ocsigen_charset_mime.update_mime_ext mime_assoc extension mime) q - | Simplexmlparser.Element + | Xml.Element ("file", ["file", file; "value", mime], []) :: q -> aux (Ocsigen_charset_mime.update_mime_file mime_assoc file mime) q - | Simplexmlparser.Element + | Xml.Element ("regexp", ["regexp", regexp; "value", mime], []) :: q -> (try let r = Ocsigen_lib.Netstring_pcre.regexp regexp in @@ -174,11 +174,11 @@ let parse_config usermode _ _ _ = function { config with Ocsigen_extensions.mime_assoc = aux config.Ocsigen_extensions.mime_assoc exts }) - | Simplexmlparser.Element ("defaultindex", [], l) -> + | Xml.Element ("defaultindex", [], l) -> let rec aux indexes = function | [] -> List.rev indexes - | Simplexmlparser.Element - ("index", [], [Simplexmlparser.PCData f]) :: q -> + | Xml.Element + ("index", [], [Xml.PCData f]) :: q -> aux (f :: indexes) q | _ :: q -> bad_config "subtags must be of the form \ ... \ @@ -187,9 +187,9 @@ let parse_config usermode _ _ _ = function gen (fun config -> { config with Ocsigen_extensions.default_directory_index = aux [] l }) - | Simplexmlparser.Element ("defaultindex" as s, _, _) -> + | Xml.Element ("defaultindex" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s - | Simplexmlparser.Element ("hidefile", [], l) -> + | Xml.Element ("hidefile", [], l) -> let do_not_serve = gather_do_not_serve_files "hidefile" l in (try check_regexp_list @@ -202,9 +202,9 @@ let parse_config usermode _ _ _ = function config.Ocsigen_extensions.do_not_serve_404 }) with Bad_regexp r -> Ocsigen_extensions.badconfig "Invalid regexp %s in %s" r "hidefile") - | Simplexmlparser.Element ("hidefile" as s, _, _) -> + | Xml.Element ("hidefile" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s - | Simplexmlparser.Element ("forbidfile", [], l) -> + | Xml.Element ("forbidfile", [], l) -> let do_not_serve = gather_do_not_serve_files "forbidfile" l in (try check_regexp_list @@ -217,18 +217,18 @@ let parse_config usermode _ _ _ = function }) with Bad_regexp r -> Ocsigen_extensions.badconfig "Invalid regexp %s in %s" r "forbidfile") - | Simplexmlparser.Element ("forbidfile" as s, _, _) -> + | Xml.Element ("forbidfile" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s - | Simplexmlparser.Element - ("uploaddir", [], [Simplexmlparser.PCData s]) -> + | Xml.Element + ("uploaddir", [], [Xml.PCData s]) -> gen @@ if s = "" then fun config -> { config with Ocsigen_extensions.uploaddir = None } else fun config -> { config with Ocsigen_extensions.uploaddir = Some s } - | Simplexmlparser.Element ("uploaddir" as s, _, _) -> + | Xml.Element ("uploaddir" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s - | Simplexmlparser.Element - ("maxuploadfilesize" as tag, [], [Simplexmlparser.PCData s]) -> + | Xml.Element + ("maxuploadfilesize" as tag, [], [Xml.PCData s]) -> let s = try Ocsigen_parseconfig.parse_size_tag "uploaddir" s with Ocsigen_config.Config_file_error _ -> @@ -236,9 +236,9 @@ let parse_config usermode _ _ _ = function in gen @@ fun config -> { config with Ocsigen_extensions.maxuploadfilesize = s } - | Simplexmlparser.Element ("maxuploadfilesize" as s, _, _) -> + | Xml.Element ("maxuploadfilesize" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s - | Simplexmlparser.Element (t, _, _) -> + | Xml.Element (t, _, _) -> raise (Ocsigen_extensions.Bad_config_tag_for_extension t) | _ -> raise (Ocsigen_extensions.Error_in_config_file diff --git a/src/extensions/ocsipersist-dbm/Makefile b/src/extensions/ocsipersist-dbm/Makefile index 2bdc44ed9..189d305e9 100644 --- a/src/extensions/ocsipersist-dbm/Makefile +++ b/src/extensions/ocsipersist-dbm/Makefile @@ -1,9 +1,6 @@ include ../../../Makefile.config -PACKAGE := ${LWT_PREEMPTIVE_PACKAGE} \ - lwt.unix \ - tyxml.parser \ - dbm \ +PACKAGE := dbm ${LWT_PREEMPTIVE_PACKAGE} lwt.unix xml-light LIBS := -I ../../baselib -I ../../http -I ../../server \ ${addprefix -package ,${PACKAGE}} diff --git a/src/extensions/ocsipersist-dbm/ocsipersist.ml b/src/extensions/ocsipersist-dbm/ocsipersist.ml index 8977995eb..dbe277c12 100644 --- a/src/extensions/ocsipersist-dbm/ocsipersist.ml +++ b/src/extensions/ocsipersist-dbm/ocsipersist.ml @@ -38,26 +38,25 @@ let socketname = "socket" (*****************************************************************************) (** Internal functions: storage directory *) -open Simplexmlparser (** getting the directory from config file *) let rec parse_global_config (store, ocsidbm, delayloading as d) = function | [] -> d - | Element ("delayloading", [("val", ("true" | "1"))], []) :: ll -> + | Xml.Element ("delayloading", [("val", ("true" | "1"))], []) :: ll -> parse_global_config (store, ocsidbm, true) ll - | Element ("store", [("dir", s)], []) :: ll -> + | Xml.Element ("store", [("dir", s)], []) :: ll -> if store = None then parse_global_config ((Some s), ocsidbm, delayloading) ll else Ocsigen_extensions.badconfig "Ocsipersist: Duplicate tag" - | Element ("ocsidbm", [("name", s)], []) :: ll -> + | Xml.Element ("ocsidbm", [("name", s)], []) :: ll -> if ocsidbm = None then parse_global_config (store, (Some s), delayloading) ll else Ocsigen_extensions.badconfig "Ocsipersist: Duplicate tag" - | (Element (s,_,_))::ll -> Ocsigen_extensions.badconfig "Bad tag %s" s + | (Xml.Element (s,_,_))::ll -> Ocsigen_extensions.badconfig "Bad tag %s" s | _ -> Ocsigen_extensions.badconfig "Unexpected content inside Ocsipersist config" diff --git a/src/extensions/ocsipersist-pgsql/Makefile b/src/extensions/ocsipersist-pgsql/Makefile index f7b226ffe..0b6ed1693 100644 --- a/src/extensions/ocsipersist-pgsql/Makefile +++ b/src/extensions/ocsipersist-pgsql/Makefile @@ -1,6 +1,6 @@ include ../../../Makefile.config -PACKAGE := tyxml.parser pgocaml.syntax lwt.syntax +PACKAGE := lwt lwt.syntax pgocaml.syntax xml-light LIBS := -I ../../baselib -I ../../http -I ../../server \ ${addprefix -package ,${PACKAGE}} diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index c08e84be5..587a70a0f 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -195,11 +195,9 @@ let fold_table = fold_step let iter_block a b = failwith "Ocsipersist.iter_block: not implemented" - -open Simplexmlparser let parse_global_config = function | [] -> () - | [Element ("database", attrs, [])] -> let parse_attr = function + | [Xml.Element ("database", attrs, [])] -> let parse_attr = function | ("host", h) -> host := Some h | ("port", p) -> begin try port := Some (int_of_string p) diff --git a/src/extensions/ocsipersist-sqlite/Makefile b/src/extensions/ocsipersist-sqlite/Makefile index fea403b48..ba3c85e12 100644 --- a/src/extensions/ocsipersist-sqlite/Makefile +++ b/src/extensions/ocsipersist-sqlite/Makefile @@ -1,8 +1,6 @@ include ../../../Makefile.config -PACKAGE := lwt.preemptive \ - tyxml.parser \ - sqlite3 \ +PACKAGE := lwt.preemptive sqlite3 xml-light LIBS := -I ../../baselib -I ../../http -I ../../server \ ${addprefix -package ,${PACKAGE}} diff --git a/src/extensions/ocsipersist-sqlite/ocsipersist.ml b/src/extensions/ocsipersist-sqlite/ocsipersist.ml index 371e7a832..42485f067 100644 --- a/src/extensions/ocsipersist-sqlite/ocsipersist.ml +++ b/src/extensions/ocsipersist-sqlite/ocsipersist.ml @@ -36,11 +36,10 @@ exception Ocsipersist_error (*****************************************************************************) -open Simplexmlparser (** getting the directory from config file *) let rec parse_global_config = function | [] -> None - | (Element ("database", [("file", s)], []))::[] -> Some s + | (Xml.Element ("database", [("file", s)], []))::[] -> Some s | _ -> raise (Ocsigen_extensions.Error_in_config_file ("Unexpected content inside Ocsipersist config")) diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index 310d2058f..8998fcf9f 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -23,7 +23,7 @@ The reverse proxy is still experimental. *) open Lwt.Infix -open Simplexmlparser +open Xml let section = Lwt_log.Section.make "ocsigen:ext:revproxy" diff --git a/src/extensions/userconf.ml b/src/extensions/userconf.ml index 8f06dec37..5fc428514 100644 --- a/src/extensions/userconf.ml +++ b/src/extensions/userconf.ml @@ -87,11 +87,15 @@ let subresult new_req user_parse_site conf previous_err req req_state = ) let conf_to_xml conf = - try Simplexmlparser.xmlparser_file conf with + try [Xml.parse_file conf] with | Sys_error _ -> raise NoConfFile - | Simplexmlparser.Xml_parser_error s -> - raise (Ocsigen_extensions.Error_in_config_file s) + | Xml.Error (s, loc) -> + let begin_char, end_char = Xml.range loc and line = Xml.line loc in + raise (Ocsigen_extensions.Error_in_config_file + (Printf.sprintf "%s, line %d, characters %d-%d" + (Xml.error_msg s) + line begin_char end_char)) let gen hostpattern sitepath (regexp, conf, url, prefix, localpath) = function diff --git a/src/files/META.in b/src/files/META.in index 81cf1a8a3..ef8586bef 100644 --- a/src/files/META.in +++ b/src/files/META.in @@ -37,7 +37,7 @@ package "baselib" ( ) package "http" ( - requires = "%%NAME%%.baselib,lwt.ssl,tyxml" + requires = "%%NAME%%.baselib,lwt.ssl" version = "[distributed with Ocsigen server]" description = "HTTP library for Ocsigen server" archive(byte) = "http.cma" diff --git a/src/http/Makefile b/src/http/Makefile index f357a5b32..b6df84be0 100644 --- a/src/http/Makefile +++ b/src/http/Makefile @@ -3,7 +3,6 @@ PACKAGE := \ bytes \ lwt.ssl \ pcre \ - tyxml \ cohttp LIBS := -I ../baselib ${addprefix -package ,${PACKAGE}} diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 154678373..4649936c9 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -256,12 +256,12 @@ and extension2 = type extension = request_state -> answer Lwt.t -type parse_fun = Simplexmlparser.xml list -> extension2 +type parse_fun = Xml.xml list -> extension2 type parse_host = Parse_host of (Url.path -> - parse_host -> parse_fun -> Simplexmlparser.xml -> extension) + parse_host -> parse_fun -> Xml.xml -> extension) let (hosts : (virtual_hosts * config_info * extension2) list ref) = ref [] @@ -317,7 +317,7 @@ let new_url_of_directory_request request ri = (*****************************************************************************) (* To give parameters to extensions: *) -let dynlinkconfig = ref ([] : Simplexmlparser.xml list) +let dynlinkconfig = ref ([] : Xml.xml list) let set_config s = dynlinkconfig := s let get_config () = !dynlinkconfig @@ -398,7 +398,7 @@ let rec default_parse_config prevpath (Parse_host parse_host) (parse_fun : parse_fun) = function - | Simplexmlparser.Element ("site", atts, l) -> + | Xml.Element ("site", atts, l) -> let rec parse_site_attrs (enc,dir) = function | [] -> (match dir with | None -> @@ -496,7 +496,7 @@ let rec default_parse_config Lwt.return (Ext_found_continue_with' (r, ri)) | Req_not_found (err, ri) -> Lwt.return (Ext_sub_result ext)) - | Simplexmlparser.Element (tag,_,_) -> + | Xml.Element (tag,_,_) -> raise (Bad_config_tag_for_extension tag) | _ -> raise (Ocsigen_config.Config_file_error ("Unexpected content inside ")) @@ -558,7 +558,7 @@ type parse_config = virtual_hosts -> config_info -> parse_config_aux and parse_config_user = userconf_info -> parse_config and parse_config_aux = Url.path -> parse_host -> - (parse_fun -> Simplexmlparser.xml -> + (parse_fun -> Xml.xml -> extension ) @@ -566,11 +566,11 @@ and parse_config_aux = let user_extension_void_fun_site : parse_config_user = fun _ _ _ _ _ _ -> function - | Simplexmlparser.Element (t, _, _) -> raise (Bad_config_tag_for_extension t) + | Xml.Element (t, _, _) -> raise (Bad_config_tag_for_extension t) | _ -> raise (Error_in_config_file "Unexpected data in config file") let extension_void_fun_site : parse_config = fun _ _ _ _ _ -> function - | Simplexmlparser.Element (t, _, _) -> raise (Bad_config_tag_for_extension t) + | Xml.Element (t, _, _) -> raise (Bad_config_tag_for_extension t) | _ -> raise (Error_in_config_file "Unexpected data in config file") @@ -693,7 +693,7 @@ module Configuration = struct elements : element list; attributes : attribute list; pcdata : (string -> unit) option; - other_elements : (string -> (string * string) list -> Simplexmlparser.xml list -> unit) option; + other_elements : (string -> (string * string) list -> Xml.xml list -> unit) option; other_attributes : (string -> string -> unit) option; } and element = string * element' @@ -737,7 +737,7 @@ module Configuration = struct let check_element_occurrence ~in_tag elements = function | name, { obligatory = true } -> let corresponding_element = function - | Simplexmlparser.Element (name', _, _) -> name = name' + | Xml.Element (name', _, _) -> name = name' | _ -> false in if not (List.exists corresponding_element elements) then @@ -760,14 +760,14 @@ module Configuration = struct let rec process_element ~in_tag ~elements:spec_elements ?pcdata:spec_pcdata ?other_elements:spec_other_elements = function - | Simplexmlparser.PCData str -> + | Xml.PCData str -> let spec_pcdata = Ocsigen_lib.Option.get (fun () -> ignore_blank_pcdata ~in_tag) spec_pcdata in spec_pcdata str - | Simplexmlparser.Element (name, attributes, elements) -> + | Xml.Element (name, attributes, elements) -> try let spec = List.assoc name spec_elements in List.iter diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 880482708..5234c4847 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -219,7 +219,7 @@ type extension = request_state -> answer Lwt.t the extension may want to modify the result (filters). *) -type parse_fun = Simplexmlparser.xml list -> extension2 +type parse_fun = Xml.xml list -> extension2 (** Type of the functions parsing the content of a tag *) type parse_host @@ -262,7 +262,7 @@ and parse_config_user = userconf_info -> parse_config and parse_config_aux = Ocsigen_lib.Url.path -> parse_host -> - (parse_fun -> Simplexmlparser.xml -> + (parse_fun -> Xml.xml -> extension ) @@ -312,7 +312,7 @@ val register_extension : ?user_fun_site:parse_config_user -> ?begin_init:(unit -> unit) -> ?end_init:(unit -> unit) -> - ?init_fun:(Simplexmlparser.xml list -> unit) -> + ?init_fun:(Xml.xml list -> unit) -> ?exn_handler:(exn -> string) -> ?respect_pipeline:bool -> unit -> unit @@ -345,7 +345,7 @@ module Configuration : sig ?elements:element list -> ?attributes:attribute list -> ?pcdata:(string -> unit) -> - ?other_elements:(string -> (string * string) list -> Simplexmlparser.xml list -> unit) -> + ?other_elements:(string -> (string * string) list -> Xml.xml list -> unit) -> ?other_attributes:(string -> string -> unit) -> unit -> element @@ -373,17 +373,17 @@ module Configuration : sig in_tag:string -> elements:element list -> ?pcdata:(string -> unit) -> - ?other_elements:(string -> (string * string) list -> Simplexmlparser.xml list -> unit) -> - Simplexmlparser.xml -> unit + ?other_elements:(string -> (string * string) list -> Xml.xml list -> unit) -> + Xml.xml -> unit (** Application of [process_element] on a list of XML elements. *) val process_elements : in_tag:string -> elements:element list -> ?pcdata:(string -> unit) -> - ?other_elements:(string -> (string * string) list -> Simplexmlparser.xml list -> unit) -> + ?other_elements:(string -> (string * string) list -> Xml.xml list -> unit) -> ?init:(unit -> unit) -> - Simplexmlparser.xml list -> unit + Xml.xml list -> unit (** The specification for ignoring blank PCDATA ('\n', '\r', ' ', '\t') and failing otherwise (a reasonable default). *) @@ -472,7 +472,7 @@ val get_numberofreloads : unit -> int val get_init_exn_handler : unit -> exn -> string -val set_config : Simplexmlparser.xml list -> unit +val set_config : Xml.xml list -> unit val sockets : Lwt_unix.file_descr list ref val sslsockets : Lwt_unix.file_descr list ref diff --git a/src/server/ocsigen_parseconfig.ml b/src/server/ocsigen_parseconfig.ml index a20ce2a7d..12b2f0ecb 100644 --- a/src/server/ocsigen_parseconfig.ml +++ b/src/server/ocsigen_parseconfig.ml @@ -22,7 +22,7 @@ (** Config file parsing *) open Ocsigen_socket -open Simplexmlparser +open Xml open Ocsigen_config module Netstring_pcre = Ocsigen_lib.Netstring_pcre @@ -184,10 +184,7 @@ let parse_string_tag tag s = let rec parser_config = - let rec verify_empty = function - | [] -> () - | _ -> raise (Config_file_error "Don't know what to do with trailing data") - in let rec parse_servers n = function + let rec parse_servers n = function | [] -> (match n with | [] -> raise (Config_file_error (" tag expected")) | _ -> n) @@ -203,14 +200,13 @@ let rec parser_config = (* nouveau at the end *) | _ -> raise (Config_file_error ("syntax error inside ")) in function - | (Element ("ocsigen", [], l))::ll -> - verify_empty ll; + | Element ("ocsigen", [], l) -> parse_servers [] l | _ -> raise (Config_file_error " tag expected") let parse_ext file = - parser_config (Simplexmlparser.xmlparser_file file) + parser_config (Xml.parse_file file) let preloadfile config () = Ocsigen_extensions.set_config config @@ -785,6 +781,6 @@ let parse_config ?file () = | None -> Ocsigen_config.get_config_file () | Some f -> f in - parser_config (Simplexmlparser.xmlparser_file file) + parser_config (Xml.parse_file file) (******************************************************************) diff --git a/src/server/ocsigen_parseconfig.mli b/src/server/ocsigen_parseconfig.mli index 9fe9da17b..2deac3fba 100644 --- a/src/server/ocsigen_parseconfig.mli +++ b/src/server/ocsigen_parseconfig.mli @@ -36,13 +36,13 @@ val parse_size_tag : string -> string -> int64 option (** Parse a string (PCDATA) as XML content. Raises [Failure "Ocsigen_parseconfig.parse_string"] in case of error. *) -val parse_string : Simplexmlparser.xml list -> string +val parse_string : Xml.xml list -> string (** [parse_string_tag tag s] parses a string (same syntax as [parse_string]). In case of error, raises [Ocsigen_config.Config_file_error m] where [m] is an error message explaining that a string was expected in tag []. *) -val parse_string_tag : string -> Simplexmlparser.xml list -> string +val parse_string_tag : string -> Xml.xml list -> string (** Parses the [hostfilter] field of the configuration file, which @@ -52,9 +52,7 @@ val parse_host_field: string option -> Ocsigen_extensions.virtual_hosts (**/**) -val parser_config : Simplexmlparser.xml list -> - Simplexmlparser.xml list list -val parse_server : bool -> Simplexmlparser.xml list -> unit +val parse_server : bool -> Xml.xml list -> unit type ssl_info = { ssl_certificate : string option; @@ -76,7 +74,7 @@ type ssl_info = { } *) val extract_info : - Simplexmlparser.xml list -> + Xml.xml list -> (string option * string option) * (ssl_info option * (Ocsigen_socket.socket_type * int) list * @@ -86,4 +84,4 @@ val extract_info : val parse_config : ?file:string -> unit -> - Simplexmlparser.xml list list + Xml.xml list list diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index f7a546594..bb42b1a38 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -68,9 +68,13 @@ let errmsg = function | Ocsigen_extensions.Error_in_config_file msg -> (("Fatal - Error in configuration file: "^msg), 50) - | Simplexmlparser.Xml_parser_error s -> - (("Fatal - Error in configuration file: "^s), - 51) + | Xml.Error (s, loc) -> + let begin_char, end_char = Xml.range loc and line = Xml.line loc in + Printf.sprintf + "Fatal - Error in configuration file, line %d, characters %d-%d: %s" + line begin_char end_char + (Xml.error_msg s), + 51 | Ocsigen_loader.Dynlink_error (s, exn) -> (("Fatal - While loading "^s^": "^(Printexc.to_string exn)), 52) From 0f47890da629d93fcaa1e23d636adb7115f2ed86 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 2 May 2017 17:18:57 +0200 Subject: [PATCH 065/111] Un-open Lwt --- src/extensions/ocsipersist-dbm/ocsidbm.ml | 20 ++-- src/extensions/ocsipersist-dbm/ocsipersist.ml | 98 +++++++++---------- .../ocsipersist-pgsql/ocsipersist.ml | 2 +- .../ocsipersist-sqlite/ocsipersist.ml | 20 ++-- src/server/ocsigen_parseconfig.ml | 23 +++-- 5 files changed, 85 insertions(+), 78 deletions(-) diff --git a/src/extensions/ocsipersist-dbm/ocsidbm.ml b/src/extensions/ocsipersist-dbm/ocsidbm.ml index e6e4d23a3..3efb56b61 100644 --- a/src/extensions/ocsipersist-dbm/ocsidbm.ml +++ b/src/extensions/ocsipersist-dbm/ocsidbm.ml @@ -23,7 +23,7 @@ open Dbm open Ocsidbmtypes -open Lwt +open Lwt.Infix let directory = Sys.argv.(1) @@ -156,14 +156,14 @@ let db_nextkey t = Dbm.nextkey (find_dont_create_table t) let db_length t = let table = find_dont_create_table t in let rec aux f n = - catch + Lwt.catch (fun () -> ignore (f table); Lwt_unix.yield () >>= (fun () -> aux Dbm.nextkey (n+1))) (function - | Not_found -> return n - | e -> fail e) + | Not_found -> Lwt.return n + | e -> Lwt.fail e) in aux Dbm.firstkey 0 (* Because of Dbm implementation, the result may be less than the expected @@ -231,7 +231,7 @@ let execute outch = with Not_found -> send outch End) | Length t -> handle_errors (fun () -> - catch + Lwt.catch (fun () -> db_length t >>= (fun i -> send outch (Value (Marshal.to_string i [])))) @@ -249,7 +249,7 @@ let finish _ = nb_clients := !nb_clients - 1; if !nb_clients = 0 then close_all 0 (); - return () + Lwt.return () let b = ref false @@ -262,7 +262,7 @@ let rec loop socket = nb_clients := !nb_clients + 1; let inch = Lwt_io.(of_fd ~mode:input) indescr in let outch = Lwt_io.(of_fd ~mode:output) indescr in - catch + Lwt.catch (fun () -> listen_client inch outch >>= finish) finish); loop socket) @@ -283,7 +283,7 @@ let _ = Lwt_main.run Unix.close devnull; Unix.close Unix.stdin; *) ignore (Lwt_unix.sleep 4.1 >>= - (fun () -> if not !b then close_all 0 (); return ())); + (fun () -> if not !b then close_all 0 (); Lwt.return ())); (* If nothing happened during 5 seconds, I quit *) loop socket) @@ -332,10 +332,10 @@ let _ = Lwt_main.run ) ) t - (return ())) + (Lwt.return ())) ) !tableoftables - (return ()) + (Lwt.return ()) ) >>= f in ignore (f ()) diff --git a/src/extensions/ocsipersist-dbm/ocsipersist.ml b/src/extensions/ocsipersist-dbm/ocsipersist.ml index dbe277c12..c2019883e 100644 --- a/src/extensions/ocsipersist-dbm/ocsipersist.ml +++ b/src/extensions/ocsipersist-dbm/ocsipersist.ml @@ -23,7 +23,7 @@ (** Module Ocsipersist: persistent data *) open Ocsidbmtypes -open Lwt +open Lwt.Infix let section = Lwt_log.Section.make "ocsipersist:dbm" (** Data are divided into stores. @@ -72,11 +72,11 @@ let (directory, ocsidbm) = external sys_exit : int -> 'a = "caml_sys_exit" let rec try_connect sname = - catch + Lwt.catch (fun () -> let socket = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in Lwt_unix.connect socket (Unix.ADDR_UNIX sname) >>= fun () -> - return socket) + Lwt.return socket) (fun _ -> Lwt_log.ign_warning_f ~section "Launching a new Ocsidbm process: %s on directory %s." !ocsidbm !directory; @@ -108,10 +108,10 @@ let rec try_connect sname = (fun () -> let socket = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in Lwt_unix.connect socket (Unix.ADDR_UNIX sname) >>= fun () -> - return socket))) + Lwt.return socket))) let rec get_indescr i = - (catch + (Lwt.catch (fun () -> try_connect (!directory^"/"^socketname)) (fun e -> if i = 0 @@ -126,7 +126,7 @@ let rec get_indescr i = | Unix.Unix_error (a,b,c) -> Printf.sprintf "%a in %s(%s)" (fun () -> Unix.error_message) a b c | _ -> Printexc.to_string e); - fail e + Lwt.fail e end else (Lwt_unix.sleep 2.1) >>= (fun () -> get_indescr (i-1)))) @@ -150,22 +150,22 @@ let init_fun config = Lwt_log.ign_warning ~section "Initializing ..."); let indescr = get_indescr 2 in if delay_loading then ( - inch := (indescr >>= fun r -> return (Lwt_io.(of_fd ~mode:input) r)); - outch := (indescr >>= fun r -> return (Lwt_io.(of_fd ~mode:output) r)); + inch := (indescr >>= fun r -> Lwt.return (Lwt_io.(of_fd ~mode:input) r)); + outch := (indescr >>= fun r -> Lwt.return (Lwt_io.(of_fd ~mode:output) r)); ) else ( let r = Lwt_main.run indescr in - inch := return (Lwt_io.(of_fd ~mode:input) r); - outch := return (Lwt_io.(of_fd ~mode:output) r); + inch := Lwt.return (Lwt_io.(of_fd ~mode:input) r); + outch := Lwt.return (Lwt_io.(of_fd ~mode:output) r); Lwt_log.ign_warning ~section "...Initialization complete"; ) let send = - let previous = ref (return Ok) in + let previous = ref (Lwt.return Ok) in fun v -> - catch + Lwt.catch (fun () -> !previous) - (fun _ -> return Ok) >>= + (fun _ -> Lwt.return Ok) >>= (fun _ -> !inch >>= fun inch -> !outch >>= fun outch -> @@ -178,54 +178,54 @@ let send = let db_get (store, name) = send (Get (store, name)) >>= (function - | Value v -> return v - | Dbm_not_found -> fail Not_found - | Error e -> fail e - | _ -> fail Ocsipersist_error) + | Value v -> Lwt.return v + | Dbm_not_found -> Lwt.fail Not_found + | Error e -> Lwt.fail e + | _ -> Lwt.fail Ocsipersist_error) let db_remove (store, name) = send (Remove (store, name)) >>= (function - | Ok -> return () - | Error e -> fail e - | _ -> fail Ocsipersist_error) + | Ok -> Lwt.return () + | Error e -> Lwt.fail e + | _ -> Lwt.fail Ocsipersist_error) let db_replace (store, name) value = send (Replace (store, name, value)) >>= (function - | Ok -> return () - | Error e -> fail e - | _ -> fail Ocsipersist_error) + | Ok -> Lwt.return () + | Error e -> Lwt.fail e + | _ -> Lwt.fail Ocsipersist_error) let db_replace_if_exists (store, name) value = send (Replace_if_exists (store, name, value)) >>= (function - | Ok -> return () - | Dbm_not_found -> fail Not_found - | Error e -> fail e - | _ -> fail Ocsipersist_error) + | Ok -> Lwt.return () + | Dbm_not_found -> Lwt.fail Not_found + | Error e -> Lwt.fail e + | _ -> Lwt.fail Ocsipersist_error) let db_firstkey store = send (Firstkey store) >>= (function - | Key k -> return (Some k) - | Error e -> fail e - | _ -> return None) + | Key k -> Lwt.return (Some k) + | Error e -> Lwt.fail e + | _ -> Lwt.return None) let db_nextkey store = send (Nextkey store) >>= (function - | Key k -> return (Some k) - | Error e -> fail e - | _ -> return None) + | Key k -> Lwt.return (Some k) + | Error e -> Lwt.fail e + | _ -> Lwt.return None) let db_length store = send (Length store) >>= (function - | Value v -> return (Marshal.from_string v 0) - | Dbm_not_found -> return 0 - | Error e -> fail e - | _ -> fail Ocsipersist_error) + | Value v -> Lwt.return (Marshal.from_string v 0) + | Dbm_not_found -> Lwt.return 0 + | Error e -> Lwt.fail e + | _ -> Lwt.fail Ocsipersist_error) @@ -240,14 +240,14 @@ let open_store name = Lwt.return name let make_persistent_lazy_lwt ~store ~name ~default = let pvname = (store, name) in - (catch - (fun () -> db_get pvname >>= (fun _ -> return ())) + (Lwt.catch + (fun () -> db_get pvname >>= (fun _ -> Lwt.return ())) (function | Not_found -> default () >>= fun def -> db_replace pvname (Marshal.to_string def []) - | e -> fail e)) >>= - (fun () -> return pvname) + | e -> Lwt.fail e)) >>= + (fun () -> Lwt.return pvname) let make_persistent_lazy ~store ~name ~default = let default () = Lwt.wrap default in @@ -258,7 +258,7 @@ let make_persistent ~store ~name ~default = let get (pvname : 'a t) : 'a = db_get pvname >>= - (fun r -> return (Marshal.from_string r 0)) + (fun r -> Lwt.return (Marshal.from_string r 0)) let set pvname v = let data = Marshal.to_string v [] in @@ -275,7 +275,7 @@ let table_name n = Lwt.return n let find table key = db_get (table, key) >>= - (fun v -> return (Marshal.from_string v 0)) + (fun v -> Lwt.return (Marshal.from_string v 0)) let add table key value = let data = Marshal.to_string value [] in @@ -292,7 +292,7 @@ let iter_table f table = let rec aux nextkey = nextkey table >>= (function - | None -> return () + | None -> Lwt.return () | Some k -> find table k >>= f k >>= (fun () -> aux db_nextkey)) in aux db_firstkey @@ -303,7 +303,7 @@ let fold_table f table beg = let rec aux nextkey beg = nextkey table >>= (function - | None -> return beg + | None -> Lwt.return beg | Some k -> find table k >>= fun r -> f k r beg >>= (fun res -> aux db_nextkey res)) in @@ -331,7 +331,7 @@ let iter_block a b = failwith "iter_block not implemented for DBM. Please use Oc let nextkey next nextl = Lwt_unix.write indescr next 0 nextl >>= (fun l2 -> if l2 <> nextl - then fail Ocsipersist_error + then Lwt.fail Ocsipersist_error else (Lwt_unix.input_line inch >>= fun answ -> return (Marshal.from_string answ 0))) in @@ -340,15 +340,15 @@ let iter_block a b = failwith "iter_block not implemented for DBM. Please use Oc (function | End -> return () | Key k -> find table k >>= f k - | Error e -> fail e - | _ -> fail Ocsipersist_error) >>= + | Error e -> Lwt.fail e + | _ -> Lwt.fail Ocsipersist_error) >>= (fun () -> aux next nextl) in catch (fun () -> aux first firstl >>= (fun () -> Unix.close socket; return ())) - (fun e -> Unix.close socket; fail e)))) + (fun e -> Unix.close socket; Lwt.fail e)))) *) diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index 587a70a0f..4e84ee802 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -17,7 +17,7 @@ module Lwt_thread = struct type out_channel = Lwt_io.output_channel end module PGOCaml = PGOCaml_generic.Make(Lwt_thread) -open Lwt +open Lwt.Infix open Printf exception Ocsipersist_error diff --git a/src/extensions/ocsipersist-sqlite/ocsipersist.ml b/src/extensions/ocsipersist-sqlite/ocsipersist.ml index 42485f067..ac4a856cc 100644 --- a/src/extensions/ocsipersist-sqlite/ocsipersist.ml +++ b/src/extensions/ocsipersist-sqlite/ocsipersist.ml @@ -22,7 +22,7 @@ let section = Lwt_log.Section.make "ocsipersist:sqlite" (** Module Ocsipersist: persistent data *) -open Lwt +open Lwt.Infix open Sqlite3 open Printf @@ -104,7 +104,7 @@ let db_create table = aux () in exec_safely create >>= fun () -> - return table + Lwt.return table let db_remove (table, key) = let sql = sprintf "DELETE FROM %s WHERE key = :key " table in @@ -230,14 +230,14 @@ let open_store name = let make_persistent_lazy_lwt ~store ~name ~default = let pvname = (store, name) in - (catch - (fun () -> db_get pvname >>= (fun _ -> return ())) + (Lwt.catch + (fun () -> db_get pvname >>= (fun _ -> Lwt.return ())) (function | Not_found -> default () >>= fun def -> db_replace pvname (Marshal.to_string def []) - | e -> fail e)) >>= - (fun () -> return pvname) + | e -> Lwt.fail e)) >>= + (fun () -> Lwt.return pvname) let make_persistent_lazy ~store ~name ~default = let default () = Lwt.wrap default in @@ -248,7 +248,7 @@ let make_persistent ~store ~name ~default = let get (pvname : 'a t) : 'a = db_get pvname >>= - (fun r -> return (Marshal.from_string r 0)) + (fun r -> Lwt.return (Marshal.from_string r 0)) let set pvname v = let data = Marshal.to_string v [] in @@ -264,7 +264,7 @@ let table_name table = Lwt.return table let find table key = db_get (table, key) >>= fun v -> - return (Marshal.from_string v 0) + Lwt.return (Marshal.from_string v 0) let add table key value = let data = Marshal.to_string value [] in @@ -281,7 +281,7 @@ let iter_step f table = let rec aux rowid = db_iter_step table rowid >>= (function - | None -> return () + | None -> Lwt.return () | Some (k,v,rowid') -> f k (Marshal.from_string v 0) >>= (fun () -> aux rowid')) in @@ -291,7 +291,7 @@ let fold_step f table beg = let rec aux rowid beg = db_iter_step table rowid >>= (function - | None -> return beg + | None -> Lwt.return beg | Some (k, v, rowid') -> f k (Marshal.from_string v 0) beg >>= (fun res -> aux rowid' res)) in diff --git a/src/server/ocsigen_parseconfig.ml b/src/server/ocsigen_parseconfig.ml index 12b2f0ecb..c21f6b884 100644 --- a/src/server/ocsigen_parseconfig.ml +++ b/src/server/ocsigen_parseconfig.ml @@ -21,7 +21,6 @@ (******************************************************************) (** Config file parsing *) -open Ocsigen_socket open Xml open Ocsigen_config @@ -605,16 +604,24 @@ let parse_port = let do_match r = Netstring_pcre.string_match r s 0 in let get x i = Netstring_pcre.matched_group x i s in match do_match all_ipv6 with - | Some r -> IPv6 (Unix.inet6_addr_any), int_of_string "port" (get r 1) + | Some r -> + Ocsigen_socket.IPv6 (Unix.inet6_addr_any), + int_of_string "port" (get r 1) | None -> match do_match all_ipv4 with - | Some r -> IPv4 (Unix.inet_addr_any), int_of_string "port" (get r 1) + | Some r -> + Ocsigen_socket.IPv4 (Unix.inet_addr_any), + int_of_string "port" (get r 1) | None -> match do_match single_ipv6 with - | Some r -> IPv6 (Unix.inet_addr_of_string (get r 1)), - int_of_string "port" (get r 2) + | Some r -> + Ocsigen_socket.IPv6 (Unix.inet_addr_of_string (get r 1)), + int_of_string "port" (get r 2) | None -> match do_match single_ipv4 with - | Some r -> IPv4 (Unix.inet_addr_of_string (get r 1)), - int_of_string "port" (get r 2) - | None -> All, int_of_string "port" s + | Some r -> + Ocsigen_socket.IPv4 (Unix.inet_addr_of_string (get r 1)), + int_of_string "port" (get r 2) + | None -> + Ocsigen_socket.All, + int_of_string "port" s let parse_facility = function | "auth" -> `Auth From 34ca53f57bae77257e8397e8cfa43a6fdeecd27b Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 3 May 2017 16:05:13 +0200 Subject: [PATCH 066/111] Begin Ocsigen_config restructuring Compile-time-generated part goes to Ocsigen_config_static . All configuration to go through Ocsigen_config eventually. --- .gitignore | 2 +- Makefile.options | 2 +- doc/manual-wiki/launching.wiki | 7 --- src/Makefile.filelist | 4 +- src/baselib/.depend | 6 ++- src/baselib/Makefile | 13 ++--- src/baselib/ocsigen_commandline.ml | 4 +- ...ocsigen_config.ml.in => ocsigen_config.ml} | 43 ++--------------- src/baselib/ocsigen_config.mli | 2 - src/baselib/ocsigen_config_static.ml.in | 42 +++++++++++++++++ src/extensions/.depend | 47 +++++++++---------- src/files/ocsigenserver.1 | 3 -- src/server/.depend | 4 +- 13 files changed, 89 insertions(+), 90 deletions(-) rename src/baselib/{ocsigen_config.ml.in => ocsigen_config.ml} (80%) create mode 100644 src/baselib/ocsigen_config_static.ml.in diff --git a/.gitignore b/.gitignore index 650df45fe..170843aed 100644 --- a/.gitignore +++ b/.gitignore @@ -12,7 +12,7 @@ *~ Makefile.config src/baselib/dynlink_wrapper.ml -src/baselib/ocsigen_config.ml +src/baselib/ocsigen_config_static.ml src/http/http_parser.ml src/http/http_parser.mli src/server/ocsigenserver diff --git a/Makefile.options b/Makefile.options index 239609380..560746591 100644 --- a/Makefile.options +++ b/Makefile.options @@ -22,7 +22,7 @@ ifeq "$(PREEMPTIVE)" "YES" endif ## ${SERVER_PACKAGE} is not only used to build the 'ocsigenserver' executable -## but also to generate src/baselib/ocsigen_config.ml and src/files/META +## but also to generate src/baselib/ocsigen_config_static.ml and src/files/META ifeq "$(PREEMPTIVE)" "YES" LWT_PREEMPTIVE_PACKAGE:=lwt.preemptive diff --git a/doc/manual-wiki/launching.wiki b/doc/manual-wiki/launching.wiki index e7c36f4cf..b2b95173a 100644 --- a/doc/manual-wiki/launching.wiki +++ b/doc/manual-wiki/launching.wiki @@ -25,16 +25,9 @@ following options: -v, --verbose Verbose mode. - -V , --veryverbose - Very verbose mode (debug). - --version Show version of program. }}} One initialization script should be provided by your distribution for launching the server automatically each time you launch the computer. - - - - diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 5369e643b..00670cc83 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -4,7 +4,7 @@ NATBIN := server/${PROJECTNAME}.opt INTF_BASE := baselib/ocsigen_cache.cmi \ baselib/ocsigen_lib_base.cmi \ baselib/ocsigen_lib.cmi \ - baselib/ocsigen_config.cmi \ + baselib/ocsigen_config.cmi \ baselib/ocsigen_messages.cmi \ baselib/ocsigen_stream.cmi \ baselib/ocsigen_loader.cmi \ @@ -25,6 +25,8 @@ INTF_BASE := baselib/ocsigen_cache.cmi \ INTF := ${INTF_BASE} baselib/ocsigen_getcommandline.cmi IMPL := baselib/ocsigen_lib_base.cmo \ + baselib/ocsigen_config_static.cmo \ + baselib/ocsigen_config.cmo \ baselib/baselib.cma \ baselib/parsecommandline.cma \ baselib/donotparsecommandline.cma \ diff --git a/src/baselib/.depend b/src/baselib/.depend index fdc97bcf9..beea2346e 100644 --- a/src/baselib/.depend +++ b/src/baselib/.depend @@ -9,9 +9,11 @@ ocsigen_cache.cmx : ocsigen_cache.cmi ocsigen_cache.cmi : ocsigen_commandline.cmo : ocsigen_getcommandline.cmi ocsigen_config.cmi ocsigen_commandline.cmx : ocsigen_getcommandline.cmi ocsigen_config.cmx -ocsigen_config.cmo : ocsigen_lib.cmi ocsigen_config.cmi -ocsigen_config.cmx : ocsigen_lib.cmx ocsigen_config.cmi +ocsigen_config.cmo : ocsigen_config_static.cmo ocsigen_config.cmi +ocsigen_config.cmx : ocsigen_config_static.cmx ocsigen_config.cmi ocsigen_config.cmi : ocsigen_lib.cmi +ocsigen_config_static.cmo : ocsigen_lib.cmi +ocsigen_config_static.cmx : ocsigen_lib.cmx ocsigen_getcommandline.cmi : ocsigen_lib.cmo : ocsigen_lib_base.cmi ocsigen_lib.cmi ocsigen_lib.cmx : ocsigen_lib_base.cmx ocsigen_lib.cmi diff --git a/src/baselib/Makefile b/src/baselib/Makefile index 5690cab0e..026561fc9 100644 --- a/src/baselib/Makefile +++ b/src/baselib/Makefile @@ -22,6 +22,7 @@ all: byte opt FILES := ocsigen_lib_base.ml \ ocsigen_lib.ml \ ocsigen_cache.ml \ + ocsigen_config_static.ml \ ocsigen_config.ml \ ocsigen_commandline.ml \ ocsigen_messages.ml \ @@ -31,7 +32,7 @@ FILES := ocsigen_lib_base.ml \ INTF_NOP4 := ocsigen_lib_base.mli ocsigen_lib.mli -PREDEP := ocsigen_config.ml dynlink_wrapper.ml +PREDEP := ocsigen_config_static.ml dynlink_wrapper.ml byte:: baselib.cma opt:: baselib.cmxa @@ -59,10 +60,10 @@ endif VERSION := $(shell head -n 1 ../../VERSION) -ocsigen_config.ml: ocsigen_config.ml.in ../../Makefile.config ../../Makefile.options ../../VERSION - cat ocsigen_config.ml.in \ - | sed s%0000000000000000%${VERSION}% \ - | sed s%_WARNING_%"Warning: this file has been generated from ocsigen_config.ml.in - DO NOT MODIFY MANUALLY!"% \ +ocsigen_config_static.ml: ocsigen_config_static.ml.in ../../Makefile.config ../../Makefile.options ../../VERSION + cat ocsigen_config_static.ml.in \ + | sed s%_VERSION_%${VERSION}% \ + | sed s%_WARNING_%"Warning: this file has been generated from ocsigen_config_static.ml.in - DO NOT MODIFY MANUALLY!"% \ | sed s%_LOGDIR_%$(LOGDIR)% \ | sed s%_DATADIR_%$(DATADIR)%g \ | sed s%_BINDIR_%$(BINDIR)%g \ @@ -77,7 +78,7 @@ ocsigen_config.ml: ocsigen_config.ml.in ../../Makefile.config ../../Makefile.opt | sed s%_PREEMTIMPLEM_%$(PREEMTIMPLEM)% \ | sed s%_ISNATIVE_%$(NATIVECODE_RUNTIME_DETECT)%g \ | sed "s%_DEPS_%$(INITPACKAGE)%g" \ - > ocsigen_config.ml + > ocsigen_config_static.ml ## Dynlink_wrapper ## diff --git a/src/baselib/ocsigen_commandline.ml b/src/baselib/ocsigen_commandline.ml index 00a52dab8..aa3842a3a 100644 --- a/src/baselib/ocsigen_commandline.ml +++ b/src/baselib/ocsigen_commandline.ml @@ -18,7 +18,7 @@ open Ocsigen_config -let cmdline : unit = +let cmdline : unit = try Arg.parse_argv Ocsigen_getcommandline.commandline [("-c", Arg.String set_configfile, @@ -31,8 +31,6 @@ let cmdline : unit = ("--pidfile", Arg.String set_pidfile, "Specify a file where to write the PIDs of servers"); ("-v", Arg.Unit set_verbose, "Verbose mode"); ("--verbose", Arg.Unit set_verbose, "Verbose mode"); - ("-V", Arg.Unit set_veryverbose, "Very verbose mode (debug)"); - ("--veryverbose", Arg.Unit set_veryverbose, "Very verbose mode (debug)"); ("-d", Arg.Unit set_daemon, "Daemon mode (detach the process)"); ("--daemon", Arg.Unit set_daemon, "Daemon mode (detach the process) (This is the default when there are more than 1 process)"); ("--version", Arg.Unit display_version, "Display version number and exit") diff --git a/src/baselib/ocsigen_config.ml.in b/src/baselib/ocsigen_config.ml similarity index 80% rename from src/baselib/ocsigen_config.ml.in rename to src/baselib/ocsigen_config.ml index 328fa8906..7f9d88576 100644 --- a/src/baselib/ocsigen_config.ml.in +++ b/src/baselib/ocsigen_config.ml @@ -1,7 +1,5 @@ -(* Warning! ocsigen_config.ml is generated automatically from ocsigen_config.ml.in! - Do not modify it manually *) (* Ocsigen - * Copyright (C) 2005 Vincent Balat + * Copyright (C) 2005-2017 Vincent Balat * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -18,26 +16,19 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ocsigen_lib +include Ocsigen_config_static exception Config_file_error of string (* General config *) -let config_file = ref "_CONFIGDIR_/_PROJECTNAME_.conf" let verbose = ref false let silent = ref false let daemon = ref false -let veryverbose = ref false -let version_number = (**)"0000000000000000"(**) -let pidfile = ref None +let pidfile = ref (None : string option) let server_name = "Ocsigen" let full_server_name = server_name^"/"^version_number -let is_native = _ISNATIVE_ let native_ext = if is_native then ".opt" else "" -let builtin_packages = - List.fold_left (fun a s -> String.Set.add s a) String.Set.empty [_DEPS_] - module Fake_preempt = struct let set_max_number_of_threads_queued : int -> unit = fun _ -> () @@ -45,32 +36,22 @@ struct let init : int -> int -> (string -> unit) -> unit = fun _ _ _ -> () end -(* Server config: *) +(* Server config *) let (uploaddir : string option ref) = ref None -let logdir = ref (Some ("_LOGDIR_")) -let syslog_facility = ref None -let default_user = ref "_OCSIGENUSER_" -let default_group = ref "_OCSIGENGROUP_" +let syslog_facility = ref (None : Lwt_log.syslog_facility option) let minthreads = ref 10 let maxthreads = ref 30 let max_number_of_connections = ref 350 -let mimefile = ref "_CONFIGDIR_/mime.types" let silent_client_timeout = ref 30 (* without speaking during sending frame *) let silent_server_timeout = ref 30 (* without speaking during sending frame *) -(*let keepalive_timeout = ref 30 -let keepopen_timeout = ref 300 (* for ocsigen as client *) *) let netbuffersize = ref 8192 let filebuffersize = ref 8192 let maxrequestbodysize = ref (Some (Int64.of_int 8000000)) let maxrequestbodysizeinmemory = ref 8192 let maxuploadfilesize = ref (Some (Int64.of_int 2000000)) let defaultcharset = ref (None : string option) -let datadir = ref "_DATADIR_" -let bindir = ref "_BINDIR_" -let extdir = ref "_EXTDIR_" let user = ref (Some !default_user) let group = ref (Some !default_group) -let command_pipe = ref "_COMMANDPIPE_" let debugmode = ref false let disablepartialrequests = ref false let usedefaulthostname = ref false @@ -89,15 +70,9 @@ let set_mimefile s = mimefile := s let set_verbose () = verbose := true let set_silent () = silent := true let set_daemon () = set_silent (); daemon := true -let set_veryverbose () = - verbose := true; - veryverbose := true; - Lwt_log.add_rule "*" Lwt_log.Debug let set_minthreads i = minthreads := i let set_maxthreads i = maxthreads := i -let set_max_number_of_threads_queued = - _PREEMTIMPLEM_.set_max_number_of_threads_queued let set_max_number_of_connections i = max_number_of_connections := i let set_client_timeout i = silent_client_timeout := i let set_server_timeout i = silent_server_timeout := i @@ -137,18 +112,13 @@ let get_mimefile () = !mimefile let get_verbose () = !verbose let get_silent () = !silent let get_daemon () = !daemon -let get_veryverbose () = !veryverbose let get_default_user () = !default_user let get_default_group () = !default_group let get_minthreads () = !minthreads let get_maxthreads () = !maxthreads -let get_max_number_of_threads_queued = - _PREEMTIMPLEM_.get_max_number_of_threads_queued let get_max_number_of_connections () = !max_number_of_connections let get_client_timeout () = !silent_client_timeout let get_server_timeout () = !silent_server_timeout -(*let get_keepalive_timeout () = !keepalive_timeout -let get_keepopen_timeout () = !keepopen_timeout *) let get_netbuffersize () = !netbuffersize let get_filebuffersize () = !filebuffersize let get_maxuploadfilesize () = !maxuploadfilesize @@ -174,6 +144,3 @@ let display_version () = print_string version_number; print_newline (); exit 0 - -let init_preempt = - _PREEMTIMPLEM_.init diff --git a/src/baselib/ocsigen_config.mli b/src/baselib/ocsigen_config.mli index f28b8f82e..d12563ec2 100644 --- a/src/baselib/ocsigen_config.mli +++ b/src/baselib/ocsigen_config.mli @@ -38,7 +38,6 @@ val set_mimefile : string -> unit val set_verbose : unit -> unit val set_silent : unit -> unit val set_daemon : unit -> unit -val set_veryverbose : unit -> unit val set_minthreads : int -> unit val set_maxthreads : int -> unit val set_max_number_of_threads_queued : int -> unit @@ -75,7 +74,6 @@ val get_mimefile : unit -> string val get_verbose : unit -> bool val get_silent : unit -> bool val get_daemon : unit -> bool -val get_veryverbose : unit -> bool val get_default_user : unit -> string val get_default_group : unit -> string val get_minthreads : unit -> int diff --git a/src/baselib/ocsigen_config_static.ml.in b/src/baselib/ocsigen_config_static.ml.in new file mode 100644 index 000000000..e1e98c556 --- /dev/null +++ b/src/baselib/ocsigen_config_static.ml.in @@ -0,0 +1,42 @@ +(* Warning! ocsigen_config_static.ml is generated automatically from + ocsigen_config_static.ml.in! Do not modify it manually *) +(* Ocsigen + * Copyright (C) 2005 Vincent Balat + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser 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 version_number = "_VERSION_" +let config_file = ref "_CONFIGDIR_/_PROJECTNAME_.conf" +let is_native = _ISNATIVE_ +let logdir = ref (Some "_LOGDIR_") +let default_user = ref "_OCSIGENUSER_" +let default_group = ref "_OCSIGENGROUP_" +let mimefile = ref "_CONFIGDIR_/mime.types" +let datadir = ref "_DATADIR_" +let bindir = ref "_BINDIR_" +let extdir = ref "_EXTDIR_" +let command_pipe = ref "_COMMANDPIPE_" +let set_max_number_of_threads_queued = + _PREEMTIMPLEM_.set_max_number_of_threads_queued +let get_max_number_of_threads_queued = + _PREEMTIMPLEM_.get_max_number_of_threads_queued +let builtin_packages = + List.fold_left + (fun a s -> Ocsigen_lib.String.Set.add s a) + Ocsigen_lib.String.Set.empty + [_DEPS_] +let init_preempt = + _PREEMTIMPLEM_.init diff --git a/src/extensions/.depend b/src/extensions/.depend index 4b2f26891..1ed8798b1 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -21,31 +21,30 @@ cgimod.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../baselib/ocsigen_config.cmx cors.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ - ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi -cors.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ - ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx -deflatemod.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ + ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ ../server/ocsigen_extensions.cmi -deflatemod.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ +cors.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ + ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ ../server/ocsigen_extensions.cmx +deflatemod.cmo : ../baselib/ocsigen_stream.cmi \ + ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ + ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi +deflatemod.cmx : ../baselib/ocsigen_stream.cmx \ + ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ + ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ - ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ - ../baselib/ocsigen_config.cmi ../http/ocsigen_charset_mime.cmi + ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi \ + ../http/ocsigen_cookies.cmi ../baselib/ocsigen_config.cmi \ + ../http/ocsigen_charset_mime.cmi extendconfiguration.cmx : ../server/ocsigen_parseconfig.cmx \ - ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ - ../baselib/ocsigen_config.cmx ../http/ocsigen_charset_mime.cmx -ocsigen_comet.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ - ../server/ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi \ - ocsigen_comet.cmi -ocsigen_comet.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ - ../server/ocsigen_extensions.cmx ../baselib/ocsigen_config.cmx \ - ocsigen_comet.cmi -ocsigen_comet.cmi : ../baselib/ocsigen_stream.cmi + ../baselib/ocsigen_lib.cmx ../server/ocsigen_extensions.cmx \ + ../http/ocsigen_cookies.cmx ../baselib/ocsigen_config.cmx \ + ../http/ocsigen_charset_mime.cmx ocsipersist.cmi : -outputfilter.cmo : ../server/ocsigen_response.cmi ../http/ocsigen_header.cmi \ - ../server/ocsigen_extensions.cmi -outputfilter.cmx : ../server/ocsigen_response.cmx ../http/ocsigen_header.cmx \ - ../server/ocsigen_extensions.cmx +outputfilter.cmo : ../server/ocsigen_response.cmi ../baselib/ocsigen_lib.cmi \ + ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi +outputfilter.cmx : ../server/ocsigen_response.cmx ../baselib/ocsigen_lib.cmx \ + ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx redirectmod.cmo : ../server/ocsigen_response.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi redirectmod.cmx : ../server/ocsigen_response.cmx ../baselib/ocsigen_lib.cmx \ @@ -56,9 +55,9 @@ revproxy.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ revproxy.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ ../server/ocsigen_extensions.cmx -rewritemod.cmo : ../server/ocsigen_request.cmi \ +rewritemod.cmo : ../server/ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi -rewritemod.cmx : ../server/ocsigen_request.cmx \ +rewritemod.cmx : ../server/ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx staticmod.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ ../server/ocsigen_local_files.cmi ../baselib/ocsigen_lib.cmi \ @@ -66,7 +65,7 @@ staticmod.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ staticmod.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ ../server/ocsigen_local_files.cmx ../baselib/ocsigen_lib.cmx \ ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx -userconf.cmo : ../server/ocsigen_request.cmi \ +userconf.cmo : ../server/ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi -userconf.cmx : ../server/ocsigen_request.cmx \ +userconf.cmx : ../server/ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx diff --git a/src/files/ocsigenserver.1 b/src/files/ocsigenserver.1 index eaa14dbba..0d5235096 100644 --- a/src/files/ocsigenserver.1 +++ b/src/files/ocsigenserver.1 @@ -35,9 +35,6 @@ Silent mode (error messages go in errors.log only). .BR \-v ,\ \-\-verbose Verbose mode. .TP -.B \-V ,\ \-\-veryverbose -Very verbose mode (debug). -.TP .B \-\-version Show version of program. .SH SEE ALSO diff --git a/src/server/.depend b/src/server/.depend index 7bc9e7f51..d418b4b7c 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -23,9 +23,9 @@ ocsigen_extensions.cmi : ocsigen_response.cmi ocsigen_request.cmi \ ocsigen_multipart.cmi ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_cookies.cmi ocsigen_command.cmi \ ../http/ocsigen_charset_mime.cmi -ocsigen_local_files.cmo : ocsigen_extensions.cmi \ +ocsigen_local_files.cmo : ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi ocsigen_local_files.cmi -ocsigen_local_files.cmx : ocsigen_extensions.cmx \ +ocsigen_local_files.cmx : ../baselib/ocsigen_lib.cmx ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ocsigen_local_files.cmi ocsigen_local_files.cmi : ocsigen_extensions.cmi ocsigen_multipart.cmo : ../baselib/ocsigen_stream.cmi \ From aa9d2716a32b48c1390fa86addc55ff6be004ac9 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 3 May 2017 16:20:25 +0200 Subject: [PATCH 067/111] Remove experimental report from Ocsigen_messages --- src/baselib/ocsigen_messages.ml | 187 -------------------------------- 1 file changed, 187 deletions(-) diff --git a/src/baselib/ocsigen_messages.ml b/src/baselib/ocsigen_messages.ml index 69185ef83..ff5395e8d 100644 --- a/src/baselib/ocsigen_messages.ml +++ b/src/baselib/ocsigen_messages.ml @@ -153,190 +153,3 @@ let command_f exc _ = function | Some l -> Lwt_log.Section.set_level sect l); Lwt.return () | _ -> Lwt.fail exc - - -(* - -Re: [Caml-list] log function without evaluate arguments -From: tmp123 -To: caml-list@inria.fr -Date: Nov 7 2007, 10:37 am - -Hello, - -Thanks a lot to everybody for your help. - -I've been testing the different proposals. I must recognize I've not yet -reviewed the proposed library, it is next step. - -The four methods tested are: lazy, fun, ifprint, and fun moving the "if" -to the caller (see full listing and results at the end of the post). Two -test has been done for each one: when parameter is an integer constant -and when parameter is the result of a funcion call who mades an addition. - -The conclusion seems: defining that "lazy" method needs 1 unit of time, -proposal using "fun" instead of lazy needs 0.8, and the version -"ifprintf" needs 16. Proposal moving the "if" needs 0.7. - -Thus, if no error has been done, fun is the fastest option, lazy is near. - -Another point is the posibility of, using a camlp4 syntax extension, to -introduce a few of sugar. Something like expand: - -from: log "some=%d\n" 14; -to: logint ( fun () -> Printf.printf "some=%d\n" 14); -or to: if log_active.val then logint ( fun() -> Printf.printf -"some=%d\n" 14) else (); - -Thanks again to everybody. - -Full listing and results: - -value log_active = ref False; - -value log1 exp = - if log_active.val - then - Lazy.force exp - else (); - -value log2 exp = - if log_active.val - then - exp() - else (); - -value log3 fmt = - if log_active.val - then - Printf.printf fmt - else - Printf.ifprintf stderr fmt; - -value log4 exp = exp (); - - - - -value suma a b = -( - a+b; -); - -value some = ref 14; - -value test1 () = - log1 (lazy (Printf.printf "%d" (suma some.val 3))); - -value test2 () = - log2 ( fun () -> Printf.printf "%d" (suma some.val 3)); - -value test3 () = - log3 "%d" (suma some.val 3); - -value test4 () = - if log_active.val then log4 ( fun () -> Printf.printf "%d" (suma -some.val 3)) - else (); - -value testb1 () = - log1 (lazy (Printf.printf "%d" 3)); - -value testb2 () = - log2 ( fun () -> Printf.printf "%d" 3); - -value testb3 () = - log3 "%d" 3; - -value testb4 () = - if log_active.val then log4 ( fun () -> Printf.printf "%d" 3) - else (); - - - - -value loop f = -( - let t=Unix.times() in - Printf.printf "%f %f %f\n" (Unix.gettimeofday()) - t.Unix.tms_utime t.Unix.tms_stime; - - for i = 0 to 1000 do - for j = 0 to 1000000 do - f (); - done; - done; - - let t=Unix.times() in - Printf.printf "%f %f %f\n" (Unix.gettimeofday()) - t.Unix.tms_utime t.Unix.tms_stime; -); - -value main () = -( - Printf.printf "test1\n"; - loop test1; - - Printf.printf "test2\n"; - loop test2; - - Printf.printf "test3\n"; - loop test3; - - Printf.printf "test4\n"; - loop test4; - - Printf.printf "\n"; - - Printf.printf "testb1\n"; - loop testb1; - - Printf.printf "testb2\n"; - loop testb2; - - Printf.printf "testb3\n"; - loop testb3; - - Printf.printf "testb4\n"; - loop testb4; - -); - -main(); - - -Results: - -test1 -1194426404.657406 0.015000 0.000000 -1194426414.136406 9.453000 0.000000 -test2 -1194426414.137406 9.468000 0.000000 -1194426422.147406 17.453000 0.000000 -test3 -1194426422.147406 17.453000 0.000000 -1194426593.308406 188.515000 0.000000 -test4 -1194426593.308406 188.515000 0.000000 -1194426599.964406 195.156000 0.000000 - -testb1 -1194426599.964406 195.156000 0.000000 -1194426609.408406 204.609000 0.000000 -testb2 -1194426609.408406 204.609000 0.000000 -1194426617.378406 212.578000 0.000000 -testb3 -1194426617.378406 212.578000 0.000000 -1194426790.412406 385.484000 0.000000 -testb4 -1194426790.412406 385.484000 0.000000 -1194426797.060406 392.125000 0.000000 - - -------------- - -_______________________________________________ -Caml-list mailing list. - -*) From 6f85d93ef606cc343a933de94539319a984e392b Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 9 May 2017 14:55:17 +0200 Subject: [PATCH 068/111] Ocsigen_server.start_server -> start Now accepts configuration as argument. --- src/server/ocsigen_server.ml | 6 +++--- src/server/ocsigen_server.mli | 13 ++++++------- src/server/server_main.ml | 3 +-- 3 files changed, 10 insertions(+), 12 deletions(-) diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index bb42b1a38..a1ae17dc0 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -144,14 +144,14 @@ let _ = in Ocsigen_command.register_command_function f -let start_server () = try +let start config_servers = + + try (* initialization functions for modules (Ocsigen extensions or application code) loaded from now on will be executed directly. *) Ocsigen_loader.set_init_on_load true; - let config_servers = Ocsigen_parseconfig.parse_config () in - let number_of_servers = List.length config_servers in if number_of_servers > 1 diff --git a/src/server/ocsigen_server.mli b/src/server/ocsigen_server.mli index 48a9dee32..6eafb82c9 100644 --- a/src/server/ocsigen_server.mli +++ b/src/server/ocsigen_server.mli @@ -18,11 +18,10 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** Reload the configuration of the server. - The optional parameter [?file] may be use to read the configuration - from another file. -*) -val reload: ?file:string -> unit -> unit +(** Reload the configuration of the server. The optional parameter + [?file] may be used to read the configuration from another + file. *) +val reload : ?file:string -> unit -> unit -(** Start the server (does not return) *) -val start_server: unit -> unit +(** Start the server. Never returns. *) +val start : Xml.xml list list -> unit diff --git a/src/server/server_main.ml b/src/server/server_main.ml index ce8fd0ee3..718c2ae39 100644 --- a/src/server/server_main.ml +++ b/src/server/server_main.ml @@ -1,2 +1 @@ -let () = - Ocsigen_server.start_server () +let () = Ocsigen_server.start (Ocsigen_parseconfig.parse_config ()) From bfa5bb6d2e9b629f52dee68e83d94a67c5cff2cb Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 11 May 2017 16:50:17 +0200 Subject: [PATCH 069/111] Ocsigen_config, Ocsigen_parseconfig, Ocsigen_server restructuring - Ocsigen_parseconfig.extract_info -> first_pass - Ocsigen_parseconfig.parse_server -> later_pass first_pass sets Ocsigen_config state instead of returning values, which are read by Ocsigen_server when needed. Ocsigen_server.start can launch without a configuration file. Depends on proper values in Ocsigen_config. --- src/baselib/ocsigen_config.ml | 59 +++++++++++-- src/baselib/ocsigen_config.mli | 32 ++++++- src/server/ocsigen_cohttp.ml | 4 +- src/server/ocsigen_cohttp.mli | 2 +- src/server/ocsigen_parseconfig.ml | 83 ++++++++---------- src/server/ocsigen_parseconfig.mli | 68 ++++----------- src/server/ocsigen_server.ml | 135 +++++++++++++---------------- src/server/ocsigen_server.mli | 4 +- src/server/ocsigen_socket.ml | 21 +---- src/server/ocsigen_socket.mli | 19 +--- src/server/server_main.ml | 5 +- 11 files changed, 211 insertions(+), 221 deletions(-) diff --git a/src/baselib/ocsigen_config.ml b/src/baselib/ocsigen_config.ml index 7f9d88576..03e3a8694 100644 --- a/src/baselib/ocsigen_config.ml +++ b/src/baselib/ocsigen_config.ml @@ -20,6 +20,36 @@ include Ocsigen_config_static exception Config_file_error of string +type ssl_info = { + ssl_certificate : string option ; + ssl_privatekey : string option ; + ssl_ciphers : string option ; + ssl_dhfile : string option ; + ssl_curve : string option +} + +module Socket_type = struct + + type t = [ + | `All + | `IPv4 of Unix.inet_addr + | `IPv6 of Unix.inet_addr + ] + + let to_string = function + | `All -> Unix.string_of_inet_addr Unix.inet_addr_any + | `IPv4 u -> Unix.string_of_inet_addr u + | `IPv6 u -> Unix.string_of_inet_addr u + + let to_inet_addr = function + | `All -> Unix.inet_addr_any + | `IPv4 u -> u + | `IPv6 u -> u + +end + +type socket_type = Socket_type.t + (* General config *) let verbose = ref false let silent = ref false @@ -56,10 +86,11 @@ let debugmode = ref false let disablepartialrequests = ref false let usedefaulthostname = ref false let respectpipeline = ref false -let default_port = ref 80 -let default_sslport = ref 443 let maxretries = ref 10 let shutdowntimeout = ref (Some 10.) +let ssl_info = ref None +let ports = ref [] +let ssl_ports = ref [] let set_uploaddir u = uploaddir := u let set_logdir s = logdir := Some s @@ -94,10 +125,11 @@ let set_debugmode s = debugmode := s let set_disablepartialrequests s = disablepartialrequests := s let set_usedefaulthostname s = usedefaulthostname := s let set_respect_pipeline () = respectpipeline := true -let set_default_port p = default_port := p -let set_default_sslport p = default_sslport := p let set_maxretries i = maxretries := i let set_shutdown_timeout s = shutdowntimeout := s +let set_ssl_info i = ssl_info := i +let set_ports l = ports := l +let set_ssl_ports l = ssl_ports := l let get_uploaddir () = !uploaddir let get_logdir () = @@ -135,10 +167,25 @@ let get_debugmode () = !debugmode let get_disablepartialrequests () = !disablepartialrequests let get_usedefaulthostname () = !usedefaulthostname let get_respect_pipeline () = !respectpipeline -let get_default_port () = !default_port -let get_default_sslport () = !default_sslport let get_maxretries () = !maxretries let get_shutdown_timeout () = !shutdowntimeout +let get_ssl_info () = !ssl_info +let get_ports () = !ports +let get_ssl_ports () = !ssl_ports + +let get_default_port () = + match !ports with + | (_, p) :: _ -> + p + | [] -> + 80 + +let get_default_sslport () = + match !ssl_ports with + | (_, p) :: _ -> + p + | [] -> + 443 let display_version () = print_string version_number; diff --git a/src/baselib/ocsigen_config.mli b/src/baselib/ocsigen_config.mli index d12563ec2..3b9a3a6cd 100644 --- a/src/baselib/ocsigen_config.mli +++ b/src/baselib/ocsigen_config.mli @@ -20,6 +20,30 @@ open Ocsigen_lib +type ssl_info = { + ssl_certificate : string option ; + ssl_privatekey : string option ; + ssl_ciphers : string option ; + ssl_dhfile : string option ; + ssl_curve : string option +} + +module Socket_type : sig + + type t = [ + | `All + | `IPv4 of Unix.inet_addr + | `IPv6 of Unix.inet_addr + ] + + val to_string : t -> string + + val to_inet_addr : t -> Unix.inet_addr + +end + +type socket_type = Socket_type.t + exception Config_file_error of string val server_name : string @@ -61,10 +85,11 @@ val set_debugmode : bool -> unit val set_disablepartialrequests : bool -> unit val set_usedefaulthostname : bool -> unit val set_respect_pipeline : unit -> unit -val set_default_port : int -> unit -val set_default_sslport : int -> unit val set_maxretries : int -> unit val set_shutdown_timeout : float option -> unit +val set_ssl_info : ssl_info option -> unit +val set_ports : (socket_type * int) list -> unit +val set_ssl_ports : (socket_type * int) list -> unit val get_logdir : unit -> string val get_syslog_facility: unit -> Lwt_log.syslog_facility option @@ -103,6 +128,9 @@ val get_default_port : unit -> int val get_default_sslport : unit -> int val get_maxretries : unit -> int val get_shutdown_timeout : unit -> float option +val get_ssl_info : unit -> ssl_info option +val get_ports : unit -> (socket_type * int) list +val get_ssl_ports : unit -> (socket_type * int) list val display_version : unit -> 'a diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index b94d15372..a3b426c6b 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -242,12 +242,12 @@ let service ?ssl ~address ~port ~connector () = in (* We create a specific context for Conduit and Cohttp. *) Conduit_lwt_unix.init - ~src:(Ocsigen_socket.string_of_socket_type address) + ~src:(Ocsigen_config.Socket_type.to_string address) ~tls_server_key () >>= fun conduit_ctx -> Lwt.return (Cohttp_lwt_unix_net.init ~ctx:conduit_ctx ()) >>= fun ctx -> (* We catch the INET_ADDR of the server *) let callback = - let address = Ocsigen_socket.to_inet_addr address + let address = Ocsigen_config.Socket_type.to_inet_addr address and ssl = match ssl with Some _ -> true | None -> false in handler ~ssl ~address ~port ~connector in diff --git a/src/server/ocsigen_cohttp.mli b/src/server/ocsigen_cohttp.mli index 994623e05..f46cd9055 100644 --- a/src/server/ocsigen_cohttp.mli +++ b/src/server/ocsigen_cohttp.mli @@ -22,7 +22,7 @@ val shutdown : float option -> unit (** initialize a main loop of http server *) val service : ?ssl:string * string * (bool -> string) option -> - address:Ocsigen_socket.socket_type -> + address:Ocsigen_config.socket_type -> port:int -> connector:(Ocsigen_request.t -> Ocsigen_response.t Lwt.t) -> unit -> diff --git a/src/server/ocsigen_parseconfig.ml b/src/server/ocsigen_parseconfig.ml index c21f6b884..595111de1 100644 --- a/src/server/ocsigen_parseconfig.ml +++ b/src/server/ocsigen_parseconfig.ml @@ -38,14 +38,6 @@ let blah_of_string f tag s = let int_of_string = blah_of_string int_of_string let float_of_string = blah_of_string float_of_string -type ssl_info = { - ssl_certificate : string option; - ssl_privatekey : string option; - ssl_ciphers : string option; - ssl_dhfile : string option; - ssl_curve : string option -} - (*****************************************************************************) let default_default_hostname = let hostname = Unix.gethostname () in @@ -211,7 +203,6 @@ let parse_ext file = let preloadfile config () = Ocsigen_extensions.set_config config let postloadfile () = Ocsigen_extensions.set_config [] - (* Checking hostnames. We make only make looze efforts. See RFC 921 and 952 for further details *) let correct_hostname = @@ -295,7 +286,7 @@ let get_defaulthostname ~defaulthostname ~defaulthttpport ~host = (* Config file is parsed twice. This is the second parsing (site loading) *) -let parse_server isreloading c = +let later_pass c = let rec parse_server_aux = function | [] -> [] | (Element ("port", atts, p))::ll -> @@ -320,10 +311,8 @@ let parse_server isreloading c = set_datadir (parse_string_tag st p); parse_server_aux ll | (Element ("minthreads" as st, [], p))::ll -> - set_minthreads (int_of_string st (parse_string_tag st p)); parse_server_aux ll | (Element ("maxthreads" as st, [], p))::ll -> - set_maxthreads (int_of_string st (parse_string_tag st p)); parse_server_aux ll | (Element ("maxdetachedcomputationsqueued" as st, [], p))::ll -> set_max_number_of_threads_queued (int_of_string st (parse_string_tag st p)); @@ -605,22 +594,22 @@ let parse_port = let get x i = Netstring_pcre.matched_group x i s in match do_match all_ipv6 with | Some r -> - Ocsigen_socket.IPv6 (Unix.inet6_addr_any), + `IPv6 (Unix.inet6_addr_any), int_of_string "port" (get r 1) | None -> match do_match all_ipv4 with | Some r -> - Ocsigen_socket.IPv4 (Unix.inet_addr_any), + `IPv4 (Unix.inet_addr_any), int_of_string "port" (get r 1) | None -> match do_match single_ipv6 with | Some r -> - Ocsigen_socket.IPv6 (Unix.inet_addr_of_string (get r 1)), + `IPv6 (Unix.inet_addr_of_string (get r 1)), int_of_string "port" (get r 2) | None -> match do_match single_ipv4 with | Some r -> - Ocsigen_socket.IPv4 (Unix.inet_addr_of_string (get r 1)), + `IPv4 (Unix.inet_addr_of_string (get r 1)), int_of_string "port" (get r 2) | None -> - Ocsigen_socket.All, + `All, int_of_string "port" s let parse_facility = function @@ -656,6 +645,7 @@ let config_error_for_some s = function | _ -> raise (Config_file_error s) let make_ssl_info ~certificate ~privatekey ~ciphers ~dhfile ~curve = { + Ocsigen_config. ssl_certificate = certificate; ssl_privatekey = privatekey; ssl_ciphers = ciphers; @@ -692,39 +682,41 @@ let rec parse_ssl l ~certificate ~privatekey ~ciphers ~dhfile ~curve = | _ -> raise (Config_file_error ("Unexpected content inside ")) -let extract_info c = - let rec aux user group ssl ports sslports minthreads maxthreads = function - [] -> ((user, group), (ssl, ports,sslports), (minthreads, maxthreads)) +let first_pass c = + let rec aux user group ssl ports sslports = function + [] -> ((user, group), (ssl, ports, sslports)) | (Element ("logdir" as st, [], p))::ll -> set_logdir (parse_string_tag st p); - aux user group ssl ports sslports minthreads maxthreads ll + aux user group ssl ports sslports ll | (Element ("syslog" as st, [], p))::ll -> let str = String.lowercase (parse_string_tag st p) in set_syslog_facility (Some (parse_facility str)); - aux user group ssl ports sslports minthreads maxthreads ll + aux user group ssl ports sslports ll | (Element ("port" as st, atts, p))::ll -> (match atts with [] | [("protocol", "HTTP")] -> - let po = try + let po = + try parse_port (parse_string_tag st p) with Failure _ -> raise (Config_file_error "Wrong value for tag") - in aux user group ssl (po::ports) sslports minthreads maxthreads ll + in + aux user group ssl (po::ports) sslports ll | [("protocol", "HTTPS")] -> let po = try parse_port (parse_string_tag st p) with Failure _ -> raise (Config_file_error "Wrong value for tag") in - aux user group ssl ports (po::sslports) minthreads maxthreads ll + aux user group ssl ports (po::sslports) ll | _ -> raise (Config_file_error "Wrong attribute for ")) | (Element ("minthreads" as st, [], p))::ll -> - aux user group ssl ports sslports - (Some (int_of_string st (parse_string_tag st p))) maxthreads ll + set_minthreads (int_of_string st (parse_string_tag st p)); + aux user group ssl ports sslports ll | (Element ("maxthreads" as st, [], p))::ll -> - aux user group ssl ports sslports minthreads - (Some (int_of_string st (parse_string_tag st p))) ll + set_maxthreads (int_of_string st (parse_string_tag st p)); + aux user group ssl ports sslports ll | (Element ("ssl", [], p))::ll -> (match ssl with None -> @@ -736,7 +728,7 @@ let extract_info c = and curve = None in parse_ssl ~certificate ~privatekey ~ciphers ~dhfile ~curve p in - aux user group ssl ports sslports minthreads maxthreads ll + aux user group ssl ports sslports ll | _ -> raise (Config_file_error @@ -744,26 +736,26 @@ let extract_info c = | (Element ("user" as st, [], p))::ll -> (match user with None -> - aux (Some (parse_string_tag st p)) group ssl ports sslports - minthreads maxthreads ll + aux (Some (parse_string_tag st p)) group ssl ports sslports ll | _ -> raise (Config_file_error "Only one tag for each server allowed")) | (Element ("group" as st, [], p))::ll -> (match group with None -> - aux user (Some (parse_string_tag st p)) ssl ports sslports - minthreads maxthreads ll + aux user (Some (parse_string_tag st p)) ssl ports sslports ll | _ -> raise (Config_file_error "Only one tag for each server allowed")) | (Element ("commandpipe" as st, [], p))::ll -> set_command_pipe (parse_string_tag st p); - aux user group ssl ports sslports minthreads maxthreads ll + aux user group ssl ports sslports ll | (Element (tag, _, _))::ll -> - aux user group ssl ports sslports minthreads maxthreads ll + aux user group ssl ports sslports ll | _ -> raise (Config_file_error "Syntax error") in - let (user, group), si, (mint, maxt) = aux None None None [] [] None None c in + let (user, group), (si, ports, ssl_ports) = + aux None None None [] [] c + in let user = match user with None -> None (* Some (get_default_user ()) *) | Some s -> if s = "" then None else Some s @@ -772,15 +764,12 @@ let extract_info c = None -> None (* Some (get_default_group ()) *) | Some s -> if s = "" then None else Some s in - let mint = match mint with - | Some t -> t - | None -> get_minthreads () - in - let maxt = match maxt with - | Some t -> t - | None -> get_maxthreads () - in - ((user, group), si, (mint, maxt)) + Ocsigen_config.set_user user; + Ocsigen_config.set_group group; + Ocsigen_config.set_ssl_info si; + Ocsigen_config.set_ports ports; + Ocsigen_config.set_ssl_ports ssl_ports; + () let parse_config ?file () = let file = @@ -789,5 +778,3 @@ let parse_config ?file () = | Some f -> f in parser_config (Xml.parse_file file) - -(******************************************************************) diff --git a/src/server/ocsigen_parseconfig.mli b/src/server/ocsigen_parseconfig.mli index 2deac3fba..ca73b7ecf 100644 --- a/src/server/ocsigen_parseconfig.mli +++ b/src/server/ocsigen_parseconfig.mli @@ -18,68 +18,36 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** Config file parsing. - See also module {! Ocsigen_extensions.​Configuration } *) - -(** Parse a size ("infinity" or using SI or binary units, - e.g. 10 10B 10o 10ko 10kB 10kiB 10MiB 10TB ...). - Raises [Failure "Ocsigen_parseconfig.parse_size"] in case of error. -*) -val parse_size : string -> int64 option - -(** [parse_size_tag tag s] parses a size (same syntax as [parse_size]). - In case of error, raises [Ocsigen_config.Config_file_error m] where [m] - is an error message explaining that a size was expected in tag []. -*) -val parse_size_tag : string -> string -> int64 option - -(** Parse a string (PCDATA) as XML content. - Raises [Failure "Ocsigen_parseconfig.parse_string"] in case of error. -*) -val parse_string : Xml.xml list -> string - -(** [parse_string_tag tag s] parses a string (same syntax as [parse_string]). - In case of error, raises [Ocsigen_config.Config_file_error m] where [m] - is an error message explaining that a string was expected in tag []. -*) -val parse_string_tag : string -> Xml.xml list -> string - - -(** Parses the [hostfilter] field of the configuration file, which - is a disjunction of possible hostnames (that can themselves contain - wildcards) *) -val parse_host_field: string option -> Ocsigen_extensions.virtual_hosts +(** Config file parsing. See also module + {! Ocsigen_extensions.​Configuration } *) (**/**) -val parse_server : bool -> Xml.xml list -> unit +(** [parse_size_tag tag s] parses a size. -type ssl_info = { - ssl_certificate : string option; - ssl_privatekey : string option; - ssl_ciphers : string option; - ssl_dhfile : string option; - ssl_curve : string option -} + The size can be either "infinity" or use SI or binary units, e.g., + 10 10B 10o 10ko 10kB 10kiB 10MiB 10TB ... . -(** First pass of parse XML file. Extracts this informations: + In case of error, raises [Ocsigen_config.Config_file_error m] + where [m] is an error message explaining that a size was expected + in tag []. *) +val parse_size_tag : string -> string -> int64 option + +(** Extracts (and stores via Ocsigen_config) the following information: {ul {- user to execute OcsigenServer (ex: www-data) } {- group to execute OcsigenServer (ex: www-data) } {- SSL key, SSL certificate, SSL ciphers list, SSL DH file, SSL EC curve } - {- list of HTTP port to listen (ex: 80) } - {- list of HTTPS port to listen (ex: 443) } - {- minimum and maximum of threads } + {- list of HTTP port to listen on (ex: 80) } + {- list of HTTPS port to listen on (ex: 443) } + {- minimum and maximum number of threads } } + To be called early by [Ocsigen_server]. *) -val extract_info : - Xml.xml list -> - (string option * string option) * - (ssl_info option * - (Ocsigen_socket.socket_type * int) list * - (Ocsigen_socket.socket_type * int) list) * - (int * int) +val first_pass : Xml.xml list -> unit + +val later_pass : Xml.xml list -> unit val parse_config : ?file:string -> diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index a1ae17dc0..2f3755c06 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -94,7 +94,7 @@ let reload_conf s = try Ocsigen_extensions.start_initialisation (); - Ocsigen_parseconfig.parse_server true s; + Ocsigen_parseconfig.later_pass s; Ocsigen_extensions.end_initialisation (); with e -> @@ -144,7 +144,7 @@ let _ = in Ocsigen_command.register_command_function f -let start config_servers = +let start ?config () = try @@ -152,10 +152,11 @@ let start config_servers = code) loaded from now on will be executed directly. *) Ocsigen_loader.set_init_on_load true; - let number_of_servers = List.length config_servers in - - if number_of_servers > 1 - then Lwt_log.ign_warning ~section "Multiple servers not supported anymore"; + (match config with + | Some (_ :: _ :: _) -> + Lwt_log.ign_warning ~section "Multiple servers not supported anymore" + | _ -> + ()); let ask_for_passwd sslports _ = print_string "Please enter the password for the HTTPS server listening \ @@ -181,57 +182,48 @@ let start config_servers = let extensions_connector = Ocsigen_extensions.compute_result in - let run (user, group) (ssl, ports, sslports) (minthreads, maxthreads) s = + let run s = + + let user = Ocsigen_config.get_user () + and group = Ocsigen_config.get_group () in Ocsigen_messages.open_files ~user ~group () >>= fun () -> - (*let wait_end_init, wait_end_init_awakener = wait () in *) - (* Listening on all ports: *) - (* - sockets := List.fold_left - (fun a i -> (listen false i wait_end_init extensions_connector)@a) [] ports; - sslsockets := List.fold_left - (fun a i -> (listen true i wait_end_init extensions_connector)@a) [] sslports; - *) - - let connection = match ports with - | [] -> [(Ocsigen_socket.All, 80)] + let ports = Ocsigen_config.get_ports () + and ssl_ports = Ocsigen_config.get_ssl_ports () in + + let connection = + match ports with + | [] -> [`All, 80] | l -> l in let ssl_connection = - let ssl = match ssl with + let ssl = + match Ocsigen_config.get_ssl_info () with | None | Some { - Ocsigen_parseconfig.ssl_certificate = None ; - Ocsigen_parseconfig.ssl_privatekey = None + Ocsigen_config.ssl_certificate = None ; + Ocsigen_config.ssl_privatekey = None } -> None | Some { - Ocsigen_parseconfig.ssl_certificate = Some crt ; - Ocsigen_parseconfig.ssl_privatekey = Some key + Ocsigen_config.ssl_certificate = Some crt ; + Ocsigen_config.ssl_privatekey = Some key } -> Some (crt, key) - | Some { Ocsigen_parseconfig.ssl_privatekey = None } -> + | Some { Ocsigen_config.ssl_privatekey = None } -> raise (Ocsigen_config.Config_file_error "SSL key is missing") - | Some { Ocsigen_parseconfig.ssl_certificate = None } -> + | Some { Ocsigen_config.ssl_certificate = None } -> raise (Ocsigen_config.Config_file_error "SSL certificate is missing") - in match sslports, ssl with - | [], Some (crt, key) -> [(Ocsigen_socket.All, 443, (crt, key))] + in + match ssl_ports, ssl with + | [], Some (crt, key) -> [`All, 443, (crt, key)] | l, Some (crt, key) -> List.map (fun (a, p) -> (a, p, (crt, key))) l | _ -> [] in - begin match ports with - | (_, p)::_ -> Ocsigen_config.set_default_port p - | _ -> () - end; - begin match sslports with - | (_, p)::_ -> Ocsigen_config.set_default_sslport p - | _ -> () - end; - let current_uid = Unix.getuid () in let gid = match group with @@ -282,25 +274,17 @@ let start config_servers = raise e end; - Ocsigen_config.set_user user; - Ocsigen_config.set_group group; - - (* Je suis fou : - let rec f () = - print_endline "-"; - Lwt_unix.yield () >>= f - in f (); *) - - if maxthreads < minthreads - then + let minthreads = Ocsigen_config.get_minthreads () + and maxthreads = Ocsigen_config.get_maxthreads () in + if minthreads > maxthreads then raise (Ocsigen_config.Config_file_error "maxthreads should be greater than minthreads"); - ignore (Ocsigen_config.init_preempt - minthreads - maxthreads - (fun s -> Lwt_log.ign_error ~section s)); + ignore + (Ocsigen_config.init_preempt + minthreads maxthreads + (fun s -> Lwt_log.ign_error ~section s)); (* Now I can load the modules *) Dynlink_wrapper.init (); @@ -308,7 +292,7 @@ let start config_servers = Ocsigen_extensions.start_initialisation (); - Ocsigen_parseconfig.parse_server false s; + Ocsigen_lib.Option.iter Ocsigen_parseconfig.later_pass s; Dynlink_wrapper.prohibit ["Ocsigen_extensions.R"]; (* As libraries are reloaded each time the config file is read, @@ -419,32 +403,35 @@ let start config_servers = Unix.close f in - let rec launch = function - | [] -> () - | [h] -> - let user_info, sslinfo, threadinfo = - Ocsigen_parseconfig.extract_info h - in - (* set_passwd_if_needed sslinfo; *) - if Ocsigen_config.get_daemon () - then - let pid = Unix.fork () in - if pid = 0 - then - Lwt_main.run (run user_info sslinfo threadinfo h) - else begin - Ocsigen_messages.console - (fun () -> "Process "^(string_of_int pid)^" detached"); - write_pid pid - end + let launch h = + Ocsigen_lib.Option.iter Ocsigen_parseconfig.first_pass h; + (* set_passwd_if_needed sslinfo; *) + if Ocsigen_config.get_daemon () then + let pid = Unix.fork () in + if pid = 0 then + Lwt_main.run (run h) else begin - write_pid (Unix.getpid ()); - Lwt_main.run (run user_info sslinfo threadinfo h) + Ocsigen_messages.console + (fun () -> "Process " ^ string_of_int pid ^ " detached"); + write_pid pid end - | _ -> () (* Multiple servers not supported any more *) + else begin + write_pid (Unix.getpid ()); + Lwt_main.run (run h) + end + in + + let launch = function + | Some [] -> () + | Some [h] -> + launch (Some h) + | None -> + launch None + | Some (_ :: _ :: _) -> + () (* Multiple servers not supported any more *) in - launch config_servers + launch config with e -> let msg, errno = errmsg e in diff --git a/src/server/ocsigen_server.mli b/src/server/ocsigen_server.mli index 6eafb82c9..ccbde2cf5 100644 --- a/src/server/ocsigen_server.mli +++ b/src/server/ocsigen_server.mli @@ -21,7 +21,7 @@ (** Reload the configuration of the server. The optional parameter [?file] may be used to read the configuration from another file. *) -val reload : ?file:string -> unit -> unit +val reload : ?file : string -> unit -> unit (** Start the server. Never returns. *) -val start : Xml.xml list list -> unit +val start : ?config : Xml.xml list list -> unit -> unit diff --git a/src/server/ocsigen_socket.ml b/src/server/ocsigen_socket.ml index f8570f1ef..237e167de 100644 --- a/src/server/ocsigen_socket.ml +++ b/src/server/ocsigen_socket.ml @@ -1,8 +1,3 @@ -type socket_type = - | All - | IPv4 of Unix.inet_addr - | IPv6 of Unix.inet_addr - (** make_ipv6_socket create a socket on an ipv6 address * @param addr address of socket * @param port port of socket @@ -30,7 +25,7 @@ let make_ipv4_socket addr port = let make_sockets addr port = match addr with - | All -> + | `All -> (* The user didn't specify a protocol in the configuration file; we try to open an IPv6 socket (listening to IPv6 only) if possible and we open an IPv4 socket anyway. This @@ -46,9 +41,9 @@ let make_sockets addr port = ), _, _) -> [] in (make_ipv4_socket Unix.inet_addr_any port)::ipv6_socket - | IPv4 addr -> + | `IPv4 addr -> [make_ipv4_socket addr port] - | IPv6 addr -> + | `IPv6 addr -> [make_ipv6_socket addr port] @@ -59,13 +54,3 @@ let ip_of_sockaddr = function let port_of_sockaddr = function | Unix.ADDR_INET (ip, port) -> port | _ -> raise (Ocsigen_lib_base.Ocsigen_Internal_Error "port of unix socket") - -let string_of_socket_type = function - | All -> Unix.string_of_inet_addr Unix.inet_addr_any - | IPv4 u -> Unix.string_of_inet_addr u - | IPv6 u -> Unix.string_of_inet_addr u - -let to_inet_addr = function - | All -> Unix.inet_addr_any - | IPv4 u -> u - | IPv6 u -> u diff --git a/src/server/ocsigen_socket.mli b/src/server/ocsigen_socket.mli index 5c90b3008..fb4260d4c 100644 --- a/src/server/ocsigen_socket.mli +++ b/src/server/ocsigen_socket.mli @@ -1,16 +1,11 @@ (** Abstraction handling sockets IPv4 and IPv6 *) -(** type of address *) -type socket_type = - | All - | IPv4 of Unix.inet_addr - | IPv6 of Unix.inet_addr - (** make_sockets create socket ready to listen in addr:port @param addr type of addresss (All | IPv4 | IPv6) @param port port of socket *) -val make_sockets : socket_type -> int -> Lwt_unix.file_descr list +val make_sockets : + Ocsigen_config.socket_type -> int -> Lwt_unix.file_descr list (** ip_of_sockaddr accessor for ip @param A Unix.ADDR_INET value or raise error @@ -21,13 +16,3 @@ val ip_of_sockaddr : Unix.sockaddr -> Unix.inet_addr @param A Unix.ADDR_INET value or raise error *) val port_of_sockaddr : Unix.sockaddr -> int - -(** string_of_socket_type cast a Unix.inet_addr in socket_type to a string - @param A socket_type -*) -val string_of_socket_type : socket_type -> string - -(** to_inet_addr accessor of inet addr - @param A socket_type -*) -val to_inet_addr : socket_type -> Unix.inet_addr diff --git a/src/server/server_main.ml b/src/server/server_main.ml index 718c2ae39..9881e3691 100644 --- a/src/server/server_main.ml +++ b/src/server/server_main.ml @@ -1 +1,4 @@ -let () = Ocsigen_server.start (Ocsigen_parseconfig.parse_config ()) +let () = + Ocsigen_server.start + ~config:(Ocsigen_parseconfig.parse_config ()) + () From f6ba08f30c9c4999dc45d9c4a7f674afc57ef121 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 19 May 2017 12:59:34 +0200 Subject: [PATCH 070/111] Compile against Lwt 3.0.0 --- .merlin | 3 ++- Makefile.options | 2 +- configure | 2 +- opam | 2 +- src/extensions/Makefile | 2 +- src/extensions/ocsipersist-dbm/ocsidbm.ml | 9 ++++++--- src/files/META.in | 2 +- src/http/Makefile | 2 +- 8 files changed, 14 insertions(+), 10 deletions(-) diff --git a/.merlin b/.merlin index 1a05d2fe6..89c96081b 100644 --- a/.merlin +++ b/.merlin @@ -1,4 +1,5 @@ -PKG lwt lwt.ssl +PKG lwt +PKG lwt_ssl PKG findlib PKG react PKG pcre diff --git a/Makefile.options b/Makefile.options index 560746591..9ef04b8f5 100644 --- a/Makefile.options +++ b/Makefile.options @@ -30,7 +30,7 @@ endif BASE_PACKAGE := lwt ipaddr bytes -SERVER_PACKAGE := lwt.ssl \ +SERVER_PACKAGE := lwt_ssl \ bytes \ ${LWT_PREEMPTIVE_PACKAGE} \ ipaddr \ diff --git a/configure b/configure index 3234971ee..4d40b8bf7 100755 --- a/configure +++ b/configure @@ -412,7 +412,7 @@ check_library ssl "See: http://sourceforge.net/projects/savonet/files/ocaml-ssl" check_library lwt "See: http://ocsigen.org/lwt" check_library lwt.unix "Missing support for 'unix' in lwt." -check_library lwt.ssl "Missing support for 'ssl' in lwt." +check_library lwt_ssl "See: http://ocsigen.org/lwt" check_library lwt.preemptive "Missing support for 'preemptive' in lwt." check_library pcre "See: http://ocaml.info/home/ocaml_sources.html" diff --git a/opam b/opam index 8f466ea2c..a11d64462 100644 --- a/opam +++ b/opam @@ -48,7 +48,7 @@ depends: [ "base-threads" "react" "ssl" - "lwt" {>= "2.5.0" & < "3.0.0"} + "lwt" {>= "3.0.0"} "pcre" "cryptokit" "xml-light" diff --git a/src/extensions/Makefile b/src/extensions/Makefile index e7667d9c1..682a71b7f 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -4,7 +4,7 @@ PACKAGE := \ bytes \ lwt.unix \ ipaddr \ - lwt.ssl \ + lwt_ssl \ pcre \ xml-light \ cohttp.lwt diff --git a/src/extensions/ocsipersist-dbm/ocsidbm.ml b/src/extensions/ocsipersist-dbm/ocsidbm.ml index 3efb56b61..066b690c9 100644 --- a/src/extensions/ocsipersist-dbm/ocsidbm.ml +++ b/src/extensions/ocsipersist-dbm/ocsidbm.ml @@ -272,9 +272,12 @@ let rec loop socket = let _ = Lwt_main.run (let socket = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - (try - Lwt_unix.bind socket (Unix.ADDR_UNIX (directory^"/"^socketname)) - with _ -> errlog ("Please make sure that the directory "^directory^" exists, writable for ocsidbm, and no other ocsidbm process is running on the same directory. If not, remove the file "^(directory^"/"^socketname)); the_end 1); + Lwt.catch + (fun () -> + Lwt_unix.bind socket (Unix.ADDR_UNIX (directory^"/"^socketname))) + (fun exn -> + errlog ("Please make sure that the directory "^directory^" exists, writable for ocsidbm, and no other ocsidbm process is running on the same directory. If not, remove the file "^(directory^"/"^socketname)); + the_end 1) >>= fun () -> Lwt_unix.listen socket 20; (* Done in ocsipersist.ml let devnull = Unix.openfile "/dev/null" [Unix.O_WRONLY] 0 in diff --git a/src/files/META.in b/src/files/META.in index ef8586bef..33b5c1a87 100644 --- a/src/files/META.in +++ b/src/files/META.in @@ -37,7 +37,7 @@ package "baselib" ( ) package "http" ( - requires = "%%NAME%%.baselib,lwt.ssl" + requires = "%%NAME%%.baselib,lwt_ssl" version = "[distributed with Ocsigen server]" description = "HTTP library for Ocsigen server" archive(byte) = "http.cma" diff --git a/src/http/Makefile b/src/http/Makefile index b6df84be0..e06c61bbd 100644 --- a/src/http/Makefile +++ b/src/http/Makefile @@ -1,7 +1,7 @@ include ../../Makefile.config PACKAGE := \ bytes \ - lwt.ssl \ + lwt_ssl \ pcre \ cohttp From 54cac9b59932e872ca2fe766a31a276adb70f5a6 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 19 May 2017 13:58:22 +0200 Subject: [PATCH 071/111] Remove Ocsigen_socket --- src/baselib/ocsigen_lib.ml | 6 ++++ src/baselib/ocsigen_lib.mli | 1 + src/server/.depend | 59 +++++++++++++++++------------------ src/server/Makefile | 3 +- src/server/ocsigen_request.ml | 2 +- src/server/ocsigen_server.ml | 5 +-- src/server/ocsigen_socket.ml | 56 --------------------------------- src/server/ocsigen_socket.mli | 18 ----------- 8 files changed, 41 insertions(+), 109 deletions(-) delete mode 100644 src/server/ocsigen_socket.ml delete mode 100644 src/server/ocsigen_socket.mli diff --git a/src/baselib/ocsigen_lib.ml b/src/baselib/ocsigen_lib.ml index 4c31c793d..c30544c7d 100644 --- a/src/baselib/ocsigen_lib.ml +++ b/src/baselib/ocsigen_lib.ml @@ -36,6 +36,12 @@ module Ip_address = struct (Lwt_unix.getaddrinfo host "" options) aux + let of_sockaddr = function + | Unix.ADDR_INET (ip, port) -> + ip + | _ -> + raise (Ocsigen_Internal_Error "ip of unix socket") + end (*****************************************************************************) diff --git a/src/baselib/ocsigen_lib.mli b/src/baselib/ocsigen_lib.mli index e0626b22b..20844ec7a 100644 --- a/src/baselib/ocsigen_lib.mli +++ b/src/baselib/ocsigen_lib.mli @@ -38,6 +38,7 @@ module String : module type of String_base module Ip_address : sig exception No_such_host val get_inet_addr : ?v6:bool -> string -> Unix.inet_addr Lwt.t + val of_sockaddr : Unix.sockaddr -> Unix.inet_addr end module Filename : sig diff --git a/src/server/.depend b/src/server/.depend index d418b4b7c..54516a90b 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -1,11 +1,13 @@ -ocsigen_cohttp.cmo : ../baselib/ocsigen_stream.cmi ocsigen_socket.cmi \ - ocsigen_response.cmi ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_header.cmi ../http/ocsigen_cookies.cmi ocsigen_cohttp.cmi -ocsigen_cohttp.cmx : ../baselib/ocsigen_stream.cmx ocsigen_socket.cmx \ - ocsigen_response.cmx ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_header.cmx ../http/ocsigen_cookies.cmx ocsigen_cohttp.cmi -ocsigen_cohttp.cmi : ocsigen_socket.cmi ocsigen_response.cmi \ - ocsigen_request.cmi ../http/ocsigen_cookies.cmi +ocsigen_cohttp.cmo : ../baselib/ocsigen_stream.cmi ocsigen_response.cmi \ + ocsigen_request.cmi ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ + ../http/ocsigen_cookies.cmi ../baselib/ocsigen_config.cmi \ + ocsigen_cohttp.cmi +ocsigen_cohttp.cmx : ../baselib/ocsigen_stream.cmx ocsigen_response.cmx \ + ocsigen_request.cmx ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ + ../http/ocsigen_cookies.cmx ../baselib/ocsigen_config.cmx \ + ocsigen_cohttp.cmi +ocsigen_cohttp.cmi : ocsigen_response.cmi ocsigen_request.cmi \ + ../http/ocsigen_cookies.cmi ../baselib/ocsigen_config.cmi ocsigen_command.cmo : ../baselib/ocsigen_messages.cmi ocsigen_command.cmi ocsigen_command.cmx : ../baselib/ocsigen_messages.cmx ocsigen_command.cmi ocsigen_command.cmi : @@ -35,21 +37,21 @@ ocsigen_multipart.cmx : ../baselib/ocsigen_stream.cmx \ ../baselib/ocsigen_lib.cmx ../baselib/ocsigen_config.cmx \ ocsigen_multipart.cmi ocsigen_multipart.cmi : ../baselib/ocsigen_stream.cmi -ocsigen_parseconfig.cmo : ocsigen_socket.cmi ../baselib/ocsigen_loader.cmi \ +ocsigen_parseconfig.cmo : ../baselib/ocsigen_loader.cmi \ ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi ../http/ocsigen_charset_mime.cmi \ ocsigen_parseconfig.cmi -ocsigen_parseconfig.cmx : ocsigen_socket.cmx ../baselib/ocsigen_loader.cmx \ +ocsigen_parseconfig.cmx : ../baselib/ocsigen_loader.cmx \ ../baselib/ocsigen_lib.cmx ocsigen_extensions.cmx \ ../baselib/ocsigen_config.cmx ../http/ocsigen_charset_mime.cmx \ ocsigen_parseconfig.cmi -ocsigen_parseconfig.cmi : ocsigen_socket.cmi ocsigen_extensions.cmi +ocsigen_parseconfig.cmi : ocsigen_request.cmo : ../baselib/polytables.cmi \ - ../baselib/ocsigen_stream.cmi ocsigen_socket.cmi ocsigen_multipart.cmi \ + ../baselib/ocsigen_stream.cmi ocsigen_multipart.cmi \ ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ ../http/ocsigen_cookies.cmi ocsigen_request.cmi ocsigen_request.cmx : ../baselib/polytables.cmx \ - ../baselib/ocsigen_stream.cmx ocsigen_socket.cmx ocsigen_multipart.cmx \ + ../baselib/ocsigen_stream.cmx ocsigen_multipart.cmx \ ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ ../http/ocsigen_cookies.cmx ocsigen_request.cmi ocsigen_request.cmi : ../baselib/polytables.cmi ocsigen_multipart.cmi \ @@ -60,21 +62,18 @@ ocsigen_response.cmx : ../http/ocsigen_header.cmx \ ../http/ocsigen_cookies.cmx ocsigen_response.cmi ocsigen_response.cmi : ../http/ocsigen_header.cmi \ ../http/ocsigen_cookies.cmi -ocsigen_server.cmo : ocsigen_socket.cmi ocsigen_parseconfig.cmi \ - ../baselib/ocsigen_messages.cmi ../baselib/ocsigen_loader.cmi \ - ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ - ../baselib/ocsigen_config.cmi ../baselib/ocsigen_commandline.cmo \ - ocsigen_command.cmi ocsigen_cohttp.cmi ../baselib/ocsigen_cache.cmi \ - ../baselib/dynlink_wrapper.cmo ocsigen_server.cmi -ocsigen_server.cmx : ocsigen_socket.cmx ocsigen_parseconfig.cmx \ - ../baselib/ocsigen_messages.cmx ../baselib/ocsigen_loader.cmx \ - ../baselib/ocsigen_lib.cmx ocsigen_extensions.cmx \ - ../baselib/ocsigen_config.cmx ../baselib/ocsigen_commandline.cmx \ - ocsigen_command.cmx ocsigen_cohttp.cmx ../baselib/ocsigen_cache.cmx \ - ../baselib/dynlink_wrapper.cmx ocsigen_server.cmi +ocsigen_server.cmo : ocsigen_parseconfig.cmi ../baselib/ocsigen_messages.cmi \ + ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ + ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi \ + ../baselib/ocsigen_commandline.cmo ocsigen_command.cmi ocsigen_cohttp.cmi \ + ../baselib/ocsigen_cache.cmi ../baselib/dynlink_wrapper.cmo \ + ocsigen_server.cmi +ocsigen_server.cmx : ocsigen_parseconfig.cmx ../baselib/ocsigen_messages.cmx \ + ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ + ocsigen_extensions.cmx ../baselib/ocsigen_config.cmx \ + ../baselib/ocsigen_commandline.cmx ocsigen_command.cmx ocsigen_cohttp.cmx \ + ../baselib/ocsigen_cache.cmx ../baselib/dynlink_wrapper.cmx \ + ocsigen_server.cmi ocsigen_server.cmi : -ocsigen_socket.cmo : ../baselib/ocsigen_lib_base.cmi ocsigen_socket.cmi -ocsigen_socket.cmx : ../baselib/ocsigen_lib_base.cmx ocsigen_socket.cmi -ocsigen_socket.cmi : -server_main.cmo : ocsigen_server.cmi -server_main.cmx : ocsigen_server.cmx +server_main.cmo : ocsigen_server.cmi ocsigen_parseconfig.cmi +server_main.cmx : ocsigen_server.cmx ocsigen_parseconfig.cmx diff --git a/src/server/Makefile b/src/server/Makefile index c2ea26342..843431c78 100644 --- a/src/server/Makefile +++ b/src/server/Makefile @@ -13,8 +13,7 @@ all: byte opt ### Common files ### -FILES := ocsigen_socket.ml \ - ocsigen_command.ml \ +FILES := ocsigen_command.ml \ ocsigen_multipart.ml \ ocsigen_request.ml \ ocsigen_response.ml \ diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index b6c22c422..1446e27c9 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -92,7 +92,7 @@ let make let r_remote_ip = lazy (Unix.string_of_inet_addr - (Ocsigen_socket.ip_of_sockaddr sockaddr)) + (Ocsigen_lib.Ip_address.of_sockaddr sockaddr)) in let r_remote_ip_parsed = lazy (Ipaddr.of_string_exn (Lazy.force r_remote_ip)) diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index 2f3755c06..838679d63 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -41,14 +41,15 @@ let _ = let warn sockaddr s = Lwt_log.ign_warning_f ~section "While talking to %a:%s" (fun () sockaddr -> - Unix.string_of_inet_addr (Ocsigen_socket.ip_of_sockaddr sockaddr)) + Unix.string_of_inet_addr + (Ocsigen_lib.Ip_address.of_sockaddr sockaddr)) sockaddr s let dbg sockaddr s = Lwt_log.ign_info_f ~section "While talking to %a:%s" (fun () sockaddr -> Unix.string_of_inet_addr - (Ocsigen_socket.ip_of_sockaddr sockaddr)) + (Ocsigen_lib.Ip_address.of_sockaddr sockaddr)) sockaddr s let try_bind' f g h = Lwt.try_bind f h g diff --git a/src/server/ocsigen_socket.ml b/src/server/ocsigen_socket.ml deleted file mode 100644 index 237e167de..000000000 --- a/src/server/ocsigen_socket.ml +++ /dev/null @@ -1,56 +0,0 @@ -(** make_ipv6_socket create a socket on an ipv6 address - * @param addr address of socket - * @param port port of socket - * *) -let make_ipv6_socket addr port = - let socket = Lwt_unix.socket Unix.PF_INET6 Unix.SOCK_STREAM 0 in - Lwt_unix.set_close_on_exec socket; - (* see http://stackoverflow.com/a/14388707/2200717 for more information - * to why set REUSEADDR on socket *) - Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true; - Lwt_unix.setsockopt socket Unix.IPV6_ONLY true; - Lwt_unix.bind socket (Unix.ADDR_INET (addr, port)); - socket - -(** make_ipv4_socket create a socket on an ipv4 address - * @param addr address of socket - * @param port port of socket - * *) -let make_ipv4_socket addr port = - let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - Lwt_unix.set_close_on_exec socket; - Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true; - Lwt_unix.bind socket (Unix.ADDR_INET (addr, port)); - socket - -let make_sockets addr port = - match addr with - | `All -> - (* The user didn't specify a protocol in the configuration - file; we try to open an IPv6 socket (listening to IPv6 - only) if possible and we open an IPv4 socket anyway. This - corresponds to the net.ipv6.bindv6only=0 behaviour on Linux, - but is portable and should work with - net.ipv6.bindv6only=1 as well. *) - let ipv6_socket = - try [make_ipv6_socket Unix.inet6_addr_any port] - with Unix.Unix_error - ((Unix.EAFNOSUPPORT - | Unix.EPROTONOSUPPORT - | Unix.EADDRINUSE (* GH issue #104 *) - ), _, _) -> [] - in - (make_ipv4_socket Unix.inet_addr_any port)::ipv6_socket - | `IPv4 addr -> - [make_ipv4_socket addr port] - | `IPv6 addr -> - [make_ipv6_socket addr port] - - -let ip_of_sockaddr = function - | Unix.ADDR_INET (ip, port) -> ip - | _ -> raise (Ocsigen_lib_base.Ocsigen_Internal_Error "ip of unix socket") - -let port_of_sockaddr = function - | Unix.ADDR_INET (ip, port) -> port - | _ -> raise (Ocsigen_lib_base.Ocsigen_Internal_Error "port of unix socket") diff --git a/src/server/ocsigen_socket.mli b/src/server/ocsigen_socket.mli deleted file mode 100644 index fb4260d4c..000000000 --- a/src/server/ocsigen_socket.mli +++ /dev/null @@ -1,18 +0,0 @@ -(** Abstraction handling sockets IPv4 and IPv6 *) - -(** make_sockets create socket ready to listen in addr:port - @param addr type of addresss (All | IPv4 | IPv6) - @param port port of socket -*) -val make_sockets : - Ocsigen_config.socket_type -> int -> Lwt_unix.file_descr list - -(** ip_of_sockaddr accessor for ip - @param A Unix.ADDR_INET value or raise error -*) -val ip_of_sockaddr : Unix.sockaddr -> Unix.inet_addr - -(** port_of_sockaddr accessor for port - @param A Unix.ADDR_INET value or raise error -*) -val port_of_sockaddr : Unix.sockaddr -> int From 18ba0641f12dcd5500f76a902970c2fe1e1afc3a Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 22 May 2017 15:57:44 +0200 Subject: [PATCH 072/111] Unify fun_site and user_fun_site in ext API --- src/extensions/accesscontrol.ml | 3 +- src/extensions/authbasic.ml | 3 +- src/extensions/cors.ml | 6 +-- src/extensions/deflatemod.ml | 2 +- src/extensions/extendconfiguration.ml | 26 ++++++------- src/extensions/outputfilter.ml | 3 +- src/extensions/redirectmod.ml | 3 +- src/extensions/revproxy.ml | 3 +- src/extensions/rewritemod.ml | 3 +- src/extensions/staticmod.ml | 3 +- src/extensions/userconf.ml | 6 +-- src/server/ocsigen_extensions.ml | 53 +++++---------------------- src/server/ocsigen_extensions.mli | 9 ++--- src/server/ocsigen_parseconfig.ml | 4 +- 14 files changed, 40 insertions(+), 87 deletions(-) diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index 774d9fc36..0ec19e3a3 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -435,6 +435,5 @@ let parse_config parse_fun = function let () = Ocsigen_extensions.register_extension ~name:"accesscontrol" - ~fun_site:(fun _ _ _ _ -> parse_config) - ~user_fun_site:(fun _ _ _ _ _ -> parse_config) + ~fun_site:(fun _ _ _ _ _ -> parse_config) () diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index 7e6d04389..e7cfbb90e 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -137,6 +137,5 @@ let parse_config element = let () = Ocsigen_extensions.register_extension ~name:"authbasic" - ~fun_site:(fun _ _ _ _ _ -> parse_config) - ~user_fun_site:(fun _ _ _ _ _ _ -> parse_config) + ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index 56abe7533..4483de628 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -194,12 +194,8 @@ let parse_config _ _ parse_fun config_elem = ); main !config -let site_creator (_ : Ocsigen_extensions.virtual_hosts) _ = parse_config -let user_site_creator (_ : Ocsigen_extensions.userconf_info) = site_creator - let () = Ocsigen_extensions.register_extension ~name:"CORS" - ~fun_site:site_creator - ~user_fun_site:user_site_creator + ~fun_site:(fun _ _ _ -> parse_config) () diff --git a/src/extensions/deflatemod.ml b/src/extensions/deflatemod.ml index e15e5134f..3eb0ee6c9 100644 --- a/src/extensions/deflatemod.ml +++ b/src/extensions/deflatemod.ml @@ -401,6 +401,6 @@ let parse_config config_elem = let () = Ocsigen_extensions.register_extension ~name:"deflatemod" - ~fun_site:(fun _ _ _ _ _ -> parse_config) + ~fun_site:(fun _ _ _ _ _ _ -> parse_config) ~init_fun:parse_global_config () diff --git a/src/extensions/extendconfiguration.ml b/src/extensions/extendconfiguration.ml index ab22b647c..d7511e948 100644 --- a/src/extensions/extendconfiguration.ml +++ b/src/extensions/extendconfiguration.ml @@ -20,6 +20,8 @@ open Lwt.Infix +let name = "extendconfiguration" + let bad_config s = raise (Ocsigen_extensions.Error_in_config_file s) let gen configfun = function @@ -70,7 +72,7 @@ let check_regexp_list = Hashtbl.add hashtbl r () with _ -> raise (Bad_regexp r) -let parse_config usermode _ _ _ = function +let fun_site usermode _ _ _ _ _ = function | Xml.Element ("listdirs", ["value", "true"], []) -> gen @@ fun config -> { config with Ocsigen_extensions.list_directory_content = true } @@ -84,13 +86,14 @@ let parse_config usermode _ _ _ = function | "never" -> Ocsigen_extensions.DoNotFollowSymlinks | "always" -> - if not usermode then - Ocsigen_extensions.AlwaysFollowSymlinks - else - raise - (Ocsigen_extensions.Error_in_user_config_file - "Cannot specify value 'always' for option \ - 'followsymlinks' in userconf files") + (match usermode with + | None -> + Ocsigen_extensions.AlwaysFollowSymlinks + | Some _ -> + raise + (Ocsigen_extensions.Error_in_user_config_file + "Cannot specify value 'always' for option \ + 'followsymlinks' in userconf files")) | "ownermatch" -> Ocsigen_extensions.FollowSymlinksIfOwnerMatch | _ -> @@ -244,9 +247,4 @@ let parse_config usermode _ _ _ = function raise (Ocsigen_extensions.Error_in_config_file "Unexpected data in config file") -let () = - Ocsigen_extensions.register_extension - ~name:"extendconfiguration" - ~fun_site:(fun _ _ -> parse_config false) - ~user_fun_site:(fun path _ _ -> parse_config true) - () +let () = Ocsigen_extensions.register_extension ~name ~fun_site () diff --git a/src/extensions/outputfilter.ml b/src/extensions/outputfilter.ml index 232249cd3..bfa4c501d 100644 --- a/src/extensions/outputfilter.ml +++ b/src/extensions/outputfilter.ml @@ -140,6 +140,5 @@ let parse_config config_elem = let () = Ocsigen_extensions.register_extension ~name:"outputfilter" - ~fun_site:(fun _ _ _ _ _ -> parse_config) - ~user_fun_site:(fun _ _ _ _ _ _ -> parse_config) + ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () diff --git a/src/extensions/redirectmod.ml b/src/extensions/redirectmod.ml index 370f243ae..a4bf4156c 100644 --- a/src/extensions/redirectmod.ml +++ b/src/extensions/redirectmod.ml @@ -120,6 +120,5 @@ let parse_config config_elem = let () = Ocsigen_extensions.register_extension ~name:"redirectmod" - ~fun_site:(fun _ _ _ _ _ -> parse_config) - ~user_fun_site:(fun _ _ _ _ _ _ -> parse_config) + ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index 8998fcf9f..68c3d132a 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -215,8 +215,7 @@ let parse_config config_elem = let () = Ocsigen_extensions.register_extension ~name:"revproxy" - ~fun_site:(fun _ _ _ _ _ -> parse_config) - ~user_fun_site:(fun _ _ _ _ _ _ -> parse_config) + ~fun_site:(fun _ _ _ _ _ _ -> parse_config) ~respect_pipeline:true (* We ask ocsigen to respect pipeline order when sending to extensions! *) () diff --git a/src/extensions/rewritemod.ml b/src/extensions/rewritemod.ml index fba712fee..71bfb51a3 100644 --- a/src/extensions/rewritemod.ml +++ b/src/extensions/rewritemod.ml @@ -139,6 +139,5 @@ let parse_config element = let () = Ocsigen_extensions.register_extension ~name:"rewritemod" - ~fun_site:(fun _ _ _ _ _ -> parse_config) - ~user_fun_site:(fun _ _ _ _ _ _ -> parse_config) + ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 8b2eb10f9..95bb0d522 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -305,6 +305,5 @@ let parse_config userconf _ let () = Ocsigen_extensions.register_extension ~name:"staticmod" - ~fun_site:(fun _ -> parse_config None) - ~user_fun_site:(fun path _ -> parse_config (Some path)) + ~fun_site:(fun path _ -> parse_config path) () diff --git a/src/extensions/userconf.ml b/src/extensions/userconf.ml index 5fc428514..d93d5b5fd 100644 --- a/src/extensions/userconf.ml +++ b/src/extensions/userconf.ml @@ -124,8 +124,8 @@ let gen hostpattern sitepath (regexp, conf, url, prefix, localpath) = Ocsigen_extensions.replace_user_dir regexp localpath path } and conf = conf_to_xml conf0 in let user_parse_host = - Ocsigen_extensions.parse_user_site_item - userconf_options hostpattern request_config in + Ocsigen_extensions.parse_config_item + (Some userconf_options) hostpattern request_config in (* Inside userconf, we create a new virtual site starting after [prefix], and use a request modified accordingly*) let user_parse_site = @@ -147,7 +147,7 @@ let gen hostpattern sitepath (regexp, conf, url, prefix, localpath) = | e -> handle_parsing_error req e -let parse_config hostpattern _ path _ _ config_elem = +let parse_config _ hostpattern _ path _ _ config_elem = let regexp = ref None in let conf = ref None in let url = ref None in diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 4649936c9..256c4b304 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -393,6 +393,7 @@ let fun_end = ref (fun () -> ()) let fun_exn = ref (fun exn -> (raise exn : string)) let rec default_parse_config + userconf_info (host : virtual_hosts) config_info prevpath @@ -554,34 +555,27 @@ type userconf_info = { localfiles_root : string; } -type parse_config = virtual_hosts -> config_info -> parse_config_aux -and parse_config_user = userconf_info -> parse_config +type parse_config = + userconf_info option -> + virtual_hosts -> + config_info -> + parse_config_aux and parse_config_aux = Url.path -> parse_host -> (parse_fun -> Xml.xml -> extension ) - - -let user_extension_void_fun_site : parse_config_user = - fun _ _ _ _ _ _ -> function - | Xml.Element (t, _, _) -> raise (Bad_config_tag_for_extension t) - | _ -> raise (Error_in_config_file "Unexpected data in config file") - -let extension_void_fun_site : parse_config = fun _ _ _ _ _ -> function +let extension_void_fun_site : parse_config = fun _ _ _ _ _ _ -> function | Xml.Element (t, _, _) -> raise (Bad_config_tag_for_extension t) | _ -> raise (Error_in_config_file "Unexpected data in config file") - -let register_extension, parse_config_item, parse_user_site_item, get_beg_init, get_end_init, get_init_exn_handler = +let register_extension, parse_config_item, get_beg_init, get_end_init, get_init_exn_handler = let ref_fun_site = ref default_parse_config in - let ref_user_fun_site = ref (fun (_ : userconf_info) -> default_parse_config) in ((* ********* register_extension ********* *) (fun ?fun_site - ?user_fun_site ?begin_init ?end_init ?(exn_handler=raise) @@ -596,28 +590,9 @@ let register_extension, parse_config_item, parse_user_site_item, get_beg_init, g | Some fun_site -> let old_fun_site = !ref_fun_site in ref_fun_site := - (fun host conf_info -> - let oldf = old_fun_site host conf_info in - let newf = fun_site host conf_info in - fun path parse_host -> - let oldf = oldf path parse_host in - let newf = newf path parse_host in - fun parse_config config_tag -> - try - oldf parse_config config_tag - with - | Bad_config_tag_for_extension c -> - newf parse_config config_tag - )); - - (match user_fun_site with - | None -> () - | Some user_fun_site -> - let old_fun_site = !ref_user_fun_site in - ref_user_fun_site := (fun path host conf_info -> let oldf = old_fun_site path host conf_info in - let newf = user_fun_site path host conf_info in + let newf = fun_site path host conf_info in fun path parse_host -> let oldf = oldf path parse_host in let newf = newf path parse_host in @@ -628,8 +603,6 @@ let register_extension, parse_config_item, parse_user_site_item, get_beg_init, g | Bad_config_tag_for_extension c -> newf parse_config config_tag )); - - (match begin_init with | Some begin_init -> fun_beg := Ocsigen_lib.comp begin_init !fun_beg | None -> ()); @@ -639,13 +612,8 @@ let register_extension, parse_config_item, parse_user_site_item, get_beg_init, g let curexnfun = !fun_exn in fun_exn := fun e -> try curexnfun e with e -> exn_handler e), - - (* ********* parse_config_item ********* *) (fun host conf -> !ref_fun_site host conf), - (* ********* parse_user_site_item ********* *) - (fun host conf -> !ref_user_fun_site host conf), - (* ********* get_beg_init ********* *) (fun () -> !fun_beg), @@ -664,7 +632,6 @@ let default_parse_extension ext_name = function let register_extension ~name ?fun_site - ?user_fun_site ?begin_init ?end_init ?init_fun @@ -676,7 +643,7 @@ let register_extension (match init_fun with | None -> default_parse_extension name (get_config ()) | Some f -> f (get_config ())); - register_extension ?fun_site ?user_fun_site ?begin_init ?end_init + register_extension ?fun_site ?begin_init ?end_init ?exn_handler ?respect_pipeline ()) module Configuration = struct diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 5234c4847..b142439c2 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -257,9 +257,10 @@ type userconf_info = { inside an userconf file. They take one more parameter, of type userconf_info *) type parse_config = - virtual_hosts -> config_info -> parse_config_aux -and parse_config_user = - userconf_info -> parse_config + userconf_info option -> + virtual_hosts -> + config_info -> + parse_config_aux and parse_config_aux = Ocsigen_lib.Url.path -> parse_host -> (parse_fun -> Xml.xml -> @@ -309,7 +310,6 @@ and parse_config_aux = val register_extension : name:string -> ?fun_site:parse_config -> - ?user_fun_site:parse_config_user -> ?begin_init:(unit -> unit) -> ?end_init:(unit -> unit) -> ?init_fun:(Xml.xml list -> unit) -> @@ -442,7 +442,6 @@ val make_parse_config : Ocsigen_lib.Url.path -> parse_config_aux -> parse_fun val parse_config_item : parse_config -val parse_user_site_item : parse_config_user val set_hosts : (virtual_hosts * config_info * extension2) list -> unit diff --git a/src/server/ocsigen_parseconfig.ml b/src/server/ocsigen_parseconfig.ml index 595111de1..642a0554e 100644 --- a/src/server/ocsigen_parseconfig.ml +++ b/src/server/ocsigen_parseconfig.ml @@ -536,9 +536,9 @@ let later_pass c = maxuploadfilesize = Ocsigen_config.get_maxuploadfilesize (); } in - let parse_host = Ocsigen_extensions.parse_config_item host conf in + let parse_host _ = Ocsigen_extensions.parse_config_item None host conf in let parse_config = - Ocsigen_extensions.make_parse_config [] parse_host + Ocsigen_extensions.make_parse_config [] (parse_host None) in (* default site for host *) (host, conf, parse_config l)::(parse_server_aux ll) From 601b8df0d34750986202946f1e32c395029fca66 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 22 May 2017 16:47:38 +0200 Subject: [PATCH 073/111] Slight Ocsigen_extensions cleanup - register_extension -> register - Unused begin_init argument gone --- src/extensions/accesscontrol.ml | 2 +- src/extensions/authbasic.ml | 2 +- src/extensions/cors.ml | 2 +- src/extensions/deflatemod.ml | 2 +- src/extensions/extendconfiguration.ml | 2 +- src/extensions/ocsipersist-dbm/ocsipersist.ml | 2 +- .../ocsipersist-pgsql/ocsipersist.ml | 2 +- .../ocsipersist-sqlite/ocsipersist.ml | 5 +- src/extensions/outputfilter.ml | 2 +- src/extensions/redirectmod.ml | 2 +- src/extensions/revproxy.ml | 2 +- src/extensions/rewritemod.ml | 2 +- src/extensions/staticmod.ml | 2 +- src/extensions/userconf.ml | 2 +- src/server/ocsigen_extensions.ml | 97 ++++++++----------- src/server/ocsigen_extensions.mli | 15 +-- 16 files changed, 53 insertions(+), 90 deletions(-) diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index 0ec19e3a3..4383c1e68 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -433,7 +433,7 @@ let parse_config parse_fun = function (* Registration of the extension *) let () = - Ocsigen_extensions.register_extension + Ocsigen_extensions.register ~name:"accesscontrol" ~fun_site:(fun _ _ _ _ _ -> parse_config) () diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index e7cfbb90e..848e9631f 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -135,7 +135,7 @@ let parse_config element = (** Registration of the extension *) let () = - Ocsigen_extensions.register_extension + Ocsigen_extensions.register ~name:"authbasic" ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index 4483de628..50222b802 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -195,7 +195,7 @@ let parse_config _ _ parse_fun config_elem = main !config let () = - Ocsigen_extensions.register_extension + Ocsigen_extensions.register ~name:"CORS" ~fun_site:(fun _ _ _ -> parse_config) () diff --git a/src/extensions/deflatemod.ml b/src/extensions/deflatemod.ml index 3eb0ee6c9..b76eb192c 100644 --- a/src/extensions/deflatemod.ml +++ b/src/extensions/deflatemod.ml @@ -399,7 +399,7 @@ let parse_config config_elem = (*****************************************************************************) (** Registration of the extension *) let () = - Ocsigen_extensions.register_extension + Ocsigen_extensions.register ~name:"deflatemod" ~fun_site:(fun _ _ _ _ _ _ -> parse_config) ~init_fun:parse_global_config diff --git a/src/extensions/extendconfiguration.ml b/src/extensions/extendconfiguration.ml index d7511e948..624db991b 100644 --- a/src/extensions/extendconfiguration.ml +++ b/src/extensions/extendconfiguration.ml @@ -247,4 +247,4 @@ let fun_site usermode _ _ _ _ _ = function raise (Ocsigen_extensions.Error_in_config_file "Unexpected data in config file") -let () = Ocsigen_extensions.register_extension ~name ~fun_site () +let () = Ocsigen_extensions.register ~name ~fun_site () diff --git a/src/extensions/ocsipersist-dbm/ocsipersist.ml b/src/extensions/ocsipersist-dbm/ocsipersist.ml index c2019883e..b11d749ee 100644 --- a/src/extensions/ocsipersist-dbm/ocsipersist.ml +++ b/src/extensions/ocsipersist-dbm/ocsipersist.ml @@ -357,4 +357,4 @@ let length table = (* Because of Dbm implementation, the result may be less thann the expected result in some case (with a version of ocsipersist based on Dbm) *) -let _ = Ocsigen_extensions.register_extension ~name:"ocsipersist" ~init_fun () +let _ = Ocsigen_extensions.register ~name:"ocsipersist" ~init_fun () diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index 4e84ee802..402cfffe3 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -224,4 +224,4 @@ let init_fun config = parse_global_config config; conn_pool := Lwt_pool.create !size_conn_pool ~validate:PGOCaml.alive connect -let _ = Ocsigen_extensions.register_extension ~name:"ocsipersist" ~init_fun () +let _ = Ocsigen_extensions.register ~name:"ocsipersist" ~init_fun () diff --git a/src/extensions/ocsipersist-sqlite/ocsipersist.ml b/src/extensions/ocsipersist-sqlite/ocsipersist.ml index ac4a856cc..24c4f6591 100644 --- a/src/extensions/ocsipersist-sqlite/ocsipersist.ml +++ b/src/extensions/ocsipersist-sqlite/ocsipersist.ml @@ -328,7 +328,4 @@ let init config = raise e -let _ = Ocsigen_extensions.register_extension - ~name:"ocsipersist" - ~init_fun:init - () +let _ = Ocsigen_extensions.register ~name:"ocsipersist" ~init_fun:init () diff --git a/src/extensions/outputfilter.ml b/src/extensions/outputfilter.ml index bfa4c501d..2be31238d 100644 --- a/src/extensions/outputfilter.ml +++ b/src/extensions/outputfilter.ml @@ -138,7 +138,7 @@ let parse_config config_elem = | Some code -> gen_code code let () = - Ocsigen_extensions.register_extension + Ocsigen_extensions.register ~name:"outputfilter" ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () diff --git a/src/extensions/redirectmod.ml b/src/extensions/redirectmod.ml index a4bf4156c..a69450f1c 100644 --- a/src/extensions/redirectmod.ml +++ b/src/extensions/redirectmod.ml @@ -118,7 +118,7 @@ let parse_config config_elem = !dest, !mode, !temporary)) let () = - Ocsigen_extensions.register_extension + Ocsigen_extensions.register ~name:"redirectmod" ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index 68c3d132a..91ce1194d 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -213,7 +213,7 @@ let parse_config config_elem = } let () = - Ocsigen_extensions.register_extension + Ocsigen_extensions.register ~name:"revproxy" ~fun_site:(fun _ _ _ _ _ _ -> parse_config) ~respect_pipeline:true (* We ask ocsigen to respect pipeline order diff --git a/src/extensions/rewritemod.ml b/src/extensions/rewritemod.ml index 71bfb51a3..9613712a6 100644 --- a/src/extensions/rewritemod.ml +++ b/src/extensions/rewritemod.ml @@ -137,7 +137,7 @@ let parse_config element = (** Registration of the extension *) let () = - Ocsigen_extensions.register_extension + Ocsigen_extensions.register ~name:"rewritemod" ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 95bb0d522..0223d6ad8 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -303,7 +303,7 @@ let parse_config userconf _ (*****************************************************************************) (** extension registration *) let () = - Ocsigen_extensions.register_extension + Ocsigen_extensions.register ~name:"staticmod" ~fun_site:(fun path _ -> parse_config path) () diff --git a/src/extensions/userconf.ml b/src/extensions/userconf.ml index d93d5b5fd..0a82b2224 100644 --- a/src/extensions/userconf.ml +++ b/src/extensions/userconf.ml @@ -199,7 +199,7 @@ let parse_config _ hostpattern _ path _ _ config_elem = gen hostpattern path info let () = - Ocsigen_extensions.register_extension + Ocsigen_extensions.register ~name:"userconf" ~fun_site:parse_config () diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 256c4b304..56c68584c 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -386,9 +386,6 @@ let make_ext cookies_to_set req_state (genfun : extension) (genfun2 : extension2 in aux cookies_to_set res - -(*****************************************************************************) -let fun_beg = ref (fun () -> ()) let fun_end = ref (fun () -> ()) let fun_exn = ref (fun exn -> (raise exn : string)) @@ -537,7 +534,6 @@ and make_parse_config path parse_host l : extension2 = (try !fun_exn e with e -> Printexc.to_string e) in - !fun_beg (); let r = try parse_config l @@ -570,69 +566,53 @@ let extension_void_fun_site : parse_config = fun _ _ _ _ _ _ -> function | Xml.Element (t, _, _) -> raise (Bad_config_tag_for_extension t) | _ -> raise (Error_in_config_file "Unexpected data in config file") -let register_extension, parse_config_item, get_beg_init, get_end_init, get_init_exn_handler = +let register, parse_config_item, get_init_exn_handler = let ref_fun_site = ref default_parse_config in - ((* ********* register_extension ********* *) - (fun - ?fun_site - ?begin_init - ?end_init - ?(exn_handler=raise) - ?(respect_pipeline=false) - () - -> - - if respect_pipeline then Ocsigen_config.set_respect_pipeline (); - - (match fun_site with - | None -> () - | Some fun_site -> - let old_fun_site = !ref_fun_site in - ref_fun_site := - (fun path host conf_info -> - let oldf = old_fun_site path host conf_info in - let newf = fun_site path host conf_info in - fun path parse_host -> - let oldf = oldf path parse_host in - let newf = newf path parse_host in - fun parse_config config_tag -> - try - oldf parse_config config_tag - with - | Bad_config_tag_for_extension c -> - newf parse_config config_tag - )); - (match begin_init with - | Some begin_init -> fun_beg := Ocsigen_lib.comp begin_init !fun_beg - | None -> ()); - (match end_init with - | Some end_init -> fun_end := Ocsigen_lib.comp end_init !fun_end; - | None -> ()); - let curexnfun = !fun_exn in - fun_exn := fun e -> try curexnfun e with e -> exn_handler e), - - (fun host conf -> !ref_fun_site host conf), - - (* ********* get_beg_init ********* *) - (fun () -> !fun_beg), - - (* ********* get_end_init ********* *) - (fun () -> !fun_end), - - (* ********* get_init_exn_handler ********* *) - (fun () -> !fun_exn) - ) + (fun + ?fun_site + ?end_init + ?(exn_handler=raise) + ?(respect_pipeline=false) + () -> + if respect_pipeline then Ocsigen_config.set_respect_pipeline (); + (match fun_site with + | None -> () + | Some fun_site -> + let old_fun_site = !ref_fun_site in + ref_fun_site := + (fun path host conf_info -> + let oldf = old_fun_site path host conf_info in + let newf = fun_site path host conf_info in + fun path parse_host -> + let oldf = oldf path parse_host in + let newf = newf path parse_host in + fun parse_config config_tag -> + try + oldf parse_config config_tag + with + | Bad_config_tag_for_extension c -> + newf parse_config config_tag + )); + (match end_init with + | Some end_init -> fun_end := Ocsigen_lib.comp end_init !fun_end; + | None -> ()); + let curexnfun = !fun_exn in + fun_exn := fun e -> try curexnfun e with e -> exn_handler e), + + (fun host conf -> !ref_fun_site host conf), + + (* ********* get_init_exn_handler ********* *) + (fun () -> !fun_exn) let default_parse_extension ext_name = function | [] -> () | _ -> raise (Error_in_config_file (Printf.sprintf "Unexpected content found in configuration of extension %s: %s does not accept options" ext_name ext_name)) -let register_extension +let register ~name ?fun_site - ?begin_init ?end_init ?init_fun ?exn_handler @@ -643,8 +623,7 @@ let register_extension (match init_fun with | None -> default_parse_extension name (get_config ()) | Some f -> f (get_config ())); - register_extension ?fun_site ?begin_init ?end_init - ?exn_handler ?respect_pipeline ()) + register ?fun_site ?end_init ?exn_handler ?respect_pipeline ()) module Configuration = struct diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index b142439c2..1a64f6296 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -273,18 +273,6 @@ and parse_config_aux = will be responsible for handling the options of the configuration files that are recognized by the extension, and potentially generating a page. - - a function [user_fun_site] of type [parse_user_config] which has the - same role as [fun_site], but inside userconf files. Specify nothing - if your extension is disallowed in userconf files. Otherwise, compared - to [fun_site], you can selectively disallow some options, - as [user_fun_site] must define only safe options (for example it is not - safe to allow such options to load a cmo specified by a user, or to - execute a program, as this program will be executed by ocsigen's user). - Note that [user_fun_site] will be called for every request, whereas the - [fun_site] is called only when starting or reloading the server. - - a function [begin_init] that will be called at the beginning - of the initialisation phase of each site, and each time the config file is - reloaded. - a function [end_init] that will be called at the end of the initialisation phase of each site - a function [init_fun] that will be called just before registering the @@ -307,10 +295,9 @@ and parse_config_aux = to another server. It is false by default. *) -val register_extension : +val register : name:string -> ?fun_site:parse_config -> - ?begin_init:(unit -> unit) -> ?end_init:(unit -> unit) -> ?init_fun:(Xml.xml list -> unit) -> ?exn_handler:(exn -> string) -> From c71d374d74ad087d24f96e38b29f4f9ee99938eb Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 22 May 2017 19:16:56 +0200 Subject: [PATCH 074/111] Ocsigen_parseconfig cleanup --- src/server/ocsigen_parseconfig.ml | 605 +++++++++++++++--------------- 1 file changed, 297 insertions(+), 308 deletions(-) diff --git a/src/server/ocsigen_parseconfig.ml b/src/server/ocsigen_parseconfig.ml index 642a0554e..e724e2369 100644 --- a/src/server/ocsigen_parseconfig.ml +++ b/src/server/ocsigen_parseconfig.ml @@ -282,306 +282,295 @@ let get_defaulthostname ~defaulthostname ~defaulthttpport ~host = raise (Ocsigen_config.Config_file_error ("Incorrect hostname " ^ host)) +let later_pass_host_attr + (name, charset, + defaulthostname, defaulthttpport, defaulthttpsport, + ishttps) = + function + | "hostfilter", s -> + (match name with + | None -> + Some s, charset, + defaulthostname, + defaulthttpport, + defaulthttpsport, + ishttps + | _ -> + raise (Ocsigen_config.Config_file_error + ("Duplicate attribute name in "))) + | "charset", s -> + (match charset with + | None -> + name, Some s, + defaulthostname, + defaulthttpport, + defaulthttpsport, + ishttps + | _ -> + raise (Ocsigen_config.Config_file_error + ("Duplicate attribute charset in "))) + | "defaulthostname", s -> + (match defaulthostname with + | None -> + if correct_hostname s then + name, charset, + Some s, + defaulthttpport, + defaulthttpsport, + ishttps + else + raise (Ocsigen_config.Config_file_error + ("Incorrect hostname " ^ s)) + | _ -> + raise (Ocsigen_config.Config_file_error + "Duplicate attribute defaulthostname in ")) + | "defaulthttpport", s -> + (match defaulthttpport with + | None -> + name, charset, + defaulthostname, + Some s, + defaulthttpsport, + ishttps + | _ -> + raise (Ocsigen_config.Config_file_error + ("Duplicate attribute defaulthttpport in "))) + | "defaulthttpsport", s -> + (match defaulthttpsport with + | None -> + name, charset, + defaulthostname, + defaulthttpport, + Some s, + ishttps + | _ -> + raise (Ocsigen_config.Config_file_error + ("Duplicate attribute defaulthttpsport in "))) + | "defaultprotocol", s -> + (match ishttps with + | None -> + name, charset, + defaulthostname, + defaulthttpport, + defaulthttpsport, + Some s + | _ -> + raise (Ocsigen_config.Config_file_error + ("Duplicate attribute defaultprotocol in "))) + | attr, _ -> + raise (Ocsigen_config.Config_file_error + ("Wrong attribute for : " ^ attr)) + +let later_pass_host attrs l = + let host, charset, defaulthostname, defaulthttpport, + defaulthttpsport, defaultprotocol = + List.fold_left + later_pass_host_attr + (None, None, None, None, None, None) + (List.rev attrs) + in + let host = parse_host_field host in + let charset = + match charset, Ocsigen_config.get_default_charset () with + | Some charset, _ + | None, Some charset -> charset + | None, None -> "utf-8" + and defaulthttpport = + match defaulthttpport with + | None -> Ocsigen_config.get_default_port () + | Some p -> int_of_string "host" p + and defaulthostname = + get_defaulthostname + ~defaulthostname ~defaulthttpport ~host + and defaulthttpsport = + match defaulthttpsport with + | None -> Ocsigen_config.get_default_sslport () + | Some p -> int_of_string "host" p + and serve_everything = { + Ocsigen_extensions.do_not_serve_regexps = []; + do_not_serve_files = []; + do_not_serve_extensions = []; + } in + let conf = { + Ocsigen_extensions.default_hostname = defaulthostname; + default_httpport = defaulthttpport; + default_httpsport = defaulthttpsport; + default_protocol_is_https = defaultprotocol = Some "https"; + mime_assoc = Ocsigen_charset_mime.default_mime_assoc (); + charset_assoc = + Ocsigen_charset_mime.empty_charset_assoc + ~default:charset (); + default_directory_index = ["index.html"]; + list_directory_content = false; + follow_symlinks = Ocsigen_extensions.FollowSymlinksIfOwnerMatch; + do_not_serve_404 = serve_everything; + do_not_serve_403 = serve_everything; + uploaddir = Ocsigen_config.get_uploaddir (); + maxuploadfilesize = Ocsigen_config.get_maxuploadfilesize (); + } in + let parse_config = + Ocsigen_extensions.make_parse_config [] + (Ocsigen_extensions.parse_config_item None host conf) + in + (* default site for host *) + host, conf, parse_config l -(* Config file is parsed twice. - This is the second parsing (site loading) -*) -let later_pass c = - let rec parse_server_aux = function - | [] -> [] - | (Element ("port", atts, p))::ll -> - parse_server_aux ll - | (Element ("charset" as st, atts, p))::ll -> - set_default_charset (Some (parse_string_tag st p)); - parse_server_aux ll - | (Element ("logdir", [], p))::ll -> - parse_server_aux ll - | (Element ("syslog", [], p))::ll -> - parse_server_aux ll - | (Element ("ssl", [], p))::ll -> - parse_server_aux ll - | (Element ("user", [], p))::ll -> - parse_server_aux ll - | (Element ("group", [], p))::ll -> - parse_server_aux ll - | (Element ("uploaddir" as st, [], p))::ll -> - set_uploaddir (Some (parse_string_tag st p)); - parse_server_aux ll - | (Element ("datadir" as st, [], p))::ll -> - set_datadir (parse_string_tag st p); - parse_server_aux ll - | (Element ("minthreads" as st, [], p))::ll -> - parse_server_aux ll - | (Element ("maxthreads" as st, [], p))::ll -> - parse_server_aux ll - | (Element ("maxdetachedcomputationsqueued" as st, [], p))::ll -> - set_max_number_of_threads_queued (int_of_string st (parse_string_tag st p)); - parse_server_aux ll - | (Element ("maxconnected" as st, [], p))::ll -> - set_max_number_of_connections (int_of_string st (parse_string_tag st p)); - parse_server_aux ll - | (Element ("mimefile" as st, [], p))::ll -> - Ocsigen_config.set_mimefile (parse_string_tag st p); - parse_server_aux ll - | (Element ("maxretries" as st, [], p))::ll -> - set_maxretries (int_of_string st (parse_string_tag st p)); - parse_server_aux ll - | (Element ("timeout" as st, [], p))::ll -(*VVV timeout: backward compatibility with <= 0.99.4 *) - | (Element ("clienttimeout" as st, [], p))::ll -> - set_client_timeout (int_of_string st (parse_string_tag st p)); - parse_server_aux ll - | (Element ("servertimeout" as st, [], p))::ll -> - set_server_timeout (int_of_string st (parse_string_tag st p)); - parse_server_aux ll -(*VVV For now we use silentservertimeout and silentclienttimeout also - for keep alive :-( - | (Element ("keepalivetimeout" as st, [], p))::ll -> - set_keepalive_timeout (int_of_string st (parse_string_tag st p)); - parse_server_aux ll - | (Element ("keepopentimeout" as st, [], p))::ll -> - set_keepopen_timeout (int_of_string st (parse_string_tag st p)); - parse_server_aux ll -*) - | (Element ("netbuffersize" as st, [], p))::ll -> - set_netbuffersize (int_of_string st (parse_string_tag st p)); - parse_server_aux ll - | (Element ("filebuffersize" as st, [], p))::ll -> - set_filebuffersize (int_of_string st (parse_string_tag st p)); - parse_server_aux ll - | (Element ("maxrequestbodysize" as st, [], p))::ll -> - set_maxrequestbodysize (parse_size_tag st (parse_string_tag st p)); - parse_server_aux ll - | (Element ("maxuploadfilesize" as st, [], p))::ll -> - set_maxuploadfilesize (parse_size_tag st - (parse_string_tag st p)); - parse_server_aux ll - | (Element ("commandpipe" as st, [], p))::ll -> - set_command_pipe (parse_string_tag st p); - parse_server_aux ll - | (Element ("shutdowntimeout" as st, [], p))::ll -> - let p = parse_string_tag st p in - let t = - if p = "notimeout" - then None - else Some (float_of_string st p) - in - set_shutdown_timeout t; - parse_server_aux ll - | (Element ("debugmode", [], []))::ll -> - set_debugmode true; - parse_server_aux ll - | (Element ("usedefaulthostname", [], []))::ll -> - set_usedefaulthostname true; - parse_server_aux ll - | (Element ("disablepartialrequests", [], []))::ll -> - set_disablepartialrequests true; - parse_server_aux ll - | (Element ("respectpipeline", [], []))::ll -> - set_respect_pipeline (); - parse_server_aux ll - | (Element ("findlib", ["path",p], []))::ll -> - Ocsigen_loader.add_ocamlpath p; - parse_server_aux ll - | (Element ("require", atts, l))::ll - | (Element ("extension", atts, l))::ll -> - (* We do not reload extensions *) - let modules = match atts with - | [] -> - raise - (Config_file_error "missing module, name or findlib-package attribute in ") - | [("name", s)] -> `Name s - | [("module", s)] -> `Files [s] - | [("findlib-package", s)] -> `Files (Ocsigen_loader.findfiles s) - | _ -> - raise (Config_file_error "Wrong attribute for ") - in begin - match modules with - | `Files modules -> - Ocsigen_loader.loadfiles - (preloadfile l) postloadfile false modules; - | `Name name -> - Ocsigen_loader.init_module - (preloadfile l) postloadfile false name - end; - parse_server_aux ll - | (Element ("library", atts, l))::ll -> - let modules = match atts with - | [] -> - raise - (Config_file_error "missing module or findlib-package attribute in ") - | [("name", s)] -> `Name s - | [("module", s)] -> `Files [s] - | [("findlib-package", s)] -> `Files (Ocsigen_loader.findfiles s) - | _ -> raise (Config_file_error "Wrong attribute for ") - in begin - match modules with - | `Files modules -> - Ocsigen_loader.loadfiles (preloadfile l) postloadfile true modules; - | `Name name -> - Ocsigen_loader.init_module (preloadfile l) postloadfile true name - end; - parse_server_aux ll - | (Element ("host", atts, l))::ll -> - let rec parse_attrs ((name, - charset, - defaulthostname, - defaulthttpport, - defaulthttpsport, - ishttps) as r) = function - | [] -> r - | ("hostfilter", s)::suite -> - (match name with - | None -> parse_attrs ((Some s), charset, - defaulthostname, - defaulthttpport, - defaulthttpsport, - ishttps) suite - | _ -> raise (Ocsigen_config.Config_file_error - ("Duplicate attribute name in "))) - | ("charset", s)::suite -> - (match charset with - | None -> parse_attrs (name, Some s, - defaulthostname, - defaulthttpport, - defaulthttpsport, - ishttps) suite - | _ -> raise (Ocsigen_config.Config_file_error - ("Duplicate attribute charset in "))) - | ("defaulthostname", s)::suite -> - (match defaulthostname with - | None -> - if correct_hostname s then - parse_attrs (name, charset, - (Some s), - defaulthttpport, - defaulthttpsport, - ishttps) suite - else - raise (Ocsigen_config.Config_file_error - ("Incorrect hostname " ^ s)) - | _ -> raise (Ocsigen_config.Config_file_error - ("Duplicate attribute defaulthostname in "))) - | ("defaulthttpport", s)::suite -> - (match defaulthttpport with - | None -> parse_attrs (name, charset, - defaulthostname, - (Some s), - defaulthttpsport, - ishttps) suite - | _ -> raise (Ocsigen_config.Config_file_error - ("Duplicate attribute defaulthttpport in "))) - | ("defaulthttpsport", s)::suite -> - (match defaulthttpsport with - | None -> parse_attrs (name, charset, - defaulthostname, - defaulthttpport, - Some s, - ishttps) suite - | _ -> raise (Ocsigen_config.Config_file_error - ("Duplicate attribute defaulthttpsport in "))) - | ("defaultprotocol", s)::suite -> - (match ishttps with - | None -> parse_attrs (name, charset, - defaulthostname, - defaulthttpport, - defaulthttpsport, - Some s) suite - | _ -> raise (Ocsigen_config.Config_file_error - ("Duplicate attribute defaultprotocol in "))) - | (s, _)::_ -> - raise (Ocsigen_config.Config_file_error - ("Wrong attribute for : "^s)) - in - let host, charset, defaulthostname, defaulthttpport, - defaulthttpsport, defaultprotocol = - parse_attrs (None, None, None, None, None, None) atts - in - let host = parse_host_field host in - let charset = - match charset, Ocsigen_config.get_default_charset () with - | Some charset, _ - | None, Some charset -> charset - | None, None -> "utf-8" - in - let defaulthttpport = match defaulthttpport with - | None -> Ocsigen_config.get_default_port () - | Some p -> int_of_string "host" p - in - let defaulthostname = get_defaulthostname - ~defaulthostname ~defaulthttpport ~host in - let defaulthttpsport = match defaulthttpsport with - | None -> Ocsigen_config.get_default_sslport () - | Some p -> int_of_string "host" p - in - let serve_everything = { - Ocsigen_extensions.do_not_serve_regexps = []; - do_not_serve_files = []; - do_not_serve_extensions = []; - } in - let conf = { - Ocsigen_extensions.default_hostname = defaulthostname; - default_httpport = defaulthttpport; - default_httpsport = defaulthttpsport; - default_protocol_is_https = defaultprotocol = Some "https"; - mime_assoc = Ocsigen_charset_mime.default_mime_assoc (); - charset_assoc = Ocsigen_charset_mime.empty_charset_assoc - ~default:charset (); - default_directory_index = ["index.html"]; - list_directory_content = false; - follow_symlinks = Ocsigen_extensions.FollowSymlinksIfOwnerMatch; - do_not_serve_404 = serve_everything; - do_not_serve_403 = serve_everything; - uploaddir = Ocsigen_config.get_uploaddir (); - maxuploadfilesize = Ocsigen_config.get_maxuploadfilesize (); - } - in - let parse_host _ = Ocsigen_extensions.parse_config_item None host conf in - let parse_config = - Ocsigen_extensions.make_parse_config [] (parse_host None) - in - (* default site for host *) - (host, conf, parse_config l)::(parse_server_aux ll) - | (Element ("extconf", [("dir", dir)], []))::ll -> - let one = - try - let files = Sys.readdir dir in - Array.sort compare files; - Array.fold_left - (fun l s -> - if Filename.check_suffix s "conf" then - let filename = dir^"/"^s in - let filecont = - try - Lwt_log.ign_info_f ~section "Parsing configuration file %s" filename; - parse_ext filename - with e -> - Lwt_log.ign_error_f ~section ~exn:e - "Error while loading configuration file %s (ignored)" filename; - [] - in - (match filecont with - | [] -> l - | s::_ -> l@(parse_server_aux s) - ) - else l - ) - [] - files - with - | Sys_error _ as e -> - Lwt_log.ign_error ~section ~exn:e - "Error while loading configuration file (ignored)"; - [] - in - one@(parse_server_aux ll) - | (Element (tag, _, _))::_ -> - raise (Config_file_error - ("tag <"^tag^"> unexpected inside ")) - | _ -> - raise (Config_file_error "Syntax error") - in Ocsigen_extensions.set_hosts (parse_server_aux c) +let later_pass_extension tag attrs l = + (* We do not reload extensions *) + match attrs with + | [] -> + raise + (Config_file_error + ("missing module, name or findlib-package attribute in " ^ tag)) + | ["name", s] -> + Ocsigen_loader.init_module + (preloadfile l) postloadfile false s + | ["module", s] -> + Ocsigen_loader.loadfiles + (preloadfile l) postloadfile false + [s]; + | ["findlib-package", s] -> + Ocsigen_loader.loadfiles + (preloadfile l) postloadfile false + (Ocsigen_loader.findfiles s) + | _ -> + raise (Config_file_error ("Wrong attribute for " ^ tag)) + +let rec later_pass_extconf dir = + let f acc s = + if Filename.check_suffix s "conf" then + match + let filename = dir^"/"^s in + try + Lwt_log.ign_info_f ~section + "Parsing configuration file %s" filename; + parse_ext filename + with e -> + Lwt_log.ign_error_f ~section ~exn:e + "Error while loading configuration file %s (ignored)" + filename; + [] + with + | [] -> acc + | s :: _ -> acc @ later_pass s + else + acc + in + try + let files = Sys.readdir dir in + Array.sort compare files; + Array.fold_left f [] files + with + | Sys_error _ as e -> + Lwt_log.ign_error ~section ~exn:e + "Error while loading configuration file (ignored)"; + [] + +(* Config file is parsed twice. This is the second parsing (site + loading). *) +and later_pass = function + | [] -> [] + | Element ("port", atts, p) :: ll -> + later_pass ll + | Element ("charset" as st, atts, p) :: ll -> + set_default_charset (Some (parse_string_tag st p)); + later_pass ll + | Element ("logdir", [], p) :: ll -> + later_pass ll + | Element ("syslog", [], p) :: ll -> + later_pass ll + | Element ("ssl", [], p) :: ll -> + later_pass ll + | Element ("user", [], p) :: ll -> + later_pass ll + | Element ("group", [], p) :: ll -> + later_pass ll + | Element ("uploaddir" as st, [], p) :: ll -> + set_uploaddir (Some (parse_string_tag st p)); + later_pass ll + | Element ("datadir" as st, [], p) :: ll -> + set_datadir (parse_string_tag st p); + later_pass ll + | Element ("minthreads", [], p) :: ll -> + later_pass ll + | Element ("maxthreads", [], p) :: ll -> + later_pass ll + | Element ("maxdetachedcomputationsqueued" as st, [], p) :: ll -> + set_max_number_of_threads_queued + (int_of_string st (parse_string_tag st p)); + later_pass ll + | Element ("maxconnected" as st, [], p) :: ll -> + set_max_number_of_connections (int_of_string st (parse_string_tag st p)); + later_pass ll + | Element ("mimefile" as st, [], p) :: ll -> + Ocsigen_config.set_mimefile (parse_string_tag st p); + later_pass ll + | Element ("maxretries" as st, [], p) :: ll -> + set_maxretries (int_of_string st (parse_string_tag st p)); + later_pass ll + | Element ("timeout" as st, [], p) :: ll + | Element ("clienttimeout" as st, [], p) :: ll -> + set_client_timeout (int_of_string st (parse_string_tag st p)); + later_pass ll + | Element ("servertimeout" as st, [], p) :: ll -> + set_server_timeout (int_of_string st (parse_string_tag st p)); + later_pass ll + | Element ("netbuffersize" as st, [], p) :: ll -> + set_netbuffersize (int_of_string st (parse_string_tag st p)); + later_pass ll + | Element ("filebuffersize" as st, [], p) :: ll -> + set_filebuffersize (int_of_string st (parse_string_tag st p)); + later_pass ll + | Element ("maxrequestbodysize" as st, [], p) :: ll -> + set_maxrequestbodysize (parse_size_tag st (parse_string_tag st p)); + later_pass ll + | Element ("maxuploadfilesize" as st, [], p) :: ll -> + set_maxuploadfilesize (parse_size_tag st (parse_string_tag st p)); + later_pass ll + | Element ("commandpipe" as st, [], p) :: ll -> + set_command_pipe (parse_string_tag st p); + later_pass ll + | Element ("shutdowntimeout" as st, [], p) :: ll -> + set_shutdown_timeout + (match parse_string_tag st p with + | "notimeout" -> + None + | p -> + Some (float_of_string st p)); + later_pass ll + | Element ("debugmode", [], []) :: ll -> + set_debugmode true; + later_pass ll + | Element ("usedefaulthostname", [], []) :: ll -> + set_usedefaulthostname true; + later_pass ll + | Element ("disablepartialrequests", [], []) :: ll -> + set_disablepartialrequests true; + later_pass ll + | Element ("respectpipeline", [], []) :: ll -> + set_respect_pipeline (); + later_pass ll + | Element ("findlib", ["path",p], []) :: ll -> + Ocsigen_loader.add_ocamlpath p; + later_pass ll + | Element ("require", atts, l) :: ll + | Element ("extension", atts, l) :: ll -> + later_pass_extension "" atts l; + later_pass ll + | Element ("library", atts, l) :: ll -> + later_pass_extension "" atts l; + later_pass ll + | Element ("host", atts, l) :: ll -> + later_pass_host atts l :: later_pass ll + | Element ("extconf", [("dir", dir)], []) :: ll -> + later_pass_extconf dir @ later_pass ll + | Element (tag, _, _) :: _ -> + raise (Config_file_error + ("tag <"^tag^"> unexpected inside ")) + | _ -> + raise (Config_file_error "Syntax error") +let later_pass l = Ocsigen_extensions.set_hosts (later_pass l) (* Parsing tags *) let parse_port = @@ -685,14 +674,14 @@ let rec parse_ssl l ~certificate ~privatekey ~ciphers ~dhfile ~curve = let first_pass c = let rec aux user group ssl ports sslports = function [] -> ((user, group), (ssl, ports, sslports)) - | (Element ("logdir" as st, [], p))::ll -> + | Element ("logdir" as st, [], p) :: ll -> set_logdir (parse_string_tag st p); aux user group ssl ports sslports ll - | (Element ("syslog" as st, [], p))::ll -> + | Element ("syslog" as st, [], p) :: ll -> let str = String.lowercase (parse_string_tag st p) in set_syslog_facility (Some (parse_facility str)); aux user group ssl ports sslports ll - | (Element ("port" as st, atts, p))::ll -> + | Element ("port" as st, atts, p) :: ll -> (match atts with [] | [("protocol", "HTTP")] -> @@ -711,13 +700,13 @@ let first_pass c = in aux user group ssl ports (po::sslports) ll | _ -> raise (Config_file_error "Wrong attribute for ")) - | (Element ("minthreads" as st, [], p))::ll -> + | Element ("minthreads" as st, [], p) :: ll -> set_minthreads (int_of_string st (parse_string_tag st p)); aux user group ssl ports sslports ll - | (Element ("maxthreads" as st, [], p))::ll -> + | Element ("maxthreads" as st, [], p) :: ll -> set_maxthreads (int_of_string st (parse_string_tag st p)); aux user group ssl ports sslports ll - | (Element ("ssl", [], p))::ll -> + | Element ("ssl", [], p) :: ll -> (match ssl with None -> let ssl = @@ -733,22 +722,22 @@ let first_pass c = raise (Config_file_error "Only one ssl certificate for each server supported for now")) - | (Element ("user" as st, [], p))::ll -> + | Element ("user" as st, [], p) :: ll -> (match user with None -> aux (Some (parse_string_tag st p)) group ssl ports sslports ll | _ -> raise (Config_file_error "Only one tag for each server allowed")) - | (Element ("group" as st, [], p))::ll -> + | Element ("group" as st, [], p) :: ll -> (match group with None -> aux user (Some (parse_string_tag st p)) ssl ports sslports ll | _ -> raise (Config_file_error "Only one tag for each server allowed")) - | (Element ("commandpipe" as st, [], p))::ll -> + | Element ("commandpipe" as st, [], p) :: ll -> set_command_pipe (parse_string_tag st p); aux user group ssl ports sslports ll - | (Element (tag, _, _))::ll -> + | Element (tag, _, _) :: ll -> aux user group ssl ports sslports ll | _ -> raise (Config_file_error "Syntax error") From 778cabd4c4db5569a2eb788c8cd51d86c04fe642 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 23 May 2017 14:38:42 +0200 Subject: [PATCH 075/111] Ocsigen_extensions API for bypassing XML parsing (WIP) --- src/extensions/extendconfiguration.ml | 16 +++--- src/extensions/staticmod.ml | 12 +++-- src/server/ocsigen_extensions.ml | 62 +++++++++++++++++------ src/server/ocsigen_extensions.mli | 44 ++++++++-------- src/server/ocsigen_local_files.ml | 6 +-- src/server/ocsigen_parseconfig.ml | 73 ++++++++++----------------- src/server/server_main.ml | 1 + 7 files changed, 116 insertions(+), 98 deletions(-) diff --git a/src/extensions/extendconfiguration.ml b/src/extensions/extendconfiguration.ml index 624db991b..c3c3ec490 100644 --- a/src/extensions/extendconfiguration.ml +++ b/src/extensions/extendconfiguration.ml @@ -81,26 +81,28 @@ let fun_site usermode _ _ _ _ _ = function { config with Ocsigen_extensions.list_directory_content = false } | Xml.Element ("listdirs" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s - | Xml.Element ("followsymlinks", ["value", s], []) -> - let v = match s with + | Xml.Element ("followsymlinks", ["value", follow_symlinks], []) -> + let follow_symlinks = + match follow_symlinks with | "never" -> - Ocsigen_extensions.DoNotFollowSymlinks + `No | "always" -> (match usermode with | None -> - Ocsigen_extensions.AlwaysFollowSymlinks + `Always | Some _ -> raise (Ocsigen_extensions.Error_in_user_config_file "Cannot specify value 'always' for option \ 'followsymlinks' in userconf files")) | "ownermatch" -> - Ocsigen_extensions.FollowSymlinksIfOwnerMatch + `Owner_match | _ -> - bad_config ("Wrong value \""^s^"\" for option \"followsymlinks\"") + bad_config ("Wrong value \"" ^ follow_symlinks ^ + "\" for option \"followsymlinks\"") in gen @@ fun config -> - { config with Ocsigen_extensions.follow_symlinks = v } + { config with Ocsigen_extensions.follow_symlinks } | Xml.Element ("followsymlinks" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s | Xml.Element ("charset", attrs, exts) -> diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 0223d6ad8..72b80ec2f 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -20,6 +20,8 @@ open Lwt.Infix +let name = "staticmod" + let section = Lwt_log.Section.make "ocsigen:ext:staticmod" exception Not_concerned @@ -300,10 +302,14 @@ let parse_config userconf _ in gen ~usermode:userconf ?cache:!opt.opt_cache kind -(*****************************************************************************) -(** extension registration *) let () = Ocsigen_extensions.register - ~name:"staticmod" + ~name ~fun_site:(fun path _ -> parse_config path) () + +let () = + Ocsigen_extensions.register_without_xml_config + (fun cookies r -> + gen ~usermode:None (Dir "/home/vasilis/static") r >|= fun response -> + response, cookies) diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 56c68584c..653e210d7 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -18,7 +18,10 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** Writing extensions for Ocsigen *) +let we_have_xml_config, set_we_have_xml_config = + let r = ref false in + (fun () -> !r), + (fun () -> r := true) let section = Lwt_log.Section.make "ocsigen:ext" @@ -77,6 +80,12 @@ type do_not_serve = { do_not_serve_extensions: string list; } +let serve_everything = { + do_not_serve_regexps = []; + do_not_serve_files = []; + do_not_serve_extensions = [] +} + (* BY TODO : Use unbalanced trees instead *) let join_do_not_serve d1 d2 = { do_not_serve_regexps = d1.do_not_serve_regexps @ d2.do_not_serve_regexps; @@ -129,12 +138,6 @@ let do_not_serve_to_regexp d = with _ -> raise (IncorrectRegexpes d) ) - -(*****************************************************************************) - -(* Main server configuration *) - - type config_info = { default_hostname: string; default_httpport: int; @@ -157,7 +160,7 @@ type config_info = { list_directory_content : bool; (** Should symlinks be followed when accessign a local file? *) - follow_symlinks: follow_symlink; + follow_symlinks: [`No | `Owner_match | `Always]; do_not_serve_404: do_not_serve; do_not_serve_403: do_not_serve; @@ -165,13 +168,29 @@ type config_info = { uploaddir: string option; maxuploadfilesize: int64 option; } -and follow_symlink = - | DoNotFollowSymlinks (** Never follow a symlink *) - | FollowSymlinksIfOwnerMatch (** Follow a symlink if the symlink and its - target have the same owner *) - | AlwaysFollowSymlinks (** Always follow symlinks *) - +let default_config_info () = + let do_not_serve_404 = { + do_not_serve_regexps = []; + do_not_serve_files = []; + do_not_serve_extensions = []; + } in { + default_hostname = Unix.gethostname (); + default_httpport = Ocsigen_config.get_default_port (); + default_httpsport = Ocsigen_config.get_default_sslport (); + default_protocol_is_https = false; + mime_assoc = Ocsigen_charset_mime.default_mime_assoc (); + charset_assoc = + Ocsigen_charset_mime.empty_charset_assoc + ?default:(Ocsigen_config.get_default_charset ()) (); + default_directory_index = ["index.html"]; + list_directory_content = false; + follow_symlinks = `Owner_match; + do_not_serve_404 ; + do_not_serve_403 = do_not_serve_404 ; + uploaddir = Ocsigen_config.get_uploaddir (); + maxuploadfilesize = Ocsigen_config.get_maxuploadfilesize (); + } (* Requests *) type request = { @@ -266,8 +285,6 @@ type parse_host = let (hosts : (virtual_hosts * config_info * extension2) list ref) = ref [] - - let set_hosts v = hosts := v let get_hosts () = !hosts @@ -625,6 +642,19 @@ let register | Some f -> f (get_config ())); register ?fun_site ?end_init ?exn_handler ?respect_pipeline ()) +let register_without_xml_config + ?(config_info = default_config_info ()) + ?(host_regexp = ".*") + ?port + f = + if not (we_have_xml_config ()) then + let virtual_hosts = + (* TODO : dedup virtual_hosts ? *) + [host_regexp, + Ocsigen_lib.Netstring_pcre.regexp host_regexp, port] + in + set_hosts ((virtual_hosts, config_info, f) :: get_hosts ()) + module Configuration = struct type attribute' = { diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 1a64f6296..d643df912 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -16,13 +16,7 @@ * You should have received a copy of the GNU Lesser 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. -*) -(*****************************************************************************) -(*****************************************************************************) -(* Tables of services (global and session tables) *) -(* Store and load dynamic pages *) -(*****************************************************************************) -(*****************************************************************************) + *) (** Extensions interface for Ocsigen Server *) @@ -72,6 +66,7 @@ type do_not_serve = { do_not_serve_extensions: string list; } +val serve_everything : do_not_serve exception IncorrectRegexpes of do_not_serve @@ -82,8 +77,6 @@ val do_not_serve_to_regexp: do_not_serve -> Pcre.regexp val join_do_not_serve : do_not_serve -> do_not_serve -> do_not_serve - - (** Configuration options, passed to (and modified by) extensions *) type config_info = { default_hostname: string; @@ -96,18 +89,18 @@ type config_info = { charset_assoc : Ocsigen_charset_mime.charset_assoc; (** Default name to use as index file when a directory is requested. - Use [None] if no index should be tried. The various indexes - are tried in the given order. If no index is specified, - or the index does not exists, the content of the directory - might be listed, according to [list_directory_content] *) + Use [None] if no index should be tried. The various indexes are + tried in the given order. If no index is specified, or the index + does not exists, the content of the directory might be listed, + according to [list_directory_content] *) default_directory_index : string list; - (** Should the list of files in a directory be displayed - if there is no index in this directory ? *) + (** Should the list of files in a directory be displayed if there is + no index in this directory ? *) list_directory_content : bool; - (** Should symlinks be followed when accessign a local file? *) - follow_symlinks: follow_symlink; + (** Should symlinks be followed when accessing a local file? *) + follow_symlinks: [`No | `Owner_match | `Always]; do_not_serve_404: do_not_serve; do_not_serve_403: do_not_serve; @@ -115,14 +108,8 @@ type config_info = { uploaddir: string option; maxuploadfilesize: int64 option; } -and follow_symlink = - | DoNotFollowSymlinks (** Never follow a symlink *) - | FollowSymlinksIfOwnerMatch (** Follow a symlink if the symlink and its - target have the same owner *) - | AlwaysFollowSymlinks (** Always follow symlinks *) - -(*****************************************************) +val default_config_info : unit -> config_info type request = { request_info: Ocsigen_request.t; @@ -462,3 +449,12 @@ val set_config : Xml.xml list -> unit val sockets : Lwt_unix.file_descr list ref val sslsockets : Lwt_unix.file_descr list ref + +val set_we_have_xml_config : unit -> unit + +val register_without_xml_config : + ?config_info:config_info -> + ?host_regexp:string -> + ?port:int -> + extension2 -> + unit diff --git a/src/server/ocsigen_local_files.ml b/src/server/ocsigen_local_files.ml index 1686dff32..f7ef54e16 100644 --- a/src/server/ocsigen_local_files.ml +++ b/src/server/ocsigen_local_files.ml @@ -88,11 +88,11 @@ let check_symlinks ~no_check_for ~filename policy = check_symlinks_parent_directories filename no_check_for policy in match policy with - | Ocsigen_extensions.AlwaysFollowSymlinks -> + | `Always -> true - | Ocsigen_extensions.DoNotFollowSymlinks -> + | `No -> aux never_follow_symlinks - | Ocsigen_extensions.FollowSymlinksIfOwnerMatch -> + | `Owner_match -> aux follow_symlinks_if_owner_match let check_dotdot = diff --git a/src/server/ocsigen_parseconfig.ml b/src/server/ocsigen_parseconfig.ml index e724e2369..f81e831f4 100644 --- a/src/server/ocsigen_parseconfig.ml +++ b/src/server/ocsigen_parseconfig.ml @@ -38,7 +38,6 @@ let blah_of_string f tag s = let int_of_string = blah_of_string int_of_string let float_of_string = blah_of_string float_of_string -(*****************************************************************************) let default_default_hostname = let hostname = Unix.gethostname () in try @@ -55,7 +54,6 @@ let default_default_hostname = in config file." hostname; (*VVV Is it the right behaviour? *) hostname -(*****************************************************************************) let parse_size = let kilo = Int64.of_int 1000 in @@ -140,7 +138,6 @@ let parse_size = else o l else o l) - let parse_size_tag tag s = try parse_size s @@ -149,20 +146,9 @@ let parse_size_tag tag s = (Ocsigen_config.Config_file_error ("While parsing <"^tag^"> - "^s^" is not a valid size.")) - - - - - -(* My xml parser is not really adapted to this. - It is the parser for the syntax extension. - But it works. -*) - - let rec parse_string = function | [] -> "" - | (PCData s)::l -> s^(parse_string l) + | PCData s :: l -> s ^ parse_string l | _ -> failwith "ocsigen_parseconfig.parse_string" let parse_string_tag tag s = @@ -173,7 +159,6 @@ let parse_string_tag tag s = (Ocsigen_config.Config_file_error ("While parsing <"^tag^"> - String expected.")) - let rec parser_config = let rec parse_servers n = function | [] -> (match n with @@ -195,11 +180,9 @@ let rec parser_config = parse_servers [] l | _ -> raise (Config_file_error " tag expected") - let parse_ext file = parser_config (Xml.parse_file file) - let preloadfile config () = Ocsigen_extensions.set_config config let postloadfile () = Ocsigen_extensions.set_config [] @@ -258,29 +241,31 @@ let parse_host_field = (r : Ocsigen_extensions.virtual_hosts) ) - -(* Extract a default hostname from the "host" field if no default is provided *) -let get_defaulthostname ~defaulthostname ~defaulthttpport ~host = - match defaulthostname with - | Some d -> d - | None -> - (* We look for a hostname without wildcard (second case) *) - (* Something more clever could be envisioned *) - let rec aux = function - | [] -> default_default_hostname - | (t, _, (Some 80 | None)) :: _ when String.contains t '*' = false -> - t - | _ :: q -> aux q - in - let host = aux host in - Lwt_log.ign_warning_f ~section - "While parsing config file, tag : No defaulthostname, \ - assuming it is \"%s\"" host; - if correct_hostname host then - host - else - raise (Ocsigen_config.Config_file_error - ("Incorrect hostname " ^ host)) +(* Extract a default hostname from the "host" field if no default is + provided *) +let get_defaulthostname ~defaulthostname ~host = + match defaulthostname with + | Some d -> d + | None -> + (* We look for a hostname without wildcard (second case). + Something more clever could be envisioned *) + let rec aux = function + | [] -> + default_default_hostname + | (t, _, (Some 80 | None)) :: _ + when (not (String.contains t '*')) -> + t + | _ :: q -> aux q + in + let host = aux host in + Lwt_log.ign_warning_f ~section + "While parsing config file, tag : No defaulthostname, \ + assuming it is \"%s\"" host; + if correct_hostname host then + host + else + raise (Ocsigen_config.Config_file_error + ("Incorrect hostname " ^ host)) let later_pass_host_attr (name, charset, @@ -379,9 +364,7 @@ let later_pass_host attrs l = match defaulthttpport with | None -> Ocsigen_config.get_default_port () | Some p -> int_of_string "host" p - and defaulthostname = - get_defaulthostname - ~defaulthostname ~defaulthttpport ~host + and defaulthostname = get_defaulthostname ~defaulthostname ~host and defaulthttpsport = match defaulthttpsport with | None -> Ocsigen_config.get_default_sslport () @@ -402,7 +385,7 @@ let later_pass_host attrs l = ~default:charset (); default_directory_index = ["index.html"]; list_directory_content = false; - follow_symlinks = Ocsigen_extensions.FollowSymlinksIfOwnerMatch; + follow_symlinks = `Owner_match; do_not_serve_404 = serve_everything; do_not_serve_403 = serve_everything; uploaddir = Ocsigen_config.get_uploaddir (); diff --git a/src/server/server_main.ml b/src/server/server_main.ml index 9881e3691..8ac45d6fa 100644 --- a/src/server/server_main.ml +++ b/src/server/server_main.ml @@ -1,4 +1,5 @@ let () = + Ocsigen_extensions.set_we_have_xml_config (); Ocsigen_server.start ~config:(Ocsigen_parseconfig.parse_config ()) () From 302f3c65d23d13636ec21c0d51fde2376ae7ef34 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 24 May 2017 17:26:13 +0200 Subject: [PATCH 076/111] New virtual host definition API Permits defining virtual hosts (equivalent to tag) programmatically. Extensions can be attached on hosts. staticmod has been enhanced to support this. --- Makefile.options | 1 + opam | 1 + src/Makefile.filelist | 3 +- src/extensions/.depend | 5 +- src/extensions/staticmod.ml | 77 ++++++++++++++++++------------- src/extensions/staticmod.mli | 11 +++++ src/server/.depend | 6 ++- src/server/ocsigen_extensions.ml | 77 +++++++++++++++++++++++++++++++ src/server/ocsigen_extensions.mli | 34 ++++++++++++++ src/server/ocsigen_server.ml | 6 ++- 10 files changed, 182 insertions(+), 39 deletions(-) create mode 100644 src/extensions/staticmod.mli diff --git a/Makefile.options b/Makefile.options index 9ef04b8f5..6630e3db9 100644 --- a/Makefile.options +++ b/Makefile.options @@ -41,6 +41,7 @@ SERVER_PACKAGE := lwt_ssl \ xml-light \ dynlink \ cohttp.lwt \ + hmap \ ppx_deriving.std INITPACKAGE := \"$(shell ${OCAMLFIND} query -p-format -recursive \ diff --git a/opam b/opam index a11d64462..e810c07e4 100644 --- a/opam +++ b/opam @@ -55,6 +55,7 @@ depends: [ ("dbm" | "sqlite3" | "pgocaml") "ipaddr" {>= "2.1"} "cohttp" {>= "0.17.0"} + "hmap" # REMOVE AFTER DEBUGGING "ppx_deriving" diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 00670cc83..7ffa82484 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -54,8 +54,7 @@ endif PLUGINS_BIN := PLUGINS_INTF := extensions/authbasic.cmi extensions/accesscontrol.cmi \ - extensions/ocsipersist.cmi - # extensions/ocsigen_comet.cmi + extensions/ocsipersist.cmi extensions/staticmod.cmi PLUGINS_IMPL := extensions/accesscontrol.cmo extensions/authbasic.cmo \ extensions/cors.cmo extensions/outputfilter.cmo \ diff --git a/src/extensions/.depend b/src/extensions/.depend index 1ed8798b1..4e36e46b4 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -61,10 +61,11 @@ rewritemod.cmx : ../server/ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx staticmod.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ ../server/ocsigen_local_files.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi + ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi staticmod.cmi staticmod.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ ../server/ocsigen_local_files.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx + ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx staticmod.cmi +staticmod.cmi : ../server/ocsigen_extensions.cmi userconf.cmo : ../server/ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi userconf.cmx : ../server/ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 72b80ec2f..e79ef19eb 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -198,6 +198,31 @@ type options = { opt_cache: int option; } +let kind dir regexp code dest root_checks = + match + dir, regexp, code, dest, root_checks + with + | (None, None, None, _, _) -> + Ocsigen_extensions.badconfig + "Missing attribute dir, regexp, or code for " + + | (Some d, None, None, None, None) -> + Dir (Ocsigen_lib.Url.remove_end_slash d) + + | (None, Some r, code, Some t, rc) -> + Regexp { source_regexp = r; + dest = t; + http_status_filter = code; + root_checks = rc; + } + + | (None, None, (Some _ as code), Some t, None) -> + Regexp { dest = t; http_status_filter = code; root_checks = None; + source_regexp = Ocsigen_lib.Netstring_pcre.regexp "^.*$" } + + | _ -> + Ocsigen_extensions.badconfig "Wrong attributes for " + let parse_config userconf _ : Ocsigen_extensions.parse_config_aux = fun _ _ _ element -> @@ -273,34 +298,10 @@ let parse_config userconf _ ] element ); - let kind = - match !opt.opt_dir, - !opt.opt_regexp, - !opt.opt_code, - !opt.opt_dest, - !opt.opt_root_checks with - | (None, None, None, _, _) -> - Ocsigen_extensions.badconfig - "Missing attribute dir, regexp, or code for " - - | (Some d, None, None, None, None) -> - Dir (Ocsigen_lib.Url.remove_end_slash d) - - | (None, Some r, code, Some t, rc) -> - Regexp { source_regexp = r; - dest = t; - http_status_filter = code; - root_checks = rc; - } - - | (None, None, (Some _ as code), Some t, None) -> - Regexp { dest = t; http_status_filter = code; root_checks = None; - source_regexp = Ocsigen_lib.Netstring_pcre.regexp "^.*$" } - - | _ -> - Ocsigen_extensions.badconfig "Wrong attributes for " - in - gen ~usermode:userconf ?cache:!opt.opt_cache kind + gen ~usermode:userconf ?cache:!opt.opt_cache @@ + kind + !opt.opt_dir !opt.opt_regexp !opt.opt_code + !opt.opt_dest !opt.opt_root_checks let () = Ocsigen_extensions.register @@ -308,8 +309,20 @@ let () = ~fun_site:(fun path _ -> parse_config path) () -let () = - Ocsigen_extensions.register_without_xml_config - (fun cookies r -> - gen ~usermode:None (Dir "/home/vasilis/static") r >|= fun response -> +(* TODO: fix names and types, preprocess as we do for XML *) +let dir = Ocsigen_extensions.Virtual_host.Config.key () +let regexp = Ocsigen_extensions.Virtual_host.Config.key () +let opt_code = Ocsigen_extensions.Virtual_host.Config.key () +let opt_dest = Ocsigen_extensions.Virtual_host.Config.key () +let opt_root_checks = Ocsigen_extensions.Virtual_host.Config.key () + +let register vh = + Ocsigen_extensions.Virtual_host.register vh + (fun {Ocsigen_extensions.Virtual_host.Config.accessor} cookies r -> + let kind = + kind + (accessor dir) (accessor regexp) + (accessor opt_code) (accessor opt_dest) (accessor opt_root_checks) + in + gen ~usermode:None kind r >|= fun response -> response, cookies) diff --git a/src/extensions/staticmod.mli b/src/extensions/staticmod.mli new file mode 100644 index 000000000..c14da4ff0 --- /dev/null +++ b/src/extensions/staticmod.mli @@ -0,0 +1,11 @@ +val dir : string Ocsigen_extensions.Virtual_host.Config.key +val regexp : + Pcre.regexp Ocsigen_extensions.Virtual_host.Config.key +val opt_code : + Pcre.regexp Ocsigen_extensions.Virtual_host.Config.key +val opt_dest : + Ocsigen_extensions.ud_string Ocsigen_extensions.Virtual_host.Config.key +val opt_root_checks : + Ocsigen_extensions.ud_string Ocsigen_extensions.Virtual_host.Config.key + +val register : Ocsigen_extensions.Virtual_host.t -> unit diff --git a/src/server/.depend b/src/server/.depend index 54516a90b..bc400e6f9 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -75,5 +75,7 @@ ocsigen_server.cmx : ocsigen_parseconfig.cmx ../baselib/ocsigen_messages.cmx \ ../baselib/ocsigen_cache.cmx ../baselib/dynlink_wrapper.cmx \ ocsigen_server.cmi ocsigen_server.cmi : -server_main.cmo : ocsigen_server.cmi ocsigen_parseconfig.cmi -server_main.cmx : ocsigen_server.cmx ocsigen_parseconfig.cmx +server_main.cmo : ocsigen_server.cmi ocsigen_parseconfig.cmi \ + ocsigen_extensions.cmi +server_main.cmx : ocsigen_server.cmx ocsigen_parseconfig.cmx \ + ocsigen_extensions.cmx diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 653e210d7..427101d43 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -642,6 +642,83 @@ let register | Some f -> f (get_config ())); register ?fun_site ?end_init ?exn_handler ?respect_pipeline ()) +module Virtual_host = struct + + type 'a config_key = 'a Hmap.key + + type accessor = { accessor : 'a . 'a Hmap.key -> 'a option } + + type t = { + vh_list : virtual_hosts ; + vh_config_info : config_info ; + mutable vh_config_map : Hmap.t ; + mutable vh_fun_l : (accessor -> extension2) list ; + } + + let l = ref [] + + let default_re_string = ".*" + + let default_re = Ocsigen_lib.Netstring_pcre.regexp default_re_string + + let create + ?(config_info = default_config_info ()) + ?host_regexp + ?port () = + let vh_list = + match host_regexp with + | Some host_regexp when host_regexp = default_re_string -> + [default_re_string, default_re, port] + | None -> + [default_re_string, default_re, port] + | Some host_regexp -> + [host_regexp, Ocsigen_lib.Netstring_pcre.regexp host_regexp, port] + in + let vh = { + vh_list ; + vh_config_info = config_info ; + vh_config_map = Hmap.empty ; + vh_fun_l = [] + } in + l := vh :: !l; + vh + + let dump () = + let f { vh_list ; vh_config_info ; vh_config_map ; vh_fun_l } = + vh_list, + vh_config_info, + List.nth vh_fun_l 0 {accessor = fun k -> Hmap.find k vh_config_map} + and l = + List.filter + (function {vh_fun_l = _ :: _} -> true | _ -> false) + !l + in + set_hosts (List.map f l) + + module Config = struct + + type nonrec accessor = accessor = + { accessor : 'a . 'a Hmap.key -> 'a option } + + type 'a key = 'a config_key + + let key () = Hmap.Key.create () + + let do_ ({vh_config_map} as vh) f = + vh.vh_config_map <- f vh_config_map + + let find {vh_config_map} k = Hmap.find k vh_config_map + + let set vh k v = do_ vh (Hmap.add k v) + + let unset vh k = do_ vh (Hmap.rem k) + + end + + let register ({vh_fun_l} as vh) f = vh.vh_fun_l <- f :: vh_fun_l + +end + let register_without_xml_config ?(config_info = default_config_info ()) ?(host_regexp = ".*") diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index d643df912..994f9d4ba 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -452,6 +452,40 @@ val sslsockets : Lwt_unix.file_descr list ref val set_we_have_xml_config : unit -> unit +module Virtual_host : sig + + type t + + module Config : sig + + type 'a key + + val key : unit -> 'a key + + val find : t -> 'a key -> 'a option + + val set : t -> 'a key -> 'a -> unit + + val unset : t -> 'a key -> unit + + type accessor = { accessor : 'a . 'a key -> 'a option } + + end + + val create : + ?config_info:config_info -> + ?host_regexp:string -> + ?port:int -> + unit -> t + + val register : t -> (Config.accessor -> extension2) -> unit + + (**/**) + + val dump : unit -> unit + +end + val register_without_xml_config : ?config_info:config_info -> ?host_regexp:string -> diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index 838679d63..b1732aa90 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -293,7 +293,11 @@ let start ?config () = Ocsigen_extensions.start_initialisation (); - Ocsigen_lib.Option.iter Ocsigen_parseconfig.later_pass s; + (match s with + | Some s -> + Ocsigen_parseconfig.later_pass s + | None -> + Ocsigen_extensions.Virtual_host.dump ()); Dynlink_wrapper.prohibit ["Ocsigen_extensions.R"]; (* As libraries are reloaded each time the config file is read, From 984d95e8c250687a8cea6d2ef2b4a689186b62cc Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 26 May 2017 20:10:00 +0200 Subject: [PATCH 077/111] Refactor Ocsigen_extensions in an effort to understand it Also properly implement composition of extensions via the Virtual_host API. --- src/extensions/staticmod.ml | 5 +- src/server/ocsigen_extensions.ml | 549 +++++++++++++++--------------- src/server/ocsigen_extensions.mli | 23 +- 3 files changed, 281 insertions(+), 296 deletions(-) diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index e79ef19eb..836b39f6a 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -318,11 +318,10 @@ let opt_root_checks = Ocsigen_extensions.Virtual_host.Config.key () let register vh = Ocsigen_extensions.Virtual_host.register vh - (fun {Ocsigen_extensions.Virtual_host.Config.accessor} cookies r -> + (fun {Ocsigen_extensions.Virtual_host.Config.accessor} r -> let kind = kind (accessor dir) (accessor regexp) (accessor opt_code) (accessor opt_dest) (accessor opt_root_checks) in - gen ~usermode:None kind r >|= fun response -> - response, cookies) + gen ~usermode:None kind r) diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 427101d43..23d64cf9a 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -52,7 +52,6 @@ type file_info = Ocsigen_multipart.file_info = { let badconfig fmt = Printf.ksprintf (fun s -> raise (Error_in_config_file s)) fmt -(*****************************************************************************) (* virtual hosts: *) type virtual_hosts = (string * Pcre.regexp * int option) list @@ -70,8 +69,6 @@ let rec equal_virtual_hosts (l1 : virtual_hosts) (l2 : virtual_hosts) = | (s1, _, p1) :: q1, (s2, _, p2) :: q2 -> s1 = s2 && p1 = p2 && equal_virtual_hosts q1 q2 -(*****************************************************************************) - (* Server configuration, for local files that must not be sent *) type do_not_serve = { @@ -250,12 +247,12 @@ type answer = these cookies yourself in request if you want them to be seen by subsequent extensions, for example using {!Ocsigen_http_frame.compute_new_ri_cookies}. *) - | Ext_sub_result of extension2 + | Ext_sub_result of extension_composite (** Used if your extension want to define option that may contain other options from other extensions. In that case, while parsing the configuration file, call the parsing function (of type [parse_fun]), that will return something of type - [extension2]. *) + [extension_composite]. *) | Ext_found_continue_with of (unit -> (Ocsigen_response.t * request) Lwt.t) (** Same as [Ext_found] but may modify the request. *) @@ -268,22 +265,23 @@ and request_state = | Req_not_found of (Cohttp.Code.status * request) | Req_found of (request * Ocsigen_response.t) -and extension2 = +and extension_composite = Ocsigen_cookies.cookieset -> request_state -> (answer * Ocsigen_cookies.cookieset) Lwt.t type extension = request_state -> answer Lwt.t -type parse_fun = Xml.xml list -> extension2 +type parse_fun = Xml.xml list -> extension_composite type parse_host = Parse_host of (Url.path -> parse_host -> parse_fun -> Xml.xml -> extension) -let (hosts : (virtual_hosts * config_info * extension2) list ref) = - ref [] +let hosts + : (virtual_hosts * config_info * extension_composite) list ref + = ref [] let set_hosts v = hosts := v let get_hosts () = !hosts @@ -332,14 +330,11 @@ let new_url_of_directory_request request ri = ~query:(Ocsigen_request.get_params ri) () -(*****************************************************************************) (* To give parameters to extensions: *) let dynlinkconfig = ref ([] : Xml.xml list) let set_config s = dynlinkconfig := s let get_config () = !dynlinkconfig - -(*****************************************************************************) let site_match request (site_path : string list) url = (* We are sure that there is no / at the end or beginning of site_path *) (* and no / at the beginning of url *) @@ -357,186 +352,99 @@ let site_match request (site_path : string list) url = | [], [] -> Some [] | _ -> aux site_path url -let make_ext cookies_to_set req_state (genfun : extension) (genfun2 : extension2) = - genfun req_state - >>= fun res -> - let rec aux cookies_to_set = function - | Ext_do_nothing -> genfun2 cookies_to_set req_state - | Ext_found r -> - r () >>= fun r' -> - let ri = match req_state with - | Req_found (ri, _) -> ri - | Req_not_found (_, ri) -> ri - in - genfun2 - Ocsigen_cookies.Cookies.empty - (Req_found (ri, Ocsigen_response.add_cookies r' cookies_to_set)) - | Ext_found_continue_with r -> - r () >>= fun (r', req) -> - genfun2 - Ocsigen_cookies.Cookies.empty - (Req_found (req, Ocsigen_response.add_cookies r' cookies_to_set)) - | Ext_found_continue_with' (r', req) -> - genfun2 - Ocsigen_cookies.Cookies.empty - (Req_found (req, Ocsigen_response.add_cookies r' cookies_to_set)) - | Ext_next e -> - let ri = match req_state with - | Req_found (ri, _) -> ri - | Req_not_found (_, ri) -> ri - in - genfun2 cookies_to_set (Req_not_found (e, ri)) - | Ext_continue_with (ri, cook, e) -> - genfun2 - (Ocsigen_cookies.add_cookies cook cookies_to_set) - (Req_not_found (e, ri)) - | Ext_found_stop _ - | Ext_stop_site _ - | Ext_stop_host _ - | Ext_stop_all _ - | Ext_retry_with _ as res -> - Lwt.return (res, cookies_to_set) - | Ext_sub_result sr -> - sr cookies_to_set req_state - >>= fun (res, cookies_to_set) -> - aux cookies_to_set res - in - aux cookies_to_set res +let default_extension_composite : extension_composite = + fun cookies_to_set -> function + | Req_found (ri, res) -> + Lwt.return (Ext_found_continue_with' (res, ri), cookies_to_set) + | Req_not_found (e, ri) -> + Lwt.return + (Ext_continue_with + (ri, Ocsigen_cookies.Cookies.empty, e), cookies_to_set) + +let compose_step (f : extension) (g : extension_composite) + : extension_composite + = fun cookies_to_set req_state -> + f req_state >>= fun res -> + let rec aux cookies_to_set = function + | Ext_do_nothing -> + g cookies_to_set req_state + | Ext_found r -> + r () >>= fun r' -> + let ri = match req_state with + | Req_found (ri, _) -> ri + | Req_not_found (_, ri) -> ri + in + g Ocsigen_cookies.Cookies.empty + (Req_found (ri, Ocsigen_response.add_cookies r' cookies_to_set)) + | Ext_found_continue_with r -> + r () >>= fun (r', req) -> + g Ocsigen_cookies.Cookies.empty + (Req_found (req, Ocsigen_response.add_cookies r' cookies_to_set)) + | Ext_found_continue_with' (r', req) -> + g Ocsigen_cookies.Cookies.empty + (Req_found (req, Ocsigen_response.add_cookies r' cookies_to_set)) + | Ext_next e -> + let ri = match req_state with + | Req_found (ri, _) -> ri + | Req_not_found (_, ri) -> ri + in + g cookies_to_set (Req_not_found (e, ri)) + | Ext_continue_with (ri, cook, e) -> + g (Ocsigen_cookies.add_cookies cook cookies_to_set) + (Req_not_found (e, ri)) + | Ext_found_stop _ + | Ext_stop_site _ + | Ext_stop_host _ + | Ext_stop_all _ + | Ext_retry_with _ as res -> + Lwt.return (res, cookies_to_set) + | Ext_sub_result sr -> + sr cookies_to_set req_state >>= fun (res, cookies_to_set) -> + aux cookies_to_set res + in + aux cookies_to_set res + +let rec compose = function + | [] -> + default_extension_composite + | e :: rest -> + compose_step e (compose rest) let fun_end = ref (fun () -> ()) let fun_exn = ref (fun exn -> (raise exn : string)) -let rec default_parse_config - userconf_info - (host : virtual_hosts) - config_info - prevpath - (Parse_host parse_host) - (parse_fun : parse_fun) = function - | Xml.Element ("site", atts, l) -> - let rec parse_site_attrs (enc,dir) = function - | [] -> (match dir with - | None -> - raise (Ocsigen_config.Config_file_error - ("Missing dir attribute in ")) - | Some s -> (enc, s)) - | ("path", s)::suite - | ("dir", s)::suite -> - (match dir with - | None -> parse_site_attrs (enc, Some s) suite - | _ -> raise (Ocsigen_config.Config_file_error - ("Duplicate attribute dir in "))) - | ("charset", s)::suite -> - (match enc with - | None -> parse_site_attrs ((Some s), dir) suite - | _ -> raise (Ocsigen_config.Config_file_error - ("Duplicate attribute charset in "))) - | (s, _)::_ -> - raise - (Ocsigen_config.Config_file_error ("Wrong attribute for : "^s)) - in - let charset, dir = parse_site_attrs (None, None) atts in - let path = - prevpath@ - Url.remove_slash_at_end - (Url.remove_slash_at_beginning - (Url.remove_dotdot (Ocsigen_lib.Url.split_path dir))) - in - let parse_config = make_parse_config path parse_host l in - let ext cookies_to_set = - function - | Req_found (ri, res) -> - Lwt.return (Ext_found_continue_with' (res, ri), cookies_to_set) - | Req_not_found (e, oldri) -> - let oldri = match charset with - | None -> oldri - | Some charset -> - { oldri with request_config = - { oldri.request_config with charset_assoc = - Ocsigen_charset_mime.set_default_charset - oldri.request_config.charset_assoc charset } } - in - match - site_match oldri path - (Ocsigen_request.path oldri.request_info) - with - | None -> - Lwt_log.ign_info_f ~section - "site \"%a\" does not match url \"%a\"." - (fun () path -> - Url.string_of_url_path ~encode:true path) path - (fun () oldri -> - Url.string_of_url_path ~encode:true - (Ocsigen_request.path oldri.request_info)) - oldri; - Lwt.return (Ext_next e, cookies_to_set) - | Some sub_path -> - Lwt_log.ign_info_f ~section - "site found: url \"%a\" matches \"%a\"." - (fun () oldri -> - Url.string_of_url_path ~encode:true - (Ocsigen_request.path oldri.request_info)) - oldri - (fun () path -> Url.string_of_url_path ~encode:true path) path; - let ri = - {oldri with - request_info = - Ocsigen_request.update oldri.request_info - ~sub_path: - (Url.string_of_url_path ~encode:true sub_path) - } in - parse_config cookies_to_set (Req_not_found (e, ri)) - >>= function - (* After a site, we turn back to old ri *) - | (Ext_stop_site (cs, err), cookies_to_set) - | (Ext_continue_with (_, cs, err), cookies_to_set) -> - Lwt.return - (Ext_continue_with (oldri, cs, err), cookies_to_set) - | (Ext_found_continue_with r, cookies_to_set) -> - r () >>= fun (r', req) -> - Lwt.return - (Ext_found_continue_with' (r', oldri), cookies_to_set) - | (Ext_found_continue_with' (r, req), cookies_to_set) -> - Lwt.return - (Ext_found_continue_with' (r, oldri), cookies_to_set) - | (Ext_do_nothing, cookies_to_set) -> - Lwt.return - (Ext_continue_with (oldri, - Ocsigen_cookies.Cookies.empty, - e), cookies_to_set) - | r -> Lwt.return r - in - (function - | Req_found (ri, r) -> - Lwt.return (Ext_found_continue_with' (r, ri)) - | Req_not_found (err, ri) -> - Lwt.return (Ext_sub_result ext)) - | Xml.Element (tag,_,_) -> - raise (Bad_config_tag_for_extension tag) - | _ -> raise (Ocsigen_config.Config_file_error - ("Unexpected content inside ")) - -and make_parse_config path parse_host l : extension2 = +let rec parse_site_attrs (enc, dir) = function + | [] -> + (match dir with + | None -> + raise (Ocsigen_config.Config_file_error + ("Missing dir attribute in ")) + | Some s -> enc, s) + | ("path", s) :: rest | ("dir", s) :: rest -> + (match dir with + | None -> parse_site_attrs (enc, Some s) rest + | _ -> + raise (Ocsigen_config.Config_file_error + ("Duplicate attribute dir in "))) + | ("charset", s) :: rest -> + (match enc with + | None -> parse_site_attrs ((Some s), dir) rest + | _ -> + raise (Ocsigen_config.Config_file_error + ("Duplicate attribute charset in "))) + | (s, _) :: _ -> + raise + (Ocsigen_config.Config_file_error ("Wrong attribute for : "^s)) + +let make_parse_config path parse_host l : extension_composite = let f = parse_host path (Parse_host parse_host) in (* creates all site data, if any *) - let rec parse_config : _ -> extension2 = function + let rec parse_config : _ -> extension_composite = function | [] -> - (fun cookies_to_set -> function - | Req_found (ri, res) -> - Lwt.return (Ext_found_continue_with' (res, ri), cookies_to_set) - | Req_not_found (e, ri) -> - Lwt.return - (Ext_continue_with - (ri, Ocsigen_cookies.Cookies.empty, e), cookies_to_set)) - (* was Lwt.return (Ext_next e, cookies_to_set)), but to use - make_parse_site with userconf, we need to know current ri after - parsing the sub-configuration. *) - | xmltag::ll -> + default_extension_composite + | xmltag :: ll -> try - let genfun = f parse_config xmltag in - let genfun2 = parse_config ll in - fun cookies_to_set req_state -> - make_ext cookies_to_set req_state genfun genfun2 + compose_step (f parse_config xmltag) (parse_config ll) with | Bad_config_tag_for_extension t -> (* This case happens only if no extension has recognized the @@ -555,14 +463,110 @@ and make_parse_config path parse_host l : extension2 = try parse_config l with e -> !fun_end (); raise e - (*VVV May be we should avoid calling fun_end after parinf user config files - (with extension userconf) ... See eliommod.ml - *) + (*VVV Maybe we should avoid calling fun_end after parsing user + config files (with extension userconf) ... See eliommod.ml *) in !fun_end (); r -(*****************************************************************************) +let site_ext ext_of_children charset path cookies_to_set = function + | Req_found (ri, res) -> + Lwt.return (Ext_found_continue_with' (res, ri), cookies_to_set) + | Req_not_found (e, oldri) -> + let oldri = match charset with + | None -> oldri + | Some charset -> + { oldri with + request_config = + { oldri.request_config with + charset_assoc = + Ocsigen_charset_mime.set_default_charset + oldri.request_config.charset_assoc charset + } + } + in + match + site_match oldri path + (Ocsigen_request.path oldri.request_info) + with + | None -> + Lwt_log.ign_info_f ~section + "site \"%a\" does not match url \"%a\"." + (fun () path -> + Url.string_of_url_path ~encode:true path) path + (fun () oldri -> + Url.string_of_url_path ~encode:true + (Ocsigen_request.path oldri.request_info)) + oldri; + Lwt.return (Ext_next e, cookies_to_set) + | Some sub_path -> + Lwt_log.ign_info_f ~section + "site found: url \"%a\" matches \"%a\"." + (fun () oldri -> + Url.string_of_url_path ~encode:true + (Ocsigen_request.path oldri.request_info)) + oldri + (fun () path -> Url.string_of_url_path ~encode:true path) path; + let ri = + { oldri with + request_info = + Ocsigen_request.update oldri.request_info + ~sub_path: + (Url.string_of_url_path ~encode:true sub_path) + } in + ext_of_children cookies_to_set (Req_not_found (e, ri)) >>= function + (* After a site, we turn back to old ri *) + | (Ext_stop_site (cs, err), cookies_to_set) + | (Ext_continue_with (_, cs, err), cookies_to_set) -> + Lwt.return + (Ext_continue_with (oldri, cs, err), cookies_to_set) + | (Ext_found_continue_with r, cookies_to_set) -> + r () >>= fun (r', req) -> + Lwt.return + (Ext_found_continue_with' (r', oldri), cookies_to_set) + | (Ext_found_continue_with' (r, req), cookies_to_set) -> + Lwt.return + (Ext_found_continue_with' (r, oldri), cookies_to_set) + | (Ext_do_nothing, cookies_to_set) -> + Lwt.return + (Ext_continue_with + (oldri, + Ocsigen_cookies.Cookies.empty, + e), cookies_to_set) + | r -> + Lwt.return r + +let site_ext ext_of_children charset path : extension = function + | Req_found (ri, r) -> + Lwt.return (Ext_found_continue_with' (r, ri)) + | Req_not_found (err, ri) -> + Lwt.return (Ext_sub_result (site_ext ext_of_children charset path)) + +(* Implements only parsing. Uses parse_host to recursively + parse children of . *) +let default_parse_config + userconf_info + (host : virtual_hosts) + config_info + prevpath + (Parse_host parse_host) + (parse_fun : parse_fun) = function + | Xml.Element ("site", atts, l) -> + let charset, dir = parse_site_attrs (None, None) atts in + let path = + prevpath @ + Url.( + split_path dir + |> remove_dotdot + |> remove_slash_at_beginning + |> remove_slash_at_end) + in + let ext_of_children = make_parse_config path parse_host l in + site_ext ext_of_children charset path + | Xml.Element (tag,_,_) -> + raise (Bad_config_tag_for_extension tag) + | _ -> raise (Ocsigen_config.Config_file_error + ("Unexpected content inside ")) type userconf_info = { localfiles_root : string; @@ -617,9 +621,8 @@ let register, parse_config_item, get_init_exn_handler = let curexnfun = !fun_exn in fun_exn := fun e -> try curexnfun e with e -> exn_handler e), - (fun host conf -> !ref_fun_site host conf), + (fun path host conf -> !ref_fun_site path host conf), - (* ********* get_init_exn_handler ********* *) (fun () -> !fun_exn) let default_parse_extension ext_name = function @@ -652,7 +655,7 @@ module Virtual_host = struct vh_list : virtual_hosts ; vh_config_info : config_info ; mutable vh_config_map : Hmap.t ; - mutable vh_fun_l : (accessor -> extension2) list ; + mutable vh_fun_l : (accessor -> extension) list ; } let l = ref [] @@ -687,11 +690,14 @@ module Virtual_host = struct let f { vh_list ; vh_config_info ; vh_config_map ; vh_fun_l } = vh_list, vh_config_info, - List.nth vh_fun_l 0 {accessor = fun k -> Hmap.find k vh_config_map} + compose + (List.map + (fun f -> f {accessor = fun k -> Hmap.find k vh_config_map}) + vh_fun_l) and l = List.filter (function {vh_fun_l = _ :: _} -> true | _ -> false) - !l + (List.rev !l) in set_hosts (List.map f l) @@ -719,19 +725,6 @@ module Virtual_host = struct end -let register_without_xml_config - ?(config_info = default_config_info ()) - ?(host_regexp = ".*") - ?port - f = - if not (we_have_xml_config ()) then - let virtual_hosts = - (* TODO : dedup virtual_hosts ? *) - [host_regexp, - Ocsigen_lib.Netstring_pcre.regexp host_regexp, port] - in - set_hosts ((virtual_hosts, config_info, f) :: get_hosts ()) - module Configuration = struct type attribute' = { @@ -861,8 +854,6 @@ module Configuration = struct end - -(*****************************************************************************) let start_initialisation, during_initialisation, end_initialisation, get_numberofreloads = let init = ref true in @@ -877,9 +868,6 @@ let start_initialisation, during_initialisation, ), (fun () -> !nb)) -(********) - - let host_match ~(virtual_hosts : virtual_hosts) ~host ~port = let port_match = function | None -> true @@ -898,8 +886,6 @@ let host_match ~(virtual_hosts : virtual_hosts) ~host ~port = in aux virtual_hosts - - (* Currently used only for error messages. *) let string_of_host (h : virtual_hosts) = let aux1 (host, _, port) = @@ -908,83 +894,88 @@ let string_of_host (h : virtual_hosts) = | Some p -> host ^ ":" ^ string_of_int p in List.fold_left (fun d arg -> d ^ aux1 arg ^" ") "" h -let compute_result ?(previous_cookies = Ocsigen_cookies.Cookies.empty) ri = +let compute_result + ?(previous_cookies = Ocsigen_cookies.Cookies.empty) + request_info = - let host = Ocsigen_request.host ri - and port = Ocsigen_request.port ri in + let host = Ocsigen_request.host request_info + and port = Ocsigen_request.port request_info in let string_of_host_option = function | None -> ":"^(string_of_int port) | Some h -> h^":"^(string_of_int port) in - let rec do2 sites cookies_to_set ri = - Ocsigen_request.incr_tries ri; - if Ocsigen_request.tries ri > Ocsigen_config.get_maxretries () then + let rec fold_hosts + request_info + (prev_err : Cohttp.Code.status) + cookies_to_set = + function + | [] -> + Lwt.fail (Ocsigen_http_error (cookies_to_set, prev_err)) + | (virtual_hosts, request_config, host_function) :: l when + host_match ~virtual_hosts ~host ~port -> + Lwt_log.ign_info_f ~section + "host found! %a matches %a" + (fun () -> string_of_host_option) host + (fun () -> string_of_host) virtual_hosts; + host_function + cookies_to_set + (Req_not_found (prev_err, { request_info ; request_config })) + >>= fun (res_ext, cookies_to_set) -> + (match res_ext with + | Ext_found r + | Ext_found_stop r -> + r () >>= fun r' -> + Lwt.return (Ocsigen_response.add_cookies r' cookies_to_set) + | Ext_do_nothing -> + fold_hosts request_info prev_err cookies_to_set l + | Ext_found_continue_with r -> + r () >>= fun (r', _) -> + Lwt.return (Ocsigen_response.add_cookies r' cookies_to_set) + | Ext_found_continue_with' (r, _) -> + Lwt.return (Ocsigen_response.add_cookies r cookies_to_set) + | Ext_next e -> + fold_hosts request_info e cookies_to_set l + (* try next site *) + | Ext_stop_host (cook, e) + | Ext_stop_site (cook, e) -> + fold_hosts request_info e + (Ocsigen_cookies.add_cookies cook cookies_to_set) l + (* try next site *) + | Ext_stop_all (cook, e) -> + Lwt.fail (Ocsigen_http_error (cookies_to_set, e)) + | Ext_continue_with (_, cook, e) -> + fold_hosts request_info e + (Ocsigen_cookies.add_cookies cook cookies_to_set) l + | Ext_retry_with (request2, cook) -> + fold_hosts_limited + (get_hosts ()) + (Ocsigen_cookies.add_cookies cook cookies_to_set) + request2.request_info + (* retry all *) + | Ext_sub_result sr -> + assert false + ) + | (h, _, _)::l -> + Lwt_log.ign_info_f ~section + "host = %a does not match %a" + (fun () -> string_of_host_option) host + (fun () -> string_of_host) h; + fold_hosts request_info prev_err cookies_to_set l + + and fold_hosts_limited sites cookies_to_set request_info = + Ocsigen_request.incr_tries request_info; + if + Ocsigen_request.tries request_info > + Ocsigen_config.get_maxretries () + then Lwt.fail Ocsigen_Looping_request else - let rec aux_host - ri - (prev_err : Cohttp.Code.status) - cookies_to_set = - function - | [] -> Lwt.fail (Ocsigen_http_error (cookies_to_set, prev_err)) - | (h, conf_info, host_function)::l when - host_match ~virtual_hosts:h ~host ~port -> - Lwt_log.ign_info_f ~section - "host found! %a matches %a" - (fun () -> string_of_host_option) host - (fun () -> string_of_host) h; - host_function - cookies_to_set - (Req_not_found (prev_err, { request_info = ri; - request_config = conf_info })) - >>= fun (res_ext, cookies_to_set) -> - (match res_ext with - | Ext_found r - | Ext_found_stop r -> - r () >>= fun r' -> - Lwt.return (Ocsigen_response.add_cookies r' cookies_to_set) - | Ext_do_nothing -> - aux_host ri prev_err cookies_to_set l - | Ext_found_continue_with r -> - r () >>= fun (r', _) -> - Lwt.return (Ocsigen_response.add_cookies r' cookies_to_set) - | Ext_found_continue_with' (r, _) -> - Lwt.return (Ocsigen_response.add_cookies r cookies_to_set) - | Ext_next e -> - aux_host ri e cookies_to_set l - (* try next site *) - | Ext_stop_host (cook, e) - | Ext_stop_site (cook, e) -> - aux_host ri e (Ocsigen_cookies.add_cookies cook cookies_to_set) l - (* try next site *) - | Ext_stop_all (cook, e) -> - Lwt.fail (Ocsigen_http_error (cookies_to_set, e)) - | Ext_continue_with (_, cook, e) -> - aux_host ri e - (Ocsigen_cookies.add_cookies cook cookies_to_set) l - | Ext_retry_with (request2, cook) -> - do2 - (get_hosts ()) - (Ocsigen_cookies.add_cookies cook cookies_to_set) - request2.request_info - (* retry all *) - | Ext_sub_result sr -> - assert false - ) - | (h, _, _)::l -> - Lwt_log.ign_info_f ~section - "host = %a does not match %a" - (fun () -> string_of_host_option) host - (fun () -> string_of_host) h; - aux_host ri prev_err cookies_to_set l - in aux_host ri `Not_found cookies_to_set sites + fold_hosts request_info `Not_found cookies_to_set sites in - do2 (get_hosts ()) previous_cookies ri - -(*****************************************************************************) + fold_hosts_limited (get_hosts ()) previous_cookies request_info (* This is used by server.ml. I put that here because I need it to be accessible for profiling. *) diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 994f9d4ba..ba33ead4c 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -168,12 +168,12 @@ type answer = these cookies yourself in request if you want them to be seen by subsequent extensions, for example using {!Ocsigen_http_frame.compute_new_ri_cookies}. *) - | Ext_sub_result of extension2 + | Ext_sub_result of extension_composite (** Used if your extension want to define option that may contain other options from other extensions. In that case, while parsing the configuration file, call the parsing function (of type [parse_fun]), that will return something of type - [extension2]. *) + [extension_composite]. *) | Ext_found_continue_with of (unit -> (Ocsigen_response.t * request) Lwt.t) (** Same as [Ext_found] but may modify the request. *) @@ -187,7 +187,7 @@ and request_state = | Req_not_found of (Cohttp.Code.status * request) | Req_found of (request * Ocsigen_response.t) -and extension2 = +and extension_composite = Ocsigen_cookies.cookieset -> request_state -> (answer * Ocsigen_cookies.cookieset) Lwt.t @@ -206,7 +206,7 @@ type extension = request_state -> answer Lwt.t the extension may want to modify the result (filters). *) -type parse_fun = Xml.xml list -> extension2 +type parse_fun = Xml.xml list -> extension_composite (** Type of the functions parsing the content of a tag *) type parse_host @@ -417,9 +417,11 @@ val make_parse_config : val parse_config_item : parse_config -val set_hosts : (virtual_hosts * config_info * extension2) list -> unit +val set_hosts : + (virtual_hosts * config_info * extension_composite) list -> unit -val get_hosts : unit -> (virtual_hosts * config_info * extension2) list +val get_hosts : + unit -> (virtual_hosts * config_info * extension_composite) list (** Compute the answer to be sent to the client, by trying all extensions according the configuration file. *) @@ -478,17 +480,10 @@ module Virtual_host : sig ?port:int -> unit -> t - val register : t -> (Config.accessor -> extension2) -> unit + val register : t -> (Config.accessor -> extension) -> unit (**/**) val dump : unit -> unit end - -val register_without_xml_config : - ?config_info:config_info -> - ?host_regexp:string -> - ?port:int -> - extension2 -> - unit From c95aa21f8d503faaede482e3882e65b26f78867b Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Sat, 27 May 2017 00:38:24 +0200 Subject: [PATCH 078/111] Enable site definition via Ocsigen_extensions.Site --- src/server/ocsigen_extensions.ml | 122 +++++++++++++++++++++++------- src/server/ocsigen_extensions.mli | 40 +++++++--- 2 files changed, 123 insertions(+), 39 deletions(-) diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 23d64cf9a..a19bb9284 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -542,6 +542,12 @@ let site_ext ext_of_children charset path : extension = function | Req_not_found (err, ri) -> Lwt.return (Ext_sub_result (site_ext ext_of_children charset path)) +let preprocess_site_path p = Url.( + remove_dotdot p + |> remove_slash_at_beginning + |> remove_slash_at_end +) + (* Implements only parsing. Uses parse_host to recursively parse children of . *) let default_parse_config @@ -553,14 +559,7 @@ let default_parse_config (parse_fun : parse_fun) = function | Xml.Element ("site", atts, l) -> let charset, dir = parse_site_attrs (None, None) atts in - let path = - prevpath @ - Url.( - split_path dir - |> remove_dotdot - |> remove_slash_at_beginning - |> remove_slash_at_end) - in + let path = prevpath @ preprocess_site_path (Url.split_path dir) in let ext_of_children = make_parse_config path parse_host l in site_ext ext_of_children charset path | Xml.Element (tag,_,_) -> @@ -645,12 +644,58 @@ let register | Some f -> f (get_config ())); register ?fun_site ?end_init ?exn_handler ?respect_pipeline ()) +type accessor = + { accessor : 'a . 'a Hmap.key -> 'a option } + +let compose_with_config m l = + compose (List.map (fun f -> f {accessor = fun k -> Hmap.find k m}) l) + +module type Hmap_wrapped = sig + type t + val get : t -> Hmap.t + val do_ : t -> (Hmap.t -> Hmap.t) -> unit +end + +module type Config_nested = sig + + type parent_t + + type 'a key + + val key : unit -> 'a key + + val find : parent_t -> 'a key -> 'a option + + val set : parent_t -> 'a key -> 'a -> unit + + val unset : parent_t -> 'a key -> unit + + type accessor = { accessor : 'a . 'a key -> 'a option } + +end + +module Make_config_nested (W : Hmap_wrapped) = struct + + type nonrec accessor + = accessor + = { accessor : 'a . 'a Hmap.key -> 'a option } + + type 'a key = 'a Hmap.key + + let key () = Hmap.Key.create () + + let find w k = Hmap.find k (W.get w) + + let set w k v = W.do_ w (Hmap.add k v) + + let unset w k = W.do_ w (Hmap.rem k) + +end + module Virtual_host = struct type 'a config_key = 'a Hmap.key - type accessor = { accessor : 'a . 'a Hmap.key -> 'a option } - type t = { vh_list : virtual_hosts ; vh_config_info : config_info ; @@ -690,10 +735,7 @@ module Virtual_host = struct let f { vh_list ; vh_config_info ; vh_config_map ; vh_fun_l } = vh_list, vh_config_info, - compose - (List.map - (fun f -> f {accessor = fun k -> Hmap.find k vh_config_map}) - vh_fun_l) + compose_with_config vh_config_map vh_fun_l and l = List.filter (function {vh_fun_l = _ :: _} -> true | _ -> false) @@ -701,27 +743,49 @@ module Virtual_host = struct in set_hosts (List.map f l) - module Config = struct + module Config = + Make_config_nested (struct + type nonrec t = t + let get {vh_config_map} = vh_config_map + let do_ ({vh_config_map} as vh) f = + vh.vh_config_map <- f vh_config_map + end) - type nonrec accessor = accessor = - { accessor : 'a . 'a Hmap.key -> 'a option } - - type 'a key = 'a config_key - - let key () = Hmap.Key.create () - - let do_ ({vh_config_map} as vh) f = - vh.vh_config_map <- f vh_config_map + let register ({vh_fun_l} as vh) f = vh.vh_fun_l <- f :: vh_fun_l - let find {vh_config_map} k = Hmap.find k vh_config_map +end - let set vh k v = do_ vh (Hmap.add k v) +module Site = struct - let unset vh k = do_ vh (Hmap.rem k) + type t = { + s_dir : string list ; + s_charset : Ocsigen_charset_mime.charset option ; + mutable s_config_map : Hmap.t ; + mutable s_fun_l : (accessor -> extension) list ; + } - end + let create s_dir s_charset = { + s_dir = preprocess_site_path s_dir ; + s_charset ; + s_config_map = Hmap.empty ; + s_fun_l = [] + } - let register ({vh_fun_l} as vh) f = vh.vh_fun_l <- f :: vh_fun_l + module Config = + Make_config_nested (struct + type nonrec t = t + let get {s_config_map} = s_config_map + let do_ ({s_config_map} as s) f = + s.s_config_map <- f s_config_map + end) + + let register ({s_fun_l} as s) f = s.s_fun_l <- f :: s_fun_l + + let to_extension + ~parent_path + {s_dir ; s_charset ; s_fun_l ; s_config_map} = + let ext_of_children = compose_with_config s_config_map s_fun_l in + site_ext ext_of_children s_charset (parent_path @ s_dir) end diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index ba33ead4c..98076df6b 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -454,25 +454,27 @@ val sslsockets : Lwt_unix.file_descr list ref val set_we_have_xml_config : unit -> unit -module Virtual_host : sig +module type Config_nested = sig - type t + type parent_t - module Config : sig + type 'a key - type 'a key + val key : unit -> 'a key - val key : unit -> 'a key + val find : parent_t -> 'a key -> 'a option - val find : t -> 'a key -> 'a option + val set : parent_t -> 'a key -> 'a -> unit - val set : t -> 'a key -> 'a -> unit + val unset : parent_t -> 'a key -> unit - val unset : t -> 'a key -> unit + type accessor = { accessor : 'a . 'a key -> 'a option } - type accessor = { accessor : 'a . 'a key -> 'a option } +end - end +module Virtual_host : sig + + type t val create : ?config_info:config_info -> @@ -480,6 +482,8 @@ module Virtual_host : sig ?port:int -> unit -> t + module Config : Config_nested with type parent_t := t + val register : t -> (Config.accessor -> extension) -> unit (**/**) @@ -487,3 +491,19 @@ module Virtual_host : sig val dump : unit -> unit end + +module Site : sig + + type t + + val create : string list -> Ocsigen_charset_mime.charset option -> t + + module Config : Config_nested + with type parent_t := t + and type 'a key = 'a Virtual_host.Config.key + + val register : t -> (Config.accessor -> extension) -> unit + + val to_extension : parent_path:string list -> t -> extension + +end From 3b162ca77f24ea006a240d10923f6625fe9cfd2c Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 29 May 2017 15:17:01 +0200 Subject: [PATCH 079/111] Add Hmap-based Ocsigen_config.Custom for use by top-level extension configuration. --- src/baselib/Makefile | 1 + src/baselib/ocsigen_config.ml | 25 +++++++++++++++++++++++++ src/baselib/ocsigen_config.mli | 14 ++++++++++++++ 3 files changed, 40 insertions(+) diff --git a/src/baselib/Makefile b/src/baselib/Makefile index 026561fc9..48291a9af 100644 --- a/src/baselib/Makefile +++ b/src/baselib/Makefile @@ -7,6 +7,7 @@ PACKAGE := \ findlib \ pcre \ ${LWT_PREEMPTIVE_PACKAGE} \ + hmap \ ipaddr LIBS := ${addprefix -package ,${PACKAGE}} diff --git a/src/baselib/ocsigen_config.ml b/src/baselib/ocsigen_config.ml index 03e3a8694..f41aede41 100644 --- a/src/baselib/ocsigen_config.ml +++ b/src/baselib/ocsigen_config.ml @@ -191,3 +191,28 @@ let display_version () = print_string version_number; print_newline (); exit 0 + +module Custom = struct + + let m = ref Hmap.empty + + (* TODO : two type variables? *) + type 'a key = ('a -> 'a) option * 'a Hmap.key + + let key ?preprocess () = preprocess, Hmap.Key.create () + + let find (_, k) = Hmap.find k !m + + let set (f, k) v = + let v = + match f with + | Some f -> + f v + | None -> + v + in + m := Hmap.add k v !m + + let unset (_, k) = m := Hmap.rem k !m + +end diff --git a/src/baselib/ocsigen_config.mli b/src/baselib/ocsigen_config.mli index 3b9a3a6cd..29b9114f7 100644 --- a/src/baselib/ocsigen_config.mli +++ b/src/baselib/ocsigen_config.mli @@ -148,3 +148,17 @@ val get_uploaddir : unit -> string option (* Same thing for upload size *) val set_maxuploadfilesize : int64 option -> unit val get_maxuploadfilesize : unit -> int64 option + +module Custom : sig + + type 'a key + + val key : ?preprocess:('a -> 'a) -> unit -> 'a key + + val find : 'a key -> 'a option + + val set : 'a key -> 'a -> unit + + val unset : 'a key -> unit + +end From 48f449c7600e350ad4fe1a801a4202fd12665a46 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 29 May 2017 16:24:57 +0200 Subject: [PATCH 080/111] Update Deflatemod for use without XML config --- src/Makefile.filelist | 3 +- src/extensions/.depend | 8 +- src/extensions/deflatemod.ml | 141 ++++++++++++++++++---------------- src/extensions/deflatemod.mli | 14 ++++ 4 files changed, 95 insertions(+), 71 deletions(-) create mode 100644 src/extensions/deflatemod.mli diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 7ffa82484..dc2b01789 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -54,7 +54,8 @@ endif PLUGINS_BIN := PLUGINS_INTF := extensions/authbasic.cmi extensions/accesscontrol.cmi \ - extensions/ocsipersist.cmi extensions/staticmod.cmi + extensions/ocsipersist.cmi extensions/staticmod.cmi \ + extensions/deflatemod.cmi PLUGINS_IMPL := extensions/accesscontrol.cmo extensions/authbasic.cmo \ extensions/cors.cmo extensions/outputfilter.cmo \ diff --git a/src/extensions/.depend b/src/extensions/.depend index 4e36e46b4..f40acaa8e 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -28,10 +28,14 @@ cors.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ ../server/ocsigen_extensions.cmx deflatemod.cmo : ../baselib/ocsigen_stream.cmi \ ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ - ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi + ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi \ + ../baselib/ocsigen_config.cmi deflatemod.cmi deflatemod.cmx : ../baselib/ocsigen_stream.cmx \ ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ - ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx + ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx \ + ../baselib/ocsigen_config.cmx deflatemod.cmi +deflatemod.cmi : ../server/ocsigen_extensions.cmi \ + ../baselib/ocsigen_config.cmi extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi \ ../http/ocsigen_cookies.cmi ../baselib/ocsigen_config.cmi \ diff --git a/src/extensions/deflatemod.ml b/src/extensions/deflatemod.ml index b76eb192c..06d2839b8 100644 --- a/src/extensions/deflatemod.ml +++ b/src/extensions/deflatemod.ml @@ -25,32 +25,35 @@ open Lwt.Infix let section = Lwt_log.Section.make "ocsigen:ext:deflate" (* Content-type *) -type filter = - | Type of string option * string option - | Extension of string +type filter = [ + | `Type of string option * string option + | `Extension of string +] -type compress_choice = - | All_but of filter list - | Compress_only of filter list +type mode = [ + | `All_but of filter list + | `Only of filter list +] let should_compress (t, t') url choice_list = let check = function - | Type (None, None) -> true - | Type (None, Some x') -> x' = t' - | Type (Some x, None) -> x = t - | Type (Some x, Some x') -> x = t && x' = t' - | Extension suff -> Filename.check_suffix url suff + | `Type (None, None) -> true + | `Type (None, Some x') -> x' = t' + | `Type (Some x, None) -> x = t + | `Type (Some x, Some x') -> x = t && x' = t' + | `Extension suff -> Filename.check_suffix url suff in match choice_list with - | Compress_only l -> List.exists check l - | All_but l -> List.for_all (fun c -> not (check c)) l + | `Only l -> List.exists check l + | `All_but l -> List.for_all (fun c -> not (check c)) l -(* Compression *) +let compress_level = + let preprocess i = if i >= 0 && i <= 9 then i else 6 in + Ocsigen_config.Custom.key ~preprocess () -let buffer_size = ref 8192 - -(* 0 = no compression ; 1 = best speed ; 9 = best compression *) -let compress_level = ref 6 +let buffer_size = + let preprocess s = if s > 0 then s else 8192 in + Ocsigen_config.Custom.key ~preprocess () (* Minimal header, by X. Leroy *) let gzip_header_length = 10 @@ -164,7 +167,12 @@ and next_cont oz stream = (* deflate param : true = deflate ; false = gzip (no header in this case) *) let compress deflate stream = - let zstream = Zlib.deflate_init !compress_level deflate in + let zstream = + Zlib.deflate_init + (Ocsigen_lib.Option.get' 6 + (Ocsigen_config.Custom.find compress_level)) + deflate + in let finalize status = Ocsigen_stream.finalize stream status >>= fun e -> (try @@ -174,10 +182,14 @@ let compress deflate stream = Zlib.Error _ -> ()); Lwt.return (Lwt_log.ign_info ~section "Zlib stream closed") in let oz = + let buffer_size = + Ocsigen_lib.Option.get' 8192 + (Ocsigen_config.Custom.find buffer_size) + in { stream = zstream ; - buf = Bytes.create !buffer_size; + buf = Bytes.create buffer_size ; pos = 0; - avail = !buffer_size; + avail = buffer_size ; size = 0l; crc = 0l; add_trailer = not deflate } in let new_stream () = next_cont oz (Ocsigen_stream.get stream) in @@ -188,11 +200,7 @@ let compress deflate stream = Ocsigen_stream.make ~finalize (fun () -> Ocsigen_stream.cont gzip_header new_stream) - -(*****************************************************************************) -(** The filter function *) (* We implement Content-Encoding, not Transfer-Encoding *) - type encoding = Deflate | Gzip | Id | Star | Not_acceptable let qvalue = function Some x -> x |None -> 1.0 @@ -313,44 +321,34 @@ let filter choice_list = function (Ocsigen_extensions.Ext_stop_all (Ocsigen_response.cookies res, `Not_acceptable)) - -(*****************************************************************************) - let rec parse_global_config = function | [] -> () - | (Xml.Element ("compress", [("level", l)], []))::ll -> - let l = try int_of_string l - with Failure _ -> raise (Ocsigen_extensions.Error_in_config_file - "Compress level should be an integer between 0 and 9") in - compress_level := if (l <= 9 && l >= 0) then l else 6 ; + | Xml.Element ("compress", ["level", i], []) :: ll -> + let i = + try + int_of_string i + with Failure _ -> + raise (Ocsigen_extensions.Error_in_config_file + "Compress level should be an integer between 0 and 9") + in + Ocsigen_config.Custom.set compress_level i; parse_global_config ll - | (Xml.Element ("buffer", [("size", s)], []))::ll -> - let s = (try int_of_string s - with Failure _ -> - raise (Ocsigen_extensions.Error_in_config_file - "Buffer size should be a positive integer")) in - buffer_size := if s > 0 then s else 8192 ; + | Xml.Element ("buffer", ["size", s], []) :: ll -> + let s = + try + int_of_string s + with Failure _ -> + raise (Ocsigen_extensions.Error_in_config_file + "Buffer size should be a positive integer") + in + Ocsigen_config.Custom.set buffer_size s; parse_global_config ll - (* TODO: Pas de filtre global pour l'instant - * le nom de balise contenttype est mauvais, au passage - | (Element ("contenttype", [("compress", b)], choices))::ll -> - let l = (try parse_filter choices - with Not_found -> raise (Error_in_config_file - "Can't parse mime-type content")) in - (match b with - |"only" -> choice_list := Compress_only l - |"allbut" -> choice_list := All_but l - | _ -> raise (Error_in_config_file - "Attribute \"compress\" should be \"allbut\" or \"only\"")); - parse_global_config ll - *) - | _ -> raise (Ocsigen_extensions.Error_in_config_file - "Unexpected content inside deflatemod config") - -(*****************************************************************************) + | _ -> + raise (Ocsigen_extensions.Error_in_config_file + "Unexpected content inside deflatemod config") let parse_config config_elem = - let mode = ref (Compress_only []) in + let mode = ref `Only in let pages = ref [] in Ocsigen_extensions.( Configuration.process_element @@ -364,8 +362,8 @@ let parse_config config_elem = ~name:"compress" ~obligatory:true (function - | "only" -> mode := Compress_only [] - | "allbut" -> mode := All_but [] + | "only" -> mode := `Only + | "allbut" -> mode := `All_but | _ -> badconfig "Attribute 'compress' should be 'allbut' or 'only'" @@ -376,11 +374,11 @@ let parse_config config_elem = ~name:"type" ~pcdata:(fun s -> let (a, b) = Ocsigen_header.Mime_type.parse s in - pages := Type (a, b) :: !pages) (); + pages := `Type (a, b) :: !pages) (); Configuration.element ~name:"extension" ~pcdata:(fun s -> - pages := Extension s :: !pages) (); + pages := `Extension s :: !pages) (); ] ()] @@ -389,18 +387,25 @@ let parse_config config_elem = match !pages with | [] -> Ocsigen_extensions.badconfig - "Unexpected element inside contenttype (should be or )" + "Unexpected element inside contenttype \ + (should be or )" | l -> - let mode = match !mode with - | Compress_only __ -> Compress_only l - | All_but _ -> All_but l - in filter mode + filter (match !mode with `Only -> `Only l | `All_but -> `All_but l) -(*****************************************************************************) -(** Registration of the extension *) let () = Ocsigen_extensions.register ~name:"deflatemod" ~fun_site:(fun _ _ _ _ _ _ -> parse_config) ~init_fun:parse_global_config () + +let mode = Ocsigen_extensions.Virtual_host.Config.key () + +let register vh = + Ocsigen_extensions.Virtual_host.register vh + (fun {Ocsigen_extensions.Virtual_host.Config.accessor} -> + match accessor mode with + | Some mode -> + filter mode + | None -> + failwith "Deflatemod.mode not set") diff --git a/src/extensions/deflatemod.mli b/src/extensions/deflatemod.mli new file mode 100644 index 000000000..dbd725b77 --- /dev/null +++ b/src/extensions/deflatemod.mli @@ -0,0 +1,14 @@ +val compress_level : int Ocsigen_config.Custom.key + +val buffer_size : int Ocsigen_config.Custom.key + +type filter = [ + | `Type of string option * string option + | `Extension of string +] + +val mode : + [`All_but of filter list | `Only of filter list] + Ocsigen_extensions.Virtual_host.Config.key + +val register : Ocsigen_extensions.Virtual_host.t -> unit From fafadbf9e63f8eb220d9d629197cae34091ffcb2 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 29 May 2017 17:21:38 +0200 Subject: [PATCH 081/111] Update Authbasic for use without XML config --- src/extensions/authbasic.ml | 15 ++++++++++++++- src/extensions/authbasic.mli | 19 ++++++++++++++----- 2 files changed, 28 insertions(+), 6 deletions(-) diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index 848e9631f..4bd3cb79f 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -22,7 +22,7 @@ open Lwt.Infix let section = Lwt_log.Section.make "ocsigen:ext:access-control" -(* Management of basic authentication methods *) +type auth = string -> string -> bool Lwt.t exception Bad_config_tag_for_auth of string @@ -139,3 +139,16 @@ let () = ~name:"authbasic" ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () + +let realm = Ocsigen_extensions.Virtual_host.Config.key () + +let auth = Ocsigen_extensions.Virtual_host.Config.key () + +let register vh = + Ocsigen_extensions.Virtual_host.register vh + (fun {Ocsigen_extensions.Virtual_host.Config.accessor} -> + match accessor realm, accessor auth with + | Some realm, Some auth -> + gen ~realm ~auth + | _, _ -> + failwith "Authbasic realm and/or auth not set") diff --git a/src/extensions/authbasic.mli b/src/extensions/authbasic.mli index a00c9e32a..1bed19599 100644 --- a/src/extensions/authbasic.mli +++ b/src/extensions/authbasic.mli @@ -20,6 +20,8 @@ (** Module [Authbasic]: Basic HTTP Authentication. *) +type auth = string -> string -> bool Lwt.t + (** This module implements Basic HTTP Authentication as described in {{:http://www.ietf.org/rfc/rfc2617.txt}RFC 2617}. It can be used to add an authentication layer to sites with no built-in @@ -32,12 +34,13 @@ very naive one (authentication with a single user/password, given in the configuration file) is provided. *) - -val register_basic_authentication_method : - (Xml.xml -> string -> string -> bool Lwt.t) -> unit +val register_basic_authentication_method : (Xml.xml -> auth) -> unit (** This function registers an authentication plugin: it adds a new parser to the list of available authentication schemes. + This is only applied if you are running the server with an XML + configuration file. Use the realm, auth variables otherwise. + A parser takes as argument an XML tree (corresponding to the first son of an element in the configuration file) and returns an authentication function [f]. [f] will be @@ -53,9 +56,15 @@ val register_basic_authentication_method : from the point of view of plugin developers and is totally transparent to the plugin. *) +val realm : string Ocsigen_extensions.Virtual_host.Config.key + +val auth : auth Ocsigen_extensions.Virtual_host.Config.key + +val register : Ocsigen_extensions.Virtual_host.t -> unit + +(**/**) -val get_basic_authentication_method : - Xml.xml -> string -> string -> bool Lwt.t +val get_basic_authentication_method : Xml.xml -> auth (** This function combines all the parsers registered with [register_basic_authentication_method]. It might be useful for other extensions. Not for the casual user. *) From ca1d7c21eec149e304310ffc0dd5649505ea1a08 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 29 May 2017 17:48:15 +0200 Subject: [PATCH 082/111] Update Outputfilter for use without XML config --- src/Makefile.filelist | 2 +- src/extensions/.depend | 20 +++++++++++++------- src/extensions/outputfilter.ml | 30 +++++++++++++++++++++--------- src/extensions/outputfilter.mli | 7 +++++++ 4 files changed, 42 insertions(+), 17 deletions(-) create mode 100644 src/extensions/outputfilter.mli diff --git a/src/Makefile.filelist b/src/Makefile.filelist index dc2b01789..d69ac46d0 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -55,7 +55,7 @@ PLUGINS_BIN := PLUGINS_INTF := extensions/authbasic.cmi extensions/accesscontrol.cmi \ extensions/ocsipersist.cmi extensions/staticmod.cmi \ - extensions/deflatemod.cmi + extensions/deflatemod.cmi extensions/outputfilter.cmi PLUGINS_IMPL := extensions/accesscontrol.cmo extensions/authbasic.cmo \ extensions/cors.cmo extensions/outputfilter.cmo \ diff --git a/src/extensions/.depend b/src/extensions/.depend index f40acaa8e..a327b338a 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -13,7 +13,7 @@ authbasic.cmo : ../server/ocsigen_request.cmi ../http/ocsigen_header.cmi \ authbasic.cmx : ../server/ocsigen_request.cmx ../http/ocsigen_header.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../server/ocsigen_cohttp.cmx authbasic.cmi -authbasic.cmi : +authbasic.cmi : ../server/ocsigen_extensions.cmi cgimod.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ ../baselib/ocsigen_config.cmi @@ -28,12 +28,14 @@ cors.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ ../server/ocsigen_extensions.cmx deflatemod.cmo : ../baselib/ocsigen_stream.cmi \ ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ - ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi \ - ../baselib/ocsigen_config.cmi deflatemod.cmi + ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ + ../server/ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi \ + deflatemod.cmi deflatemod.cmx : ../baselib/ocsigen_stream.cmx \ ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ - ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx \ - ../baselib/ocsigen_config.cmx deflatemod.cmi + ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ + ../server/ocsigen_extensions.cmx ../baselib/ocsigen_config.cmx \ + deflatemod.cmi deflatemod.cmi : ../server/ocsigen_extensions.cmi \ ../baselib/ocsigen_config.cmi extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ @@ -46,9 +48,13 @@ extendconfiguration.cmx : ../server/ocsigen_parseconfig.cmx \ ../http/ocsigen_charset_mime.cmx ocsipersist.cmi : outputfilter.cmo : ../server/ocsigen_response.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi + ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi \ + outputfilter.cmi outputfilter.cmx : ../server/ocsigen_response.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx + ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx \ + outputfilter.cmi +outputfilter.cmi : ../http/ocsigen_header.cmi \ + ../server/ocsigen_extensions.cmi redirectmod.cmo : ../server/ocsigen_response.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi redirectmod.cmx : ../server/ocsigen_response.cmx ../baselib/ocsigen_lib.cmx \ diff --git a/src/extensions/outputfilter.ml b/src/extensions/outputfilter.ml index 2be31238d..fa3181b0e 100644 --- a/src/extensions/outputfilter.ml +++ b/src/extensions/outputfilter.ml @@ -20,11 +20,10 @@ (* This module enables rewritting the server output *) -type outputfilter = - | Rewrite_header of - (Ocsigen_header.Name.t * Pcre.regexp * string) - | Add_header of - (Ocsigen_header.Name.t * string * bool option) +type header_filter = [ + | `Rewrite of (Ocsigen_header.Name.t * Pcre.regexp * string) + | `Add of (Ocsigen_header.Name.t * string * bool option) +] let gen filter = function | Ocsigen_extensions.Req_not_found (code, _) -> @@ -32,7 +31,7 @@ let gen filter = function | Ocsigen_extensions.Req_found (ri, res) -> Lwt.return @@ Ocsigen_extensions.Ext_found (fun () -> Lwt.return @@ match filter with - | Rewrite_header (header, regexp, dest) -> + | `Rewrite (header, regexp, dest) -> (try let l = List.map @@ -42,7 +41,7 @@ let gen filter = function Ocsigen_response.add_header_multi a header l with Not_found -> res) - | Add_header (header, dest, replace) -> + | `Add (header, dest, replace) -> match replace with | None -> (match Ocsigen_response.header res header with @@ -127,9 +126,9 @@ let parse_config config_elem = "Wrong attributes for : attributes regexp and \ replace can't be set simultaneously" | (Some h, Some r, Some d, None) -> - gen (Rewrite_header (Ocsigen_header.Name.of_string h, r, d)) + gen (`Rewrite (Ocsigen_header.Name.of_string h, r, d)) | (Some h, None, Some d, rep) -> - gen (Add_header (Ocsigen_header.Name.of_string h, d, rep)) + gen (`Add (Ocsigen_header.Name.of_string h, d, rep)) | _ -> Ocsigen_extensions.badconfig "Wrong attributes for parse_config) () + +let mode = Ocsigen_extensions.Virtual_host.Config.key () + +let register vh = + Ocsigen_extensions.Virtual_host.register vh + (fun {Ocsigen_extensions.Virtual_host.Config.accessor} -> + match accessor mode with + | Some (`Code c) -> + gen_code c + | Some (#header_filter as f) -> + gen f + | None -> + failwith "Outputfilter.mode not set") diff --git a/src/extensions/outputfilter.mli b/src/extensions/outputfilter.mli new file mode 100644 index 000000000..a40694966 --- /dev/null +++ b/src/extensions/outputfilter.mli @@ -0,0 +1,7 @@ +val mode : + [ `Rewrite of (Ocsigen_header.Name.t * Pcre.regexp * string) + | `Add of (Ocsigen_header.Name.t * string * bool option) + | `Code of Cohttp.Code.status + ] Ocsigen_extensions.Virtual_host.Config.key + +val register : Ocsigen_extensions.Virtual_host.t -> unit From 212efafce85621ef4c889e005f693efed8521da9 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 29 May 2017 18:37:09 +0200 Subject: [PATCH 083/111] Remove useless command line modules --- Makefile.options | 1 - src/Makefile | 2 +- src/Makefile.filelist | 8 +--- src/baselib/.depend | 3 -- src/baselib/Makefile | 23 ----------- .../commandline/ocsigen_getcommandline.ml | 1 - .../nocommandline/ocsigen_getcommandline.ml | 1 - src/baselib/ocsigen_commandline.ml | 40 ------------------- src/baselib/ocsigen_getcommandline.mli | 3 -- src/files/META.in | 11 +---- src/server/.depend | 18 ++++----- src/server/Makefile | 9 +---- src/server/ocsigen_server.ml | 8 +--- src/server/server_main.ml | 28 +++++++++++++ 14 files changed, 43 insertions(+), 113 deletions(-) delete mode 100644 src/baselib/commandline/ocsigen_getcommandline.ml delete mode 100644 src/baselib/nocommandline/ocsigen_getcommandline.ml delete mode 100644 src/baselib/ocsigen_commandline.ml delete mode 100644 src/baselib/ocsigen_getcommandline.mli diff --git a/Makefile.options b/Makefile.options index 6630e3db9..eb9ecf55b 100644 --- a/Makefile.options +++ b/Makefile.options @@ -46,7 +46,6 @@ SERVER_PACKAGE := lwt_ssl \ INITPACKAGE := \"$(shell ${OCAMLFIND} query -p-format -recursive \ -separator '\";\"' ${SERVER_PACKAGE})\"; \ - \"${PROJECTNAME}.commandline\"; \ \"${PROJECTNAME}.polytables\"; \ \"${PROJECTNAME}.cookies\"; \ \"${PROJECTNAME}.baselib\"; \ diff --git a/src/Makefile b/src/Makefile index eadc5ae0c..1f37e59a6 100644 --- a/src/Makefile +++ b/src/Makefile @@ -37,7 +37,7 @@ files/META.${PROJECTNAME}: files/META.in ../Makefile.config ../Makefile.options | sed s/%%NAME%%/$(PROJECTNAME)/g \ | sed s/%%DEPS%%/$(shell ${OCAMLFIND} query -p-format -separator ',' ${SERVER_PACKAGE})/g \ | sed s/%%BASEDEPS%%/$(shell ${OCAMLFIND} query -p-format -separator ',' ${BASE_PACKAGE})/g \ - | sed "s%package \"\(polytables\|commandline\|baselib\)\" (%package \"\1\" (\n directory = \"../baselib\"%" \ + | sed "s%package \"\(polytables\|baselib\)\" (%package \"\1\" (\n directory = \"../baselib\"%" \ | sed "s%package \"\(http\|cookies\)\" (%package \"\1\" (\n directory = \"../http\"%" \ | sed "s%directory = \"extensions\"%directory = \"../extensions\"%" \ >> $@ diff --git a/src/Makefile.filelist b/src/Makefile.filelist index d69ac46d0..d17f26e0a 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -22,14 +22,12 @@ INTF_BASE := baselib/ocsigen_cache.cmi \ server/ocsigen_local_files.cmi \ server/ocsigen_server.cmi -INTF := ${INTF_BASE} baselib/ocsigen_getcommandline.cmi +INTF := ${INTF_BASE} IMPL := baselib/ocsigen_lib_base.cmo \ baselib/ocsigen_config_static.cmo \ baselib/ocsigen_config.cmo \ baselib/baselib.cma \ - baselib/parsecommandline.cma \ - baselib/donotparsecommandline.cma \ baselib/polytables.cmo \ \ http/ocsigen_cookies.cmo \ @@ -46,9 +44,7 @@ NATIMPL := $(patsubst %.cmo,%.cmx, $(filter %.cmo,${IMPL})) \ $(patsubst %.cma,%.a, $(filter %.cma,${IMPL})) \ ifeq "$(NATDYNLINK)" "YES" -NATIMPL += baselib/parsecommandline.cmxs \ - baselib/donotparsecommandline.cmxs \ - baselib/polytables.cmxs +NATIMPL += baselib/polytables.cmxs endif PLUGINS_BIN := diff --git a/src/baselib/.depend b/src/baselib/.depend index beea2346e..a2feb10fb 100644 --- a/src/baselib/.depend +++ b/src/baselib/.depend @@ -7,14 +7,11 @@ dynlink_wrapper.nonatdynlink.cmx : ocsigen_cache.cmo : ocsigen_cache.cmi ocsigen_cache.cmx : ocsigen_cache.cmi ocsigen_cache.cmi : -ocsigen_commandline.cmo : ocsigen_getcommandline.cmi ocsigen_config.cmi -ocsigen_commandline.cmx : ocsigen_getcommandline.cmi ocsigen_config.cmx ocsigen_config.cmo : ocsigen_config_static.cmo ocsigen_config.cmi ocsigen_config.cmx : ocsigen_config_static.cmx ocsigen_config.cmi ocsigen_config.cmi : ocsigen_lib.cmi ocsigen_config_static.cmo : ocsigen_lib.cmi ocsigen_config_static.cmx : ocsigen_lib.cmx -ocsigen_getcommandline.cmi : ocsigen_lib.cmo : ocsigen_lib_base.cmi ocsigen_lib.cmi ocsigen_lib.cmx : ocsigen_lib_base.cmx ocsigen_lib.cmi ocsigen_lib_base.cmo : ocsigen_lib_base.cmi diff --git a/src/baselib/Makefile b/src/baselib/Makefile index 48291a9af..b783dfbcf 100644 --- a/src/baselib/Makefile +++ b/src/baselib/Makefile @@ -25,7 +25,6 @@ FILES := ocsigen_lib_base.ml \ ocsigen_cache.ml \ ocsigen_config_static.ml \ ocsigen_config.ml \ - ocsigen_commandline.ml \ ocsigen_messages.ml \ dynlink_wrapper.ml \ ocsigen_loader.ml \ @@ -93,26 +92,6 @@ dynlink_wrapper.ml: dynlink_wrapper.cmo dynlink_wrapper.cmx: dynlink_wrapper.nonatdynlink.ml endif -### Command line ### - -byte:: parsecommandline.cma donotparsecommandline.cma -opt:: parsecommandline.cmxa donotparsecommandline.cmxa -ifeq "$(NATDYNLINK)" "YES" -opt:: parsecommandline.cmxs donotparsecommandline.cmxs -endif - -parsecommandline.cma: commandline/ocsigen_getcommandline.cmo - $(OCAMLC) -a -o $@ $^ - -donotparsecommandline.cma: nocommandline/ocsigen_getcommandline.cmo - $(OCAMLC) -a -o $@ $^ - -parsecommandline.cmxa: commandline/ocsigen_getcommandline.cmx - $(OCAMLOPT) -a -o $@ $^ - -donotparsecommandline.cmxa: nocommandline/ocsigen_getcommandline.cmx - $(OCAMLOPT) -a -o $@ $^ - ### Polytables ### byte:: polytables.cma @@ -146,8 +125,6 @@ ${INTF_NOP4:.mli=.cmi}: \ clean: -rm -f *.cm* *.o *.a *.annot -rm -f ${PREDEP} - -cd commandline; rm -f *.cm* *.annot *.o - -cd nocommandline; rm -f *.cm* *.annot *.o distclean: clean -rm -f *~ \#* .\#* diff --git a/src/baselib/commandline/ocsigen_getcommandline.ml b/src/baselib/commandline/ocsigen_getcommandline.ml deleted file mode 100644 index d1bac515f..000000000 --- a/src/baselib/commandline/ocsigen_getcommandline.ml +++ /dev/null @@ -1 +0,0 @@ -let commandline = Sys.argv diff --git a/src/baselib/nocommandline/ocsigen_getcommandline.ml b/src/baselib/nocommandline/ocsigen_getcommandline.ml deleted file mode 100644 index 8fd7c02ab..000000000 --- a/src/baselib/nocommandline/ocsigen_getcommandline.ml +++ /dev/null @@ -1 +0,0 @@ -let commandline = Array.sub Sys.argv 0 1 diff --git a/src/baselib/ocsigen_commandline.ml b/src/baselib/ocsigen_commandline.ml deleted file mode 100644 index aa3842a3a..000000000 --- a/src/baselib/ocsigen_commandline.ml +++ /dev/null @@ -1,40 +0,0 @@ -(* Ocsigen - * Copyright (C) 2005 Vincent Balat - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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 Ocsigen_config - -let cmdline : unit = - try - Arg.parse_argv Ocsigen_getcommandline.commandline - [("-c", Arg.String set_configfile, - "Alternate config file (default "^ Ocsigen_config.get_config_file() ^")"); - ("--config", Arg.String set_configfile, - "Alternate config file (default "^ Ocsigen_config.get_config_file() ^")"); - ("-s", Arg.Unit set_silent, "Silent mode (error messages in errors.log only)"); - ("--silent", Arg.Unit set_silent, "Silent mode (error messages in errors.log only)"); - ("-p", Arg.String set_pidfile, "Specify a file where to write the PIDs of servers"); - ("--pidfile", Arg.String set_pidfile, "Specify a file where to write the PIDs of servers"); - ("-v", Arg.Unit set_verbose, "Verbose mode"); - ("--verbose", Arg.Unit set_verbose, "Verbose mode"); - ("-d", Arg.Unit set_daemon, "Daemon mode (detach the process)"); - ("--daemon", Arg.Unit set_daemon, "Daemon mode (detach the process) (This is the default when there are more than 1 process)"); - ("--version", Arg.Unit display_version, "Display version number and exit") - ] - (fun _ -> ()) - "usage: ocsigen [-c configfile]" - with Arg.Help s -> print_endline s; exit 0 diff --git a/src/baselib/ocsigen_getcommandline.mli b/src/baselib/ocsigen_getcommandline.mli deleted file mode 100644 index d853ae3e7..000000000 --- a/src/baselib/ocsigen_getcommandline.mli +++ /dev/null @@ -1,3 +0,0 @@ -(** Contains the command line that will be parsed by the server - when Ocsigen_commandline is linked *) -val commandline : string array diff --git a/src/files/META.in b/src/files/META.in index 33b5c1a87..77ad45a04 100644 --- a/src/files/META.in +++ b/src/files/META.in @@ -1,6 +1,6 @@ description = "Ocsigen server library" version = "dev" -requires = "%%NAME%%.commandline,%%NAME%%.polytables,%%NAME%%.http,%%NAME%%.baselib" +requires = "%%NAME%%.polytables,%%NAME%%.http,%%NAME%%.baselib" archive(byte) = "ocsigenserver.cma" archive(native) = "ocsigenserver.cmxa" @@ -12,15 +12,6 @@ package "polytables" ( archive(native) = "polytables.cmx" ) -package "commandline" ( - description = "Read the commandline during server initialization" - version = "[distributed with Ocsigen server]" - archive(byte) = "parsecommandline.cma" - archive(native) = "parsecommandline.cmxa" - archive(byte,nocommandline) = "donotparsecommandline.cma" - archive(native,nocommandline) = "donotparsecommandline.cmxa" -) - package "baselib" ( requires = "%%DEPS%%" version = "[distributed with Ocsigen server]" diff --git a/src/server/.depend b/src/server/.depend index bc400e6f9..972932739 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -64,18 +64,16 @@ ocsigen_response.cmi : ../http/ocsigen_header.cmi \ ../http/ocsigen_cookies.cmi ocsigen_server.cmo : ocsigen_parseconfig.cmi ../baselib/ocsigen_messages.cmi \ ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ - ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi \ - ../baselib/ocsigen_commandline.cmo ocsigen_command.cmi ocsigen_cohttp.cmi \ - ../baselib/ocsigen_cache.cmi ../baselib/dynlink_wrapper.cmo \ - ocsigen_server.cmi + ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi ocsigen_command.cmi \ + ocsigen_cohttp.cmi ../baselib/ocsigen_cache.cmi \ + ../baselib/dynlink_wrapper.cmo ocsigen_server.cmi ocsigen_server.cmx : ocsigen_parseconfig.cmx ../baselib/ocsigen_messages.cmx \ ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ - ocsigen_extensions.cmx ../baselib/ocsigen_config.cmx \ - ../baselib/ocsigen_commandline.cmx ocsigen_command.cmx ocsigen_cohttp.cmx \ - ../baselib/ocsigen_cache.cmx ../baselib/dynlink_wrapper.cmx \ - ocsigen_server.cmi + ocsigen_extensions.cmx ../baselib/ocsigen_config.cmx ocsigen_command.cmx \ + ocsigen_cohttp.cmx ../baselib/ocsigen_cache.cmx \ + ../baselib/dynlink_wrapper.cmx ocsigen_server.cmi ocsigen_server.cmi : server_main.cmo : ocsigen_server.cmi ocsigen_parseconfig.cmi \ - ocsigen_extensions.cmi + ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi server_main.cmx : ocsigen_server.cmx ocsigen_parseconfig.cmx \ - ocsigen_extensions.cmx + ocsigen_extensions.cmx ../baselib/ocsigen_config.cmx diff --git a/src/server/Makefile b/src/server/Makefile index 843431c78..2d6d56ad1 100644 --- a/src/server/Makefile +++ b/src/server/Makefile @@ -36,14 +36,7 @@ ${PROJECTNAME}.cmxa: $(FILES:.ml=.cmx) byte:: ${PROJECTNAME} opt:: ${PROJECTNAME}.opt -ifdef DONOTPARSECOMMANDLINE -PARSECOMMANDLINE := ../baselib/donotparsecommandline.cma -else -PARSECOMMANDLINE := ../baselib/parsecommandline.cma -endif - -SERVERLIBS := ${PARSECOMMANDLINE} \ - ../baselib/baselib.cma \ +SERVERLIBS := ../baselib/baselib.cma \ ../baselib/polytables.cma \ ../http/http.cma \ ${PROJECTNAME}.cma \ diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index b1732aa90..29eefe92a 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -22,12 +22,8 @@ open Lwt.Infix let () = Random.self_init () -let () = Ocsigen_commandline.cmdline -(* This is only to have the module Ocsigen_commandline linked - when we do not use -linkall *) - -(* Without the following line, it stops with "Broken Pipe" without raising - an exception ... *) +(* Without the following line, it stops with "Broken Pipe" without + raising an exception ... *) let _ = Sys.set_signal Sys.sigpipe Sys.Signal_ignore let section = Lwt_log.Section.make "ocsigen:main" diff --git a/src/server/server_main.ml b/src/server/server_main.ml index 8ac45d6fa..9a3318005 100644 --- a/src/server/server_main.ml +++ b/src/server/server_main.ml @@ -1,3 +1,31 @@ +let () = + let alt_msg = + "Alternate config file (default " ^ + Ocsigen_config.get_config_file () ^ + ")" + and silent_msg = "Silent mode (error messages in errors.log only)" + and pid_msg = "Specify a file where to write the PIDs of servers" + and daemon_msg = "Daemon mode (detach the process)" + and verbose_msg = "Verbose mode" + and version_msg = "Display version number and exit" in + try + Arg.parse_argv Sys.argv [ + "-c", Arg.String Ocsigen_config.set_configfile, alt_msg; + "--config", Arg.String Ocsigen_config.set_configfile, alt_msg; + "-s", Arg.Unit Ocsigen_config.set_silent, silent_msg; + "--silent", Arg.Unit Ocsigen_config.set_silent, silent_msg; + "-p", Arg.String Ocsigen_config.set_pidfile, pid_msg; + "--pidfile", Arg.String Ocsigen_config.set_pidfile, pid_msg; + "-v", Arg.Unit Ocsigen_config.set_verbose, verbose_msg; + "--verbose", Arg.Unit Ocsigen_config.set_verbose, verbose_msg; + "-d", Arg.Unit Ocsigen_config.set_daemon, daemon_msg; + "--daemon", Arg.Unit Ocsigen_config.set_daemon, daemon_msg; + "--version", Arg.Unit Ocsigen_config.display_version, version_msg + ] (fun _ -> ()) "usage: ocsigenserver [-c configfile]" + with Arg.Help s -> + print_endline s; + exit 0 + let () = Ocsigen_extensions.set_we_have_xml_config (); Ocsigen_server.start From f9db02fbfc776dde628029035eeb55f6983d4468 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 29 May 2017 22:15:01 +0200 Subject: [PATCH 084/111] Ocsigen_config moved from baselib to server --- src/Makefile.filelist | 7 +- src/baselib/.depend | 18 ++---- src/baselib/Makefile | 2 - src/baselib/ocsigen_config_static.ml.in | 1 + src/baselib/ocsigen_loader.ml | 17 +++-- src/baselib/ocsigen_stream.ml | 23 ++----- src/baselib/ocsigen_stream.mli | 8 ++- src/extensions/.depend | 14 ++-- src/extensions/ocsipersist-dbm/.depend | 8 +-- src/extensions/ocsipersist-sqlite/.depend | 8 +-- src/http/.depend | 4 +- src/http/ocsigen_charset_mime.ml | 2 +- src/http/ocsigen_charset_mime.mli | 2 +- src/server/.depend | 68 ++++++++++---------- src/server/Makefile | 12 ++-- src/{baselib => server}/ocsigen_config.ml | 3 - src/{baselib => server}/ocsigen_config.mli | 2 - src/{baselib => server}/ocsigen_messages.ml | 0 src/{baselib => server}/ocsigen_messages.mli | 0 src/server/ocsigen_parseconfig.ml | 3 +- 20 files changed, 94 insertions(+), 108 deletions(-) rename src/{baselib => server}/ocsigen_config.ml (98%) rename src/{baselib => server}/ocsigen_config.mli (98%) rename src/{baselib => server}/ocsigen_messages.ml (100%) rename src/{baselib => server}/ocsigen_messages.mli (100%) diff --git a/src/Makefile.filelist b/src/Makefile.filelist index d17f26e0a..3a66ff98b 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -4,8 +4,6 @@ NATBIN := server/${PROJECTNAME}.opt INTF_BASE := baselib/ocsigen_cache.cmi \ baselib/ocsigen_lib_base.cmi \ baselib/ocsigen_lib.cmi \ - baselib/ocsigen_config.cmi \ - baselib/ocsigen_messages.cmi \ baselib/ocsigen_stream.cmi \ baselib/ocsigen_loader.cmi \ baselib/polytables.cmi \ @@ -14,8 +12,10 @@ INTF_BASE := baselib/ocsigen_cache.cmi \ http/ocsigen_cookies.cmi \ http/ocsigen_header.cmi \ \ + server/ocsigen_config.cmi \ server/ocsigen_request.cmi \ server/ocsigen_response.cmi \ + server/ocsigen_messages.cmi \ server/ocsigen_multipart.cmi \ server/ocsigen_extensions.cmi \ server/ocsigen_parseconfig.cmi \ @@ -26,7 +26,6 @@ INTF := ${INTF_BASE} IMPL := baselib/ocsigen_lib_base.cmo \ baselib/ocsigen_config_static.cmo \ - baselib/ocsigen_config.cmo \ baselib/baselib.cma \ baselib/polytables.cmo \ \ @@ -34,7 +33,7 @@ IMPL := baselib/ocsigen_lib_base.cmo \ http/http.cma \ \ server/${PROJECTNAME}.cma \ - server/server_main.cmo \ + server/server_main.cmo INTF_CMX := $(patsubst %.cmi,%.cmx,${INTF_BASE}) diff --git a/src/baselib/.depend b/src/baselib/.depend index a2feb10fb..95e06c7b6 100644 --- a/src/baselib/.depend +++ b/src/baselib/.depend @@ -7,25 +7,19 @@ dynlink_wrapper.nonatdynlink.cmx : ocsigen_cache.cmo : ocsigen_cache.cmi ocsigen_cache.cmx : ocsigen_cache.cmi ocsigen_cache.cmi : -ocsigen_config.cmo : ocsigen_config_static.cmo ocsigen_config.cmi -ocsigen_config.cmx : ocsigen_config_static.cmx ocsigen_config.cmi -ocsigen_config.cmi : ocsigen_lib.cmi ocsigen_config_static.cmo : ocsigen_lib.cmi ocsigen_config_static.cmx : ocsigen_lib.cmx ocsigen_lib.cmo : ocsigen_lib_base.cmi ocsigen_lib.cmi ocsigen_lib.cmx : ocsigen_lib_base.cmx ocsigen_lib.cmi ocsigen_lib_base.cmo : ocsigen_lib_base.cmi ocsigen_lib_base.cmx : ocsigen_lib_base.cmi -ocsigen_loader.cmo : ocsigen_lib.cmi ocsigen_config.cmi dynlink_wrapper.cmo \ - ocsigen_loader.cmi -ocsigen_loader.cmx : ocsigen_lib.cmx ocsigen_config.cmx dynlink_wrapper.cmx \ - ocsigen_loader.cmi +ocsigen_loader.cmo : ocsigen_lib.cmi ocsigen_config_static.cmo \ + dynlink_wrapper.cmo ocsigen_loader.cmi +ocsigen_loader.cmx : ocsigen_lib.cmx ocsigen_config_static.cmx \ + dynlink_wrapper.cmx ocsigen_loader.cmi ocsigen_loader.cmi : -ocsigen_messages.cmo : ocsigen_config.cmi ocsigen_messages.cmi -ocsigen_messages.cmx : ocsigen_config.cmx ocsigen_messages.cmi -ocsigen_messages.cmi : -ocsigen_stream.cmo : ocsigen_lib.cmi ocsigen_config.cmi ocsigen_stream.cmi -ocsigen_stream.cmx : ocsigen_lib.cmx ocsigen_config.cmx ocsigen_stream.cmi +ocsigen_stream.cmo : ocsigen_lib.cmi ocsigen_stream.cmi +ocsigen_stream.cmx : ocsigen_lib.cmx ocsigen_stream.cmi ocsigen_stream.cmi : polytables.cmo : polytables.cmi polytables.cmx : polytables.cmi diff --git a/src/baselib/Makefile b/src/baselib/Makefile index b783dfbcf..7e29aace0 100644 --- a/src/baselib/Makefile +++ b/src/baselib/Makefile @@ -24,8 +24,6 @@ FILES := ocsigen_lib_base.ml \ ocsigen_lib.ml \ ocsigen_cache.ml \ ocsigen_config_static.ml \ - ocsigen_config.ml \ - ocsigen_messages.ml \ dynlink_wrapper.ml \ ocsigen_loader.ml \ ocsigen_stream.ml \ diff --git a/src/baselib/ocsigen_config_static.ml.in b/src/baselib/ocsigen_config_static.ml.in index e1e98c556..8b64732ab 100644 --- a/src/baselib/ocsigen_config_static.ml.in +++ b/src/baselib/ocsigen_config_static.ml.in @@ -20,6 +20,7 @@ let version_number = "_VERSION_" let config_file = ref "_CONFIGDIR_/_PROJECTNAME_.conf" +(* We could eventually use Sys.backend_type. *) let is_native = _ISNATIVE_ let logdir = ref (Some "_LOGDIR_") let default_user = ref "_OCSIGENUSER_" diff --git a/src/baselib/ocsigen_loader.ml b/src/baselib/ocsigen_loader.ml index c4a2329b6..f7ed3e0ff 100644 --- a/src/baselib/ocsigen_loader.ml +++ b/src/baselib/ocsigen_loader.ml @@ -30,7 +30,7 @@ let section = Lwt_log.Section.make "ocsigen:dynlink" (* Translate .cmo/.cma extensions to .cmxs in native mode, and .cmxs to .cmo (.cma if the file exists) in bytecode mode. *) let translate = - if Ocsigen_config.is_native then + if Ocsigen_config_static.is_native then fun filename -> if Filename.check_suffix filename ".cmo" || Filename.check_suffix filename ".cma" then @@ -166,10 +166,17 @@ let findfiles = let cmx = Pcre.regexp ~flags:[`MULTILINE; `CASELESS] "\\.cmx($| |a)" in fun package -> try - let preds = [(if Ocsigen_config.is_native then "native" else "byte"); "plugin"; "mt"] in - let deps = Findlib.package_deep_ancestors preds [package] in - let deps = List.filter - (fun a -> not (String.Set.mem a Ocsigen_config.builtin_packages)) deps in + let preds = [ + (if Ocsigen_config_static.is_native then "native" else "byte"); + "plugin"; + "mt" + ] in + let deps = + List.filter + (fun a -> not @@ + String.Set.mem a Ocsigen_config_static.builtin_packages) + (Findlib.package_deep_ancestors preds [package]) + in Lwt_log.ign_info_f ~section "Dependencies of %s: %s" package (String.concat ", " deps); let rec aux = function diff --git a/src/baselib/ocsigen_stream.ml b/src/baselib/ocsigen_stream.ml index 9ab364cfb..ea1d42f22 100644 --- a/src/baselib/ocsigen_stream.ml +++ b/src/baselib/ocsigen_stream.ml @@ -37,6 +37,10 @@ type 'a t = mutable in_use : bool; mutable finalizer : outcome -> unit Lwt.t } +let net_buffer_size = ref 8192 + +let set_net_buffer_size i = net_buffer_size := i + let empty follow = match follow with None -> Lwt.return (Finished None) @@ -116,28 +120,11 @@ let string_of_stream m s = in aux 0 s >|= Buffer.contents -(* -(*XXX Quadratic!!! *) -let string_of_streams = - let rec aux l = function - | Finished None -> return "" - | Finished (Some s) -> next s >>= fun r -> aux l r - | Cont (s, f) -> - let l2 = l+String.length s in - if l2 > Ocsigen_config.get_netbuffersize () - then Lwt.fail String_too_large - else - next f >>= fun r -> - aux l2 r >>= fun r -> - return (s^r) - in aux 0 -*) - let enlarge_stream = function | Finished a -> Lwt.fail Stream_too_small | Cont (s, f) -> let long = String.length s in - let max = Ocsigen_config.get_netbuffersize () in + let max = !net_buffer_size in if long >= max then Lwt.fail Input_is_too_large else diff --git a/src/baselib/ocsigen_stream.mli b/src/baselib/ocsigen_stream.mli index 5b4bca719..77e08ff0a 100644 --- a/src/baselib/ocsigen_stream.mli +++ b/src/baselib/ocsigen_stream.mli @@ -97,7 +97,7 @@ val stream_want : string step -> int -> string step Lwt.t (** Returns the value of the current buffer *) val current_buffer : string step -> string -(** Skips data. Raises [Stream_too_small (Some size)] +(** Skips data. Raises [Stream_too_small (Some size)] if the stream is too small, where [size] is the size of the stream. *) val skip : string step -> int64 -> string step Lwt.t @@ -141,3 +141,9 @@ module StringStream : sig val concat: m -> m -> m end + +(**/**) + +(* Small hack that will allow us to move [Ocsigen_config] out of + baselib. Not super-pretty. *) +val set_net_buffer_size : int -> unit diff --git a/src/extensions/.depend b/src/extensions/.depend index a327b338a..053e731b9 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -16,10 +16,10 @@ authbasic.cmx : ../server/ocsigen_request.cmx ../http/ocsigen_header.cmx \ authbasic.cmi : ../server/ocsigen_extensions.cmi cgimod.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ - ../baselib/ocsigen_config.cmi + ../server/ocsigen_config.cmi cgimod.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ - ../baselib/ocsigen_config.cmx + ../server/ocsigen_config.cmx cors.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ ../server/ocsigen_extensions.cmi @@ -29,22 +29,22 @@ cors.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ deflatemod.cmo : ../baselib/ocsigen_stream.cmi \ ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ - ../server/ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi \ + ../server/ocsigen_extensions.cmi ../server/ocsigen_config.cmi \ deflatemod.cmi deflatemod.cmx : ../baselib/ocsigen_stream.cmx \ ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ - ../server/ocsigen_extensions.cmx ../baselib/ocsigen_config.cmx \ + ../server/ocsigen_extensions.cmx ../server/ocsigen_config.cmx \ deflatemod.cmi deflatemod.cmi : ../server/ocsigen_extensions.cmi \ - ../baselib/ocsigen_config.cmi + ../server/ocsigen_config.cmi extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi \ - ../http/ocsigen_cookies.cmi ../baselib/ocsigen_config.cmi \ + ../http/ocsigen_cookies.cmi ../server/ocsigen_config.cmi \ ../http/ocsigen_charset_mime.cmi extendconfiguration.cmx : ../server/ocsigen_parseconfig.cmx \ ../baselib/ocsigen_lib.cmx ../server/ocsigen_extensions.cmx \ - ../http/ocsigen_cookies.cmx ../baselib/ocsigen_config.cmx \ + ../http/ocsigen_cookies.cmx ../server/ocsigen_config.cmx \ ../http/ocsigen_charset_mime.cmx ocsipersist.cmi : outputfilter.cmo : ../server/ocsigen_response.cmi ../baselib/ocsigen_lib.cmi \ diff --git a/src/extensions/ocsipersist-dbm/.depend b/src/extensions/ocsipersist-dbm/.depend index 95d34f7c4..9dbf83564 100644 --- a/src/extensions/ocsipersist-dbm/.depend +++ b/src/extensions/ocsipersist-dbm/.depend @@ -1,10 +1,10 @@ ocsidbm.cmo : ocsidbmtypes.cmi ocsidbm.cmx : ocsidbmtypes.cmi ocsidbmtypes.cmi : -ocsipersist.cmo : ../../baselib/ocsigen_messages.cmi \ - ../../server/ocsigen_extensions.cmi ../../baselib/ocsigen_config.cmi \ +ocsipersist.cmo : ../../server/ocsigen_messages.cmi \ + ../../server/ocsigen_extensions.cmi ../../server/ocsigen_config.cmi \ ocsidbmtypes.cmi ocsipersist.cmi -ocsipersist.cmx : ../../baselib/ocsigen_messages.cmx \ - ../../server/ocsigen_extensions.cmx ../../baselib/ocsigen_config.cmx \ +ocsipersist.cmx : ../../server/ocsigen_messages.cmx \ + ../../server/ocsigen_extensions.cmx ../../server/ocsigen_config.cmx \ ocsidbmtypes.cmi ocsipersist.cmi ocsipersist.cmi : diff --git a/src/extensions/ocsipersist-sqlite/.depend b/src/extensions/ocsipersist-sqlite/.depend index 7a5fecd55..7f0473395 100644 --- a/src/extensions/ocsipersist-sqlite/.depend +++ b/src/extensions/ocsipersist-sqlite/.depend @@ -1,7 +1,7 @@ -ocsipersist.cmo : ../../baselib/ocsigen_messages.cmi \ - ../../server/ocsigen_extensions.cmi ../../baselib/ocsigen_config.cmi \ +ocsipersist.cmo : ../../server/ocsigen_messages.cmi \ + ../../server/ocsigen_extensions.cmi ../../server/ocsigen_config.cmi \ ocsipersist.cmi -ocsipersist.cmx : ../../baselib/ocsigen_messages.cmx \ - ../../server/ocsigen_extensions.cmx ../../baselib/ocsigen_config.cmx \ +ocsipersist.cmx : ../../server/ocsigen_messages.cmx \ + ../../server/ocsigen_extensions.cmx ../../server/ocsigen_config.cmx \ ocsipersist.cmi ocsipersist.cmi : diff --git a/src/http/.depend b/src/http/.depend index 5c9d195f0..8fc4f652f 100644 --- a/src/http/.depend +++ b/src/http/.depend @@ -1,7 +1,7 @@ ocsigen_charset_mime.cmo : ../baselib/ocsigen_lib.cmi \ - ../baselib/ocsigen_config.cmi ocsigen_charset_mime.cmi + ../baselib/ocsigen_config_static.cmo ocsigen_charset_mime.cmi ocsigen_charset_mime.cmx : ../baselib/ocsigen_lib.cmx \ - ../baselib/ocsigen_config.cmx ocsigen_charset_mime.cmi + ../baselib/ocsigen_config_static.cmx ocsigen_charset_mime.cmi ocsigen_charset_mime.cmi : ocsigen_cookies.cmo : ocsigen_cookies.cmi ocsigen_cookies.cmx : ocsigen_cookies.cmi diff --git a/src/http/ocsigen_charset_mime.ml b/src/http/ocsigen_charset_mime.ml index b96dc7c41..444645cbf 100644 --- a/src/http/ocsigen_charset_mime.ml +++ b/src/http/ocsigen_charset_mime.ml @@ -165,7 +165,7 @@ let default_mime_assoc () = let parsed = ref None in match !parsed with | None -> - let file = Ocsigen_config.get_mimefile () in + let file = !Ocsigen_config_static.mimefile in Lwt_log.ign_info_f ~section "Loading mime types in '%s'" file; let map = parse_mime_types file in parsed := Some map; diff --git a/src/http/ocsigen_charset_mime.mli b/src/http/ocsigen_charset_mime.mli index 2fa27dbcf..a14a6e88f 100644 --- a/src/http/ocsigen_charset_mime.mli +++ b/src/http/ocsigen_charset_mime.mli @@ -64,7 +64,7 @@ val default_mime_type : mime_type type mime_assoc (** Default values, obtained by reading the file specified by - [Ocsigen_config.get_mimefile] *) + [Ocsigen_config_static.get_mimefile] *) val default_mime_assoc : unit -> mime_assoc diff --git a/src/server/.depend b/src/server/.depend index 972932739..313e04459 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -1,50 +1,52 @@ ocsigen_cohttp.cmo : ../baselib/ocsigen_stream.cmi ocsigen_response.cmi \ ocsigen_request.cmi ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ - ../http/ocsigen_cookies.cmi ../baselib/ocsigen_config.cmi \ - ocsigen_cohttp.cmi + ../http/ocsigen_cookies.cmi ocsigen_config.cmi ocsigen_cohttp.cmi ocsigen_cohttp.cmx : ../baselib/ocsigen_stream.cmx ocsigen_response.cmx \ ocsigen_request.cmx ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ - ../http/ocsigen_cookies.cmx ../baselib/ocsigen_config.cmx \ - ocsigen_cohttp.cmi + ../http/ocsigen_cookies.cmx ocsigen_config.cmx ocsigen_cohttp.cmi ocsigen_cohttp.cmi : ocsigen_response.cmi ocsigen_request.cmi \ - ../http/ocsigen_cookies.cmi ../baselib/ocsigen_config.cmi -ocsigen_command.cmo : ../baselib/ocsigen_messages.cmi ocsigen_command.cmi -ocsigen_command.cmx : ../baselib/ocsigen_messages.cmx ocsigen_command.cmi + ../http/ocsigen_cookies.cmi ocsigen_config.cmi +ocsigen_command.cmo : ocsigen_messages.cmi ocsigen_command.cmi +ocsigen_command.cmx : ocsigen_messages.cmx ocsigen_command.cmi ocsigen_command.cmi : +ocsigen_config.cmo : ../baselib/ocsigen_config_static.cmo ocsigen_config.cmi +ocsigen_config.cmx : ../baselib/ocsigen_config_static.cmx ocsigen_config.cmi +ocsigen_config.cmi : ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmo : ocsigen_response.cmi ocsigen_request.cmi \ ocsigen_multipart.cmi ../baselib/ocsigen_loader.cmi \ - ../baselib/ocsigen_lib.cmi ../http/ocsigen_cookies.cmi \ - ../baselib/ocsigen_config.cmi ocsigen_command.cmi ocsigen_cohttp.cmi \ - ../http/ocsigen_charset_mime.cmi ocsigen_extensions.cmi + ../baselib/ocsigen_lib.cmi ../http/ocsigen_cookies.cmi ocsigen_config.cmi \ + ocsigen_command.cmi ocsigen_cohttp.cmi ../http/ocsigen_charset_mime.cmi \ + ocsigen_extensions.cmi ocsigen_extensions.cmx : ocsigen_response.cmx ocsigen_request.cmx \ ocsigen_multipart.cmx ../baselib/ocsigen_loader.cmx \ - ../baselib/ocsigen_lib.cmx ../http/ocsigen_cookies.cmx \ - ../baselib/ocsigen_config.cmx ocsigen_command.cmx ocsigen_cohttp.cmx \ - ../http/ocsigen_charset_mime.cmx ocsigen_extensions.cmi + ../baselib/ocsigen_lib.cmx ../http/ocsigen_cookies.cmx ocsigen_config.cmx \ + ocsigen_command.cmx ocsigen_cohttp.cmx ../http/ocsigen_charset_mime.cmx \ + ocsigen_extensions.cmi ocsigen_extensions.cmi : ocsigen_response.cmi ocsigen_request.cmi \ ocsigen_multipart.cmi ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_cookies.cmi ocsigen_command.cmi \ ../http/ocsigen_charset_mime.cmi ocsigen_local_files.cmo : ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ - ../baselib/ocsigen_config.cmi ocsigen_local_files.cmi + ocsigen_config.cmi ocsigen_local_files.cmi ocsigen_local_files.cmx : ../baselib/ocsigen_lib.cmx ocsigen_extensions.cmx \ - ../baselib/ocsigen_config.cmx ocsigen_local_files.cmi + ocsigen_config.cmx ocsigen_local_files.cmi ocsigen_local_files.cmi : ocsigen_extensions.cmi +ocsigen_messages.cmo : ocsigen_config.cmi ocsigen_messages.cmi +ocsigen_messages.cmx : ocsigen_config.cmx ocsigen_messages.cmi +ocsigen_messages.cmi : ocsigen_multipart.cmo : ../baselib/ocsigen_stream.cmi \ - ../baselib/ocsigen_lib.cmi ../baselib/ocsigen_config.cmi \ - ocsigen_multipart.cmi + ../baselib/ocsigen_lib.cmi ocsigen_config.cmi ocsigen_multipart.cmi ocsigen_multipart.cmx : ../baselib/ocsigen_stream.cmx \ - ../baselib/ocsigen_lib.cmx ../baselib/ocsigen_config.cmx \ - ocsigen_multipart.cmi + ../baselib/ocsigen_lib.cmx ocsigen_config.cmx ocsigen_multipart.cmi ocsigen_multipart.cmi : ../baselib/ocsigen_stream.cmi -ocsigen_parseconfig.cmo : ../baselib/ocsigen_loader.cmi \ - ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ - ../baselib/ocsigen_config.cmi ../http/ocsigen_charset_mime.cmi \ - ocsigen_parseconfig.cmi -ocsigen_parseconfig.cmx : ../baselib/ocsigen_loader.cmx \ - ../baselib/ocsigen_lib.cmx ocsigen_extensions.cmx \ - ../baselib/ocsigen_config.cmx ../http/ocsigen_charset_mime.cmx \ - ocsigen_parseconfig.cmi +ocsigen_parseconfig.cmo : ../baselib/ocsigen_stream.cmi \ + ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ + ocsigen_extensions.cmi ocsigen_config.cmi \ + ../http/ocsigen_charset_mime.cmi ocsigen_parseconfig.cmi +ocsigen_parseconfig.cmx : ../baselib/ocsigen_stream.cmx \ + ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ + ocsigen_extensions.cmx ocsigen_config.cmx \ + ../http/ocsigen_charset_mime.cmx ocsigen_parseconfig.cmi ocsigen_parseconfig.cmi : ocsigen_request.cmo : ../baselib/polytables.cmi \ ../baselib/ocsigen_stream.cmi ocsigen_multipart.cmi \ @@ -62,18 +64,18 @@ ocsigen_response.cmx : ../http/ocsigen_header.cmx \ ../http/ocsigen_cookies.cmx ocsigen_response.cmi ocsigen_response.cmi : ../http/ocsigen_header.cmi \ ../http/ocsigen_cookies.cmi -ocsigen_server.cmo : ocsigen_parseconfig.cmi ../baselib/ocsigen_messages.cmi \ +ocsigen_server.cmo : ocsigen_parseconfig.cmi ocsigen_messages.cmi \ ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ - ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi ocsigen_command.cmi \ + ocsigen_extensions.cmi ocsigen_config.cmi ocsigen_command.cmi \ ocsigen_cohttp.cmi ../baselib/ocsigen_cache.cmi \ ../baselib/dynlink_wrapper.cmo ocsigen_server.cmi -ocsigen_server.cmx : ocsigen_parseconfig.cmx ../baselib/ocsigen_messages.cmx \ +ocsigen_server.cmx : ocsigen_parseconfig.cmx ocsigen_messages.cmx \ ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ - ocsigen_extensions.cmx ../baselib/ocsigen_config.cmx ocsigen_command.cmx \ + ocsigen_extensions.cmx ocsigen_config.cmx ocsigen_command.cmx \ ocsigen_cohttp.cmx ../baselib/ocsigen_cache.cmx \ ../baselib/dynlink_wrapper.cmx ocsigen_server.cmi ocsigen_server.cmi : server_main.cmo : ocsigen_server.cmi ocsigen_parseconfig.cmi \ - ocsigen_extensions.cmi ../baselib/ocsigen_config.cmi + ocsigen_extensions.cmi ocsigen_config.cmi server_main.cmx : ocsigen_server.cmx ocsigen_parseconfig.cmx \ - ocsigen_extensions.cmx ../baselib/ocsigen_config.cmx + ocsigen_extensions.cmx ocsigen_config.cmx diff --git a/src/server/Makefile b/src/server/Makefile index 2d6d56ad1..a97a65e40 100644 --- a/src/server/Makefile +++ b/src/server/Makefile @@ -13,14 +13,10 @@ all: byte opt ### Common files ### -FILES := ocsigen_command.ml \ - ocsigen_multipart.ml \ - ocsigen_request.ml \ - ocsigen_response.ml \ - ocsigen_cohttp.ml \ - ocsigen_extensions.ml \ - ocsigen_parseconfig.ml \ - ocsigen_local_files.ml \ +FILES := ocsigen_config.ml ocsigen_messages.ml ocsigen_command.ml \ + ocsigen_multipart.ml ocsigen_request.ml ocsigen_response.ml \ + ocsigen_cohttp.ml ocsigen_extensions.ml \ + ocsigen_parseconfig.ml ocsigen_local_files.ml \ ocsigen_server.ml byte:: ${PROJECTNAME}.cma diff --git a/src/baselib/ocsigen_config.ml b/src/server/ocsigen_config.ml similarity index 98% rename from src/baselib/ocsigen_config.ml rename to src/server/ocsigen_config.ml index f41aede41..a379b978b 100644 --- a/src/baselib/ocsigen_config.ml +++ b/src/server/ocsigen_config.ml @@ -74,7 +74,6 @@ let maxthreads = ref 30 let max_number_of_connections = ref 350 let silent_client_timeout = ref 30 (* without speaking during sending frame *) let silent_server_timeout = ref 30 (* without speaking during sending frame *) -let netbuffersize = ref 8192 let filebuffersize = ref 8192 let maxrequestbodysize = ref (Some (Int64.of_int 8000000)) let maxrequestbodysizeinmemory = ref 8192 @@ -109,7 +108,6 @@ let set_client_timeout i = silent_client_timeout := i let set_server_timeout i = silent_server_timeout := i (* let set_keepalive_timeout i = keepalive_timeout := i let set_keepopen_timeout i = keepopen_timeout := i *) -let set_netbuffersize i = netbuffersize := i let set_filebuffersize i = filebuffersize := i let set_maxuploadfilesize i = maxuploadfilesize := i let set_maxrequestbodysize i = maxrequestbodysize := i @@ -151,7 +149,6 @@ let get_maxthreads () = !maxthreads let get_max_number_of_connections () = !max_number_of_connections let get_client_timeout () = !silent_client_timeout let get_server_timeout () = !silent_server_timeout -let get_netbuffersize () = !netbuffersize let get_filebuffersize () = !filebuffersize let get_maxuploadfilesize () = !maxuploadfilesize let get_maxrequestbodysize () = !maxrequestbodysize diff --git a/src/baselib/ocsigen_config.mli b/src/server/ocsigen_config.mli similarity index 98% rename from src/baselib/ocsigen_config.mli rename to src/server/ocsigen_config.mli index 29b9114f7..3bfe19508 100644 --- a/src/baselib/ocsigen_config.mli +++ b/src/server/ocsigen_config.mli @@ -70,7 +70,6 @@ val set_client_timeout : int -> unit val set_server_timeout : int -> unit (* val set_keepalive_timeout : int -> unit val set_keepopen_timeout : int -> unit *) -val set_netbuffersize : int -> unit val set_filebuffersize : int -> unit val set_maxrequestbodysize : int64 option -> unit val set_maxrequestbodysizeinmemory : int -> unit @@ -109,7 +108,6 @@ val get_client_timeout : unit -> int val get_server_timeout : unit -> int (*val get_keepalive_timeout : unit -> int val get_keepopen_timeout : unit -> int*) -val get_netbuffersize : unit -> int val get_filebuffersize : unit -> int val get_maxrequestbodysize : unit -> int64 option val get_maxrequestbodysizeinmemory : unit -> int diff --git a/src/baselib/ocsigen_messages.ml b/src/server/ocsigen_messages.ml similarity index 100% rename from src/baselib/ocsigen_messages.ml rename to src/server/ocsigen_messages.ml diff --git a/src/baselib/ocsigen_messages.mli b/src/server/ocsigen_messages.mli similarity index 100% rename from src/baselib/ocsigen_messages.mli rename to src/server/ocsigen_messages.mli diff --git a/src/server/ocsigen_parseconfig.ml b/src/server/ocsigen_parseconfig.ml index f81e831f4..37dbf2b48 100644 --- a/src/server/ocsigen_parseconfig.ml +++ b/src/server/ocsigen_parseconfig.ml @@ -499,7 +499,8 @@ and later_pass = function set_server_timeout (int_of_string st (parse_string_tag st p)); later_pass ll | Element ("netbuffersize" as st, [], p) :: ll -> - set_netbuffersize (int_of_string st (parse_string_tag st p)); + Ocsigen_stream.set_net_buffer_size + (int_of_string st (parse_string_tag st p)); later_pass ll | Element ("filebuffersize" as st, [], p) :: ll -> set_filebuffersize (int_of_string st (parse_string_tag st p)); From b37bed0162a367b6b7ddf01a3f50eca768929a94 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 29 May 2017 22:50:50 +0200 Subject: [PATCH 085/111] Vhost and site APIs now in Ocsigen_server --- src/extensions/.depend | 47 +++++----- src/extensions/authbasic.ml | 8 +- src/extensions/authbasic.mli | 6 +- src/extensions/deflatemod.ml | 6 +- src/extensions/deflatemod.mli | 4 +- src/extensions/outputfilter.ml | 6 +- src/extensions/outputfilter.mli | 4 +- src/extensions/staticmod.ml | 14 +-- src/extensions/staticmod.mli | 12 +-- src/server/.depend | 16 ++-- src/server/ocsigen_extensions.ml | 146 ----------------------------- src/server/ocsigen_extensions.mli | 65 ++----------- src/server/ocsigen_server.ml | 150 +++++++++++++++++++++++++++++- src/server/ocsigen_server.mli | 59 ++++++++++++ 14 files changed, 282 insertions(+), 261 deletions(-) diff --git a/src/extensions/.depend b/src/extensions/.depend index 053e731b9..d8e0cfc0a 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -7,13 +7,13 @@ accesscontrol.cmx : ../server/ocsigen_response.cmx \ ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx \ ../http/ocsigen_cookies.cmx accesscontrol.cmi accesscontrol.cmi : -authbasic.cmo : ../server/ocsigen_request.cmi ../http/ocsigen_header.cmi \ - ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ - ../server/ocsigen_cohttp.cmi authbasic.cmi -authbasic.cmx : ../server/ocsigen_request.cmx ../http/ocsigen_header.cmx \ - ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ - ../server/ocsigen_cohttp.cmx authbasic.cmi -authbasic.cmi : ../server/ocsigen_extensions.cmi +authbasic.cmo : ../server/ocsigen_server.cmi ../server/ocsigen_request.cmi \ + ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi \ + ../http/ocsigen_cookies.cmi ../server/ocsigen_cohttp.cmi authbasic.cmi +authbasic.cmx : ../server/ocsigen_server.cmx ../server/ocsigen_request.cmx \ + ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx \ + ../http/ocsigen_cookies.cmx ../server/ocsigen_cohttp.cmx authbasic.cmi +authbasic.cmi : ../server/ocsigen_server.cmi cgimod.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ ../server/ocsigen_config.cmi @@ -26,18 +26,17 @@ cors.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ cors.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ ../server/ocsigen_extensions.cmx -deflatemod.cmo : ../baselib/ocsigen_stream.cmi \ +deflatemod.cmo : ../baselib/ocsigen_stream.cmi ../server/ocsigen_server.cmi \ ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ ../server/ocsigen_extensions.cmi ../server/ocsigen_config.cmi \ deflatemod.cmi -deflatemod.cmx : ../baselib/ocsigen_stream.cmx \ +deflatemod.cmx : ../baselib/ocsigen_stream.cmx ../server/ocsigen_server.cmx \ ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ ../server/ocsigen_extensions.cmx ../server/ocsigen_config.cmx \ deflatemod.cmi -deflatemod.cmi : ../server/ocsigen_extensions.cmi \ - ../server/ocsigen_config.cmi +deflatemod.cmi : ../server/ocsigen_server.cmi ../server/ocsigen_config.cmi extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi \ ../http/ocsigen_cookies.cmi ../server/ocsigen_config.cmi \ @@ -47,14 +46,15 @@ extendconfiguration.cmx : ../server/ocsigen_parseconfig.cmx \ ../http/ocsigen_cookies.cmx ../server/ocsigen_config.cmx \ ../http/ocsigen_charset_mime.cmx ocsipersist.cmi : -outputfilter.cmo : ../server/ocsigen_response.cmi ../baselib/ocsigen_lib.cmi \ +outputfilter.cmo : ../server/ocsigen_server.cmi \ + ../server/ocsigen_response.cmi ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi \ outputfilter.cmi -outputfilter.cmx : ../server/ocsigen_response.cmx ../baselib/ocsigen_lib.cmx \ +outputfilter.cmx : ../server/ocsigen_server.cmx \ + ../server/ocsigen_response.cmx ../baselib/ocsigen_lib.cmx \ ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx \ outputfilter.cmi -outputfilter.cmi : ../http/ocsigen_header.cmi \ - ../server/ocsigen_extensions.cmi +outputfilter.cmi : ../server/ocsigen_server.cmi ../http/ocsigen_header.cmi redirectmod.cmo : ../server/ocsigen_response.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi redirectmod.cmx : ../server/ocsigen_response.cmx ../baselib/ocsigen_lib.cmx \ @@ -69,13 +69,16 @@ rewritemod.cmo : ../server/ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi rewritemod.cmx : ../server/ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx -staticmod.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ - ../server/ocsigen_local_files.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi staticmod.cmi -staticmod.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ - ../server/ocsigen_local_files.cmx ../baselib/ocsigen_lib.cmx \ - ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx staticmod.cmi -staticmod.cmi : ../server/ocsigen_extensions.cmi +staticmod.cmo : ../server/ocsigen_server.cmi ../server/ocsigen_response.cmi \ + ../server/ocsigen_request.cmi ../server/ocsigen_local_files.cmi \ + ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ + ../server/ocsigen_extensions.cmi staticmod.cmi +staticmod.cmx : ../server/ocsigen_server.cmx ../server/ocsigen_response.cmx \ + ../server/ocsigen_request.cmx ../server/ocsigen_local_files.cmx \ + ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ + ../server/ocsigen_extensions.cmx staticmod.cmi +staticmod.cmi : ../server/ocsigen_server.cmi \ + ../server/ocsigen_extensions.cmi userconf.cmo : ../server/ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi userconf.cmx : ../server/ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index 4bd3cb79f..8e1307519 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -140,13 +140,13 @@ let () = ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () -let realm = Ocsigen_extensions.Virtual_host.Config.key () +let realm = Ocsigen_server.Vhost.Config.key () -let auth = Ocsigen_extensions.Virtual_host.Config.key () +let auth = Ocsigen_server.Vhost.Config.key () let register vh = - Ocsigen_extensions.Virtual_host.register vh - (fun {Ocsigen_extensions.Virtual_host.Config.accessor} -> + Ocsigen_server.Vhost.register vh + (fun {Ocsigen_server.Vhost.Config.accessor} -> match accessor realm, accessor auth with | Some realm, Some auth -> gen ~realm ~auth diff --git a/src/extensions/authbasic.mli b/src/extensions/authbasic.mli index 1bed19599..e209dc41b 100644 --- a/src/extensions/authbasic.mli +++ b/src/extensions/authbasic.mli @@ -56,11 +56,11 @@ val register_basic_authentication_method : (Xml.xml -> auth) -> unit from the point of view of plugin developers and is totally transparent to the plugin. *) -val realm : string Ocsigen_extensions.Virtual_host.Config.key +val realm : string Ocsigen_server.Vhost.Config.key -val auth : auth Ocsigen_extensions.Virtual_host.Config.key +val auth : auth Ocsigen_server.Vhost.Config.key -val register : Ocsigen_extensions.Virtual_host.t -> unit +val register : Ocsigen_server.Vhost.t -> unit (**/**) diff --git a/src/extensions/deflatemod.ml b/src/extensions/deflatemod.ml index 06d2839b8..6ac11e629 100644 --- a/src/extensions/deflatemod.ml +++ b/src/extensions/deflatemod.ml @@ -399,11 +399,11 @@ let () = ~init_fun:parse_global_config () -let mode = Ocsigen_extensions.Virtual_host.Config.key () +let mode = Ocsigen_server.Vhost.Config.key () let register vh = - Ocsigen_extensions.Virtual_host.register vh - (fun {Ocsigen_extensions.Virtual_host.Config.accessor} -> + Ocsigen_server.Vhost.register vh + (fun {Ocsigen_server.Vhost.Config.accessor} -> match accessor mode with | Some mode -> filter mode diff --git a/src/extensions/deflatemod.mli b/src/extensions/deflatemod.mli index dbd725b77..33d148ec8 100644 --- a/src/extensions/deflatemod.mli +++ b/src/extensions/deflatemod.mli @@ -9,6 +9,6 @@ type filter = [ val mode : [`All_but of filter list | `Only of filter list] - Ocsigen_extensions.Virtual_host.Config.key + Ocsigen_server.Vhost.Config.key -val register : Ocsigen_extensions.Virtual_host.t -> unit +val register : Ocsigen_server.Vhost.t -> unit diff --git a/src/extensions/outputfilter.ml b/src/extensions/outputfilter.ml index fa3181b0e..3a1cd48db 100644 --- a/src/extensions/outputfilter.ml +++ b/src/extensions/outputfilter.ml @@ -142,11 +142,11 @@ let () = ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () -let mode = Ocsigen_extensions.Virtual_host.Config.key () +let mode = Ocsigen_server.Vhost.Config.key () let register vh = - Ocsigen_extensions.Virtual_host.register vh - (fun {Ocsigen_extensions.Virtual_host.Config.accessor} -> + Ocsigen_server.Vhost.register vh + (fun {Ocsigen_server.Vhost.Config.accessor} -> match accessor mode with | Some (`Code c) -> gen_code c diff --git a/src/extensions/outputfilter.mli b/src/extensions/outputfilter.mli index a40694966..6bc9fa246 100644 --- a/src/extensions/outputfilter.mli +++ b/src/extensions/outputfilter.mli @@ -2,6 +2,6 @@ val mode : [ `Rewrite of (Ocsigen_header.Name.t * Pcre.regexp * string) | `Add of (Ocsigen_header.Name.t * string * bool option) | `Code of Cohttp.Code.status - ] Ocsigen_extensions.Virtual_host.Config.key + ] Ocsigen_server.Vhost.Config.key -val register : Ocsigen_extensions.Virtual_host.t -> unit +val register : Ocsigen_server.Vhost.t -> unit diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 836b39f6a..3a1469426 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -310,15 +310,15 @@ let () = () (* TODO: fix names and types, preprocess as we do for XML *) -let dir = Ocsigen_extensions.Virtual_host.Config.key () -let regexp = Ocsigen_extensions.Virtual_host.Config.key () -let opt_code = Ocsigen_extensions.Virtual_host.Config.key () -let opt_dest = Ocsigen_extensions.Virtual_host.Config.key () -let opt_root_checks = Ocsigen_extensions.Virtual_host.Config.key () +let dir = Ocsigen_server.Vhost.Config.key () +let regexp = Ocsigen_server.Vhost.Config.key () +let opt_code = Ocsigen_server.Vhost.Config.key () +let opt_dest = Ocsigen_server.Vhost.Config.key () +let opt_root_checks = Ocsigen_server.Vhost.Config.key () let register vh = - Ocsigen_extensions.Virtual_host.register vh - (fun {Ocsigen_extensions.Virtual_host.Config.accessor} r -> + Ocsigen_server.Vhost.register vh + (fun {Ocsigen_server.Vhost.Config.accessor} r -> let kind = kind (accessor dir) (accessor regexp) diff --git a/src/extensions/staticmod.mli b/src/extensions/staticmod.mli index c14da4ff0..70abfa942 100644 --- a/src/extensions/staticmod.mli +++ b/src/extensions/staticmod.mli @@ -1,11 +1,11 @@ -val dir : string Ocsigen_extensions.Virtual_host.Config.key +val dir : string Ocsigen_server.Vhost.Config.key val regexp : - Pcre.regexp Ocsigen_extensions.Virtual_host.Config.key + Pcre.regexp Ocsigen_server.Vhost.Config.key val opt_code : - Pcre.regexp Ocsigen_extensions.Virtual_host.Config.key + Pcre.regexp Ocsigen_server.Vhost.Config.key val opt_dest : - Ocsigen_extensions.ud_string Ocsigen_extensions.Virtual_host.Config.key + Ocsigen_extensions.ud_string Ocsigen_server.Vhost.Config.key val opt_root_checks : - Ocsigen_extensions.ud_string Ocsigen_extensions.Virtual_host.Config.key + Ocsigen_extensions.ud_string Ocsigen_server.Vhost.Config.key -val register : Ocsigen_extensions.Virtual_host.t -> unit +val register : Ocsigen_server.Vhost.t -> unit diff --git a/src/server/.depend b/src/server/.depend index 313e04459..996535682 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -67,15 +67,17 @@ ocsigen_response.cmi : ../http/ocsigen_header.cmi \ ocsigen_server.cmo : ocsigen_parseconfig.cmi ocsigen_messages.cmi \ ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ ocsigen_extensions.cmi ocsigen_config.cmi ocsigen_command.cmi \ - ocsigen_cohttp.cmi ../baselib/ocsigen_cache.cmi \ - ../baselib/dynlink_wrapper.cmo ocsigen_server.cmi + ocsigen_cohttp.cmi ../http/ocsigen_charset_mime.cmi \ + ../baselib/ocsigen_cache.cmi ../baselib/dynlink_wrapper.cmo \ + ocsigen_server.cmi ocsigen_server.cmx : ocsigen_parseconfig.cmx ocsigen_messages.cmx \ ../baselib/ocsigen_loader.cmx ../baselib/ocsigen_lib.cmx \ ocsigen_extensions.cmx ocsigen_config.cmx ocsigen_command.cmx \ - ocsigen_cohttp.cmx ../baselib/ocsigen_cache.cmx \ - ../baselib/dynlink_wrapper.cmx ocsigen_server.cmi -ocsigen_server.cmi : + ocsigen_cohttp.cmx ../http/ocsigen_charset_mime.cmx \ + ../baselib/ocsigen_cache.cmx ../baselib/dynlink_wrapper.cmx \ + ocsigen_server.cmi +ocsigen_server.cmi : ocsigen_extensions.cmi ../http/ocsigen_charset_mime.cmi server_main.cmo : ocsigen_server.cmi ocsigen_parseconfig.cmi \ - ocsigen_extensions.cmi ocsigen_config.cmi + ocsigen_config.cmi server_main.cmx : ocsigen_server.cmx ocsigen_parseconfig.cmx \ - ocsigen_extensions.cmx ocsigen_config.cmx + ocsigen_config.cmx diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index a19bb9284..a52b34a9c 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -643,152 +643,6 @@ let register | None -> default_parse_extension name (get_config ()) | Some f -> f (get_config ())); register ?fun_site ?end_init ?exn_handler ?respect_pipeline ()) - -type accessor = - { accessor : 'a . 'a Hmap.key -> 'a option } - -let compose_with_config m l = - compose (List.map (fun f -> f {accessor = fun k -> Hmap.find k m}) l) - -module type Hmap_wrapped = sig - type t - val get : t -> Hmap.t - val do_ : t -> (Hmap.t -> Hmap.t) -> unit -end - -module type Config_nested = sig - - type parent_t - - type 'a key - - val key : unit -> 'a key - - val find : parent_t -> 'a key -> 'a option - - val set : parent_t -> 'a key -> 'a -> unit - - val unset : parent_t -> 'a key -> unit - - type accessor = { accessor : 'a . 'a key -> 'a option } - -end - -module Make_config_nested (W : Hmap_wrapped) = struct - - type nonrec accessor - = accessor - = { accessor : 'a . 'a Hmap.key -> 'a option } - - type 'a key = 'a Hmap.key - - let key () = Hmap.Key.create () - - let find w k = Hmap.find k (W.get w) - - let set w k v = W.do_ w (Hmap.add k v) - - let unset w k = W.do_ w (Hmap.rem k) - -end - -module Virtual_host = struct - - type 'a config_key = 'a Hmap.key - - type t = { - vh_list : virtual_hosts ; - vh_config_info : config_info ; - mutable vh_config_map : Hmap.t ; - mutable vh_fun_l : (accessor -> extension) list ; - } - - let l = ref [] - - let default_re_string = ".*" - - let default_re = Ocsigen_lib.Netstring_pcre.regexp default_re_string - - let create - ?(config_info = default_config_info ()) - ?host_regexp - ?port () = - let vh_list = - match host_regexp with - | Some host_regexp when host_regexp = default_re_string -> - [default_re_string, default_re, port] - | None -> - [default_re_string, default_re, port] - | Some host_regexp -> - [host_regexp, Ocsigen_lib.Netstring_pcre.regexp host_regexp, port] - in - let vh = { - vh_list ; - vh_config_info = config_info ; - vh_config_map = Hmap.empty ; - vh_fun_l = [] - } in - l := vh :: !l; - vh - - let dump () = - let f { vh_list ; vh_config_info ; vh_config_map ; vh_fun_l } = - vh_list, - vh_config_info, - compose_with_config vh_config_map vh_fun_l - and l = - List.filter - (function {vh_fun_l = _ :: _} -> true | _ -> false) - (List.rev !l) - in - set_hosts (List.map f l) - - module Config = - Make_config_nested (struct - type nonrec t = t - let get {vh_config_map} = vh_config_map - let do_ ({vh_config_map} as vh) f = - vh.vh_config_map <- f vh_config_map - end) - - let register ({vh_fun_l} as vh) f = vh.vh_fun_l <- f :: vh_fun_l - -end - -module Site = struct - - type t = { - s_dir : string list ; - s_charset : Ocsigen_charset_mime.charset option ; - mutable s_config_map : Hmap.t ; - mutable s_fun_l : (accessor -> extension) list ; - } - - let create s_dir s_charset = { - s_dir = preprocess_site_path s_dir ; - s_charset ; - s_config_map = Hmap.empty ; - s_fun_l = [] - } - - module Config = - Make_config_nested (struct - type nonrec t = t - let get {s_config_map} = s_config_map - let do_ ({s_config_map} as s) f = - s.s_config_map <- f s_config_map - end) - - let register ({s_fun_l} as s) f = s.s_fun_l <- f :: s_fun_l - - let to_extension - ~parent_path - {s_dir ; s_charset ; s_fun_l ; s_config_map} = - let ext_of_children = compose_with_config s_config_map s_fun_l in - site_ext ext_of_children s_charset (parent_path @ s_dir) - -end - module Configuration = struct type attribute' = { diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 98076df6b..597cff3e6 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -410,13 +410,22 @@ val find_redirection : string (**/**) -(**/**) + +val preprocess_site_path : Ocsigen_lib.Url.path -> Ocsigen_lib.Url.path + +val compose : extension list -> extension_composite val make_parse_config : Ocsigen_lib.Url.path -> parse_config_aux -> parse_fun val parse_config_item : parse_config +val site_ext : + extension_composite -> + Ocsigen_charset_mime.charset option -> + Ocsigen_lib.Url.path -> + extension + val set_hosts : (virtual_hosts * config_info * extension_composite) list -> unit @@ -453,57 +462,3 @@ val sockets : Lwt_unix.file_descr list ref val sslsockets : Lwt_unix.file_descr list ref val set_we_have_xml_config : unit -> unit - -module type Config_nested = sig - - type parent_t - - type 'a key - - val key : unit -> 'a key - - val find : parent_t -> 'a key -> 'a option - - val set : parent_t -> 'a key -> 'a -> unit - - val unset : parent_t -> 'a key -> unit - - type accessor = { accessor : 'a . 'a key -> 'a option } - -end - -module Virtual_host : sig - - type t - - val create : - ?config_info:config_info -> - ?host_regexp:string -> - ?port:int -> - unit -> t - - module Config : Config_nested with type parent_t := t - - val register : t -> (Config.accessor -> extension) -> unit - - (**/**) - - val dump : unit -> unit - -end - -module Site : sig - - type t - - val create : string list -> Ocsigen_charset_mime.charset option -> t - - module Config : Config_nested - with type parent_t := t - and type 'a key = 'a Virtual_host.Config.key - - val register : t -> (Config.accessor -> extension) -> unit - - val to_extension : parent_path:string list -> t -> extension - -end diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index 29eefe92a..ce74e8611 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -141,6 +141,154 @@ let _ = in Ocsigen_command.register_command_function f +type accessor = + { accessor : 'a . 'a Hmap.key -> 'a option } + +let compose_with_config m l = + Ocsigen_extensions.compose + (List.map (fun f -> f {accessor = fun k -> Hmap.find k m}) l) + +module type Hmap_wrapped = sig + type t + val get : t -> Hmap.t + val do_ : t -> (Hmap.t -> Hmap.t) -> unit +end + +module type Config_nested = sig + + type parent_t + + type 'a key + + val key : unit -> 'a key + + val find : parent_t -> 'a key -> 'a option + + val set : parent_t -> 'a key -> 'a -> unit + + val unset : parent_t -> 'a key -> unit + + type accessor = { accessor : 'a . 'a key -> 'a option } + +end + +module Make_config_nested (W : Hmap_wrapped) = struct + + type nonrec accessor + = accessor + = { accessor : 'a . 'a Hmap.key -> 'a option } + + type 'a key = 'a Hmap.key + + let key () = Hmap.Key.create () + + let find w k = Hmap.find k (W.get w) + + let set w k v = W.do_ w (Hmap.add k v) + + let unset w k = W.do_ w (Hmap.rem k) + +end + +module Vhost = struct + + type 'a config_key = 'a Hmap.key + + type t = { + vh_list : Ocsigen_extensions.virtual_hosts ; + vh_config_info : Ocsigen_extensions.config_info ; + mutable vh_config_map : Hmap.t ; + mutable vh_fun_l : (accessor -> Ocsigen_extensions.extension) list ; + } + + let l = ref [] + + let default_re_string = ".*" + + let default_re = Ocsigen_lib.Netstring_pcre.regexp default_re_string + + let create + ?(config_info = Ocsigen_extensions.default_config_info ()) + ?host_regexp + ?port () = + let vh_list = + match host_regexp with + | Some host_regexp when host_regexp = default_re_string -> + [default_re_string, default_re, port] + | None -> + [default_re_string, default_re, port] + | Some host_regexp -> + [host_regexp, Ocsigen_lib.Netstring_pcre.regexp host_regexp, port] + in + let vh = { + vh_list ; + vh_config_info = config_info ; + vh_config_map = Hmap.empty ; + vh_fun_l = [] + } in + l := vh :: !l; + vh + + let dump () = + let f { vh_list ; vh_config_info ; vh_config_map ; vh_fun_l } = + vh_list, + vh_config_info, + compose_with_config vh_config_map vh_fun_l + and l = + List.filter + (function {vh_fun_l = _ :: _} -> true | _ -> false) + (List.rev !l) + in + Ocsigen_extensions.set_hosts (List.map f l) + + module Config = + Make_config_nested (struct + type nonrec t = t + let get {vh_config_map} = vh_config_map + let do_ ({vh_config_map} as vh) f = + vh.vh_config_map <- f vh_config_map + end) + + let register ({vh_fun_l} as vh) f = vh.vh_fun_l <- f :: vh_fun_l + +end + +module Site = struct + + type t = { + s_dir : string list ; + s_charset : Ocsigen_charset_mime.charset option ; + mutable s_config_map : Hmap.t ; + mutable s_fun_l : (accessor -> Ocsigen_extensions.extension) list ; + } + + let create s_dir s_charset = { + s_dir = Ocsigen_extensions.preprocess_site_path s_dir ; + s_charset ; + s_config_map = Hmap.empty ; + s_fun_l = [] + } + + module Config = + Make_config_nested (struct + type nonrec t = t + let get {s_config_map} = s_config_map + let do_ ({s_config_map} as s) f = + s.s_config_map <- f s_config_map + end) + + let register ({s_fun_l} as s) f = s.s_fun_l <- f :: s_fun_l + + let to_extension + ~parent_path + {s_dir ; s_charset ; s_fun_l ; s_config_map} = + let ext_of_children = compose_with_config s_config_map s_fun_l in + Ocsigen_extensions.site_ext + ext_of_children s_charset + (parent_path @ s_dir) + +end + let start ?config () = try @@ -293,7 +441,7 @@ let start ?config () = | Some s -> Ocsigen_parseconfig.later_pass s | None -> - Ocsigen_extensions.Virtual_host.dump ()); + Vhost.dump ()); Dynlink_wrapper.prohibit ["Ocsigen_extensions.R"]; (* As libraries are reloaded each time the config file is read, diff --git a/src/server/ocsigen_server.mli b/src/server/ocsigen_server.mli index ccbde2cf5..3ad1c9cdc 100644 --- a/src/server/ocsigen_server.mli +++ b/src/server/ocsigen_server.mli @@ -25,3 +25,62 @@ val reload : ?file : string -> unit -> unit (** Start the server. Never returns. *) val start : ?config : Xml.xml list list -> unit -> unit + +module type Config_nested = sig + + type parent_t + + type 'a key + + val key : unit -> 'a key + + val find : parent_t -> 'a key -> 'a option + + val set : parent_t -> 'a key -> 'a -> unit + + val unset : parent_t -> 'a key -> unit + + type accessor = { accessor : 'a . 'a key -> 'a option } + +end + +module Vhost : sig + + type t + + val create : + ?config_info:Ocsigen_extensions.config_info -> + ?host_regexp:string -> + ?port:int -> + unit -> t + + module Config : Config_nested with type parent_t := t + + val register : + t -> + (Config.accessor -> Ocsigen_extensions.extension) -> + unit + +end + +module Site : sig + + type t + + val create : string list -> Ocsigen_charset_mime.charset option -> t + + module Config : Config_nested + with type parent_t := t + and type 'a key = 'a Vhost.Config.key + + val register : + t -> + (Config.accessor -> Ocsigen_extensions.extension) -> + unit + + val to_extension : + parent_path:string list -> + t -> + Ocsigen_extensions.extension + +end From b2d26c71e15c5dd259201eb43ee0ed938e5b75dc Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 29 May 2017 22:56:19 +0200 Subject: [PATCH 086/111] Remove unused Ocsigen_extensions.*we_have_xml_config --- src/server/ocsigen_extensions.ml | 5 ----- src/server/ocsigen_extensions.mli | 2 -- src/server/server_main.ml | 5 +---- 3 files changed, 1 insertion(+), 11 deletions(-) diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index a52b34a9c..e8c62190e 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -18,11 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let we_have_xml_config, set_we_have_xml_config = - let r = ref false in - (fun () -> !r), - (fun () -> r := true) - let section = Lwt_log.Section.make "ocsigen:ext" open Lwt.Infix diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 597cff3e6..7cfa0def5 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -460,5 +460,3 @@ val set_config : Xml.xml list -> unit val sockets : Lwt_unix.file_descr list ref val sslsockets : Lwt_unix.file_descr list ref - -val set_we_have_xml_config : unit -> unit diff --git a/src/server/server_main.ml b/src/server/server_main.ml index 9a3318005..dc0a18b8a 100644 --- a/src/server/server_main.ml +++ b/src/server/server_main.ml @@ -27,7 +27,4 @@ let () = exit 0 let () = - Ocsigen_extensions.set_we_have_xml_config (); - Ocsigen_server.start - ~config:(Ocsigen_parseconfig.parse_config ()) - () + Ocsigen_server.start ~config:(Ocsigen_parseconfig.parse_config ()) () From 2933f19d29dbf9d18e4c794ad07de764523c6ee3 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 30 May 2017 14:54:54 +0200 Subject: [PATCH 087/111] Update CORS for use without XML config --- src/Makefile.filelist | 7 ++++--- src/extensions/.depend | 13 +++++++------ src/extensions/cors.ml | 36 ++++++++++++++++++++++++++---------- src/extensions/cors.mli | 6 ++++++ 4 files changed, 43 insertions(+), 19 deletions(-) create mode 100644 src/extensions/cors.mli diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 3a66ff98b..2bf9de19c 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -48,9 +48,10 @@ endif PLUGINS_BIN := -PLUGINS_INTF := extensions/authbasic.cmi extensions/accesscontrol.cmi \ - extensions/ocsipersist.cmi extensions/staticmod.cmi \ - extensions/deflatemod.cmi extensions/outputfilter.cmi +PLUGINS_INTF := extensions/accesscontrol.cmi extensions/authbasic.cmi \ + extensions/cors.cmi extensions/deflatemod.cmi \ + extensions/ocsipersist.cmi \ + extensions/outputfilter.cmi extensions/staticmod.cmi PLUGINS_IMPL := extensions/accesscontrol.cmo extensions/authbasic.cmo \ extensions/cors.cmo extensions/outputfilter.cmo \ diff --git a/src/extensions/.depend b/src/extensions/.depend index d8e0cfc0a..7be8c50de 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -20,12 +20,13 @@ cgimod.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ cgimod.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ ../server/ocsigen_config.cmx -cors.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ - ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ - ../server/ocsigen_extensions.cmi -cors.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ - ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ - ../server/ocsigen_extensions.cmx +cors.cmo : ../server/ocsigen_server.cmi ../server/ocsigen_response.cmi \ + ../server/ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ + ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi cors.cmi +cors.cmx : ../server/ocsigen_server.cmx ../server/ocsigen_response.cmx \ + ../server/ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ + ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx cors.cmi +cors.cmi : ../server/ocsigen_server.cmi deflatemod.cmo : ../baselib/ocsigen_stream.cmi ../server/ocsigen_server.cmi \ ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index 50222b802..d7c588403 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -28,9 +28,9 @@ let default_frame () = Ocsigen_response.make (Cohttp.Response.make ~status:`OK ()) type config = { - allowed_method : Cohttp.Code.meth list option; + methods : Cohttp.Code.meth list option; (* None means: all method are accepted *) - allowed_credentials : bool; + credentials : bool; max_age : int option; exposed_headers : string list } @@ -51,7 +51,7 @@ let add_headers config r response = let l = [Ocsigen_header.Name.origin, origin] in let l = - if config.allowed_credentials then + if config.credentials then (Ocsigen_header.Name.access_control_allow_credentials, "true") :: l else l @@ -63,8 +63,8 @@ let add_headers config r response = Ocsigen_header.Name.access_control_request_method with | Some request_method -> - let allowed_method = - match config.allowed_method with + let methods = + match config.methods with | None -> true | Some l -> @@ -73,7 +73,7 @@ let add_headers config r response = with _ -> false in - if allowed_method then + if methods then (Ocsigen_header.Name.access_control_allow_methods, request_method) :: l @@ -148,8 +148,8 @@ let comma_space_regexp = let parse_config _ _ parse_fun config_elem = let config = ref { - allowed_method = None; - allowed_credentials = false; + methods = None; + credentials = false; max_age = None; exposed_headers = [] } in @@ -165,7 +165,7 @@ let parse_config _ _ parse_fun config_elem = ~name:"credentials" (fun s -> let s = bool_of_string s in - config := { !config with allowed_credentials = s }); + config := { !config with credentials = s }); Configuration.attribute ~name:"max_age" (fun s -> @@ -187,7 +187,7 @@ let parse_config _ _ parse_fun config_elem = comma_space_regexp s in let s = Some (List.map Cohttp.Code.method_of_string s) in - config := { !config with allowed_method = s }); + config := { !config with methods = s }); ] ()] config_elem @@ -199,3 +199,19 @@ let () = ~name:"CORS" ~fun_site:(fun _ _ _ -> parse_config) () + +let credentials = Ocsigen_server.Vhost.Config.key () +let max_age = Ocsigen_server.Vhost.Config.key () +let exposed_headers = Ocsigen_server.Vhost.Config.key () +let methods = Ocsigen_server.Vhost.Config.key () + +let register vh = + Ocsigen_server.Vhost.register vh + (fun {Ocsigen_server.Vhost.Config.accessor} -> + let methods = accessor methods + and credentials = Ocsigen_lib.Option.get' false (accessor credentials) + and max_age = accessor max_age + and exposed_headers = + Ocsigen_lib.Option.get' [] (accessor exposed_headers) + in + main {credentials ; methods ; max_age ; exposed_headers}) diff --git a/src/extensions/cors.mli b/src/extensions/cors.mli new file mode 100644 index 000000000..5377c6e2c --- /dev/null +++ b/src/extensions/cors.mli @@ -0,0 +1,6 @@ +val credentials : bool Ocsigen_server.Vhost.Config.key +val max_age : int Ocsigen_server.Vhost.Config.key +val exposed_headers : string list Ocsigen_server.Vhost.Config.key +val methods : Cohttp.Code.meth list Ocsigen_server.Vhost.Config.key + +val register : Ocsigen_server.Vhost.t -> unit From 9817732be3f9d9f254c638e14d2e6620adc8061c Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 30 May 2017 16:53:42 +0200 Subject: [PATCH 088/111] Ocsigen_server.Vhost.Config.key ~preprocess --- src/extensions/staticmod.ml | 18 ++++++++++++------ src/extensions/staticmod.mli | 10 ++++------ src/server/ocsigen_server.ml | 31 ++++++++++++++++++++----------- src/server/ocsigen_server.mli | 2 +- 4 files changed, 37 insertions(+), 24 deletions(-) diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 3a1469426..4f3fdcb8b 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -310,18 +310,24 @@ let () = () (* TODO: fix names and types, preprocess as we do for XML *) + +let preprocess s = "^" ^ s ^ "$" + let dir = Ocsigen_server.Vhost.Config.key () -let regexp = Ocsigen_server.Vhost.Config.key () -let opt_code = Ocsigen_server.Vhost.Config.key () -let opt_dest = Ocsigen_server.Vhost.Config.key () -let opt_root_checks = Ocsigen_server.Vhost.Config.key () +let regexp = Ocsigen_server.Vhost.Config.key ~preprocess () +let code = Ocsigen_server.Vhost.Config.key ~preprocess () +let dest = Ocsigen_server.Vhost.Config.key () +let root_checks = Ocsigen_server.Vhost.Config.key () let register vh = Ocsigen_server.Vhost.register vh (fun {Ocsigen_server.Vhost.Config.accessor} r -> let kind = kind - (accessor dir) (accessor regexp) - (accessor opt_code) (accessor opt_dest) (accessor opt_root_checks) + (accessor dir) + (Ocsigen_lib.Option.map Pcre.regexp (accessor regexp)) + (Ocsigen_lib.Option.map Pcre.regexp (accessor code)) + (accessor dest) + (accessor root_checks) in gen ~usermode:None kind r) diff --git a/src/extensions/staticmod.mli b/src/extensions/staticmod.mli index 70abfa942..035bdfa7d 100644 --- a/src/extensions/staticmod.mli +++ b/src/extensions/staticmod.mli @@ -1,11 +1,9 @@ val dir : string Ocsigen_server.Vhost.Config.key -val regexp : - Pcre.regexp Ocsigen_server.Vhost.Config.key -val opt_code : - Pcre.regexp Ocsigen_server.Vhost.Config.key -val opt_dest : +val regexp : string Ocsigen_server.Vhost.Config.key +val code : string Ocsigen_server.Vhost.Config.key +val dest : Ocsigen_extensions.ud_string Ocsigen_server.Vhost.Config.key -val opt_root_checks : +val root_checks : Ocsigen_extensions.ud_string Ocsigen_server.Vhost.Config.key val register : Ocsigen_server.Vhost.t -> unit diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index ce74e8611..2db4662c5 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -142,11 +142,11 @@ let _ = Ocsigen_command.register_command_function f type accessor = - { accessor : 'a . 'a Hmap.key -> 'a option } + { accessor : 'a . (('a -> 'a) option * 'a Hmap.key) -> 'a option } let compose_with_config m l = Ocsigen_extensions.compose - (List.map (fun f -> f {accessor = fun k -> Hmap.find k m}) l) + (List.map (fun f -> f {accessor = fun (_, k) -> Hmap.find k m}) l) module type Hmap_wrapped = sig type t @@ -160,7 +160,7 @@ module type Config_nested = sig type 'a key - val key : unit -> 'a key + val key : ?preprocess:('a -> 'a) -> unit -> 'a key val find : parent_t -> 'a key -> 'a option @@ -168,25 +168,34 @@ module type Config_nested = sig val unset : parent_t -> 'a key -> unit - type accessor = { accessor : 'a . 'a key -> 'a option } + type accessor = + { accessor : 'a . 'a key -> 'a option } end module Make_config_nested (W : Hmap_wrapped) = struct + type 'a key = ('a -> 'a) option * 'a Hmap.key + type nonrec accessor = accessor - = { accessor : 'a . 'a Hmap.key -> 'a option } - - type 'a key = 'a Hmap.key + = { accessor : 'a . 'a key -> 'a option } - let key () = Hmap.Key.create () + let key ?preprocess () = preprocess, Hmap.Key.create () - let find w k = Hmap.find k (W.get w) + let find w (_, k) = Hmap.find k (W.get w) - let set w k v = W.do_ w (Hmap.add k v) + let set w (f, k) v = + let v = + match f with + | Some f -> + f v + | None -> + v + in + W.do_ w (Hmap.add k v) - let unset w k = W.do_ w (Hmap.rem k) + let unset w (_, k) = W.do_ w (Hmap.rem k) end diff --git a/src/server/ocsigen_server.mli b/src/server/ocsigen_server.mli index 3ad1c9cdc..f1d2b5756 100644 --- a/src/server/ocsigen_server.mli +++ b/src/server/ocsigen_server.mli @@ -32,7 +32,7 @@ module type Config_nested = sig type 'a key - val key : unit -> 'a key + val key : ?preprocess:('a -> 'a) -> unit -> 'a key val find : parent_t -> 'a key -> 'a option From 6baca78b843fcb64947168a9990d20d5e757dfb2 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 30 May 2017 16:53:42 +0200 Subject: [PATCH 089/111] Update redirectmod for use without XML config --- src/Makefile.filelist | 3 +- src/extensions/.depend | 11 ++++-- src/extensions/redirectmod.ml | 69 ++++++++++++++++++++++------------ src/extensions/redirectmod.mli | 12 ++++++ src/extensions/staticmod.ml | 4 +- 5 files changed, 67 insertions(+), 32 deletions(-) create mode 100644 src/extensions/redirectmod.mli diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 2bf9de19c..62e70867d 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -51,7 +51,8 @@ PLUGINS_BIN := PLUGINS_INTF := extensions/accesscontrol.cmi extensions/authbasic.cmi \ extensions/cors.cmi extensions/deflatemod.cmi \ extensions/ocsipersist.cmi \ - extensions/outputfilter.cmi extensions/staticmod.cmi + extensions/outputfilter.cmi \ + extensions/redirectmod.cmi extensions/staticmod.cmi PLUGINS_IMPL := extensions/accesscontrol.cmo extensions/authbasic.cmo \ extensions/cors.cmo extensions/outputfilter.cmo \ diff --git a/src/extensions/.depend b/src/extensions/.depend index 7be8c50de..d2ba26051 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -56,10 +56,13 @@ outputfilter.cmx : ../server/ocsigen_server.cmx \ ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx \ outputfilter.cmi outputfilter.cmi : ../server/ocsigen_server.cmi ../http/ocsigen_header.cmi -redirectmod.cmo : ../server/ocsigen_response.cmi ../baselib/ocsigen_lib.cmi \ - ../server/ocsigen_extensions.cmi -redirectmod.cmx : ../server/ocsigen_response.cmx ../baselib/ocsigen_lib.cmx \ - ../server/ocsigen_extensions.cmx +redirectmod.cmo : ../server/ocsigen_server.cmi \ + ../server/ocsigen_response.cmi ../server/ocsigen_extensions.cmi \ + redirectmod.cmi +redirectmod.cmx : ../server/ocsigen_server.cmx \ + ../server/ocsigen_response.cmx ../server/ocsigen_extensions.cmx \ + redirectmod.cmi +redirectmod.cmi : ../server/ocsigen_server.cmi revproxy.cmo : ../server/ocsigen_response.cmi ../server/ocsigen_request.cmi \ ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ ../server/ocsigen_extensions.cmi diff --git a/src/extensions/redirectmod.ml b/src/extensions/redirectmod.ml index a69450f1c..fc11f276a 100644 --- a/src/extensions/redirectmod.ml +++ b/src/extensions/redirectmod.ml @@ -23,26 +23,35 @@ let section = Lwt_log.Section.make "ocsigen:ext:redirectmod" (* The table of redirections for each virtual server *) -type assockind = Regexp of - Pcre.regexp * - string * - Ocsigen_lib.yesnomaybe * (* full url *) - bool (* temporary *) +type redirection = { + r_regexp : Pcre.regexp ; + r_dest : string ; + r_full : [`Yes | `No | `Maybe] ; + r_temp : bool +} -let attempt_redir dir err ri () = +let create_redirection + ?(full = `Yes) + ?(temporary = false) + ~regexp r_dest = + let r_regexp = Pcre.regexp ("^" ^ regexp ^ "$") in + { r_regexp ; r_dest ; r_full = full ; r_temp = temporary } + +let attempt_redir + { r_regexp ; r_dest ; r_full ; r_temp } + err ri () = Lwt_log.ign_info ~section "Is it a redirection?"; - let Regexp (regexp, dest, full, temp) = dir in let redir = let find full = Ocsigen_extensions.find_redirection - regexp full dest ri + r_regexp full r_dest ri in - match full with - | Ocsigen_lib.Yes -> + match r_full with + | `Yes -> find true - | Ocsigen_lib.No -> + | `No -> find false - | Ocsigen_lib.Maybe -> + | `Maybe -> try find false with Ocsigen_extensions.Not_concerned -> @@ -50,13 +59,13 @@ let attempt_redir dir err ri () = in Lwt_log.ign_info_f ~section "YES! %s redirection to: %s" - (if temp then "Temporary " else "Permanent ") + (if r_temp then "Temporary " else "Permanent ") redir; Lwt.return @@ Ocsigen_extensions.Ext_found (fun () -> Lwt.return @@ Ocsigen_response.make @@ let headers = Cohttp.Header.(init_with "Location" redir) - and status = if temp then `Found else `Moved_permanently in + and status = if r_temp then `Found else `Moved_permanently in Cohttp.Response.make ~status ~headers ()) (** The function that will generate the pages from the request *) @@ -72,9 +81,9 @@ let gen dir = function Lwt.fail e let parse_config config_elem = - let pattern = ref None + let regexp = ref None and dest = ref "" - and mode = ref Ocsigen_lib.Yes + and mode = ref `Yes and temporary = ref false in Ocsigen_extensions.( Configuration.process_element @@ -87,18 +96,18 @@ let parse_config config_elem = Configuration.attribute ~name:"regexp" (fun s -> - pattern := Some ("^" ^ s ^ "$"); - mode := Ocsigen_lib.Maybe); + regexp := Some ("^" ^ s ^ "$"); + mode := `Maybe); Configuration.attribute ~name:"fullurl" (fun s -> - pattern := Some ("^" ^ s ^ "$"); - mode := Ocsigen_lib.Yes); + regexp := Some s; + mode := `Yes); Configuration.attribute ~name:"suburl" (fun s -> - pattern := Some ("^" ^ s ^ "$"); - mode := Ocsigen_lib.No); + regexp := Some s; + mode := `No); Configuration.attribute ~name:"dest" ~obligatory:true @@ -110,15 +119,25 @@ let parse_config config_elem = ()] config_elem ); - match !pattern with + match !regexp with | None -> Ocsigen_extensions.badconfig "Missing attribute regexp for " | Some regexp -> - gen (Regexp (Ocsigen_lib.Netstring_pcre.regexp regexp, - !dest, !mode, !temporary)) + gen (create_redirection ~full:!mode ~regexp ~temporary:!temporary !dest) let () = Ocsigen_extensions.register ~name:"redirectmod" ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () + +let redirection = Ocsigen_server.Vhost.Config.key () + +let register vh = + Ocsigen_server.Vhost.register vh + (fun {Ocsigen_server.Vhost.Config.accessor} -> + match accessor redirection with + | Some redirection -> + gen redirection + | None -> + failwith "Redirectmod.redirection not set") diff --git a/src/extensions/redirectmod.mli b/src/extensions/redirectmod.mli new file mode 100644 index 000000000..62463f8a6 --- /dev/null +++ b/src/extensions/redirectmod.mli @@ -0,0 +1,12 @@ +type redirection + +val create_redirection : + ?full : [ `Maybe | `No | `Yes ] -> + ?temporary : bool -> + regexp : string -> + string -> + redirection + +val redirection : redirection Ocsigen_server.Vhost.Config.key + +val register : Ocsigen_server.Vhost.t -> unit diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 4f3fdcb8b..11f5e8190 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -321,7 +321,7 @@ let root_checks = Ocsigen_server.Vhost.Config.key () let register vh = Ocsigen_server.Vhost.register vh - (fun {Ocsigen_server.Vhost.Config.accessor} r -> + (fun {Ocsigen_server.Vhost.Config.accessor} -> let kind = kind (accessor dir) @@ -330,4 +330,4 @@ let register vh = (accessor dest) (accessor root_checks) in - gen ~usermode:None kind r) + gen ~usermode:None kind) From ab7170028852b7fa1ca7ed961fadcec26f1c4330 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 7 Jun 2017 18:07:08 +0200 Subject: [PATCH 090/111] Unify Ocsigen_server.{Vhost,Site} Also give extensions access to more info. Needed for Eliom. --- src/extensions/authbasic.ml | 8 ++-- src/extensions/authbasic.mli | 6 +-- src/extensions/cors.ml | 12 ++--- src/extensions/cors.mli | 10 ++--- src/extensions/deflatemod.ml | 6 +-- src/extensions/deflatemod.mli | 4 +- src/extensions/outputfilter.ml | 6 +-- src/extensions/outputfilter.mli | 4 +- src/extensions/redirectmod.ml | 6 +-- src/extensions/redirectmod.mli | 4 +- src/extensions/staticmod.ml | 14 +++--- src/extensions/staticmod.mli | 12 ++--- src/server/ocsigen_server.ml | 79 ++++++++++----------------------- src/server/ocsigen_server.mli | 31 +++---------- 14 files changed, 77 insertions(+), 125 deletions(-) diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index 8e1307519..cbed0319b 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -140,13 +140,13 @@ let () = ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () -let realm = Ocsigen_server.Vhost.Config.key () +let realm = Ocsigen_server.Site.Config.key () -let auth = Ocsigen_server.Vhost.Config.key () +let auth = Ocsigen_server.Site.Config.key () let register vh = - Ocsigen_server.Vhost.register vh - (fun {Ocsigen_server.Vhost.Config.accessor} -> + Ocsigen_server.Site.register vh + (fun _ _ _ {Ocsigen_server.Site.Config.accessor} -> match accessor realm, accessor auth with | Some realm, Some auth -> gen ~realm ~auth diff --git a/src/extensions/authbasic.mli b/src/extensions/authbasic.mli index e209dc41b..1ea91e78f 100644 --- a/src/extensions/authbasic.mli +++ b/src/extensions/authbasic.mli @@ -56,11 +56,11 @@ val register_basic_authentication_method : (Xml.xml -> auth) -> unit from the point of view of plugin developers and is totally transparent to the plugin. *) -val realm : string Ocsigen_server.Vhost.Config.key +val realm : string Ocsigen_server.Site.Config.key -val auth : auth Ocsigen_server.Vhost.Config.key +val auth : auth Ocsigen_server.Site.Config.key -val register : Ocsigen_server.Vhost.t -> unit +val register : Ocsigen_server.Site.t -> unit (**/**) diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index d7c588403..53e0ac255 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -200,14 +200,14 @@ let () = ~fun_site:(fun _ _ _ -> parse_config) () -let credentials = Ocsigen_server.Vhost.Config.key () -let max_age = Ocsigen_server.Vhost.Config.key () -let exposed_headers = Ocsigen_server.Vhost.Config.key () -let methods = Ocsigen_server.Vhost.Config.key () +let credentials = Ocsigen_server.Site.Config.key () +let max_age = Ocsigen_server.Site.Config.key () +let exposed_headers = Ocsigen_server.Site.Config.key () +let methods = Ocsigen_server.Site.Config.key () let register vh = - Ocsigen_server.Vhost.register vh - (fun {Ocsigen_server.Vhost.Config.accessor} -> + Ocsigen_server.Site.register vh + (fun _ _ _ {Ocsigen_server.Site.Config.accessor} -> let methods = accessor methods and credentials = Ocsigen_lib.Option.get' false (accessor credentials) and max_age = accessor max_age diff --git a/src/extensions/cors.mli b/src/extensions/cors.mli index 5377c6e2c..5e0439e6f 100644 --- a/src/extensions/cors.mli +++ b/src/extensions/cors.mli @@ -1,6 +1,6 @@ -val credentials : bool Ocsigen_server.Vhost.Config.key -val max_age : int Ocsigen_server.Vhost.Config.key -val exposed_headers : string list Ocsigen_server.Vhost.Config.key -val methods : Cohttp.Code.meth list Ocsigen_server.Vhost.Config.key +val credentials : bool Ocsigen_server.Site.Config.key +val max_age : int Ocsigen_server.Site.Config.key +val exposed_headers : string list Ocsigen_server.Site.Config.key +val methods : Cohttp.Code.meth list Ocsigen_server.Site.Config.key -val register : Ocsigen_server.Vhost.t -> unit +val register : Ocsigen_server.Site.t -> unit diff --git a/src/extensions/deflatemod.ml b/src/extensions/deflatemod.ml index 6ac11e629..43882405f 100644 --- a/src/extensions/deflatemod.ml +++ b/src/extensions/deflatemod.ml @@ -399,11 +399,11 @@ let () = ~init_fun:parse_global_config () -let mode = Ocsigen_server.Vhost.Config.key () +let mode = Ocsigen_server.Site.Config.key () let register vh = - Ocsigen_server.Vhost.register vh - (fun {Ocsigen_server.Vhost.Config.accessor} -> + Ocsigen_server.Site.register vh + (fun _ _ _ {Ocsigen_server.Site.Config.accessor} -> match accessor mode with | Some mode -> filter mode diff --git a/src/extensions/deflatemod.mli b/src/extensions/deflatemod.mli index 33d148ec8..a8624bf1e 100644 --- a/src/extensions/deflatemod.mli +++ b/src/extensions/deflatemod.mli @@ -9,6 +9,6 @@ type filter = [ val mode : [`All_but of filter list | `Only of filter list] - Ocsigen_server.Vhost.Config.key + Ocsigen_server.Site.Config.key -val register : Ocsigen_server.Vhost.t -> unit +val register : Ocsigen_server.Site.t -> unit diff --git a/src/extensions/outputfilter.ml b/src/extensions/outputfilter.ml index 3a1cd48db..0850ded4b 100644 --- a/src/extensions/outputfilter.ml +++ b/src/extensions/outputfilter.ml @@ -142,11 +142,11 @@ let () = ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () -let mode = Ocsigen_server.Vhost.Config.key () +let mode = Ocsigen_server.Site.Config.key () let register vh = - Ocsigen_server.Vhost.register vh - (fun {Ocsigen_server.Vhost.Config.accessor} -> + Ocsigen_server.Site.register vh + (fun _ _ _ {Ocsigen_server.Site.Config.accessor} -> match accessor mode with | Some (`Code c) -> gen_code c diff --git a/src/extensions/outputfilter.mli b/src/extensions/outputfilter.mli index 6bc9fa246..de783d3f4 100644 --- a/src/extensions/outputfilter.mli +++ b/src/extensions/outputfilter.mli @@ -2,6 +2,6 @@ val mode : [ `Rewrite of (Ocsigen_header.Name.t * Pcre.regexp * string) | `Add of (Ocsigen_header.Name.t * string * bool option) | `Code of Cohttp.Code.status - ] Ocsigen_server.Vhost.Config.key + ] Ocsigen_server.Site.Config.key -val register : Ocsigen_server.Vhost.t -> unit +val register : Ocsigen_server.Site.t -> unit diff --git a/src/extensions/redirectmod.ml b/src/extensions/redirectmod.ml index fc11f276a..42367cf2b 100644 --- a/src/extensions/redirectmod.ml +++ b/src/extensions/redirectmod.ml @@ -131,11 +131,11 @@ let () = ~fun_site:(fun _ _ _ _ _ _ -> parse_config) () -let redirection = Ocsigen_server.Vhost.Config.key () +let redirection = Ocsigen_server.Site.Config.key () let register vh = - Ocsigen_server.Vhost.register vh - (fun {Ocsigen_server.Vhost.Config.accessor} -> + Ocsigen_server.Site.register vh + (fun _ _ _ {Ocsigen_server.Site.Config.accessor} -> match accessor redirection with | Some redirection -> gen redirection diff --git a/src/extensions/redirectmod.mli b/src/extensions/redirectmod.mli index 62463f8a6..b4ead97a0 100644 --- a/src/extensions/redirectmod.mli +++ b/src/extensions/redirectmod.mli @@ -7,6 +7,6 @@ val create_redirection : string -> redirection -val redirection : redirection Ocsigen_server.Vhost.Config.key +val redirection : redirection Ocsigen_server.Site.Config.key -val register : Ocsigen_server.Vhost.t -> unit +val register : Ocsigen_server.Site.t -> unit diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index 11f5e8190..cde24a2cb 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -313,15 +313,15 @@ let () = let preprocess s = "^" ^ s ^ "$" -let dir = Ocsigen_server.Vhost.Config.key () -let regexp = Ocsigen_server.Vhost.Config.key ~preprocess () -let code = Ocsigen_server.Vhost.Config.key ~preprocess () -let dest = Ocsigen_server.Vhost.Config.key () -let root_checks = Ocsigen_server.Vhost.Config.key () +let dir = Ocsigen_server.Site.Config.key () +let regexp = Ocsigen_server.Site.Config.key ~preprocess () +let code = Ocsigen_server.Site.Config.key ~preprocess () +let dest = Ocsigen_server.Site.Config.key () +let root_checks = Ocsigen_server.Site.Config.key () let register vh = - Ocsigen_server.Vhost.register vh - (fun {Ocsigen_server.Vhost.Config.accessor} -> + Ocsigen_server.Site.register vh + (fun _ _ _ {Ocsigen_server.Site.Config.accessor} -> let kind = kind (accessor dir) diff --git a/src/extensions/staticmod.mli b/src/extensions/staticmod.mli index 035bdfa7d..9aa5f57bb 100644 --- a/src/extensions/staticmod.mli +++ b/src/extensions/staticmod.mli @@ -1,9 +1,9 @@ -val dir : string Ocsigen_server.Vhost.Config.key -val regexp : string Ocsigen_server.Vhost.Config.key -val code : string Ocsigen_server.Vhost.Config.key +val dir : string Ocsigen_server.Site.Config.key +val regexp : string Ocsigen_server.Site.Config.key +val code : string Ocsigen_server.Site.Config.key val dest : - Ocsigen_extensions.ud_string Ocsigen_server.Vhost.Config.key + Ocsigen_extensions.ud_string Ocsigen_server.Site.Config.key val root_checks : - Ocsigen_extensions.ud_string Ocsigen_server.Vhost.Config.key + Ocsigen_extensions.ud_string Ocsigen_server.Site.Config.key -val register : Ocsigen_server.Vhost.t -> unit +val register : Ocsigen_server.Site.t -> unit diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index 2db4662c5..49f8254b6 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -199,15 +199,16 @@ module Make_config_nested (W : Hmap_wrapped) = struct end -module Vhost = struct +module Site = struct type 'a config_key = 'a Hmap.key type t = { - vh_list : Ocsigen_extensions.virtual_hosts ; - vh_config_info : Ocsigen_extensions.config_info ; - mutable vh_config_map : Hmap.t ; - mutable vh_fun_l : (accessor -> Ocsigen_extensions.extension) list ; + s_list : Ocsigen_extensions.virtual_hosts ; + s_config_info : Ocsigen_extensions.config_info ; + s_path : Ocsigen_lib.Url.path ; + mutable s_config_map : Hmap.t ; + mutable s_fun_l : (accessor -> Ocsigen_extensions.extension) list ; } let l = ref [] @@ -219,8 +220,9 @@ module Vhost = struct let create ?(config_info = Ocsigen_extensions.default_config_info ()) ?host_regexp + ?(path = []) ?port () = - let vh_list = + let s_list = match host_regexp with | Some host_regexp when host_regexp = default_re_string -> [default_re_string, default_re, port] @@ -230,71 +232,38 @@ module Vhost = struct [host_regexp, Ocsigen_lib.Netstring_pcre.regexp host_regexp, port] in let vh = { - vh_list ; - vh_config_info = config_info ; - vh_config_map = Hmap.empty ; - vh_fun_l = [] + s_list ; + s_path = path ; + s_config_info = config_info ; + s_config_map = Hmap.empty ; + s_fun_l = [] } in l := vh :: !l; vh let dump () = - let f { vh_list ; vh_config_info ; vh_config_map ; vh_fun_l } = - vh_list, - vh_config_info, - compose_with_config vh_config_map vh_fun_l + let f { s_list ; s_config_info ; s_config_map ; s_fun_l } = + s_list, + s_config_info, + compose_with_config s_config_map s_fun_l and l = List.filter - (function {vh_fun_l = _ :: _} -> true | _ -> false) + (function {s_fun_l = _ :: _} -> true | _ -> false) (List.rev !l) in Ocsigen_extensions.set_hosts (List.map f l) - module Config = - Make_config_nested (struct - type nonrec t = t - let get {vh_config_map} = vh_config_map - let do_ ({vh_config_map} as vh) f = - vh.vh_config_map <- f vh_config_map - end) - - let register ({vh_fun_l} as vh) f = vh.vh_fun_l <- f :: vh_fun_l - -end - -module Site = struct - - type t = { - s_dir : string list ; - s_charset : Ocsigen_charset_mime.charset option ; - mutable s_config_map : Hmap.t ; - mutable s_fun_l : (accessor -> Ocsigen_extensions.extension) list ; - } - - let create s_dir s_charset = { - s_dir = Ocsigen_extensions.preprocess_site_path s_dir ; - s_charset ; - s_config_map = Hmap.empty ; - s_fun_l = [] - } - module Config = Make_config_nested (struct type nonrec t = t let get {s_config_map} = s_config_map - let do_ ({s_config_map} as s) f = - s.s_config_map <- f s_config_map + let do_ ({s_config_map} as vh) f = + vh.s_config_map <- f s_config_map end) - let register ({s_fun_l} as s) f = s.s_fun_l <- f :: s_fun_l - - let to_extension - ~parent_path - {s_dir ; s_charset ; s_fun_l ; s_config_map} = - let ext_of_children = compose_with_config s_config_map s_fun_l in - Ocsigen_extensions.site_ext - ext_of_children s_charset - (parent_path @ s_dir) + let register + ({s_list ; s_config_info ; s_path ; s_fun_l } as vh) f = + vh.s_fun_l <- f s_list s_config_info s_path :: s_fun_l end @@ -450,7 +419,7 @@ let start ?config () = | Some s -> Ocsigen_parseconfig.later_pass s | None -> - Vhost.dump ()); + Site.dump ()); Dynlink_wrapper.prohibit ["Ocsigen_extensions.R"]; (* As libraries are reloaded each time the config file is read, diff --git a/src/server/ocsigen_server.mli b/src/server/ocsigen_server.mli index f1d2b5756..dccf8a1e6 100644 --- a/src/server/ocsigen_server.mli +++ b/src/server/ocsigen_server.mli @@ -44,13 +44,14 @@ module type Config_nested = sig end -module Vhost : sig +module Site : sig type t val create : ?config_info:Ocsigen_extensions.config_info -> ?host_regexp:string -> + ?path:Ocsigen_lib.Url.path -> ?port:int -> unit -> t @@ -58,29 +59,11 @@ module Vhost : sig val register : t -> - (Config.accessor -> Ocsigen_extensions.extension) -> + (Ocsigen_extensions.virtual_hosts -> + Ocsigen_extensions.config_info -> + Ocsigen_lib.Url.path -> + Config.accessor -> + Ocsigen_extensions.extension) -> unit end - -module Site : sig - - type t - - val create : string list -> Ocsigen_charset_mime.charset option -> t - - module Config : Config_nested - with type parent_t := t - and type 'a key = 'a Vhost.Config.key - - val register : - t -> - (Config.accessor -> Ocsigen_extensions.extension) -> - unit - - val to_extension : - parent_path:string list -> - t -> - Ocsigen_extensions.extension - -end From f7466b5fbe9795c1438c10df99906452bc6103f2 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 7 Jun 2017 18:12:05 +0200 Subject: [PATCH 091/111] Do not initialize Dynlink if not needed --- src/server/ocsigen_server.ml | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index 49f8254b6..9e5cec59c 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -409,26 +409,24 @@ let start ?config () = minthreads maxthreads (fun s -> Lwt_log.ign_error ~section s)); - (* Now I can load the modules *) - Dynlink_wrapper.init (); - Dynlink_wrapper.allow_unsafe_modules true; - - Ocsigen_extensions.start_initialisation (); - (match s with | Some s -> - Ocsigen_parseconfig.later_pass s + (* Now I can load the modules *) + Dynlink_wrapper.init (); + Dynlink_wrapper.allow_unsafe_modules true; + Ocsigen_extensions.start_initialisation (); + Ocsigen_parseconfig.later_pass s; + (* As libraries are reloaded each time the config file is + read, we do not allow to register extensions in + libraries. Seems it does not work :-/ *) + Dynlink_wrapper.prohibit ["Ocsigen_extensions.R"] | None -> - Site.dump ()); - - Dynlink_wrapper.prohibit ["Ocsigen_extensions.R"]; - (* As libraries are reloaded each time the config file is read, - we do not allow to register extensions in libraries *) - (* seems it does not work :-/ *) - (* Closing stderr, stdout stdin if silent *) + (Ocsigen_extensions.start_initialisation (); + Site.dump ())); if (Ocsigen_config.get_silent ()) then begin + (* Close stderr, stdout stdin if silent *) (* redirect stdout and stderr to /dev/null *) let devnull = Unix.openfile "/dev/null" [Unix.O_WRONLY] 0 in Unix.dup2 devnull Unix.stdout; From f5597e067a1e20c431e02252dc955a526217f15b Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 8 Jun 2017 14:53:34 +0200 Subject: [PATCH 092/111] Re-organize Ocsigen_server.Site to allow automation. See Ocsigen_server.Site.create ~auto_load_extensions . --- src/extensions/authbasic.ml | 6 ++-- src/extensions/authbasic.mli | 2 +- src/extensions/cors.ml | 6 ++-- src/extensions/cors.mli | 2 +- src/extensions/deflatemod.ml | 6 ++-- src/extensions/deflatemod.mli | 2 +- src/extensions/outputfilter.ml | 6 ++-- src/extensions/outputfilter.mli | 2 +- src/extensions/redirectmod.ml | 6 ++-- src/extensions/redirectmod.mli | 2 +- src/extensions/staticmod.ml | 6 ++-- src/extensions/staticmod.mli | 2 +- src/server/ocsigen_server.ml | 54 +++++++++++++++++++++++++-------- src/server/ocsigen_server.mli | 26 +++++++++++----- 14 files changed, 84 insertions(+), 44 deletions(-) diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index cbed0319b..8e666fee0 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -144,9 +144,9 @@ let realm = Ocsigen_server.Site.Config.key () let auth = Ocsigen_server.Site.Config.key () -let register vh = - Ocsigen_server.Site.register vh - (fun _ _ _ {Ocsigen_server.Site.Config.accessor} -> +let extension = + Ocsigen_server.Site.create_extension + (fun {Ocsigen_server.Site.Config.accessor} -> match accessor realm, accessor auth with | Some realm, Some auth -> gen ~realm ~auth diff --git a/src/extensions/authbasic.mli b/src/extensions/authbasic.mli index 1ea91e78f..bd9775a00 100644 --- a/src/extensions/authbasic.mli +++ b/src/extensions/authbasic.mli @@ -60,7 +60,7 @@ val realm : string Ocsigen_server.Site.Config.key val auth : auth Ocsigen_server.Site.Config.key -val register : Ocsigen_server.Site.t -> unit +val extension : Ocsigen_server.Site.extension (**/**) diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index 53e0ac255..ab78616d6 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -205,9 +205,9 @@ let max_age = Ocsigen_server.Site.Config.key () let exposed_headers = Ocsigen_server.Site.Config.key () let methods = Ocsigen_server.Site.Config.key () -let register vh = - Ocsigen_server.Site.register vh - (fun _ _ _ {Ocsigen_server.Site.Config.accessor} -> +let extension = + Ocsigen_server.Site.create_extension + (fun {Ocsigen_server.Site.Config.accessor} -> let methods = accessor methods and credentials = Ocsigen_lib.Option.get' false (accessor credentials) and max_age = accessor max_age diff --git a/src/extensions/cors.mli b/src/extensions/cors.mli index 5e0439e6f..4622ad3c5 100644 --- a/src/extensions/cors.mli +++ b/src/extensions/cors.mli @@ -3,4 +3,4 @@ val max_age : int Ocsigen_server.Site.Config.key val exposed_headers : string list Ocsigen_server.Site.Config.key val methods : Cohttp.Code.meth list Ocsigen_server.Site.Config.key -val register : Ocsigen_server.Site.t -> unit +val extension : Ocsigen_server.Site.extension diff --git a/src/extensions/deflatemod.ml b/src/extensions/deflatemod.ml index 43882405f..4fab154d6 100644 --- a/src/extensions/deflatemod.ml +++ b/src/extensions/deflatemod.ml @@ -401,9 +401,9 @@ let () = let mode = Ocsigen_server.Site.Config.key () -let register vh = - Ocsigen_server.Site.register vh - (fun _ _ _ {Ocsigen_server.Site.Config.accessor} -> +let extension = + Ocsigen_server.Site.create_extension + (fun {Ocsigen_server.Site.Config.accessor} -> match accessor mode with | Some mode -> filter mode diff --git a/src/extensions/deflatemod.mli b/src/extensions/deflatemod.mli index a8624bf1e..73f9b4157 100644 --- a/src/extensions/deflatemod.mli +++ b/src/extensions/deflatemod.mli @@ -11,4 +11,4 @@ val mode : [`All_but of filter list | `Only of filter list] Ocsigen_server.Site.Config.key -val register : Ocsigen_server.Site.t -> unit +val extension : Ocsigen_server.Site.extension diff --git a/src/extensions/outputfilter.ml b/src/extensions/outputfilter.ml index 0850ded4b..b19f1a869 100644 --- a/src/extensions/outputfilter.ml +++ b/src/extensions/outputfilter.ml @@ -144,9 +144,9 @@ let () = let mode = Ocsigen_server.Site.Config.key () -let register vh = - Ocsigen_server.Site.register vh - (fun _ _ _ {Ocsigen_server.Site.Config.accessor} -> +let extension = + Ocsigen_server.Site.create_extension + (fun {Ocsigen_server.Site.Config.accessor} -> match accessor mode with | Some (`Code c) -> gen_code c diff --git a/src/extensions/outputfilter.mli b/src/extensions/outputfilter.mli index de783d3f4..93f7710df 100644 --- a/src/extensions/outputfilter.mli +++ b/src/extensions/outputfilter.mli @@ -4,4 +4,4 @@ val mode : | `Code of Cohttp.Code.status ] Ocsigen_server.Site.Config.key -val register : Ocsigen_server.Site.t -> unit +val extension : Ocsigen_server.Site.extension diff --git a/src/extensions/redirectmod.ml b/src/extensions/redirectmod.ml index 42367cf2b..b023eab79 100644 --- a/src/extensions/redirectmod.ml +++ b/src/extensions/redirectmod.ml @@ -133,9 +133,9 @@ let () = let redirection = Ocsigen_server.Site.Config.key () -let register vh = - Ocsigen_server.Site.register vh - (fun _ _ _ {Ocsigen_server.Site.Config.accessor} -> +let extension = + Ocsigen_server.Site.create_extension + (fun {Ocsigen_server.Site.Config.accessor} -> match accessor redirection with | Some redirection -> gen redirection diff --git a/src/extensions/redirectmod.mli b/src/extensions/redirectmod.mli index b4ead97a0..ca5ffd4f5 100644 --- a/src/extensions/redirectmod.mli +++ b/src/extensions/redirectmod.mli @@ -9,4 +9,4 @@ val create_redirection : val redirection : redirection Ocsigen_server.Site.Config.key -val register : Ocsigen_server.Site.t -> unit +val extension : Ocsigen_server.Site.extension diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index cde24a2cb..5b3cced72 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -319,9 +319,9 @@ let code = Ocsigen_server.Site.Config.key ~preprocess () let dest = Ocsigen_server.Site.Config.key () let root_checks = Ocsigen_server.Site.Config.key () -let register vh = - Ocsigen_server.Site.register vh - (fun _ _ _ {Ocsigen_server.Site.Config.accessor} -> +let extension = + Ocsigen_server.Site.create_extension + (fun {Ocsigen_server.Site.Config.accessor} -> let kind = kind (accessor dir) diff --git a/src/extensions/staticmod.mli b/src/extensions/staticmod.mli index 9aa5f57bb..16842be78 100644 --- a/src/extensions/staticmod.mli +++ b/src/extensions/staticmod.mli @@ -6,4 +6,4 @@ val dest : val root_checks : Ocsigen_extensions.ud_string Ocsigen_server.Site.Config.key -val register : Ocsigen_server.Site.t -> unit +val extension : Ocsigen_server.Site.extension diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index 9e5cec59c..db6623d89 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -156,17 +156,17 @@ end module type Config_nested = sig - type parent_t + type t type 'a key val key : ?preprocess:('a -> 'a) -> unit -> 'a key - val find : parent_t -> 'a key -> 'a option + val find : t -> 'a key -> 'a option - val set : parent_t -> 'a key -> 'a -> unit + val set : t -> 'a key -> 'a -> unit - val unset : parent_t -> 'a key -> unit + val unset : t -> 'a key -> unit type accessor = { accessor : 'a . 'a key -> 'a option } @@ -203,12 +203,33 @@ module Site = struct type 'a config_key = 'a Hmap.key + type extension_simple = accessor -> Ocsigen_extensions.extension + + type extension = + [ `Simple of extension_simple + | `Intrusive of + Ocsigen_extensions.virtual_hosts -> + Ocsigen_extensions.config_info -> + Ocsigen_lib.Url.path -> + extension_simple + ] + + let registered_extensions = ref [] + + let create_extension f = + let v = `Simple f in + registered_extensions := v :: !registered_extensions; v + + let create_extension_intrusive f = + let v = `Intrusive f in + registered_extensions := v :: !registered_extensions; v + type t = { s_list : Ocsigen_extensions.virtual_hosts ; s_config_info : Ocsigen_extensions.config_info ; s_path : Ocsigen_lib.Url.path ; mutable s_config_map : Hmap.t ; - mutable s_fun_l : (accessor -> Ocsigen_extensions.extension) list ; + mutable s_fun_l : extension_simple list ; } let l = ref [] @@ -217,11 +238,20 @@ module Site = struct let default_re = Ocsigen_lib.Netstring_pcre.regexp default_re_string + let register ({s_list ; s_config_info ; s_path ; s_fun_l } as vh) = + function + | `Simple f -> + vh.s_fun_l <- f :: s_fun_l + | `Intrusive f -> + vh.s_fun_l <- f s_list s_config_info s_path :: s_fun_l + let create ?(config_info = Ocsigen_extensions.default_config_info ()) ?host_regexp ?(path = []) - ?port () = + ?port + ?(auto_load_extensions = false) + () = let s_list = match host_regexp with | Some host_regexp when host_regexp = default_re_string -> @@ -231,15 +261,17 @@ module Site = struct | Some host_regexp -> [host_regexp, Ocsigen_lib.Netstring_pcre.regexp host_regexp, port] in - let vh = { + let s = { s_list ; s_path = path ; s_config_info = config_info ; s_config_map = Hmap.empty ; s_fun_l = [] } in - l := vh :: !l; - vh + l := s :: !l; + if auto_load_extensions then + List.iter (register s) (List.rev !registered_extensions); + s let dump () = let f { s_list ; s_config_info ; s_config_map ; s_fun_l } = @@ -261,10 +293,6 @@ module Site = struct vh.s_config_map <- f s_config_map end) - let register - ({s_list ; s_config_info ; s_path ; s_fun_l } as vh) f = - vh.s_fun_l <- f s_list s_config_info s_path :: s_fun_l - end let start ?config () = diff --git a/src/server/ocsigen_server.mli b/src/server/ocsigen_server.mli index dccf8a1e6..e71a438f7 100644 --- a/src/server/ocsigen_server.mli +++ b/src/server/ocsigen_server.mli @@ -28,17 +28,17 @@ val start : ?config : Xml.xml list list -> unit -> unit module type Config_nested = sig - type parent_t + type t type 'a key val key : ?preprocess:('a -> 'a) -> unit -> 'a key - val find : parent_t -> 'a key -> 'a option + val find : t -> 'a key -> 'a option - val set : parent_t -> 'a key -> 'a -> unit + val set : t -> 'a key -> 'a -> unit - val unset : parent_t -> 'a key -> unit + val unset : t -> 'a key -> unit type accessor = { accessor : 'a . 'a key -> 'a option } @@ -53,17 +53,29 @@ module Site : sig ?host_regexp:string -> ?path:Ocsigen_lib.Url.path -> ?port:int -> + ?auto_load_extensions:bool -> unit -> t - module Config : Config_nested with type parent_t := t + module Config : Config_nested with type t := t + + type extension + + val create_extension : + (Config.accessor -> Ocsigen_extensions.extension) -> extension val register : - t -> + t -> extension -> unit + + (**/**) + + (** Lower-level interface for creating extensions that gives the + extension more info. To be avoided. Currently used by Eliom. *) + val create_extension_intrusive : (Ocsigen_extensions.virtual_hosts -> Ocsigen_extensions.config_info -> Ocsigen_lib.Url.path -> Config.accessor -> Ocsigen_extensions.extension) -> - unit + extension end From 8198bf33bb788bc6a25970e02400ade598dbc6a4 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 9 Jun 2017 13:59:10 +0200 Subject: [PATCH 093/111] Implement Ocsigen_server.Site.t nesting --- src/server/ocsigen_server.ml | 96 ++++++++++++++++++++++------------- src/server/ocsigen_server.mli | 7 +-- 2 files changed, 64 insertions(+), 39 deletions(-) diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index db6623d89..e341d8b16 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -144,10 +144,6 @@ let _ = type accessor = { accessor : 'a . (('a -> 'a) option * 'a Hmap.key) -> 'a option } -let compose_with_config m l = - Ocsigen_extensions.compose - (List.map (fun f -> f {accessor = fun (_, k) -> Hmap.find k m}) l) - module type Hmap_wrapped = sig type t val get : t -> Hmap.t @@ -211,8 +207,7 @@ module Site = struct Ocsigen_extensions.virtual_hosts -> Ocsigen_extensions.config_info -> Ocsigen_lib.Url.path -> - extension_simple - ] + extension_simple ] let registered_extensions = ref [] @@ -225,11 +220,14 @@ module Site = struct registered_extensions := v :: !registered_extensions; v type t = { - s_list : Ocsigen_extensions.virtual_hosts ; + s_id : + [ `Host of Ocsigen_extensions.virtual_hosts + | `Attach of (t * Ocsigen_lib.Url.path) ]; s_config_info : Ocsigen_extensions.config_info ; - s_path : Ocsigen_lib.Url.path ; + s_charset : Ocsigen_charset_mime.charset option ; mutable s_config_map : Hmap.t ; - mutable s_fun_l : extension_simple list ; + mutable s_children_l : + [ `Extension of extension_simple | `Child of t ] list ; } let l = ref [] @@ -238,52 +236,78 @@ module Site = struct let default_re = Ocsigen_lib.Netstring_pcre.regexp default_re_string - let register ({s_list ; s_config_info ; s_path ; s_fun_l } as vh) = + let rec path_and_hosts {s_id} = + match s_id with + | `Host hosts -> + [], hosts + | `Attach (s, path') -> + let path, hosts = path_and_hosts s in + path @ path', hosts + + let register ({ s_config_info ; s_children_l } as s) = function | `Simple f -> - vh.s_fun_l <- f :: s_fun_l + s.s_children_l <- `Extension f :: s_children_l | `Intrusive f -> - vh.s_fun_l <- f s_list s_config_info s_path :: s_fun_l + let path, hosts = path_and_hosts s in + s.s_children_l <- + `Extension (f hosts s_config_info path) :: s_children_l let create ?(config_info = Ocsigen_extensions.default_config_info ()) - ?host_regexp - ?(path = []) - ?port + ?(id = `Host (default_re_string, None)) + ?charset ?(auto_load_extensions = false) () = - let s_list = - match host_regexp with - | Some host_regexp when host_regexp = default_re_string -> - [default_re_string, default_re, port] - | None -> - [default_re_string, default_re, port] - | Some host_regexp -> - [host_regexp, Ocsigen_lib.Netstring_pcre.regexp host_regexp, port] + let s_id = + match id with + | `Host (host_regexp, port) when host_regexp = default_re_string -> + `Host + [default_re_string, default_re, port] + | `Host (host_regexp, port) -> + `Host + [host_regexp, Ocsigen_lib.Netstring_pcre.regexp host_regexp, port] + | `Attach (parent, path) -> + `Attach (parent, Ocsigen_extensions.preprocess_site_path path) in let s = { - s_list ; - s_path = path ; + s_id ; + s_charset = charset ; s_config_info = config_info ; s_config_map = Hmap.empty ; - s_fun_l = [] + s_children_l = [] } in - l := s :: !l; + (match s_id with + | `Host _ -> + l := s :: !l; + | `Attach (parent, _) -> + parent.s_children_l <- `Child s :: parent.s_children_l); if auto_load_extensions then List.iter (register s) (List.rev !registered_extensions); s + let rec dump_host + path + { s_config_info ; s_config_map ; s_children_l ; s_id } = + let f = function + | `Extension f -> + f {accessor = fun (_, k) -> Hmap.find k s_config_map} + | `Child ({s_charset ; s_id = `Attach (_, path')} as s) -> + let path = path @ path' in + Ocsigen_extensions.site_ext (dump_host path s) s_charset path + | `Child _ -> + failwith "Ocsigen_server.dump_host" + in + Ocsigen_extensions.compose (List.map f s_children_l) + let dump () = - let f { s_list ; s_config_info ; s_config_map ; s_fun_l } = - s_list, - s_config_info, - compose_with_config s_config_map s_fun_l - and l = - List.filter - (function {s_fun_l = _ :: _} -> true | _ -> false) - (List.rev !l) + let f acc = function + | { s_config_info ; s_id = `Host l ; s_children_l = _ :: _ } as s -> + (l, s_config_info, dump_host [] s) :: acc + | _ -> + acc in - Ocsigen_extensions.set_hosts (List.map f l) + Ocsigen_extensions.set_hosts (List.fold_left f [] !l) module Config = Make_config_nested (struct diff --git a/src/server/ocsigen_server.mli b/src/server/ocsigen_server.mli index e71a438f7..3481a14b4 100644 --- a/src/server/ocsigen_server.mli +++ b/src/server/ocsigen_server.mli @@ -50,9 +50,10 @@ module Site : sig val create : ?config_info:Ocsigen_extensions.config_info -> - ?host_regexp:string -> - ?path:Ocsigen_lib.Url.path -> - ?port:int -> + ?id: + [ `Attach of t * Ocsigen_lib.Url.path + | `Host of string * int option ] -> + ?charset:Ocsigen_charset_mime.charset -> ?auto_load_extensions:bool -> unit -> t From 5da7c1c1634627d1422e457285a92068359522a8 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Fri, 9 Jun 2017 17:02:15 +0200 Subject: [PATCH 094/111] Fix redirection for dirs --- src/server/ocsigen_cohttp.ml | 8 ++++++-- src/server/ocsigen_extensions.ml | 28 ++++++++++++++-------------- 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index a3b426c6b..261e7a7ca 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -199,8 +199,12 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body = Lwt.return (response, body)) (function | Ocsigen_is_dir fun_request -> - Cohttp_lwt_unix.Server.respond_redirect () - ~uri:(fun_request request) + let headers = + fun_request request + |> Uri.to_string + |> Cohttp.Header.init_with "location" + and status = `Moved_permanently in + Cohttp_lwt_unix.Server.respond ~headers ~status ~body:`Empty () | exn -> handle_error exn) diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index e8c62190e..586cb2d42 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -310,20 +310,20 @@ let get_port let new_url_of_directory_request request ri = Lwt_log.ign_info ~section "Sending 301 Moved permanently"; - let port = get_port request - and ssl = Ocsigen_request.ssl ri in - Uri.make - ~scheme:(if ssl then "https" else "http") - ~host:(get_hostname request) - ?port:( - if (port = 80 && not ssl) || (ssl && port = 443) then - None - else - Some port - ) - ~path:(Ocsigen_request.path_string ri) - ~query:(Ocsigen_request.get_params ri) - () + let ssl = Ocsigen_request.ssl ri in + let scheme = if ssl then "https" else "http" + and host = get_hostname request + and port = + let port = get_port request in + if port = if ssl then 443 else 80 then + None + else + Some port + and path = + let path = Ocsigen_request.path_string ri in + if path.[String.length path - 1] = '/' then path else path ^ "/" + and query = Ocsigen_request.get_params ri in + Uri.make ~scheme ~host ?port ~path ~query () (* To give parameters to extensions: *) let dynlinkconfig = ref ([] : Xml.xml list) From a8bc9d979389c0448211ff24f087faf4bfd29968 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 14 Jun 2017 23:29:14 +0200 Subject: [PATCH 095/111] Declare lwt_ssl dependency --- opam | 1 + 1 file changed, 1 insertion(+) diff --git a/opam b/opam index e810c07e4..68a211833 100644 --- a/opam +++ b/opam @@ -49,6 +49,7 @@ depends: [ "react" "ssl" "lwt" {>= "3.0.0"} + "lwt_ssl" "pcre" "cryptokit" "xml-light" From 48eae62222676625633e78752538b645b1f63de4 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 14 Jun 2017 23:43:09 +0200 Subject: [PATCH 096/111] Fix doc generation (and hopefully Jenkins build) --- doc/Makefile | 2 +- src/server/.depend | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/Makefile b/doc/Makefile index 33e05ec0c..8ae67829d 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -4,7 +4,7 @@ include ../src/Makefile.filelist OCAMLDOC := ${OCAMLFIND} ocamldoc ODOC_WIKI := odoc_wiki.cma -LIBS := -package lwt,tyxml,ssl,ipaddr \ +LIBS := -package lwt,ssl,ipaddr,cohttp.lwt,pcre,xml-light \ ${addprefix -I ../src/, baselib http server extensions } doc: api-html/index.html diff --git a/src/server/.depend b/src/server/.depend index 996535682..06911f94e 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -76,7 +76,8 @@ ocsigen_server.cmx : ocsigen_parseconfig.cmx ocsigen_messages.cmx \ ocsigen_cohttp.cmx ../http/ocsigen_charset_mime.cmx \ ../baselib/ocsigen_cache.cmx ../baselib/dynlink_wrapper.cmx \ ocsigen_server.cmi -ocsigen_server.cmi : ocsigen_extensions.cmi ../http/ocsigen_charset_mime.cmi +ocsigen_server.cmi : ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ + ../http/ocsigen_charset_mime.cmi server_main.cmo : ocsigen_server.cmi ocsigen_parseconfig.cmi \ ocsigen_config.cmi server_main.cmx : ocsigen_server.cmx ocsigen_parseconfig.cmx \ From 76bc89de29fce457cc1436d6ef3f631d17d05460 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 11 Jul 2017 18:27:42 +0200 Subject: [PATCH 097/111] Export Ocsigen_extensions.Ocsigen_http_error --- src/server/ocsigen_extensions.mli | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 7cfa0def5..b090a1ba0 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -22,6 +22,9 @@ include (module type of Ocsigen_command) +exception Ocsigen_http_error of + Ocsigen_cookies.cookieset * Cohttp.Code.status + (** Xml tag not recognized by an extension (usually not a real error) *) exception Bad_config_tag_for_extension of string From fa99319fc57a99d0d3be61b13801b49759292ebb Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 12 Jul 2017 14:31:24 +0200 Subject: [PATCH 098/111] More precise dynlink error message --- src/server/ocsigen_server.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index e341d8b16..60cb17a4d 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -72,6 +72,9 @@ let errmsg = function line begin_char end_char (Xml.error_msg s), 51 + | Ocsigen_loader.Dynlink_error (s, (Dynlink.Error err)) -> + (("Fatal - While loading "^s^": "^(Dynlink.error_message err)), + 52) | Ocsigen_loader.Dynlink_error (s, exn) -> (("Fatal - While loading "^s^": "^(Printexc.to_string exn)), 52) From a3f1e849c5785872baf26fd01ea9d4045afc2473 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 13 Jul 2017 16:54:20 +0200 Subject: [PATCH 099/111] Install extendconfiguration extension --- src/Makefile.filelist | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 62e70867d..2e5c2b0e4 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -55,9 +55,10 @@ PLUGINS_INTF := extensions/accesscontrol.cmi extensions/authbasic.cmi \ extensions/redirectmod.cmi extensions/staticmod.cmi PLUGINS_IMPL := extensions/accesscontrol.cmo extensions/authbasic.cmo \ - extensions/cors.cmo extensions/outputfilter.cmo \ - extensions/redirectmod.cmo extensions/revproxy.cmo \ - extensions/rewritemod.cmo extensions/staticmod.cmo + extensions/cors.cmo extensions/extendconfiguration.cmo \ + extensions/outputfilter.cmo extensions/redirectmod.cmo \ + extensions/revproxy.cmo extensions/rewritemod.cmo \ + extensions/staticmod.cmo ifeq "$(CAMLZIP)" "YES" PLUGINS_IMPL += extensions/deflatemod.cmo From bf59c9c556c90856e23d792d72125f4a0603e3df Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 25 Jul 2017 10:24:23 +0200 Subject: [PATCH 100/111] Fix installation without deflatemod --- src/Makefile.filelist | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 2e5c2b0e4..fd09af44d 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -49,8 +49,7 @@ endif PLUGINS_BIN := PLUGINS_INTF := extensions/accesscontrol.cmi extensions/authbasic.cmi \ - extensions/cors.cmi extensions/deflatemod.cmi \ - extensions/ocsipersist.cmi \ + extensions/cors.cmi extensions/ocsipersist.cmi \ extensions/outputfilter.cmi \ extensions/redirectmod.cmi extensions/staticmod.cmi @@ -62,6 +61,7 @@ PLUGINS_IMPL := extensions/accesscontrol.cmo extensions/authbasic.cmo \ ifeq "$(CAMLZIP)" "YES" PLUGINS_IMPL += extensions/deflatemod.cmo +PLUGINS_INTF += extensions/deflatemod.cmi endif ifeq "$(OCSIPERSISTSQLITE)" "YES" From e4764db14225494b93820dc6a4e52fb0738d5ee7 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 3 Aug 2017 17:55:43 +0200 Subject: [PATCH 101/111] Depend on cohttp-lwt-unix --- opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/opam b/opam index 68a211833..0ae8ea2c0 100644 --- a/opam +++ b/opam @@ -55,7 +55,7 @@ depends: [ "xml-light" ("dbm" | "sqlite3" | "pgocaml") "ipaddr" {>= "2.1"} - "cohttp" {>= "0.17.0"} + "cohttp-lwt-unix" "hmap" # REMOVE AFTER DEBUGGING From 548353fda1906711b7bc13cf82c98bd9818f201f Mon Sep 17 00:00:00 2001 From: Jerome Vouillon Date: Sat, 7 Jan 2017 15:26:10 +0100 Subject: [PATCH 102/111] Much more efficient implementation of Ocsigen_lib.Url.encode Faster, and perform much less memory allocations. Fixes #117. --- src/baselib/ocsigen_lib.ml | 90 ++++++++++++++++++++++++++++---------- 1 file changed, 67 insertions(+), 23 deletions(-) diff --git a/src/baselib/ocsigen_lib.ml b/src/baselib/ocsigen_lib.ml index c30544c7d..f294a1a4d 100644 --- a/src/baselib/ocsigen_lib.ml +++ b/src/baselib/ocsigen_lib.ml @@ -225,31 +225,75 @@ module Url = struct (not encoded by browsers). Here is a patch that does not encode '~': *) module MyUrl = struct - let hex_digits = - [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; - '8'; '9'; 'A'; 'B'; 'C'; 'D'; 'E'; 'F' |] - - let to_hex2 k = - (* Converts k to a 2-digit hex string *) - let s = Bytes.create 2 in - Bytes.set s 0 hex_digits.( (k lsr 4) land 15 ); - Bytes.set s 1 hex_digits.( k land 15 ); - s - - let url_encoding_re = - Netstring_pcre.regexp "[^A-Za-z0-9~_.!*\\-]" + let percent_encode = + let lengths = + let l = Array.make 256 3 in + String.iter (fun c -> l.(Char.code c) <- 1) + (* Unreserved Characters (section 2.3 of RFC 3986) *) + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_.~"; + l + in + fun s -> + let l = String.length s in + let l' = ref 0 in + for i = 0 to l - 1 do + l' := !l' + lengths.(Char.code s.[i]) + done; + if l = !l' then + String.copy s + else + let s' = Bytes.create !l' in + let j = ref 0 in + let hex = "0123456789ABCDEF" in + for i = 0 to l - 1 do + let c = s.[i] in + let n = Char.code s.[i] in + let d = lengths.(n) in + if d = 1 then + Bytes.set s' !j c + else begin + Bytes.set s' !j '%'; + Bytes.set s' (!j + 1) hex.[n lsr 4]; + Bytes.set s' (!j + 2) hex.[n land 0xf] + end; + j := !j + d + done; + Bytes.unsafe_to_string s' + + let encode_plus = + let lengths = + let l = Array.make 256 3 in + String.iter (fun c -> l.(Char.code c) <- 1) + (* Unchanged characters + space (HTML spec) *) + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_.* "; + l + in + fun s -> + let l = String.length s in + let l' = ref 0 in + for i = 0 to l - 1 do + l' := !l' + lengths.(Char.code s.[i]) + done; + let s' = Bytes.create !l' in + let j = ref 0 in + let hex = "0123456789ABCDEF" in + for i = 0 to l - 1 do + let c = s.[i] in + let n = Char.code s.[i] in + let d = lengths.(n) in + if d = 1 then + Bytes.set s' !j (if c = ' ' then '+' else c) + else begin + Bytes.set s' !j '%'; + Bytes.set s' (!j + 1) hex.[n lsr 4]; + Bytes.set s' (!j + 2) hex.[n land 0xf] + end; + j := !j + d + done; + Bytes.unsafe_to_string s' let encode ?(plus = true) s = - Netstring_pcre.global_substitute - url_encoding_re - (fun r _ -> - match Netstring_pcre.matched_string r s with - | " " when plus -> "+" - | x -> - let k = Char.code(x.[0]) in - "%" ^ to_hex2 k - ) - s + if plus then encode_plus s else percent_encode s end From da2423b4f61c123eca68ddb1d07ecfbd53437b68 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Tue, 6 Feb 2018 14:39:17 +0100 Subject: [PATCH 103/111] Compile against OCaml 4.06 & Cohttp 1.0.x --- src/baselib/ocsigen_stream.ml | 2 +- src/extensions/deflatemod.ml | 29 +++++++++++++++++++---------- src/server/ocsigen_cohttp.ml | 2 +- src/server/ocsigen_multipart.ml | 6 +++--- src/server/ocsigen_request.ml | 4 ++-- src/server/ocsigen_request.mli | 4 ++-- src/server/ocsigen_response.ml | 4 ++-- src/server/ocsigen_response.mli | 8 ++++---- src/server/ocsigen_server.ml | 2 +- 9 files changed, 35 insertions(+), 26 deletions(-) diff --git a/src/baselib/ocsigen_stream.ml b/src/baselib/ocsigen_stream.ml index ea1d42f22..936a49512 100644 --- a/src/baselib/ocsigen_stream.ml +++ b/src/baselib/ocsigen_stream.ml @@ -223,7 +223,7 @@ let of_file filename = if n = 0 then empty None else (* Streams should be immutable, thus we always make a copy of the buffer *) - cont (Bytes.sub buf 0 n) aux + cont (Bytes.sub_string buf 0 n) aux in make ~finalize:(fun _ -> Lwt_unix.close fd) aux let of_string s = diff --git a/src/extensions/deflatemod.ml b/src/extensions/deflatemod.ml index 4fab154d6..1e57cad90 100644 --- a/src/extensions/deflatemod.ml +++ b/src/extensions/deflatemod.ml @@ -58,17 +58,18 @@ let buffer_size = (* Minimal header, by X. Leroy *) let gzip_header_length = 10 let gzip_header = Bytes.make gzip_header_length (Char.chr 0) -let () = +let gzip_header = Bytes.set gzip_header 0 @@ Char.chr 0x1F; Bytes.set gzip_header 1 @@ Char.chr 0x8B; Bytes.set gzip_header 2 @@ Char.chr 8; - Bytes.set gzip_header 9 @@ Char.chr 0xFF + Bytes.set gzip_header 9 @@ Char.chr 0xFF; + Bytes.unsafe_to_string gzip_header (* inspired by an auxiliary function from camlzip, by Xavier Leroy *) type output_buffer = { stream: Zlib.stream; - buf: string; + buf: bytes; mutable pos: int; mutable avail: int; mutable size : int32; @@ -99,7 +100,8 @@ let rec output oz f buf pos len = let (_, used_in, used_out) = try Zlib.deflate - oz.stream buf pos len oz.buf oz.pos oz.avail Zlib.Z_NO_FLUSH + oz.stream (Bytes.unsafe_of_string buf) + pos len oz.buf oz.pos oz.avail Zlib.Z_NO_FLUSH with Zlib.Error(s, s') -> raise (Ocsigen_stream.Stream_error("Error during compression: "^s^" "^s')) @@ -107,7 +109,7 @@ let rec output oz f buf pos len = oz.pos <- oz.pos + used_out; oz.avail <- oz.avail - used_out; oz.size <- Int32.add oz.size (Int32.of_int used_in); - oz.crc <- Zlib.update_crc oz.crc buf pos used_in; + oz.crc <- Zlib.update_crc_string oz.crc buf pos used_in; output oz f buf (pos + used_in) (len - used_in) end @@ -119,7 +121,12 @@ and flush oz cont = cont () else begin let buf_len = Bytes.length oz.buf in - let s = if len = buf_len then oz.buf else Bytes.sub oz.buf 0 len in + let s = + if len = buf_len then + Bytes.to_string oz.buf + else + Bytes.sub_string oz.buf 0 len + in Lwt_log.ign_info ~section "Flushing!"; oz.pos <- 0 ; oz.avail <- buf_len; @@ -140,7 +147,9 @@ and next_cont oz stream = (* no more input, deflates only what were left because output buffer * was full *) let (finished, _, used_out) = - Zlib.deflate oz.stream oz.buf 0 0 oz.buf oz.pos oz.avail Zlib.Z_FINISH + Zlib.deflate + oz.stream oz.buf + 0 0 oz.buf oz.pos oz.avail Zlib.Z_FINISH in oz.pos <- oz.pos + used_out; oz.avail <- oz.avail - used_out; @@ -166,7 +175,7 @@ and next_cont oz stream = output oz f s 0 (String.length s) (* deflate param : true = deflate ; false = gzip (no header in this case) *) -let compress deflate stream = +let compress deflate stream : string Ocsigen_stream.t = let zstream = Zlib.deflate_init (Ocsigen_lib.Option.get' 6 @@ -286,11 +295,11 @@ let stream_filter contentencoding url deflate choice res = Cohttp.Response.encoding = Cohttp.Transfer.Chunked } and body = - Cohttp_lwt_body.to_stream body + Cohttp_lwt.Body.to_stream body |> Ocsigen_stream.of_lwt_stream |> compress deflate |> Ocsigen_stream.to_lwt_stream - |> Cohttp_lwt_body.of_stream + |> Cohttp_lwt.Body.of_stream in Lwt.return (Ocsigen_response.update res ~body ~response) | _ -> diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index 261e7a7ca..325c0fb08 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -248,7 +248,7 @@ let service ?ssl ~address ~port ~connector () = Conduit_lwt_unix.init ~src:(Ocsigen_config.Socket_type.to_string address) ~tls_server_key () >>= fun conduit_ctx -> - Lwt.return (Cohttp_lwt_unix_net.init ~ctx:conduit_ctx ()) >>= fun ctx -> + Lwt.return (Cohttp_lwt_unix.Net.init ~ctx:conduit_ctx ()) >>= fun ctx -> (* We catch the INET_ADDR of the server *) let callback = let address = Ocsigen_config.Socket_type.to_inet_addr address diff --git a/src/server/ocsigen_multipart.ml b/src/server/ocsigen_multipart.ml index 8fdaf1682..26187315b 100644 --- a/src/server/ocsigen_multipart.ml +++ b/src/server/ocsigen_multipart.ml @@ -48,7 +48,7 @@ let scan_header if i' > end_pos then raise (Multipart_error "Mimestring.scan_header"); let name = if downcase then - String.lowercase (S.matched_group r 1 parstr) + String.lowercase_ascii (S.matched_group r 1 parstr) else S.matched_group r 1 parstr in @@ -343,7 +343,7 @@ let post_params_multipart_form_data body_gen ctparams upload_dir max_size = Lwt.return () | _, `Some_file (_, _, wh, _) -> let len = String.length s in - let r = Unix.write wh s 0 len in + let r = Unix.write_substring wh s 0 len in if r < len then (*XXXX Inefficient if s is long *) add p (String.sub s r (len - r)) @@ -413,7 +413,7 @@ let post_params_multipart_form_data body_gen ctparams upload_dir max_size = let post_params ~content_type body_gen = let (ct, cst), ctparams = content_type in - match String.lowercase ct, String.lowercase cst with + match String.lowercase_ascii ct, String.lowercase_ascii cst with | "application", "x-www-form-urlencoded" -> Some (post_params_form_urlencoded body_gen) | "multipart", "form-data" -> diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 1446e27c9..824c500bb 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -1,7 +1,7 @@ open Lwt.Infix let post_data_of_body ~content_type b = - Cohttp_lwt_body.to_stream b + Cohttp_lwt.Body.to_stream b |> Ocsigen_stream.of_lwt_stream |> Ocsigen_multipart.post_params ~content_type @@ -17,7 +17,7 @@ type file_info = Ocsigen_multipart.file_info = { type post_data = Ocsigen_multipart.post_data type body = [ - | `Unparsed of Cohttp_lwt_body.t + | `Unparsed of Cohttp_lwt.Body.t | `Parsed of post_data Lwt.t option ] diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli index 36061cb19..cf3dbb668 100644 --- a/src/server/ocsigen_request.mli +++ b/src/server/ocsigen_request.mli @@ -22,7 +22,7 @@ val make : ssl : bool -> filenames : string list ref -> sockaddr : Lwt_unix.sockaddr -> - body : Cohttp_lwt_body.t -> + body : Cohttp_lwt.Body.t -> connection_closed : unit Lwt.t -> Cohttp.Request.t -> t @@ -45,7 +45,7 @@ val to_cohttp : t -> Cohttp.Request.t val uri : t -> Uri.t -val body : t -> Cohttp_lwt_body.t +val body : t -> Cohttp_lwt.Body.t val address : t -> Unix.inet_addr diff --git a/src/server/ocsigen_response.ml b/src/server/ocsigen_response.ml index c94ccf46a..63183a4d8 100644 --- a/src/server/ocsigen_response.ml +++ b/src/server/ocsigen_response.ml @@ -1,11 +1,11 @@ type t = { a_response : Cohttp.Response.t ; - a_body : Cohttp_lwt_body.t ; + a_body : Cohttp_lwt.Body.t ; a_cookies : Ocsigen_cookies.cookieset } let make - ?(body = Cohttp_lwt_body.empty) + ?(body = Cohttp_lwt.Body.empty) ?(cookies = Ocsigen_cookies.empty_cookieset) a_response = { a_response ; a_body = body ; a_cookies = cookies } diff --git a/src/server/ocsigen_response.mli b/src/server/ocsigen_response.mli index feb29bb67..3b6cfa532 100644 --- a/src/server/ocsigen_response.mli +++ b/src/server/ocsigen_response.mli @@ -1,24 +1,24 @@ type t val make : - ?body : Cohttp_lwt_body.t -> + ?body : Cohttp_lwt.Body.t -> ?cookies : Ocsigen_cookies.cookieset -> Cohttp.Response.t -> t val update : ?response : Cohttp.Response.t -> - ?body : Cohttp_lwt_body.t -> + ?body : Cohttp_lwt.Body.t -> ?cookies : Ocsigen_cookies.cookieset -> t -> t val of_cohttp : ?cookies : Ocsigen_cookies.cookieset -> - (Cohttp.Response.t * Cohttp_lwt_body.t) -> + (Cohttp.Response.t * Cohttp_lwt.Body.t) -> t -val to_cohttp : t -> Cohttp.Response.t * Cohttp_lwt_body.t +val to_cohttp : t -> Cohttp.Response.t * Cohttp_lwt.Body.t val status : t -> Cohttp.Code.status diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index 60cb17a4d..7b4b9db1f 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -579,7 +579,7 @@ let start ?config () = Unix.openfile p [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 0o640 in - ignore (Unix.write f spid 0 len); + ignore (Unix.write_substring f spid 0 len); Unix.close f in From 2610b4faac533cf040960cd5e0e4388e925d2c7c Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Fri, 27 Oct 2017 10:45:27 +0200 Subject: [PATCH 104/111] Ocsigen_lib.List.split_at --- src/baselib/ocsigen_lib_base.ml | 7 +++++++ src/baselib/ocsigen_lib_base.mli | 1 + 2 files changed, 8 insertions(+) diff --git a/src/baselib/ocsigen_lib_base.ml b/src/baselib/ocsigen_lib_base.ml index a02796328..0969197cb 100644 --- a/src/baselib/ocsigen_lib_base.ml +++ b/src/baselib/ocsigen_lib_base.ml @@ -173,6 +173,13 @@ module List = struct | [] -> [] | x :: xs -> chop (n-1) xs + let rec split_at n xs = + if n <= 0 + then [], xs + else match xs with + | [] -> [], [] + | x::xs -> let l,r = split_at (n-1) xs in x::l, r + end (*****************************************************************************) diff --git a/src/baselib/ocsigen_lib_base.mli b/src/baselib/ocsigen_lib_base.mli index bca337a76..3891feb2c 100644 --- a/src/baselib/ocsigen_lib_base.mli +++ b/src/baselib/ocsigen_lib_base.mli @@ -91,6 +91,7 @@ module List : sig val is_prefix : 'a list -> 'a list -> bool val chop : int -> 'a list -> 'a list + val split_at : int -> 'a list -> 'a list * 'a list end From 4c5b8591291d2293ccae5128039f0096b8532698 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 7 Feb 2018 15:46:49 +0100 Subject: [PATCH 105/111] More robust cookie parsing: ignore cookies without equal sign Cherry-pick dbeb38d2d1f0722cb504f6000b5155f2415ce8e9 by @vouillon --- src/server/ocsigen_request.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 824c500bb..e235ceb33 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -308,8 +308,11 @@ let parse_cookies s = try List.fold_left (fun beg a -> - let (n, v) = Ocsigen_lib.String.sep '=' a in - Ocsigen_cookies.CookiesTable.add n v beg) + try + let (n, v) = Ocsigen_lib.String.sep '=' a in + Ocsigen_cookies.CookiesTable.add n v beg + with Not_found -> + beg) Ocsigen_cookies.CookiesTable.empty splitted with _ -> From e7357581887a37d77cb27b5cdca56d03d3eb225b Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 1 Feb 2018 13:40:08 +0100 Subject: [PATCH 106/111] Add .travis.yml --- .travis.yml | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 000000000..bc50bffbb --- /dev/null +++ b/.travis.yml @@ -0,0 +1,11 @@ +language: c +sudo: required +install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh +script: bash -ex .travis-opam.sh +env: + - OCAML_VERSION=4.03 PACKAGE=ocsigenserver + - OCAML_VERSION=4.05 PACKAGE=ocsigenserver + - OCAML_VERSION=4.06 PACKAGE=ocsigenserver +os: + - linux + - osx From 800447d64cc489c4492723150cf5cb9c35e32429 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 8 Feb 2018 11:34:41 +0100 Subject: [PATCH 107/111] Remove most warnings & require OCaml 4.03.x --- opam | 1 + src/extensions/accesscontrol.ml | 2 +- src/http/ocsigen_charset_mime.ml | 4 ++-- src/http/ocsigen_header.ml | 2 +- src/server/ocsigen_messages.ml | 2 +- src/server/ocsigen_parseconfig.ml | 2 +- 6 files changed, 7 insertions(+), 6 deletions(-) diff --git a/opam b/opam index 0ae8ea2c0..52e8e8cec 100644 --- a/opam +++ b/opam @@ -66,3 +66,4 @@ conflicts: [ "camlzip" {< "1.04"} "pgocaml" {< "2.2"} ] +available: [ocaml-version >= "4.03.0"] \ No newline at end of file diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index 4383c1e68..f9f3fd7c6 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -404,7 +404,7 @@ let parse_config parse_fun = function in match header with | Some header -> - (match String.lowercase header with + (match String.lowercase_ascii header with | "http" -> Ocsigen_request.update ~ssl:false request_info | "https" -> diff --git a/src/http/ocsigen_charset_mime.ml b/src/http/ocsigen_charset_mime.ml index 444645cbf..b00fe35e3 100644 --- a/src/http/ocsigen_charset_mime.ml +++ b/src/http/ocsigen_charset_mime.ml @@ -42,7 +42,7 @@ type 'a assoc = { let find_in_assoc file assoc = let filename = Filename.basename file in let ext = - try String.lowercase (Filename.extension_no_directory file) + try String.lowercase_ascii (Filename.extension_no_directory file) with Not_found -> "" in let rec aux = function @@ -66,7 +66,7 @@ let set_default assoc default = { assoc with assoc_default = default } let update_ext assoc (ext : extension) v = { assoc with assoc_list = - Extension (String.lowercase ext, v) :: assoc.assoc_list} + Extension (String.lowercase_ascii ext, v) :: assoc.assoc_list} let update_file assoc (file : filename) v = { assoc with assoc_list = File (file, v) :: assoc.assoc_list} diff --git a/src/http/ocsigen_header.ml b/src/http/ocsigen_header.ml index 729832e8a..666a75b35 100644 --- a/src/http/ocsigen_header.ml +++ b/src/http/ocsigen_header.ml @@ -24,7 +24,7 @@ module Name = struct type t = string - let of_string = String.lowercase + let of_string = String.lowercase_ascii let to_string s = s let accept = of_string "Accept" diff --git a/src/server/ocsigen_messages.ml b/src/server/ocsigen_messages.ml index ff5395e8d..af1ac02f5 100644 --- a/src/server/ocsigen_messages.ml +++ b/src/server/ocsigen_messages.ml @@ -148,7 +148,7 @@ let command_f exc _ = function if a section with the same name already exists, it is returned. *) let sect = Lwt_log.Section.make sect_name in - (match level_of_string (String.lowercase level_name) with + (match level_of_string (String.lowercase_ascii level_name) with | None -> Lwt_log.Section.reset_level sect | Some l -> Lwt_log.Section.set_level sect l); Lwt.return () diff --git a/src/server/ocsigen_parseconfig.ml b/src/server/ocsigen_parseconfig.ml index 37dbf2b48..232fe4573 100644 --- a/src/server/ocsigen_parseconfig.ml +++ b/src/server/ocsigen_parseconfig.ml @@ -662,7 +662,7 @@ let first_pass c = set_logdir (parse_string_tag st p); aux user group ssl ports sslports ll | Element ("syslog" as st, [], p) :: ll -> - let str = String.lowercase (parse_string_tag st p) in + let str = String.lowercase_ascii (parse_string_tag st p) in set_syslog_facility (Some (parse_facility str)); aux user group ssl ports sslports ll | Element ("port" as st, atts, p) :: ll -> From 36281f2903c6a30ddb4624c1e77c7cc67f69f252 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 8 Feb 2018 11:38:08 +0100 Subject: [PATCH 108/111] Ocsigen_cookies -> Ocsigen_cookie_map --- .gitignore | 2 - src/Makefile.filelist | 48 +++++++------- src/extensions/.depend | 26 ++++---- src/extensions/accesscontrol.ml | 14 ++-- src/extensions/authbasic.ml | 2 +- src/extensions/extendconfiguration.ml | 4 +- src/extensions/ocsipersist-dbm/Makefile | 3 +- src/extensions/ocsipersist-pgsql/Makefile | 3 +- src/extensions/ocsipersist-sqlite/Makefile | 3 +- src/extensions/rewritemod.ml | 4 +- src/extensions/userconf.ml | 4 +- src/files/META.in | 2 +- src/http/.depend | 6 +- src/http/Makefile | 2 +- src/http/ocsigen_cookie_map.ml | 64 ++++++++++++++++++ src/http/ocsigen_cookie_map.mli | 77 ++++++++++++++++++++++ src/http/ocsigen_cookies.ml | 67 ------------------- src/http/ocsigen_cookies.mli | 65 ------------------ src/server/.depend | 32 ++++----- src/server/ocsigen_cohttp.ml | 33 +++++----- src/server/ocsigen_cohttp.mli | 2 +- src/server/ocsigen_extensions.ml | 38 +++++------ src/server/ocsigen_extensions.mli | 25 ++++--- src/server/ocsigen_request.ml | 10 +-- src/server/ocsigen_request.mli | 6 +- src/server/ocsigen_response.ml | 10 +-- src/server/ocsigen_response.mli | 10 +-- 27 files changed, 279 insertions(+), 283 deletions(-) create mode 100644 src/http/ocsigen_cookie_map.ml create mode 100644 src/http/ocsigen_cookie_map.mli delete mode 100644 src/http/ocsigen_cookies.ml delete mode 100644 src/http/ocsigen_cookies.mli diff --git a/.gitignore b/.gitignore index 170843aed..70d5a3fbe 100644 --- a/.gitignore +++ b/.gitignore @@ -13,8 +13,6 @@ Makefile.config src/baselib/dynlink_wrapper.ml src/baselib/ocsigen_config_static.ml -src/http/http_parser.ml -src/http/http_parser.mli src/server/ocsigenserver src/server/ocsigenserver.opt src/extensions/ocsipersist.mli diff --git a/src/Makefile.filelist b/src/Makefile.filelist index fd09af44d..e6278b521 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -1,39 +1,39 @@ BIN := server/${PROJECTNAME} NATBIN := server/${PROJECTNAME}.opt -INTF_BASE := baselib/ocsigen_cache.cmi \ - baselib/ocsigen_lib_base.cmi \ - baselib/ocsigen_lib.cmi \ - baselib/ocsigen_stream.cmi \ - baselib/ocsigen_loader.cmi \ - baselib/polytables.cmi \ +INTF_BASE := baselib/ocsigen_cache.cmi \ + baselib/ocsigen_lib_base.cmi \ + baselib/ocsigen_lib.cmi \ + baselib/ocsigen_stream.cmi \ + baselib/ocsigen_loader.cmi \ + baselib/polytables.cmi \ + \ + http/ocsigen_charset_mime.cmi \ + http/ocsigen_cookie_map.cmi \ + http/ocsigen_header.cmi \ \ - http/ocsigen_charset_mime.cmi \ - http/ocsigen_cookies.cmi \ - http/ocsigen_header.cmi \ - \ server/ocsigen_config.cmi \ server/ocsigen_request.cmi \ server/ocsigen_response.cmi \ - server/ocsigen_messages.cmi \ + server/ocsigen_messages.cmi \ server/ocsigen_multipart.cmi \ - server/ocsigen_extensions.cmi \ - server/ocsigen_parseconfig.cmi \ - server/ocsigen_local_files.cmi \ - server/ocsigen_server.cmi + server/ocsigen_extensions.cmi \ + server/ocsigen_parseconfig.cmi \ + server/ocsigen_local_files.cmi \ + server/ocsigen_server.cmi INTF := ${INTF_BASE} -IMPL := baselib/ocsigen_lib_base.cmo \ +IMPL := baselib/ocsigen_lib_base.cmo \ baselib/ocsigen_config_static.cmo \ - baselib/baselib.cma \ - baselib/polytables.cmo \ - \ - http/ocsigen_cookies.cmo \ - http/http.cma \ - \ - server/${PROJECTNAME}.cma \ - server/server_main.cmo + baselib/baselib.cma \ + baselib/polytables.cmo \ + \ + http/ocsigen_cookie_map.cmo \ + http/http.cma \ + \ + server/${PROJECTNAME}.cma \ + server/server_main.cmo INTF_CMX := $(patsubst %.cmi,%.cmx,${INTF_BASE}) diff --git a/src/extensions/.depend b/src/extensions/.depend index d2ba26051..74db47376 100644 --- a/src/extensions/.depend +++ b/src/extensions/.depend @@ -1,25 +1,23 @@ accesscontrol.cmo : ../server/ocsigen_response.cmi \ ../server/ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi \ - ../http/ocsigen_cookies.cmi accesscontrol.cmi + ../http/ocsigen_cookie_map.cmi accesscontrol.cmi accesscontrol.cmx : ../server/ocsigen_response.cmx \ ../server/ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx \ - ../http/ocsigen_cookies.cmx accesscontrol.cmi + ../http/ocsigen_cookie_map.cmx accesscontrol.cmi accesscontrol.cmi : authbasic.cmo : ../server/ocsigen_server.cmi ../server/ocsigen_request.cmi \ ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi \ - ../http/ocsigen_cookies.cmi ../server/ocsigen_cohttp.cmi authbasic.cmi + ../http/ocsigen_cookie_map.cmi ../server/ocsigen_cohttp.cmi authbasic.cmi authbasic.cmx : ../server/ocsigen_server.cmx ../server/ocsigen_request.cmx \ ../http/ocsigen_header.cmx ../server/ocsigen_extensions.cmx \ - ../http/ocsigen_cookies.cmx ../server/ocsigen_cohttp.cmx authbasic.cmi + ../http/ocsigen_cookie_map.cmx ../server/ocsigen_cohttp.cmx authbasic.cmi authbasic.cmi : ../server/ocsigen_server.cmi cgimod.cmo : ../baselib/ocsigen_stream.cmi ../baselib/ocsigen_lib.cmi \ - ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi \ - ../server/ocsigen_config.cmi + ../server/ocsigen_extensions.cmi ../server/ocsigen_config.cmi cgimod.cmx : ../baselib/ocsigen_stream.cmx ../baselib/ocsigen_lib.cmx \ - ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx \ - ../server/ocsigen_config.cmx + ../server/ocsigen_extensions.cmx ../server/ocsigen_config.cmx cors.cmo : ../server/ocsigen_server.cmi ../server/ocsigen_response.cmi \ ../server/ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ ../http/ocsigen_header.cmi ../server/ocsigen_extensions.cmi cors.cmi @@ -40,11 +38,11 @@ deflatemod.cmx : ../baselib/ocsigen_stream.cmx ../server/ocsigen_server.cmx \ deflatemod.cmi : ../server/ocsigen_server.cmi ../server/ocsigen_config.cmi extendconfiguration.cmo : ../server/ocsigen_parseconfig.cmi \ ../baselib/ocsigen_lib.cmi ../server/ocsigen_extensions.cmi \ - ../http/ocsigen_cookies.cmi ../server/ocsigen_config.cmi \ + ../http/ocsigen_cookie_map.cmi ../server/ocsigen_config.cmi \ ../http/ocsigen_charset_mime.cmi extendconfiguration.cmx : ../server/ocsigen_parseconfig.cmx \ ../baselib/ocsigen_lib.cmx ../server/ocsigen_extensions.cmx \ - ../http/ocsigen_cookies.cmx ../server/ocsigen_config.cmx \ + ../http/ocsigen_cookie_map.cmx ../server/ocsigen_config.cmx \ ../http/ocsigen_charset_mime.cmx ocsipersist.cmi : outputfilter.cmo : ../server/ocsigen_server.cmi \ @@ -70,9 +68,9 @@ revproxy.cmx : ../server/ocsigen_response.cmx ../server/ocsigen_request.cmx \ ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ ../server/ocsigen_extensions.cmx rewritemod.cmo : ../server/ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ - ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi + ../server/ocsigen_extensions.cmi ../http/ocsigen_cookie_map.cmi rewritemod.cmx : ../server/ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ - ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx + ../server/ocsigen_extensions.cmx ../http/ocsigen_cookie_map.cmx staticmod.cmo : ../server/ocsigen_server.cmi ../server/ocsigen_response.cmi \ ../server/ocsigen_request.cmi ../server/ocsigen_local_files.cmi \ ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ @@ -84,6 +82,6 @@ staticmod.cmx : ../server/ocsigen_server.cmx ../server/ocsigen_response.cmx \ staticmod.cmi : ../server/ocsigen_server.cmi \ ../server/ocsigen_extensions.cmi userconf.cmo : ../server/ocsigen_request.cmi ../baselib/ocsigen_lib.cmi \ - ../server/ocsigen_extensions.cmi ../http/ocsigen_cookies.cmi + ../server/ocsigen_extensions.cmi ../http/ocsigen_cookie_map.cmi userconf.cmx : ../server/ocsigen_request.cmx ../baselib/ocsigen_lib.cmx \ - ../server/ocsigen_extensions.cmx ../http/ocsigen_cookies.cmx + ../server/ocsigen_extensions.cmx ../http/ocsigen_cookie_map.cmx diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index f9f3fd7c6..f66bebf20 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -239,7 +239,7 @@ let parse_config parse_fun = function (fun rs -> Lwt_log.ign_info ~section "NOT_FOUND: taking in charge 404"; Lwt.return (Ocsigen_extensions.Ext_stop_all - (Ocsigen_cookies.Cookies.empty, `Not_found))) + (Ocsigen_cookie_map.empty, `Not_found))) | Element ("notfound" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s @@ -250,7 +250,7 @@ let parse_config parse_fun = function (fun () -> Lwt.return r)) | Ocsigen_extensions.Req_not_found (err, ri) -> Lwt.return (Ocsigen_extensions.Ext_stop_site - (Ocsigen_cookies.Cookies.empty, `Not_found))) + (Ocsigen_cookie_map.empty, `Not_found))) | Element ("nexthost", [], []) -> (function @@ -259,7 +259,7 @@ let parse_config parse_fun = function (fun () -> Lwt.return r)) | Ocsigen_extensions.Req_not_found (err, ri) -> Lwt.return (Ocsigen_extensions.Ext_stop_host - (Ocsigen_cookies.Cookies.empty, `Not_found))) + (Ocsigen_cookie_map.empty, `Not_found))) | Element ("nextsite" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s @@ -270,7 +270,7 @@ let parse_config parse_fun = function (fun () -> Lwt.return r)) | Ocsigen_extensions.Req_not_found (err, ri) -> Lwt.return (Ocsigen_extensions.Ext_stop_all - (Ocsigen_cookies.Cookies.empty, `Not_found))) + (Ocsigen_cookie_map.empty, `Not_found))) | Element ("stop" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s @@ -278,7 +278,7 @@ let parse_config parse_fun = function (fun rs -> Lwt_log.ign_info ~section "FORBIDDEN: taking in charge 403"; Lwt.return (Ocsigen_extensions.Ext_stop_all - (Ocsigen_cookies.Cookies.empty, `Forbidden))) + (Ocsigen_cookie_map.empty, `Forbidden))) | Element ("forbidden" as s, _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s @@ -384,7 +384,7 @@ let parse_config parse_fun = function Lwt.return (Ocsigen_extensions.Ext_continue_with ( request, - Ocsigen_cookies.Cookies.empty, + Ocsigen_cookie_map.empty, code )) in (function @@ -419,7 +419,7 @@ let parse_config parse_fun = function Lwt.return (Ocsigen_extensions.Ext_continue_with ( { request with Ocsigen_extensions.request_info }, - Ocsigen_cookies.Cookies.empty, + Ocsigen_cookie_map.empty, code )) in (function diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index 8e666fee0..28ee2c8c9 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -74,7 +74,7 @@ let gen ~realm ~auth rs = "AUTH: invalid Authorization header"; Lwt.fail (Ocsigen_cohttp.Ocsigen_http_error - (Ocsigen_cookies.Cookies.empty, `Bad_request)) + (Ocsigen_cookie_map.empty, `Bad_request)) in diff --git a/src/extensions/extendconfiguration.ml b/src/extensions/extendconfiguration.ml index c3c3ec490..479d44e25 100644 --- a/src/extensions/extendconfiguration.ml +++ b/src/extensions/extendconfiguration.ml @@ -38,9 +38,7 @@ let gen configfun = function in Lwt.return (Ocsigen_extensions.Ext_continue_with - (request, - Ocsigen_cookies.Cookies.empty, - err)) + (request, Ocsigen_cookie_map.empty, err)) let gather_do_not_serve_files tag = let rec aux (regexps, files, extensions) = function diff --git a/src/extensions/ocsipersist-dbm/Makefile b/src/extensions/ocsipersist-dbm/Makefile index 189d305e9..572813b81 100644 --- a/src/extensions/ocsipersist-dbm/Makefile +++ b/src/extensions/ocsipersist-dbm/Makefile @@ -2,8 +2,7 @@ include ../../../Makefile.config PACKAGE := dbm ${LWT_PREEMPTIVE_PACKAGE} lwt.unix xml-light -LIBS := -I ../../baselib -I ../../http -I ../../server \ - ${addprefix -package ,${PACKAGE}} +LIBS := -I ../../baselib -I ../../server ${addprefix -package ,${PACKAGE}} OCAMLC := $(OCAMLFIND) ocamlc${BYTEDBG} ${THREAD} OCAMLOPT := $(OCAMLFIND) ocamlopt ${OPTDBG} ${THREAD} OCAMLDOC := $(OCAMLFIND) ocamldoc diff --git a/src/extensions/ocsipersist-pgsql/Makefile b/src/extensions/ocsipersist-pgsql/Makefile index 0b6ed1693..7845863cc 100644 --- a/src/extensions/ocsipersist-pgsql/Makefile +++ b/src/extensions/ocsipersist-pgsql/Makefile @@ -2,8 +2,7 @@ include ../../../Makefile.config PACKAGE := lwt lwt.syntax pgocaml.syntax xml-light -LIBS := -I ../../baselib -I ../../http -I ../../server \ - ${addprefix -package ,${PACKAGE}} +LIBS := -I ../../baselib -I ../../server ${addprefix -package ,${PACKAGE}} OCAMLC := $(OCAMLFIND) ocamlc${BYTEDBG} ${THREAD} OCAMLOPT := $(OCAMLFIND) ocamlopt ${OPTDBG} ${THREAD} OCAMLDOC := $(OCAMLFIND) ocamldoc diff --git a/src/extensions/ocsipersist-sqlite/Makefile b/src/extensions/ocsipersist-sqlite/Makefile index ba3c85e12..7e437efd6 100644 --- a/src/extensions/ocsipersist-sqlite/Makefile +++ b/src/extensions/ocsipersist-sqlite/Makefile @@ -2,8 +2,7 @@ include ../../../Makefile.config PACKAGE := lwt.preemptive sqlite3 xml-light -LIBS := -I ../../baselib -I ../../http -I ../../server \ - ${addprefix -package ,${PACKAGE}} +LIBS := -I ../../baselib -I ../../server ${addprefix -package ,${PACKAGE}} OCAMLC := $(OCAMLFIND) ocamlc${BYTEDBG} ${THREAD} OCAMLOPT := $(OCAMLFIND) ocamlopt ${OPTDBG} ${THREAD} OCAMLDOC := $(OCAMLFIND) ocamldoc diff --git a/src/extensions/rewritemod.ml b/src/extensions/rewritemod.ml index 9613712a6..e5d729197 100644 --- a/src/extensions/rewritemod.ml +++ b/src/extensions/rewritemod.ml @@ -71,7 +71,7 @@ let gen regexp continue = function ~uri:(Uri.of_string redir) ri.Ocsigen_extensions.request_info }, - Ocsigen_cookies.Cookies.empty, + Ocsigen_cookie_map.empty, err) else Lwt.return @@ Ocsigen_extensions.Ext_retry_with @@ -81,7 +81,7 @@ let gen regexp continue = function ~full_rewrite ~uri:(Uri.of_string redir) ri.Ocsigen_extensions.request_info }, - Ocsigen_cookies.Cookies.empty) + Ocsigen_cookie_map.empty) and catch_block = function | Ocsigen_extensions.Not_concerned -> Lwt.return (Ocsigen_extensions.Ext_next err) diff --git a/src/extensions/userconf.ml b/src/extensions/userconf.ml index 0a82b2224..7ea2d276b 100644 --- a/src/extensions/userconf.ml +++ b/src/extensions/userconf.ml @@ -28,7 +28,7 @@ let section = Lwt_log.Section.make "ocsigen:ext:userconf" let err_500 = Ocsigen_extensions.Ext_stop_site - (Ocsigen_cookies.Cookies.empty, `Internal_server_error) + (Ocsigen_cookie_map.empty, `Internal_server_error) let handle_parsing_error {Ocsigen_extensions.request_info} = function | Ocsigen_extensions.Error_in_config_file s -> @@ -83,7 +83,7 @@ let subresult new_req user_parse_site conf previous_err req req_state = (fun e -> handle_parsing_error req e >>= fun answer -> - Lwt.return (answer, Ocsigen_cookies.Cookies.empty)) + Lwt.return (answer, Ocsigen_cookie_map.empty)) ) let conf_to_xml conf = diff --git a/src/files/META.in b/src/files/META.in index 77ad45a04..1e483b863 100644 --- a/src/files/META.in +++ b/src/files/META.in @@ -37,7 +37,7 @@ package "http" ( package "cookies" ( version = "[distributed with Ocsigen server]" - archive(byte) = "ocsigen_cookies.cmo" + archive(byte) = "ocsigen_cookie_map.cmo" ) package "ext" ( diff --git a/src/http/.depend b/src/http/.depend index 8fc4f652f..f9fa4aedc 100644 --- a/src/http/.depend +++ b/src/http/.depend @@ -3,9 +3,9 @@ ocsigen_charset_mime.cmo : ../baselib/ocsigen_lib.cmi \ ocsigen_charset_mime.cmx : ../baselib/ocsigen_lib.cmx \ ../baselib/ocsigen_config_static.cmx ocsigen_charset_mime.cmi ocsigen_charset_mime.cmi : -ocsigen_cookies.cmo : ocsigen_cookies.cmi -ocsigen_cookies.cmx : ocsigen_cookies.cmi -ocsigen_cookies.cmi : ../baselib/ocsigen_lib.cmi +ocsigen_cookie_map.cmo : ocsigen_cookie_map.cmi +ocsigen_cookie_map.cmx : ocsigen_cookie_map.cmi +ocsigen_cookie_map.cmi : ../baselib/ocsigen_lib.cmi ocsigen_header.cmo : ../baselib/ocsigen_lib.cmi ocsigen_header.cmi ocsigen_header.cmx : ../baselib/ocsigen_lib.cmx ocsigen_header.cmi ocsigen_header.cmi : diff --git a/src/http/Makefile b/src/http/Makefile index e06c61bbd..db6481797 100644 --- a/src/http/Makefile +++ b/src/http/Makefile @@ -15,7 +15,7 @@ all: byte opt ### Common files ### -FILES := ocsigen_cookies.ml ocsigen_charset_mime.ml ocsigen_header.ml +FILES := ocsigen_charset_mime.ml ocsigen_cookie_map.ml ocsigen_header.ml PREDEP := diff --git a/src/http/ocsigen_cookie_map.ml b/src/http/ocsigen_cookie_map.ml new file mode 100644 index 000000000..e28dc84cd --- /dev/null +++ b/src/http/ocsigen_cookie_map.ml @@ -0,0 +1,64 @@ +(* Ocsigen + * Copyright (C) 2010 Vincent Balat + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser 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. +*) + +module Map_path = + Map.Make(struct type t = string list let compare = compare end) + +module Map_inner = Map.Make(String) + +type cookie = + [ `Set of (float option * string * bool) + | `Unset ] + +type t = cookie Map_inner.t Map_path.t + +let empty = Map_path.empty + +let add ~path n v m = + let m' = try Map_path.find path m with Not_found -> Map_inner.empty in + (* We replace the old value if it exists *) + Map_path.add path (Map_inner.add n v m') m + +(* [add_multi new old] adds the cookies from [new] to [old]. If + cookies are already bound in oldcookies, the previous binding + disappear. *) +let add_multi = + Map_path.fold @@ fun path -> + Map_inner.fold @@ fun n v beg -> + match v with + | `Set (expo, v, secure) -> + add ~path n (`Set (expo, v, secure)) beg + | `Unset -> + add ~path n `Unset beg + +let remove ~path n m = + try + let m' = Map_path.find path m in + let m' = Map_inner.remove n m' in + if Map_inner.is_empty m' then + Map_path.remove path m + else + (* We replace the old value *) + Map_path.add path m' m + with Not_found -> + m + +module Poly = struct + let add = add + let remove = remove +end diff --git a/src/http/ocsigen_cookie_map.mli b/src/http/ocsigen_cookie_map.mli new file mode 100644 index 000000000..00c18f581 --- /dev/null +++ b/src/http/ocsigen_cookie_map.mli @@ -0,0 +1,77 @@ +(* Ocsigen + * Copyright (C) 2010 Vincent Balat + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser 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. + *) + +(** This type of maps is used to store cookie values for each + path. The key has type Url.path option: it is for the path + (default: root of the site). *) +module Map_path : Map.S with type key := Ocsigen_lib.Url.path + +module Map_inner : Map.S with type key := string + +(** Type used for cookies to set. The float option is the timestamp + for the expiration date. The string is the value. If the bool is + true and the protocol is https, the cookie will be secure (will ask + the browser to send it only through secure connections). *) +type cookie = + [ `Set of (float option * string * bool) + | `Unset ] + +type t = cookie Map_inner.t Map_path.t + +val empty : t + +(** [add ~path c v m] adds the cookie [c] to [m]. + + If the cookie is already bound, the previous binding disappear. *) +val add : + path:Ocsigen_lib.Url.path -> + string -> + cookie -> + t -> t + +(** [add_multi new old] adds the cookies from [new] to [old]. If + cookies are already bound in oldcookies, the previous binding + disappear. *) +val add_multi : t -> t -> t + +(** [remove c cookie_table] removes the cookie [c] from [m]. + + Warning: it is not equivalent to [add ... `Unset ...]). *) +val remove : + path:Ocsigen_lib.Url.path -> + string -> + t -> t + +(** Polymorphic versions of [add] and [remove] to use when we don't need to + `Unset (client-side) *) +module Poly : sig + + val add : + path:Ocsigen_lib.Url.path -> + string -> + 'a -> + 'a Map_inner.t Map_path.t -> + 'a Map_inner.t Map_path.t + + val remove : + path:Ocsigen_lib.Url.path -> + string -> + 'a Map_inner.t Map_path.t -> + 'a Map_inner.t Map_path.t + +end diff --git a/src/http/ocsigen_cookies.ml b/src/http/ocsigen_cookies.ml deleted file mode 100644 index 8f615c947..000000000 --- a/src/http/ocsigen_cookies.ml +++ /dev/null @@ -1,67 +0,0 @@ -(* Ocsigen - * Copyright (C) 2010 Vincent Balat - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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. -*) - -module CookiesTable = Map.Make(String) - -module Cookies = - Map.Make(struct type t = string list let compare = compare end) - -type cookie = - | OSet of float option * string * bool - | OUnset - -type cookieset = cookie CookiesTable.t Cookies.t - -let empty_cookieset = Cookies.empty - -let add_cookie path n v t = - let ct = - try Cookies.find path t - with Not_found -> CookiesTable.empty - in - (* We replace the old value if it exists *) - Cookies.add path (CookiesTable.add n v ct) t - -let remove_cookie path n t = - try - let ct = Cookies.find path t in - let newct = CookiesTable.remove n ct in - if CookiesTable.is_empty newct - then Cookies.remove path t - else (* We replace the old value *) Cookies.add path newct t - with Not_found -> t - -(* [add_cookies newcookies oldcookies] adds the cookies from [newcookies] - to [oldcookies]. If cookies are already bound in oldcookies, - the previous binding disappear. *) -let add_cookies newcookies oldcookies = - Cookies.fold - (fun path ct t -> - CookiesTable.fold - (fun n v beg -> - match v with - | OSet (expo, v, secure) -> - add_cookie path n (OSet (expo, v, secure)) beg - | OUnset -> - add_cookie path n OUnset beg - ) - ct - t - ) - newcookies - oldcookies diff --git a/src/http/ocsigen_cookies.mli b/src/http/ocsigen_cookies.mli deleted file mode 100644 index f774a25cd..000000000 --- a/src/http/ocsigen_cookies.mli +++ /dev/null @@ -1,65 +0,0 @@ -(* Ocsigen - * Copyright (C) 2010 Vincent Balat - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser 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 Ocsigen_lib - -module CookiesTable : Map.S with type key = string - -(** This table is to store cookie values for each path. - The key has type Url.path option: - it is for the path (default: root of the site), -*) -module Cookies : Map.S with type key = Url.path - -(** Type used for cookies to set. - The float option is the timestamp for the expiration date. - The string is the value. - If the bool is true and the protocol is https, the cookie will be secure - (will ask the browser to send it only through secure connections). -*) -type cookie = - | OSet of float option * string * bool - | OUnset - -type cookieset = cookie CookiesTable.t Cookies.t - -val empty_cookieset : 'a CookiesTable.t Cookies.t - - -(** [add_cookie path c v cookie_table] - adds the cookie [c] to the table [cookie_table]. - If the cookie is already bound, the previous binding disappear. *) -val add_cookie : Url.path -> string -> 'a -> - 'a CookiesTable.t Cookies.t -> - 'a CookiesTable.t Cookies.t - -(** [remove_cookie c cookie_table] removes the cookie [c] - from the table [cookie_table]. - Warning: it is not equivalent to [add_cookie ... OUnset ...]). -*) -val remove_cookie : Url.path -> string -> - 'a CookiesTable.t Cookies.t -> - 'a CookiesTable.t Cookies.t - -(** [add_cookies newcookies oldcookies] adds the cookies from [newcookies] - to [oldcookies]. If cookies are already bound in oldcookies, - the previous binding disappear. *) -val add_cookies : - cookie CookiesTable.t Cookies.t -> - cookie CookiesTable.t Cookies.t -> - cookie CookiesTable.t Cookies.t diff --git a/src/server/.depend b/src/server/.depend index 06911f94e..8576287c8 100644 --- a/src/server/.depend +++ b/src/server/.depend @@ -1,11 +1,11 @@ ocsigen_cohttp.cmo : ../baselib/ocsigen_stream.cmi ocsigen_response.cmi \ ocsigen_request.cmi ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ - ../http/ocsigen_cookies.cmi ocsigen_config.cmi ocsigen_cohttp.cmi + ../http/ocsigen_cookie_map.cmi ocsigen_config.cmi ocsigen_cohttp.cmi ocsigen_cohttp.cmx : ../baselib/ocsigen_stream.cmx ocsigen_response.cmx \ ocsigen_request.cmx ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ - ../http/ocsigen_cookies.cmx ocsigen_config.cmx ocsigen_cohttp.cmi + ../http/ocsigen_cookie_map.cmx ocsigen_config.cmx ocsigen_cohttp.cmi ocsigen_cohttp.cmi : ocsigen_response.cmi ocsigen_request.cmi \ - ../http/ocsigen_cookies.cmi ocsigen_config.cmi + ../http/ocsigen_cookie_map.cmi ocsigen_config.cmi ocsigen_command.cmo : ocsigen_messages.cmi ocsigen_command.cmi ocsigen_command.cmx : ocsigen_messages.cmx ocsigen_command.cmi ocsigen_command.cmi : @@ -14,17 +14,17 @@ ocsigen_config.cmx : ../baselib/ocsigen_config_static.cmx ocsigen_config.cmi ocsigen_config.cmi : ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmo : ocsigen_response.cmi ocsigen_request.cmi \ ocsigen_multipart.cmi ../baselib/ocsigen_loader.cmi \ - ../baselib/ocsigen_lib.cmi ../http/ocsigen_cookies.cmi ocsigen_config.cmi \ - ocsigen_command.cmi ocsigen_cohttp.cmi ../http/ocsigen_charset_mime.cmi \ - ocsigen_extensions.cmi + ../baselib/ocsigen_lib.cmi ../http/ocsigen_cookie_map.cmi \ + ocsigen_config.cmi ocsigen_command.cmi ocsigen_cohttp.cmi \ + ../http/ocsigen_charset_mime.cmi ocsigen_extensions.cmi ocsigen_extensions.cmx : ocsigen_response.cmx ocsigen_request.cmx \ ocsigen_multipart.cmx ../baselib/ocsigen_loader.cmx \ - ../baselib/ocsigen_lib.cmx ../http/ocsigen_cookies.cmx ocsigen_config.cmx \ - ocsigen_command.cmx ocsigen_cohttp.cmx ../http/ocsigen_charset_mime.cmx \ - ocsigen_extensions.cmi + ../baselib/ocsigen_lib.cmx ../http/ocsigen_cookie_map.cmx \ + ocsigen_config.cmx ocsigen_command.cmx ocsigen_cohttp.cmx \ + ../http/ocsigen_charset_mime.cmx ocsigen_extensions.cmi ocsigen_extensions.cmi : ocsigen_response.cmi ocsigen_request.cmi \ ocsigen_multipart.cmi ../baselib/ocsigen_lib.cmi \ - ../http/ocsigen_cookies.cmi ocsigen_command.cmi \ + ../http/ocsigen_cookie_map.cmi ocsigen_command.cmi \ ../http/ocsigen_charset_mime.cmi ocsigen_local_files.cmo : ../baselib/ocsigen_lib.cmi ocsigen_extensions.cmi \ ocsigen_config.cmi ocsigen_local_files.cmi @@ -51,19 +51,19 @@ ocsigen_parseconfig.cmi : ocsigen_request.cmo : ../baselib/polytables.cmi \ ../baselib/ocsigen_stream.cmi ocsigen_multipart.cmi \ ../baselib/ocsigen_lib.cmi ../http/ocsigen_header.cmi \ - ../http/ocsigen_cookies.cmi ocsigen_request.cmi + ../http/ocsigen_cookie_map.cmi ocsigen_request.cmi ocsigen_request.cmx : ../baselib/polytables.cmx \ ../baselib/ocsigen_stream.cmx ocsigen_multipart.cmx \ ../baselib/ocsigen_lib.cmx ../http/ocsigen_header.cmx \ - ../http/ocsigen_cookies.cmx ocsigen_request.cmi + ../http/ocsigen_cookie_map.cmx ocsigen_request.cmi ocsigen_request.cmi : ../baselib/polytables.cmi ocsigen_multipart.cmi \ - ../http/ocsigen_header.cmi ../http/ocsigen_cookies.cmi + ../http/ocsigen_header.cmi ../http/ocsigen_cookie_map.cmi ocsigen_response.cmo : ../http/ocsigen_header.cmi \ - ../http/ocsigen_cookies.cmi ocsigen_response.cmi + ../http/ocsigen_cookie_map.cmi ocsigen_response.cmi ocsigen_response.cmx : ../http/ocsigen_header.cmx \ - ../http/ocsigen_cookies.cmx ocsigen_response.cmi + ../http/ocsigen_cookie_map.cmx ocsigen_response.cmi ocsigen_response.cmi : ../http/ocsigen_header.cmi \ - ../http/ocsigen_cookies.cmi + ../http/ocsigen_cookie_map.cmi ocsigen_server.cmo : ocsigen_parseconfig.cmi ocsigen_messages.cmi \ ../baselib/ocsigen_loader.cmi ../baselib/ocsigen_lib.cmi \ ocsigen_extensions.cmi ocsigen_config.cmi ocsigen_command.cmi \ diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index 325c0fb08..585eef7ec 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -3,7 +3,7 @@ open Lwt.Infix let section = Lwt_log.Section.make "ocsigen:cohttp" exception Ocsigen_http_error of - Ocsigen_cookies.cookieset * Cohttp.Code.status + Ocsigen_cookie_map.t * Cohttp.Code.status exception Ext_http_error of Cohttp.Code.status * string option * Cohttp.Header.t option @@ -52,21 +52,18 @@ module Cookie = struct | None -> "") - let serialize_cookies path table headers = - Ocsigen_cookies.CookiesTable.fold - (fun name c h -> - let exp, v, secure = match c with - | Ocsigen_cookies.OUnset -> (Some 0., "", false) - | Ocsigen_cookies.OSet (t, v, secure) -> (t, v, secure) - in - Cohttp.Header.add h - Ocsigen_header.Name.(to_string set_cookie) - (serialize_cookie_raw path exp name v secure)) - table - headers + let serialize_cookies path = + Ocsigen_cookie_map.Map_inner.fold @@ fun name c h -> + let exp, v, secure = match c with + | `Unset -> (Some 0., "", false) + | `Set (t, v, secure) -> (t, v, secure) + in + Cohttp.Header.add h + Ocsigen_header.Name.(to_string set_cookie) + (serialize_cookie_raw path exp name v secure) let serialize cookies headers = - Ocsigen_cookies.Cookies.fold serialize_cookies cookies headers + Ocsigen_cookie_map.Map_path.fold serialize_cookies cookies headers end @@ -83,13 +80,13 @@ let make_cookies_header path exp name c secure = | None -> "") let make_cookies_headers path t hds = - Ocsigen_cookies.CookiesTable.fold + Ocsigen_cookie_map.Map_inner.fold (fun name c h -> let exp, v, secure = match c with - | Ocsigen_cookies.OUnset -> + | `Unset -> Some 0., "", false - | Ocsigen_cookies.OSet (t, v, secure) -> + | `Set (t, v, secure) -> t, v, secure in Cohttp.Header.add h @@ -189,7 +186,7 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body = and cookies = Ocsigen_response.cookies response in let response = let headers = - Ocsigen_cookies.Cookies.fold + Ocsigen_cookie_map.Map_path.fold make_cookies_headers cookies (Cohttp.Response.headers response) diff --git a/src/server/ocsigen_cohttp.mli b/src/server/ocsigen_cohttp.mli index f46cd9055..24c195d48 100644 --- a/src/server/ocsigen_cohttp.mli +++ b/src/server/ocsigen_cohttp.mli @@ -1,5 +1,5 @@ exception Ocsigen_http_error of - Ocsigen_cookies.cookieset * Cohttp.Code.status + Ocsigen_cookie_map.t * Cohttp.Code.status (** Exception raised by exceptions to describe an HTTP error. It is possible to pass the code of the error, an optional comment, and diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 586cb2d42..c93cb5ed5 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -212,33 +212,33 @@ type answer = `Not_found, but may be for example `Forbidden (403) if you want to try another extension afterwards. Same as Ext_continue_with but does not change the request. *) - | Ext_stop_site of (Ocsigen_cookies.cookieset * Cohttp.Code.status) + | Ext_stop_site of (Ocsigen_cookie_map.t * Cohttp.Code.status) (** Error. Do not try next extension, but try next site. *) - | Ext_stop_host of (Ocsigen_cookies.cookieset * Cohttp.Code.status) + | Ext_stop_host of (Ocsigen_cookie_map.t * Cohttp.Code.status) (** Error. Do not try next extension, do not try next site, but try next host. *) - | Ext_stop_all of (Ocsigen_cookies.cookieset * Cohttp.Code.status) + | Ext_stop_all of (Ocsigen_cookie_map.t * Cohttp.Code.status) (** Error. Do not try next extension, do not try next site, do not try next host. *) | Ext_continue_with of - (request * Ocsigen_cookies.cookieset * Cohttp.Code.status) + (request * Ocsigen_cookie_map.t * Cohttp.Code.status) (** Used to modify the request before giving it to next extension. The extension returns the request (possibly modified) and a set of cookies if it wants to set or cookies - ({!Ocsigen_cookies.Cookies.empty} for no cookies). You must add + ({!Ocsigen_cookie_set.empty} for no cookies). You must add these cookies yourself in request if you want them to be seen by subsequent extensions, for example using {!Ocsigen_http_frame.compute_new_ri_cookies}. The status is usually equal to the one received from preceding extension (but you may want to modify it). *) - | Ext_retry_with of request * Ocsigen_cookies.cookieset + | Ext_retry_with of request * Ocsigen_cookie_map.t (** Used to retry all the extensions with a new request. The extension returns the request (possibly modified) and a set of cookies if it wants to set or cookies - ({!Ocsigen_cookies.Cookies.empty} for no cookies). You must add + ({!Ocsigen_cookie_set.empty} for no cookies). You must add these cookies yourself in request if you want them to be seen by subsequent extensions, for example using {!Ocsigen_http_frame.compute_new_ri_cookies}. *) @@ -261,9 +261,9 @@ and request_state = | Req_found of (request * Ocsigen_response.t) and extension_composite = - Ocsigen_cookies.cookieset -> + Ocsigen_cookie_map.t -> request_state -> - (answer * Ocsigen_cookies.cookieset) Lwt.t + (answer * Ocsigen_cookie_map.t) Lwt.t type extension = request_state -> answer Lwt.t @@ -354,7 +354,7 @@ let default_extension_composite : extension_composite = | Req_not_found (e, ri) -> Lwt.return (Ext_continue_with - (ri, Ocsigen_cookies.Cookies.empty, e), cookies_to_set) + (ri, Ocsigen_cookie_map.empty, e), cookies_to_set) let compose_step (f : extension) (g : extension_composite) : extension_composite @@ -369,14 +369,14 @@ let compose_step (f : extension) (g : extension_composite) | Req_found (ri, _) -> ri | Req_not_found (_, ri) -> ri in - g Ocsigen_cookies.Cookies.empty + g Ocsigen_cookie_map.empty (Req_found (ri, Ocsigen_response.add_cookies r' cookies_to_set)) | Ext_found_continue_with r -> r () >>= fun (r', req) -> - g Ocsigen_cookies.Cookies.empty + g Ocsigen_cookie_map.empty (Req_found (req, Ocsigen_response.add_cookies r' cookies_to_set)) | Ext_found_continue_with' (r', req) -> - g Ocsigen_cookies.Cookies.empty + g Ocsigen_cookie_map.empty (Req_found (req, Ocsigen_response.add_cookies r' cookies_to_set)) | Ext_next e -> let ri = match req_state with @@ -385,7 +385,7 @@ let compose_step (f : extension) (g : extension_composite) in g cookies_to_set (Req_not_found (e, ri)) | Ext_continue_with (ri, cook, e) -> - g (Ocsigen_cookies.add_cookies cook cookies_to_set) + g (Ocsigen_cookie_map.add_multi cook cookies_to_set) (Req_not_found (e, ri)) | Ext_found_stop _ | Ext_stop_site _ @@ -526,7 +526,7 @@ let site_ext ext_of_children charset path cookies_to_set = function Lwt.return (Ext_continue_with (oldri, - Ocsigen_cookies.Cookies.empty, + Ocsigen_cookie_map.empty, e), cookies_to_set) | r -> Lwt.return r @@ -808,7 +808,7 @@ let string_of_host (h : virtual_hosts) = in List.fold_left (fun d arg -> d ^ aux1 arg ^" ") "" h let compute_result - ?(previous_cookies = Ocsigen_cookies.Cookies.empty) + ?(previous_cookies = Ocsigen_cookie_map.empty) request_info = let host = Ocsigen_request.host request_info @@ -854,17 +854,17 @@ let compute_result | Ext_stop_host (cook, e) | Ext_stop_site (cook, e) -> fold_hosts request_info e - (Ocsigen_cookies.add_cookies cook cookies_to_set) l + (Ocsigen_cookie_map.add_multi cook cookies_to_set) l (* try next site *) | Ext_stop_all (cook, e) -> Lwt.fail (Ocsigen_http_error (cookies_to_set, e)) | Ext_continue_with (_, cook, e) -> fold_hosts request_info e - (Ocsigen_cookies.add_cookies cook cookies_to_set) l + (Ocsigen_cookie_map.add_multi cook cookies_to_set) l | Ext_retry_with (request2, cook) -> fold_hosts_limited (get_hosts ()) - (Ocsigen_cookies.add_cookies cook cookies_to_set) + (Ocsigen_cookie_map.add_multi cook cookies_to_set) request2.request_info (* retry all *) | Ext_sub_result sr -> diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index b090a1ba0..af7af2dec 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -23,7 +23,7 @@ include (module type of Ocsigen_command) exception Ocsigen_http_error of - Ocsigen_cookies.cookieset * Cohttp.Code.status + Ocsigen_cookie_map.t * Cohttp.Code.status (** Xml tag not recognized by an extension (usually not a real error) *) exception Bad_config_tag_for_extension of string @@ -141,33 +141,33 @@ type answer = `Not_found, but may be for example `Forbidden (403) if you want to try another extension afterwards. Same as Ext_continue_with but does not change the request. *) - | Ext_stop_site of (Ocsigen_cookies.cookieset * Cohttp.Code.status) + | Ext_stop_site of (Ocsigen_cookie_map.t * Cohttp.Code.status) (** Error. Do not try next extension, but try next site. *) - | Ext_stop_host of (Ocsigen_cookies.cookieset * Cohttp.Code.status) + | Ext_stop_host of (Ocsigen_cookie_map.t * Cohttp.Code.status) (** Error. Do not try next extension, do not try next site, but try next host. *) - | Ext_stop_all of (Ocsigen_cookies.cookieset * Cohttp.Code.status) + | Ext_stop_all of (Ocsigen_cookie_map.t * Cohttp.Code.status) (** Error. Do not try next extension, do not try next site, do not try next host. *) | Ext_continue_with of - (request * Ocsigen_cookies.cookieset * Cohttp.Code.status) + (request * Ocsigen_cookie_map.t * Cohttp.Code.status) (** Used to modify the request before giving it to next extension. The extension returns the request (possibly modified) and a set of cookies if it wants to set or cookies - ({!Ocsigen_cookies.Cookies.empty} for no cookies). You must add + ({!Ocsigen_cookie_set.empty} for no cookies). You must add these cookies yourself in request if you want them to be seen by subsequent extensions, for example using {!Ocsigen_http_frame.compute_new_ri_cookies}. The status is usually equal to the one received from preceding extension (but you may want to modify it). *) - | Ext_retry_with of request * Ocsigen_cookies.cookieset + | Ext_retry_with of request * Ocsigen_cookie_map.t (** Used to retry all the extensions with a new request. The extension returns the request (possibly modified) and a set of cookies if it wants to set or cookies - ({!Ocsigen_cookies.Cookies.empty} for no cookies). You must add + ({!Ocsigen_cookie_set.empty} for no cookies). You must add these cookies yourself in request if you want them to be seen by subsequent extensions, for example using {!Ocsigen_http_frame.compute_new_ri_cookies}. *) @@ -180,8 +180,7 @@ type answer = | Ext_found_continue_with of (unit -> (Ocsigen_response.t * request) Lwt.t) (** Same as [Ext_found] but may modify the request. *) - | Ext_found_continue_with' of - (Ocsigen_response.t * request) + | Ext_found_continue_with' of (Ocsigen_response.t * request) (** Same as [Ext_found_continue_with] but does not allow to delay the computation of the page. You should probably not use it, but for output filters. *) @@ -191,9 +190,9 @@ and request_state = | Req_found of (request * Ocsigen_response.t) and extension_composite = - Ocsigen_cookies.cookieset -> + Ocsigen_cookie_map.t -> request_state -> - (answer * Ocsigen_cookies.cookieset) Lwt.t + (answer * Ocsigen_cookie_map.t) Lwt.t type extension = request_state -> answer Lwt.t (** For each tag in the configuration file, @@ -438,7 +437,7 @@ val get_hosts : (** Compute the answer to be sent to the client, by trying all extensions according the configuration file. *) val compute_result : - ?previous_cookies:Ocsigen_cookies.cookieset -> + ?previous_cookies:Ocsigen_cookie_map.t -> Ocsigen_request.t -> Ocsigen_response.t Lwt.t diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index e235ceb33..333050a3e 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -77,7 +77,7 @@ type t = { r_body : body ref ; r_original_full_path : string option ; r_sub_path : string option ; - r_cookies_override : string Ocsigen_cookies.CookiesTable.t option ; + r_cookies_override : string Ocsigen_cookie_map.Map_inner.t option ; mutable r_request_cache : Polytables.t ; mutable r_tries : int ; r_connection_closed : unit Lwt.t @@ -310,13 +310,13 @@ let parse_cookies s = (fun beg a -> try let (n, v) = Ocsigen_lib.String.sep '=' a in - Ocsigen_cookies.CookiesTable.add n v beg + Ocsigen_cookie_map.Map_inner.add n v beg with Not_found -> beg) - Ocsigen_cookies.CookiesTable.empty + Ocsigen_cookie_map.Map_inner.empty splitted with _ -> - Ocsigen_cookies.CookiesTable.empty + Ocsigen_cookie_map.Map_inner.empty let cookies = function | {r_cookies_override = Some cookies} -> @@ -326,7 +326,7 @@ let cookies = function | Some cookies -> parse_cookies cookies | None -> - Ocsigen_cookies.CookiesTable.empty + Ocsigen_cookie_map.Map_inner.empty let content_type r = match header r Ocsigen_header.Name.content_type with diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli index cf3dbb668..68da21358 100644 --- a/src/server/ocsigen_request.mli +++ b/src/server/ocsigen_request.mli @@ -16,7 +16,7 @@ val make : ?sub_path : string -> ?original_full_path : string -> ?request_cache : Polytables.t -> - ?cookies_override : string Ocsigen_cookies.CookiesTable.t -> + ?cookies_override : string Ocsigen_cookie_map.Map_inner.t -> address : Unix.inet_addr -> port : int -> ssl : bool -> @@ -35,7 +35,7 @@ val update : ?meth : Cohttp.Code.meth -> ?get_params_flat : (string * string) list -> ?post_data : post_data option -> - ?cookies_override : string Ocsigen_cookies.CookiesTable.t -> + ?cookies_override : string Ocsigen_cookie_map.Map_inner.t -> ?full_rewrite : bool -> ?uri : Uri.t -> t -> @@ -83,7 +83,7 @@ val header_multi : t -> Ocsigen_header.Name.t -> string list val add_header : t -> Ocsigen_header.Name.t -> string -> t -val cookies : t -> string Ocsigen_cookies.CookiesTable.t +val cookies : t -> string Ocsigen_cookie_map.Map_inner.t val files : t -> diff --git a/src/server/ocsigen_response.ml b/src/server/ocsigen_response.ml index 63183a4d8..b558a88e0 100644 --- a/src/server/ocsigen_response.ml +++ b/src/server/ocsigen_response.ml @@ -1,12 +1,12 @@ type t = { a_response : Cohttp.Response.t ; a_body : Cohttp_lwt.Body.t ; - a_cookies : Ocsigen_cookies.cookieset + a_cookies : Ocsigen_cookie_map.t } let make ?(body = Cohttp_lwt.Body.empty) - ?(cookies = Ocsigen_cookies.empty_cookieset) + ?(cookies = Ocsigen_cookie_map.empty) a_response = { a_response ; a_body = body ; a_cookies = cookies } @@ -31,7 +31,7 @@ let update { a_response ; a_body ; a_cookies } let of_cohttp - ?(cookies = Ocsigen_cookies.empty_cookieset) + ?(cookies = Ocsigen_cookie_map.empty) (a_response, a_body) = { a_response ; a_body ; a_cookies = cookies } @@ -55,11 +55,11 @@ let set_status ({ a_response } as a) status = let cookies {a_cookies} = a_cookies let add_cookies ({ a_cookies } as a) cookies = - if cookies = Ocsigen_cookies.Cookies.empty then + if cookies = Ocsigen_cookie_map.empty then a else { a with - a_cookies = Ocsigen_cookies.add_cookies a_cookies cookies + a_cookies = Ocsigen_cookie_map.add_multi a_cookies cookies } let header {a_response} id = diff --git a/src/server/ocsigen_response.mli b/src/server/ocsigen_response.mli index 3b6cfa532..715fb59fe 100644 --- a/src/server/ocsigen_response.mli +++ b/src/server/ocsigen_response.mli @@ -2,19 +2,19 @@ type t val make : ?body : Cohttp_lwt.Body.t -> - ?cookies : Ocsigen_cookies.cookieset -> + ?cookies : Ocsigen_cookie_map.t -> Cohttp.Response.t -> t val update : ?response : Cohttp.Response.t -> ?body : Cohttp_lwt.Body.t -> - ?cookies : Ocsigen_cookies.cookieset -> + ?cookies : Ocsigen_cookie_map.t -> t -> t val of_cohttp : - ?cookies : Ocsigen_cookies.cookieset -> + ?cookies : Ocsigen_cookie_map.t -> (Cohttp.Response.t * Cohttp_lwt.Body.t) -> t @@ -24,9 +24,9 @@ val status : t -> Cohttp.Code.status val set_status : t -> Cohttp.Code.status -> t -val cookies : t -> Ocsigen_cookies.cookieset +val cookies : t -> Ocsigen_cookie_map.t -val add_cookies : t -> Ocsigen_cookies.cookieset -> t +val add_cookies : t -> Ocsigen_cookie_map.t -> t val header : t -> Ocsigen_header.Name.t -> string option From 8dfa9c775a403b873256a6b24e162d20a11b5de8 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Thu, 8 Feb 2018 15:00:40 +0100 Subject: [PATCH 109/111] Cohttp debugging message adjustments --- src/server/ocsigen_cohttp.ml | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index 585eef7ec..122c42976 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -98,11 +98,6 @@ let make_cookies_headers path t hds = let handler ~ssl ~address ~port ~connector (flow, conn) request body = - Lwt_log.ign_info_f ~section - "Receiving the request: %s\nConnection ID: %s" - (Format.asprintf "%a" print_request request) - (Cohttp.Connection.to_string conn); - let filenames = ref [] in let edn = Conduit_lwt_unix.endp_of_flow flow in let rec getsockname = function @@ -149,9 +144,6 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body = None, `Internal_server_error in - Lwt_log.ign_warning_f ~section "Returning error code %i." - (Cohttp.Code.code_of_status (ret_code :> Cohttp.Code.status_code)); - let body = match ret_code with | `Not_found -> "Not Found" @@ -207,7 +199,7 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body = let conn_closed (flow, conn) = try - Lwt_log.ign_info_f ~section + Lwt_log.ign_debug_f ~section "Connection closed:\n%s" (Cohttp.Connection.to_string conn); let wakener = Hashtbl.find waiters conn in From 340bdc653178c863d6f08611adb9f90d17e43886 Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Mon, 12 Feb 2018 19:07:24 +0100 Subject: [PATCH 110/111] Fix buggy & leaky "connection closed" detection connection != request :( --- src/server/ocsigen_cohttp.ml | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index 122c42976..52fa2e9d5 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -35,7 +35,7 @@ let print_request fmt request = values)) (Cohttp.Request.headers request) -let waiters = Hashtbl.create 256 +let connections = Hashtbl.create 256 exception Ocsigen_is_dir of (Ocsigen_request.t -> Uri.t) @@ -116,8 +116,15 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body = in let sockaddr = getsockname edn in - let (connection_closed, wakener) = Lwt.wait () in - Hashtbl.add waiters conn wakener; + + let connection_closed = + try + fst (Hashtbl.find connections conn) + with Not_found -> + let ((connection_closed, _) as p) = Lwt.wait () in + Hashtbl.add connections conn p; + connection_closed + in let handle_error exn = @@ -202,9 +209,8 @@ let conn_closed (flow, conn) = Lwt_log.ign_debug_f ~section "Connection closed:\n%s" (Cohttp.Connection.to_string conn); - let wakener = Hashtbl.find waiters conn in - Lwt.wakeup wakener (); - Hashtbl.remove waiters conn + Lwt.wakeup (snd (Hashtbl.find connections conn)) (); + Hashtbl.remove connections conn with Not_found -> () let stop, stop_wakener = Lwt.wait () From ae1ed95ea77be8586797df4b5214fc6e60a68d0a Mon Sep 17 00:00:00 2001 From: Vasilis Papavasileiou Date: Wed, 14 Feb 2018 16:40:11 +0100 Subject: [PATCH 111/111] Remove redundant ppx_deriving dependency --- Makefile.options | 3 +-- opam | 3 --- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/Makefile.options b/Makefile.options index eb9ecf55b..134e80254 100644 --- a/Makefile.options +++ b/Makefile.options @@ -41,8 +41,7 @@ SERVER_PACKAGE := lwt_ssl \ xml-light \ dynlink \ cohttp.lwt \ - hmap \ - ppx_deriving.std + hmap INITPACKAGE := \"$(shell ${OCAMLFIND} query -p-format -recursive \ -separator '\";\"' ${SERVER_PACKAGE})\"; \ diff --git a/opam b/opam index 52e8e8cec..a33cf6a61 100644 --- a/opam +++ b/opam @@ -57,9 +57,6 @@ depends: [ "ipaddr" {>= "2.1"} "cohttp-lwt-unix" "hmap" - - # REMOVE AFTER DEBUGGING - "ppx_deriving" ] depopts: "camlzip" conflicts: [