From 19b453a59c499dfeb4d85843719047acdf41af07 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 11:23:40 +0200 Subject: [PATCH 01/46] Rename conduit's ctx to resolvers into Cohttp_lwt.Client --- cohttp-lwt/src/client.ml | 37 ++++++++++++++++++------------------- cohttp-lwt/src/client.mli | 2 +- 2 files changed, 19 insertions(+), 20 deletions(-) diff --git a/cohttp-lwt/src/client.ml b/cohttp-lwt/src/client.ml index 3af601d834..e5fd92f11e 100644 --- a/cohttp-lwt/src/client.ml +++ b/cohttp-lwt/src/client.ml @@ -10,8 +10,7 @@ module Make module Response = Make.Response(IO) module Request = Make.Request(IO) - type ctx = Net.ctx [@@deriving sexp_of] - let default_ctx = Net.default_ctx + type resolvers = Net.resolvers let read_response ~closefn ic _oc meth = Response.read ic >>= begin function @@ -47,9 +46,9 @@ module Make | `DELETE -> false | _ -> true - let call ?(ctx=default_ctx) ?headers ?(body=`Empty) ?chunked meth uri = + let call ?(resolvers= Net.empty) ?headers ?(body=`Empty) ?chunked meth uri = let headers = match headers with None -> Header.init () | Some h -> h in - Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) -> + Net.connect_uri ~resolvers uri >>= fun (_conn, ic, oc) -> let closefn () = Net.close ic oc in let chunked = match chunked with @@ -74,28 +73,28 @@ module Make read_response ~closefn ic oc meth (* The HEAD should not have a response body *) - let head ?ctx ?headers uri = - call ?ctx ?headers `HEAD uri + let head ?resolvers ?headers uri = + call ?resolvers ?headers `HEAD uri >|= fst - let get ?ctx ?headers uri = call ?ctx ?headers `GET uri - let delete ?ctx ?body ?chunked ?headers uri = - call ?ctx ?headers ?body ?chunked `DELETE uri - let post ?ctx ?body ?chunked ?headers uri = - call ?ctx ?headers ?body ?chunked `POST uri - let put ?ctx ?body ?chunked ?headers uri = - call ?ctx ?headers ?body ?chunked `PUT uri - let patch ?ctx ?body ?chunked ?headers uri = - call ?ctx ?headers ?body ?chunked `PATCH uri + let get ?resolvers ?headers uri = call ?resolvers ?headers `GET uri + let delete ?resolvers ?body ?chunked ?headers uri = + call ?resolvers ?headers ?body ?chunked `DELETE uri + let post ?resolvers ?body ?chunked ?headers uri = + call ?resolvers ?headers ?body ?chunked `POST uri + let put ?resolvers ?body ?chunked ?headers uri = + call ?resolvers ?headers ?body ?chunked `PUT uri + let patch ?resolvers ?body ?chunked ?headers uri = + call ?resolvers ?headers ?body ?chunked `PATCH uri - let post_form ?ctx ?headers ~params uri = + let post_form ?resolvers ?headers ~params uri = let headers = Header.add_opt_unless_exists headers "content-type" "application/x-www-form-urlencoded" in let body = Body.of_string (Uri.encoded_of_query params) in - post ?ctx ~chunked:false ~headers ~body uri + post ?resolvers ~chunked:false ~headers ~body uri - let callv ?(ctx=default_ctx) uri reqs = - Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) -> + let callv ?(resolvers= Net.empty) uri reqs = + Net.connect_uri ~resolvers uri >>= fun (_conn, ic, oc) -> (* Serialise the requests out to the wire *) let meth_stream = Lwt_stream.map_s (fun (req,body) -> Request.write (fun writer -> diff --git a/cohttp-lwt/src/client.mli b/cohttp-lwt/src/client.mli index f76fc6f3f5..f3a22ca020 100644 --- a/cohttp-lwt/src/client.mli +++ b/cohttp-lwt/src/client.mli @@ -4,4 +4,4 @@ module. The resulting module satisfies the {! Client } module type. *) module Make (IO:S.IO) (Net:S.Net with module IO = IO) : S.Client - with type ctx = Net.ctx + with type resolvers = Net.resolvers From 9ab38355a8538619f42cc99f2daf1d417c875095 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 11:29:22 +0200 Subject: [PATCH 02/46] Rename conduit's ctx to resolvers into Cohttp_lwt_jsoo --- cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml b/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml index 1aa3c4e0db..4cf89573fc 100644 --- a/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml @@ -122,33 +122,32 @@ module Make_api(X : sig module Request = X.Request module Response = X.Response - let default_ctx = () - type ctx = unit + type resolvers = unit let sexp_of_ctx _ = Sexplib0.Sexp.List [] - let call ?ctx:_ ?headers ?body ?chunked:_ meth uri = + let call ?resolvers:_ ?headers ?body ?chunked:_ meth uri = X.call ?headers ?body meth uri (* The HEAD should not have a response body *) - let head ?ctx ?headers uri = + let head ?resolvers ?headers uri = let open Lwt in - call ?ctx ?headers ~chunked:false `HEAD uri + call ?resolvers ?headers ~chunked:false `HEAD uri >|= fst - let get ?ctx ?headers uri = call ?ctx ?headers ~chunked:false `GET uri - let delete ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `DELETE uri - let post ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `POST uri - let put ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `PUT uri - let patch ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `PATCH uri + let get ?resolvers ?headers uri = call ?resolvers ?headers ~chunked:false `GET uri + let delete ?resolvers ?body ?chunked ?headers uri = call ?resolvers ?headers ?body ?chunked `DELETE uri + let post ?resolvers ?body ?chunked ?headers uri = call ?resolvers ?headers ?body ?chunked `POST uri + let put ?resolvers ?body ?chunked ?headers uri = call ?resolvers ?headers ?body ?chunked `PUT uri + let patch ?resolvers ?body ?chunked ?headers uri = call ?resolvers ?headers ?body ?chunked `PATCH uri - let post_form ?ctx ?headers ~params uri = + let post_form ?resolvers ?headers ~params uri = let headers = C.Header.add_opt headers "content-type" "application/x-www-form-urlencoded" in let body = Cohttp_lwt.Body.of_string (Uri.encoded_of_query params) in - post ?ctx ~chunked:false ~headers ~body uri + post ?resolvers ~chunked:false ~headers ~body uri (* No implementation (can it be done?). What should the failure exception be? *) exception Cohttp_lwt_xhr_callv_not_implemented - let callv ?ctx:_ _uri _reqs = + let callv ?resolvers:_ _uri _reqs = Lwt.fail Cohttp_lwt_xhr_callv_not_implemented (* ??? *) end From e5db38329e51432b59b4b284df0b5e46050b2d89 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 11:30:08 +0200 Subject: [PATCH 03/46] Update interface and rename conduit's ctx to resolvers --- cohttp-lwt/src/s.ml | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/cohttp-lwt/src/s.ml b/cohttp-lwt/src/s.ml index f9a3d1500d..07dc0d2587 100644 --- a/cohttp-lwt/src/s.ml +++ b/cohttp-lwt/src/s.ml @@ -21,9 +21,11 @@ end and close the resulting channels to clean up. *) module type Net = sig module IO : IO - type ctx [@@deriving sexp_of] - val default_ctx: ctx - val connect_uri : ctx:ctx -> Uri.t -> (IO.conn * IO.ic * IO.oc) Lwt.t + + type resolvers + + val empty : resolvers + val connect_uri : ?host:string -> resolvers:resolvers -> Uri.t -> (IO.conn * IO.ic * IO.oc) Lwt.t val close_in : IO.ic -> unit val close_out : IO.oc -> unit val close : IO.ic -> IO.oc -> unit @@ -36,13 +38,11 @@ end fashion. It will still be finalized by a GC hook if it is not used up, but this can take some additional time to happen. *) module type Client = sig + type resolvers - type ctx [@@deriving sexp_of] - val default_ctx : ctx - - (** [call ?ctx ?headers ?body ?chunked meth uri] will resolve the + (** [call ?resolvers ?headers ?body ?chunked meth uri] will resolve the [uri] to a concrete network endpoint using the resolver initialized - in [ctx]. It will then issue an HTTP request with method [meth], + in [resolvers]. It will then issue an HTTP request with method [meth], adding request headers from [headers] if present. If a [body] is specified then that will be included with the request, using chunked encoding if [chunked] is true. The default is to disable @@ -52,7 +52,7 @@ module type Client = sig interface rather than invoke this function directly. See {!head}, {!get} and {!post} for some examples. *) val call : - ?ctx:ctx -> + ?resolvers:resolvers -> ?headers:Cohttp.Header.t -> ?body:Body.t -> ?chunked:bool -> @@ -60,51 +60,51 @@ module type Client = sig Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val head : - ?ctx:ctx -> + ?resolvers:resolvers -> ?headers:Cohttp.Header.t -> Uri.t -> Cohttp.Response.t Lwt.t val get : - ?ctx:ctx -> + ?resolvers:resolvers -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val delete : - ?ctx:ctx -> + ?resolvers:resolvers -> ?body:Body.t -> ?chunked:bool -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val post : - ?ctx:ctx -> + ?resolvers:resolvers -> ?body:Body.t -> ?chunked:bool -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val put : - ?ctx:ctx -> + ?resolvers:resolvers -> ?body:Body.t -> ?chunked:bool -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val patch : - ?ctx:ctx -> + ?resolvers:resolvers -> ?body:Body.t -> ?chunked:bool -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val post_form : - ?ctx:ctx -> + ?resolvers:resolvers -> ?headers:Cohttp.Header.t -> params:(string * string list) list -> Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val callv : - ?ctx:ctx -> + ?resolvers:resolvers -> Uri.t -> (Cohttp.Request.t * Body.t) Lwt_stream.t -> (Cohttp.Response.t * Body.t) Lwt_stream.t Lwt.t From b98a7a5a2271b89791b3c5e74194f43ec8f21564 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 8 Sep 2020 17:18:56 +0200 Subject: [PATCH 04/46] Update type of connection for Cohttp_lwt_unix.Io `conduit-lwt-unix` does not exist and `conduit-lwt` is the only specialisation with lwt and lwt.unix of conduit available. --- cohttp-lwt-unix/src/io.ml | 2 +- cohttp-lwt-unix/src/io.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cohttp-lwt-unix/src/io.ml b/cohttp-lwt-unix/src/io.ml index b5579d6b24..030d30384a 100644 --- a/cohttp-lwt-unix/src/io.ml +++ b/cohttp-lwt-unix/src/io.ml @@ -30,7 +30,7 @@ let return = Lwt.return type ic = Lwt_io.input_channel type oc = Lwt_io.output_channel -type conn = Conduit_lwt_unix.flow +type conn = Conduit_lwt.flow let src = Logs.Src.create "cohttp.lwt.io" ~doc:"Cohttp Lwt IO module" module Log = (val Logs.src_log src : Logs.LOG) diff --git a/cohttp-lwt-unix/src/io.mli b/cohttp-lwt-unix/src/io.mli index 1e90ce1b11..0814303c84 100644 --- a/cohttp-lwt-unix/src/io.mli +++ b/cohttp-lwt-unix/src/io.mli @@ -17,5 +17,5 @@ include Cohttp_lwt.S.IO with type ic = Lwt_io.input_channel and type oc = Lwt_io.output_channel - and type conn = Conduit_lwt_unix.flow + and type conn = Conduit_lwt.flow and type error = exn From 5d2bb1c43ebd6c2ad8a9a169c1d92f6eacca91c9 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:06:08 +0200 Subject: [PATCH 05/46] Update Cohttp_lwt_unix.Client with new interface given by Cohttp_lwt.S --- cohttp-lwt-unix/src/client.ml | 2 -- cohttp-lwt-unix/src/client.mli | 14 +------------- 2 files changed, 1 insertion(+), 15 deletions(-) diff --git a/cohttp-lwt-unix/src/client.ml b/cohttp-lwt-unix/src/client.ml index 2af115ccde..b7138d5f56 100644 --- a/cohttp-lwt-unix/src/client.ml +++ b/cohttp-lwt-unix/src/client.ml @@ -1,4 +1,2 @@ include Cohttp_lwt.Make_client(Io)(Net) - -let custom_ctx = Net.init diff --git a/cohttp-lwt-unix/src/client.mli b/cohttp-lwt-unix/src/client.mli index 1301262073..59ae57f8b7 100644 --- a/cohttp-lwt-unix/src/client.mli +++ b/cohttp-lwt-unix/src/client.mli @@ -2,16 +2,4 @@ (** The [Client] module implements the full UNIX HTTP client interface, including the UNIX-specific functions defined in {!C }. *) -include Cohttp_lwt.S.Client with type ctx = Net.ctx - -(** [custom_ctx ?ctx ?resolver ()] will return a context that is the - same as the {!default_ctx}, but with either the connection handling - or resolution module overridden with [ctx] or [resolver] respectively. - - This is useful to supply a {!Conduit_lwt_unix.ctx} with a custom - source network interface, or a {!Resolver_lwt.t} with a different - name resolution strategy (for instance to override a hostname to - point it to a Unix domain socket). *) -val custom_ctx: - ?ctx:Conduit_lwt_unix.ctx -> - ?resolver:Resolver_lwt.t -> unit -> ctx +include Cohttp_lwt.S.Client with type resolvers = Conduit.resolvers From e3d227905aa64adc2dd2bbeaae3f959d5ee95aa6 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:06:56 +0200 Subject: [PATCH 06/46] Update implementation of Cohttp_lwt_unix.Net with new version of conduit-lwt-unix --- cohttp-lwt-unix/src/net.ml | 34 ++++++++++++++-------------------- cohttp-lwt-unix/src/net.mli | 17 +++++++++-------- 2 files changed, 23 insertions(+), 28 deletions(-) diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index a0d2665423..227a259565 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -21,26 +21,20 @@ open Lwt.Infix module IO = Io -type ctx = { - ctx: Conduit_lwt_unix.ctx; - resolver: Resolver_lwt.t; -} [@@deriving sexp_of] - -let init ?(ctx=Conduit_lwt_unix.default_ctx) - ?(resolver=Resolver_lwt_unix.system) () = - { ctx; resolver } - -let default_ctx = { - resolver = Resolver_lwt_unix.system; - ctx = Conduit_lwt_unix.default_ctx; -} - -let connect_uri ~ctx uri = - Resolver_lwt.resolve_uri ~uri ctx.resolver - >>= fun endp -> - Conduit_lwt_unix.endp_to_client ~ctx:ctx.ctx endp - >>= fun client -> - Conduit_lwt_unix.connect ~ctx:ctx.ctx client +type resolvers = Conduit.resolvers + +let empty = Conduit.empty + +let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt + +let connect_uri ?host:(default= "localhost") ~resolvers uri = + let domain_name = Domain_name.(host_exn (of_string_exn (Uri.host_with_default ~default uri))) in + Conduit_lwt.resolve resolvers domain_name >>= function + | Ok flow -> + let ic, oc = Conduit_lwt.io_of_flow flow in + Lwt.return (flow, ic, oc) + | Error err -> + failwith "%a" Conduit_lwt.pp_error err let close c = Lwt.catch (fun () -> Lwt_io.close c) diff --git a/cohttp-lwt-unix/src/net.mli b/cohttp-lwt-unix/src/net.mli index ca5bc291d1..49ba25cdae 100644 --- a/cohttp-lwt-unix/src/net.mli +++ b/cohttp-lwt-unix/src/net.mli @@ -18,19 +18,20 @@ module IO = Io -type ctx = { - ctx : Conduit_lwt_unix.ctx; - resolver : Resolver_lwt.t; -} [@@deriving sexp_of] +type resolvers = Conduit.resolvers -val init : ?ctx:Conduit_lwt_unix.ctx -> ?resolver:Resolver_lwt.t -> unit -> ctx +val empty : resolvers -val default_ctx : ctx +(** Exceptions from [conduit]. + + When the [recv] or the [send] {i syscalls} return an error, + [conduit] will reraise it. *) val connect_uri : - ctx:ctx -> + ?host:string -> + resolvers:resolvers -> Uri.t -> - (Conduit_lwt_unix.flow * Conduit_lwt_unix.ic * Conduit_lwt_unix.oc) Lwt.t + (Conduit_lwt.flow * Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel) Lwt.t val close_in : 'a Lwt_io.channel -> unit val close_out : 'a Lwt_io.channel -> unit From 236e5e3e305b9cd521204d3ee0ed62310fdf3d8d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:07:41 +0200 Subject: [PATCH 07/46] Update Cohttp_lwt_unix.Server with the new way to initialize a server --- cohttp-lwt-unix/src/server.ml | 34 ++++++++++++++++++++++++++++++---- cohttp-lwt-unix/src/server.mli | 5 +++-- 2 files changed, 33 insertions(+), 6 deletions(-) diff --git a/cohttp-lwt-unix/src/server.ml b/cohttp-lwt-unix/src/server.ml index 3aea6dc1ba..8df0999468 100644 --- a/cohttp-lwt-unix/src/server.ml +++ b/cohttp-lwt-unix/src/server.ml @@ -67,7 +67,33 @@ let log_on_exn = (Unix.error_message error) func arg) | exn -> Logs.err (fun m -> m "Unhandled exception: %a" Fmt.exn exn) -let create ?timeout ?backlog ?stop ?(on_exn=log_on_exn) ?(ctx=Net.default_ctx) - ?(mode=`TCP (`Port 8080)) spec = - Conduit_lwt_unix.serve ?backlog ?timeout ?stop ~on_exn ~ctx:ctx.Net.ctx - ~mode (callback spec) +let safe error_handler callback spec flow () = + Lwt.catch + (fun () -> let ic, oc = Conduit_lwt.io_of_flow flow in callback spec flow ic oc) + (fun exn -> error_handler exn) + +let create + : type cfg t flow. + ?timeout:int + -> ?backlog:int + -> ?stop:unit Lwt.t + -> ?on_exn:(exn -> unit) + -> cfg + -> (_, flow) Conduit_lwt.protocol + -> (cfg, t, flow) Conduit_lwt.Service.service + -> _ -> unit Lwt.t + = fun ?timeout ?(backlog= 128) ?(stop= fst (Lwt.wait ())) ?(on_exn=log_on_exn) + cfg protocol service spec -> + let error_handler exn = on_exn exn ; Lwt.return_unit in + let cfg : cfg = match Conduit_lwt.Service.equal service Conduit_lwt.TCP.service with + | Some (Conduit.Refl, _, _) -> + { cfg with Conduit_lwt.TCP.capacity= backlog } + | None -> cfg in + let handler flow = + let flow = Conduit_lwt.pack protocol flow in + Lwt.finalize + (safe error_handler callback spec flow) + (fun () -> Conduit_lwt.close flow >>= fun _ -> Lwt.return_unit) in + let cond, run = Conduit_lwt.serve ?timeout ~handler ~service cfg in + Lwt.pick [ (stop >|= Lwt_condition.signal cond) + ; run ] diff --git a/cohttp-lwt-unix/src/server.mli b/cohttp-lwt-unix/src/server.mli index 2bf30975c5..399ee03947 100644 --- a/cohttp-lwt-unix/src/server.mli +++ b/cohttp-lwt-unix/src/server.mli @@ -34,5 +34,6 @@ val create : ?backlog:int -> ?stop:unit Lwt.t -> ?on_exn:(exn -> unit) -> - ?ctx:Net.ctx -> - ?mode:Conduit_lwt_unix.server -> t -> unit Lwt.t + 'cfg -> + (_, 'flow) Conduit_lwt.protocol -> + ('cfg, 't, 'flow) Conduit_lwt.Service.service -> t -> unit Lwt.t From 6a599538df385d4a06fccf3c9e7ffc0edfed41df Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:08:27 +0200 Subject: [PATCH 08/46] Update binaries provided by cohttp-lwt-unix --- cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml | 59 ++++++++++++++++++++---- cohttp-lwt-unix/bin/cohttp_server_lwt.ml | 56 +++++++++++++++++----- 2 files changed, 95 insertions(+), 20 deletions(-) diff --git a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml index f58aa090ec..5ed9fb8cc7 100644 --- a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml @@ -22,6 +22,27 @@ open Lwt open Cohttp open Cohttp_lwt_unix +let option_bind x f = match x with + | Some x -> f x + | None -> None + +let ssl_protocol, ssl_service = + let open Conduit_lwt_ssl.TCP in + protocol, service + +let sockaddr_of_flow + : Conduit_lwt.flow -> Unix.sockaddr option + = fun flow -> match Conduit_lwt.cast flow Conduit_lwt.TCP.protocol, + Conduit_lwt.cast flow ssl_protocol with + | Some flow, None -> Some (Conduit_lwt.TCP.Protocol.sock flow) + | None, Some flow -> Some (Lwt_ssl.getsockname flow) + | _ -> None + +let pp_sockaddr ppf = function + | Unix.ADDR_UNIX v -> Format.fprintf ppf "<%s>" v + | Unix.ADDR_INET (inet_addr, port) -> + Format.fprintf ppf "<%s:%d>" (Unix.string_of_inet_addr inet_addr) port + let handler ~verbose _ req body = let uri = Cohttp.Request.uri req in (* Log the request to the console *) @@ -54,18 +75,40 @@ let handler ~verbose _ req body = in Server.respond ~headers ~status ~body () +let load_ssl ?(version= Ssl.TLSv1_2) (cert, key) = + try + let ctx = Ssl.create_context version Ssl.Server_context in + Ssl.use_certificate ctx cert key ; + Some ctx + with _ -> None + +let sockaddr_of_host_and_port host port = + let inet_addr = Unix.inet_addr_of_string host in + Unix.ADDR_INET (inet_addr, port) + let start_proxy port host verbose cert key () = printf "Listening for HTTP request on: %s %d\n%!" host port; let conn_closed (ch,_conn) = - printf "Connection %s closed\n%!" - (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch)) in + let pp_option pp_val ppf = function + | Some x -> pp_val ppf x + | None -> () in + Format.printf "Connection %a closed.\n%!" + (pp_option pp_sockaddr) (sockaddr_of_flow ch) in let callback = handler ~verbose in let config = Server.make ~callback ~conn_closed () in - let mode = match cert, key with - | Some c, Some k -> `TLS (`Crt_file_path c, `Key_file_path k, `No_password, `Port port) - | _ -> `TCP (`Port port) - in - Server.create ~mode config + let ssl = match cert, key with + | Some cert, Some key -> Some (cert, key) + | None, None -> None + | _ -> failwith "A TLS proxy requires a certificates and a key" in + let ssl_config = option_bind ssl load_ssl in + let tcp_config = + { Conduit_lwt.TCP.sockaddr= sockaddr_of_host_and_port host port + ; capacity= 40; } in + match ssl_config with + | Some ssl_config -> + Server.create (ssl_config, tcp_config) ssl_protocol ssl_service config + | None -> + Server.create tcp_config Conduit_lwt.TCP.protocol Conduit_lwt.TCP.service config let lwt_start_proxy port host verbose cert key = Lwt_main.run (start_proxy port host verbose cert key ()) @@ -74,7 +117,7 @@ open Cmdliner let host = let doc = "IP address to listen on." in - Arg.(value & opt string "0.0.0.0" & info ["s"] ~docv:"HOST" ~doc) + Arg.(value & opt string "localhost" & info ["s"] ~docv:"HOST" ~doc) let port = let doc = "TCP port to listen on." in diff --git a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml index 81e92b17e8..0f1e432cb8 100644 --- a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml @@ -21,9 +21,29 @@ open Cohttp_lwt_unix open Cohttp_server +let option_bind x f = match x with + | Some x -> f x + | None -> None + let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server" module Log = (val Logs.src_log src : Logs.LOG) +let ssl_protocol, ssl_service = + let open Conduit_lwt_ssl.TCP in + protocol, service + +let sockaddr_of_flow + : Conduit_lwt.flow -> Unix.sockaddr option + = fun flow -> match Conduit_lwt.cast flow Conduit_lwt.TCP.protocol, + Conduit_lwt.cast flow ssl_protocol with + | Some flow, None -> Some (Conduit_lwt.TCP.Protocol.sock flow) + | None, Some flow -> Some (Lwt_ssl.getsockname flow) + | _ -> None + +let pp_sockaddr ppf = function + | Unix.ADDR_UNIX v -> Fmt.pf ppf "<%s>" v + | Unix.ADDR_INET (inet_addr, port) -> + Fmt.pf ppf "<%s:%d>" (Unix.string_of_inet_addr inet_addr) port let method_filter meth (res,body) = match meth with | `HEAD -> Lwt.return (res,`Empty) @@ -86,10 +106,10 @@ let handler ~info ~docroot ~index (ch,_conn) req _body = let path = Uri.path uri in (* Log the request to the console *) Log.debug (fun m -> m - "%s %s %s" + "%s %s %a" (Cohttp.(Code.string_of_method (Request.meth req))) path - (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))); + Fmt.(option pp_sockaddr) (sockaddr_of_flow ch)); (* Get a canonical filename from the URL and docroot *) match Request.meth req with | (`GET | `HEAD) as meth -> @@ -102,22 +122,34 @@ let handler ~info ~docroot ~index (ch,_conn) req _body = Server.respond_string ~headers ~status:`Method_not_allowed ~body:(html_of_method_not_allowed meth (String.concat "," allowed) path info) () +let load_ssl ?(version= Ssl.TLSv1_2) (cert, key) = + try + let ctx = Ssl.create_context version Ssl.Server_context in + Ssl.use_certificate ctx cert key ; + Some ctx + with _ -> None + +let sockaddr_of_host_and_port host port = + let inet_addr = Unix.inet_addr_of_string host in + Unix.ADDR_INET (inet_addr, port) + let start_server docroot port host index tls () = Log.info (fun m -> m "Listening for HTTP request on: %s %d" host port); let info = Printf.sprintf "Served by Cohttp/Lwt listening on %s:%d" host port in let conn_closed (ch,_conn) = - Log.debug (fun m -> m "connection %s closed" - (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))) in + Log.debug (fun m -> m "connection %a closed" + Fmt.(option pp_sockaddr) (sockaddr_of_flow ch)) in let callback = handler ~info ~docroot ~index in let config = Server.make ~callback ~conn_closed () in - let mode = match tls with - | Some (c, k) -> `TLS (`Crt_file_path c, `Key_file_path k, `No_password, `Port port) - | None -> `TCP (`Port port) - in - Conduit_lwt_unix.init ~src:host () - >>= fun ctx -> - let ctx = Cohttp_lwt_unix.Net.init ~ctx () in - Server.create ~ctx ~mode config + let ssl_config = option_bind tls load_ssl in + let tcp_config = + { Conduit_lwt.TCP.sockaddr= sockaddr_of_host_and_port host port + ; capacity= 40; } in + match ssl_config with + | Some ssl_config -> + Server.create (ssl_config, tcp_config) ssl_protocol ssl_service config + | None -> + Server.create tcp_config Conduit_lwt.TCP.protocol Conduit_lwt.TCP.service config let lwt_start_server docroot port host index verbose tls = if verbose <> None then begin From 3242816dcf35ed821348b23e847ff681b3a8c3e0 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:09:29 +0200 Subject: [PATCH 09/46] Update Cohttp_mirage.Client with the new interface fiven by Cohttp_lwt.S --- cohttp-mirage/src/client.ml | 27 ++++++++++++--------------- cohttp-mirage/src/client.mli | 3 +-- 2 files changed, 13 insertions(+), 17 deletions(-) diff --git a/cohttp-mirage/src/client.ml b/cohttp-mirage/src/client.ml index f40997bf02..c9d4ca026c 100644 --- a/cohttp-mirage/src/client.ml +++ b/cohttp-mirage/src/client.ml @@ -19,29 +19,27 @@ open Lwt.Infix -module Channel = Mirage_channel.Make(Conduit_mirage.Flow) +module Channel = Mirage_channel.Make(Conduit_mirage_flow) module HTTP_IO = Io.Make(Channel) module Net_IO = struct module IO = HTTP_IO - type ctx = { - resolver: Resolver_lwt.t; - conduit : Conduit_mirage.t; - } + type resolvers = Conduit.resolvers - let sexp_of_ctx { resolver; _ } = Resolver_lwt.sexp_of_t resolver + let empty = Conduit.empty - let default_ctx = - { resolver = Resolver_mirage.localhost; conduit = Conduit_mirage.empty } + let failwith fmt = Fmt.kstrf (fun err -> Lwt.fail (Failure err)) fmt - let connect_uri ~ctx uri = - Resolver_lwt.resolve_uri ~uri ctx.resolver >>= fun endp -> - Conduit_mirage.client endp >>= fun client -> - Conduit_mirage.connect ctx.conduit client >>= fun flow -> - let ch = Channel.create flow in - Lwt.return (flow, ch, ch) + let connect_uri ?host:(default= "localhost") ~resolvers uri = + let domain_name = Domain_name.(host_exn (of_string_exn (Uri.host_with_default ~default uri))) in + Conduit_mirage.resolve resolvers domain_name >>= function + | Ok flow -> + let ch = Channel.create flow in + Lwt.return (flow, ch, ch) + | Error err -> + failwith "%a" Conduit_mirage.pp_error err let close_in _ = () let close_out _ = () @@ -54,7 +52,6 @@ module Net_IO = struct ) end -let ctx resolver conduit = { Net_IO.resolver; conduit } (* Build all the core modules from the [Cohttp_lwt] functors *) include Cohttp_lwt.Make_client(HTTP_IO)(Net_IO) diff --git a/cohttp-mirage/src/client.mli b/cohttp-mirage/src/client.mli index fe49a7f733..c7972e5866 100644 --- a/cohttp-mirage/src/client.mli +++ b/cohttp-mirage/src/client.mli @@ -1,3 +1,2 @@ - include Cohttp_lwt.S.Client -val ctx: Resolver_lwt.t -> Conduit_mirage.t -> ctx + with type resolvers = Conduit.resolvers From 181f9c8b830d37a1b0f701564229837f5b529daa Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:10:14 +0200 Subject: [PATCH 10/46] Update Cohttp_mirage.Server_with_conduit with the new way to initialize a server --- cohttp-mirage/src/server_with_conduit.ml | 19 ++++++++++++++----- cohttp-mirage/src/server_with_conduit.mli | 10 ++++++---- 2 files changed, 20 insertions(+), 9 deletions(-) diff --git a/cohttp-mirage/src/server_with_conduit.ml b/cohttp-mirage/src/server_with_conduit.ml index e34786384d..2fc93807ae 100644 --- a/cohttp-mirage/src/server_with_conduit.ml +++ b/cohttp-mirage/src/server_with_conduit.ml @@ -1,6 +1,15 @@ +include Make.Server(Conduit_mirage_flow) -include Make.Server(Conduit_mirage.Flow) - -let connect t = - let listen s f = Conduit_mirage.listen t s (listen f) in - Lwt.return listen +let connect + : type cfg t flow. + (_, flow) Conduit_mirage.protocol + -> (cfg, t, flow) Conduit_mirage.Service.service + -> (cfg -> _ -> unit Lwt.t) Lwt.t + = fun protocol service -> + let server = fun cfg spec -> + let handler flow = + let flow = Conduit_mirage.pack protocol flow in + listen spec flow in + let _, run = Conduit_mirage.serve ~service ~handler cfg in + run in + Lwt.return server diff --git a/cohttp-mirage/src/server_with_conduit.mli b/cohttp-mirage/src/server_with_conduit.mli index 18485b5596..70f7465cf3 100644 --- a/cohttp-mirage/src/server_with_conduit.mli +++ b/cohttp-mirage/src/server_with_conduit.mli @@ -1,6 +1,8 @@ (** HTTP server with conduit. *) -include Cohttp_lwt.S.Server with type IO.conn = Conduit_mirage.Flow.flow -val connect: - Conduit_mirage.t -> - (Conduit_mirage.server -> t -> unit Lwt.t) Lwt.t +include Cohttp_lwt.S.Server with type IO.conn = Conduit_mirage.flow + +val connect : + (_, 'flow) Conduit_mirage.protocol -> + ('cfg, 't, 'flow) Conduit_mirage.Service.service -> + ('cfg -> t -> unit Lwt.t) Lwt.t From 83bf0c28f91a96e03cbb747283cfc0a7942b050d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:11:42 +0200 Subject: [PATCH 11/46] Update Cohttp_async.Client (rename ssl_config to ssl_ctx) with conduit-async.3.0.0 --- cohttp-async/src/client.ml | 89 ++++++++++++++++++++++--------------- cohttp-async/src/client.mli | 30 +++++-------- 2 files changed, 64 insertions(+), 55 deletions(-) diff --git a/cohttp-async/src/client.ml b/cohttp-async/src/client.ml index bae9a7a74a..8afe996af7 100644 --- a/cohttp-async/src/client.ml +++ b/cohttp-async/src/client.ml @@ -28,24 +28,44 @@ module Net = struct Or_error.return (host, Ipaddr_unix.of_inet_addr addr, port) | _ -> Or_error.error "Failed to resolve Uri" uri Uri_sexp.sexp_of_t - let connect_uri ?interrupt ?ssl_config uri = - (match Uri.scheme uri with - | Some "httpunix" -> + let connect_uri ?ssl_ctx uri = + match (Uri.scheme uri, ssl_ctx) with + | Some "httpunix", _ -> let host = Uri.host_with_default ~default:"localhost" uri in - return @@ `Unix_domain_socket host - | _ -> + let tcp_cfg = Conduit_async.TCP.Unix (Socket.Address.Unix.create host) in + Conduit_async.connect tcp_cfg Conduit_async.TCP.protocol + | Some "https", Some ctx -> + lookup uri + |> Deferred.Or_error.ok_exn + >>= fun (_, addr, port) -> + let tcp_cfg = + let addr = Ipaddr_unix.to_inet_addr addr in + Conduit_async.TCP.Inet (Socket.Address.Inet.create addr ~port) in + Conduit_async.connect (ctx, tcp_cfg) Conduit_async_ssl.TCP.protocol + | Some "https", None -> lookup uri |> Deferred.Or_error.ok_exn >>= fun (host, addr, port) -> - return @@ match (Uri.scheme uri, ssl_config) with - | Some "https", Some config -> - `OpenSSL (addr, port, config) - | Some "https", None -> - let config = Conduit_async.V2.Ssl.Config.create ~hostname:host () in - `OpenSSL (addr, port, config) - | _ -> `TCP (addr, port)) - >>= fun mode -> - Conduit_async.V2.connect ?interrupt mode + let tcp_cfg = + let addr = Ipaddr_unix.to_inet_addr addr in + Conduit_async.TCP.Inet (Socket.Address.Inet.create addr ~port) in + let ctx = Conduit_async_ssl.context ~hostname:host () in + Conduit_async.connect (ctx, tcp_cfg) Conduit_async_ssl.TCP.protocol + | _ -> + lookup uri + |> Deferred.Or_error.ok_exn + >>= fun (_, addr, port) -> + let tcp_cfg = + let addr = Ipaddr_unix.to_inet_addr addr in + Conduit_async.TCP.Inet (Socket.Address.Inet.create addr ~port) in + Conduit_async.connect tcp_cfg Conduit_async.TCP.protocol + + let failwith fmt = Stdlib.Format.kasprintf failwith fmt + + let connect_uri ?ssl_ctx uri = + connect_uri ?ssl_ctx uri >>= function + | Ok flow -> Conduit_async.reader_and_writer_of_flow flow + | Error err -> failwith "%a" Conduit_async.pp_error err end let read_response ic = @@ -65,14 +85,13 @@ let read_response ic = (res, pipe) end -let request ?interrupt ?ssl_config ?uri ?(body=`Empty) req = +let request ?ssl_ctx ?uri ?(body=`Empty) req = (* Connect to the remote side *) let uri = match uri with | Some t -> t | None -> Request.uri req in - Net.connect_uri ?interrupt ?ssl_config uri - >>= fun (ic, oc) -> + Net.connect_uri ?ssl_ctx uri >>= fun (ic, oc) -> try_with (fun () -> Request.write (fun writer -> Body_raw.write_body Request.write_body body writer) req oc @@ -89,10 +108,10 @@ let request ?interrupt ?ssl_config ?uri ?(body=`Empty) req = raise e end -let callv ?interrupt ?ssl_config uri reqs = +let callv ?ssl_ctx uri reqs = let reqs_c = ref 0 in let resp_c = ref 0 in - Net.connect_uri ?interrupt ?ssl_config uri >>= fun (ic, oc) -> + Net.connect_uri ?ssl_ctx uri >>= fun (ic, oc) -> try_with (fun () -> reqs |> Pipe.iter ~f:(fun (req, body) -> @@ -125,7 +144,7 @@ let callv ?interrupt ?ssl_config uri reqs = raise e end -let call ?interrupt ?ssl_config ?headers ?(chunked=false) ?(body=`Empty) meth uri = +let call ?ssl_ctx ?headers ?(chunked=false) ?(body=`Empty) meth uri = (* Create a request, then make the request. Figure out an appropriate transfer encoding *) begin @@ -140,33 +159,33 @@ let call ?interrupt ?ssl_config ?headers ?(chunked=false) ?(body=`Empty) meth ur | false -> (* Use chunked encoding if there is a body *) Request.make_for_client ?headers ~chunked:true meth uri, body end - end >>= fun (req, body) -> request ?interrupt ?ssl_config ~body ~uri req + end >>= fun (req, body) -> request ?ssl_ctx ~body ~uri req -let get ?interrupt ?ssl_config ?headers uri = - call ?interrupt ?ssl_config ?headers ~chunked:false `GET uri +let get ?ssl_ctx ?headers uri = + call ?ssl_ctx ?headers ~chunked:false `GET uri -let head ?interrupt ?ssl_config ?headers uri = - call ?interrupt ?ssl_config ?headers ~chunked:false `HEAD uri +let head ?ssl_ctx ?headers uri = + call ?ssl_ctx ?headers ~chunked:false `HEAD uri >>| fun (res, body) -> (match body with | `Pipe p -> Pipe.close_read p; | _ -> ()); res -let post ?interrupt ?ssl_config ?headers ?(chunked=false) ?body uri = - call ?interrupt ?ssl_config ?headers ~chunked ?body `POST uri +let post ?ssl_ctx ?headers ?(chunked=false) ?body uri = + call ?ssl_ctx ?headers ~chunked ?body `POST uri -let post_form ?interrupt ?ssl_config ?headers ~params uri = +let post_form ?ssl_ctx ?headers ~params uri = let headers = Cohttp.Header.add_opt_unless_exists headers "content-type" "application/x-www-form-urlencoded" in let body = Body.of_string (Uri.encoded_of_query params) in - post ?interrupt ?ssl_config ~headers ~chunked:false ~body uri + post ?ssl_ctx ~headers ~chunked:false ~body uri -let put ?interrupt ?ssl_config ?headers ?(chunked=false) ?body uri = - call ?interrupt ?ssl_config ?headers ~chunked ?body `PUT uri +let put ?ssl_ctx ?headers ?(chunked=false) ?body uri = + call ?ssl_ctx ?headers ~chunked ?body `PUT uri -let patch ?interrupt ?ssl_config ?headers ?(chunked=false) ?body uri = - call ?interrupt ?ssl_config ?headers ~chunked ?body `PATCH uri +let patch ?ssl_ctx ?headers ?(chunked=false) ?body uri = + call ?ssl_ctx ?headers ~chunked ?body `PATCH uri -let delete ?interrupt ?ssl_config ?headers ?(chunked=false) ?body uri = - call ?interrupt ?ssl_config ?headers ~chunked ?body `DELETE uri +let delete ?ssl_ctx ?headers ?(chunked=false) ?body uri = + call ?ssl_ctx ?headers ~chunked ?body `DELETE uri diff --git a/cohttp-async/src/client.mli b/cohttp-async/src/client.mli index 436cc58941..0e22e8affd 100644 --- a/cohttp-async/src/client.mli +++ b/cohttp-async/src/client.mli @@ -1,8 +1,7 @@ (** Send an HTTP request with an arbitrary body The request is sent as-is. *) val request : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> + ?ssl_ctx:Conduit_async_ssl.context -> ?uri:Uri.t -> ?body:Body.t -> Cohttp.Request.t -> @@ -11,8 +10,7 @@ val request : (** Send an HTTP request with arbitrary method and a body Infers the transfer encoding *) val call : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> + ?ssl_ctx:Conduit_async_ssl.context -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -21,32 +19,28 @@ val call : (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t val callv : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> + ?ssl_ctx:Conduit_async_ssl.context -> Uri.t -> (Cohttp.Request.t * Body.t) Async_kernel.Pipe.Reader.t -> (Cohttp.Response.t * Body.t) Async_kernel.Pipe.Reader.t Async_kernel.Deferred.t (** Send an HTTP GET request *) val get : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> + ?ssl_ctx:Conduit_async_ssl.context -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t (** Send an HTTP HEAD request *) val head : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> + ?ssl_ctx:Conduit_async_ssl.context -> ?headers:Cohttp.Header.t -> Uri.t -> Cohttp.Response.t Async_kernel.Deferred.t (** Send an HTTP DELETE request *) val delete : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> + ?ssl_ctx:Conduit_async_ssl.context -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -57,8 +51,7 @@ val delete : [chunked] encoding is off by default as not many servers support it *) val post : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> + ?ssl_ctx:Conduit_async_ssl.context -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -69,8 +62,7 @@ val post : [chunked] encoding is off by default as not many servers support it *) val put : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> + ?ssl_ctx:Conduit_async_ssl.context -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -81,8 +73,7 @@ val put : [chunked] encoding is off by default as not many servers support it *) val patch : - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> + ?ssl_ctx:Conduit_async_ssl.context -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -91,8 +82,7 @@ val patch : (** Send an HTTP POST request in form format *) val post_form: - ?interrupt:unit Async_kernel.Deferred.t -> - ?ssl_config:Conduit_async.V2.Ssl.Config.t -> + ?ssl_ctx:Conduit_async_ssl.context -> ?headers:Cohttp.Header.t -> params:(string * string list) list -> Uri.t -> From 559ac0e78c59b7e12ed90d841880c9750da769ae Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:12:48 +0200 Subject: [PATCH 12/46] Update Cohttp_async.Server with the new way to initialize a server --- cohttp-async/src/server.ml | 87 ++++++++++++++++++++++++------------- cohttp-async/src/server.mli | 41 ++++++----------- 2 files changed, 70 insertions(+), 58 deletions(-) diff --git a/cohttp-async/src/server.ml b/cohttp-async/src/server.ml index 4e53317b1d..c6ff663fb5 100644 --- a/cohttp-async/src/server.ml +++ b/cohttp-async/src/server.ml @@ -12,10 +12,6 @@ module Response = struct include (Make(Io) : module type of Make(Io) with type t := t) end -type ('address, 'listening_on) t = { - server: ('address, 'listening_on) Tcp.Server.t [@sexp.opaque]; -} [@@deriving sexp_of] - type response = Response.t * Body.t [@@deriving sexp_of] type response_action = @@ -30,11 +26,6 @@ type 'r respond_t = -> Cohttp.Code.status_code -> 'r Deferred.t -let close t = Tcp.Server.close t.server -let close_finished t = Tcp.Server.close_finished t.server -let is_closed t = Tcp.Server.is_closed t.server -let listening_on t = Tcp.Server.listening_on t.server - let read_body req rd = match Request.has_body req with (* TODO maybe attempt to read body *) @@ -152,36 +143,70 @@ let respond_with_file ?flush ?headers ?(error_body=error_body_default) filename |Ok res -> return res |Error _exn -> respond_string ~status:`Not_found error_body -type mode = Conduit_async.server - -let create_raw ?max_connections ?backlog ?buffer_age_limit ?(mode=`TCP) - ~on_handler_error where_to_listen handle_request = - Conduit_async.serve ?max_connections ?backlog - ?buffer_age_limit ~on_handler_error mode - where_to_listen (handle_client handle_request) - >>| fun server -> - { server } - - -let create_expert ?max_connections ?backlog - ?buffer_age_limit ?(mode=`TCP) ~on_handler_error where_to_listen handle_request = - create_raw ?max_connections ?backlog - ?buffer_age_limit ~on_handler_error ~mode where_to_listen +let reader_and_writer_of_flow flow = + match Conduit_async.cast flow Conduit_async.TCP.protocol, + Conduit_async.cast flow Conduit_async_ssl.TCP.protocol with + | Some flow, None -> + Async.return (Conduit_async.TCP.Protocol.reader flow, + Conduit_async.TCP.Protocol.writer flow) + | None, Some flow -> + let { Conduit_async_ssl.reader; writer; _ } = flow in + Async.return (reader, writer) + | _ -> Conduit_async.reader_and_writer_of_flow flow + +let create_raw + : type cfg t flow. + ?timeout:int -> + ?backlog:int -> + on_handler_error:[ `Call of Conduit_async.flow -> exn -> unit | `Ignore | `Raise ] -> + protocol:(_, flow) Conduit_async.protocol -> + service:(cfg, t, flow) Conduit_async.Service.service -> + cfg + -> (body:Body.t -> + Conduit_async.flow -> Request.t -> response_action Async_kernel.Deferred.t) + -> unit Async.Condition.t * unit Async.Deferred.t + = fun ?timeout ?backlog + ~on_handler_error ~protocol ~service + cfg handle_request -> + let handler flow = + let flow = Conduit_async.pack protocol flow in + let on_handler_error = match on_handler_error with + | `Ignore -> `Log + | `Call f -> `Call (f flow) + | `Raise -> `Raise in + reader_and_writer_of_flow flow >>= fun (reader, writer) -> + Monitor.try_with + ~rest:on_handler_error + (fun () -> handle_client handle_request flow reader writer) >>= function + | Ok () | Error _ -> Async.return () in + let cfg : cfg = match Conduit_async.Service.equal service Conduit_async.TCP.service with + | Some (Refl, _, _) -> + let Conduit_async.TCP.Listen (_backlog, where) = cfg in + (* XXX(dinosaure): to be compatible with [cohttp-lwt-unix], + * [?backlog] takes the lead over the user's configuration + * on [cohttp-lwt-unix]. We do the same here - even if we + * should introspect [cfg] and let the value given by the + * user. *) + Conduit_async.TCP.Listen (backlog, where) + | _ -> cfg in + Conduit_async.serve ?timeout ~service ~handler cfg + +let create_expert ?timeout ?backlog + ~on_handler_error ~protocol ~service cfg handle_request = + create_raw ?timeout ?backlog + ~on_handler_error ~protocol ~service cfg handle_request let create - ?max_connections - ?backlog - ?buffer_age_limit - ?(mode = `TCP) + ?timeout ?backlog ~on_handler_error - where_to_listen + ~protocol ~service cfg handle_request = let handle_request ~body address request = handle_request ~body address request >>| fun r -> `Response r in - create_raw ?max_connections ?backlog - ?buffer_age_limit ~on_handler_error ~mode where_to_listen + create_raw ?timeout ?backlog + ~on_handler_error ~protocol ~service cfg handle_request diff --git a/cohttp-async/src/server.mli b/cohttp-async/src/server.mli index 17b606870e..6708f1ae0c 100644 --- a/cohttp-async/src/server.mli +++ b/cohttp-async/src/server.mli @@ -1,13 +1,3 @@ -type ('address, 'listening_on) t constraint 'address - = [< Async_unix.Socket.Address.t ] - [@@deriving sexp_of] - -val close : (_, _) t -> unit Async_kernel.Deferred.t -val close_finished : (_, _) t -> unit Async_kernel.Deferred.t -val is_closed : (_, _) t -> bool - -val listening_on : (_, 'listening_on) t -> 'listening_on - type response = Response.t * Body.t [@@deriving sexp_of] type 'r respond_t = @@ -62,33 +52,30 @@ val respond_with_file : ?headers:Cohttp.Header.t -> ?error_body:string -> string -> response Async_kernel.Deferred.t -type mode = Conduit_async.server - (** Build a HTTP server and expose the [IO.ic] and [IO.oc]s, based on the [Tcp.Server] interface. *) val create_expert : - ?max_connections:int -> + ?timeout:int -> ?backlog:int -> - ?buffer_age_limit:Async_unix.Writer.buffer_age_limit -> - ?mode:mode -> - on_handler_error:[ `Call of 'address -> exn -> unit + on_handler_error:[ `Call of Conduit_async.flow -> exn -> unit | `Ignore | `Raise ] -> - ('address, 'listening_on) Async.Tcp.Where_to_listen.t - -> (body:Body.t -> 'address -> Request.t - -> response_action Async_kernel.Deferred.t) - -> ('address, 'listening_on) t Async_kernel.Deferred.t + protocol:(_, 'flow) Conduit_async.protocol -> + service:('cfg, 't, 'flow) Conduit_async.Service.service -> + 'cfg + -> (body:Body.t -> Conduit_async.flow -> Request.t -> response_action Async_kernel.Deferred.t) + -> unit Async.Condition.t * unit Async.Deferred.t (** Build a HTTP server, based on the [Tcp.Server] interface *) val create : - ?max_connections:int -> + ?timeout:int -> ?backlog:int -> - ?buffer_age_limit:Async_unix.Writer.buffer_age_limit -> - ?mode:Conduit_async.server -> - on_handler_error:[ `Call of 'address -> exn -> unit + on_handler_error:[ `Call of Conduit_async.flow -> exn -> unit | `Ignore | `Raise ] -> - ('address, 'listening_on) Async.Tcp.Where_to_listen.t - -> (body:Body.t -> 'address -> Request.t -> response Async_kernel.Deferred.t) - -> ('address, 'listening_on) t Async_kernel.Deferred.t + protocol:(_, 'flow) Conduit_async.protocol -> + service:('cfg, 't, 'flow) Conduit_async.Service.service -> + 'cfg + -> (body:Body.t -> Conduit_async.flow -> Request.t -> response Async_kernel.Deferred.t) + -> unit Async.Condition.t * unit Async.Deferred.t From c20c68cc88ba79c520a547d9ed1b425bb70df5f8 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:13:11 +0200 Subject: [PATCH 13/46] Update binaries provided by cohttp-async --- cohttp-async/bin/cohttp_server_async.ml | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/cohttp-async/bin/cohttp_server_async.ml b/cohttp-async/bin/cohttp_server_async.ml index c6c0e514d3..5168d05323 100644 --- a/cohttp-async/bin/cohttp_server_async.ml +++ b/cohttp-async/bin/cohttp_server_async.ml @@ -116,14 +116,19 @@ let start_server docroot port index cert_file key_file verbose () = let mode_str = (match mode with `OpenSSL _ -> "HTTPS" | `TCP -> "HTTP") in Logs.info (fun f -> f "Listening for %s requests on %d" mode_str port); let info = Printf.sprintf "Served by Cohttp/Async listening on %d" port in - Server.create - ~on_handler_error:(`Call (fun addr exn -> + let _never, server = Server.create + ~on_handler_error:(`Call (fun flow exn -> + let addr = match Conduit_async.cast flow Conduit_async.TCP.protocol with + | Some flow -> Conduit_async.TCP.Protocol.address flow + | None -> assert false (* XXX(dinosaure): safe when we initialize the server with + [Conduit_async_tcp.service] *) in Logs.err (fun f -> f "Error from %s" (Socket.Address.to_string addr)); Logs.err (fun f -> f "%s" @@ Exn.to_string exn))) - ~mode - (Tcp.Where_to_listen.of_port port) - (handler ~info ~docroot ~index) >>= fun _serv -> - Deferred.never () + ~protocol:Conduit_async.TCP.protocol + ~service:Conduit_async.TCP.service + (Conduit_async.TCP.Listen (None, Tcp.Where_to_listen.of_port port)) + (handler ~info ~docroot ~index) in + server let () = let open Async_command in From 60754849c8cda99c378ee1f1d276a4d01845040f Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:15:23 +0200 Subject: [PATCH 14/46] Update cohttp-lwt-unix tests (avoid overlap of ports used and use localhost instead 0.0.0.0) --- cohttp-lwt-unix/test/test_sanity.ml | 9 +-------- cohttp-lwt-unix/test/test_sanity_noisy.ml | 14 ++++++++++---- cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml | 15 ++++++++++++--- 3 files changed, 23 insertions(+), 15 deletions(-) diff --git a/cohttp-lwt-unix/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml index e5f0c402ca..336519c0a1 100644 --- a/cohttp-lwt-unix/test/test_sanity.ml +++ b/cohttp-lwt-unix/test/test_sanity.ml @@ -22,13 +22,6 @@ let () = Logs.set_level (Some Warning) let cond = Lwt_condition.create () -let check_logs test () = - let old = Logs.(warn_count () + err_count ()) in - test () >|= fun () -> - let new_errs = Logs.(warn_count () + err_count ()) - old in - if new_errs > 0 then - Fmt.failwith "Test produced %d log messages at level >= warn" new_errs - let server = List.map const [ (* t *) Server.respond_string ~status:`OK ~body:message (); @@ -192,4 +185,4 @@ let ts = ] end -let _ = ts |> run_async_tests |> Lwt_main.run \ No newline at end of file +let _ = ts |> run_async_tests |> Lwt_main.run diff --git a/cohttp-lwt-unix/test/test_sanity_noisy.ml b/cohttp-lwt-unix/test/test_sanity_noisy.ml index 7566952cbb..909857c5c2 100644 --- a/cohttp-lwt-unix/test/test_sanity_noisy.ml +++ b/cohttp-lwt-unix/test/test_sanity_noisy.ml @@ -44,12 +44,18 @@ let server_noisy = let ts_noisy = Cohttp_lwt_unix_test.test_server_s ~port:10193 server_noisy begin fun uri -> + let resolvers = match Uri.port uri with + | Some port -> + Cohttp_lwt_unix.Net.empty + |> Conduit_lwt.add ~priority:0 Conduit_lwt.TCP.protocol + (Conduit_lwt.TCP.resolve ~port) + | None -> Cohttp_lwt_unix.Net.empty in let empty_chunk () = - Client.get uri >>= fun (_, body) -> + Client.get ~resolvers uri >>= fun (_, body) -> body |> Body.to_string >|= fun body -> assert_equal body (String.concat "" chunk_body) in let not_modified_has_no_body () = - Client.get uri >>= fun (resp, body) -> + Client.get ~resolvers uri >>= fun (resp, body) -> assert_equal (Response.status resp) `Not_modified; let headers = Response.headers resp in assert_equal ~printer:Transfer.string_of_encoding @@ -63,7 +69,7 @@ let ts_noisy = ~mode:Lwt_io.Output fname >>= fun oc -> Lwt_io.write_line oc "never read" >>= fun () -> Lwt_io.close oc >>= fun () -> - Client.post uri ~body:(Body.of_string fname) + Client.post ~resolvers uri ~body:(Body.of_string fname) >>= begin fun (resp, body) -> assert_equal ~printer:Code.string_of_status (Response.status resp) `Internal_server_error; @@ -79,4 +85,4 @@ let ts_noisy = ] end -let _ = ts_noisy |> run_async_tests |> Lwt_main.run \ No newline at end of file +let _ = ts_noisy |> run_async_tests |> Lwt_main.run diff --git a/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml b/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml index 114e239223..621381bf00 100644 --- a/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml +++ b/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml @@ -28,15 +28,24 @@ let response_sequence = Cohttp_test.response_sequence Lwt.fail_with let () = Debug.activate_debug () let () = Logs.set_level (Some Info) +let get_port = + let port = ref 4000 in + (fun () -> let v = !port in incr port ; v) + let temp_server ?port spec callback = let port = match port with - | None -> Cohttp_test.next_port () + | None -> get_port () | Some p -> p in let server = Server.make_response_action ~callback:(fun _ req body -> spec req body) () in - let uri = Uri.of_string ("http://0.0.0.0:" ^ (string_of_int port)) in + let uri = Uri.of_string ("http://localhost:" ^ (string_of_int port)) in let server_failed, server_failed_wake = Lwt.task () in let server = Lwt.catch - (fun () -> Server.create ~mode:(`TCP (`Port port)) server) + (fun () -> + let open Conduit_lwt.TCP in + let tcp_config = + { sockaddr= Unix.ADDR_INET (Unix.inet_addr_any, port) + ; capacity= 40 } in + Cohttp_lwt_unix.Server.create tcp_config protocol service server) (function | Lwt.Canceled -> Lwt.return_unit | x -> Lwt.wakeup_exn server_failed_wake x; Lwt.fail x) From b6afe08e06bb2aa5eb0c7ee4c82f4da3724d49f7 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:16:03 +0200 Subject: [PATCH 15/46] Update cohttp-async tests (avoid overlap of ports used and use localhost instead 0.0.0.0) --- cohttp_async_test/src/cohttp_async_test.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/cohttp_async_test/src/cohttp_async_test.ml b/cohttp_async_test/src/cohttp_async_test.ml index 463b26446c..e55a87a8da 100644 --- a/cohttp_async_test/src/cohttp_async_test.ml +++ b/cohttp_async_test/src/cohttp_async_test.ml @@ -31,14 +31,14 @@ let temp_server ?port spec callback = let port = match port with | None -> get_port () | Some p -> p in - let uri = Uri.of_string ("http://0.0.0.0:" ^ (Int.to_string port)) in - let server = Server.create_expert ~on_handler_error:`Raise - (Async.Tcp.Where_to_listen.of_port port) + let uri = Uri.of_string ("http://localhost:" ^ (Int.to_string port)) in + let stop, server = Server.create_expert ~on_handler_error:`Raise + ~protocol:Conduit_async.TCP.protocol ~service:Conduit_async.TCP.service + (Conduit_async.TCP.Listen (None, Async.Tcp.Where_to_listen.of_port port)) (fun ~body _sock req -> spec req body) in - server >>= fun server -> - callback uri >>= fun res -> - Server.close server >>| fun () -> - res + Async.Deferred.both server (callback uri >>= fun res -> + Async.Condition.broadcast stop () ; Async.return res) + >>= fun ((), res) -> Async.return res let test_server_s ?port ?(name="Cohttp Server Test") spec f = temp_server ?port spec begin fun uri -> From c1e43a17d1d226649339e4e39ff2c59d6c876dcc Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:17:23 +0200 Subject: [PATCH 16/46] Add a resolver to run tests on cohttp-lwt-unix --- cohttp-lwt-unix/test/test_sanity.ml | 37 ++++++++++++++++++++++------- 1 file changed, 28 insertions(+), 9 deletions(-) diff --git a/cohttp-lwt-unix/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml index 336519c0a1..18fc02ea60 100644 --- a/cohttp-lwt-unix/test/test_sanity.ml +++ b/cohttp-lwt-unix/test/test_sanity.ml @@ -88,10 +88,29 @@ let server = ] |> response_sequence +let check_logs test () = + let old = Logs.(warn_count () + err_count ()) in + test () >|= fun () -> + let new_errs = Logs.(warn_count () + err_count ()) - old in + if new_errs > 0 then + Fmt.failwith "Test produced %d log messages at level >= warn" new_errs + +let http_resolver ?(port= 80) domain_name = + try let inet_addr = Unix.inet_addr_of_string (Domain_name.to_string domain_name) in + Lwt.return_some (Unix.ADDR_INET (inet_addr, port)) + with _ -> + Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function + | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> + Lwt.return_some (Unix.ADDR_INET (h_addr_list.(0), port)) + | _ -> Lwt.return_none + let ts = Cohttp_lwt_unix_test.test_server_s server begin fun uri -> + let resolvers = Conduit_lwt.register_resolver + ~key:Conduit_lwt_unix_tcp.endpoint (http_resolver ?port:(Uri.port uri)) + Conduit.empty in let t () = - Client.get uri >>= fun (_, body) -> + Client.get ~resolvers uri >>= fun (_, body) -> body |> Body.to_string >|= fun body -> assert_equal body message in let pipelined_chunk () = @@ -103,7 +122,7 @@ let ts = Request.make ~meth:`HEAD uri, `Empty; ] in let counter = ref 0 in - Client.callv uri (Lwt_stream.of_list reqs) >>= fun resps -> + Client.callv ~resolvers uri (Lwt_stream.of_list reqs) >>= fun resps -> Lwt_stream.iter_s (fun (_, rbody) -> rbody |> Body.to_string >|= fun rbody -> begin match !counter with @@ -121,7 +140,7 @@ let ts = let (reqs, push) = Lwt_stream.create () in push (Some (r 1)); push (Some (r 2)); - Client.callv uri reqs >>= fun resps -> + Client.callv ~resolvers uri reqs >>= fun resps -> let resps = Lwt_stream.map_s (fun (_, b) -> Body.to_string b) resps in Lwt_stream.fold (fun b i -> Logs.info (fun f -> f "Request %i\n" i); @@ -141,29 +160,29 @@ let ts = assert_equal l 3 in let massive_chunked () = - Client.get uri >>= fun (_resp, body) -> + Client.get ~resolvers uri >>= fun (_resp, body) -> Body.to_string body >|= fun body -> assert_equal ~printer:string_of_int (1000 * 64) (String.length body) in let test_no_leak () = let stream = Array.init leak_repeat (fun _ -> uri) |> Lwt_stream.of_array in Lwt_stream.fold_s (fun uri () -> - Client.head uri >>= fun resp_head -> + Client.head ~resolvers uri >>= fun resp_head -> assert_equal (Response.status resp_head) `OK; - Client.get uri >>= fun (resp_get, body) -> + Client.get ~resolvers uri >>= fun (resp_get, body) -> assert_equal (Response.status resp_get) `OK; Body.drain_body body) stream () in let expert_pipelined () = let printer x = x in - Client.get uri >>= fun (_rsp, body) -> + Client.get ~resolvers uri >>= fun (_rsp, body) -> Body.to_string body >>= fun body -> assert_equal ~printer "expert 1" body; - Client.get uri >>= fun (_rsp, body) -> + Client.get ~resolvers uri >>= fun (_rsp, body) -> Body.to_string body >|= fun body -> assert_equal ~printer "expert 2" body in let client_close () = - Cohttp_lwt_unix.Net.(connect_uri ~ctx:default_ctx) uri >>= fun (_conn, ic, oc) -> + Cohttp_lwt_unix.Net.(connect_uri ~resolvers) uri >>= fun (_conn, ic, oc) -> let req = Cohttp.Request.make_for_client ~chunked:false `GET (Uri.with_path uri "/test.html") in Request.write (fun _writer -> Lwt.return_unit) req oc >>= fun () -> From 2cef3c5438454b7754db3b3ffe73062d08c69e4b Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:18:05 +0200 Subject: [PATCH 17/46] Fixes examples with cohttp-async to be able to compile the project --- examples/async/hello_world.ml | 8 +++---- examples/async/receive_post.ml | 11 +++++----- examples/async/s3_cp.ml | 39 +++++++++++++++++----------------- 3 files changed, 30 insertions(+), 28 deletions(-) diff --git a/examples/async/hello_world.ml b/examples/async/hello_world.ml index b566fb6646..7241ac6bc8 100644 --- a/examples/async/hello_world.ml +++ b/examples/async/hello_world.ml @@ -1,7 +1,6 @@ (* This file is in the public domain *) open Base -open Async_kernel open Cohttp_async (* given filename: hello_world.ml compile with: @@ -22,9 +21,10 @@ let handler ~body:_ _sock req = let start_server port () = Caml.Printf.eprintf "Listening for HTTP on port %d\n" port; Caml.Printf.eprintf "Try 'curl http://localhost:%d/test?hello=xyz'\n%!" port; - Cohttp_async.Server.create ~on_handler_error:`Raise - (Async.Tcp.Where_to_listen.of_port port) handler - >>= fun _ -> Deferred.never () + let _never, server = Cohttp_async.Server.create ~on_handler_error:`Raise + ~protocol:Conduit_async.TCP.protocol ~service:Conduit_async.TCP.service + (Conduit_async.TCP.Listen (None, Async.Tcp.Where_to_listen.of_port port)) handler in + server let () = let module Command = Async_command in diff --git a/examples/async/receive_post.ml b/examples/async/receive_post.ml index 91ef78b918..5f3690215f 100644 --- a/examples/async/receive_post.ml +++ b/examples/async/receive_post.ml @@ -8,16 +8,17 @@ open Cohttp_async let start_server port () = Caml.Printf.eprintf "Listening for HTTP on port %d\n" port; Caml.Printf.eprintf "Try 'curl -X POST -d 'foo bar' http://localhost:%d\n" port; - Cohttp_async.Server.create ~on_handler_error:`Raise - (Async.Tcp.Where_to_listen.of_port port) (fun ~body _ req -> + let _never, server = Cohttp_async.Server.create ~on_handler_error:`Raise + ~protocol:Conduit_async.TCP.protocol ~service:Conduit_async.TCP.service + (Conduit_async.TCP.Listen (None, Async.Tcp.Where_to_listen.of_port port)) + (fun ~body _ req -> match req |> Cohttp.Request.meth with | `POST -> (Body.to_string body) >>= (fun body -> Caml.Printf.eprintf "Body: %s" body; Server.respond `OK) - | _ -> Server.respond `Method_not_allowed - ) - >>= fun _ -> Deferred.never () + | _ -> Server.respond `Method_not_allowed) in + server let () = let module Command = Async_command in diff --git a/examples/async/s3_cp.ml b/examples/async/s3_cp.ml index a6f7446a1d..81efea28fc 100644 --- a/examples/async/s3_cp.ml +++ b/examples/async/s3_cp.ml @@ -45,7 +45,7 @@ open Base open Core -open Async_kernel +open Async open Cohttp open Cohttp_async @@ -78,9 +78,9 @@ module Compat = struct if is_hex(String.get s (i+1)) && is_hex(String.get s (i+2)) then Buffer.add_char buf c else - Buffer.add_bytes buf "%25" + Buffer.add_string buf "%25" end - | _ -> Buffer.add_bytes buf (Printf.sprintf "%%%X" (Char.to_int c)) + | _ -> Buffer.add_string buf (Printf.sprintf "%%%X" (Char.to_int c)) done; Buffer.contents buf @@ -108,7 +108,7 @@ module Compat = struct URI.encoded_of_query encodes [""] as ?a=, and [] as ?a. *) Uri.query uri - |> List.sort ~cmp:ksrt + |> List.sort ~compare:ksrt |> List.map ~f:(fun (k,v) -> (k, match v with [] -> [""] | x -> x)) |> Uri.encoded_of_query @@ -180,7 +180,7 @@ module Auth = struct let digest s = (* string -> sha256 as a hex string *) - Nocrypto.Hash.(digest `SHA256 (Cstruct.of_string s)) + Mirage_crypto.Hash.(digest `SHA256 (Cstruct.of_string s)) |> Compat.cstruct_to_hex_string let make_amz_headers ?body time = @@ -212,7 +212,7 @@ module Auth = struct (* Sort query string in alphabetical order by key *) let canonical_query = Compat.encode_query_string uri in let sorted_headers = Header.to_list request.headers - |> List.sort ~cmp:ksrt in + |> List.sort ~compare:ksrt in let canonical_headers = sorted_headers |> List.fold ~init:"" ~f:(fun acc (k,v) -> acc ^ @@ -244,7 +244,7 @@ module Auth = struct Printf.sprintf "AWS4-HMAC-SHA256\n%s\n%s\n%s" time_str scope_str hashed_req let make_signing_key ?date ~region ~service ~secret_access_key = - let mac k v = Nocrypto.Hash.(mac `SHA256 + let mac k v = Mirage_crypto.Hash.(mac `SHA256 ~key:k (Cstruct.of_string v)) in let date' = match date with @@ -269,7 +269,7 @@ module Auth = struct (string_of_region region) (string_of_service service) in - let signature = Nocrypto.Hash.(mac `SHA256 + let signature = Mirage_crypto.Hash.(mac `SHA256 ~key:signing_key (Cstruct.of_string string_to_sign)) in let auth_header = Printf.sprintf @@ -343,7 +343,7 @@ let determine_paths src dst = | (false, false) -> failwith "Use cp(1) :)" | (true, true) -> failwith "Does not support copying from s3 to s3" -let run region_str aws_access_key aws_secret_key src dst () = +let main region_str aws_access_key aws_secret_key src dst () = (* nb client does not support redirects or preflight 100 *) let open S3 in let region = region_of_string region_str in @@ -376,14 +376,15 @@ let run region_str aws_access_key aws_secret_key src dst () = end let () = - Command.async + let open Async_command in + async_spec ~summary:"Simple command line client that copies files to/from S3" - Command.Spec.(empty - +> flag "-r" (optional_with_default "us-east-1" string) - ~doc:"string AWS Region" - +> anon ("aws_access_key" %: string) - +> anon ("aws_secret_key" %: string) - +> anon ("src" %: string) - +> anon ("dst" %: string) - ) run - |> Command.run + Spec.(empty + +> flag "-r" (optional_with_default "us-east-1" string) + ~doc:"string AWS Region" + +> anon ("aws_access_key" %: string) + +> anon ("aws_secret_key" %: string) + +> anon ("src" %: string) + +> anon ("dst" %: string) + ) main + |> run From f9fbaf74b6b843306233e2e671eb2eb2375321a8 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:21:39 +0200 Subject: [PATCH 18/46] Update to dune.2.0 and apply dune @fmt on dune files --- cohttp-async/bin/dune | 10 +++---- cohttp-async/src/dune | 13 +++++---- cohttp-async/test/dune | 15 +++++----- cohttp-lwt-jsoo/src/dune | 13 +++++---- cohttp-lwt-unix/bin/dune | 10 +++---- cohttp-lwt-unix/src/dune | 13 +++++---- cohttp-lwt-unix/test/dune | 54 +++++++++++++++++++---------------- cohttp-lwt/src/dune | 11 +++---- cohttp-mirage/src/dune | 12 ++++---- cohttp-top/src/dune | 6 ++-- cohttp/scripts/dune | 2 +- cohttp/src/dune | 27 ++++++++++++------ cohttp/test/dune | 52 +++++++++++++++++---------------- cohttp_async_test/src/dune | 6 ++-- cohttp_lwt_unix_test/src/dune | 6 ++-- cohttp_server/dune | 6 ++-- cohttp_test/src/dune | 6 ++-- dune-project | 2 +- examples/async/dune | 10 +++---- 19 files changed, 149 insertions(+), 125 deletions(-) diff --git a/cohttp-async/bin/dune b/cohttp-async/bin/dune index 5c06d2b461..80e12e9ae3 100644 --- a/cohttp-async/bin/dune +++ b/cohttp-async/bin/dune @@ -1,6 +1,6 @@ (executables - (names cohttp_curl_async cohttp_server_async) - (package cohttp-async) - (public_names cohttp-curl-async cohttp-server-async) - (libraries cohttp-async async_kernel async.async_command async_unix base - cohttp cohttp_server fmt.tty)) + (names cohttp_curl_async cohttp_server_async) + (package cohttp-async) + (public_names cohttp-curl-async cohttp-server-async) + (libraries cohttp-async async_kernel async.async_command async_unix base + cohttp cohttp_server fmt.tty)) diff --git a/cohttp-async/src/dune b/cohttp-async/src/dune index 1b2500a30f..0303c6761e 100644 --- a/cohttp-async/src/dune +++ b/cohttp-async/src/dune @@ -1,7 +1,8 @@ (library - (name cohttp_async) - (synopsis "Async backend") - (public_name cohttp-async) - (libraries logs.fmt base fmt async_unix async_kernel uri - uri.services uri-sexp ipaddr.unix conduit-async magic-mime cohttp) - (preprocess (pps ppx_sexp_conv))) + (name cohttp_async) + (synopsis "Async backend") + (public_name cohttp-async) + (libraries logs.fmt base fmt async_unix async_kernel uri uri.services + uri-sexp ipaddr.unix conduit-async conduit-async-ssl magic-mime cohttp) + (preprocess + (pps ppx_sexp_conv))) diff --git a/cohttp-async/test/dune b/cohttp-async/test/dune index a8be8427d8..085cf34eb3 100644 --- a/cohttp-async/test/dune +++ b/cohttp-async/test/dune @@ -1,9 +1,10 @@ (executable - (name test_async_integration) - (libraries cohttp_async_test async_unix base core async_kernel oUnit - cohttp-async)) + (name test_async_integration) + (libraries cohttp_async_test async_unix base core async_kernel oUnit + cohttp-async)) -(alias - (name runtest) - (package cohttp-async) - (action (run ./test_async_integration.exe))) +(rule + (alias runtest) + (package cohttp-async) + (action + (run ./test_async_integration.exe))) diff --git a/cohttp-lwt-jsoo/src/dune b/cohttp-lwt-jsoo/src/dune index e5ffd37c70..161ba3e40f 100644 --- a/cohttp-lwt-jsoo/src/dune +++ b/cohttp-lwt-jsoo/src/dune @@ -1,7 +1,8 @@ (library - (name cohttp_lwt_jsoo) - (public_name cohttp-lwt-jsoo) - (synopsis "XHR/Lwt based http client") - (wrapped false) - (preprocess (pps js_of_ocaml-ppx)) - (libraries js_of_ocaml cohttp-lwt)) + (name cohttp_lwt_jsoo) + (public_name cohttp-lwt-jsoo) + (synopsis "XHR/Lwt based http client") + (wrapped false) + (preprocess + (pps js_of_ocaml-ppx)) + (libraries js_of_ocaml cohttp-lwt)) diff --git a/cohttp-lwt-unix/bin/dune b/cohttp-lwt-unix/bin/dune index 833d0986a5..afb381dfeb 100644 --- a/cohttp-lwt-unix/bin/dune +++ b/cohttp-lwt-unix/bin/dune @@ -1,6 +1,6 @@ (executables - (names cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt) - (libraries cohttp-lwt-unix cohttp_server logs logs.lwt logs.fmt logs.cli - cmdliner) - (package cohttp-lwt-unix) - (public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt)) + (names cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt) + (libraries cohttp-lwt-unix cohttp_server logs logs.lwt logs.fmt logs.cli + cmdliner conduit-lwt conduit-lwt-ssl) + (package cohttp-lwt-unix) + (public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt)) diff --git a/cohttp-lwt-unix/src/dune b/cohttp-lwt-unix/src/dune index 1ce34e90af..81a100fa50 100644 --- a/cohttp-lwt-unix/src/dune +++ b/cohttp-lwt-unix/src/dune @@ -1,7 +1,8 @@ (library - (name cohttp_lwt_unix) - (public_name cohttp-lwt-unix) - (synopsis "Lwt/Unix backend for Cohttp") - (preprocess (pps ppx_sexp_conv)) - (libraries fmt logs logs.lwt conduit-lwt-unix magic-mime lwt.unix cohttp - cohttp-lwt)) + (name cohttp_lwt_unix) + (public_name cohttp-lwt-unix) + (synopsis "Lwt/Unix backend for Cohttp") + (preprocess + (pps ppx_sexp_conv)) + (libraries fmt logs logs.lwt conduit-lwt conduit-lwt-ssl magic-mime lwt.unix + cohttp cohttp-lwt)) diff --git a/cohttp-lwt-unix/test/dune b/cohttp-lwt-unix/test/dune index 27f300a195..163c21cdcf 100644 --- a/cohttp-lwt-unix/test/dune +++ b/cohttp-lwt-unix/test/dune @@ -1,39 +1,43 @@ (executable - (name test_parser) - (modules test_parser) - (libraries cohttp-lwt-unix oUnit lwt.unix)) + (name test_parser) + (modules test_parser) + (libraries cohttp-lwt-unix oUnit lwt.unix)) -(alias - (name runtest) - (package cohttp-lwt-unix) - (action (run ./test_parser.exe))) +(rule + (alias runtest) + (package cohttp-lwt-unix) + (action + (run ./test_parser.exe))) (executable - (modules test_sanity) - (name test_sanity) + (modules test_sanity) + (name test_sanity) (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) (executable - (modules test_sanity_noisy) - (name test_sanity_noisy) + (modules test_sanity_noisy) + (name test_sanity_noisy) (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) -(alias - (name runtest) - (package cohttp-lwt-unix) - (action (run ./test_sanity.exe))) +(rule + (alias runtest) + (package cohttp-lwt-unix) + (action + (run ./test_sanity.exe))) -(alias - (name runtest) - (package cohttp-lwt-unix) - (action (run ./test_sanity_noisy.exe))) +(rule + (alias runtest) + (package cohttp-lwt-unix) + (action + (run ./test_sanity_noisy.exe))) (executable - (modules test_body) - (name test_body) + (modules test_body) + (name test_body) (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) -(alias - (name runtest) - (package cohttp-lwt-unix) - (action (run ./test_body.exe))) +(rule + (alias runtest) + (package cohttp-lwt-unix) + (action + (run ./test_body.exe))) diff --git a/cohttp-lwt/src/dune b/cohttp-lwt/src/dune index 0a0e22bc12..432e4d981d 100644 --- a/cohttp-lwt/src/dune +++ b/cohttp-lwt/src/dune @@ -1,6 +1,7 @@ (library - (name cohttp_lwt) - (public_name cohttp-lwt) - (synopsis "Lwt backend") - (preprocess (pps ppx_sexp_conv)) - (libraries lwt uri cohttp logs logs.lwt)) + (name cohttp_lwt) + (public_name cohttp-lwt) + (synopsis "Lwt backend") + (preprocess + (pps ppx_sexp_conv)) + (libraries lwt uri cohttp logs logs.lwt)) diff --git a/cohttp-mirage/src/dune b/cohttp-mirage/src/dune index 95fb33a2ab..4e74c9e5ce 100644 --- a/cohttp-mirage/src/dune +++ b/cohttp-mirage/src/dune @@ -1,7 +1,7 @@ (library - (name cohttp_mirage) - (public_name cohttp-mirage) - (synopsis "Mirage backend for cohttp") - (wrapped false) - (libraries cohttp-lwt mirage-channel conduit-mirage sexplib - mirage-flow magic-mime astring)) + (name cohttp_mirage) + (public_name cohttp-mirage) + (synopsis "Mirage backend for cohttp") + (wrapped false) + (libraries conduit-mirage.flow cohttp-lwt mirage-channel conduit-mirage + mirage-kv mirage-flow magic-mime astring)) diff --git a/cohttp-top/src/dune b/cohttp-top/src/dune index 8053786577..e81b71ccb9 100644 --- a/cohttp-top/src/dune +++ b/cohttp-top/src/dune @@ -1,4 +1,4 @@ (library - (name cohttp_top) - (public_name cohttp-top) - (libraries cohttp compiler-libs.toplevel)) \ No newline at end of file + (name cohttp_top) + (public_name cohttp-top) + (libraries cohttp compiler-libs.toplevel)) diff --git a/cohttp/scripts/dune b/cohttp/scripts/dune index 0c5ac7145c..c5afa948c2 100644 --- a/cohttp/scripts/dune +++ b/cohttp/scripts/dune @@ -1,3 +1,3 @@ (executable - (name generate) + (name generate) (libraries jsonm)) diff --git a/cohttp/src/dune b/cohttp/src/dune index a3a15d0701..8a2f06232e 100644 --- a/cohttp/src/dune +++ b/cohttp/src/dune @@ -1,16 +1,27 @@ -(rule (with-stdout-to conf.ml (echo "let version = \"%{version:cohttp}\""))) +(rule + (with-stdout-to + conf.ml + (echo "let version = \"%{version:cohttp}\""))) (rule - (targets code.ml code.mli) - (deps ../scripts/generate.exe (source_tree "../scripts/codes")) - (action (chdir "../scripts" (run ./generate.exe)))) + (targets code.ml code.mli) + (deps + ../scripts/generate.exe + (source_tree "../scripts/codes")) + (action + (chdir + "../scripts" + (run ./generate.exe)))) (library - (name cohttp) + (name cohttp) (public_name cohttp) (synopsis "Co-operative Client/Server HTTP library.") - (preprocess (pps ppx_fields_conv ppx_sexp_conv)) - (libraries re stringext uri uri-sexp fieldslib sexplib0 bytes base64 stdlib-shims)) + (preprocess + (pps ppx_fields_conv ppx_sexp_conv)) + (libraries re stringext uri uri-sexp fieldslib sexplib0 bytes base64 + stdlib-shims)) + +(ocamllex accept_lexer) -(ocamllex accept_lexer) (ocamlyacc accept_parser) diff --git a/cohttp/test/dune b/cohttp/test/dune index ef7adfb384..4632550955 100644 --- a/cohttp/test/dune +++ b/cohttp/test/dune @@ -1,39 +1,43 @@ (executable - (name test_accept) - (modules test_accept) + (name test_accept) + (modules test_accept) (libraries cohttp alcotest fmt)) -(alias - (name runtest) - (package cohttp) - (action (run ./test_accept.exe))) +(rule + (alias runtest) + (package cohttp) + (action + (run ./test_accept.exe))) (executable - (name test_header) - (modules test_header) + (name test_header) + (modules test_header) (libraries cohttp alcotest fmt)) -(alias - (name runtest) - (package cohttp) - (action (run ./test_header.exe))) +(rule + (alias runtest) + (package cohttp) + (action + (run ./test_header.exe))) (executable - (name test_request) - (modules test_request) + (name test_request) + (modules test_request) (libraries cohttp alcotest fmt)) -(alias - (name runtest) - (package cohttp) - (action (run ./test_request.exe))) +(rule + (alias runtest) + (package cohttp) + (action + (run ./test_request.exe))) (executable - (name test_body) - (modules test_body) + (name test_body) + (modules test_body) (libraries cohttp alcotest fmt)) -(alias - (name runtest) - (package cohttp) - (action (run ./test_body.exe))) +(rule + (alias runtest) + (package cohttp) + (action + (run ./test_body.exe))) diff --git a/cohttp_async_test/src/dune b/cohttp_async_test/src/dune index 0c77334d59..a652ed2385 100644 --- a/cohttp_async_test/src/dune +++ b/cohttp_async_test/src/dune @@ -1,4 +1,4 @@ (library - (name cohttp_async_test) - (wrapped false) - (libraries fmt.tty uri.services async_kernel cohttp_test cohttp-async)) + (name cohttp_async_test) + (wrapped false) + (libraries fmt.tty uri.services async_kernel cohttp_test cohttp-async)) diff --git a/cohttp_lwt_unix_test/src/dune b/cohttp_lwt_unix_test/src/dune index a9e60e8a75..cc9c9ecff7 100644 --- a/cohttp_lwt_unix_test/src/dune +++ b/cohttp_lwt_unix_test/src/dune @@ -1,4 +1,4 @@ (library - (name cohttp_lwt_unix_test) - (wrapped false) - (libraries cohttp-lwt-unix cohttp_test oUnit)) \ No newline at end of file + (name cohttp_lwt_unix_test) + (wrapped false) + (libraries conduit-lwt cohttp-lwt-unix cohttp_test oUnit)) diff --git a/cohttp_server/dune b/cohttp_server/dune index 0408657ea0..863ac8d6f0 100644 --- a/cohttp_server/dune +++ b/cohttp_server/dune @@ -1,4 +1,4 @@ (library - (name cohttp_server) - (wrapped false) - (libraries cohttp)) \ No newline at end of file + (name cohttp_server) + (wrapped false) + (libraries cohttp)) diff --git a/cohttp_test/src/dune b/cohttp_test/src/dune index 06963a0a86..8cd1bb10a7 100644 --- a/cohttp_test/src/dune +++ b/cohttp_test/src/dune @@ -1,4 +1,4 @@ (library - (name cohttp_test) - (wrapped false) - (libraries cohttp oUnit)) + (name cohttp_test) + (wrapped false) + (libraries cohttp oUnit)) diff --git a/dune-project b/dune-project index d5ee0b5f46..ad62607fd3 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,2 @@ -(lang dune 1.1) +(lang dune 2.0) (name cohttp) diff --git a/examples/async/dune b/examples/async/dune index 78c2522519..92af22612d 100644 --- a/examples/async/dune +++ b/examples/async/dune @@ -1,8 +1,8 @@ (executables - (names hello_world receive_post) - (libraries cohttp-async base async_kernel)) + (names hello_world receive_post) + (libraries mirage-crypto cohttp-async base async_kernel)) (alias - (name runtest) - (package cohttp-async) - (deps hello_world.exe receive_post.exe)) + (name runtest) + (package cohttp-async) + (deps hello_world.exe receive_post.exe)) From d5de3bf6367b4d913d97ca90d99d162092c8413c Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:23:07 +0200 Subject: [PATCH 19/46] Delete Travis CI script (use ocaml-ci instead) --- .travis.yml | 35 ----------------------------------- 1 file changed, 35 deletions(-) delete mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index c50d978dff..0000000000 --- a/.travis.yml +++ /dev/null @@ -1,35 +0,0 @@ -language: c -sudo: false -services: - - docker -install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh -script: bash -ex ./.travis-docker.sh -env: - global: - - PINS="cohttp-top.dev:. cohttp-async.dev:. cohttp-lwt-unix.dev:. cohttp-lwt-jsoo.dev:. cohttp-lwt.dev:. cohttp-mirage.dev:. cohttp.dev:." - matrix: - - PACKAGE="cohttp" DISTRO="ubuntu-lts" OCAML_VERSION="4.08" DEPOPTS="cohttp-async cohttp-lwt-unix cohttp-mirage" - - PACKAGE="cohttp" DISTRO="ubuntu-lts" OCAML_VERSION="4.07" - - PACKAGE="cohttp-async" DISTRO="ubuntu-lts" OCAML_VERSION="4.08" - - PACKAGE="cohttp-async" DISTRO="alpine" OCAML_VERSION="4.08" - - PACKAGE="cohttp-async" DISTRO="ubuntu-16.04" OCAML_VERSION="4.08" - - PACKAGE="cohttp-lwt-unix" DISTRO="ubuntu-lts" OCAML_VERSION="4.07" - - PACKAGE="cohttp-lwt-jsoo" DISTRO="ubuntu-lts" OCAML_VERSION="4.07" - - PACKAGE="cohttp-lwt" DISTRO="ubuntu-lts" OCAML_VERSION="4.07" - - PACKAGE="cohttp-mirage" DISTRO="alpine" OCAML_VERSION="4.07" - - PACKAGE="cohttp" DISTRO="alpine" OCAML_VERSION="4.06" - - PACKAGE="cohttp-lwt-unix" DISTRO="alpine" OCAML_VERSION="4.06" - - PACKAGE="cohttp-lwt-jsoo" DISTRO="alpine" OCAML_VERSION="4.06" - - PACKAGE="cohttp-lwt" DISTRO="alpine" OCAML_VERSION="4.06" - - PACKAGE="cohttp" DISTRO="ubuntu-16.04" OCAML_VERSION="4.04" - - PACKAGE="cohttp-lwt-unix" DISTRO="ubuntu-16.04" OCAML_VERSION="4.04" - - PACKAGE="cohttp-lwt-jsoo" DISTRO="ubuntu-16.04" OCAML_VERSION="4.04" - - PACKAGE="cohttp-lwt" DISTRO="ubuntu-16.04" OCAML_VERSION="4.04" - -notifications: - webhooks: - urls: - - https://webhooks.gitter.im/e/6ee5059c7420709f4ad1 - on_success: change - on_failure: always - on_start: false From b6efc31562618aa96f32f2e537c3f4488ec65bf8 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 6 May 2020 12:24:41 +0200 Subject: [PATCH 20/46] Update OPAM packages --- .gitmodules | 0 cohttp-async.opam | 8 ++++++++ cohttp-lwt-unix.opam | 10 +++++++++- cohttp-mirage.opam | 5 +++++ 4 files changed, 22 insertions(+), 1 deletion(-) create mode 100644 .gitmodules diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000000..e69de29bb2 diff --git a/cohttp-async.opam b/cohttp-async.opam index fd838ba36f..39f49b23c7 100644 --- a/cohttp-async.opam +++ b/cohttp-async.opam @@ -32,6 +32,7 @@ depends: [ "core" {with-test} "cohttp" {=version} "conduit-async" {>="1.2.0"} + "conduit-async-ssl" "magic-mime" "logs" "fmt" {>= "0.8.2"} @@ -41,6 +42,7 @@ depends: [ "ounit" {with-test} "uri" {>= "2.0.0"} "uri-sexp" + "ipaddr" ] build: [ ["dune" "subst"] {pinned} @@ -48,3 +50,9 @@ build: [ ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" +pin-depends: [ + [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-async-ssl.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-async.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] +] diff --git a/cohttp-lwt-unix.opam b/cohttp-lwt-unix.opam index 25244d0a88..61919cce70 100644 --- a/cohttp-lwt-unix.opam +++ b/cohttp-lwt-unix.opam @@ -27,13 +27,15 @@ bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" depends: [ "ocaml" {>= "4.04.1"} "dune" {>= "1.1.0"} - "conduit-lwt-unix" {>= "1.0.3"} + "conduit-lwt" {>= "1.0.3"} + "conduit-lwt-ssl" "cmdliner" "magic-mime" "logs" "fmt" {>= "0.8.2"} "cohttp-lwt" {=version} "lwt" {>= "3.0.0"} + "lwt_ssl" "base-unix" "ounit" {with-test} ] @@ -43,3 +45,9 @@ build: [ ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" +pin-depends: [ + [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-lwt-ssl.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-lwt.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] +] diff --git a/cohttp-mirage.opam b/cohttp-mirage.opam index e0a6b8defe..756540ce92 100644 --- a/cohttp-mirage.opam +++ b/cohttp-mirage.opam @@ -37,3 +37,8 @@ build: [ ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" +pin-depends: [ + [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-mirage.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] +] From 3bbdf30bd760b1e067e9f1888514b14e3e24e6e0 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 8 Sep 2020 15:25:11 +0200 Subject: [PATCH 21/46] Delay the initialization of the cohttp server --- cohttp-async/bin/cohttp_server_async.ml | 2 +- cohttp-async/src/server.ml | 2 +- cohttp-async/src/server.mli | 4 ++-- cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml | 2 +- cohttp-lwt-unix/bin/cohttp_server_lwt.ml | 2 +- cohttp-lwt-unix/src/server.ml | 5 ++--- cohttp-lwt-unix/src/server.mli | 2 +- cohttp_async_test/src/cohttp_async_test.ml | 2 +- cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml | 2 +- examples/async/hello_world.ml | 2 +- examples/async/receive_post.ml | 2 +- 11 files changed, 13 insertions(+), 14 deletions(-) diff --git a/cohttp-async/bin/cohttp_server_async.ml b/cohttp-async/bin/cohttp_server_async.ml index 5168d05323..aa4bee0a94 100644 --- a/cohttp-async/bin/cohttp_server_async.ml +++ b/cohttp-async/bin/cohttp_server_async.ml @@ -107,7 +107,7 @@ let determine_mode cert_file_path key_file_path = | None, None -> `TCP | _ -> failwith "Error: must specify both certificate and key for HTTPS" -let start_server docroot port index cert_file key_file verbose () = +let start_server docroot port index cert_file key_file verbose = (* enable logging to stdout *) Fmt_tty.setup_std_outputs (); Logs.set_level @@ if verbose then (Some Logs.Debug) else (Some Logs.Info); diff --git a/cohttp-async/src/server.ml b/cohttp-async/src/server.ml index c6ff663fb5..41abccf9cf 100644 --- a/cohttp-async/src/server.ml +++ b/cohttp-async/src/server.ml @@ -164,7 +164,7 @@ let create_raw cfg -> (body:Body.t -> Conduit_async.flow -> Request.t -> response_action Async_kernel.Deferred.t) - -> unit Async.Condition.t * unit Async.Deferred.t + -> unit Async.Condition.t * (unit -> unit Async.Deferred.t) = fun ?timeout ?backlog ~on_handler_error ~protocol ~service cfg handle_request -> diff --git a/cohttp-async/src/server.mli b/cohttp-async/src/server.mli index 6708f1ae0c..3437243789 100644 --- a/cohttp-async/src/server.mli +++ b/cohttp-async/src/server.mli @@ -64,7 +64,7 @@ val create_expert : service:('cfg, 't, 'flow) Conduit_async.Service.service -> 'cfg -> (body:Body.t -> Conduit_async.flow -> Request.t -> response_action Async_kernel.Deferred.t) - -> unit Async.Condition.t * unit Async.Deferred.t + -> unit Async.Condition.t * (unit -> unit Async.Deferred.t) (** Build a HTTP server, based on the [Tcp.Server] interface *) @@ -78,4 +78,4 @@ val create : service:('cfg, 't, 'flow) Conduit_async.Service.service -> 'cfg -> (body:Body.t -> Conduit_async.flow -> Request.t -> response Async_kernel.Deferred.t) - -> unit Async.Condition.t * unit Async.Deferred.t + -> unit Async.Condition.t * (unit -> unit Async.Deferred.t) diff --git a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml index 5ed9fb8cc7..85bb89d655 100644 --- a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml @@ -86,7 +86,7 @@ let sockaddr_of_host_and_port host port = let inet_addr = Unix.inet_addr_of_string host in Unix.ADDR_INET (inet_addr, port) -let start_proxy port host verbose cert key () = +let start_proxy port host verbose cert key = printf "Listening for HTTP request on: %s %d\n%!" host port; let conn_closed (ch,_conn) = let pp_option pp_val ppf = function diff --git a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml index 0f1e432cb8..c586425723 100644 --- a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml @@ -133,7 +133,7 @@ let sockaddr_of_host_and_port host port = let inet_addr = Unix.inet_addr_of_string host in Unix.ADDR_INET (inet_addr, port) -let start_server docroot port host index tls () = +let start_server docroot port host index tls = Log.info (fun m -> m "Listening for HTTP request on: %s %d" host port); let info = Printf.sprintf "Served by Cohttp/Lwt listening on %s:%d" host port in let conn_closed (ch,_conn) = diff --git a/cohttp-lwt-unix/src/server.ml b/cohttp-lwt-unix/src/server.ml index 8df0999468..cc4af0a224 100644 --- a/cohttp-lwt-unix/src/server.ml +++ b/cohttp-lwt-unix/src/server.ml @@ -81,7 +81,7 @@ let create -> cfg -> (_, flow) Conduit_lwt.protocol -> (cfg, t, flow) Conduit_lwt.Service.service - -> _ -> unit Lwt.t + -> _ -> (unit -> unit Lwt.t) = fun ?timeout ?(backlog= 128) ?(stop= fst (Lwt.wait ())) ?(on_exn=log_on_exn) cfg protocol service spec -> let error_handler exn = on_exn exn ; Lwt.return_unit in @@ -95,5 +95,4 @@ let create (safe error_handler callback spec flow) (fun () -> Conduit_lwt.close flow >>= fun _ -> Lwt.return_unit) in let cond, run = Conduit_lwt.serve ?timeout ~handler ~service cfg in - Lwt.pick [ (stop >|= Lwt_condition.signal cond) - ; run ] + (); fun () -> Lwt.pick [ (stop >|= Lwt_condition.signal cond); run () ] diff --git a/cohttp-lwt-unix/src/server.mli b/cohttp-lwt-unix/src/server.mli index 399ee03947..d24c938780 100644 --- a/cohttp-lwt-unix/src/server.mli +++ b/cohttp-lwt-unix/src/server.mli @@ -36,4 +36,4 @@ val create : ?on_exn:(exn -> unit) -> 'cfg -> (_, 'flow) Conduit_lwt.protocol -> - ('cfg, 't, 'flow) Conduit_lwt.Service.service -> t -> unit Lwt.t + ('cfg, 't, 'flow) Conduit_lwt.Service.service -> t -> (unit -> unit Lwt.t) diff --git a/cohttp_async_test/src/cohttp_async_test.ml b/cohttp_async_test/src/cohttp_async_test.ml index e55a87a8da..c893bbbb73 100644 --- a/cohttp_async_test/src/cohttp_async_test.ml +++ b/cohttp_async_test/src/cohttp_async_test.ml @@ -36,7 +36,7 @@ let temp_server ?port spec callback = ~protocol:Conduit_async.TCP.protocol ~service:Conduit_async.TCP.service (Conduit_async.TCP.Listen (None, Async.Tcp.Where_to_listen.of_port port)) (fun ~body _sock req -> spec req body) in - Async.Deferred.both server (callback uri >>= fun res -> + Async.Deferred.both (server ()) (callback uri >>= fun res -> Async.Condition.broadcast stop () ; Async.return res) >>= fun ((), res) -> Async.return res diff --git a/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml b/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml index 621381bf00..091efd5267 100644 --- a/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml +++ b/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml @@ -45,7 +45,7 @@ let temp_server ?port spec callback = let tcp_config = { sockaddr= Unix.ADDR_INET (Unix.inet_addr_any, port) ; capacity= 40 } in - Cohttp_lwt_unix.Server.create tcp_config protocol service server) + Cohttp_lwt_unix.Server.create tcp_config protocol service server ()) (function | Lwt.Canceled -> Lwt.return_unit | x -> Lwt.wakeup_exn server_failed_wake x; Lwt.fail x) diff --git a/examples/async/hello_world.ml b/examples/async/hello_world.ml index 7241ac6bc8..720b77070e 100644 --- a/examples/async/hello_world.ml +++ b/examples/async/hello_world.ml @@ -18,7 +18,7 @@ let handler ~body:_ _sock req = | _ -> Server.respond_string ~status:`Not_found "Route not found" -let start_server port () = +let start_server port = Caml.Printf.eprintf "Listening for HTTP on port %d\n" port; Caml.Printf.eprintf "Try 'curl http://localhost:%d/test?hello=xyz'\n%!" port; let _never, server = Cohttp_async.Server.create ~on_handler_error:`Raise diff --git a/examples/async/receive_post.ml b/examples/async/receive_post.ml index 5f3690215f..2279231fe8 100644 --- a/examples/async/receive_post.ml +++ b/examples/async/receive_post.ml @@ -5,7 +5,7 @@ open Cohttp_async (* compile with: $ corebuild receive_post.native -pkg cohttp.async *) -let start_server port () = +let start_server port = Caml.Printf.eprintf "Listening for HTTP on port %d\n" port; Caml.Printf.eprintf "Try 'curl -X POST -d 'foo bar' http://localhost:%d\n" port; let _never, server = Cohttp_async.Server.create ~on_handler_error:`Raise From d3e04f008af8c84702ba7deca6b76195c5c425f7 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 8 Sep 2020 17:29:06 +0200 Subject: [PATCH 22/46] Be able to resolve *:80 and *:443 domains with cohttp-lwt-unix --- cohttp-lwt-unix/src/net.ml | 18 +++++++++++++++++- cohttp-lwt-unix/test/test_sanity.ml | 18 ++++++------------ 2 files changed, 23 insertions(+), 13 deletions(-) diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index 227a259565..30981e72d3 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -23,7 +23,23 @@ module IO = Io type resolvers = Conduit.resolvers -let empty = Conduit.empty +let () = Ssl.init () + +let default_ssl_context = + Ssl.create_context Ssl.SSLv23 Ssl.Client_context + +let empty = + Conduit_lwt.empty + |> Conduit_lwt.add Conduit_lwt.TCP.protocol + (Conduit_lwt.TCP.resolve ~port:80) + |> Conduit_lwt.add Conduit_lwt_ssl.TCP.protocol + (Conduit_lwt_ssl.TCP.resolve ~port:443 ~context:default_ssl_context) +(* XXX(dinosaure) [cohttp-lwt-unix] provides a default resolve which is + * able to start a simple TCP/IP connection or a TLS 1.3 connection to + * handle [http] and [https] cases. + * + * The user is able to prioritize over these resolvers its own resolver + * such as one with a specific [Ssl.context] (with TLS 1.3 support) if he wants. *) let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt diff --git a/cohttp-lwt-unix/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml index 18fc02ea60..f381761cc0 100644 --- a/cohttp-lwt-unix/test/test_sanity.ml +++ b/cohttp-lwt-unix/test/test_sanity.ml @@ -95,20 +95,14 @@ let check_logs test () = if new_errs > 0 then Fmt.failwith "Test produced %d log messages at level >= warn" new_errs -let http_resolver ?(port= 80) domain_name = - try let inet_addr = Unix.inet_addr_of_string (Domain_name.to_string domain_name) in - Lwt.return_some (Unix.ADDR_INET (inet_addr, port)) - with _ -> - Lwt_unix.gethostbyname (Domain_name.to_string domain_name) >>= function - | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> - Lwt.return_some (Unix.ADDR_INET (h_addr_list.(0), port)) - | _ -> Lwt.return_none - let ts = Cohttp_lwt_unix_test.test_server_s server begin fun uri -> - let resolvers = Conduit_lwt.register_resolver - ~key:Conduit_lwt_unix_tcp.endpoint (http_resolver ?port:(Uri.port uri)) - Conduit.empty in + let resolvers = match Uri.port uri with + | Some port -> + Cohttp_lwt_unix.Net.empty + |> Conduit_lwt.add ~priority:0 Conduit_lwt.TCP.protocol + (Conduit_lwt.TCP.resolve ~port) + | None -> Cohttp_lwt_unix.Net.empty in let t () = Client.get ~resolvers uri >>= fun (_, body) -> body |> Body.to_string >|= fun body -> From 32dce1b456bdf3fd563bf8edbdcb330ef119df31 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 8 Sep 2020 15:50:37 +0200 Subject: [PATCH 23/46] Remove unused value sexp_of_ctx --- cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml b/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml index 4cf89573fc..c73f208a7d 100644 --- a/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml @@ -123,7 +123,6 @@ module Make_api(X : sig module Response = X.Response type resolvers = unit - let sexp_of_ctx _ = Sexplib0.Sexp.List [] let call ?resolvers:_ ?headers ?body ?chunked:_ meth uri = X.call ?headers ?body meth uri From 11dc50bf1ee6e3df831e76ebcc25a5c9f3abc280 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 8 Sep 2020 18:07:21 +0200 Subject: [PATCH 24/46] Add an .ocamlformat file --- .ocamlformat | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 .ocamlformat diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000000..2e686658cb --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,2 @@ +version = 0.15.0 +disable = true From 253140ce3d39b94a6c8efba51057be8c7c867e7d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 21 Sep 2020 15:34:22 +0200 Subject: [PATCH 25/46] Create 2 new packages: cohttp-lwt-unix-{ssl,tls} and rename the package cohttp-lwt-unix to cohttp-lwt-unix-nossl --- ...wt-unix.opam => cohttp-lwt-unix-nossl.opam | 3 - .../bin/cohttp_curl_lwt.ml | 0 .../bin/cohttp_proxy_lwt.ml | 0 .../bin/cohttp_server_lwt.ml | 0 cohttp-lwt-unix-nossl/bin/dune | 6 ++ .../src/client.ml | 0 .../src/client.mli | 0 .../src/cohttp_lwt_unix.ml | 0 .../src/debug.ml | 0 .../src/debug.mli | 0 cohttp-lwt-unix-nossl/src/dune | 8 +++ .../src/io.ml | 0 .../src/io.mli | 0 cohttp-lwt-unix-nossl/src/net.ml | 53 ++++++++++++++++ .../src/net.mli | 0 .../src/server.ml | 0 .../src/server.mli | 0 .../test/dune | 16 ++--- .../test/test_body.ml | 0 .../test/test_parser.ml | 0 .../test/test_sanity.ml | 0 .../test/test_sanity_noisy.ml | 0 cohttp-lwt-unix-ssl.opam | 51 ++++++++++++++++ .../src/cohttp_lwt_unix_ssl.ml | 31 ++++++++++ cohttp-lwt-unix-ssl/src/dune | 7 +++ .../src/net.ml | 4 +- cohttp-lwt-unix-ssl/src/net.mli | 39 ++++++++++++ cohttp-lwt-unix-tls.opam | 53 ++++++++++++++++ .../src/cohttp_lwt_unix_tls.ml | 31 ++++++++++ cohttp-lwt-unix-tls/src/dune | 7 +++ cohttp-lwt-unix-tls/src/net.ml | 60 +++++++++++++++++++ cohttp-lwt-unix-tls/src/net.mli | 39 ++++++++++++ cohttp-lwt-unix/bin/dune | 6 -- cohttp-lwt-unix/src/dune | 8 --- cohttp_lwt_unix_test/src/dune | 2 +- 35 files changed, 396 insertions(+), 28 deletions(-) rename cohttp-lwt-unix.opam => cohttp-lwt-unix-nossl.opam (85%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/bin/cohttp_curl_lwt.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/bin/cohttp_proxy_lwt.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/bin/cohttp_server_lwt.ml (100%) create mode 100644 cohttp-lwt-unix-nossl/bin/dune rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/client.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/client.mli (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/cohttp_lwt_unix.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/debug.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/debug.mli (100%) create mode 100644 cohttp-lwt-unix-nossl/src/dune rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/io.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/io.mli (100%) create mode 100644 cohttp-lwt-unix-nossl/src/net.ml rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/net.mli (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/server.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/server.mli (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/test/dune (57%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/test/test_body.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/test/test_parser.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/test/test_sanity.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/test/test_sanity_noisy.ml (100%) create mode 100644 cohttp-lwt-unix-ssl.opam create mode 100644 cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml create mode 100644 cohttp-lwt-unix-ssl/src/dune rename {cohttp-lwt-unix => cohttp-lwt-unix-ssl}/src/net.ml (96%) create mode 100644 cohttp-lwt-unix-ssl/src/net.mli create mode 100644 cohttp-lwt-unix-tls.opam create mode 100644 cohttp-lwt-unix-tls/src/cohttp_lwt_unix_tls.ml create mode 100644 cohttp-lwt-unix-tls/src/dune create mode 100644 cohttp-lwt-unix-tls/src/net.ml create mode 100644 cohttp-lwt-unix-tls/src/net.mli delete mode 100644 cohttp-lwt-unix/bin/dune delete mode 100644 cohttp-lwt-unix/src/dune diff --git a/cohttp-lwt-unix.opam b/cohttp-lwt-unix-nossl.opam similarity index 85% rename from cohttp-lwt-unix.opam rename to cohttp-lwt-unix-nossl.opam index 61919cce70..45c8c467f6 100644 --- a/cohttp-lwt-unix.opam +++ b/cohttp-lwt-unix-nossl.opam @@ -28,7 +28,6 @@ depends: [ "ocaml" {>= "4.04.1"} "dune" {>= "1.1.0"} "conduit-lwt" {>= "1.0.3"} - "conduit-lwt-ssl" "cmdliner" "magic-mime" "logs" @@ -47,7 +46,5 @@ build: [ dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" pin-depends: [ [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-lwt-ssl.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] [ "conduit-lwt.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] ] diff --git a/cohttp-lwt-unix/bin/cohttp_curl_lwt.ml b/cohttp-lwt-unix-nossl/bin/cohttp_curl_lwt.ml similarity index 100% rename from cohttp-lwt-unix/bin/cohttp_curl_lwt.ml rename to cohttp-lwt-unix-nossl/bin/cohttp_curl_lwt.ml diff --git a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml b/cohttp-lwt-unix-nossl/bin/cohttp_proxy_lwt.ml similarity index 100% rename from cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml rename to cohttp-lwt-unix-nossl/bin/cohttp_proxy_lwt.ml diff --git a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml b/cohttp-lwt-unix-nossl/bin/cohttp_server_lwt.ml similarity index 100% rename from cohttp-lwt-unix/bin/cohttp_server_lwt.ml rename to cohttp-lwt-unix-nossl/bin/cohttp_server_lwt.ml diff --git a/cohttp-lwt-unix-nossl/bin/dune b/cohttp-lwt-unix-nossl/bin/dune new file mode 100644 index 0000000000..338101bf07 --- /dev/null +++ b/cohttp-lwt-unix-nossl/bin/dune @@ -0,0 +1,6 @@ +(executables + (names cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt) + (libraries cohttp-lwt-unix-nossl cohttp_server logs logs.lwt logs.fmt + logs.cli cmdliner conduit-lwt conduit-lwt-ssl) + (package cohttp-lwt-unix-nossl) + (public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt)) diff --git a/cohttp-lwt-unix/src/client.ml b/cohttp-lwt-unix-nossl/src/client.ml similarity index 100% rename from cohttp-lwt-unix/src/client.ml rename to cohttp-lwt-unix-nossl/src/client.ml diff --git a/cohttp-lwt-unix/src/client.mli b/cohttp-lwt-unix-nossl/src/client.mli similarity index 100% rename from cohttp-lwt-unix/src/client.mli rename to cohttp-lwt-unix-nossl/src/client.mli diff --git a/cohttp-lwt-unix/src/cohttp_lwt_unix.ml b/cohttp-lwt-unix-nossl/src/cohttp_lwt_unix.ml similarity index 100% rename from cohttp-lwt-unix/src/cohttp_lwt_unix.ml rename to cohttp-lwt-unix-nossl/src/cohttp_lwt_unix.ml diff --git a/cohttp-lwt-unix/src/debug.ml b/cohttp-lwt-unix-nossl/src/debug.ml similarity index 100% rename from cohttp-lwt-unix/src/debug.ml rename to cohttp-lwt-unix-nossl/src/debug.ml diff --git a/cohttp-lwt-unix/src/debug.mli b/cohttp-lwt-unix-nossl/src/debug.mli similarity index 100% rename from cohttp-lwt-unix/src/debug.mli rename to cohttp-lwt-unix-nossl/src/debug.mli diff --git a/cohttp-lwt-unix-nossl/src/dune b/cohttp-lwt-unix-nossl/src/dune new file mode 100644 index 0000000000..9d83878c34 --- /dev/null +++ b/cohttp-lwt-unix-nossl/src/dune @@ -0,0 +1,8 @@ +(library + (name cohttp_lwt_unix) + (public_name cohttp-lwt-unix-nossl) + (synopsis "Lwt/Unix backend for Cohttp") + (preprocess + (pps ppx_sexp_conv)) + (libraries fmt logs logs.lwt conduit-lwt magic-mime lwt.unix cohttp + cohttp-lwt)) diff --git a/cohttp-lwt-unix/src/io.ml b/cohttp-lwt-unix-nossl/src/io.ml similarity index 100% rename from cohttp-lwt-unix/src/io.ml rename to cohttp-lwt-unix-nossl/src/io.ml diff --git a/cohttp-lwt-unix/src/io.mli b/cohttp-lwt-unix-nossl/src/io.mli similarity index 100% rename from cohttp-lwt-unix/src/io.mli rename to cohttp-lwt-unix-nossl/src/io.mli diff --git a/cohttp-lwt-unix-nossl/src/net.ml b/cohttp-lwt-unix-nossl/src/net.ml new file mode 100644 index 0000000000..70efd08a74 --- /dev/null +++ b/cohttp-lwt-unix-nossl/src/net.ml @@ -0,0 +1,53 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + }}}*) + +(* Miscellaneous net-helpers used by Cohttp. Ideally, these will disappear + * into some connection-management framework such as andrenth/release *) + +open Lwt.Infix + +module IO = Io + +type resolvers = Conduit.resolvers + +let empty = + Conduit_lwt.empty + |> Conduit_lwt.add Conduit_lwt.TCP.protocol + (Conduit_lwt.TCP.resolve ~port:80) + +let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt + +let connect_uri ?host:(default= "localhost") ~resolvers uri = + let domain_name = Domain_name.(host_exn (of_string_exn (Uri.host_with_default ~default uri))) in + Conduit_lwt.resolve resolvers domain_name >>= function + | Ok flow -> + let ic, oc = Conduit_lwt.io_of_flow flow in + Lwt.return (flow, ic, oc) + | Error err -> + failwith "%a" Conduit_lwt.pp_error err + +let close c = Lwt.catch + (fun () -> Lwt_io.close c) + (fun e -> + Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e)); + Lwt.return_unit + ) + +let close_in ic = Lwt.ignore_result (close ic) + +let close_out oc = Lwt.ignore_result (close oc) + +let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close oc) diff --git a/cohttp-lwt-unix/src/net.mli b/cohttp-lwt-unix-nossl/src/net.mli similarity index 100% rename from cohttp-lwt-unix/src/net.mli rename to cohttp-lwt-unix-nossl/src/net.mli diff --git a/cohttp-lwt-unix/src/server.ml b/cohttp-lwt-unix-nossl/src/server.ml similarity index 100% rename from cohttp-lwt-unix/src/server.ml rename to cohttp-lwt-unix-nossl/src/server.ml diff --git a/cohttp-lwt-unix/src/server.mli b/cohttp-lwt-unix-nossl/src/server.mli similarity index 100% rename from cohttp-lwt-unix/src/server.mli rename to cohttp-lwt-unix-nossl/src/server.mli diff --git a/cohttp-lwt-unix/test/dune b/cohttp-lwt-unix-nossl/test/dune similarity index 57% rename from cohttp-lwt-unix/test/dune rename to cohttp-lwt-unix-nossl/test/dune index 163c21cdcf..b01d494b10 100644 --- a/cohttp-lwt-unix/test/dune +++ b/cohttp-lwt-unix-nossl/test/dune @@ -1,43 +1,43 @@ (executable (name test_parser) (modules test_parser) - (libraries cohttp-lwt-unix oUnit lwt.unix)) + (libraries cohttp-lwt-unix-nossl oUnit lwt.unix)) (rule (alias runtest) - (package cohttp-lwt-unix) + (package cohttp-lwt-unix-nossl) (action (run ./test_parser.exe))) (executable (modules test_sanity) (name test_sanity) - (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) + (libraries cohttp_lwt_unix_test cohttp-lwt-unix-nossl)) (executable (modules test_sanity_noisy) (name test_sanity_noisy) - (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) + (libraries cohttp_lwt_unix_test cohttp-lwt-unix-nossl)) (rule (alias runtest) - (package cohttp-lwt-unix) + (package cohttp-lwt-unix-nossl) (action (run ./test_sanity.exe))) (rule (alias runtest) - (package cohttp-lwt-unix) + (package cohttp-lwt-unix-nossl) (action (run ./test_sanity_noisy.exe))) (executable (modules test_body) (name test_body) - (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) + (libraries cohttp_lwt_unix_test cohttp-lwt-unix-nossl)) (rule (alias runtest) - (package cohttp-lwt-unix) + (package cohttp-lwt-unix-nossl) (action (run ./test_body.exe))) diff --git a/cohttp-lwt-unix/test/test_body.ml b/cohttp-lwt-unix-nossl/test/test_body.ml similarity index 100% rename from cohttp-lwt-unix/test/test_body.ml rename to cohttp-lwt-unix-nossl/test/test_body.ml diff --git a/cohttp-lwt-unix/test/test_parser.ml b/cohttp-lwt-unix-nossl/test/test_parser.ml similarity index 100% rename from cohttp-lwt-unix/test/test_parser.ml rename to cohttp-lwt-unix-nossl/test/test_parser.ml diff --git a/cohttp-lwt-unix/test/test_sanity.ml b/cohttp-lwt-unix-nossl/test/test_sanity.ml similarity index 100% rename from cohttp-lwt-unix/test/test_sanity.ml rename to cohttp-lwt-unix-nossl/test/test_sanity.ml diff --git a/cohttp-lwt-unix/test/test_sanity_noisy.ml b/cohttp-lwt-unix-nossl/test/test_sanity_noisy.ml similarity index 100% rename from cohttp-lwt-unix/test/test_sanity_noisy.ml rename to cohttp-lwt-unix-nossl/test/test_sanity_noisy.ml diff --git a/cohttp-lwt-unix-ssl.opam b/cohttp-lwt-unix-ssl.opam new file mode 100644 index 0000000000..3ae6cbe501 --- /dev/null +++ b/cohttp-lwt-unix-ssl.opam @@ -0,0 +1,51 @@ +opam-version: "2.0" +maintainer: "anil@recoil.org" +authors: [ + "Anil Madhavapeddy" + "Stefano Zacchiroli" + "David Sheets" + "Thomas Gazagnaire" + "David Scott" + "Rudi Grinberg" + "Andy Ray" +] +synopsis: "CoHTTP implementation for Unix and Windows using Lwt and SSL" +description: """ +An implementation of an HTTP client and server using the Lwt +concurrency library. See the `Cohttp_lwt_unix_ssl` module for information +on how to use this. The package also installs `cohttp-curl-lwt` +binary for quick uses of a HTTP(S) client. + +Although the name implies that this only works under Unix, it +should also be fine under Windows too.""" +license: "ISC" +tags: ["org:mirage" "org:xapi-project"] +homepage: "https://github.com/mirage/ocaml-cohttp" +doc: "https://mirage.github.io/ocaml-cohttp/" +bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" +depends: [ + "ocaml" {>= "4.04.1"} + "dune" {>= "1.1.0"} + "conduit-lwt" {>= "1.0.3"} + "conduit-lwt-ssl" + "cmdliner" + "magic-mime" + "logs" + "fmt" {>= "0.8.2"} + "cohttp-lwt" {=version} + "lwt" {>= "3.0.0"} + "lwt_ssl" + "base-unix" + "ounit" {with-test} +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" +pin-depends: [ + [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-lwt-ssl.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-lwt.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] +] diff --git a/cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml b/cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml new file mode 100644 index 0000000000..b76de1abb7 --- /dev/null +++ b/cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml @@ -0,0 +1,31 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + }}}*) + +module Request = struct + include Cohttp.Request + include (Make(Cohttp_lwt_unix.IO) + : module type of Make(Cohttp_lwt_unix.IO) with type t := t) +end + +module Response = struct + include Cohttp.Response + include (Make(Cohttp_lwt_unix.IO) + : module type of Make(Cohttp_lwt_unix.IO) with type t := t) +end + +module Client = Cohttp_lwt.Make_client(Cohttp_lwt_unix.IO)(Net) +module Net = Net +module IO = Cohttp_lwt_unix.IO diff --git a/cohttp-lwt-unix-ssl/src/dune b/cohttp-lwt-unix-ssl/src/dune new file mode 100644 index 0000000000..dcd7ef5b86 --- /dev/null +++ b/cohttp-lwt-unix-ssl/src/dune @@ -0,0 +1,7 @@ +(library + (name cohttp_lwt_unix_ssl) + (public_name cohttp-lwt-unix-ssl) + (synopsis "Lwt/Unix backend for Cohttp with SSL support") + (preprocess + (pps ppx_sexp_conv)) + (libraries cohttp-lwt-unix-nossl conduit-lwt-ssl)) diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix-ssl/src/net.ml similarity index 96% rename from cohttp-lwt-unix/src/net.ml rename to cohttp-lwt-unix-ssl/src/net.ml index 30981e72d3..b4bf0b0035 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix-ssl/src/net.ml @@ -19,7 +19,7 @@ open Lwt.Infix -module IO = Io +module IO = Cohttp_lwt_unix.IO type resolvers = Conduit.resolvers @@ -32,7 +32,7 @@ let empty = Conduit_lwt.empty |> Conduit_lwt.add Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port:80) - |> Conduit_lwt.add Conduit_lwt_ssl.TCP.protocol + |> Conduit_lwt.add ~priority:10 Conduit_lwt_ssl.TCP.protocol (Conduit_lwt_ssl.TCP.resolve ~port:443 ~context:default_ssl_context) (* XXX(dinosaure) [cohttp-lwt-unix] provides a default resolve which is * able to start a simple TCP/IP connection or a TLS 1.3 connection to diff --git a/cohttp-lwt-unix-ssl/src/net.mli b/cohttp-lwt-unix-ssl/src/net.mli new file mode 100644 index 0000000000..955328c3aa --- /dev/null +++ b/cohttp-lwt-unix-ssl/src/net.mli @@ -0,0 +1,39 @@ +(*{{{ Copyright (c) 2015 David Sheets + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + }}}*) + +(** Basic satisfaction of {! Cohttp_lwt.Net } *) + +module IO = Cohttp_lwt_unix.IO + +type resolvers = Conduit.resolvers + +val empty : resolvers + +(** Exceptions from [conduit]. + + When the [recv] or the [send] {i syscalls} return an error, + [conduit] will reraise it. *) + +val connect_uri : + ?host:string -> + resolvers:resolvers -> + Uri.t -> + (Conduit_lwt.flow * Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel) Lwt.t + +val close_in : 'a Lwt_io.channel -> unit +val close_out : 'a Lwt_io.channel -> unit + +val close : 'a Lwt_io.channel -> 'b Lwt_io.channel -> unit diff --git a/cohttp-lwt-unix-tls.opam b/cohttp-lwt-unix-tls.opam new file mode 100644 index 0000000000..8ecbe429e0 --- /dev/null +++ b/cohttp-lwt-unix-tls.opam @@ -0,0 +1,53 @@ +opam-version: "2.0" +maintainer: "anil@recoil.org" +authors: [ + "Anil Madhavapeddy" + "Stefano Zacchiroli" + "David Sheets" + "Thomas Gazagnaire" + "David Scott" + "Rudi Grinberg" + "Andy Ray" +] +synopsis: "CoHTTP implementation for Unix and Windows using Lwt and TLS" +description: """ +An implementation of an HTTP client and server using the Lwt +concurrency library. See the `Cohttp_lwt_unix_tls` module for information +on how to use this. The package also installs `cohttp-curl-lwt` +binary for quick uses of a HTTP(S) client. + +Although the name implies that this only works under Unix, it +should also be fine under Windows too.""" +license: "ISC" +tags: ["org:mirage" "org:xapi-project"] +homepage: "https://github.com/mirage/ocaml-cohttp" +doc: "https://mirage.github.io/ocaml-cohttp/" +bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" +depends: [ + "ocaml" {>= "4.04.1"} + "dune" {>= "1.1.0"} + "conduit-lwt" {>= "1.0.3"} + "conduit-lwt-tls" + "mirage-crypto-rng" {>= "0.8.5"} + "cmdliner" + "magic-mime" + "logs" + "fmt" {>= "0.8.2"} + "cohttp-lwt" {=version} + "lwt" {>= "3.0.0"} + "lwt_ssl" + "base-unix" + "ounit" {with-test} +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" +pin-depends: [ + [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-lwt-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-lwt.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] +] diff --git a/cohttp-lwt-unix-tls/src/cohttp_lwt_unix_tls.ml b/cohttp-lwt-unix-tls/src/cohttp_lwt_unix_tls.ml new file mode 100644 index 0000000000..b76de1abb7 --- /dev/null +++ b/cohttp-lwt-unix-tls/src/cohttp_lwt_unix_tls.ml @@ -0,0 +1,31 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + }}}*) + +module Request = struct + include Cohttp.Request + include (Make(Cohttp_lwt_unix.IO) + : module type of Make(Cohttp_lwt_unix.IO) with type t := t) +end + +module Response = struct + include Cohttp.Response + include (Make(Cohttp_lwt_unix.IO) + : module type of Make(Cohttp_lwt_unix.IO) with type t := t) +end + +module Client = Cohttp_lwt.Make_client(Cohttp_lwt_unix.IO)(Net) +module Net = Net +module IO = Cohttp_lwt_unix.IO diff --git a/cohttp-lwt-unix-tls/src/dune b/cohttp-lwt-unix-tls/src/dune new file mode 100644 index 0000000000..8c05a2f22b --- /dev/null +++ b/cohttp-lwt-unix-tls/src/dune @@ -0,0 +1,7 @@ +(library + (name cohttp_lwt_unix_tls) + (public_name cohttp-lwt-unix-tls) + (synopsis "Lwt/Unix backend for Cohttp with TLS support") + (preprocess + (pps ppx_sexp_conv)) + (libraries cohttp-lwt-unix-nossl mirage-crypto-rng.unix conduit-lwt-tls)) diff --git a/cohttp-lwt-unix-tls/src/net.ml b/cohttp-lwt-unix-tls/src/net.ml new file mode 100644 index 0000000000..d5edffd477 --- /dev/null +++ b/cohttp-lwt-unix-tls/src/net.ml @@ -0,0 +1,60 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + }}}*) + +(* Miscellaneous net-helpers used by Cohttp. Ideally, these will disappear + * into some connection-management framework such as andrenth/release *) + +open Lwt.Infix + +module IO = Cohttp_lwt_unix.IO + +type resolvers = Conduit.resolvers + +let () = Mirage_crypto_rng_unix.initialize () + +let authenticator ~host:_ _ = Ok None +let config = Tls.Config.client ~authenticator () + +let empty = + Conduit_lwt.empty + |> Conduit_lwt.add Conduit_lwt.TCP.protocol + (Conduit_lwt.TCP.resolve ~port:80) + |> Conduit_lwt.add ~priority:10 Conduit_lwt_tls.TCP.protocol + (Conduit_lwt_tls.TCP.resolve ~port:443 ~config) + +let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt + +let connect_uri ?host:(default= "localhost") ~resolvers uri = + let domain_name = Domain_name.(host_exn (of_string_exn (Uri.host_with_default ~default uri))) in + Conduit_lwt.resolve resolvers domain_name >>= function + | Ok flow -> + let ic, oc = Conduit_lwt.io_of_flow flow in + Lwt.return (flow, ic, oc) + | Error err -> + failwith "%a" Conduit_lwt.pp_error err + +let close c = Lwt.catch + (fun () -> Lwt_io.close c) + (fun e -> + Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e)); + Lwt.return_unit + ) + +let close_in ic = Lwt.ignore_result (close ic) + +let close_out oc = Lwt.ignore_result (close oc) + +let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close oc) diff --git a/cohttp-lwt-unix-tls/src/net.mli b/cohttp-lwt-unix-tls/src/net.mli new file mode 100644 index 0000000000..955328c3aa --- /dev/null +++ b/cohttp-lwt-unix-tls/src/net.mli @@ -0,0 +1,39 @@ +(*{{{ Copyright (c) 2015 David Sheets + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + }}}*) + +(** Basic satisfaction of {! Cohttp_lwt.Net } *) + +module IO = Cohttp_lwt_unix.IO + +type resolvers = Conduit.resolvers + +val empty : resolvers + +(** Exceptions from [conduit]. + + When the [recv] or the [send] {i syscalls} return an error, + [conduit] will reraise it. *) + +val connect_uri : + ?host:string -> + resolvers:resolvers -> + Uri.t -> + (Conduit_lwt.flow * Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel) Lwt.t + +val close_in : 'a Lwt_io.channel -> unit +val close_out : 'a Lwt_io.channel -> unit + +val close : 'a Lwt_io.channel -> 'b Lwt_io.channel -> unit diff --git a/cohttp-lwt-unix/bin/dune b/cohttp-lwt-unix/bin/dune deleted file mode 100644 index afb381dfeb..0000000000 --- a/cohttp-lwt-unix/bin/dune +++ /dev/null @@ -1,6 +0,0 @@ -(executables - (names cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt) - (libraries cohttp-lwt-unix cohttp_server logs logs.lwt logs.fmt logs.cli - cmdliner conduit-lwt conduit-lwt-ssl) - (package cohttp-lwt-unix) - (public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt)) diff --git a/cohttp-lwt-unix/src/dune b/cohttp-lwt-unix/src/dune deleted file mode 100644 index 81a100fa50..0000000000 --- a/cohttp-lwt-unix/src/dune +++ /dev/null @@ -1,8 +0,0 @@ -(library - (name cohttp_lwt_unix) - (public_name cohttp-lwt-unix) - (synopsis "Lwt/Unix backend for Cohttp") - (preprocess - (pps ppx_sexp_conv)) - (libraries fmt logs logs.lwt conduit-lwt conduit-lwt-ssl magic-mime lwt.unix - cohttp cohttp-lwt)) diff --git a/cohttp_lwt_unix_test/src/dune b/cohttp_lwt_unix_test/src/dune index cc9c9ecff7..8dcf99e1ab 100644 --- a/cohttp_lwt_unix_test/src/dune +++ b/cohttp_lwt_unix_test/src/dune @@ -1,4 +1,4 @@ (library (name cohttp_lwt_unix_test) (wrapped false) - (libraries conduit-lwt cohttp-lwt-unix cohttp_test oUnit)) + (libraries conduit-lwt cohttp-lwt-unix-nossl cohttp_test oUnit)) From ce3fc307bf023919d50d97d142edef7fe7125bc3 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 23 Sep 2020 10:57:02 +0200 Subject: [PATCH 26/46] Revert "Create 2 new packages: cohttp-lwt-unix-{ssl,tls} and rename the package cohttp-lwt-unix to cohttp-lwt-unix-nossl" This reverts commit 253140ce3d39b94a6c8efba51057be8c7c867e7d. --- cohttp-lwt-unix-nossl/bin/dune | 6 -- cohttp-lwt-unix-nossl/src/dune | 8 --- cohttp-lwt-unix-nossl/src/net.ml | 53 ---------------- cohttp-lwt-unix-ssl.opam | 51 ---------------- .../src/cohttp_lwt_unix_ssl.ml | 31 ---------- cohttp-lwt-unix-ssl/src/dune | 7 --- cohttp-lwt-unix-ssl/src/net.mli | 39 ------------ cohttp-lwt-unix-tls.opam | 53 ---------------- .../src/cohttp_lwt_unix_tls.ml | 31 ---------- cohttp-lwt-unix-tls/src/dune | 7 --- cohttp-lwt-unix-tls/src/net.ml | 60 ------------------- cohttp-lwt-unix-tls/src/net.mli | 39 ------------ ...wt-unix-nossl.opam => cohttp-lwt-unix.opam | 3 + .../bin/cohttp_curl_lwt.ml | 0 .../bin/cohttp_proxy_lwt.ml | 0 .../bin/cohttp_server_lwt.ml | 0 cohttp-lwt-unix/bin/dune | 6 ++ .../src/client.ml | 0 .../src/client.mli | 0 .../src/cohttp_lwt_unix.ml | 0 .../src/debug.ml | 0 .../src/debug.mli | 0 cohttp-lwt-unix/src/dune | 8 +++ .../src/io.ml | 0 .../src/io.mli | 0 .../src/net.ml | 4 +- .../src/net.mli | 0 .../src/server.ml | 0 .../src/server.mli | 0 .../test/dune | 16 ++--- .../test/test_body.ml | 0 .../test/test_parser.ml | 0 .../test/test_sanity.ml | 0 .../test/test_sanity_noisy.ml | 0 cohttp_lwt_unix_test/src/dune | 2 +- 35 files changed, 28 insertions(+), 396 deletions(-) delete mode 100644 cohttp-lwt-unix-nossl/bin/dune delete mode 100644 cohttp-lwt-unix-nossl/src/dune delete mode 100644 cohttp-lwt-unix-nossl/src/net.ml delete mode 100644 cohttp-lwt-unix-ssl.opam delete mode 100644 cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml delete mode 100644 cohttp-lwt-unix-ssl/src/dune delete mode 100644 cohttp-lwt-unix-ssl/src/net.mli delete mode 100644 cohttp-lwt-unix-tls.opam delete mode 100644 cohttp-lwt-unix-tls/src/cohttp_lwt_unix_tls.ml delete mode 100644 cohttp-lwt-unix-tls/src/dune delete mode 100644 cohttp-lwt-unix-tls/src/net.ml delete mode 100644 cohttp-lwt-unix-tls/src/net.mli rename cohttp-lwt-unix-nossl.opam => cohttp-lwt-unix.opam (85%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/bin/cohttp_curl_lwt.ml (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/bin/cohttp_proxy_lwt.ml (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/bin/cohttp_server_lwt.ml (100%) create mode 100644 cohttp-lwt-unix/bin/dune rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/client.ml (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/client.mli (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/cohttp_lwt_unix.ml (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/debug.ml (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/debug.mli (100%) create mode 100644 cohttp-lwt-unix/src/dune rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/io.ml (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/io.mli (100%) rename {cohttp-lwt-unix-ssl => cohttp-lwt-unix}/src/net.ml (96%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/net.mli (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/server.ml (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/server.mli (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/test/dune (57%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/test/test_body.ml (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/test/test_parser.ml (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/test/test_sanity.ml (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/test/test_sanity_noisy.ml (100%) diff --git a/cohttp-lwt-unix-nossl/bin/dune b/cohttp-lwt-unix-nossl/bin/dune deleted file mode 100644 index 338101bf07..0000000000 --- a/cohttp-lwt-unix-nossl/bin/dune +++ /dev/null @@ -1,6 +0,0 @@ -(executables - (names cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt) - (libraries cohttp-lwt-unix-nossl cohttp_server logs logs.lwt logs.fmt - logs.cli cmdliner conduit-lwt conduit-lwt-ssl) - (package cohttp-lwt-unix-nossl) - (public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt)) diff --git a/cohttp-lwt-unix-nossl/src/dune b/cohttp-lwt-unix-nossl/src/dune deleted file mode 100644 index 9d83878c34..0000000000 --- a/cohttp-lwt-unix-nossl/src/dune +++ /dev/null @@ -1,8 +0,0 @@ -(library - (name cohttp_lwt_unix) - (public_name cohttp-lwt-unix-nossl) - (synopsis "Lwt/Unix backend for Cohttp") - (preprocess - (pps ppx_sexp_conv)) - (libraries fmt logs logs.lwt conduit-lwt magic-mime lwt.unix cohttp - cohttp-lwt)) diff --git a/cohttp-lwt-unix-nossl/src/net.ml b/cohttp-lwt-unix-nossl/src/net.ml deleted file mode 100644 index 70efd08a74..0000000000 --- a/cohttp-lwt-unix-nossl/src/net.ml +++ /dev/null @@ -1,53 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(* Miscellaneous net-helpers used by Cohttp. Ideally, these will disappear - * into some connection-management framework such as andrenth/release *) - -open Lwt.Infix - -module IO = Io - -type resolvers = Conduit.resolvers - -let empty = - Conduit_lwt.empty - |> Conduit_lwt.add Conduit_lwt.TCP.protocol - (Conduit_lwt.TCP.resolve ~port:80) - -let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt - -let connect_uri ?host:(default= "localhost") ~resolvers uri = - let domain_name = Domain_name.(host_exn (of_string_exn (Uri.host_with_default ~default uri))) in - Conduit_lwt.resolve resolvers domain_name >>= function - | Ok flow -> - let ic, oc = Conduit_lwt.io_of_flow flow in - Lwt.return (flow, ic, oc) - | Error err -> - failwith "%a" Conduit_lwt.pp_error err - -let close c = Lwt.catch - (fun () -> Lwt_io.close c) - (fun e -> - Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e)); - Lwt.return_unit - ) - -let close_in ic = Lwt.ignore_result (close ic) - -let close_out oc = Lwt.ignore_result (close oc) - -let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close oc) diff --git a/cohttp-lwt-unix-ssl.opam b/cohttp-lwt-unix-ssl.opam deleted file mode 100644 index 3ae6cbe501..0000000000 --- a/cohttp-lwt-unix-ssl.opam +++ /dev/null @@ -1,51 +0,0 @@ -opam-version: "2.0" -maintainer: "anil@recoil.org" -authors: [ - "Anil Madhavapeddy" - "Stefano Zacchiroli" - "David Sheets" - "Thomas Gazagnaire" - "David Scott" - "Rudi Grinberg" - "Andy Ray" -] -synopsis: "CoHTTP implementation for Unix and Windows using Lwt and SSL" -description: """ -An implementation of an HTTP client and server using the Lwt -concurrency library. See the `Cohttp_lwt_unix_ssl` module for information -on how to use this. The package also installs `cohttp-curl-lwt` -binary for quick uses of a HTTP(S) client. - -Although the name implies that this only works under Unix, it -should also be fine under Windows too.""" -license: "ISC" -tags: ["org:mirage" "org:xapi-project"] -homepage: "https://github.com/mirage/ocaml-cohttp" -doc: "https://mirage.github.io/ocaml-cohttp/" -bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" -depends: [ - "ocaml" {>= "4.04.1"} - "dune" {>= "1.1.0"} - "conduit-lwt" {>= "1.0.3"} - "conduit-lwt-ssl" - "cmdliner" - "magic-mime" - "logs" - "fmt" {>= "0.8.2"} - "cohttp-lwt" {=version} - "lwt" {>= "3.0.0"} - "lwt_ssl" - "base-unix" - "ounit" {with-test} -] -build: [ - ["dune" "subst"] {pinned} - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" -pin-depends: [ - [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-lwt-ssl.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-lwt.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] -] diff --git a/cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml b/cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml deleted file mode 100644 index b76de1abb7..0000000000 --- a/cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml +++ /dev/null @@ -1,31 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -module Request = struct - include Cohttp.Request - include (Make(Cohttp_lwt_unix.IO) - : module type of Make(Cohttp_lwt_unix.IO) with type t := t) -end - -module Response = struct - include Cohttp.Response - include (Make(Cohttp_lwt_unix.IO) - : module type of Make(Cohttp_lwt_unix.IO) with type t := t) -end - -module Client = Cohttp_lwt.Make_client(Cohttp_lwt_unix.IO)(Net) -module Net = Net -module IO = Cohttp_lwt_unix.IO diff --git a/cohttp-lwt-unix-ssl/src/dune b/cohttp-lwt-unix-ssl/src/dune deleted file mode 100644 index dcd7ef5b86..0000000000 --- a/cohttp-lwt-unix-ssl/src/dune +++ /dev/null @@ -1,7 +0,0 @@ -(library - (name cohttp_lwt_unix_ssl) - (public_name cohttp-lwt-unix-ssl) - (synopsis "Lwt/Unix backend for Cohttp with SSL support") - (preprocess - (pps ppx_sexp_conv)) - (libraries cohttp-lwt-unix-nossl conduit-lwt-ssl)) diff --git a/cohttp-lwt-unix-ssl/src/net.mli b/cohttp-lwt-unix-ssl/src/net.mli deleted file mode 100644 index 955328c3aa..0000000000 --- a/cohttp-lwt-unix-ssl/src/net.mli +++ /dev/null @@ -1,39 +0,0 @@ -(*{{{ Copyright (c) 2015 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** Basic satisfaction of {! Cohttp_lwt.Net } *) - -module IO = Cohttp_lwt_unix.IO - -type resolvers = Conduit.resolvers - -val empty : resolvers - -(** Exceptions from [conduit]. - - When the [recv] or the [send] {i syscalls} return an error, - [conduit] will reraise it. *) - -val connect_uri : - ?host:string -> - resolvers:resolvers -> - Uri.t -> - (Conduit_lwt.flow * Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel) Lwt.t - -val close_in : 'a Lwt_io.channel -> unit -val close_out : 'a Lwt_io.channel -> unit - -val close : 'a Lwt_io.channel -> 'b Lwt_io.channel -> unit diff --git a/cohttp-lwt-unix-tls.opam b/cohttp-lwt-unix-tls.opam deleted file mode 100644 index 8ecbe429e0..0000000000 --- a/cohttp-lwt-unix-tls.opam +++ /dev/null @@ -1,53 +0,0 @@ -opam-version: "2.0" -maintainer: "anil@recoil.org" -authors: [ - "Anil Madhavapeddy" - "Stefano Zacchiroli" - "David Sheets" - "Thomas Gazagnaire" - "David Scott" - "Rudi Grinberg" - "Andy Ray" -] -synopsis: "CoHTTP implementation for Unix and Windows using Lwt and TLS" -description: """ -An implementation of an HTTP client and server using the Lwt -concurrency library. See the `Cohttp_lwt_unix_tls` module for information -on how to use this. The package also installs `cohttp-curl-lwt` -binary for quick uses of a HTTP(S) client. - -Although the name implies that this only works under Unix, it -should also be fine under Windows too.""" -license: "ISC" -tags: ["org:mirage" "org:xapi-project"] -homepage: "https://github.com/mirage/ocaml-cohttp" -doc: "https://mirage.github.io/ocaml-cohttp/" -bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" -depends: [ - "ocaml" {>= "4.04.1"} - "dune" {>= "1.1.0"} - "conduit-lwt" {>= "1.0.3"} - "conduit-lwt-tls" - "mirage-crypto-rng" {>= "0.8.5"} - "cmdliner" - "magic-mime" - "logs" - "fmt" {>= "0.8.2"} - "cohttp-lwt" {=version} - "lwt" {>= "3.0.0"} - "lwt_ssl" - "base-unix" - "ounit" {with-test} -] -build: [ - ["dune" "subst"] {pinned} - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" -pin-depends: [ - [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-lwt-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-lwt.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] -] diff --git a/cohttp-lwt-unix-tls/src/cohttp_lwt_unix_tls.ml b/cohttp-lwt-unix-tls/src/cohttp_lwt_unix_tls.ml deleted file mode 100644 index b76de1abb7..0000000000 --- a/cohttp-lwt-unix-tls/src/cohttp_lwt_unix_tls.ml +++ /dev/null @@ -1,31 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -module Request = struct - include Cohttp.Request - include (Make(Cohttp_lwt_unix.IO) - : module type of Make(Cohttp_lwt_unix.IO) with type t := t) -end - -module Response = struct - include Cohttp.Response - include (Make(Cohttp_lwt_unix.IO) - : module type of Make(Cohttp_lwt_unix.IO) with type t := t) -end - -module Client = Cohttp_lwt.Make_client(Cohttp_lwt_unix.IO)(Net) -module Net = Net -module IO = Cohttp_lwt_unix.IO diff --git a/cohttp-lwt-unix-tls/src/dune b/cohttp-lwt-unix-tls/src/dune deleted file mode 100644 index 8c05a2f22b..0000000000 --- a/cohttp-lwt-unix-tls/src/dune +++ /dev/null @@ -1,7 +0,0 @@ -(library - (name cohttp_lwt_unix_tls) - (public_name cohttp-lwt-unix-tls) - (synopsis "Lwt/Unix backend for Cohttp with TLS support") - (preprocess - (pps ppx_sexp_conv)) - (libraries cohttp-lwt-unix-nossl mirage-crypto-rng.unix conduit-lwt-tls)) diff --git a/cohttp-lwt-unix-tls/src/net.ml b/cohttp-lwt-unix-tls/src/net.ml deleted file mode 100644 index d5edffd477..0000000000 --- a/cohttp-lwt-unix-tls/src/net.ml +++ /dev/null @@ -1,60 +0,0 @@ -(*{{{ Copyright (c) 2012 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(* Miscellaneous net-helpers used by Cohttp. Ideally, these will disappear - * into some connection-management framework such as andrenth/release *) - -open Lwt.Infix - -module IO = Cohttp_lwt_unix.IO - -type resolvers = Conduit.resolvers - -let () = Mirage_crypto_rng_unix.initialize () - -let authenticator ~host:_ _ = Ok None -let config = Tls.Config.client ~authenticator () - -let empty = - Conduit_lwt.empty - |> Conduit_lwt.add Conduit_lwt.TCP.protocol - (Conduit_lwt.TCP.resolve ~port:80) - |> Conduit_lwt.add ~priority:10 Conduit_lwt_tls.TCP.protocol - (Conduit_lwt_tls.TCP.resolve ~port:443 ~config) - -let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt - -let connect_uri ?host:(default= "localhost") ~resolvers uri = - let domain_name = Domain_name.(host_exn (of_string_exn (Uri.host_with_default ~default uri))) in - Conduit_lwt.resolve resolvers domain_name >>= function - | Ok flow -> - let ic, oc = Conduit_lwt.io_of_flow flow in - Lwt.return (flow, ic, oc) - | Error err -> - failwith "%a" Conduit_lwt.pp_error err - -let close c = Lwt.catch - (fun () -> Lwt_io.close c) - (fun e -> - Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e)); - Lwt.return_unit - ) - -let close_in ic = Lwt.ignore_result (close ic) - -let close_out oc = Lwt.ignore_result (close oc) - -let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close oc) diff --git a/cohttp-lwt-unix-tls/src/net.mli b/cohttp-lwt-unix-tls/src/net.mli deleted file mode 100644 index 955328c3aa..0000000000 --- a/cohttp-lwt-unix-tls/src/net.mli +++ /dev/null @@ -1,39 +0,0 @@ -(*{{{ Copyright (c) 2015 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - }}}*) - -(** Basic satisfaction of {! Cohttp_lwt.Net } *) - -module IO = Cohttp_lwt_unix.IO - -type resolvers = Conduit.resolvers - -val empty : resolvers - -(** Exceptions from [conduit]. - - When the [recv] or the [send] {i syscalls} return an error, - [conduit] will reraise it. *) - -val connect_uri : - ?host:string -> - resolvers:resolvers -> - Uri.t -> - (Conduit_lwt.flow * Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel) Lwt.t - -val close_in : 'a Lwt_io.channel -> unit -val close_out : 'a Lwt_io.channel -> unit - -val close : 'a Lwt_io.channel -> 'b Lwt_io.channel -> unit diff --git a/cohttp-lwt-unix-nossl.opam b/cohttp-lwt-unix.opam similarity index 85% rename from cohttp-lwt-unix-nossl.opam rename to cohttp-lwt-unix.opam index 45c8c467f6..61919cce70 100644 --- a/cohttp-lwt-unix-nossl.opam +++ b/cohttp-lwt-unix.opam @@ -28,6 +28,7 @@ depends: [ "ocaml" {>= "4.04.1"} "dune" {>= "1.1.0"} "conduit-lwt" {>= "1.0.3"} + "conduit-lwt-ssl" "cmdliner" "magic-mime" "logs" @@ -46,5 +47,7 @@ build: [ dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" pin-depends: [ [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-lwt-ssl.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] [ "conduit-lwt.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] ] diff --git a/cohttp-lwt-unix-nossl/bin/cohttp_curl_lwt.ml b/cohttp-lwt-unix/bin/cohttp_curl_lwt.ml similarity index 100% rename from cohttp-lwt-unix-nossl/bin/cohttp_curl_lwt.ml rename to cohttp-lwt-unix/bin/cohttp_curl_lwt.ml diff --git a/cohttp-lwt-unix-nossl/bin/cohttp_proxy_lwt.ml b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml similarity index 100% rename from cohttp-lwt-unix-nossl/bin/cohttp_proxy_lwt.ml rename to cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml diff --git a/cohttp-lwt-unix-nossl/bin/cohttp_server_lwt.ml b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml similarity index 100% rename from cohttp-lwt-unix-nossl/bin/cohttp_server_lwt.ml rename to cohttp-lwt-unix/bin/cohttp_server_lwt.ml diff --git a/cohttp-lwt-unix/bin/dune b/cohttp-lwt-unix/bin/dune new file mode 100644 index 0000000000..afb381dfeb --- /dev/null +++ b/cohttp-lwt-unix/bin/dune @@ -0,0 +1,6 @@ +(executables + (names cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt) + (libraries cohttp-lwt-unix cohttp_server logs logs.lwt logs.fmt logs.cli + cmdliner conduit-lwt conduit-lwt-ssl) + (package cohttp-lwt-unix) + (public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt)) diff --git a/cohttp-lwt-unix-nossl/src/client.ml b/cohttp-lwt-unix/src/client.ml similarity index 100% rename from cohttp-lwt-unix-nossl/src/client.ml rename to cohttp-lwt-unix/src/client.ml diff --git a/cohttp-lwt-unix-nossl/src/client.mli b/cohttp-lwt-unix/src/client.mli similarity index 100% rename from cohttp-lwt-unix-nossl/src/client.mli rename to cohttp-lwt-unix/src/client.mli diff --git a/cohttp-lwt-unix-nossl/src/cohttp_lwt_unix.ml b/cohttp-lwt-unix/src/cohttp_lwt_unix.ml similarity index 100% rename from cohttp-lwt-unix-nossl/src/cohttp_lwt_unix.ml rename to cohttp-lwt-unix/src/cohttp_lwt_unix.ml diff --git a/cohttp-lwt-unix-nossl/src/debug.ml b/cohttp-lwt-unix/src/debug.ml similarity index 100% rename from cohttp-lwt-unix-nossl/src/debug.ml rename to cohttp-lwt-unix/src/debug.ml diff --git a/cohttp-lwt-unix-nossl/src/debug.mli b/cohttp-lwt-unix/src/debug.mli similarity index 100% rename from cohttp-lwt-unix-nossl/src/debug.mli rename to cohttp-lwt-unix/src/debug.mli diff --git a/cohttp-lwt-unix/src/dune b/cohttp-lwt-unix/src/dune new file mode 100644 index 0000000000..81a100fa50 --- /dev/null +++ b/cohttp-lwt-unix/src/dune @@ -0,0 +1,8 @@ +(library + (name cohttp_lwt_unix) + (public_name cohttp-lwt-unix) + (synopsis "Lwt/Unix backend for Cohttp") + (preprocess + (pps ppx_sexp_conv)) + (libraries fmt logs logs.lwt conduit-lwt conduit-lwt-ssl magic-mime lwt.unix + cohttp cohttp-lwt)) diff --git a/cohttp-lwt-unix-nossl/src/io.ml b/cohttp-lwt-unix/src/io.ml similarity index 100% rename from cohttp-lwt-unix-nossl/src/io.ml rename to cohttp-lwt-unix/src/io.ml diff --git a/cohttp-lwt-unix-nossl/src/io.mli b/cohttp-lwt-unix/src/io.mli similarity index 100% rename from cohttp-lwt-unix-nossl/src/io.mli rename to cohttp-lwt-unix/src/io.mli diff --git a/cohttp-lwt-unix-ssl/src/net.ml b/cohttp-lwt-unix/src/net.ml similarity index 96% rename from cohttp-lwt-unix-ssl/src/net.ml rename to cohttp-lwt-unix/src/net.ml index b4bf0b0035..30981e72d3 100644 --- a/cohttp-lwt-unix-ssl/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -19,7 +19,7 @@ open Lwt.Infix -module IO = Cohttp_lwt_unix.IO +module IO = Io type resolvers = Conduit.resolvers @@ -32,7 +32,7 @@ let empty = Conduit_lwt.empty |> Conduit_lwt.add Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port:80) - |> Conduit_lwt.add ~priority:10 Conduit_lwt_ssl.TCP.protocol + |> Conduit_lwt.add Conduit_lwt_ssl.TCP.protocol (Conduit_lwt_ssl.TCP.resolve ~port:443 ~context:default_ssl_context) (* XXX(dinosaure) [cohttp-lwt-unix] provides a default resolve which is * able to start a simple TCP/IP connection or a TLS 1.3 connection to diff --git a/cohttp-lwt-unix-nossl/src/net.mli b/cohttp-lwt-unix/src/net.mli similarity index 100% rename from cohttp-lwt-unix-nossl/src/net.mli rename to cohttp-lwt-unix/src/net.mli diff --git a/cohttp-lwt-unix-nossl/src/server.ml b/cohttp-lwt-unix/src/server.ml similarity index 100% rename from cohttp-lwt-unix-nossl/src/server.ml rename to cohttp-lwt-unix/src/server.ml diff --git a/cohttp-lwt-unix-nossl/src/server.mli b/cohttp-lwt-unix/src/server.mli similarity index 100% rename from cohttp-lwt-unix-nossl/src/server.mli rename to cohttp-lwt-unix/src/server.mli diff --git a/cohttp-lwt-unix-nossl/test/dune b/cohttp-lwt-unix/test/dune similarity index 57% rename from cohttp-lwt-unix-nossl/test/dune rename to cohttp-lwt-unix/test/dune index b01d494b10..163c21cdcf 100644 --- a/cohttp-lwt-unix-nossl/test/dune +++ b/cohttp-lwt-unix/test/dune @@ -1,43 +1,43 @@ (executable (name test_parser) (modules test_parser) - (libraries cohttp-lwt-unix-nossl oUnit lwt.unix)) + (libraries cohttp-lwt-unix oUnit lwt.unix)) (rule (alias runtest) - (package cohttp-lwt-unix-nossl) + (package cohttp-lwt-unix) (action (run ./test_parser.exe))) (executable (modules test_sanity) (name test_sanity) - (libraries cohttp_lwt_unix_test cohttp-lwt-unix-nossl)) + (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) (executable (modules test_sanity_noisy) (name test_sanity_noisy) - (libraries cohttp_lwt_unix_test cohttp-lwt-unix-nossl)) + (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) (rule (alias runtest) - (package cohttp-lwt-unix-nossl) + (package cohttp-lwt-unix) (action (run ./test_sanity.exe))) (rule (alias runtest) - (package cohttp-lwt-unix-nossl) + (package cohttp-lwt-unix) (action (run ./test_sanity_noisy.exe))) (executable (modules test_body) (name test_body) - (libraries cohttp_lwt_unix_test cohttp-lwt-unix-nossl)) + (libraries cohttp_lwt_unix_test cohttp-lwt-unix)) (rule (alias runtest) - (package cohttp-lwt-unix-nossl) + (package cohttp-lwt-unix) (action (run ./test_body.exe))) diff --git a/cohttp-lwt-unix-nossl/test/test_body.ml b/cohttp-lwt-unix/test/test_body.ml similarity index 100% rename from cohttp-lwt-unix-nossl/test/test_body.ml rename to cohttp-lwt-unix/test/test_body.ml diff --git a/cohttp-lwt-unix-nossl/test/test_parser.ml b/cohttp-lwt-unix/test/test_parser.ml similarity index 100% rename from cohttp-lwt-unix-nossl/test/test_parser.ml rename to cohttp-lwt-unix/test/test_parser.ml diff --git a/cohttp-lwt-unix-nossl/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml similarity index 100% rename from cohttp-lwt-unix-nossl/test/test_sanity.ml rename to cohttp-lwt-unix/test/test_sanity.ml diff --git a/cohttp-lwt-unix-nossl/test/test_sanity_noisy.ml b/cohttp-lwt-unix/test/test_sanity_noisy.ml similarity index 100% rename from cohttp-lwt-unix-nossl/test/test_sanity_noisy.ml rename to cohttp-lwt-unix/test/test_sanity_noisy.ml diff --git a/cohttp_lwt_unix_test/src/dune b/cohttp_lwt_unix_test/src/dune index 8dcf99e1ab..cc9c9ecff7 100644 --- a/cohttp_lwt_unix_test/src/dune +++ b/cohttp_lwt_unix_test/src/dune @@ -1,4 +1,4 @@ (library (name cohttp_lwt_unix_test) (wrapped false) - (libraries conduit-lwt cohttp-lwt-unix-nossl cohttp_test oUnit)) + (libraries conduit-lwt cohttp-lwt-unix cohttp_test oUnit)) From f3a4fe073b6957d37b9b2a6d1cc011a288c344e9 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 23 Sep 2020 12:02:13 +0200 Subject: [PATCH 27/46] Use conduit-lwt-tls to provide a TLS connection with cohttp-lwt-unix (instead of conduit-lwt-ssl) --- cohttp-lwt-unix.opam | 4 ++-- cohttp-lwt-unix/src/dune | 4 ++-- cohttp-lwt-unix/src/net.ml | 18 +++++++----------- 3 files changed, 11 insertions(+), 15 deletions(-) diff --git a/cohttp-lwt-unix.opam b/cohttp-lwt-unix.opam index 61919cce70..5289c499ce 100644 --- a/cohttp-lwt-unix.opam +++ b/cohttp-lwt-unix.opam @@ -28,7 +28,7 @@ depends: [ "ocaml" {>= "4.04.1"} "dune" {>= "1.1.0"} "conduit-lwt" {>= "1.0.3"} - "conduit-lwt-ssl" + "conduit-lwt-tls" "cmdliner" "magic-mime" "logs" @@ -48,6 +48,6 @@ dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" pin-depends: [ [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] [ "conduit-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-lwt-ssl.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit-lwt-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] [ "conduit-lwt.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] ] diff --git a/cohttp-lwt-unix/src/dune b/cohttp-lwt-unix/src/dune index 81a100fa50..e039eec473 100644 --- a/cohttp-lwt-unix/src/dune +++ b/cohttp-lwt-unix/src/dune @@ -4,5 +4,5 @@ (synopsis "Lwt/Unix backend for Cohttp") (preprocess (pps ppx_sexp_conv)) - (libraries fmt logs logs.lwt conduit-lwt conduit-lwt-ssl magic-mime lwt.unix - cohttp cohttp-lwt)) + (libraries mirage-crypto-rng.unix fmt logs logs.lwt conduit-lwt + conduit-lwt-tls magic-mime lwt.unix cohttp cohttp-lwt)) diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index 30981e72d3..719062ba8f 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -23,23 +23,19 @@ module IO = Io type resolvers = Conduit.resolvers -let () = Ssl.init () +let () = Mirage_crypto_rng_unix.initialize () -let default_ssl_context = - Ssl.create_context Ssl.SSLv23 Ssl.Client_context +let authenticator ~host:_ _ = Ok None + +let tls_config = + Tls.Config.client ~authenticator () let empty = Conduit_lwt.empty |> Conduit_lwt.add Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port:80) - |> Conduit_lwt.add Conduit_lwt_ssl.TCP.protocol - (Conduit_lwt_ssl.TCP.resolve ~port:443 ~context:default_ssl_context) -(* XXX(dinosaure) [cohttp-lwt-unix] provides a default resolve which is - * able to start a simple TCP/IP connection or a TLS 1.3 connection to - * handle [http] and [https] cases. - * - * The user is able to prioritize over these resolvers its own resolver - * such as one with a specific [Ssl.context] (with TLS 1.3 support) if he wants. *) + |> Conduit_lwt.add ~priority:10 Conduit_lwt_tls.TCP.protocol + (Conduit_lwt_tls.TCP.resolve ~port:443 ~config:tls_config) let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt From 2f346f1aef0312f29e3283e176607d46c972620d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 23 Sep 2020 12:08:35 +0200 Subject: [PATCH 28/46] Rename resolvers to ctx --- cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml | 24 +++++++-------- cohttp-lwt-unix/src/client.mli | 2 +- cohttp-lwt-unix/src/net.ml | 6 ++-- cohttp-lwt-unix/src/net.mli | 6 ++-- cohttp-lwt-unix/test/test_sanity.ml | 20 ++++++------- cohttp-lwt-unix/test/test_sanity_noisy.ml | 8 ++--- cohttp-lwt/src/client.ml | 36 +++++++++++------------ cohttp-lwt/src/client.mli | 2 +- cohttp-lwt/src/s.ml | 30 +++++++++---------- cohttp-mirage/src/client.ml | 6 ++-- cohttp-mirage/src/client.mli | 2 +- 11 files changed, 71 insertions(+), 71 deletions(-) diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml b/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml index c73f208a7d..47b653bba7 100644 --- a/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml @@ -122,31 +122,31 @@ module Make_api(X : sig module Request = X.Request module Response = X.Response - type resolvers = unit + type ctx = unit - let call ?resolvers:_ ?headers ?body ?chunked:_ meth uri = + let call ?ctx:_ ?headers ?body ?chunked:_ meth uri = X.call ?headers ?body meth uri (* The HEAD should not have a response body *) - let head ?resolvers ?headers uri = + let head ?ctx ?headers uri = let open Lwt in - call ?resolvers ?headers ~chunked:false `HEAD uri + call ?ctx ?headers ~chunked:false `HEAD uri >|= fst - let get ?resolvers ?headers uri = call ?resolvers ?headers ~chunked:false `GET uri - let delete ?resolvers ?body ?chunked ?headers uri = call ?resolvers ?headers ?body ?chunked `DELETE uri - let post ?resolvers ?body ?chunked ?headers uri = call ?resolvers ?headers ?body ?chunked `POST uri - let put ?resolvers ?body ?chunked ?headers uri = call ?resolvers ?headers ?body ?chunked `PUT uri - let patch ?resolvers ?body ?chunked ?headers uri = call ?resolvers ?headers ?body ?chunked `PATCH uri + let get ?ctx ?headers uri = call ?ctx ?headers ~chunked:false `GET uri + let delete ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `DELETE uri + let post ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `POST uri + let put ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `PUT uri + let patch ?ctx ?body ?chunked ?headers uri = call ?ctx ?headers ?body ?chunked `PATCH uri - let post_form ?resolvers ?headers ~params uri = + let post_form ?ctx ?headers ~params uri = let headers = C.Header.add_opt headers "content-type" "application/x-www-form-urlencoded" in let body = Cohttp_lwt.Body.of_string (Uri.encoded_of_query params) in - post ?resolvers ~chunked:false ~headers ~body uri + post ?ctx ~chunked:false ~headers ~body uri (* No implementation (can it be done?). What should the failure exception be? *) exception Cohttp_lwt_xhr_callv_not_implemented - let callv ?resolvers:_ _uri _reqs = + let callv ?ctx:_ _uri _reqs = Lwt.fail Cohttp_lwt_xhr_callv_not_implemented (* ??? *) end diff --git a/cohttp-lwt-unix/src/client.mli b/cohttp-lwt-unix/src/client.mli index 59ae57f8b7..e0b0631d28 100644 --- a/cohttp-lwt-unix/src/client.mli +++ b/cohttp-lwt-unix/src/client.mli @@ -2,4 +2,4 @@ (** The [Client] module implements the full UNIX HTTP client interface, including the UNIX-specific functions defined in {!C }. *) -include Cohttp_lwt.S.Client with type resolvers = Conduit.resolvers +include Cohttp_lwt.S.Client with type ctx = Conduit.resolvers diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index 719062ba8f..f968244c94 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -21,7 +21,7 @@ open Lwt.Infix module IO = Io -type resolvers = Conduit.resolvers +type ctx = Conduit.resolvers let () = Mirage_crypto_rng_unix.initialize () @@ -39,9 +39,9 @@ let empty = let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt -let connect_uri ?host:(default= "localhost") ~resolvers uri = +let connect_uri ?host:(default= "localhost") ~ctx uri = let domain_name = Domain_name.(host_exn (of_string_exn (Uri.host_with_default ~default uri))) in - Conduit_lwt.resolve resolvers domain_name >>= function + Conduit_lwt.resolve ctx domain_name >>= function | Ok flow -> let ic, oc = Conduit_lwt.io_of_flow flow in Lwt.return (flow, ic, oc) diff --git a/cohttp-lwt-unix/src/net.mli b/cohttp-lwt-unix/src/net.mli index 49ba25cdae..b1f9942fc9 100644 --- a/cohttp-lwt-unix/src/net.mli +++ b/cohttp-lwt-unix/src/net.mli @@ -18,9 +18,9 @@ module IO = Io -type resolvers = Conduit.resolvers +type ctx = Conduit.resolvers -val empty : resolvers +val empty : ctx (** Exceptions from [conduit]. @@ -29,7 +29,7 @@ val empty : resolvers val connect_uri : ?host:string -> - resolvers:resolvers -> + ctx:ctx -> Uri.t -> (Conduit_lwt.flow * Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel) Lwt.t diff --git a/cohttp-lwt-unix/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml index f381761cc0..11b975a8f5 100644 --- a/cohttp-lwt-unix/test/test_sanity.ml +++ b/cohttp-lwt-unix/test/test_sanity.ml @@ -97,14 +97,14 @@ let check_logs test () = let ts = Cohttp_lwt_unix_test.test_server_s server begin fun uri -> - let resolvers = match Uri.port uri with + let ctx = match Uri.port uri with | Some port -> Cohttp_lwt_unix.Net.empty |> Conduit_lwt.add ~priority:0 Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port) | None -> Cohttp_lwt_unix.Net.empty in let t () = - Client.get ~resolvers uri >>= fun (_, body) -> + Client.get ~ctx uri >>= fun (_, body) -> body |> Body.to_string >|= fun body -> assert_equal body message in let pipelined_chunk () = @@ -116,7 +116,7 @@ let ts = Request.make ~meth:`HEAD uri, `Empty; ] in let counter = ref 0 in - Client.callv ~resolvers uri (Lwt_stream.of_list reqs) >>= fun resps -> + Client.callv ~ctx uri (Lwt_stream.of_list reqs) >>= fun resps -> Lwt_stream.iter_s (fun (_, rbody) -> rbody |> Body.to_string >|= fun rbody -> begin match !counter with @@ -134,7 +134,7 @@ let ts = let (reqs, push) = Lwt_stream.create () in push (Some (r 1)); push (Some (r 2)); - Client.callv ~resolvers uri reqs >>= fun resps -> + Client.callv ~ctx uri reqs >>= fun resps -> let resps = Lwt_stream.map_s (fun (_, b) -> Body.to_string b) resps in Lwt_stream.fold (fun b i -> Logs.info (fun f -> f "Request %i\n" i); @@ -154,29 +154,29 @@ let ts = assert_equal l 3 in let massive_chunked () = - Client.get ~resolvers uri >>= fun (_resp, body) -> + Client.get ~ctx uri >>= fun (_resp, body) -> Body.to_string body >|= fun body -> assert_equal ~printer:string_of_int (1000 * 64) (String.length body) in let test_no_leak () = let stream = Array.init leak_repeat (fun _ -> uri) |> Lwt_stream.of_array in Lwt_stream.fold_s (fun uri () -> - Client.head ~resolvers uri >>= fun resp_head -> + Client.head ~ctx uri >>= fun resp_head -> assert_equal (Response.status resp_head) `OK; - Client.get ~resolvers uri >>= fun (resp_get, body) -> + Client.get ~ctx uri >>= fun (resp_get, body) -> assert_equal (Response.status resp_get) `OK; Body.drain_body body) stream () in let expert_pipelined () = let printer x = x in - Client.get ~resolvers uri >>= fun (_rsp, body) -> + Client.get ~ctx uri >>= fun (_rsp, body) -> Body.to_string body >>= fun body -> assert_equal ~printer "expert 1" body; - Client.get ~resolvers uri >>= fun (_rsp, body) -> + Client.get ~ctx uri >>= fun (_rsp, body) -> Body.to_string body >|= fun body -> assert_equal ~printer "expert 2" body in let client_close () = - Cohttp_lwt_unix.Net.(connect_uri ~resolvers) uri >>= fun (_conn, ic, oc) -> + Cohttp_lwt_unix.Net.(connect_uri ~ctx) uri >>= fun (_conn, ic, oc) -> let req = Cohttp.Request.make_for_client ~chunked:false `GET (Uri.with_path uri "/test.html") in Request.write (fun _writer -> Lwt.return_unit) req oc >>= fun () -> diff --git a/cohttp-lwt-unix/test/test_sanity_noisy.ml b/cohttp-lwt-unix/test/test_sanity_noisy.ml index 909857c5c2..548bd42c0c 100644 --- a/cohttp-lwt-unix/test/test_sanity_noisy.ml +++ b/cohttp-lwt-unix/test/test_sanity_noisy.ml @@ -44,18 +44,18 @@ let server_noisy = let ts_noisy = Cohttp_lwt_unix_test.test_server_s ~port:10193 server_noisy begin fun uri -> - let resolvers = match Uri.port uri with + let ctx = match Uri.port uri with | Some port -> Cohttp_lwt_unix.Net.empty |> Conduit_lwt.add ~priority:0 Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port) | None -> Cohttp_lwt_unix.Net.empty in let empty_chunk () = - Client.get ~resolvers uri >>= fun (_, body) -> + Client.get ~ctx uri >>= fun (_, body) -> body |> Body.to_string >|= fun body -> assert_equal body (String.concat "" chunk_body) in let not_modified_has_no_body () = - Client.get ~resolvers uri >>= fun (resp, body) -> + Client.get ~ctx uri >>= fun (resp, body) -> assert_equal (Response.status resp) `Not_modified; let headers = Response.headers resp in assert_equal ~printer:Transfer.string_of_encoding @@ -69,7 +69,7 @@ let ts_noisy = ~mode:Lwt_io.Output fname >>= fun oc -> Lwt_io.write_line oc "never read" >>= fun () -> Lwt_io.close oc >>= fun () -> - Client.post ~resolvers uri ~body:(Body.of_string fname) + Client.post ~ctx uri ~body:(Body.of_string fname) >>= begin fun (resp, body) -> assert_equal ~printer:Code.string_of_status (Response.status resp) `Internal_server_error; diff --git a/cohttp-lwt/src/client.ml b/cohttp-lwt/src/client.ml index e5fd92f11e..a4449ff410 100644 --- a/cohttp-lwt/src/client.ml +++ b/cohttp-lwt/src/client.ml @@ -10,7 +10,7 @@ module Make module Response = Make.Response(IO) module Request = Make.Request(IO) - type resolvers = Net.resolvers + type ctx = Net.ctx let read_response ~closefn ic _oc meth = Response.read ic >>= begin function @@ -46,9 +46,9 @@ module Make | `DELETE -> false | _ -> true - let call ?(resolvers= Net.empty) ?headers ?(body=`Empty) ?chunked meth uri = + let call ?(ctx= Net.empty) ?headers ?(body=`Empty) ?chunked meth uri = let headers = match headers with None -> Header.init () | Some h -> h in - Net.connect_uri ~resolvers uri >>= fun (_conn, ic, oc) -> + Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) -> let closefn () = Net.close ic oc in let chunked = match chunked with @@ -73,28 +73,28 @@ module Make read_response ~closefn ic oc meth (* The HEAD should not have a response body *) - let head ?resolvers ?headers uri = - call ?resolvers ?headers `HEAD uri + let head ?ctx ?headers uri = + call ?ctx ?headers `HEAD uri >|= fst - let get ?resolvers ?headers uri = call ?resolvers ?headers `GET uri - let delete ?resolvers ?body ?chunked ?headers uri = - call ?resolvers ?headers ?body ?chunked `DELETE uri - let post ?resolvers ?body ?chunked ?headers uri = - call ?resolvers ?headers ?body ?chunked `POST uri - let put ?resolvers ?body ?chunked ?headers uri = - call ?resolvers ?headers ?body ?chunked `PUT uri - let patch ?resolvers ?body ?chunked ?headers uri = - call ?resolvers ?headers ?body ?chunked `PATCH uri + let get ?ctx ?headers uri = call ?ctx ?headers `GET uri + let delete ?ctx ?body ?chunked ?headers uri = + call ?ctx ?headers ?body ?chunked `DELETE uri + let post ?ctx ?body ?chunked ?headers uri = + call ?ctx ?headers ?body ?chunked `POST uri + let put ?ctx ?body ?chunked ?headers uri = + call ?ctx ?headers ?body ?chunked `PUT uri + let patch ?ctx ?body ?chunked ?headers uri = + call ?ctx ?headers ?body ?chunked `PATCH uri - let post_form ?resolvers ?headers ~params uri = + let post_form ?ctx ?headers ~params uri = let headers = Header.add_opt_unless_exists headers "content-type" "application/x-www-form-urlencoded" in let body = Body.of_string (Uri.encoded_of_query params) in - post ?resolvers ~chunked:false ~headers ~body uri + post ?ctx ~chunked:false ~headers ~body uri - let callv ?(resolvers= Net.empty) uri reqs = - Net.connect_uri ~resolvers uri >>= fun (_conn, ic, oc) -> + let callv ?(ctx= Net.empty) uri reqs = + Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) -> (* Serialise the requests out to the wire *) let meth_stream = Lwt_stream.map_s (fun (req,body) -> Request.write (fun writer -> diff --git a/cohttp-lwt/src/client.mli b/cohttp-lwt/src/client.mli index f3a22ca020..f76fc6f3f5 100644 --- a/cohttp-lwt/src/client.mli +++ b/cohttp-lwt/src/client.mli @@ -4,4 +4,4 @@ module. The resulting module satisfies the {! Client } module type. *) module Make (IO:S.IO) (Net:S.Net with module IO = IO) : S.Client - with type resolvers = Net.resolvers + with type ctx = Net.ctx diff --git a/cohttp-lwt/src/s.ml b/cohttp-lwt/src/s.ml index 07dc0d2587..773b67d6de 100644 --- a/cohttp-lwt/src/s.ml +++ b/cohttp-lwt/src/s.ml @@ -22,10 +22,10 @@ end module type Net = sig module IO : IO - type resolvers + type ctx - val empty : resolvers - val connect_uri : ?host:string -> resolvers:resolvers -> Uri.t -> (IO.conn * IO.ic * IO.oc) Lwt.t + val empty : ctx + val connect_uri : ?host:string -> ctx:ctx -> Uri.t -> (IO.conn * IO.ic * IO.oc) Lwt.t val close_in : IO.ic -> unit val close_out : IO.oc -> unit val close : IO.ic -> IO.oc -> unit @@ -38,11 +38,11 @@ end fashion. It will still be finalized by a GC hook if it is not used up, but this can take some additional time to happen. *) module type Client = sig - type resolvers + type ctx - (** [call ?resolvers ?headers ?body ?chunked meth uri] will resolve the + (** [call ?ctx ?headers ?body ?chunked meth uri] will resolve the [uri] to a concrete network endpoint using the resolver initialized - in [resolvers]. It will then issue an HTTP request with method [meth], + in [ctx]. It will then issue an HTTP request with method [meth], adding request headers from [headers] if present. If a [body] is specified then that will be included with the request, using chunked encoding if [chunked] is true. The default is to disable @@ -52,7 +52,7 @@ module type Client = sig interface rather than invoke this function directly. See {!head}, {!get} and {!post} for some examples. *) val call : - ?resolvers:resolvers -> + ?ctx:ctx -> ?headers:Cohttp.Header.t -> ?body:Body.t -> ?chunked:bool -> @@ -60,51 +60,51 @@ module type Client = sig Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val head : - ?resolvers:resolvers -> + ?ctx:ctx -> ?headers:Cohttp.Header.t -> Uri.t -> Cohttp.Response.t Lwt.t val get : - ?resolvers:resolvers -> + ?ctx:ctx -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val delete : - ?resolvers:resolvers -> + ?ctx:ctx -> ?body:Body.t -> ?chunked:bool -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val post : - ?resolvers:resolvers -> + ?ctx:ctx -> ?body:Body.t -> ?chunked:bool -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val put : - ?resolvers:resolvers -> + ?ctx:ctx -> ?body:Body.t -> ?chunked:bool -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val patch : - ?resolvers:resolvers -> + ?ctx:ctx -> ?body:Body.t -> ?chunked:bool -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val post_form : - ?resolvers:resolvers -> + ?ctx:ctx -> ?headers:Cohttp.Header.t -> params:(string * string list) list -> Uri.t -> (Cohttp.Response.t * Body.t) Lwt.t val callv : - ?resolvers:resolvers -> + ?ctx:ctx -> Uri.t -> (Cohttp.Request.t * Body.t) Lwt_stream.t -> (Cohttp.Response.t * Body.t) Lwt_stream.t Lwt.t diff --git a/cohttp-mirage/src/client.ml b/cohttp-mirage/src/client.ml index c9d4ca026c..fadfd1b7b9 100644 --- a/cohttp-mirage/src/client.ml +++ b/cohttp-mirage/src/client.ml @@ -26,15 +26,15 @@ module Net_IO = struct module IO = HTTP_IO - type resolvers = Conduit.resolvers + type ctx = Conduit.resolvers let empty = Conduit.empty let failwith fmt = Fmt.kstrf (fun err -> Lwt.fail (Failure err)) fmt - let connect_uri ?host:(default= "localhost") ~resolvers uri = + let connect_uri ?host:(default= "localhost") ~ctx uri = let domain_name = Domain_name.(host_exn (of_string_exn (Uri.host_with_default ~default uri))) in - Conduit_mirage.resolve resolvers domain_name >>= function + Conduit_mirage.resolve ctx domain_name >>= function | Ok flow -> let ch = Channel.create flow in Lwt.return (flow, ch, ch) diff --git a/cohttp-mirage/src/client.mli b/cohttp-mirage/src/client.mli index c7972e5866..d8c82bc7c8 100644 --- a/cohttp-mirage/src/client.mli +++ b/cohttp-mirage/src/client.mli @@ -1,2 +1,2 @@ include Cohttp_lwt.S.Client - with type resolvers = Conduit.resolvers + with type ctx = Conduit.resolvers From dfcc589d05f6069ed2dbeca121586d00b6858e06 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 23 Sep 2020 12:22:37 +0200 Subject: [PATCH 29/46] Net.ctx is sexpable --- cohttp-lwt-unix/src/net.ml | 2 +- cohttp-lwt-unix/src/net.mli | 2 +- cohttp-lwt/src/s.ml | 2 +- cohttp-mirage/src/client.ml | 3 ++- cohttp-mirage/src/dune | 2 ++ 5 files changed, 7 insertions(+), 4 deletions(-) diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index f968244c94..ab14dde12e 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -21,7 +21,7 @@ open Lwt.Infix module IO = Io -type ctx = Conduit.resolvers +type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] let () = Mirage_crypto_rng_unix.initialize () diff --git a/cohttp-lwt-unix/src/net.mli b/cohttp-lwt-unix/src/net.mli index b1f9942fc9..10c669b9be 100644 --- a/cohttp-lwt-unix/src/net.mli +++ b/cohttp-lwt-unix/src/net.mli @@ -18,7 +18,7 @@ module IO = Io -type ctx = Conduit.resolvers +type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] val empty : ctx diff --git a/cohttp-lwt/src/s.ml b/cohttp-lwt/src/s.ml index 773b67d6de..941510ac46 100644 --- a/cohttp-lwt/src/s.ml +++ b/cohttp-lwt/src/s.ml @@ -22,7 +22,7 @@ end module type Net = sig module IO : IO - type ctx + type ctx [@@deriving sexp] val empty : ctx val connect_uri : ?host:string -> ctx:ctx -> Uri.t -> (IO.conn * IO.ic * IO.oc) Lwt.t diff --git a/cohttp-mirage/src/client.ml b/cohttp-mirage/src/client.ml index fadfd1b7b9..b66e3dae82 100644 --- a/cohttp-mirage/src/client.ml +++ b/cohttp-mirage/src/client.ml @@ -22,11 +22,12 @@ open Lwt.Infix module Channel = Mirage_channel.Make(Conduit_mirage_flow) module HTTP_IO = Io.Make(Channel) + module Net_IO = struct module IO = HTTP_IO - type ctx = Conduit.resolvers + type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] let empty = Conduit.empty diff --git a/cohttp-mirage/src/dune b/cohttp-mirage/src/dune index 4e74c9e5ce..ca62bfd2fc 100644 --- a/cohttp-mirage/src/dune +++ b/cohttp-mirage/src/dune @@ -3,5 +3,7 @@ (public_name cohttp-mirage) (synopsis "Mirage backend for cohttp") (wrapped false) + (preprocess + (pps ppx_sexp_conv)) (libraries conduit-mirage.flow cohttp-lwt mirage-channel conduit-mirage mirage-kv mirage-flow magic-mime astring)) From 2e74d83f72cd24ef3d06cde7eea1734437cea0cd Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 23 Sep 2020 14:46:48 +0200 Subject: [PATCH 30/46] Use conduit-lwt-tls instead conduit-lwt-ssl in binaries --- cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml | 44 +++++++++++++----------- cohttp-lwt-unix/bin/cohttp_server_lwt.ml | 38 +++++++++++--------- cohttp-lwt-unix/bin/dune | 2 +- 3 files changed, 46 insertions(+), 38 deletions(-) diff --git a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml index 85bb89d655..eb4643d76a 100644 --- a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml @@ -26,16 +26,14 @@ let option_bind x f = match x with | Some x -> f x | None -> None -let ssl_protocol, ssl_service = - let open Conduit_lwt_ssl.TCP in - protocol, service - let sockaddr_of_flow : Conduit_lwt.flow -> Unix.sockaddr option = fun flow -> match Conduit_lwt.cast flow Conduit_lwt.TCP.protocol, - Conduit_lwt.cast flow ssl_protocol with + Conduit_lwt.cast flow Conduit_lwt_tls.TCP.protocol with | Some flow, None -> Some (Conduit_lwt.TCP.Protocol.sock flow) - | None, Some flow -> Some (Lwt_ssl.getsockname flow) + | None, Some flow -> + let flow = Conduit_lwt_tls.underlying flow in + Some (Conduit_lwt.TCP.Protocol.sock flow) | _ -> None let pp_sockaddr ppf = function @@ -75,12 +73,12 @@ let handler ~verbose _ req body = in Server.respond ~headers ~status ~body () -let load_ssl ?(version= Ssl.TLSv1_2) (cert, key) = - try - let ctx = Ssl.create_context version Ssl.Server_context in - Ssl.use_certificate ctx cert key ; - Some ctx - with _ -> None +let load_file filename = + let ic = open_in filename in + let ln = in_channel_length ic in + let rs = Bytes.create ln in + really_input ic rs 0 ln ; close_in ic ; + Cstruct.of_bytes rs let sockaddr_of_host_and_port host port = let inet_addr = Unix.inet_addr_of_string host in @@ -96,17 +94,21 @@ let start_proxy port host verbose cert key = (pp_option pp_sockaddr) (sockaddr_of_flow ch) in let callback = handler ~verbose in let config = Server.make ~callback ~conn_closed () in - let ssl = match cert, key with - | Some cert, Some key -> Some (cert, key) - | None, None -> None - | _ -> failwith "A TLS proxy requires a certificates and a key" in - let ssl_config = option_bind ssl load_ssl in + let tls_config = + match cert, key with + | Some cert, Some key -> + let open Rresult in + X509.Certificate.decode_pem_multiple (load_file cert) >>= fun certs -> + X509.Private_key.decode_pem (load_file key) >>| fun (`RSA key) -> + Tls.Config.server ~certificates:(`Single (certs, key)) () + | _ -> Error (`Msg "No TLS certificate") in + let tls_config = Rresult.R.to_option tls_config in let tcp_config = { Conduit_lwt.TCP.sockaddr= sockaddr_of_host_and_port host port - ; capacity= 40; } in - match ssl_config with - | Some ssl_config -> - Server.create (ssl_config, tcp_config) ssl_protocol ssl_service config + ; capacity= 40 } in + match tls_config with + | Some tls_config -> + Server.create (tcp_config, tls_config) Conduit_lwt_tls.TCP.protocol Conduit_lwt_tls.TCP.service config | None -> Server.create tcp_config Conduit_lwt.TCP.protocol Conduit_lwt.TCP.service config diff --git a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml index c586425723..3580428caf 100644 --- a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml @@ -28,16 +28,14 @@ let option_bind x f = match x with let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server" module Log = (val Logs.src_log src : Logs.LOG) -let ssl_protocol, ssl_service = - let open Conduit_lwt_ssl.TCP in - protocol, service - let sockaddr_of_flow : Conduit_lwt.flow -> Unix.sockaddr option = fun flow -> match Conduit_lwt.cast flow Conduit_lwt.TCP.protocol, - Conduit_lwt.cast flow ssl_protocol with + Conduit_lwt.cast flow Conduit_lwt_tls.TCP.protocol with | Some flow, None -> Some (Conduit_lwt.TCP.Protocol.sock flow) - | None, Some flow -> Some (Lwt_ssl.getsockname flow) + | None, Some flow -> + let flow = Conduit_lwt_tls.underlying flow in + Some (Conduit_lwt.TCP.Protocol.sock flow) | _ -> None let pp_sockaddr ppf = function @@ -122,12 +120,12 @@ let handler ~info ~docroot ~index (ch,_conn) req _body = Server.respond_string ~headers ~status:`Method_not_allowed ~body:(html_of_method_not_allowed meth (String.concat "," allowed) path info) () -let load_ssl ?(version= Ssl.TLSv1_2) (cert, key) = - try - let ctx = Ssl.create_context version Ssl.Server_context in - Ssl.use_certificate ctx cert key ; - Some ctx - with _ -> None +let load_file filename = + let ic = open_in filename in + let ln = in_channel_length ic in + let rs = Bytes.create ln in + really_input ic rs 0 ln ; close_in ic ; + Cstruct.of_bytes rs let sockaddr_of_host_and_port host port = let inet_addr = Unix.inet_addr_of_string host in @@ -141,13 +139,21 @@ let start_server docroot port host index tls = Fmt.(option pp_sockaddr) (sockaddr_of_flow ch)) in let callback = handler ~info ~docroot ~index in let config = Server.make ~callback ~conn_closed () in - let ssl_config = option_bind tls load_ssl in + let tls_config = + match tls with + | Some (cert, key) -> + let open Rresult in + X509.Certificate.decode_pem_multiple (load_file cert) >>= fun certs -> + X509.Private_key.decode_pem (load_file key) >>| fun (`RSA key) -> + Tls.Config.server ~certificates:(`Single (certs, key)) () + | _ -> Error (`Msg "No TLS certificate") in + let tls_config = Rresult.R.to_option tls_config in let tcp_config = { Conduit_lwt.TCP.sockaddr= sockaddr_of_host_and_port host port ; capacity= 40; } in - match ssl_config with - | Some ssl_config -> - Server.create (ssl_config, tcp_config) ssl_protocol ssl_service config + match tls_config with + | Some tls_config -> + Server.create (tcp_config, tls_config) Conduit_lwt_tls.TCP.protocol Conduit_lwt_tls.TCP.service config | None -> Server.create tcp_config Conduit_lwt.TCP.protocol Conduit_lwt.TCP.service config diff --git a/cohttp-lwt-unix/bin/dune b/cohttp-lwt-unix/bin/dune index afb381dfeb..a76a0c4c00 100644 --- a/cohttp-lwt-unix/bin/dune +++ b/cohttp-lwt-unix/bin/dune @@ -1,6 +1,6 @@ (executables (names cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt) (libraries cohttp-lwt-unix cohttp_server logs logs.lwt logs.fmt logs.cli - cmdliner conduit-lwt conduit-lwt-ssl) + cmdliner conduit-lwt) (package cohttp-lwt-unix) (public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt)) From 10ce452be074e91400c81271fd444af62c130019 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 23 Sep 2020 15:29:02 +0200 Subject: [PATCH 31/46] Delete lwt_ssl as a dependency of cohttp-lwt-unix (we use ocaml-tls instead) --- cohttp-lwt-unix.opam | 1 - 1 file changed, 1 deletion(-) diff --git a/cohttp-lwt-unix.opam b/cohttp-lwt-unix.opam index 5289c499ce..300bec4bd7 100644 --- a/cohttp-lwt-unix.opam +++ b/cohttp-lwt-unix.opam @@ -35,7 +35,6 @@ depends: [ "fmt" {>= "0.8.2"} "cohttp-lwt" {=version} "lwt" {>= "3.0.0"} - "lwt_ssl" "base-unix" "ounit" {with-test} ] From 0a8c31a79ba35f4e086f97e29b0c4f75d57dafac Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 2 Oct 2020 17:27:22 +0200 Subject: [PATCH 32/46] Use the last version of conduit (new concrete endpoint) --- cohttp-async.opam | 8 ++++---- cohttp-lwt-unix.opam | 8 ++++---- cohttp-lwt-unix/src/net.ml | 14 +++++++++++--- cohttp-mirage.opam | 6 +++--- cohttp-mirage/src/client.ml | 14 +++++++++++--- 5 files changed, 33 insertions(+), 17 deletions(-) diff --git a/cohttp-async.opam b/cohttp-async.opam index 39f49b23c7..ab80470f83 100644 --- a/cohttp-async.opam +++ b/cohttp-async.opam @@ -51,8 +51,8 @@ build: [ ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" pin-depends: [ - [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-async-ssl.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-async.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-async-ssl.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-async.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] ] diff --git a/cohttp-lwt-unix.opam b/cohttp-lwt-unix.opam index 300bec4bd7..26092d92df 100644 --- a/cohttp-lwt-unix.opam +++ b/cohttp-lwt-unix.opam @@ -45,8 +45,8 @@ build: [ ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" pin-depends: [ - [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-lwt-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-lwt.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-lwt-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] ] diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index ab14dde12e..ba632fc086 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -39,9 +39,17 @@ let empty = let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt -let connect_uri ?host:(default= "localhost") ~ctx uri = - let domain_name = Domain_name.(host_exn (of_string_exn (Uri.host_with_default ~default uri))) in - Conduit_lwt.resolve ctx domain_name >>= function +let uri_to_endpoint ?host:(default= "localhost") uri = + let v = Uri.host_with_default ~default uri in + let ( >>= ) x f = match x with Ok x -> f x | Error err -> Error err in + match Domain_name.(of_string v >>= host), Ipaddr.of_string v with + | Ok domain_name, _ -> Lwt.return (Conduit.Endpoint.domain domain_name) + | Error _, Ok v -> Lwt.return (Conduit.Endpoint.ip v) + | Error _, Error _ -> failwith "Invalid uri: %a" Uri.pp uri + +let connect_uri ?host ~ctx uri = + uri_to_endpoint ?host uri >>= fun edn -> + Conduit_lwt.resolve ctx edn >>= function | Ok flow -> let ic, oc = Conduit_lwt.io_of_flow flow in Lwt.return (flow, ic, oc) diff --git a/cohttp-mirage.opam b/cohttp-mirage.opam index 756540ce92..c5a51cc1a2 100644 --- a/cohttp-mirage.opam +++ b/cohttp-mirage.opam @@ -38,7 +38,7 @@ build: [ ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" pin-depends: [ - [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] - [ "conduit-mirage.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#4dffc531e6dde24fcc6aec84bb453f5bea277e80" ] + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-mirage.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] ] diff --git a/cohttp-mirage/src/client.ml b/cohttp-mirage/src/client.ml index b66e3dae82..dfcafe5f24 100644 --- a/cohttp-mirage/src/client.ml +++ b/cohttp-mirage/src/client.ml @@ -33,9 +33,17 @@ module Net_IO = struct let failwith fmt = Fmt.kstrf (fun err -> Lwt.fail (Failure err)) fmt - let connect_uri ?host:(default= "localhost") ~ctx uri = - let domain_name = Domain_name.(host_exn (of_string_exn (Uri.host_with_default ~default uri))) in - Conduit_mirage.resolve ctx domain_name >>= function + let uri_to_endpoint ?host:(default= "localhost") uri = + let v = Uri.host_with_default ~default uri in + let ( >>= ) x f = match x with Ok x -> f x | Error err -> Error err in + match Domain_name.(of_string v >>= host), Ipaddr.of_string v with + | Ok domain_name, _ -> Lwt.return (Conduit.Endpoint.domain domain_name) + | Error _, Ok v -> Lwt.return (Conduit.Endpoint.ip v) + | Error _, Error _ -> failwith "Invalid uri: %a" Uri.pp uri + + let connect_uri ?host ~ctx uri = + uri_to_endpoint ?host uri >>= fun edn -> + Conduit_mirage.resolve ctx edn >>= function | Ok flow -> let ch = Channel.create flow in Lwt.return (flow, ch, ch) From e97c646e68fe1a1e0cb859eb64300beadb1515e8 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 2 Oct 2020 17:48:05 +0200 Subject: [PATCH 33/46] Fix flaky tests on async --- cohttp_async_test/src/cohttp_async_test.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/cohttp_async_test/src/cohttp_async_test.ml b/cohttp_async_test/src/cohttp_async_test.ml index c893bbbb73..ff4bc91322 100644 --- a/cohttp_async_test/src/cohttp_async_test.ml +++ b/cohttp_async_test/src/cohttp_async_test.ml @@ -24,7 +24,7 @@ let const rsp _req _body = rsp >>| response let response_sequence = Cohttp_test.response_sequence failwith let get_port = - let port = ref 8080 in + let port = ref 10_000 in (fun () -> let v = !port in Int.incr port ; v ) let temp_server ?port spec callback = @@ -36,7 +36,9 @@ let temp_server ?port spec callback = ~protocol:Conduit_async.TCP.protocol ~service:Conduit_async.TCP.service (Conduit_async.TCP.Listen (None, Async.Tcp.Where_to_listen.of_port port)) (fun ~body _sock req -> spec req body) in - Async.Deferred.both (server ()) (callback uri >>= fun res -> + Async.Deferred.both (server ()) + (Async.after Core.Time.Span.(of_sec 0.5) >>= fun () -> + callback uri >>= fun res -> Async.Condition.broadcast stop () ; Async.return res) >>= fun ((), res) -> Async.return res From 7f0efc6d7e0420e3abff99d29633519785c41f4b Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 2 Oct 2020 17:59:09 +0200 Subject: [PATCH 34/46] Fix the documentation on cohttp-async --- cohttp-async/src/server.mli | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/cohttp-async/src/server.mli b/cohttp-async/src/server.mli index 3437243789..83599adc30 100644 --- a/cohttp-async/src/server.mli +++ b/cohttp-async/src/server.mli @@ -28,7 +28,8 @@ val respond : response respond_t val resolve_local_file : docroot:string -> uri:Uri.t -> string (** Respond with a [string] Pipe that provides the response string - Pipe.Reader.t. @param code Default is HTTP 200 `OK *) + Pipe.Reader.t. + @param code Default is HTTP 200 `OK *) val respond_with_pipe : ?flush:bool -> ?headers:Cohttp.Header.t -> ?code:Cohttp.Code.status_code -> From a21c9c663c80ba051306d71c6b6c31ce20993e61 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 4 Oct 2020 10:47:35 +0200 Subject: [PATCH 35/46] conduit-lwt-tls is responsible to initialize the PRNG, not cohttp-lwt-unix --- cohttp-lwt-unix/src/dune | 2 +- cohttp-lwt-unix/src/net.ml | 2 -- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/cohttp-lwt-unix/src/dune b/cohttp-lwt-unix/src/dune index e039eec473..908c7303d9 100644 --- a/cohttp-lwt-unix/src/dune +++ b/cohttp-lwt-unix/src/dune @@ -4,5 +4,5 @@ (synopsis "Lwt/Unix backend for Cohttp") (preprocess (pps ppx_sexp_conv)) - (libraries mirage-crypto-rng.unix fmt logs logs.lwt conduit-lwt + (libraries fmt logs logs.lwt conduit-lwt conduit-lwt-tls magic-mime lwt.unix cohttp cohttp-lwt)) diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index ba632fc086..6dee16d321 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -23,8 +23,6 @@ module IO = Io type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] -let () = Mirage_crypto_rng_unix.initialize () - let authenticator ~host:_ _ = Ok None let tls_config = From f0400d6bb6037643d226aa589e5bf8cbccd4c24f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 4 Oct 2020 10:59:15 +0200 Subject: [PATCH 36/46] cohttp-lwt-unix: allow passing a custom tls_config --- cohttp-lwt-unix/src/client.ml | 2 ++ cohttp-lwt-unix/src/client.mli | 3 +++ cohttp-lwt-unix/src/net.ml | 6 ++++-- cohttp-lwt-unix/src/net.mli | 2 ++ 4 files changed, 11 insertions(+), 2 deletions(-) diff --git a/cohttp-lwt-unix/src/client.ml b/cohttp-lwt-unix/src/client.ml index b7138d5f56..2af115ccde 100644 --- a/cohttp-lwt-unix/src/client.ml +++ b/cohttp-lwt-unix/src/client.ml @@ -1,2 +1,4 @@ include Cohttp_lwt.Make_client(Io)(Net) + +let custom_ctx = Net.init diff --git a/cohttp-lwt-unix/src/client.mli b/cohttp-lwt-unix/src/client.mli index e0b0631d28..f036527f55 100644 --- a/cohttp-lwt-unix/src/client.mli +++ b/cohttp-lwt-unix/src/client.mli @@ -3,3 +3,6 @@ including the UNIX-specific functions defined in {!C }. *) include Cohttp_lwt.S.Client with type ctx = Conduit.resolvers + +val custom_ctx : ?ctx:Conduit.resolvers -> ?tls_config:Tls.Config.client + -> unit -> ctx diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index 6dee16d321..7a21ef115a 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -23,13 +23,15 @@ module IO = Io type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] +let empty = Conduit_lwt.empty + let authenticator ~host:_ _ = Ok None let tls_config = Tls.Config.client ~authenticator () -let empty = - Conduit_lwt.empty +let init ?(ctx = empty) ?(tls_config = tls_config) () = + ctx |> Conduit_lwt.add Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port:80) |> Conduit_lwt.add ~priority:10 Conduit_lwt_tls.TCP.protocol diff --git a/cohttp-lwt-unix/src/net.mli b/cohttp-lwt-unix/src/net.mli index 10c669b9be..8332690f3d 100644 --- a/cohttp-lwt-unix/src/net.mli +++ b/cohttp-lwt-unix/src/net.mli @@ -22,6 +22,8 @@ type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] val empty : ctx +val init : ?ctx:ctx -> ?tls_config:Tls.Config.client -> unit -> ctx + (** Exceptions from [conduit]. When the [recv] or the [send] {i syscalls} return an error, From 3f7032e80896609eff60005d2677aeab4f4d0062 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 4 Oct 2020 11:38:59 +0200 Subject: [PATCH 37/46] cohttp-lwt - revert default_ctx -> empty change - remove ?host from connect_uri --- cohttp-lwt-unix/src/client.mli | 3 +-- cohttp-lwt-unix/src/net.ml | 18 ++++++++++-------- cohttp-lwt-unix/src/net.mli | 5 ++--- cohttp-lwt/src/client.ml | 4 ++-- cohttp-lwt/src/s.ml | 4 ++-- cohttp-mirage/src/client.ml | 12 +++++++----- 6 files changed, 24 insertions(+), 22 deletions(-) diff --git a/cohttp-lwt-unix/src/client.mli b/cohttp-lwt-unix/src/client.mli index f036527f55..5f95dbf916 100644 --- a/cohttp-lwt-unix/src/client.mli +++ b/cohttp-lwt-unix/src/client.mli @@ -4,5 +4,4 @@ include Cohttp_lwt.S.Client with type ctx = Conduit.resolvers -val custom_ctx : ?ctx:Conduit.resolvers -> ?tls_config:Tls.Config.client - -> unit -> ctx +val custom_ctx : ?tls_config:Tls.Config.client -> unit -> ctx diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index 7a21ef115a..0d4fbf56c6 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -23,32 +23,34 @@ module IO = Io type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] -let empty = Conduit_lwt.empty - let authenticator ~host:_ _ = Ok None let tls_config = Tls.Config.client ~authenticator () -let init ?(ctx = empty) ?(tls_config = tls_config) () = - ctx +let init ?(tls_config = tls_config) () = + Conduit_lwt.empty |> Conduit_lwt.add Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port:80) |> Conduit_lwt.add ~priority:10 Conduit_lwt_tls.TCP.protocol (Conduit_lwt_tls.TCP.resolve ~port:443 ~config:tls_config) +let default_ctx = init () + let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt -let uri_to_endpoint ?host:(default= "localhost") uri = - let v = Uri.host_with_default ~default uri in +let uri_to_endpoint uri = + (match Uri.host uri with + | None -> failwith "Invalid uri: no host component in %a" Uri.pp uri + | Some h -> Lwt.return h) >>= fun v -> let ( >>= ) x f = match x with Ok x -> f x | Error err -> Error err in match Domain_name.(of_string v >>= host), Ipaddr.of_string v with | Ok domain_name, _ -> Lwt.return (Conduit.Endpoint.domain domain_name) | Error _, Ok v -> Lwt.return (Conduit.Endpoint.ip v) | Error _, Error _ -> failwith "Invalid uri: %a" Uri.pp uri -let connect_uri ?host ~ctx uri = - uri_to_endpoint ?host uri >>= fun edn -> +let connect_uri ~ctx uri = + uri_to_endpoint uri >>= fun edn -> Conduit_lwt.resolve ctx edn >>= function | Ok flow -> let ic, oc = Conduit_lwt.io_of_flow flow in diff --git a/cohttp-lwt-unix/src/net.mli b/cohttp-lwt-unix/src/net.mli index 8332690f3d..81e38ac4d3 100644 --- a/cohttp-lwt-unix/src/net.mli +++ b/cohttp-lwt-unix/src/net.mli @@ -20,9 +20,9 @@ module IO = Io type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] -val empty : ctx +val default_ctx : ctx -val init : ?ctx:ctx -> ?tls_config:Tls.Config.client -> unit -> ctx +val init : ?tls_config:Tls.Config.client -> unit -> ctx (** Exceptions from [conduit]. @@ -30,7 +30,6 @@ val init : ?ctx:ctx -> ?tls_config:Tls.Config.client -> unit -> ctx [conduit] will reraise it. *) val connect_uri : - ?host:string -> ctx:ctx -> Uri.t -> (Conduit_lwt.flow * Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel) Lwt.t diff --git a/cohttp-lwt/src/client.ml b/cohttp-lwt/src/client.ml index a4449ff410..982626f814 100644 --- a/cohttp-lwt/src/client.ml +++ b/cohttp-lwt/src/client.ml @@ -46,7 +46,7 @@ module Make | `DELETE -> false | _ -> true - let call ?(ctx= Net.empty) ?headers ?(body=`Empty) ?chunked meth uri = + let call ?(ctx = Net.default_ctx) ?headers ?(body=`Empty) ?chunked meth uri = let headers = match headers with None -> Header.init () | Some h -> h in Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) -> let closefn () = Net.close ic oc in @@ -93,7 +93,7 @@ module Make let body = Body.of_string (Uri.encoded_of_query params) in post ?ctx ~chunked:false ~headers ~body uri - let callv ?(ctx= Net.empty) uri reqs = + let callv ?(ctx = Net.default_ctx) uri reqs = Net.connect_uri ~ctx uri >>= fun (_conn, ic, oc) -> (* Serialise the requests out to the wire *) let meth_stream = Lwt_stream.map_s (fun (req,body) -> diff --git a/cohttp-lwt/src/s.ml b/cohttp-lwt/src/s.ml index 941510ac46..b5a618edec 100644 --- a/cohttp-lwt/src/s.ml +++ b/cohttp-lwt/src/s.ml @@ -24,8 +24,8 @@ module type Net = sig type ctx [@@deriving sexp] - val empty : ctx - val connect_uri : ?host:string -> ctx:ctx -> Uri.t -> (IO.conn * IO.ic * IO.oc) Lwt.t + val default_ctx : ctx + val connect_uri : ctx:ctx -> Uri.t -> (IO.conn * IO.ic * IO.oc) Lwt.t val close_in : IO.ic -> unit val close_out : IO.oc -> unit val close : IO.ic -> IO.oc -> unit diff --git a/cohttp-mirage/src/client.ml b/cohttp-mirage/src/client.ml index dfcafe5f24..d132b4d8ba 100644 --- a/cohttp-mirage/src/client.ml +++ b/cohttp-mirage/src/client.ml @@ -29,20 +29,22 @@ module Net_IO = struct type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] - let empty = Conduit.empty + let default_ctx = Conduit.empty let failwith fmt = Fmt.kstrf (fun err -> Lwt.fail (Failure err)) fmt - let uri_to_endpoint ?host:(default= "localhost") uri = - let v = Uri.host_with_default ~default uri in + let uri_to_endpoint uri = + (match Uri.host uri with + | None -> failwith "Invalid uri: no host component in %a" Uri.pp uri + | Some h -> Lwt.return h) >>= fun v -> let ( >>= ) x f = match x with Ok x -> f x | Error err -> Error err in match Domain_name.(of_string v >>= host), Ipaddr.of_string v with | Ok domain_name, _ -> Lwt.return (Conduit.Endpoint.domain domain_name) | Error _, Ok v -> Lwt.return (Conduit.Endpoint.ip v) | Error _, Error _ -> failwith "Invalid uri: %a" Uri.pp uri - let connect_uri ?host ~ctx uri = - uri_to_endpoint ?host uri >>= fun edn -> + let connect_uri ~ctx uri = + uri_to_endpoint uri >>= fun edn -> Conduit_mirage.resolve ctx edn >>= function | Ok flow -> let ch = Channel.create flow in From 6b0335ddd068fed8bc5f4663a1dead80c4bbe33a Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 5 Oct 2020 15:37:17 +0200 Subject: [PATCH 38/46] Fix tests about previous renaming of Net module --- cohttp-lwt-unix/test/test_sanity.ml | 7 +------ cohttp-lwt-unix/test/test_sanity_noisy.ml | 7 +------ 2 files changed, 2 insertions(+), 12 deletions(-) diff --git a/cohttp-lwt-unix/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml index 11b975a8f5..71767c2e37 100644 --- a/cohttp-lwt-unix/test/test_sanity.ml +++ b/cohttp-lwt-unix/test/test_sanity.ml @@ -97,12 +97,7 @@ let check_logs test () = let ts = Cohttp_lwt_unix_test.test_server_s server begin fun uri -> - let ctx = match Uri.port uri with - | Some port -> - Cohttp_lwt_unix.Net.empty - |> Conduit_lwt.add ~priority:0 Conduit_lwt.TCP.protocol - (Conduit_lwt.TCP.resolve ~port) - | None -> Cohttp_lwt_unix.Net.empty in + let ctx = Cohttp_lwt_unix.Net.init () in let t () = Client.get ~ctx uri >>= fun (_, body) -> body |> Body.to_string >|= fun body -> diff --git a/cohttp-lwt-unix/test/test_sanity_noisy.ml b/cohttp-lwt-unix/test/test_sanity_noisy.ml index 548bd42c0c..d5bac1da29 100644 --- a/cohttp-lwt-unix/test/test_sanity_noisy.ml +++ b/cohttp-lwt-unix/test/test_sanity_noisy.ml @@ -44,12 +44,7 @@ let server_noisy = let ts_noisy = Cohttp_lwt_unix_test.test_server_s ~port:10193 server_noisy begin fun uri -> - let ctx = match Uri.port uri with - | Some port -> - Cohttp_lwt_unix.Net.empty - |> Conduit_lwt.add ~priority:0 Conduit_lwt.TCP.protocol - (Conduit_lwt.TCP.resolve ~port) - | None -> Cohttp_lwt_unix.Net.empty in + let ctx = Cohttp_lwt_unix.Net.init () in let empty_chunk () = Client.get ~ctx uri >>= fun (_, body) -> body |> Body.to_string >|= fun body -> From f206d671e7094ba1a7709e0a2e3f9ffff78dc102 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 5 Oct 2020 15:37:39 +0200 Subject: [PATCH 39/46] Correctly handle ports from the given Uri.t --- cohttp-lwt-unix/src/net.ml | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index 0d4fbf56c6..be47a7ffcd 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -51,6 +51,22 @@ let uri_to_endpoint uri = let connect_uri ~ctx uri = uri_to_endpoint uri >>= fun edn -> + (* XXX(dinosaure): this situation is not the right one, [connect_uri] should + * take [Conduit.Endpoint.t] and use the given [ctx] which is well-defined + * by the user. However, [Cohttp] proposes a /default/ [ctx]. + * + * We can see an another use of [Conduit] with [Cohttp_async] which does not + * rely on the given [ctx] but it uses [Conduit_async.connect] according to + * the introspection of the given [uri]. We have 3 incompatible choices here: + * - expect an user's [ctx] with a [Conduit.Endpoint.t] + * - make a [ctx] from the given [uri] + * - *) + let ctx = match Uri.scheme uri, Uri.port uri with + | Some "https", Some port -> + Conduit_lwt.add ~priority:0 Conduit_lwt_tls.TCP.protocol (Conduit_lwt_tls.TCP.resolve ~port ~config:tls_config) ctx + | (Some "http" | None), Some port -> + Conduit_lwt.add ~priority:0 Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port) ctx + | _ -> ctx in Conduit_lwt.resolve ctx edn >>= function | Ok flow -> let ic, oc = Conduit_lwt.io_of_flow flow in From fc39c982ba287b8377e0df7f67281996c0e4e0a9 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 5 Oct 2020 15:40:10 +0200 Subject: [PATCH 40/46] Apply dune @fmt --- cohttp-lwt-unix/src/dune | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cohttp-lwt-unix/src/dune b/cohttp-lwt-unix/src/dune index 908c7303d9..04c607ccec 100644 --- a/cohttp-lwt-unix/src/dune +++ b/cohttp-lwt-unix/src/dune @@ -4,5 +4,5 @@ (synopsis "Lwt/Unix backend for Cohttp") (preprocess (pps ppx_sexp_conv)) - (libraries fmt logs logs.lwt conduit-lwt - conduit-lwt-tls magic-mime lwt.unix cohttp cohttp-lwt)) + (libraries fmt logs logs.lwt conduit-lwt conduit-lwt-tls magic-mime lwt.unix + cohttp cohttp-lwt)) From 0221253d7cea47814a3adba9a4cecd8f6e16fcdd Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 12 Oct 2020 15:59:59 +0200 Subject: [PATCH 41/46] Delete Cohttp_lwt_unix.Net.init and custom_ctx, the real default ctx is an empty ctx --- cohttp-lwt-unix/src/client.ml | 2 -- cohttp-lwt-unix/src/client.mli | 2 -- cohttp-lwt-unix/src/net.ml | 33 +++++++---------------- cohttp-lwt-unix/src/net.mli | 2 -- cohttp-lwt-unix/test/test_sanity.ml | 2 +- cohttp-lwt-unix/test/test_sanity_noisy.ml | 2 +- 6 files changed, 12 insertions(+), 31 deletions(-) diff --git a/cohttp-lwt-unix/src/client.ml b/cohttp-lwt-unix/src/client.ml index 2af115ccde..b7138d5f56 100644 --- a/cohttp-lwt-unix/src/client.ml +++ b/cohttp-lwt-unix/src/client.ml @@ -1,4 +1,2 @@ include Cohttp_lwt.Make_client(Io)(Net) - -let custom_ctx = Net.init diff --git a/cohttp-lwt-unix/src/client.mli b/cohttp-lwt-unix/src/client.mli index 5f95dbf916..e0b0631d28 100644 --- a/cohttp-lwt-unix/src/client.mli +++ b/cohttp-lwt-unix/src/client.mli @@ -3,5 +3,3 @@ including the UNIX-specific functions defined in {!C }. *) include Cohttp_lwt.S.Client with type ctx = Conduit.resolvers - -val custom_ctx : ?tls_config:Tls.Config.client -> unit -> ctx diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index be47a7ffcd..ad4bed6b17 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -28,14 +28,7 @@ let authenticator ~host:_ _ = Ok None let tls_config = Tls.Config.client ~authenticator () -let init ?(tls_config = tls_config) () = - Conduit_lwt.empty - |> Conduit_lwt.add Conduit_lwt.TCP.protocol - (Conduit_lwt.TCP.resolve ~port:80) - |> Conduit_lwt.add ~priority:10 Conduit_lwt_tls.TCP.protocol - (Conduit_lwt_tls.TCP.resolve ~port:443 ~config:tls_config) - -let default_ctx = init () +let default_ctx = Conduit_lwt.empty let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt @@ -51,21 +44,15 @@ let uri_to_endpoint uri = let connect_uri ~ctx uri = uri_to_endpoint uri >>= fun edn -> - (* XXX(dinosaure): this situation is not the right one, [connect_uri] should - * take [Conduit.Endpoint.t] and use the given [ctx] which is well-defined - * by the user. However, [Cohttp] proposes a /default/ [ctx]. - * - * We can see an another use of [Conduit] with [Cohttp_async] which does not - * rely on the given [ctx] but it uses [Conduit_async.connect] according to - * the introspection of the given [uri]. We have 3 incompatible choices here: - * - expect an user's [ctx] with a [Conduit.Endpoint.t] - * - make a [ctx] from the given [uri] - * - *) - let ctx = match Uri.scheme uri, Uri.port uri with - | Some "https", Some port -> - Conduit_lwt.add ~priority:0 Conduit_lwt_tls.TCP.protocol (Conduit_lwt_tls.TCP.resolve ~port ~config:tls_config) ctx - | (Some "http" | None), Some port -> - Conduit_lwt.add ~priority:0 Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port) ctx + let ctx = match Uri.scheme uri with + | Some "https" -> + let port = Option.value ~default:443 (Uri.port uri) in + Conduit_lwt.add + Conduit_lwt_tls.TCP.protocol + (Conduit_lwt_tls.TCP.resolve ~port ~config:tls_config) ctx + | (Some "http" | None) -> + let port = Option.value ~default:80 (Uri.port uri) in + Conduit_lwt.add Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port) ctx | _ -> ctx in Conduit_lwt.resolve ctx edn >>= function | Ok flow -> diff --git a/cohttp-lwt-unix/src/net.mli b/cohttp-lwt-unix/src/net.mli index 81e38ac4d3..25d9cd000d 100644 --- a/cohttp-lwt-unix/src/net.mli +++ b/cohttp-lwt-unix/src/net.mli @@ -22,8 +22,6 @@ type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] val default_ctx : ctx -val init : ?tls_config:Tls.Config.client -> unit -> ctx - (** Exceptions from [conduit]. When the [recv] or the [send] {i syscalls} return an error, diff --git a/cohttp-lwt-unix/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml index 71767c2e37..60e29446b0 100644 --- a/cohttp-lwt-unix/test/test_sanity.ml +++ b/cohttp-lwt-unix/test/test_sanity.ml @@ -97,7 +97,7 @@ let check_logs test () = let ts = Cohttp_lwt_unix_test.test_server_s server begin fun uri -> - let ctx = Cohttp_lwt_unix.Net.init () in + let ctx = Cohttp_lwt_unix.Net.default_ctx in let t () = Client.get ~ctx uri >>= fun (_, body) -> body |> Body.to_string >|= fun body -> diff --git a/cohttp-lwt-unix/test/test_sanity_noisy.ml b/cohttp-lwt-unix/test/test_sanity_noisy.ml index d5bac1da29..927819c682 100644 --- a/cohttp-lwt-unix/test/test_sanity_noisy.ml +++ b/cohttp-lwt-unix/test/test_sanity_noisy.ml @@ -44,7 +44,7 @@ let server_noisy = let ts_noisy = Cohttp_lwt_unix_test.test_server_s ~port:10193 server_noisy begin fun uri -> - let ctx = Cohttp_lwt_unix.Net.init () in + let ctx = Cohttp_lwt_unix.Net.default_ctx in let empty_chunk () = Client.get ~ctx uri >>= fun (_, body) -> body |> Body.to_string >|= fun body -> From 8443defbf9dafc9cc2b82352e9806c2e143345d5 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 12 Oct 2020 20:26:54 +0200 Subject: [PATCH 42/46] cohttp-lwt-unix: use ca-certs, authenticate client connections --- cohttp-lwt-unix.opam | 1 + cohttp-lwt-unix/src/dune | 2 +- cohttp-lwt-unix/src/net.ml | 5 ++++- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/cohttp-lwt-unix.opam b/cohttp-lwt-unix.opam index 26092d92df..96c40b7ea8 100644 --- a/cohttp-lwt-unix.opam +++ b/cohttp-lwt-unix.opam @@ -29,6 +29,7 @@ depends: [ "dune" {>= "1.1.0"} "conduit-lwt" {>= "1.0.3"} "conduit-lwt-tls" + "ca-certs" "cmdliner" "magic-mime" "logs" diff --git a/cohttp-lwt-unix/src/dune b/cohttp-lwt-unix/src/dune index 04c607ccec..3e3cd05689 100644 --- a/cohttp-lwt-unix/src/dune +++ b/cohttp-lwt-unix/src/dune @@ -5,4 +5,4 @@ (preprocess (pps ppx_sexp_conv)) (libraries fmt logs logs.lwt conduit-lwt conduit-lwt-tls magic-mime lwt.unix - cohttp cohttp-lwt)) + ca-certs cohttp cohttp-lwt)) diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index be47a7ffcd..180b2b8d6e 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -23,7 +23,10 @@ module IO = Io type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] -let authenticator ~host:_ _ = Ok None +let authenticator = + match Ca_certs.authenticator () with + | Ok a -> a + | Error (`Msg msg) -> failwith msg let tls_config = Tls.Config.client ~authenticator () From 7d562811dc471d3b5de60b78ef8b3a23eca7553a Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 13 Oct 2020 19:39:42 +0200 Subject: [PATCH 43/46] Handle peer name when we can on TLS connection --- cohttp-lwt-unix/src/net.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index 2ad6202cd5..dfd68bb0bf 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -28,8 +28,8 @@ let authenticator = | Ok a -> a | Error (`Msg msg) -> failwith msg -let tls_config = - Tls.Config.client ~authenticator () +let tls_config ?peer_name () = + Tls.Config.client ~authenticator ?peer_name () let default_ctx = Conduit_lwt.empty @@ -41,14 +41,15 @@ let uri_to_endpoint uri = | Some h -> Lwt.return h) >>= fun v -> let ( >>= ) x f = match x with Ok x -> f x | Error err -> Error err in match Domain_name.(of_string v >>= host), Ipaddr.of_string v with - | Ok domain_name, _ -> Lwt.return (Conduit.Endpoint.domain domain_name) - | Error _, Ok v -> Lwt.return (Conduit.Endpoint.ip v) + | Ok domain_name, _ -> Lwt.return (Conduit.Endpoint.domain domain_name, Some v) + | Error _, Ok v -> Lwt.return (Conduit.Endpoint.ip v, None) | Error _, Error _ -> failwith "Invalid uri: %a" Uri.pp uri let connect_uri ~ctx uri = - uri_to_endpoint uri >>= fun edn -> + uri_to_endpoint uri >>= fun (edn, peer_name) -> let ctx = match Uri.scheme uri with | Some "https" -> + let tls_config = tls_config ?peer_name () in let port = Option.value ~default:443 (Uri.port uri) in Conduit_lwt.add Conduit_lwt_tls.TCP.protocol From 8bd204d533da94cd62062f2370e7de982fe401ca Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 14 Oct 2020 14:40:14 +0200 Subject: [PATCH 44/46] Add cohttp-lwt-unix-nossl and cohttp-lwt-unix-ssl (update cohttp-lwt-unix to use cohttp-lwt-unix-nossl) --- cohttp-lwt-unix-nossl.opam | 50 +++++++++++ cohttp-lwt-unix-nossl/src/client.ml | 2 + cohttp-lwt-unix-nossl/src/client.mli | 5 ++ .../src/cohttp_lwt_unix_nossl.ml | 33 +++++++ .../src/debug.ml | 0 .../src/debug.mli | 0 cohttp-lwt-unix-nossl/src/dune | 8 ++ .../src/io.ml | 0 .../src/io.mli | 0 cohttp-lwt-unix-nossl/src/net.ml | 65 ++++++++++++++ cohttp-lwt-unix-nossl/src/net.mli | 38 +++++++++ .../src/server.ml | 0 .../src/server.mli | 0 cohttp-lwt-unix-ssl.opam | 54 ++++++++++++ cohttp-lwt-unix-ssl/src/client.ml | 2 + cohttp-lwt-unix-ssl/src/client.mli | 5 ++ .../src/cohttp_lwt_unix_ssl.ml | 33 +++++++ cohttp-lwt-unix-ssl/src/dune | 8 ++ cohttp-lwt-unix-ssl/src/net.ml | 85 +++++++++++++++++++ cohttp-lwt-unix-ssl/src/net.mli | 38 +++++++++ cohttp-lwt-unix.opam | 9 +- cohttp-lwt-unix/src/client.ml | 2 +- cohttp-lwt-unix/src/cohttp_lwt_unix.ml | 14 +-- cohttp-lwt-unix/src/dune | 2 +- cohttp-lwt-unix/src/net.ml | 14 ++- cohttp-lwt-unix/src/net.mli | 2 +- 26 files changed, 447 insertions(+), 22 deletions(-) create mode 100644 cohttp-lwt-unix-nossl.opam create mode 100644 cohttp-lwt-unix-nossl/src/client.ml create mode 100644 cohttp-lwt-unix-nossl/src/client.mli create mode 100644 cohttp-lwt-unix-nossl/src/cohttp_lwt_unix_nossl.ml rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/debug.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/debug.mli (100%) create mode 100644 cohttp-lwt-unix-nossl/src/dune rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/io.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/io.mli (100%) create mode 100644 cohttp-lwt-unix-nossl/src/net.ml create mode 100644 cohttp-lwt-unix-nossl/src/net.mli rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/server.ml (100%) rename {cohttp-lwt-unix => cohttp-lwt-unix-nossl}/src/server.mli (100%) create mode 100644 cohttp-lwt-unix-ssl.opam create mode 100644 cohttp-lwt-unix-ssl/src/client.ml create mode 100644 cohttp-lwt-unix-ssl/src/client.mli create mode 100644 cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml create mode 100644 cohttp-lwt-unix-ssl/src/dune create mode 100644 cohttp-lwt-unix-ssl/src/net.ml create mode 100644 cohttp-lwt-unix-ssl/src/net.mli diff --git a/cohttp-lwt-unix-nossl.opam b/cohttp-lwt-unix-nossl.opam new file mode 100644 index 0000000000..b0055a0dc4 --- /dev/null +++ b/cohttp-lwt-unix-nossl.opam @@ -0,0 +1,50 @@ +opam-version: "2.0" +maintainer: "anil@recoil.org" +authors: [ + "Anil Madhavapeddy" + "Stefano Zacchiroli" + "David Sheets" + "Thomas Gazagnaire" + "David Scott" + "Rudi Grinberg" + "Andy Ray" +] +synopsis: "CoHTTP implementation for Unix and Windows using Lwt" +description: """ +An implementation of an HTTP client and server using the Lwt +concurrency library. See the `Cohttp_lwt_unix` module for information +on how to use this. The package also installs `cohttp-curl-lwt` +and a `cohttp-server-lwt` binaries for quick uses of a HTTP(S) +client and server respectively. + +Although the name implies that this only works under Unix, it +should also be fine under Windows too.""" +license: "ISC" +tags: ["org:mirage" "org:xapi-project"] +homepage: "https://github.com/mirage/ocaml-cohttp" +doc: "https://mirage.github.io/ocaml-cohttp/" +bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" +depends: [ + "ocaml" {>= "4.04.1"} + "dune" {>= "1.1.0"} + "conduit-lwt" {>= "1.0.3"} + "ca-certs" + "cmdliner" + "magic-mime" + "logs" + "fmt" {>= "0.8.2"} + "cohttp-lwt" {=version} + "lwt" {>= "3.0.0"} + "base-unix" + "ounit" {with-test} +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" +pin-depends: [ + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] + [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] +] diff --git a/cohttp-lwt-unix-nossl/src/client.ml b/cohttp-lwt-unix-nossl/src/client.ml new file mode 100644 index 0000000000..b7138d5f56 --- /dev/null +++ b/cohttp-lwt-unix-nossl/src/client.ml @@ -0,0 +1,2 @@ + +include Cohttp_lwt.Make_client(Io)(Net) diff --git a/cohttp-lwt-unix-nossl/src/client.mli b/cohttp-lwt-unix-nossl/src/client.mli new file mode 100644 index 0000000000..e0b0631d28 --- /dev/null +++ b/cohttp-lwt-unix-nossl/src/client.mli @@ -0,0 +1,5 @@ + +(** The [Client] module implements the full UNIX HTTP client interface, + including the UNIX-specific functions defined in {!C }. *) + +include Cohttp_lwt.S.Client with type ctx = Conduit.resolvers diff --git a/cohttp-lwt-unix-nossl/src/cohttp_lwt_unix_nossl.ml b/cohttp-lwt-unix-nossl/src/cohttp_lwt_unix_nossl.ml new file mode 100644 index 0000000000..5c171184c7 --- /dev/null +++ b/cohttp-lwt-unix-nossl/src/cohttp_lwt_unix_nossl.ml @@ -0,0 +1,33 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + }}}*) + +module Request = struct + include Cohttp.Request + include (Make(Io) + : module type of Make(Io) with type t := t) +end + +module Response = struct + include Cohttp.Response + include (Make(Io) + : module type of Make(Io) with type t := t) +end + +module Client = Client +module Server = Server +module Debug = Debug +module Net = Net +module IO = Io diff --git a/cohttp-lwt-unix/src/debug.ml b/cohttp-lwt-unix-nossl/src/debug.ml similarity index 100% rename from cohttp-lwt-unix/src/debug.ml rename to cohttp-lwt-unix-nossl/src/debug.ml diff --git a/cohttp-lwt-unix/src/debug.mli b/cohttp-lwt-unix-nossl/src/debug.mli similarity index 100% rename from cohttp-lwt-unix/src/debug.mli rename to cohttp-lwt-unix-nossl/src/debug.mli diff --git a/cohttp-lwt-unix-nossl/src/dune b/cohttp-lwt-unix-nossl/src/dune new file mode 100644 index 0000000000..328de497e5 --- /dev/null +++ b/cohttp-lwt-unix-nossl/src/dune @@ -0,0 +1,8 @@ +(library + (name cohttp_lwt_unix_nossl) + (public_name cohttp-lwt-unix-nossl) + (synopsis "Lwt/Unix backend for Cohttp") + (preprocess + (pps ppx_sexp_conv)) + (libraries fmt logs logs.lwt conduit-lwt magic-mime lwt.unix cohttp + cohttp-lwt)) diff --git a/cohttp-lwt-unix/src/io.ml b/cohttp-lwt-unix-nossl/src/io.ml similarity index 100% rename from cohttp-lwt-unix/src/io.ml rename to cohttp-lwt-unix-nossl/src/io.ml diff --git a/cohttp-lwt-unix/src/io.mli b/cohttp-lwt-unix-nossl/src/io.mli similarity index 100% rename from cohttp-lwt-unix/src/io.mli rename to cohttp-lwt-unix-nossl/src/io.mli diff --git a/cohttp-lwt-unix-nossl/src/net.ml b/cohttp-lwt-unix-nossl/src/net.ml new file mode 100644 index 0000000000..07cb56b430 --- /dev/null +++ b/cohttp-lwt-unix-nossl/src/net.ml @@ -0,0 +1,65 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + }}}*) + +(* Miscellaneous net-helpers used by Cohttp. Ideally, these will disappear + * into some connection-management framework such as andrenth/release *) + +open Lwt.Infix + +module IO = Io + +type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] + +let default_ctx = Conduit_lwt.empty + +let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt + +let uri_to_endpoint uri = + (match Uri.host uri with + | None -> failwith "Invalid uri: no host component in %a" Uri.pp uri + | Some h -> Lwt.return h) >>= fun v -> + let ( >>= ) x f = match x with Ok x -> f x | Error err -> Error err in + match Domain_name.(of_string v >>= host), Ipaddr.of_string v with + | Ok domain_name, _ -> Lwt.return (Conduit.Endpoint.domain domain_name) + | Error _, Ok v -> Lwt.return (Conduit.Endpoint.ip v) + | Error _, Error _ -> failwith "Invalid uri: %a" Uri.pp uri + +let connect_uri ~ctx uri = + uri_to_endpoint uri >>= fun edn -> + let ctx = match Uri.scheme uri with + | (Some "http" | None) -> + let port = Option.value ~default:80 (Uri.port uri) in + Conduit_lwt.add Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port) ctx + | _ -> ctx in + Conduit_lwt.resolve ctx edn >>= function + | Ok flow -> + let ic, oc = Conduit_lwt.io_of_flow flow in + Lwt.return (flow, ic, oc) + | Error err -> + failwith "%a" Conduit_lwt.pp_error err + +let close c = Lwt.catch + (fun () -> Lwt_io.close c) + (fun e -> + Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e)); + Lwt.return_unit + ) + +let close_in ic = Lwt.ignore_result (close ic) + +let close_out oc = Lwt.ignore_result (close oc) + +let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close oc) diff --git a/cohttp-lwt-unix-nossl/src/net.mli b/cohttp-lwt-unix-nossl/src/net.mli new file mode 100644 index 0000000000..25d9cd000d --- /dev/null +++ b/cohttp-lwt-unix-nossl/src/net.mli @@ -0,0 +1,38 @@ +(*{{{ Copyright (c) 2015 David Sheets + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + }}}*) + +(** Basic satisfaction of {! Cohttp_lwt.Net } *) + +module IO = Io + +type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] + +val default_ctx : ctx + +(** Exceptions from [conduit]. + + When the [recv] or the [send] {i syscalls} return an error, + [conduit] will reraise it. *) + +val connect_uri : + ctx:ctx -> + Uri.t -> + (Conduit_lwt.flow * Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel) Lwt.t + +val close_in : 'a Lwt_io.channel -> unit +val close_out : 'a Lwt_io.channel -> unit + +val close : 'a Lwt_io.channel -> 'b Lwt_io.channel -> unit diff --git a/cohttp-lwt-unix/src/server.ml b/cohttp-lwt-unix-nossl/src/server.ml similarity index 100% rename from cohttp-lwt-unix/src/server.ml rename to cohttp-lwt-unix-nossl/src/server.ml diff --git a/cohttp-lwt-unix/src/server.mli b/cohttp-lwt-unix-nossl/src/server.mli similarity index 100% rename from cohttp-lwt-unix/src/server.mli rename to cohttp-lwt-unix-nossl/src/server.mli diff --git a/cohttp-lwt-unix-ssl.opam b/cohttp-lwt-unix-ssl.opam new file mode 100644 index 0000000000..3b15935291 --- /dev/null +++ b/cohttp-lwt-unix-ssl.opam @@ -0,0 +1,54 @@ +opam-version: "2.0" +maintainer: "anil@recoil.org" +authors: [ + "Anil Madhavapeddy" + "Stefano Zacchiroli" + "David Sheets" + "Thomas Gazagnaire" + "David Scott" + "Rudi Grinberg" + "Andy Ray" +] +synopsis: "CoHTTP implementation for Unix and Windows using Lwt" +description: """ +An implementation of an HTTP client and server using the Lwt +concurrency library. See the `Cohttp_lwt_unix` module for information +on how to use this. The package also installs `cohttp-curl-lwt` +and a `cohttp-server-lwt` binaries for quick uses of a HTTP(S) +client and server respectively. + +Although the name implies that this only works under Unix, it +should also be fine under Windows too.""" +license: "ISC" +tags: ["org:mirage" "org:xapi-project"] +homepage: "https://github.com/mirage/ocaml-cohttp" +doc: "https://mirage.github.io/ocaml-cohttp/" +bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" +depends: [ + "ocaml" {>= "4.04.1"} + "dune" {>= "1.1.0"} + "conduit-lwt" {>= "1.0.3"} + "conduit-lwt-ssl" + "ca-certs" + "cmdliner" + "magic-mime" + "logs" + "fmt" {>= "0.8.2"} + "cohttp-lwt" {=version} + "cohttp-lwt-unix-nossl" {=version} + "lwt" {>= "3.0.0"} + "base-unix" + "ounit" {with-test} +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" +pin-depends: [ + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] + [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] + [ "conduit-lwt-ssl.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] + [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] +] diff --git a/cohttp-lwt-unix-ssl/src/client.ml b/cohttp-lwt-unix-ssl/src/client.ml new file mode 100644 index 0000000000..f2f3b4a39a --- /dev/null +++ b/cohttp-lwt-unix-ssl/src/client.ml @@ -0,0 +1,2 @@ + +include Cohttp_lwt.Make_client(Cohttp_lwt_unix_nossl.IO)(Net) diff --git a/cohttp-lwt-unix-ssl/src/client.mli b/cohttp-lwt-unix-ssl/src/client.mli new file mode 100644 index 0000000000..e0b0631d28 --- /dev/null +++ b/cohttp-lwt-unix-ssl/src/client.mli @@ -0,0 +1,5 @@ + +(** The [Client] module implements the full UNIX HTTP client interface, + including the UNIX-specific functions defined in {!C }. *) + +include Cohttp_lwt.S.Client with type ctx = Conduit.resolvers diff --git a/cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml b/cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml new file mode 100644 index 0000000000..2d27f99338 --- /dev/null +++ b/cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml @@ -0,0 +1,33 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + }}}*) + +module Request = struct + include Cohttp.Request + include (Make(Cohttp_lwt_unix_nossl.IO) + : module type of Make(Cohttp_lwt_unix_nossl.IO) with type t := t) +end + +module Response = struct + include Cohttp.Response + include (Make(Cohttp_lwt_unix_nossl.IO) + : module type of Make(Cohttp_lwt_unix_nossl.IO) with type t := t) +end + +module Client = Client +module Server = Cohttp_lwt_unix_nossl.Server +module Debug = Cohttp_lwt_unix_nossl.Debug +module Net = Net +module IO = Cohttp_lwt_unix_nossl.IO diff --git a/cohttp-lwt-unix-ssl/src/dune b/cohttp-lwt-unix-ssl/src/dune new file mode 100644 index 0000000000..c9c66c0ff8 --- /dev/null +++ b/cohttp-lwt-unix-ssl/src/dune @@ -0,0 +1,8 @@ +(library + (name cohttp_lwt_unix_ssl) + (public_name cohttp-lwt-unix-ssl) + (synopsis "Lwt/Unix (with OpenSSL) backend for Cohttp") + (preprocess + (pps ppx_sexp_conv)) + (libraries fmt logs logs.lwt conduit-lwt conduit-lwt-ssl magic-mime lwt.unix + cohttp cohttp-lwt cohttp-lwt-unix-nossl)) diff --git a/cohttp-lwt-unix-ssl/src/net.ml b/cohttp-lwt-unix-ssl/src/net.ml new file mode 100644 index 0000000000..2cb9821590 --- /dev/null +++ b/cohttp-lwt-unix-ssl/src/net.ml @@ -0,0 +1,85 @@ +(*{{{ Copyright (c) 2012 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + }}}*) + +(* Miscellaneous net-helpers used by Cohttp. Ideally, these will disappear + * into some connection-management framework such as andrenth/release *) + +open Lwt.Infix + +module IO = Cohttp_lwt_unix_nossl.IO + +type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] + +let () = Ssl.init () + +let default_ctx = Conduit_lwt.empty + +let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt + +let uri_to_endpoint uri = + (match Uri.host uri with + | None -> failwith "Invalid uri: no host component in %a" Uri.pp uri + | Some h -> Lwt.return h) >>= fun v -> + let ( >>= ) x f = match x with Ok x -> f x | Error err -> Error err in + match Domain_name.(of_string v >>= host), Ipaddr.of_string v with + | Ok domain_name, _ -> Lwt.return (Conduit.Endpoint.domain domain_name) + | Error _, Ok v -> Lwt.return (Conduit.Endpoint.ip v) + | Error _, Error _ -> failwith "Invalid uri: %a" Uri.pp uri + +let verify ?host ctx flow = + let socket = Conduit_lwt.TCP.Protocol.file_descr flow in + let uninitialized_socket = Lwt_ssl.embed_uninitialized_socket socket ctx in + let ssl_socket = Lwt_ssl.ssl_socket_of_uninitialized_socket uninitialized_socket in + Option.iter (Ssl.set_client_SNI_hostname ssl_socket) host ; + Lwt_ssl.ssl_perform_handshake uninitialized_socket >|= fun v -> Ok v + +let connect_uri ~ctx uri = + uri_to_endpoint uri >>= fun edn -> + let ctx = match Uri.scheme uri with + | Some "https" -> + let port = Option.value ~default:443 (Uri.port uri) in + let host = Uri.host uri in + let context = Ssl.create_context Ssl.TLSv1_2 Ssl.Client_context in + Conduit_lwt.add + Conduit_lwt_ssl.TCP.protocol + (Conduit_lwt_ssl.TCP.resolve ~verify:(verify ?host) ~port ~context) ctx + | (Some "http" | None) -> + let port = Option.value ~default:80 (Uri.port uri) in + Conduit_lwt.add Conduit_lwt.TCP.protocol (Conduit_lwt.TCP.resolve ~port) ctx + | _ -> ctx in + Conduit_lwt.resolve ctx edn >>= function + | Ok (Conduit_lwt_ssl.TCP.T (Value socket) as flow) -> + let ic = Lwt_ssl.in_channel_of_descr socket in + let oc = Lwt_ssl.out_channel_of_descr socket in + Lwt.return (flow, ic, oc) + | Ok flow -> + let ic, oc = Conduit_lwt.io_of_flow flow in + Lwt.return (flow, ic, oc) + | Error err -> + failwith "%a" Conduit_lwt.pp_error err + +let close c = Lwt.catch + (fun () -> Lwt_io.close c) + (fun e -> + Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e)); + Lwt.return_unit + ) + +let close_in ic = Lwt.ignore_result (close ic) + +let close_out oc = Lwt.ignore_result (close oc) + +let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close oc) diff --git a/cohttp-lwt-unix-ssl/src/net.mli b/cohttp-lwt-unix-ssl/src/net.mli new file mode 100644 index 0000000000..b5d8852a52 --- /dev/null +++ b/cohttp-lwt-unix-ssl/src/net.mli @@ -0,0 +1,38 @@ +(*{{{ Copyright (c) 2015 David Sheets + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + }}}*) + +(** Basic satisfaction of {! Cohttp_lwt.Net } *) + +module IO = Cohttp_lwt_unix_nossl.IO + +type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] + +val default_ctx : ctx + +(** Exceptions from [conduit]. + + When the [recv] or the [send] {i syscalls} return an error, + [conduit] will reraise it. *) + +val connect_uri : + ctx:ctx -> + Uri.t -> + (Conduit_lwt.flow * Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel) Lwt.t + +val close_in : 'a Lwt_io.channel -> unit +val close_out : 'a Lwt_io.channel -> unit + +val close : 'a Lwt_io.channel -> 'b Lwt_io.channel -> unit diff --git a/cohttp-lwt-unix.opam b/cohttp-lwt-unix.opam index 96c40b7ea8..c48175421f 100644 --- a/cohttp-lwt-unix.opam +++ b/cohttp-lwt-unix.opam @@ -35,6 +35,7 @@ depends: [ "logs" "fmt" {>= "0.8.2"} "cohttp-lwt" {=version} + "cohttp-lwt-unix-nossl" {=version} "lwt" {>= "3.0.0"} "base-unix" "ounit" {with-test} @@ -46,8 +47,8 @@ build: [ ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-lwt-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] + [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] + [ "conduit-lwt-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] + [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] ] diff --git a/cohttp-lwt-unix/src/client.ml b/cohttp-lwt-unix/src/client.ml index b7138d5f56..f2f3b4a39a 100644 --- a/cohttp-lwt-unix/src/client.ml +++ b/cohttp-lwt-unix/src/client.ml @@ -1,2 +1,2 @@ -include Cohttp_lwt.Make_client(Io)(Net) +include Cohttp_lwt.Make_client(Cohttp_lwt_unix_nossl.IO)(Net) diff --git a/cohttp-lwt-unix/src/cohttp_lwt_unix.ml b/cohttp-lwt-unix/src/cohttp_lwt_unix.ml index 5c171184c7..2d27f99338 100644 --- a/cohttp-lwt-unix/src/cohttp_lwt_unix.ml +++ b/cohttp-lwt-unix/src/cohttp_lwt_unix.ml @@ -16,18 +16,18 @@ module Request = struct include Cohttp.Request - include (Make(Io) - : module type of Make(Io) with type t := t) + include (Make(Cohttp_lwt_unix_nossl.IO) + : module type of Make(Cohttp_lwt_unix_nossl.IO) with type t := t) end module Response = struct include Cohttp.Response - include (Make(Io) - : module type of Make(Io) with type t := t) + include (Make(Cohttp_lwt_unix_nossl.IO) + : module type of Make(Cohttp_lwt_unix_nossl.IO) with type t := t) end module Client = Client -module Server = Server -module Debug = Debug +module Server = Cohttp_lwt_unix_nossl.Server +module Debug = Cohttp_lwt_unix_nossl.Debug module Net = Net -module IO = Io +module IO = Cohttp_lwt_unix_nossl.IO diff --git a/cohttp-lwt-unix/src/dune b/cohttp-lwt-unix/src/dune index 3e3cd05689..a7493e16f4 100644 --- a/cohttp-lwt-unix/src/dune +++ b/cohttp-lwt-unix/src/dune @@ -5,4 +5,4 @@ (preprocess (pps ppx_sexp_conv)) (libraries fmt logs logs.lwt conduit-lwt conduit-lwt-tls magic-mime lwt.unix - ca-certs cohttp cohttp-lwt)) + ca-certs cohttp cohttp-lwt cohttp-lwt-unix-nossl)) diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index dfd68bb0bf..33147386dd 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -19,7 +19,7 @@ open Lwt.Infix -module IO = Io +module IO = Cohttp_lwt_unix_nossl.IO type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] @@ -28,9 +28,6 @@ let authenticator = | Ok a -> a | Error (`Msg msg) -> failwith msg -let tls_config ?peer_name () = - Tls.Config.client ~authenticator ?peer_name () - let default_ctx = Conduit_lwt.empty let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt @@ -41,15 +38,16 @@ let uri_to_endpoint uri = | Some h -> Lwt.return h) >>= fun v -> let ( >>= ) x f = match x with Ok x -> f x | Error err -> Error err in match Domain_name.(of_string v >>= host), Ipaddr.of_string v with - | Ok domain_name, _ -> Lwt.return (Conduit.Endpoint.domain domain_name, Some v) - | Error _, Ok v -> Lwt.return (Conduit.Endpoint.ip v, None) + | Ok domain_name, _ -> Lwt.return (Conduit.Endpoint.domain domain_name) + | Error _, Ok v -> Lwt.return (Conduit.Endpoint.ip v) | Error _, Error _ -> failwith "Invalid uri: %a" Uri.pp uri let connect_uri ~ctx uri = - uri_to_endpoint uri >>= fun (edn, peer_name) -> + uri_to_endpoint uri >>= fun edn -> let ctx = match Uri.scheme uri with | Some "https" -> - let tls_config = tls_config ?peer_name () in + let peer_name = Uri.host uri in + let tls_config = Tls.Config.client ~authenticator ?peer_name () in let port = Option.value ~default:443 (Uri.port uri) in Conduit_lwt.add Conduit_lwt_tls.TCP.protocol diff --git a/cohttp-lwt-unix/src/net.mli b/cohttp-lwt-unix/src/net.mli index 25d9cd000d..b5d8852a52 100644 --- a/cohttp-lwt-unix/src/net.mli +++ b/cohttp-lwt-unix/src/net.mli @@ -16,7 +16,7 @@ (** Basic satisfaction of {! Cohttp_lwt.Net } *) -module IO = Io +module IO = Cohttp_lwt_unix_nossl.IO type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] From 52d5d58876b1a84c2095db5adf4044c8b267b22d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 14 Oct 2020 14:40:25 +0200 Subject: [PATCH 45/46] Update OPAM files --- cohttp-async.opam | 8 ++++---- cohttp-mirage.opam | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/cohttp-async.opam b/cohttp-async.opam index ab80470f83..a2ae0d2a8e 100644 --- a/cohttp-async.opam +++ b/cohttp-async.opam @@ -51,8 +51,8 @@ build: [ ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-async-ssl.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-async.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] + [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] + [ "conduit-async-ssl.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] + [ "conduit-async.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] ] diff --git a/cohttp-mirage.opam b/cohttp-mirage.opam index c5a51cc1a2..dc3cd175f6 100644 --- a/cohttp-mirage.opam +++ b/cohttp-mirage.opam @@ -38,7 +38,7 @@ build: [ ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-mirage.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] + [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] + [ "conduit-mirage.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] ] From f4d0b6841c9995ed97805a8894ca6d7b8d12a609 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 21 Oct 2020 16:26:09 +0200 Subject: [PATCH 46/46] Remove pin-depends and use conduit.3.0.0 --- cohttp-async.opam | 8 +------- cohttp-lwt-unix-nossl.opam | 6 +----- cohttp-lwt-unix-ssl.opam | 8 +------- cohttp-lwt-unix.opam | 8 +------- cohttp-mirage.opam | 7 +------ 5 files changed, 5 insertions(+), 32 deletions(-) diff --git a/cohttp-async.opam b/cohttp-async.opam index a2ae0d2a8e..786836bbe0 100644 --- a/cohttp-async.opam +++ b/cohttp-async.opam @@ -31,7 +31,7 @@ depends: [ "base" {>= "v0.11.0"} "core" {with-test} "cohttp" {=version} - "conduit-async" {>="1.2.0"} + "conduit-async" {>="3.0.0"} "conduit-async-ssl" "magic-mime" "logs" @@ -50,9 +50,3 @@ build: [ ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" -pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] - [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] - [ "conduit-async-ssl.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] - [ "conduit-async.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] -] diff --git a/cohttp-lwt-unix-nossl.opam b/cohttp-lwt-unix-nossl.opam index b0055a0dc4..edffa284cd 100644 --- a/cohttp-lwt-unix-nossl.opam +++ b/cohttp-lwt-unix-nossl.opam @@ -27,7 +27,7 @@ bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" depends: [ "ocaml" {>= "4.04.1"} "dune" {>= "1.1.0"} - "conduit-lwt" {>= "1.0.3"} + "conduit-lwt" {>= "3.0.0"} "ca-certs" "cmdliner" "magic-mime" @@ -44,7 +44,3 @@ build: [ ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" -pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] - [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] -] diff --git a/cohttp-lwt-unix-ssl.opam b/cohttp-lwt-unix-ssl.opam index 3b15935291..ab71da9fd2 100644 --- a/cohttp-lwt-unix-ssl.opam +++ b/cohttp-lwt-unix-ssl.opam @@ -27,7 +27,7 @@ bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" depends: [ "ocaml" {>= "4.04.1"} "dune" {>= "1.1.0"} - "conduit-lwt" {>= "1.0.3"} + "conduit-lwt" {>= "3.0.0"} "conduit-lwt-ssl" "ca-certs" "cmdliner" @@ -46,9 +46,3 @@ build: [ ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" -pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] - [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] - [ "conduit-lwt-ssl.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] - [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] -] diff --git a/cohttp-lwt-unix.opam b/cohttp-lwt-unix.opam index c48175421f..efb566b7cb 100644 --- a/cohttp-lwt-unix.opam +++ b/cohttp-lwt-unix.opam @@ -27,7 +27,7 @@ bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" depends: [ "ocaml" {>= "4.04.1"} "dune" {>= "1.1.0"} - "conduit-lwt" {>= "1.0.3"} + "conduit-lwt" {>= "3.0.0"} "conduit-lwt-tls" "ca-certs" "cmdliner" @@ -46,9 +46,3 @@ build: [ ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" -pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] - [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] - [ "conduit-lwt-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] - [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] -] diff --git a/cohttp-mirage.opam b/cohttp-mirage.opam index dc3cd175f6..eff6232186 100644 --- a/cohttp-mirage.opam +++ b/cohttp-mirage.opam @@ -23,7 +23,7 @@ depends: [ "mirage-flow" {>= "2.0.0"} "mirage-channel" {>= "4.0.0"} "conduit" {>= "2.0.2"} - "conduit-mirage" {>= "2.0.2"} + "conduit-mirage" {>= "3.0.0"} "mirage-kv" {>= "3.0.0"} "lwt" {>= "2.4.3"} "cohttp" @@ -37,8 +37,3 @@ build: [ ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] dev-repo: "git+https://github.com/mirage/ocaml-cohttp.git" -pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] - [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] - [ "conduit-mirage.dev" "git+https://github.com/mirage/ocaml-conduit.git#4b9e8b0f8e96459c8e27ca27ed7416b8d1b5ba23" ] -]