diff --git a/Makefile.options b/Makefile.options index 691adb93b..f3831bc1c 100644 --- a/Makefile.options +++ b/Makefile.options @@ -23,6 +23,6 @@ INCS= -I ${BLD}/server/.ocsigenserver.objs/byte \ ## ${SERVER_PACKAGE} is not only used to build the 'ocsigenserver' executable ## but also to generate src/baselib/ocsigen_config_static.ml -SERVER_PACKAGE := lwt_ssl,bytes,lwt.unix,logs,logs-syslog,syslog-message,ipaddr,findlib,cryptokit,re,str,xml-light,dynlink,cohttp-lwt-unix,http +SERVER_PACKAGE := bytes,logs,logs-syslog.unix,syslog-message,ipaddr,findlib,cryptokit,re,str,xml-light,dynlink,cohttp-eio,http,eio,eio_main,ipaddr.unix,magic-mime LIBS := -package ${SERVER_PACKAGE} ${INCS} diff --git a/configure b/configure index 1ddf344a4..0ff7b6e73 100755 --- a/configure +++ b/configure @@ -393,15 +393,13 @@ 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-unix "Missing support for 'lwt' in cohttp." +check_library cohttp-eio "Missing support for 'eio' in cohttp." check_library react "See: http://erratique.ch/software/react" check_library ssl "See: http://sourceforge.net/projects/savonet/files/ocaml-ssl" check_library http "" -check_library lwt "See: http://ocsigen.org/lwt" -check_library lwt.unix "Missing support for 'unix' in lwt." -check_library lwt_react "See: http://ocsigen.org/lwt" -check_library lwt_ssl "See: http://ocsigen.org/lwt" +check_library eio "" +check_library eio_main "" check_library logs "" check_library logs-syslog "Missing syslog support." diff --git a/dune-project b/dune-project index 9e0b44e7f..766b6f96f 100644 --- a/dune-project +++ b/dune-project @@ -18,12 +18,12 @@ (depends (ocaml (>= 4.08.1)) (camlzip (>= 1.04)) - (cohttp-lwt-unix (and (>= 5.0) (< 6.0))) - (conduit-lwt-unix (and (>= 2.0) (< 7.0))) + (cohttp-eio (>= 6.0.0)) http cryptokit (ipaddr (>= 2.1)) - (lwt (>= 3.0)) + (eio (>= 0.13)) + eio_main lwt_react lwt_ssl ocamlfind @@ -33,6 +33,7 @@ xml-light logs logs-syslog - syslog-message) + syslog-message + magic-mime) (conflicts (pgocaml (< 2.2)))) diff --git a/ocsigenserver.opam b/ocsigenserver.opam index ef989a6dd..ff42f7204 100644 --- a/ocsigenserver.opam +++ b/ocsigenserver.opam @@ -13,12 +13,12 @@ depends: [ "dune" {>= "3.19"} "ocaml" {>= "4.08.1"} "camlzip" {>= "1.04"} - "cohttp-lwt-unix" {>= "5.0" & < "6.0"} - "conduit-lwt-unix" {>= "2.0" & < "7.0"} + "cohttp-eio" {>= "6.0.0"} "http" "cryptokit" "ipaddr" {>= "2.1"} - "lwt" {>= "3.0"} + "eio" {>= "0.13"} + "eio_main" "lwt_react" "lwt_ssl" "ocamlfind" @@ -29,6 +29,7 @@ depends: [ "logs" "logs-syslog" "syslog-message" + "magic-mime" "odoc" {with-doc} ] conflicts: [ diff --git a/src/baselib/dune b/src/baselib/dune index 6024b9c33..41a752d2d 100644 --- a/src/baselib/dune +++ b/src/baselib/dune @@ -4,7 +4,7 @@ (flags (:standard -no-keep-locs)) (modules ocsigen_lib_base) - (libraries lwt)) + (libraries eio eio.unix)) (library (name baselib) @@ -22,10 +22,12 @@ (libraries str findlib - lwt.unix + eio cryptokit re ocsigen_lib_base + cohttp + cohttp-eio logs (select dynlink_wrapper.ml diff --git a/src/baselib/ocsigen_cache.ml b/src/baselib/ocsigen_cache.ml index 4cc22a248..856ab22f1 100644 --- a/src/baselib/ocsigen_cache.ml +++ b/src/baselib/ocsigen_cache.ml @@ -1,3 +1,5 @@ +open Eio.Std + (* Ocsigen * Copyright (C) 2009 * @@ -22,8 +24,6 @@ @author Raphaël Proust (adding timers) *) -open Lwt.Infix - module Dlist : sig type 'a t type 'a node @@ -120,7 +120,8 @@ end = struct ; mutable finaliser_after : 'a node -> unit ; time_bound : time_bound option } - and time_bound = {timer : float; mutable collector : unit Lwt.t option} + and time_bound = + {timer : float; mutable collector : (unit, exn) result Promise.t option} (* Checks (by BY): @@ -214,7 +215,7 @@ end = struct | None -> assert false (* collection is set to None and collector to Some *) | Some t -> let duration = t -. Unix.gettimeofday () in - if duration <= 0. then Lwt.return () else Lwt_unix.sleep duration + if duration <= 0. then () else Eio_unix.sleep duration (* a function to set the collector. *) let rec update_collector r = @@ -227,11 +228,13 @@ end = struct | Some n -> t.collector <- Some - ( sleep_until n.collection >>= fun () -> - collect r n; - t.collector <- None; - update_collector r; - Lwt.return () )) + (Fiber.fork_promise + ~sw:(Option.get (Fiber.get Ocsigen_lib.current_switch)) + (fun () -> + sleep_until n.collection; + collect r n; + t.collector <- None; + update_collector r))) (* Add a node that do not belong to any list to a list. The fields [succ] and [prev] are overridden. @@ -399,7 +402,7 @@ functor type t = { mutable pointers : A.key Dlist.t ; mutable table : (A.value * A.key Dlist.node) H.t - ; finder : A.key -> A.value Lwt.t + ; finder : A.key -> A.value ; clear : unit -> unit (* This function clears the cache. It is put inside the cache structure so that it is garbage-collected only when the cache @@ -460,14 +463,14 @@ functor let size c = Dlist.size c.pointers let find cache k = - try Lwt.return (find_in_cache cache k) + try find_in_cache cache k with Not_found -> - cache.finder k >>= fun r -> + let r = cache.finder k in (try (* it may have been added during cache.finder *) ignore (find_in_cache cache k : A.value) with Not_found -> add_no_remove cache k r); - Lwt.return r + r class cache f ?timer size_c = let c = create f ?timer size_c in diff --git a/src/baselib/ocsigen_cache.mli b/src/baselib/ocsigen_cache.mli index fc68c2fe4..0b95cb049 100644 --- a/src/baselib/ocsigen_cache.mli +++ b/src/baselib/ocsigen_cache.mli @@ -53,8 +53,8 @@ module Make : functor Using [timer] allow one to create a cache bounded both in space and time. It is to be noted that real lifespan of values is always slightly greater than [timer]. *) - class cache : (A.key -> A.value Lwt.t) -> ?timer:float -> int -> object - method find : A.key -> A.value Lwt.t + class cache : (A.key -> A.value) -> ?timer:float -> int -> object + method find : A.key -> A.value (** Find the cached value associated to the key, or binds this value in the cache using the function [finder] passed as argument to [create], and returns this value *) diff --git a/src/baselib/ocsigen_lib.ml b/src/baselib/ocsigen_lib.ml index 426839250..638da53d6 100644 --- a/src/baselib/ocsigen_lib.ml +++ b/src/baselib/ocsigen_lib.ml @@ -16,9 +16,13 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Eio.Std include Ocsigen_lib_base module String = String_base +let current_switch = Eio.Fiber.create_key () +let env = Eio.Fiber.create_key () + (*****************************************************************************) module Ip_address = struct @@ -26,17 +30,16 @@ module Ip_address = struct let get_inet_addr ?(v6 = false) host = let rec aux = function - | [] -> Lwt.fail No_such_host - | {Unix.ai_addr = Unix.ADDR_INET (inet_addr, _); _} :: _ -> - Lwt.return inet_addr + | [] -> raise No_such_host + | `Tcp (ipv4v6, _port) :: tl -> + Eio.Net.Ipaddr.fold + ~v4:(fun ip -> if v6 then aux tl else ip) + ~v6:(fun ip -> if v6 then ip else aux tl) + ipv4v6 | _ :: l -> aux l in - let options = - [ (if v6 - then Lwt_unix.AI_FAMILY Lwt_unix.PF_INET6 - else Lwt_unix.AI_FAMILY Lwt_unix.PF_INET) ] - in - Lwt.bind (Lwt_unix.getaddrinfo host "" options) aux + let env = Stdlib.Option.get (Fiber.get env) in + (aux (Eio.Net.getaddrinfo env#net host) : _ Eio.Net.Ipaddr.t :> string) end (*****************************************************************************) diff --git a/src/baselib/ocsigen_lib.mli b/src/baselib/ocsigen_lib.mli index 0c3a78c78..658034fc9 100644 --- a/src/baselib/ocsigen_lib.mli +++ b/src/baselib/ocsigen_lib.mli @@ -29,6 +29,9 @@ include and type 'a Clist.t = 'a Ocsigen_lib_base.Clist.t and type 'a Clist.node = 'a Ocsigen_lib_base.Clist.node +val current_switch : Eio.Switch.t Eio.Fiber.key +val env : Eio_unix.Stdenv.base Eio.Fiber.key + val make_cryptographic_safe_string : unit -> string (** Generate an unique and cryptographically safe random string. It is impossible to guess for other people and @@ -39,7 +42,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 get_inet_addr : ?v6:bool -> string -> string end module Filename : sig diff --git a/src/baselib/ocsigen_lib_base.ml b/src/baselib/ocsigen_lib_base.ml index 5c8f63d4c..d26beb8b9 100644 --- a/src/baselib/ocsigen_lib_base.ml +++ b/src/baselib/ocsigen_lib_base.ml @@ -23,8 +23,6 @@ exception Ocsigen_Request_too_long external id : 'a -> 'a = "%identity" -include Lwt.Infix - let ( !! ) = Lazy.force let ( |> ) x f = f x let ( @@ ) f x = f x @@ -47,8 +45,7 @@ type yesnomaybe = Yes | No | Maybe type ('a, 'b) leftright = Left of 'a | Right of 'b let advert = - "Page generated by OCaml with Ocsigen. -See http://ocsigen.org/ and http://caml.inria.fr/ for information" + "Page generated by OCaml with Ocsigen.\nSee http://ocsigen.org/ and http://caml.inria.fr/ for information" (*****************************************************************************) diff --git a/src/baselib/ocsigen_lib_base.mli b/src/baselib/ocsigen_lib_base.mli index bc68b8a7c..8b56fa053 100644 --- a/src/baselib/ocsigen_lib_base.mli +++ b/src/baselib/ocsigen_lib_base.mli @@ -26,8 +26,6 @@ exception Input_is_too_large exception Ocsigen_Bad_Request exception Ocsigen_Request_too_long -include module type of Lwt.Infix - val ( !! ) : 'a Lazy.t -> 'a val ( |> ) : 'a -> ('a -> 'b) -> 'b val ( @@ ) : ('a -> 'b) -> 'a -> 'b diff --git a/src/baselib/ocsigen_stream.ml b/src/baselib/ocsigen_stream.ml index 8e7faa970..98cda4cfd 100644 --- a/src/baselib/ocsigen_stream.ml +++ b/src/baselib/ocsigen_stream.ml @@ -1,3 +1,5 @@ +open Eio.Std + (* Ocsigen * ocsigen_stream.ml Copyright (C) 2005 Vincent Balat * @@ -23,7 +25,8 @@ exception Cancelled exception Already_read exception Finalized -type 'a stream = 'a step Lwt.t Lazy.t +type 'a stream = 'a step Lazy.t +(** Forcing a [stream] performs effects. *) and 'a step = | Finished of 'a stream option @@ -37,37 +40,35 @@ type outcome = [`Success | `Failure] type 'a t = { mutable stream : 'a stream ; mutable in_use : bool - ; mutable finalizer : outcome -> unit Lwt.t } + ; mutable finalizer : outcome -> unit } 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) - | Some st -> Lwt.return (Finished (Some (Lazy.from_fun st))) + | None -> Finished None + | Some st -> Finished (Some (Lazy.from_fun st)) -let cont stri f = Lwt.return (Cont (stri, Lazy.from_fun f)) +let cont stri f = Cont (stri, Lazy.from_fun f) -let make ?finalize:(g = fun _ -> Lwt.return ()) f = +let make ?finalize:(g = fun _ -> ()) f = {stream = Lazy.from_fun f; in_use = false; finalizer = g} let next = Lazy.force let rec get_aux st = lazy - (Lwt.try_bind - (fun () -> Lazy.force st.stream) - (fun e -> - Lwt.return - (match e with - | Cont (s, rem) -> - st.stream <- rem; - Cont (s, get_aux st) - | _ -> e)) - (fun e -> - st.stream <- lazy (Lwt.fail e); - Lwt.fail (Interrupted e))) + (match Lazy.force st.stream with + | e -> ( + match e with + | Cont (s, rem) -> + st.stream <- rem; + Cont (s, get_aux st) + | _ -> e) + | exception e -> + st.stream <- lazy (raise e); + raise (Interrupted e)) let get st = if st.in_use then raise Already_read; @@ -76,29 +77,28 @@ let get st = (** read the stream until the end, without decoding *) let rec consume_aux st = - next st >>= fun e -> + let e = next st in match e with | Cont (_, f) -> consume_aux f | Finished (Some ss) -> consume_aux ss - | Finished None -> Lwt.return () + | Finished None -> () let cancel st = let st' = st.stream in - st.stream <- lazy (Lwt.fail Cancelled); + st.stream <- lazy (raise Cancelled); consume_aux st' let consume st = consume_aux st.stream let finalize st status = let f = st.finalizer in - st.finalizer <- (fun _ -> Lwt.return ()); - f status >>= fun () -> - st.stream <- lazy (Lwt.fail Finalized); - Lwt.return () + st.finalizer <- (fun _ -> ()); + f status; + st.stream <- lazy (raise Finalized) let add_finalizer st g = let f = st.finalizer in - st.finalizer <- (fun status -> f status >>= fun () -> g status) + st.finalizer <- (fun status -> f status; g status) (****) @@ -111,53 +111,56 @@ exception String_too_large let string_of_stream m s = let buff = Buffer.create (m / 4) in let rec aux i s = - next s >>= function - | Finished _ -> Lwt.return buff + match next s with + | Finished _ -> buff | Cont (s, f) -> let i = i + String.length s in if i > m - then Lwt.fail String_too_large + then raise String_too_large else (Buffer.add_string buff s; aux i f) in - aux 0 s >|= Buffer.contents + Buffer.contents (aux 0 s) let enlarge_stream = function - | Finished _a -> Lwt.fail Stream_too_small + | Finished _a -> raise Stream_too_small | Cont (s, f) -> ( let long = String.length s in let max = !net_buffer_size in if long >= max - then Lwt.fail Input_is_too_large + then raise Input_is_too_large else - next f >>= fun e -> + let e = next f in match e with - | Finished _ -> Lwt.fail Stream_too_small + | Finished _ -> raise Stream_too_small | Cont (r, ff) -> let long2 = String.length r in let long3 = long + long2 in let new_s = s ^ r in if long3 <= max - then Lwt.return (Cont (new_s, ff)) + then Cont (new_s, ff) else let long4 = long3 - max in cont (String.sub new_s 0 max) (fun () -> - Lwt.return (Cont (String.sub new_s max long4, ff)))) + Cont (String.sub new_s max long4, ff))) let rec stream_want s len = (* returns a stream with at least len bytes read if possible *) match s with - | Finished _ -> Lwt.return s + | Finished _ -> s | Cont (stri, _f) -> ( if String.length stri >= len - then Lwt.return s + then s else - Lwt.catch - (fun () -> enlarge_stream s >>= fun r -> Lwt.return (`OK r)) - (function - | Stream_too_small -> Lwt.return `Too_small | e -> Lwt.fail e) - >>= function + match + try + let r = enlarge_stream s in + `OK r + with + | Stream_too_small -> `Too_small + | e -> raise e + with | `OK r -> stream_want r len - | `Too_small -> Lwt.return s) + | `Too_small -> s) let current_buffer = function | Finished _ -> raise Stream_too_small @@ -172,35 +175,35 @@ let rec skip s k = if Int64.compare k len64 <= 0 then let k = Int64.to_int k in - Lwt.return (Cont (String.sub s k (len - k), f)) - else enlarge_stream (Cont ("", f)) >>= fun s -> skip s (Int64.sub k len64) + Cont (String.sub s k (len - k), f) + else + let s = enlarge_stream (Cont ("", f)) in + skip s (Int64.sub k len64) let substream delim s = let ldelim = String.length delim in if ldelim = 0 - then Lwt.fail (Stream_error "Empty delimiter") + then raise (Stream_error "Empty delimiter") else let rdelim = Re.Pcre.(regexp (quote delim)) in let rec aux = function - | Finished _ -> Lwt.fail Stream_too_small + | Finished _ -> raise Stream_too_small | Cont (s, f) as stre -> ( let len = String.length s in if len < ldelim - then enlarge_stream stre >>= aux + then aux (enlarge_stream stre) else try let p, (_ : 'groups) = Ocsigen_lib.Netstring_pcre.search_forward rdelim s 0 in cont (String.sub s 0 p) (fun () -> - empty - (Some - (fun () -> Lwt.return (Cont (String.sub s p (len - p), f))))) + empty (Some (fun () -> Cont (String.sub s p (len - p), f)))) with Not_found -> let pos = len + 1 - ldelim in cont (String.sub s 0 pos) (fun () -> - next f >>= function - | Finished _ -> Lwt.fail Stream_too_small + match next f with + | Finished _ -> raise Stream_too_small | Cont (s', f') -> aux (Cont (String.sub s pos (len - pos) ^ s', f')))) in @@ -211,64 +214,51 @@ let substream delim s = (*VVV Is it the good place for this? *) let of_file filename = - let fd = - Lwt_unix.of_unix_file_descr - (Unix.openfile filename [Unix.O_RDONLY; Unix.O_NONBLOCK] 0o666) + let fd = Unix.openfile filename [Unix.O_RDONLY; Unix.O_NONBLOCK] 0o666 in + let ch = + (Eio_unix.Net.import_socket_stream + ~sw:(Stdlib.Option.get (Fiber.get Ocsigen_lib.current_switch)) + ~close_unix:true fd + :> [`R | `Flow | `Close] r) in - let ch = Lwt_io.(of_fd ~mode:input) fd in - let buf = Bytes.create 1024 in + let buf = Cstruct.create 1024 in let rec aux () = - Lwt_io.read_into ch buf 0 1024 >>= fun n -> + let n = Eio.Flow.single_read ch buf in if n = 0 then empty None else (* Streams should be immutable, thus we always make a copy of the buffer *) - cont (Bytes.sub_string buf 0 n) aux + cont (Cstruct.to_string ~len:n buf) aux in - make ~finalize:(fun _ -> Lwt_unix.close fd) aux + make ~finalize:(fun _ -> Unix.close fd) aux let of_string s = make (fun () -> cont s (fun () -> empty None)) -(** Convert a {!Lwt_stream.t} to an {!Ocsigen_stream.t}. *) -let of_lwt_stream stream = +let of_eio_flow body = + let buf = Cstruct.create !net_buffer_size in let rec aux () = - Lwt_stream.get stream >>= function - | Some e -> cont e aux - | None -> empty None + match Eio.Flow.single_read body buf with + | exception End_of_file -> empty None + | len -> cont (Cstruct.to_string ~len buf) aux in make aux -(** Convert an {!Ocsigen_stream.t} into a {!Lwt_stream.t}. - @param is_empty function to skip empty chunk. -*) -let to_lwt_stream ?(is_empty = fun _ -> false) o_stream = - let stream = ref (get o_stream) in - let rec wrap () = - next !stream >>= function - | Finished None -> o_stream.finalizer `Success >>= fun () -> Lwt.return None - | Finished (Some next) -> - stream := next; - wrap () - | Cont (value, next) -> - stream := next; - if is_empty value then wrap () else Lwt.return (Some value) - in - Lwt_stream.from wrap +let of_cohttp_body = of_eio_flow module StringStream = struct type out = string t - type m = (string stream -> string step Lwt.t) Lazy.t + type m = (string stream -> string step) Lazy.t let empty : m = lazy (fun c -> Lazy.force c) let concat (m : m) (f : m) : m = lazy (fun c -> Lazy.force m (lazy (Lazy.force f c))) - let put (s : string) : m = lazy (fun c -> Lwt.return (Cont (s, c))) + let put (s : string) : m = lazy (fun c -> Cont (s, c)) let make_stream (m : m) : string stream = - lazy (Lazy.force m (lazy (Lwt.return (Finished None)))) + lazy (Lazy.force m (lazy (Finished None))) let make (m : m) : out = make (fun () -> Lazy.force (make_stream m)) end diff --git a/src/baselib/ocsigen_stream.mli b/src/baselib/ocsigen_stream.mli index 31ec51136..19cc38695 100644 --- a/src/baselib/ocsigen_stream.mli +++ b/src/baselib/ocsigen_stream.mli @@ -35,39 +35,39 @@ type 'a step = private Finished of 'a stream option | Cont of 'a * 'a stream type 'a t type outcome = [`Success | `Failure] -val make : ?finalize:(outcome -> unit Lwt.t) -> (unit -> 'a step Lwt.t) -> 'a t +val make : ?finalize:(outcome -> unit) -> (unit -> 'a step) -> 'a t (** creates a new stream *) val get : 'a t -> 'a stream (** call this function if you decide to start reading a stream. @raise Already_read if the stream has already been read. *) -val next : 'a stream -> 'a step Lwt.t +val next : 'a stream -> 'a step (** get the next step of a stream. Fails with [Interrupted e] if reading the thread failed with exception [e], and with [Cancelled] if the thread has been cancelled. *) -val empty : (unit -> 'a step Lwt.t) option -> 'a step Lwt.t +val empty : (unit -> 'a step) option -> 'a step (** creates an empty step. The parameter is the following substream, if any. *) -val cont : 'a -> (unit -> 'a step Lwt.t) -> 'a step Lwt.t +val cont : 'a -> (unit -> 'a step) -> 'a step (** creates a non empty step. *) -val add_finalizer : 'a t -> (outcome -> unit Lwt.t) -> unit +val add_finalizer : 'a t -> (outcome -> unit) -> unit (** Add a finalizer function. In the current version, finalizers must be called manually. *) -val finalize : 'a t -> outcome -> unit Lwt.t +val finalize : 'a t -> outcome -> unit (** Finalize the stream. This function must be called explicitly after reading the stream, otherwise finalizers won't be called. *) -val cancel : 'a t -> unit Lwt.t +val cancel : 'a t -> unit (** Cancel the stream, i.e. read the stream until the end, without decoding. Further tries to read on the stream will fail with exception {!Ocsigen_stream.Cancelled} *) -val consume : 'a t -> unit Lwt.t +val consume : 'a t -> unit (** Consume without cancelling. Read the stream until the end, without decoding. *) @@ -77,25 +77,25 @@ exception Stream_too_small exception Stream_error of string exception String_too_large -val string_of_stream : int -> string stream -> string Lwt.t +val string_of_stream : int -> string stream -> string (** Creates a string from a stream. The first argument is the upper limit of the string length *) -val enlarge_stream : string step -> string step Lwt.t +val enlarge_stream : string step -> string step (** Read more data in the buffer *) -val stream_want : string step -> int -> string step Lwt.t +val stream_want : string step -> int -> string step (** [stream_want s len] Returns a stream with at least len bytes in the buffer if possible *) val current_buffer : string step -> string (** Returns the value of the current buffer *) -val skip : string step -> int64 -> string step Lwt.t +val skip : string step -> int64 -> string step (** Skips data. Raises [Stream_too_small (Some size)] if the stream is too small, where [size] is the size of the stream. *) -val substream : string -> string step -> string step Lwt.t +val substream : string -> string step -> string step (** Cut the stream at the position given by a string delimiter *) val of_file : string -> string t @@ -106,13 +106,8 @@ val of_file : string -> string t val of_string : string -> string t (** returns a stream containing a string. *) -val of_lwt_stream : 'a Lwt_stream.t -> 'a t -(** Convert a {!Lwt_stream.t} to an {!Ocsigen_stream.t}. *) - -val to_lwt_stream : ?is_empty:('a -> bool) -> 'a t -> 'a Lwt_stream.t -(** Convert an {!Ocsigen_stream.t} into a {!Lwt_stream.t}. - @param is_empty function to skip empty chunk. -*) +val of_cohttp_body : Cohttp_eio.Body.t -> string t +(** Convert the body of a request to a {!Ocsigen_stream}. *) module StringStream : sig type out = string t diff --git a/src/extensions/accesscontrol.ml b/src/extensions/accesscontrol.ml index 2fc848f63..7ddab3faf 100644 --- a/src/extensions/accesscontrol.ml +++ b/src/extensions/accesscontrol.ml @@ -246,9 +246,8 @@ let allow_forward_for_handler ?(check_equal_ip = false) () = request) | None -> request in - Lwt.return - (Ocsigen_extensions.Ext_continue_with - (request, Ocsigen_cookie_map.empty, code)) + Ocsigen_extensions.Ext_continue_with + (request, Ocsigen_cookie_map.empty, code) in function | Ocsigen_extensions.Req_found (request, resp) -> @@ -274,11 +273,10 @@ let allow_forward_proto_handler = request_info) | None -> request_info in - Lwt.return - (Ocsigen_extensions.Ext_continue_with - ( {request with Ocsigen_extensions.request_info} - , Ocsigen_cookie_map.empty - , code )) + Ocsigen_extensions.Ext_continue_with + ( {request with Ocsigen_extensions.request_info} + , Ocsigen_cookie_map.empty + , code ) in function | Ocsigen_extensions.Req_found (request, resp) -> @@ -306,95 +304,86 @@ let parse_config parse_fun = function function | Ocsigen_extensions.Req_found (ri, _) | Ocsigen_extensions.Req_not_found (_, ri) -> - Lwt.return - (if condition ri.Ocsigen_extensions.request_info - then ( - Logs.info ~src:section (fun fmt -> - fmt "COND: going into branch"); - Ocsigen_extensions.Ext_sub_result ithen) - else ( - Logs.info ~src:section (fun fmt -> - fmt "COND: going into branch, if any"); - Ocsigen_extensions.Ext_sub_result ielse))) + if condition ri.Ocsigen_extensions.request_info + then ( + Logs.info ~src:section (fun fmt -> + fmt "COND: going into branch"); + Ocsigen_extensions.Ext_sub_result ithen) + else ( + Logs.info ~src:section (fun fmt -> + fmt "COND: going into branch, if any"); + Ocsigen_extensions.Ext_sub_result ielse)) | Element (("if" as s), _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s | Element ("notfound", [], []) -> fun _rs -> Logs.info ~src:section (fun fmt -> fmt "NOT_FOUND: taking in charge 404"); - Lwt.return - (Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.empty, `Not_found)) + Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.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.Ext_found_stop (fun () -> r) | Ocsigen_extensions.Req_not_found _ -> - Lwt.return - (Ocsigen_extensions.Ext_stop_site - (Ocsigen_cookie_map.empty, `Not_found))) + Ocsigen_extensions.Ext_stop_site (Ocsigen_cookie_map.empty, `Not_found) + ) | Element ("nexthost", [], []) -> ( function | Ocsigen_extensions.Req_found (_, r) -> - Lwt.return - (Ocsigen_extensions.Ext_found_stop (fun () -> Lwt.return r)) + Ocsigen_extensions.Ext_found_stop (fun () -> r) | Ocsigen_extensions.Req_not_found _ -> - Lwt.return - (Ocsigen_extensions.Ext_stop_host - (Ocsigen_cookie_map.empty, `Not_found))) + Ocsigen_extensions.Ext_stop_host (Ocsigen_cookie_map.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.Ext_found_stop (fun () -> r) | Ocsigen_extensions.Req_not_found _ -> - Lwt.return - (Ocsigen_extensions.Ext_stop_all - (Ocsigen_cookie_map.empty, `Not_found))) + Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.empty, `Not_found) + ) | Element (("stop" as s), _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s | Xml.Element ("forbidden", [], []) -> fun _rs -> Logs.info ~src:section (fun fmt -> fmt "FORBIDDEN: taking in charge 403"); - Lwt.return - (Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.empty, `Forbidden)) + Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.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 (Ocsigen_extensions.Ext_sub_result ext) + Ocsigen_extensions.Ext_sub_result ext | Ocsigen_extensions.Req_not_found (err, _ri) -> - Lwt.return (Ocsigen_extensions.Ext_next err)) + 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.Ext_found (fun () -> r) | Ocsigen_extensions.Req_not_found _ -> - Lwt.return (Ocsigen_extensions.Ext_sub_result ext)) + Ocsigen_extensions.Ext_sub_result ext) | Element ("ifnotfound", [("code", s)], sub) -> ( let ext = parse_fun sub in let re = Netstring_pcre.regexp ("^" ^ s ^ "$") in function | Ocsigen_extensions.Req_found (_, r) -> - Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return r)) + Ocsigen_extensions.Ext_found (fun () -> 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 re err 0 <> None - then Lwt.return (Ocsigen_extensions.Ext_sub_result ext) - else Lwt.return (Ocsigen_extensions.Ext_next err)) + then Ocsigen_extensions.Ext_sub_result ext + else Ocsigen_extensions.Ext_next err) | Element (("ifnotfound" as s), _, _) -> Ocsigen_extensions.badconfig "Bad syntax for tag %s" s | Element ("allow-forward-for", param, _) -> @@ -425,34 +414,31 @@ let () = let if_ condition ithen ielse vh ci p = function | Ocsigen_extensions.Req_found (ri, _) | Ocsigen_extensions.Req_not_found (_, ri) -> - Lwt.return - (if condition ri.Ocsigen_extensions.request_info - then - Ocsigen_extensions.Ext_sub_result - (Ocsigen_extensions.compose (List.map (fun i -> i vh ci p) ithen)) - else - Ocsigen_extensions.Ext_sub_result - (Ocsigen_extensions.compose (List.map (fun i -> i vh ci p) ielse))) + if condition ri.Ocsigen_extensions.request_info + then + Ocsigen_extensions.Ext_sub_result + (Ocsigen_extensions.compose (List.map (fun i -> i vh ci p) ithen)) + else + Ocsigen_extensions.Ext_sub_result + (Ocsigen_extensions.compose (List.map (fun i -> i vh ci p) ielse)) let iffound instrs vh ci p = function | Ocsigen_extensions.Req_found (_, _) -> - Lwt.return - (Ocsigen_extensions.Ext_sub_result - (Ocsigen_extensions.compose (List.map (fun i -> i vh ci p) instrs))) + Ocsigen_extensions.Ext_sub_result + (Ocsigen_extensions.compose (List.map (fun i -> i vh ci p) instrs)) | Ocsigen_extensions.Req_not_found (err, _ri) -> - Lwt.return (Ocsigen_extensions.Ext_next err) + Ocsigen_extensions.Ext_next err let ifnotfound ?code instrs vh ci p = let re = Option.map (fun s -> Netstring_pcre.regexp ("^" ^ s ^ "$")) code in function | Ocsigen_extensions.Req_found (_, r) -> - Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return r)) + Ocsigen_extensions.Ext_found (fun () -> r) | Ocsigen_extensions.Req_not_found (err, _) -> ( match re with | None -> - Lwt.return - (Ocsigen_extensions.Ext_sub_result - (Ocsigen_extensions.compose (List.map (fun i -> i vh ci p) instrs))) + Ocsigen_extensions.Ext_sub_result + (Ocsigen_extensions.compose (List.map (fun i -> i vh ci p) instrs)) | Some re -> if let err = @@ -460,40 +446,33 @@ let ifnotfound ?code instrs vh ci p = in Netstring_pcre.string_match re err 0 <> None then - Lwt.return - (Ocsigen_extensions.Ext_sub_result - (Ocsigen_extensions.compose - (List.map (fun i -> i vh ci p) instrs))) - else Lwt.return (Ocsigen_extensions.Ext_next err)) + Ocsigen_extensions.Ext_sub_result + (Ocsigen_extensions.compose (List.map (fun i -> i vh ci p) instrs)) + else Ocsigen_extensions.Ext_next err) let notfound _ _ _ _ = - Lwt.return - (Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.empty, `Not_found)) + Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.empty, `Not_found) let nextsite _ _ _ = function | Ocsigen_extensions.Req_found (_, r) -> - Lwt.return (Ocsigen_extensions.Ext_found_stop (fun () -> Lwt.return r)) + Ocsigen_extensions.Ext_found_stop (fun () -> r) | Ocsigen_extensions.Req_not_found _ -> - Lwt.return - (Ocsigen_extensions.Ext_stop_site (Ocsigen_cookie_map.empty, `Not_found)) + Ocsigen_extensions.Ext_stop_site (Ocsigen_cookie_map.empty, `Not_found) let nexthost _ _ _ = function | Ocsigen_extensions.Req_found (_, r) -> - Lwt.return (Ocsigen_extensions.Ext_found_stop (fun () -> Lwt.return r)) + Ocsigen_extensions.Ext_found_stop (fun () -> r) | Ocsigen_extensions.Req_not_found _ -> - Lwt.return - (Ocsigen_extensions.Ext_stop_host (Ocsigen_cookie_map.empty, `Not_found)) + Ocsigen_extensions.Ext_stop_host (Ocsigen_cookie_map.empty, `Not_found) let stop _ _ _ = function | Ocsigen_extensions.Req_found (_, r) -> - Lwt.return (Ocsigen_extensions.Ext_found_stop (fun () -> Lwt.return r)) + Ocsigen_extensions.Ext_found_stop (fun () -> r) | Ocsigen_extensions.Req_not_found _ -> - Lwt.return - (Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.empty, `Not_found)) + Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.empty, `Not_found) let forbidden _ _ _ _ = - Lwt.return - (Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.empty, `Forbidden)) + Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.empty, `Forbidden) let allow_forward_for ?check_equal_ip () _ _ _ = allow_forward_for_handler ?check_equal_ip () diff --git a/src/extensions/authbasic.ml b/src/extensions/authbasic.ml index f40712d5e..18a2e3974 100644 --- a/src/extensions/authbasic.ml +++ b/src/extensions/authbasic.ml @@ -18,11 +18,9 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Lwt.Infix - let section = Logs.Src.create "ocsigen:ext:access-control" -type auth = string -> string -> bool Lwt.t +type auth = string -> string -> bool exception Bad_config_tag_for_auth of string @@ -46,7 +44,7 @@ let () = let open Xml in register_basic_authentication_method @@ function | Element ("plain", [("login", login); ("password", password)], _) -> - fun l p -> Lwt.return (login = l && password = p) + fun l p -> login = l && password = p | _ -> raise (Ocsigen_extensions.Bad_config_tag_for_extension "not for htpasswd") @@ -57,17 +55,17 @@ let gen ~realm ~auth rs = (Printf.sprintf "Basic realm=\"%s\"" realm) in Logs.info ~src:section (fun fmt -> fmt "AUTH: invalid credentials!"); - Lwt.fail (Ocsigen_cohttp.Ext_http_error (`Unauthorized, None, Some h)) + raise (Ocsigen_cohttp.Ext_http_error (`Unauthorized, None, Some h)) and invalid_header () = Logs.info ~src:section (fun fmt -> fmt "AUTH: invalid Authorization header"); - Lwt.fail + raise (Ocsigen_cohttp.Ocsigen_http_error (Ocsigen_cookie_map.empty, `Bad_request)) 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 () + let b = auth user pass in + if b then Ocsigen_extensions.Ext_next err else reject () | `Other _s -> invalid_header () in match rs with @@ -78,8 +76,7 @@ let gen ~realm ~auth rs = with | Some s -> validate ~err s | None -> reject ()) - | Ocsigen_extensions.Req_found _ -> - Lwt.return Ocsigen_extensions.Ext_do_nothing + | Ocsigen_extensions.Req_found _ -> Ocsigen_extensions.Ext_do_nothing let parse_config element = let realm_ref = ref "" in diff --git a/src/extensions/authbasic.mli b/src/extensions/authbasic.mli index b50d3b280..adc280f67 100644 --- a/src/extensions/authbasic.mli +++ b/src/extensions/authbasic.mli @@ -58,7 +58,7 @@ let _ = val section : Logs.src -type auth = string -> string -> bool Lwt.t +type auth = string -> string -> bool val register_basic_authentication_method : (Xml.xml -> auth) -> unit (** This function registers an authentication plugin: it adds a new diff --git a/src/extensions/cors.ml b/src/extensions/cors.ml index a6307a250..96c2822b9 100644 --- a/src/extensions/cors.ml +++ b/src/extensions/cors.ml @@ -38,7 +38,7 @@ exception Refused let add_headers config r response = match Ocsigen_request.header r Ocsigen_header.Name.origin with - | None -> Lwt.return Ocsigen_extensions.Ext_do_nothing + | None -> Ocsigen_extensions.Ext_do_nothing | Some origin -> Logs.info ~src:section (fun fmt -> fmt "request with origin: %s" origin); let l = [Ocsigen_header.Name.access_control_allow_origin, origin] in @@ -94,9 +94,8 @@ let add_headers config r response = , String.concat ", " exposed_headers ) :: l in - Lwt.return - (Ocsigen_extensions.Ext_found - (fun () -> Lwt.return @@ Ocsigen_response.replace_headers response l)) + Ocsigen_extensions.Ext_found + (fun () -> Ocsigen_response.replace_headers response l) let main config = function | Ocsigen_extensions.Req_not_found (_, {Ocsigen_extensions.request_info; _}) @@ -107,8 +106,8 @@ let main config = function try add_headers config request_info (default_frame ()) with Refused -> Logs.info ~src:section (fun fmt -> fmt "Refused request"); - Lwt.return Ocsigen_extensions.Ext_do_nothing) - | _ -> Lwt.return Ocsigen_extensions.Ext_do_nothing) + Ocsigen_extensions.Ext_do_nothing) + | _ -> Ocsigen_extensions.Ext_do_nothing) | Ocsigen_extensions.Req_found ({Ocsigen_extensions.request_info; _}, response) -> Logs.info ~src:section (fun fmt -> fmt "answered request"); diff --git a/src/extensions/deflatemod.ml b/src/extensions/deflatemod.ml index 2ca4adfe5..80e26e351 100644 --- a/src/extensions/deflatemod.ml +++ b/src/extensions/deflatemod.ml @@ -20,8 +20,6 @@ (* Compress output sent by the server *) -open Lwt.Infix - let section = Logs.Src.create "ocsigen:ext:deflate" (* Content-type *) @@ -59,7 +57,7 @@ let gzip_header = type output_buffer = { stream : Zlib.stream ; buf : bytes - ; flush : string -> unit Lwt.t + ; flush : string -> unit ; mutable size : int32 ; mutable crc : int32 } @@ -71,9 +69,7 @@ let write_int32 buf offset n = let compress_flush oz used_out = Logs.debug ~src:section (fun fmt -> fmt "Flushing %d bytes" used_out); - if used_out > 0 - then oz.flush (Bytes.sub_string oz.buf 0 used_out) - else Lwt.return_unit + if used_out > 0 then oz.flush (Bytes.sub_string oz.buf 0 used_out) else () (* gzip trailer *) let write_trailer oz = @@ -84,7 +80,7 @@ let write_trailer oz = (* puts in oz the content of buf, from pos to pos + len ; *) let rec compress_output oz inbuf pos len = if len = 0 - then Lwt.return_unit + then () else let (_ : bool), used_in, used_out = try @@ -95,7 +91,7 @@ let rec compress_output oz inbuf pos len = (Ocsigen_stream.Stream_error ("Error during compression: " ^ s ^ " " ^ s')) in - compress_flush oz used_out >>= fun () -> + compress_flush oz used_out; compress_output oz inbuf (pos + used_in) (len - used_in) let rec compress_finish oz = @@ -105,8 +101,8 @@ let rec compress_finish oz = Zlib.deflate oz.stream oz.buf 0 0 oz.buf 0 (Bytes.length oz.buf) Zlib.Z_FINISH in - compress_flush oz used_out >>= fun () -> - if not finished then compress_finish oz else Lwt.return_unit + compress_flush oz used_out; + if not finished then compress_finish oz else () (* deflate param : true = deflate ; false = gzip (no header in this case) *) let compress_body deflate body = @@ -120,22 +116,20 @@ let compress_body deflate body = ; size = 0l ; crc = 0l } in - (if deflate then Lwt.return_unit else flush gzip_header) >>= fun () -> + if deflate then () else flush gzip_header; body (fun inbuf -> let len = String.length inbuf in oz.size <- Int32.add oz.size (Int32.of_int len); oz.crc <- Zlib.update_crc_string oz.crc inbuf 0 len; - compress_output oz inbuf 0 len) - >>= fun () -> - compress_finish oz >>= fun () -> - (if deflate then Lwt.return_unit else write_trailer oz) >>= fun () -> + compress_output oz inbuf 0 len); + compress_finish oz; + if deflate then () else write_trailer oz; Logs.debug ~src:section (fun fmt -> fmt "Close stream"); - (try Zlib.deflate_end zstream - with - (* ignore errors, deflate_end cleans everything anyway *) - | Zlib.Error _ -> - ()); - Lwt.return_unit + try Zlib.deflate_end zstream + with + (* ignore errors, deflate_end cleans everything anyway *) + | Zlib.Error _ -> + () (* We implement Content-Encoding, not Transfer-Encoding *) type encoding = Deflate | Gzip | Id | Star | Not_acceptable @@ -188,55 +182,50 @@ let select_encoding accept_header = (* deflate = true -> mode deflate deflate = false -> mode gzip *) let stream_filter contentencoding url deflate choice 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 -> ( - let contenttype = - try String.sub contenttype 0 (String.index contenttype ';') - with Not_found -> contenttype - in - 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 = - let response = Ocsigen_response.response res in - 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 -> headers - in - let headers = - Cohttp.Header.replace headers - Ocsigen_header.Name.(to_string content_encoding) - contentencoding - in - { response with - Cohttp.Response.headers - ; Cohttp.Response.encoding = Cohttp.Transfer.Chunked } - and body = - Ocsigen_response.Body.make Cohttp.Transfer.Chunked - (compress_body deflate - (Ocsigen_response.Body.write - (Ocsigen_response.body res))) - in - Lwt.return (Ocsigen_response.update res ~body ~response) - | _ -> Lwt.return res) - with Not_found -> Lwt.return res)) + Ocsigen_extensions.Ext_found + (fun () -> + try + match Ocsigen_response.header res Ocsigen_header.Name.content_type with + | None -> res + | Some contenttype -> ( + let contenttype = + try String.sub contenttype 0 (String.index contenttype ';') + with Not_found -> contenttype + in + match Ocsigen_header.Mime_type.parse contenttype with + | None, _ | _, None -> res + | Some a, Some b when should_compress (a, b) url choice -> + let response = + let {Http.Response.headers; status; version} = + Ocsigen_response.response res + 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 -> headers + in + let headers = + Http.Header.replace headers + Ocsigen_header.Name.(to_string content_encoding) + contentencoding + in + Http.Response.make ~headers ~status ~version () + and body = + Ocsigen_response.Body.make Cohttp.Transfer.Chunked + (compress_body deflate + (Ocsigen_response.Body.write (Ocsigen_response.body res))) + in + Ocsigen_response.update res ~body ~response + | _ -> res) + with Not_found -> res) let filter choice_list = function | Ocsigen_extensions.Req_not_found (code, _) -> - Lwt.return (Ocsigen_extensions.Ext_next code) + Ocsigen_extensions.Ext_next code | Ocsigen_extensions.Req_found ({Ocsigen_extensions.request_info = ri; _}, res) -> ( match @@ -251,12 +240,10 @@ let filter choice_list = function 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)) + | Id | Star -> Ocsigen_extensions.Ext_found (fun () -> res) | Not_acceptable -> - Lwt.return - (Ocsigen_extensions.Ext_stop_all - (Ocsigen_response.cookies res, `Not_acceptable))) + Ocsigen_extensions.Ext_stop_all + (Ocsigen_response.cookies res, `Not_acceptable)) let rec parse_global_config = function | [] -> () diff --git a/src/extensions/extendconfiguration.ml b/src/extensions/extendconfiguration.ml index 7781a9c00..3b0be5a3d 100644 --- a/src/extensions/extendconfiguration.ml +++ b/src/extensions/extendconfiguration.ml @@ -22,8 +22,7 @@ let name = "extendconfiguration" 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_found _ -> Ocsigen_extensions.Ext_do_nothing | Ocsigen_extensions.Req_not_found (err, ({Ocsigen_extensions.request_config; _} as request)) -> Logs.info (fun fmt -> fmt "Updating configuration"); @@ -31,9 +30,8 @@ let gen configfun = function { request with Ocsigen_extensions.request_config = configfun request_config } in - Lwt.return - (Ocsigen_extensions.Ext_continue_with - (request, Ocsigen_cookie_map.empty, err)) + Ocsigen_extensions.Ext_continue_with + (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/outputfilter.ml b/src/extensions/outputfilter.ml index 03bcdd4b9..0d9cc0e66 100644 --- a/src/extensions/outputfilter.ml +++ b/src/extensions/outputfilter.ml @@ -22,39 +22,35 @@ let gen filter = function | Ocsigen_extensions.Req_not_found (code, _) -> - Lwt.return (Ocsigen_extensions.Ext_next code) + 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, regexp, dest) -> ( - try - let l = - List.map - (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 - with Not_found -> res) - | `Add (header, dest, replace) -> ( - match replace with - | None -> ( - match Ocsigen_response.header res header with - | Some _ -> res - | None -> Ocsigen_response.add_header res header dest) - | Some false -> Ocsigen_response.add_header res header dest - | Some true -> Ocsigen_response.replace_header res header dest)) + Ocsigen_extensions.Ext_found + (fun () -> + match filter with + | `Rewrite (header, regexp, dest) -> ( + try + let l = + List.map + (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 + with Not_found -> res) + | `Add (header, dest, replace) -> ( + match replace with + | None -> ( + match Ocsigen_response.header res header with + | Some _ -> res + | None -> Ocsigen_response.add_header res header dest) + | Some false -> Ocsigen_response.add_header res header dest + | Some true -> 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.Ext_next code | Ocsigen_extensions.Req_found (_ri, res) -> - Lwt.return - @@ Ocsigen_extensions.Ext_found - (fun () -> Lwt.return (Ocsigen_response.set_status res code)) + Ocsigen_extensions.Ext_found + (fun () -> 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 8aed99c9f..21e8cfec1 100644 --- a/src/extensions/redirectmod.ml +++ b/src/extensions/redirectmod.ml @@ -39,25 +39,22 @@ let attempt_redir {r_regexp; r_dest; r_full; r_temp} _err ri () = fmt "YES! %s redirection to: %s" (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 r_temp then `Found else `Moved_permanently in - Cohttp.Response.make ~status ~headers ()) + Ocsigen_extensions.Ext_found + (fun () -> + Ocsigen_response.make + @@ + let headers = Cohttp.Header.(init_with "Location" redir) + 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 *) let gen dir = function - | Ocsigen_extensions.Req_found _ -> - Lwt.return Ocsigen_extensions.Ext_do_nothing + | Ocsigen_extensions.Req_found _ -> Ocsigen_extensions.Ext_do_nothing | 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) - | e -> Lwt.fail e) + try (attempt_redir dir err request_info) () with + | Ocsigen_extensions.Not_concerned -> Ocsigen_extensions.Ext_next err + | e -> raise e) let parse_config config_elem = let regexp = ref None diff --git a/src/extensions/revproxy.ml b/src/extensions/revproxy.ml index 1ad47fa42..2330172bc 100644 --- a/src/extensions/revproxy.ml +++ b/src/extensions/revproxy.ml @@ -22,7 +22,7 @@ The reverse proxy is still experimental. *) -open Lwt.Infix +open Eio.Std module Pcre = Re.Pcre let section = Logs.Src.create "ocsigen:ext:revproxy" @@ -47,101 +47,101 @@ let create_redirection (** Generate the pages from the request *) let gen dir = function - | Ocsigen_extensions.Req_found _ -> - Lwt.return Ocsigen_extensions.Ext_do_nothing + | Ocsigen_extensions.Req_found _ -> Ocsigen_extensions.Ext_do_nothing | Ocsigen_extensions.Req_not_found (err, {Ocsigen_extensions.request_info; _}) - -> - Lwt.catch - (* Is it a redirection? *) - (fun () -> - Logs.info ~src:section (fun fmt -> fmt "Is it a redirection?"); - let dest = - Ocsigen_extensions.find_redirection dir.regexp dir.full_url - dir.dest request_info - in - let https, host, port, path = - try - (* FIXME: we do not seem to handle GET + -> ( + try + (* Is it a redirection? *) + Logs.info ~src:section (fun fmt -> fmt "Is it a redirection?"); + let dest = + Ocsigen_extensions.find_redirection dir.regexp dir.full_url dir.dest + request_info + in + 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, path, _, _, _ -> - let port = - match port with - | None -> if https then 443 else 80 - | Some p -> p - in - https, host, port, path - | _ -> - raise - (Ocsigen_extensions.Error_in_config_file - ("Revproxy : error in destination URL " ^ dest)) - (*VVV catch only URL-related exceptions? *) - with e -> - raise - (Ocsigen_extensions.Error_in_config_file - ("Revproxy : error in destination URL " ^ dest ^ " - " - ^ Printexc.to_string e)) - in - Logs.info ~src:section (fun fmt -> - fmt "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 -> - (* It is now safe to start processing next request. + match Ocsigen_lib.Url.parse dest with + | 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, path + | _ -> + raise + (Ocsigen_extensions.Error_in_config_file + ("Revproxy : error in destination URL " ^ dest)) + (*VVV catch only URL-related exceptions? *) + with e -> + raise + (Ocsigen_extensions.Error_in_config_file + ("Revproxy : error in destination URL " ^ dest ^ " - " + ^ Printexc.to_string e)) + in + Logs.info ~src:section (fun fmt -> + fmt "YES! Redirection to http%s://%s:%d/%s" + (if https then "s" else "") + host port path); + let _inet_addr = Ocsigen_lib.Ip_address.get_inet_addr host in + (* It is now safe to start processing next request. We are sure that the request won't be taken in disorder, so we return. *) - let do_request () = - let headers = - let h = - Cohttp.Request.headers (Ocsigen_request.to_cohttp request_info) - in - let h = - Ocsigen_request.version request_info - |> Cohttp.Code.string_of_version - |> Cohttp.Header.replace h - Ocsigen_header.Name.(to_string x_forwarded_proto) - in - let h = - let forward = - let address = - Ocsigen_config.Socket_type.to_string - (Ocsigen_request.address request_info) - in - String.concat ", " - (Ocsigen_request.remote_ip request_info - :: Ocsigen_request.forward_ip request_info - @ [address]) - in - Cohttp.Header.replace h - Ocsigen_header.Name.(to_string x_forwarded_for) - forward - in - Cohttp.Header.remove h Ocsigen_header.Name.(to_string host) - 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 - Cohttp_lwt_unix.Client.call ~headers ~body meth uri - in - Lwt.return - @@ Ocsigen_extensions.Ext_found - (fun () -> do_request () >|= Ocsigen_response.of_cohttp)) - (function - | Ocsigen_extensions.Not_concerned -> - Lwt.return (Ocsigen_extensions.Ext_next err) - | e -> Lwt.fail e) + let do_request () = + let headers = + let h = + Cohttp.Request.headers (Ocsigen_request.to_cohttp request_info) + in + let h = + Ocsigen_request.version request_info + |> Cohttp.Code.string_of_version + |> Cohttp.Header.replace h + Ocsigen_header.Name.(to_string x_forwarded_proto) + in + let h = + let forward = + let address = + Ocsigen_config.Socket_type.to_string + (Ocsigen_request.address request_info) + in + String.concat ", " + (Ocsigen_request.remote_ip request_info + :: Ocsigen_request.forward_ip request_info + @ [address]) + in + Cohttp.Header.replace h + Ocsigen_header.Name.(to_string x_forwarded_for) + forward + in + Cohttp.Header.remove h Ocsigen_header.Name.(to_string host) + 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 + let sw = Stdlib.Option.get (Fiber.get Ocsigen_lib.current_switch) in + let env = Stdlib.Option.get (Fiber.get Ocsigen_lib.env) in + let client = + (* TODO: Https not supported out of the box in [Cohttp_eio]. *) + Cohttp_eio.Client.make ~https:None env#net + in + Cohttp_eio.Client.call client ~sw ~headers ~body meth uri + in + Ocsigen_extensions.Ext_found + (fun () -> Ocsigen_response.of_cohttp (do_request ())) + with + | Ocsigen_extensions.Not_concerned -> Ocsigen_extensions.Ext_next err + | e -> raise e) let parse_config config_elem = let regexp = ref None in diff --git a/src/extensions/rewritemod.ml b/src/extensions/rewritemod.ml index bed91c876..a604773d7 100644 --- a/src/extensions/rewritemod.ml +++ b/src/extensions/rewritemod.ml @@ -48,9 +48,8 @@ let find_rewrite (Regexp (regexp, dest, fullrewrite)) suburl = (* 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) -> + | Ocsigen_extensions.Req_found _ -> Ocsigen_extensions.Ext_do_nothing + | Ocsigen_extensions.Req_not_found (err, ri) -> ( let try_block () = Logs.info ~src:section (fun fmt -> fmt "Is it a rewrite?"); let redir, full_rewrite = @@ -63,30 +62,27 @@ let gen regexp continue = function Logs.info ~src:section (fun fmt -> fmt "YES! rewrite to: %s" redir); if continue then - Lwt.return - @@ Ocsigen_extensions.Ext_continue_with - ( { ri with - Ocsigen_extensions.request_info = - Ocsigen_request.update ~full_rewrite - ~uri:(Uri.of_string redir) - ri.Ocsigen_extensions.request_info } - , Ocsigen_cookie_map.empty - , err ) + Ocsigen_extensions.Ext_continue_with + ( { ri with + Ocsigen_extensions.request_info = + Ocsigen_request.update ~full_rewrite + ~uri:(Uri.of_string redir) + ri.Ocsigen_extensions.request_info } + , Ocsigen_cookie_map.empty + , err ) else - Lwt.return - @@ Ocsigen_extensions.Ext_retry_with - ( { ri with - Ocsigen_extensions.request_info = - Ocsigen_request.update ~full_rewrite - ~uri:(Uri.of_string redir) - ri.Ocsigen_extensions.request_info } - , Ocsigen_cookie_map.empty ) + Ocsigen_extensions.Ext_retry_with + ( { ri with + Ocsigen_extensions.request_info = + Ocsigen_request.update ~full_rewrite + ~uri:(Uri.of_string redir) + ri.Ocsigen_extensions.request_info } + , Ocsigen_cookie_map.empty ) and catch_block = function - | Ocsigen_extensions.Not_concerned -> - Lwt.return (Ocsigen_extensions.Ext_next err) - | e -> Lwt.fail e + | Ocsigen_extensions.Not_concerned -> Ocsigen_extensions.Ext_next err + | e -> raise e in - Lwt.catch try_block catch_block + try try_block () with v -> catch_block v) let parse_config element = let regexp = ref "" in diff --git a/src/extensions/staticmod.ml b/src/extensions/staticmod.ml index dd2c6e632..358d65071 100644 --- a/src/extensions/staticmod.ml +++ b/src/extensions/staticmod.ml @@ -18,7 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Lwt.Infix module Pcre = Re.Pcre let name = "staticmod" @@ -123,10 +122,9 @@ let find_static_page "Staticmod: cannot use '..' in user paths") let gen ~usermode ?cache dir = function - | Ocsigen_extensions.Req_found _ -> - Lwt.return Ocsigen_extensions.Ext_do_nothing + | Ocsigen_extensions.Req_found _ -> Ocsigen_extensions.Ext_do_nothing | Ocsigen_extensions.Req_not_found - (err, ({Ocsigen_extensions.request_info; _} as request)) -> + (err, ({Ocsigen_extensions.request_info; _} as request)) -> ( let try_block () = Logs.info ~src:section (fun fmt -> fmt "Is it a static file?"); let status_filter, page = @@ -142,8 +140,7 @@ let gen ~usermode ?cache dir = function | Ocsigen_local_files.RDir _ -> failwith "FIXME: staticmod dirs not implemented" in - Cohttp_lwt_unix.Server.respond_file ~fname () >>= fun answer -> - let answer = Ocsigen_response.of_cohttp answer in + let answer = Ocsigen_response.respond_file fname in let answer = if not status_filter then answer @@ -165,20 +162,20 @@ let gen ~usermode ?cache dir = function [ Ocsigen_header.Name.cache_control, cache_control ; Ocsigen_header.Name.expires, expires ] in - Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return answer)) + Ocsigen_extensions.Ext_found (fun () -> answer) and catch_block = function | Ocsigen_local_files.Failed_403 -> - Lwt.return (Ocsigen_extensions.Ext_next `Forbidden) + Ocsigen_extensions.Ext_next `Forbidden (* XXX We should try to leave an information about this error for later *) | Ocsigen_local_files.NotReadableDirectory -> - Lwt.return (Ocsigen_extensions.Ext_next err) + 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 + Ocsigen_extensions.Ext_next err + | e -> raise e in - Lwt.catch try_block catch_block + try try_block () with v -> catch_block v) (*****************************************************************************) (** Parsing of config file *) diff --git a/src/extensions/userconf.ml b/src/extensions/userconf.ml index 54033c2d5..ea882258d 100644 --- a/src/extensions/userconf.ml +++ b/src/extensions/userconf.ml @@ -20,8 +20,6 @@ (* Local (users) config files *) -open Lwt.Infix - exception NoConfFile let section = Logs.Src.create "ocsigen:ext:userconf" @@ -36,57 +34,53 @@ let handle_parsing_error {Ocsigen_extensions.request_info; _} = function fmt "Syntax error in userconf configuration file for url %s: %s" (Uri.to_string (Ocsigen_request.uri request_info)) s); - Lwt.return err_500 + err_500 | Ocsigen_extensions.Error_in_user_config_file s -> Logs.err ~src:section (fun fmt -> fmt "Unauthorized option in user configuration for url %s: %s" (Uri.to_string (Ocsigen_request.uri request_info)) s); - Lwt.return err_500 - | e -> Lwt.fail e + err_500 + | e -> raise e (* Answer returned by userconf when the url matches *) let subresult new_req user_parse_site conf previous_err req req_state = 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 + try + let answer, cookies = + (* XXX why is rs above never used ?? *) + user_parse_site conf cookies_to_set + (Ocsigen_extensions.Req_not_found (previous_err, new_req)) + in + (* 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_cookie_map.empty))) + let rec aux ((answer, cts) as r) = + match answer with + | Ocsigen_extensions.Ext_sub_result sr -> + aux + (* XXX Are these the good cookies ?? *) + (sr cookies_to_set req_state) + | Ocsigen_extensions.Ext_continue_with + ({Ocsigen_extensions.request_config; _}, cookies, err) -> + ( 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! *) + ( Ocsigen_extensions.Ext_found_continue_with + (fun () -> + let r, {Ocsigen_extensions.request_config; _} = r () in + r, {req with Ocsigen_extensions.request_config}) + , cts ) + | _ -> r + in + aux (answer, cookies) + with e -> + let answer = handle_parsing_error req e in + answer, Ocsigen_cookie_map.empty) let conf_to_xml conf = try [Xml.parse_file conf] with @@ -101,13 +95,13 @@ let conf_to_xml conf = 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 Ocsigen_extensions.Ext_do_nothing + 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 Ocsigen_lib.Netstring_pcre.string_match regexp path 0 with - | None -> Lwt.return (Ocsigen_extensions.Ext_next previous_err) + | None -> Ocsigen_extensions.Ext_next previous_err | Some _ -> ( try Logs.info ~src:section (fun fmt -> fmt "Using user configuration"); @@ -135,13 +129,12 @@ let gen hostpattern sitepath (regexp, conf, url, prefix, localpath) = function Ocsigen_extensions.request_info = Ocsigen_request.update ~uri request_info } in - Lwt.return - (subresult req user_parse_site conf previous_err req req_state) + 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) + Ocsigen_extensions.Ext_next previous_err | e -> handle_parsing_error req e)) let parse_config _ hostpattern _ path _ _ config_elem = diff --git a/src/files/ocsigenserver.conf/gen.ml b/src/files/ocsigenserver.conf/gen.ml index c2e58f68c..8b9eef079 100644 --- a/src/files/ocsigenserver.conf/gen.ml +++ b/src/files/ocsigenserver.conf/gen.ml @@ -84,7 +84,7 @@ let deps () = ; "ocsigenserver" ] in let packages = - "lwt_ssl,bytes,lwt.unix,logs,logs-syslog.unix,syslog-message,ipaddr,findlib,cryptokit,re,str,xml-light,dynlink,cohttp-lwt-unix,http" + "bytes,logs,logs-syslog.unix,syslog-message,ipaddr,findlib,cryptokit,re,str,xml-light,dynlink,cohttp-eio,http,eio,eio_main,ipaddr.unix,magic-mime" in let deps = ref [] in let cmd = "ocamlfind query -p-format -recursive " ^ packages in diff --git a/src/http/dune b/src/http/dune index e46e06e91..c66822dd5 100644 --- a/src/http/dune +++ b/src/http/dune @@ -9,4 +9,4 @@ (public_name ocsigenserver.http) (wrapped false) (modules ocsigen_charset_mime ocsigen_header) - (libraries cohttp-lwt-unix baselib logs)) + (libraries cohttp-eio baselib logs)) diff --git a/src/server/dune b/src/server/dune index 0f316372c..803f744b1 100644 --- a/src/server/dune +++ b/src/server/dune @@ -4,7 +4,7 @@ (wrapped false) (libraries xml-light - cohttp-lwt-unix + cohttp-eio http polytables ocsigen_cookie_map @@ -12,4 +12,9 @@ ocsigen_http logs logs-syslog.unix - syslog-message)) + syslog-message + eio + ipaddr + ipaddr.unix + magic-mime + eio_main)) diff --git a/src/server/ocsigen_cohttp.ml b/src/server/ocsigen_cohttp.ml index c0e79fed5..94f59aa91 100644 --- a/src/server/ocsigen_cohttp.ml +++ b/src/server/ocsigen_cohttp.ml @@ -1,4 +1,4 @@ -open Lwt.Infix +open Eio.Std let section = Logs.Src.create "ocsigen:cohttp" @@ -54,31 +54,31 @@ module Cookie = struct Ocsigen_cookie_map.Map_path.fold serialize_cookies cookies headers end -let handler ~ssl ~address ~port ~connector (flow, conn) request body = +(* TODO: Use [_conn_sw] for nested concurrency *) +let handler + ~ssl + ~address + ~port + ~connector + ((_conn_sw, eio_stream), conn) + request + body + = 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") + let sockaddr = + match eio_stream with + | `Unix s -> "unix://" ^ s + | `Tcp (ip, _port) -> (ip : _ Eio.Net.Ipaddr.t :> string) in - let sockaddr = getsockname edn in let connection_closed = try fst (Hashtbl.find connections conn) with Not_found -> - let ((connection_closed, _) as p) = Lwt.wait () in + let ((connection_closed, _) as p) = Promise.create () in Hashtbl.add connections conn p; incr_connected (); connection_closed in let handle_error exn = - Logs.debug ~src:section (fun fmt -> - fmt - ("Got exception while handling request." ^^ "@\n%s") - (Printexc.to_string exn)); let headers, ret_code = match exn with | Ocsigen_http_error (cookies_to_set, code) -> @@ -94,9 +94,7 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body = | Ocsigen_lib.Ocsigen_Request_too_long -> None, `Request_entity_too_large | exn -> Logs.err ~src:section (fun fmt -> - fmt - ("Error while handling request." ^^ "@\n%s") - (Printexc.to_string exn)); + fmt "Error while handling request.@\n%a" Eio.Exn.pp exn); None, `Internal_server_error in let body = @@ -113,7 +111,17 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body = Ocsigen_request.make ~address ~port ~ssl ~filenames ~sockaddr ~body ~connection_closed request in - Lwt.finalize + Fun.protect + ~finally:(fun () -> + if !filenames <> [] + then + List.iter + (fun a -> + try Unix.unlink a + with Unix.Unix_error _ as exn -> + Logs.warn ~src:section (fun fmt -> + fmt "Error while removing file %s@\n%a" a Eio.Exn.pp exn)) + !filenames) (fun () -> Ocsigen_messages.accesslog (Format.sprintf "connection for %s from %s (%s)%s: %s" @@ -128,53 +136,39 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body = (Ocsigen_request.header request Ocsigen_header.Name.x_forwarded_for)) (Uri.path (Ocsigen_request.uri request))); - Lwt.catch - (fun () -> connector request) - (function - | Ocsigen_is_dir fun_request -> - let headers = - fun_request request |> Uri.to_string - |> Cohttp.Header.init_with "location" - and status = `Moved_permanently in - Lwt.return - (Ocsigen_response.respond_string ~headers ~status ~body:"" ()) - | exn -> Lwt.return (handle_error exn)) - >>= fun response -> - Lwt.return (Ocsigen_response.to_response_expert response)) - (fun () -> - if !filenames <> [] - then - List.iter - (fun a -> - try Unix.unlink a - with Unix.Unix_error _ as exn -> - Logs.warn ~src:section (fun fmt -> - fmt - ("Error while removing file %s" ^^ "@\n%s") - a (Printexc.to_string exn))) - !filenames; - Lwt.return_unit) + let response = + try connector request with + | Ocsigen_is_dir fun_request -> + let headers = + fun_request request |> Uri.to_string + |> Cohttp.Header.init_with "location" + and status = `Moved_permanently in + Ocsigen_response.respond_string ~headers ~status ~body:"" () + | exn -> handle_error exn + in + Ocsigen_response.to_response_expert response) let conn_closed (_flow, conn) = try - Logs.debug ~src:section (fun fmt -> - fmt "Connection closed:\n%s" (Cohttp.Connection.to_string conn)); - Lwt.wakeup (snd (Hashtbl.find connections conn)) (); + Promise.resolve (snd (Hashtbl.find connections conn)) (); Hashtbl.remove connections conn; decr_connected () with Not_found -> () -let stop, stop_wakener = Lwt.wait () +let stop, stop_wakener = Promise.create () let shutdown timeout = let process = match timeout with - | Some f -> fun () -> Lwt_unix.sleep f - | None -> fun () -> Lwt.return () + | Some f -> fun () -> Eio_unix.sleep f + | None -> fun () -> () in - ignore (Lwt.pick [process (); stop] >>= fun () -> exit 0 : unit Lwt.t) + ignore + (Fiber.any [process; (fun () -> Promise.await stop)]; + exit 0 + : unit Promise.t) -let service ?ssl ~address ~port ~connector () = +let service ?ssl ~address ~port ~connector ~on_error () = let tls_own_key = match ssl with | Some (crt, key, Some password) -> @@ -183,25 +177,23 @@ let service ?ssl ~address ~port ~connector () = `TLS (`Crt_file_path crt, `Key_file_path key, `No_password) | None -> `None in - (* We create a specific context for Conduit and Cohttp. *) - let src = - match address with - | `Unix _ -> None - | _ -> Some (Ocsigen_config.Socket_type.to_string address) - in - Conduit_lwt_unix.init ?src ~tls_own_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 ssl = match ssl with Some _ -> true | None -> false in handler ~ssl ~address ~port ~connector in - let config = Cohttp_lwt_unix.Server.make_expert ~conn_closed ~callback () in - let mode = + let config = Cohttp_eio.Server.make_expert ~conn_closed ~callback () in + let sockaddr = match address, tls_own_key with - | `Unix f, _ -> `Unix_domain_socket (`File f) - | _, `None -> `TCP (`Port port) - | _, `TLS (crt, key, pass) -> `OpenSSL (crt, key, pass, `Port port) + | (`Unix _ as a), _ -> a + | `All, `None -> `Tcp (Eio.Net.Ipaddr.V4.any, port) + | `IPv4 ip, `None -> + `Tcp (Eio.Net.Ipaddr.of_raw (Unix.string_of_inet_addr ip), port) + | _, `None -> `Tcp (Eio.Net.Ipaddr.V4.any, port) + | _, `TLS (_crt, _key, _pass) -> failwith "TLS is not supported" in - Cohttp_lwt_unix.Server.create ~stop ~ctx ~mode config >>= fun () -> - Lwt.return (Lwt.wakeup stop_wakener ()) + let sw = Stdlib.Option.get (Fiber.get Ocsigen_lib.current_switch) in + let env = Stdlib.Option.get (Fiber.get Ocsigen_lib.env) in + let listening_socket = Eio.Net.listen ~sw ~backlog:100 env#net sockaddr in + Cohttp_eio.Server.run ~stop ~on_error listening_socket config; + Promise.resolve stop_wakener () diff --git a/src/server/ocsigen_cohttp.mli b/src/server/ocsigen_cohttp.mli index 6d3a853fb..7375e18d3 100644 --- a/src/server/ocsigen_cohttp.mli +++ b/src/server/ocsigen_cohttp.mli @@ -21,7 +21,8 @@ val service : ?ssl:string * string * (bool -> string) option -> address:Ocsigen_config.socket_type -> port:int - -> connector:(Ocsigen_request.t -> Ocsigen_response.t Lwt.t) + -> connector:(Ocsigen_request.t -> Ocsigen_response.t) + -> on_error:(exn -> unit) + -> unit -> unit - -> unit Lwt.t (** initialize a main loop of http server *) diff --git a/src/server/ocsigen_command.ml b/src/server/ocsigen_command.ml index 1f477d9ea..5f2609362 100644 --- a/src/server/ocsigen_command.ml +++ b/src/server/ocsigen_command.ml @@ -21,18 +21,16 @@ exception Unknown_command let register_command_function, get_command_function = - let command_function = ref (fun ?prefix:_ _ _ -> Lwt.fail Unknown_command) in + let command_function = ref (fun ?prefix:_ _ _ -> raise Unknown_command) in ( (fun ?prefix f -> let prefix' = prefix in let old_command_function = !command_function in command_function := fun ?prefix s c -> - Lwt.catch - (fun () -> old_command_function ?prefix s c) - (function - | Unknown_command -> - if prefix = prefix' then f s c else Lwt.fail Unknown_command - | e -> Lwt.fail e)) + try old_command_function ?prefix s c with + | Unknown_command -> + if prefix = prefix' then f s c else raise Unknown_command + | e -> raise e) , fun () -> !command_function ) let () = diff --git a/src/server/ocsigen_command.mli b/src/server/ocsigen_command.mli index 81603782d..5d93308d3 100644 --- a/src/server/ocsigen_command.mli +++ b/src/server/ocsigen_command.mli @@ -24,7 +24,7 @@ exception Unknown_command val register_command_function : ?prefix:string - -> (string -> string list -> unit Lwt.t) + -> (string -> string list -> unit) -> unit (** Use a prefix for all your commands when you want to create extension-specific commands. @@ -44,4 +44,4 @@ val get_command_function : -> ?prefix:string -> string -> string list - -> unit Lwt.t + -> unit diff --git a/src/server/ocsigen_extensions.ml b/src/server/ocsigen_extensions.ml index 3a4e8aa0a..f5112f356 100644 --- a/src/server/ocsigen_extensions.ml +++ b/src/server/ocsigen_extensions.ml @@ -20,7 +20,6 @@ let section = Logs.Src.create "ocsigen:ext" -open Lwt.Infix module Pcre = Re.Pcre module Url = Ocsigen_lib.Url include Ocsigen_command @@ -187,7 +186,7 @@ exception Ocsigen_is_dir = Ocsigen_cohttp.Ocsigen_is_dir type answer = | Ext_do_nothing (** I don't want to do anything *) - | Ext_found of (unit -> Ocsigen_response.t Lwt.t) + | Ext_found of (unit -> Ocsigen_response.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 @@ -197,7 +196,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_response.t Lwt.t) + | Ext_found_stop of (unit -> Ocsigen_response.t) (** Found but do not try next extensions *) | Ext_next of Cohttp.Code.status (** Page not found. Try next extension. The status is usually @@ -239,7 +238,7 @@ type answer = parsing the configuration file, call the parsing function (of type [parse_fun]), that will return something of type [extension_composite]. *) - | Ext_found_continue_with of (unit -> (Ocsigen_response.t * request) Lwt.t) + | Ext_found_continue_with of (unit -> Ocsigen_response.t * request) (** Same as [Ext_found] but may modify the request. *) | Ext_found_continue_with' of (Ocsigen_response.t * request) (** Same as [Ext_found_continue_with] but does not allow to delay @@ -251,9 +250,9 @@ and request_state = | Req_found of (request * Ocsigen_response.t) and extension_composite = - Ocsigen_cookie_map.t -> request_state -> (answer * Ocsigen_cookie_map.t) Lwt.t + Ocsigen_cookie_map.t -> request_state -> answer * Ocsigen_cookie_map.t -type extension = request_state -> answer Lwt.t +type extension = request_state -> answer type parse_fun = Xml.xml list -> extension_composite type parse_host = @@ -324,20 +323,18 @@ let site_match request (site_path : string list) url = 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_found (ri, res) -> Ext_found_continue_with' (res, ri), cookies_to_set | Req_not_found (e, ri) -> - Lwt.return - (Ext_continue_with (ri, Ocsigen_cookie_map.empty, e), cookies_to_set) + Ext_continue_with (ri, Ocsigen_cookie_map.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 res = f req_state in let rec aux cookies_to_set = function | Ext_do_nothing -> g cookies_to_set req_state | Ext_found r -> - r () >>= fun r' -> + let r' = r () in let ri = match req_state with | Req_found (ri, _) -> ri @@ -346,7 +343,7 @@ let compose_step (f : extension) (g : extension_composite) : extension_composite 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) -> + let r', req = r () in g Ocsigen_cookie_map.empty (Req_found (req, Ocsigen_response.add_cookies r' cookies_to_set)) | Ext_found_continue_with' (r', req) -> @@ -365,9 +362,9 @@ let compose_step (f : extension) (g : extension_composite) : extension_composite (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) + res, cookies_to_set | Ext_sub_result sr -> - sr cookies_to_set req_state >>= fun (res, cookies_to_set) -> + let res, cookies_to_set = sr cookies_to_set req_state in aux cookies_to_set res in aux cookies_to_set res @@ -433,8 +430,7 @@ let make_parse_config path parse_host l : extension_composite = !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_found (ri, res) -> Ext_found_continue_with' (res, ri), cookies_to_set | Req_not_found (e, oldri) -> ( let oldri = match charset with @@ -454,7 +450,7 @@ let site_ext ext_of_children charset path cookies_to_set = function (Url.string_of_url_path ~encode:true path) (Url.string_of_url_path ~encode:true (Ocsigen_request.path oldri.request_info))); - Lwt.return (Ext_next e, cookies_to_set) + Ext_next e, cookies_to_set | Some sub_path -> ( Logs.info ~src:section (fun fmt -> fmt "site found: url \"%s\" matches \"%s\"." @@ -467,26 +463,24 @@ let site_ext ext_of_children charset path cookies_to_set = function 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 + match ext_of_children cookies_to_set (Req_not_found (e, ri)) with (* 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_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) + let r', _req = r () in + 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_found_continue_with' (r, oldri), cookies_to_set | Ext_do_nothing, cookies_to_set -> - Lwt.return - ( Ext_continue_with (oldri, Ocsigen_cookie_map.empty, e) - , cookies_to_set ) - | r -> Lwt.return r)) + ( Ext_continue_with (oldri, Ocsigen_cookie_map.empty, e) + , cookies_to_set ) + | r -> 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 _ -> - Lwt.return (Ext_sub_result (site_ext ext_of_children charset path)) + | Req_found (ri, r) -> Ext_found_continue_with' (r, ri) + | Req_not_found _ -> 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) @@ -768,26 +762,27 @@ let compute_result ?(previous_cookies = Ocsigen_cookie_map.empty) request_info = in 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)) + | [] -> raise (Ocsigen_http_error (cookies_to_set, prev_err)) | (virtual_hosts, request_config, host_function) :: l when host_match ~virtual_hosts ~host ~port -> ( Logs.info ~src:section (fun fmt -> fmt "host found! %s matches %s" (string_of_host_option host) (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) -> + let res_ext, cookies_to_set = + host_function cookies_to_set + (Req_not_found (prev_err, {request_info; request_config})) + in match res_ext with | Ext_found r | Ext_found_stop r -> - r () >>= fun r' -> - Lwt.return (Ocsigen_response.add_cookies r' cookies_to_set) + let r' = r () in + 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) + let r', _ = r () in + Ocsigen_response.add_cookies r' cookies_to_set | Ext_found_continue_with' (r, _) -> - Lwt.return (Ocsigen_response.add_cookies r cookies_to_set) + 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) -> @@ -796,7 +791,7 @@ let compute_result ?(previous_cookies = Ocsigen_cookie_map.empty) request_info = l (* try next site *) | Ext_stop_all (_cook, e) -> - Lwt.fail (Ocsigen_http_error (cookies_to_set, e)) + raise (Ocsigen_http_error (cookies_to_set, e)) | Ext_continue_with (_, cook, e) -> fold_hosts request_info e (Ocsigen_cookie_map.add_multi cook cookies_to_set) @@ -816,7 +811,7 @@ let compute_result ?(previous_cookies = Ocsigen_cookie_map.empty) request_info = 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 + then raise Ocsigen_Looping_request else fold_hosts request_info `Not_found cookies_to_set sites in fold_hosts_limited (get_hosts ()) previous_cookies request_info diff --git a/src/server/ocsigen_extensions.mli b/src/server/ocsigen_extensions.mli index 1a45c9d6a..b4c848e98 100644 --- a/src/server/ocsigen_extensions.mli +++ b/src/server/ocsigen_extensions.mli @@ -114,7 +114,7 @@ exception Ocsigen_is_dir of (Ocsigen_request.t -> Uri.t) type answer = | Ext_do_nothing (** I don't want to do anything *) - | Ext_found of (unit -> Ocsigen_response.t Lwt.t) + | Ext_found of (unit -> Ocsigen_response.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 @@ -124,7 +124,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_response.t Lwt.t) + | Ext_found_stop of (unit -> Ocsigen_response.t) (** Found but do not try next extensions *) | Ext_next of Cohttp.Code.status (** Page not found. Try next extension. The status is usually @@ -166,7 +166,7 @@ type answer = parsing the configuration file, call the parsing function (of type [parse_fun]), that will return something of type [extension_composite]. *) - | Ext_found_continue_with of (unit -> (Ocsigen_response.t * request) Lwt.t) + | Ext_found_continue_with of (unit -> Ocsigen_response.t * request) (** Same as [Ext_found] but may modify the request. *) | Ext_found_continue_with' of (Ocsigen_response.t * request) (** Same as [Ext_found_continue_with] but does not allow to delay @@ -178,9 +178,9 @@ and request_state = | Req_found of (request * Ocsigen_response.t) and extension_composite = - Ocsigen_cookie_map.t -> request_state -> (answer * Ocsigen_cookie_map.t) Lwt.t + Ocsigen_cookie_map.t -> request_state -> answer * Ocsigen_cookie_map.t -type extension = request_state -> answer Lwt.t +type extension = request_state -> answer (** For each tag in the configuration file, you can set the extensions you want. Each extension is implemented as a function, taking @@ -413,7 +413,7 @@ val get_hosts : unit -> (virtual_hosts * config_info * extension_composite) list val compute_result : ?previous_cookies:Ocsigen_cookie_map.t -> Ocsigen_request.t - -> Ocsigen_response.t Lwt.t + -> Ocsigen_response.t (** Compute the answer to be sent to the client, by trying all extensions according the configuration file. *) diff --git a/src/server/ocsigen_messages.ml b/src/server/ocsigen_messages.ml index ae137cf82..42ed59996 100644 --- a/src/server/ocsigen_messages.ml +++ b/src/server/ocsigen_messages.ml @@ -82,8 +82,7 @@ let open_files () = (fun src level ~over k msgf -> List.fold_left (fun k r () -> r.Logs.report src level ~over k msgf) - k broadcast_reporters ()) }); - Lwt.return () + k broadcast_reporters ()) }) | None -> (* log to files *) let open_channel path = @@ -150,8 +149,7 @@ let open_files () = (fun src level ~over k msgf -> List.fold_left (fun k r () -> r.Logs.report src level ~over k msgf) - k broadcast_reporters ()) }); - Lwt.return () + k broadcast_reporters ()) }) (****) @@ -160,8 +158,7 @@ let errlog ?section s = Logs.err ?src:section (fun fmt -> fmt "%s" s) let warning ?section s = Logs.warn ?src:section (fun fmt -> fmt "%s" s) let unexpected_exception e s = - Logs.warn (fun fmt -> - fmt ("Unexpected exception in %s" ^^ "@\n%s") s (Printexc.to_string e)) + Logs.warn (fun fmt -> fmt "Unexpected exception in %s@\n%a" s Eio.Exn.pp e) (****) @@ -185,15 +182,13 @@ let command_f exc _ = function if a section with the same name already exists, it is returned. *) let sect = Logs.Src.create sect_name in - Logs.Src.set_level sect None; - Lwt.return_unit - | [sect_name; level_name] -> + Logs.Src.set_level sect None + | [sect_name; level_name] -> ( (* Lwt_log.Section.make : if a section with the same name already exists, it is returned. *) let sect = Logs.Src.create sect_name in - (match level_of_string (String.lowercase_ascii level_name) with + match level_of_string (String.lowercase_ascii level_name) with | None -> Logs.Src.set_level sect None - | Some l -> Logs.Src.set_level sect (Some l)); - Lwt.return () - | _ -> Lwt.fail exc + | Some l -> Logs.Src.set_level sect (Some l)) + | _ -> raise exc diff --git a/src/server/ocsigen_messages.mli b/src/server/ocsigen_messages.mli index 6558c5b78..f9a40895d 100644 --- a/src/server/ocsigen_messages.mli +++ b/src/server/ocsigen_messages.mli @@ -45,5 +45,5 @@ val error_log_path : unit -> string (**/**) -val open_files : unit -> unit Lwt.t -val command_f : exn -> string -> string list -> unit Lwt.t +val open_files : unit -> unit +val command_f : exn -> string -> string list -> unit diff --git a/src/server/ocsigen_multipart.ml b/src/server/ocsigen_multipart.ml index 51888ea01..270d0d86c 100644 --- a/src/server/ocsigen_multipart.ml +++ b/src/server/ocsigen_multipart.ml @@ -1,10 +1,11 @@ +open Eio.Std + (* 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 = Ocsigen_lib.Netstring_pcre module Pcre = Re.Pcre @@ -65,85 +66,83 @@ let scan_header 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 + try + 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, match_end r) - | None -> - (* Search for an empty line *) - Lwt.return - (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 _ as s -> find_end_of_header s) - | e -> Lwt.fail e) + match S.string_match empty_line_re b 0 with + | Some r -> s, match_end r + | None -> + (* Search for an empty line *) + s, match_end (snd (S.search_forward end_of_header_re b 0)) + with + | Not_found -> ( + match Ocsigen_stream.enlarge_stream s with + | Ocsigen_stream.Finished _ -> raise Ocsigen_stream.Stream_too_small + | Ocsigen_stream.Cont _ as s -> find_end_of_header s) + | e -> raise e in - find_end_of_header s >>= fun (s, end_pos) -> + let s, end_pos = find_end_of_header s in let b = Ocsigen_stream.current_buffer s in let h, (_ : int) = 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 s = Ocsigen_stream.skip s (Int64.of_int end_pos) in + 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)) + try 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 + match Ocsigen_stream.enlarge_stream s with + | Ocsigen_stream.Finished _ -> raise Ocsigen_stream.Stream_too_small | Ocsigen_stream.Cont _ 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, match_end x)) - (function - | Not_found -> - Lwt.fail - (Multipart_error - "read_multipart_body: MIME boundary without line end") - | e -> Lwt.fail e) + try + let s, x = + (* Search LF beginning at position k *) + search_window s lf_re k + in + s, match_end x + with + | Not_found -> + raise + (Multipart_error "read_multipart_body: MIME boundary without line end") + | e -> raise 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--" ^ Pcre.quote boundary) in - search_window s re 0 >>= fun (s, x) -> Lwt.return (s, match_end x) + let s, x = search_window s re 0 in + 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) + match Ocsigen_stream.stream_want s (ldel + 2) with + | Ocsigen_stream.Finished _ as str2 -> 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) + 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) -> + let a = Ocsigen_stream.substream delimiter s in + let y, s = decode_part a in (* 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 s = Ocsigen_stream.next s in + let s = Ocsigen_stream.stream_want s (l_delimiter + 2) in let last_part = match s with | Ocsigen_stream.Finished _ -> false @@ -154,53 +153,59 @@ let rec parse_parts ~boundary ~decode_part s uses_crlf = && ss.[l_delimiter + 1] = '-' in if last_part - then Lwt.return [y] + then [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 s, k = search_end_of_line s 2 in + let s = + (* [k]: Beginning of next part *) + Ocsigen_stream.skip s (Int64.of_int k) + in + let l = parse_parts ~boundary ~decode_part s uses_crlf in + 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) -> + let s, b, islast = + (* Check whether s directly begins with a boundary *) + check_beginning_is_boundary ~boundary s + in if islast - then Lwt.return [] + then [] else if b then - (* Move to the beginning of the next line *) - search_end_of_line s 0 >>= fun (s, k_eol) -> + let s, k_eol = + (* Move to the beginning of the next line *) + search_end_of_line s 0 + in let uses_crlf = (Ocsigen_stream.current_buffer s).[k_eol - 2] = '\r' in - Ocsigen_stream.skip s (Int64.of_int k_eol) >>= fun s -> + let s = Ocsigen_stream.skip s (Int64.of_int k_eol) in (* 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) + else (* Look for the first boundary *) + try + let s, k_eob = search_first_boundary ~boundary s in + let s, k_eol = search_end_of_line s k_eob in + let uses_crlf = (Ocsigen_stream.current_buffer s).[k_eol - 2] = '\r' in + let s = + (* Printf.printf "k_eol=%d\n" k_eol; *) + Ocsigen_stream.skip s (Int64.of_int k_eol) + in + (* Begin with first part: *) + parse_parts ~boundary ~decode_part s uses_crlf + with + | Not_found -> + (* No boundary at all, empty body *) + [] + | e -> raise 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 s, header = read_header stream in 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.Finished None -> size, empty_stream + | Ocsigen_stream.Finished (Some ss) -> size, ss | Ocsigen_stream.Cont (stri, f) -> let long = String.length stri in let size2 = Int64.add size (Int64.of_int long) in @@ -208,29 +213,33 @@ let decode_part ~max_size ~create ~add ~stop stream = match max_size with | None -> false | Some m -> Int64.compare size2 m > 0 - then Lwt.fail Ocsigen_lib.Ocsigen_Request_too_long + then raise 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 + then (while_stream size) (Ocsigen_stream.next f) + else ( + add p stri; + (while_stream size2) (Ocsigen_stream.next f)) 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) + try + let size, s = while_stream Int64.zero s in + let r = stop size p in + r, s + with error -> + let _ = stop Int64.zero p in + raise 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) + try + let s = + (* read the multipart body: *) + Ocsigen_stream.next s + in + let _ = read_multipart_body ~boundary ~decode_part s in + () + with + | Ocsigen_stream.Stream_too_small -> raise Ocsigen_lib.Ocsigen_Bad_Request + | e -> raise e let get_boundary ctparams = List.assoc "boundary" ctparams @@ -271,26 +280,25 @@ type file_info = 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 - (* BY, adapted from a previous comment. Should this stream be + try + let body = Ocsigen_stream.get body_gen in + let r = + (* 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 - 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 - | e -> Lwt.fail e) + Ocsigen_stream.string_of_stream + (Ocsigen_config.get_maxrequestbodysizeinmemory ()) + body + in + let r = Ocsigen_lib.Url.fixup_url_string r in + let l = + Uri.query_of_encoded r + |> List.map (fun (s, l) -> List.map (fun v -> s, v) l) + |> List.concat + in + l, [] + with + | Ocsigen_stream.String_too_large -> raise Ocsigen_lib.Input_is_too_large + | e -> raise e let post_params_multipart_form_data ctparams body_gen upload_dir max_size = (* Same question here, should this stream be consumed after an @@ -302,14 +310,14 @@ let post_params_multipart_form_data ctparams body_gen upload_dir max_size = and filenames = ref [] in let rec add p s = match p with - | _, `No_file to_buf -> Buffer.add_string to_buf s; Lwt.return () + | _, `No_file to_buf -> Buffer.add_string to_buf s | _, `Some_file (_, _, wh, _) -> let len = String.length s 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)) - else Lwt.pause () + else Fiber.yield () in let create hs = let content_type = @@ -340,8 +348,7 @@ let post_params_multipart_form_data ctparams body_gen upload_dir max_size = 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 () + params := !params @ [p_name, Buffer.contents to_buf] (* in the end ? *) | ( p_name , `Some_file (tmp_filename, raw_original_filename, wh, file_content_type) @@ -350,25 +357,24 @@ let post_params_multipart_form_data ctparams body_gen upload_dir max_size = {tmp_filename; filesize; raw_original_filename; file_content_type} in files := !files @ [p_name, file_info]; - Unix.close wh; - Lwt.return () + Unix.close wh in - scan_multipart_body_from_stream ?max_size ~boundary ~create ~add ~stop body - >>= fun () -> + scan_multipart_body_from_stream ?max_size ~boundary ~create ~add ~stop body; (*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) + Ocsigen_stream.consume body_gen; + !params, !files let post_params ~content_type body_gen = let (ct, cst), ctparams = content_type in match String.lowercase_ascii ct, String.lowercase_ascii cst with | "application", "x-www-form-urlencoded" -> Some - (body_gen |> Cohttp_lwt.Body.to_stream |> Ocsigen_stream.of_lwt_stream + (body_gen |> Ocsigen_stream.of_cohttp_body |> post_params_form_urlencoded) | "multipart", "form-data" -> Some - (body_gen |> Cohttp_lwt.Body.to_stream |> Ocsigen_stream.of_lwt_stream + (body_gen |> Ocsigen_stream.of_cohttp_body |> post_params_multipart_form_data ctparams) | _ -> None diff --git a/src/server/ocsigen_multipart.mli b/src/server/ocsigen_multipart.mli index 65e8d911e..efbef4097 100644 --- a/src/server/ocsigen_multipart.mli +++ b/src/server/ocsigen_multipart.mli @@ -4,10 +4,10 @@ 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) + -> add:('a -> string -> unit) + -> stop:(int64 -> 'a -> 'b) -> string Ocsigen_stream.stream - -> unit Lwt.t + -> unit type content_type = (string * string) * (string * string) list @@ -21,7 +21,7 @@ type post_data = (string * string) list * (string * file_info) list val post_params : content_type:content_type - -> Cohttp_lwt.Body.t - -> (string option -> Int64.t option -> post_data Lwt.t) option + -> Cohttp_eio.Body.t + -> (string option -> Int64.t option -> post_data) option val parse_content_type : string -> content_type option diff --git a/src/server/ocsigen_parseconfig.ml b/src/server/ocsigen_parseconfig.ml index 73cc28320..d2bfed0e3 100644 --- a/src/server/ocsigen_parseconfig.ml +++ b/src/server/ocsigen_parseconfig.ml @@ -405,9 +405,8 @@ let rec later_pass_extconf dir = parse_ext filename with e -> Logs.err ~src:section (fun fmt -> - fmt - ("Error while loading configuration file %s (ignored)" ^^ "@\n%s") - filename (Printexc.to_string e)); + fmt "Error while loading configuration file %s (ignored)@\n%a" + filename Eio.Exn.pp e); [] with | [] -> acc @@ -419,9 +418,7 @@ let rec later_pass_extconf dir = Array.sort compare files; Array.fold_left f [] files with Sys_error _ as e -> Logs.err ~src:section (fun fmt -> - fmt - ("Error while loading configuration file (ignored)" ^^ "@\n%s") - (Printexc.to_string e)); + fmt "Error while loading configuration file (ignored)@\n%a" Eio.Exn.pp e); [] (* Config file is parsed twice. This is the second parsing (site diff --git a/src/server/ocsigen_request.ml b/src/server/ocsigen_request.ml index 040662272..b6c973c08 100644 --- a/src/server/ocsigen_request.ml +++ b/src/server/ocsigen_request.ml @@ -1,4 +1,4 @@ -open Lwt.Infix +open Eio.Std let post_data_of_body ~content_type b = Ocsigen_multipart.post_params ~content_type b @@ -12,7 +12,7 @@ type file_info = Ocsigen_multipart.file_info = ; file_content_type : content_type option } type post_data = Ocsigen_multipart.post_data -type body = [`Unparsed of Cohttp_lwt.Body.t | `Parsed of post_data Lwt.t] +type body = [`Unparsed of Cohttp_eio.Body.t | `Parsed of post_data] (* Wrapper around Uri providing our derived fields. @@ -53,9 +53,7 @@ type t = ; r_port : int ; r_ssl : bool ; r_filenames : string list ref - ; r_sockaddr : Lwt_unix.sockaddr - ; r_remote_ip : string Lazy.t - ; r_remote_ip_parsed : [`Ip of Ipaddr.t | `Unix of string] Lazy.t + ; r_remote_ip : string ; r_forward_ip : string list ; r_uri : uri ; r_meth : Cohttp.Code.meth @@ -68,7 +66,7 @@ type t = ; 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 + ; r_connection_closed : unit Promise.t ; r_timeofday : float } let make @@ -86,26 +84,11 @@ let make ~connection_closed request = - let r_remote_ip = - lazy - (match sockaddr with - | Unix.ADDR_INET (ip, _port) -> Unix.string_of_inet_addr ip - | ADDR_UNIX f -> f) - in - let r_remote_ip_parsed = - lazy - (match sockaddr with - | Unix.ADDR_INET (ip, _port) -> - `Ip (Ipaddr.of_string_exn (Unix.string_of_inet_addr ip)) - | ADDR_UNIX f -> `Unix f) - in { r_address = address ; r_port = port ; r_ssl = ssl ; r_filenames = filenames - ; r_sockaddr = sockaddr - ; r_remote_ip - ; r_remote_ip_parsed + ; r_remote_ip = sockaddr ; r_forward_ip = forward_ip ; r_uri = make_uri (Cohttp.Request.uri request) ; r_encoding = Cohttp.Request.encoding request @@ -140,7 +123,6 @@ let update ; r_meth ; r_forward_ip ; r_remote_ip - ; r_remote_ip_parsed ; r_cookies_override ; r_body ; r_sub_path @@ -150,16 +132,13 @@ let update 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 | None -> r_forward_ip - and r_remote_ip, r_remote_ip_parsed = - match remote_ip with - | Some remote_ip -> - lazy remote_ip, lazy (`Ip (Ipaddr.of_string_exn remote_ip)) - | None -> r_remote_ip, r_remote_ip_parsed + and r_remote_ip = + match remote_ip with Some remote_ip -> remote_ip | None -> r_remote_ip 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) -> ref (`Parsed (Lwt.return post_data)) - | Some None -> ref (`Parsed (Lwt.return ([], []))) + | Some (Some post_data) -> ref (`Parsed post_data) + | Some None -> ref (`Parsed ([], [])) | None -> r_body and r_cookies_override = match cookies_override with @@ -193,7 +172,6 @@ let update ; r_meth ; r_forward_ip ; r_remote_ip - ; r_remote_ip_parsed ; r_body ; r_cookies_override ; r_sub_path @@ -287,16 +265,30 @@ let force_post_data ({r_body; _} as r) s i = | None -> None) let post_params r s i = - match force_post_data r s i with Some v -> Some (v >|= fst) | None -> None + match force_post_data r s i with Some v -> Some (fst v) | None -> None let files r s i = - match force_post_data r s i with Some v -> Some (v >|= snd) | None -> None + match force_post_data r s i with Some v -> Some (snd v) | None -> None + +let remote_ip {r_remote_ip; _} = r_remote_ip + +let remote_ip_parsed {r_remote_ip; _} = + let is_prefix prefix s = + (* TODO: Naive version to be swapped with [String.starts_with ~prefix s] + when the dependency on OCaml >= 4.13 is acceptable. *) + let plen = String.length prefix in + String.length s >= plen && String.sub s 0 plen = prefix + in + if is_prefix "unix://" r_remote_ip + then `Unix r_remote_ip + else `Ip (Ipaddr.of_string_exn r_remote_ip) -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 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; _} = r_connection_closed + +let connection_closed {r_connection_closed; _} = + Promise.await r_connection_closed + let timeofday {r_timeofday; _} = r_timeofday diff --git a/src/server/ocsigen_request.mli b/src/server/ocsigen_request.mli index 4d9db6004..707ae9482 100644 --- a/src/server/ocsigen_request.mli +++ b/src/server/ocsigen_request.mli @@ -1,3 +1,5 @@ +open Eio.Std + type t type content_type = (string * string) * (string * string) list @@ -19,9 +21,9 @@ val make : -> port:int -> ssl:bool -> filenames:string list ref - -> sockaddr:Lwt_unix.sockaddr - -> body:Cohttp_lwt.Body.t - -> connection_closed:unit Lwt.t + -> sockaddr:string + -> body:Cohttp_eio.Body.t + -> connection_closed:unit Promise.t -> Cohttp.Request.t -> t @@ -41,7 +43,7 @@ val update : val to_cohttp : t -> Cohttp.Request.t val uri : t -> Uri.t -val body : t -> Cohttp_lwt.Body.t +val body : t -> Cohttp_eio.Body.t val address : t -> Ocsigen_config.Socket_type.t val host : t -> string option val meth : t -> Cohttp.Code.meth @@ -66,13 +68,13 @@ val files : t -> string option -> Int64.t option - -> (string * file_info) list Lwt.t option + -> (string * file_info) list option val post_params : t -> string option -> Int64.t option - -> (string * string) list Lwt.t option + -> (string * string) list option val remote_ip : t -> string val remote_ip_parsed : t -> [`Ip of Ipaddr.t | `Unix of string] @@ -81,5 +83,5 @@ val content_type : t -> content_type option val request_cache : t -> Polytables.t val tries : t -> int val incr_tries : t -> unit -val connection_closed : t -> unit Lwt.t +val connection_closed : t -> unit val timeofday : t -> float diff --git a/src/server/ocsigen_response.ml b/src/server/ocsigen_response.ml index d9e5fe7d2..644f38c88 100644 --- a/src/server/ocsigen_response.ml +++ b/src/server/ocsigen_response.ml @@ -1,24 +1,33 @@ +open Eio.Std open Cohttp -open Lwt.Syntax module Body = struct (* TODO: Avoid copies by passing buffers directly. This API was choosen because it is closer to [Lwt_stream] which was used before. This type forces data to be copied from buffers (usually [bytes]) to immutable strings, which is unecessary. *) - type t = ((string -> unit Lwt.t) -> unit Lwt.t) * Transfer.encoding + type t = ((string -> unit) -> unit) * Transfer.encoding let make encoding writer : t = writer, encoding - let empty = make (Fixed 0L) (fun _write -> Lwt.return_unit) + let empty = make (Fixed 0L) (fun _write -> ()) let of_string s = make (Transfer.Fixed (Int64.of_int (String.length s))) (fun write -> write s) - let of_cohttp ~encoding body = - (fun write -> Cohttp_lwt.Body.write_body write body), encoding + let copy_body_to_t body write = + let buf = Cstruct.create 4096 in + let rec aux () = + match Eio.Flow.single_read body buf with + | len -> + write (Cstruct.to_string ~len buf); + aux () + | exception End_of_file -> () + in + aux () + let of_cohttp ~encoding body = copy_body_to_t body, encoding let write (w, _) = w let transfer_encoding = snd end @@ -50,10 +59,63 @@ let respond_string ?headers ~status ~body () = let respond_error ?headers ?(status = `Internal_server_error) ~body () = respond_string ?headers ~status ~body:("Error: " ^ body) () +let respond_not_found ?uri () = + let body = + match uri with + | None -> "Not found" + | Some uri -> "Not found: " ^ Uri.to_string uri + in + respond_string ~status:`Not_found ~body () + +let respond_file ?headers ?(status = `OK) fname = + let exception Isnt_a_file in + try + let sw = Stdlib.Option.get (Fiber.get Ocsigen_lib.current_switch) in + let env = Stdlib.Option.get (Fiber.get Ocsigen_lib.env) in + (* Copied from [cohttp-lwt-unix] and adapted to [Body]. *) + let file_path = Eio.Path.( / ) env#fs fname in + let file_size = + (* Check this isn't a directory first *) + let s = Eio.Path.stat ~follow:true file_path in + if s.Eio.File.Stat.kind <> `Regular_file + then raise Isnt_a_file + else s.size + in + let ic = Eio.Path.open_in ~sw file_path in + let encoding = Http.Transfer.Fixed (Optint.Int63.to_int64 file_size) in + let stream write = + let buf = Cstruct.create 16384 in + let rec cat_loop () = + match Eio.Flow.single_read ic buf with + | len -> + write (Cstruct.to_string ~len buf); + cat_loop () + | exception End_of_file -> () + in + let () = + try cat_loop () + with exn -> + Logs.warn (fun m -> + m "Error resolving file %s@\n%a" fname Eio.Exn.pp exn) + in + try Eio.Resource.close ic + with e -> + Logs.warn (fun f -> f "Closing channel failed:@\n%a" Eio.Exn.pp e) + in + let body = Body.make encoding stream in + let mime_type = Magic_mime.lookup fname in + let headers = + Http.Header.add_opt_unless_exists headers "content-type" mime_type + in + respond ~headers ~status ~encoding ~body () + with Unix.Unix_error (Unix.ENOENT, _, _) | Isnt_a_file -> + respond_not_found () + 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 + in + let a_body = match body with Some body -> body | None -> a_body and a_cookies = match cookies with Some cookies -> cookies | None -> a_cookies in @@ -90,30 +152,41 @@ let make_cookies_headers path t hds = (make_cookies_header path exp name v secure)) t hds -let to_cohttp_response {a_response; a_cookies; a_body = _} = +let to_cohttp_response {a_response; a_cookies; a_body = _, encoding} = let headers = let add name value headers = Header.add_unless_exists headers name value in + let add_transfer_encoding h = + match encoding with + | Transfer.Chunked -> add "transfer-encoding" "chunked" h + | _ -> h + in Ocsigen_cookie_map.Map_path.fold make_cookies_headers a_cookies (Response.headers a_response) |> add "server" Ocsigen_config.server_name |> add "date" (Ocsigen_lib.Date.to_string (Unix.time ())) + |> add_transfer_encoding in {a_response with Response.headers} +module Response_io = Cohttp.Response.Make (Cohttp_eio.Server.IO) +[@alert "-deprecated"] + let to_response_expert t = - let module R = Cohttp_lwt_unix.Response in - let write_footer {R.encoding; _} oc = - (* Copied from [cohttp/response.ml]. *) + let module R = Response_io in + let write_footer encoding oc = match encoding with - | Transfer.Chunked -> Lwt_io.write oc "0\r\n\r\n" - | Transfer.Fixed _ | Transfer.Unknown -> Lwt.return_unit + (* Copied from [cohttp/response.ml]. *) + | Transfer.Chunked -> Eio.Buf_write.string oc "0\r\n\r\n" + | Transfer.Fixed _ | Transfer.Unknown -> () in let res = to_cohttp_response t in ( res , fun _ic oc -> + (* TODO: Use [Cohttp_eio.Server.respond] instead of internal APIs. This requires turning [Body.t] into a [Eio.Flow]. *) let writer = R.make_body_writer ~flush:false res oc in - let* () = fst t.a_body (R.write_body writer) in - write_footer res oc ) + let body, encoding = t.a_body in + let () = body (R.write_body writer) in + write_footer encoding oc ) let response t = t.a_response let body t = t.a_body diff --git a/src/server/ocsigen_response.mli b/src/server/ocsigen_response.mli index 8ecb48acc..3edd08d35 100644 --- a/src/server/ocsigen_response.mli +++ b/src/server/ocsigen_response.mli @@ -6,15 +6,12 @@ module Body : sig val empty : t val of_string : string -> t - val make : - Cohttp.Transfer.encoding - -> ((string -> unit Lwt.t) -> unit Lwt.t) - -> t + val make : Cohttp.Transfer.encoding -> ((string -> unit) -> unit) -> t (** [make writer] makes a reponse body whose content is generated by [writer write]. [write str] blocks until [str] is fully written. *) - val of_cohttp : encoding:Cohttp.Transfer.encoding -> Cohttp_lwt.Body.t -> t - val write : t -> (string -> unit Lwt.t) -> unit Lwt.t + val of_cohttp : encoding:Cohttp.Transfer.encoding -> Cohttp_eio.Body.t -> t + val write : t -> (string -> unit) -> unit val transfer_encoding : t -> Cohttp.Transfer.encoding end @@ -53,6 +50,14 @@ val respond_error : @deprecated Use [respond_string] with a [~status] argument instead. *) +val respond_file : + ?headers:Cohttp.Header.t + -> ?status:Http.Status.t + -> string + -> t +(** Respond with the content of a file. The content type is guessed using + [Magic_mime]. *) + val update : ?response:Cohttp.Response.t -> ?body:Body.t @@ -62,12 +67,12 @@ val update : val of_cohttp : ?cookies:Ocsigen_cookie_map.t - -> Cohttp.Response.t * Cohttp_lwt.Body.t + -> Cohttp.Response.t * Cohttp_eio.Body.t -> t val to_response_expert : t - -> Cohttp.Response.t * ('ic -> Lwt_io.output_channel -> unit Lwt.t) + -> Cohttp.Response.t * ('ic -> Eio.Buf_write.t -> unit) (** Response for [Cohttp_lwt_unix.Server.make_expert]. Set cookie headers. *) val response : t -> Cohttp.Response.t diff --git a/src/server/ocsigen_server.ml b/src/server/ocsigen_server.ml index e4a221444..719d85412 100644 --- a/src/server/ocsigen_server.ml +++ b/src/server/ocsigen_server.ml @@ -1,3 +1,5 @@ +open Eio.Std + (* Ocsigen * http://www.ocsigen.org * Copyright (C) 2005 @@ -18,8 +20,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Lwt.Infix - let () = Random.self_init () (* Without the following line, it stops with "Broken Pipe" without @@ -30,33 +30,15 @@ let () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore let () = Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> exit 0)) let section = Logs.Src.create "ocsigen:main" -(* Initialize exception handler for Lwt timeouts: *) -let () = - Lwt_timeout.set_exn_handler (fun e -> - Logs.err ~src:section (fun fmt -> - fmt - ("Uncaught Exception after lwt timeout" ^^ "@\n%s") - (Printexc.to_string e))) - -let pp_sockaddr ppf = function - | Unix.ADDR_INET (ip, _port) -> - Format.fprintf ppf "%s" (Unix.string_of_inet_addr ip) - | ADDR_UNIX f -> Format.fprintf ppf "%s" f - -let _warn sockaddr s = - Logs.warn ~src:section (fun fmt -> - fmt "While talking to %a:%s" pp_sockaddr sockaddr s) - -let _dbg sockaddr s = - Logs.info ~src:section (fun fmt -> - fmt "While talking to %a:%s" pp_sockaddr sockaddr s) +let log_uncaught_exception exn = + Logs.err ~src:section (fun fmt -> + fmt "Uncaught Exception@\n%a" Eio.Exn.pp exn) (* fatal errors messages *) let errmsg = function | Dynlink_wrapper.Error e -> "Fatal - Dynamic linking error: " ^ Dynlink_wrapper.error_message e, 6 | Unix.Unix_error _ as e -> "Fatal - " ^ Printexc.to_string e, 9 - | Ssl.Private_key_error msg -> "Fatal - bad password: " ^ msg, 10 | Ocsigen_config.Config_file_error msg | Ocsigen_extensions.Error_in_config_file msg -> "Fatal - Error in configuration file: " ^ msg, 50 @@ -104,26 +86,18 @@ let reload ?file () = let () = let f _s = function | ["reopen_logs"] -> - Ocsigen_messages.open_files () >>= fun () -> - Logs.warn ~src:section (fun fmt -> fmt "Log files reopened"); - Lwt.return () - | ["reload"] -> reload (); Lwt.return () - | ["reload"; file] -> reload ~file (); Lwt.return () - | ["shutdown"] -> - Ocsigen_cohttp.shutdown None; - Lwt.return () - | ["shutdown"; f] -> - Ocsigen_cohttp.shutdown (Some (float_of_string f)); - Lwt.return () + Ocsigen_messages.open_files (); + Logs.warn ~src:section (fun fmt -> fmt "Log files reopened") + | ["reload"] -> reload () + | ["reload"; file] -> reload ~file () + | ["shutdown"] -> Ocsigen_cohttp.shutdown None + | ["shutdown"; f] -> Ocsigen_cohttp.shutdown (Some (float_of_string f)) | ["gc"] -> Gc.compact (); Logs.warn ~src:section (fun fmt -> - fmt "Heap compaction requested by user"); - Lwt.return () - | ["clearcache"] -> - Ocsigen_cache.clear_all_caches (); - Lwt.return () - | _ -> Lwt.fail Ocsigen_command.Unknown_command + fmt "Heap compaction requested by user") + | ["clearcache"] -> Ocsigen_cache.clear_all_caches () + | _ -> raise Ocsigen_command.Unknown_command in Ocsigen_command.register_command_function f @@ -221,7 +195,8 @@ let main config = in let extensions_connector = Ocsigen_extensions.compute_result in let run () = - Ocsigen_messages.open_files () >>= fun () -> + let sw = Stdlib.Option.get (Fiber.get Ocsigen_lib.current_switch) in + Ocsigen_messages.open_files (); 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 @@ -266,9 +241,8 @@ let main config = with e -> Logs.warn ~src:section (fun fmt -> fmt - ("Cannot create the command pipe %s. I will continue without." - ^^ "@\n%s") - commandpipe (Printexc.to_string e)); + "Cannot create the command pipe %s. I will continue without.@\n%a" + commandpipe Eio.Exn.pp e); false) in let minthreads = Ocsigen_config.get_minthreads () @@ -278,14 +252,6 @@ let main config = raise (Ocsigen_config.Config_file_error "maxthreads should be greater than minthreads"); - (Lwt.async_exception_hook := - fun e -> - (* replace the default "exit 2" behaviour *) - match e with - | Unix.Unix_error (Unix.EPIPE, _, _) -> () - | _ -> - Logs.err ~src:section (fun fmt -> - fmt ("Uncaught Exception" ^^ "@\n%s") (Printexc.to_string e))); (* Now apply host configuration: *) config (); if Ocsigen_config.get_silent () @@ -304,14 +270,16 @@ let main config = then let pipe = Unix.(openfile commandpipe [O_RDWR; O_NONBLOCK; O_APPEND]) 0o660 - |> Lwt_unix.of_unix_file_descr - |> Lwt_io.(of_fd ~mode:input) + |> fun x1 -> + Eio.Buf_read.of_flow ~max_size:1_000_000 + (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true x1 + :> [`R | `Flow | `Close] r) in let rec f () = - Lwt_io.read_line pipe >>= fun s -> + let s = Eio.Buf_read.line pipe in Ocsigen_messages.warning ("Command received: " ^ s); - Lwt.catch - (fun () -> + f + (try let prefix, c = match Ocsigen_lib.String.split ~multisep:true ' ' s with | [] -> raise Ocsigen_command.Unknown_command @@ -321,30 +289,28 @@ let main config = Some aa, ab :: l with Not_found -> None, a :: l) in - Ocsigen_command.get_command_function () ?prefix s c) - (function - | Ocsigen_command.Unknown_command -> - Logs.warn ~src:section (fun fmt -> fmt "Unknown command"); - Lwt.return () - | e -> - Logs.err ~src:section (fun fmt -> - fmt - ("Uncaught Exception after command" ^^ "@\n%s") - (Printexc.to_string e)); - Lwt.fail e) - >>= f + Ocsigen_command.get_command_function () ?prefix s c + with + | Ocsigen_command.Unknown_command -> + Logs.warn ~src:section (fun fmt -> fmt "Unknown command") + | e -> + Logs.err ~src:section (fun fmt -> + fmt "Uncaught Exception after command@\n%a" Eio.Exn.pp e); + raise e) in - ignore (f () : 'a Lwt.t)); - Lwt.join + Fiber.fork_daemon ~sw f); + Fiber.all (List.map - (fun (address, port) -> + (fun (address, port) () -> Ocsigen_cohttp.service ~address ~port - ~connector:extensions_connector ()) + ~connector:extensions_connector ~on_error:log_uncaught_exception + ()) connection @ (List.map (fun (address, port, (crt, key)) -> Ocsigen_cohttp.service ~ssl:(crt, key, Some (ask_for_passwd [address, port])) - ~address ~port ~connector:extensions_connector ())) + ~address ~port ~connector:extensions_connector + ~on_error:log_uncaught_exception)) ssl_connection) (* Ocsigen_messages.warning "Ocsigen has been launched (initialisations ok)"; @@ -380,19 +346,25 @@ let main config = ignore (Unix.write_substring f spid 0 len : int); Unix.close f in + let run () = + Eio_main.run (fun env -> + Fiber.with_binding Ocsigen_lib.env env (fun () -> + Switch.run (fun sw -> + Fiber.with_binding Ocsigen_lib.current_switch sw run))) + 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 ()) + then run () else ( Ocsigen_messages.console (fun () -> "Process " ^ string_of_int pid ^ " detached"); write_pid pid) else ( write_pid (Unix.getpid ()); - Lwt_main.run (run ())) + run ()) with e -> let msg, errno = errmsg e in Ocsigen_messages.errlog msg; diff --git a/test/extensions/deflatemod.t/index.html b/test/extensions/deflatemod.t/index.html deleted file mode 100644 index 802992c42..000000000 --- a/test/extensions/deflatemod.t/index.html +++ /dev/null @@ -1 +0,0 @@ -Hello world diff --git a/test/extensions/deflatemod.t/run.t b/test/extensions/deflatemod.t/run.t index 94368ce2d..ae6b365f4 100644 --- a/test/extensions/deflatemod.t/run.t +++ b/test/extensions/deflatemod.t/run.t @@ -1,28 +1,47 @@ $ source ../../server-test-helpers.sh $ run_server ./test.exe ocsigen:main: [WARNING] Command pipe created - ocsigen:access: connection for local-test from (curl/8.12.1): /index.html + cohttp.eio: [INFO] unix:: accept connection + ocsigen:access: connection for local-test from unix:// (): /index.html ocsigen:ext: [INFO] host found! local-test:0 matches .* ocsigen:ext:staticmod: [INFO] Is it a static file? ocsigen:local-file: [INFO] Testing "./index.html". ocsigen:local-file: [INFO] checking if file index.html can be sent ocsigen:ext: [INFO] Compiling exclusion regexp $^ ocsigen:local-file: [INFO] Returning "./index.html". - ocsigen:access: connection for local-test from (curl/8.12.1): /index.html + cohttp.eio: [INFO] unix:: disconnected + cohttp.eio: [INFO] unix:: accept connection + ocsigen:access: connection for local-test from unix:// (): /index.html ocsigen:ext: [INFO] host found! local-test:0 matches .* ocsigen:ext:staticmod: [INFO] Is it a static file? ocsigen:local-file: [INFO] Testing "./index.html". ocsigen:local-file: [INFO] checking if file index.html can be sent ocsigen:local-file: [INFO] Returning "./index.html". + cohttp.eio: [INFO] unix:: disconnected + cohttp.eio: [INFO] unix:: accept connection + ocsigen:access: connection for local-test from unix:// (): /empty_dir/ + ocsigen:ext: [INFO] host found! local-test:0 matches .* + ocsigen:ext:staticmod: [INFO] Is it a static file? + ocsigen:local-file: [INFO] Testing "./empty_dir/". + ocsigen:local-file: [INFO] Testing "./empty_dir/index.html" as possible index. + ocsigen:local-file: [INFO] No index and no listing + cohttp.eio: [INFO] unix:: disconnected + cohttp.eio: [INFO] unix:: accept connection + ocsigen:access: connection for local-test from unix:// (): /doesnt_exists.html + ocsigen:ext: [INFO] host found! local-test:0 matches .* + ocsigen:ext:staticmod: [INFO] Is it a static file? + ocsigen:local-file: [INFO] Testing "./doesnt_exists.html". + cohttp.eio: [INFO] unix:: disconnected application: [WARNING] Command received: shutdown First response is not compressed: + $ echo "Hello world" > index.html $ curl_ "index.html" HTTP/1.1 200 OK content-type: text/html - server: Ocsigen content-length: 12 + server: Ocsigen Hello world @@ -31,8 +50,25 @@ Second response is compressed: $ curl_ "index.html" --compressed HTTP/1.1 200 OK content-type: text/html + content-length: 12 content-encoding: gzip server: Ocsigen transfer-encoding: chunked Hello world + +Querying a directory or a non-existing file should give "Not found" without +compression: + + $ mkdir empty_dir && curl_ empty_dir/ --compressed + HTTP/1.1 404 Not Found + content-length: 16 + server: Ocsigen + + Error: Not Found + $ curl_ doesnt_exists.html --compressed + HTTP/1.1 404 Not Found + content-length: 16 + server: Ocsigen + + Error: Not Found diff --git a/test/server-test-helpers.sh b/test/server-test-helpers.sh index b438febc1..249cd7f43 100644 --- a/test/server-test-helpers.sh +++ b/test/server-test-helpers.sh @@ -37,6 +37,7 @@ curl_ () { local path=$1; shift # Remove the 'date' header, which is unreproducible - curl --unix-socket ./local.sock -s -i "$@" "http://local-test/$path" | \ + curl --unix-socket ./local.sock --user-agent "" -s -i \ + "$@" "http://local-test/$path" | \ grep -v "^date: " }