From 9fa8152a1bfa2777582ac4a55b607f7136900415 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 29 Jan 2021 15:36:38 +0100 Subject: [PATCH] Revert conduit 3 changes --- .github/workflows/workflow.yml | 4 - CHANGES.md | 3 +- README.md | 10 +- cohttp-async.opam | 3 +- cohttp-async/bin/cohttp_server_async.ml | 19 ++-- cohttp-async/src/client.ml | 93 ++++++++----------- cohttp-async/src/client.mli | 33 ++++--- cohttp-async/src/dune | 2 +- cohttp-async/src/server.ml | 88 ++++++------------ cohttp-async/src/server.mli | 41 +++++--- cohttp-lwt-unix-nossl.opam | 47 ---------- cohttp-lwt-unix-nossl/src/client.ml | 2 - cohttp-lwt-unix-nossl/src/client.mli | 5 - .../src/cohttp_lwt_unix_nossl.ml | 33 ------- cohttp-lwt-unix-nossl/src/dune | 8 -- cohttp-lwt-unix-nossl/src/net.ml | 65 ------------- cohttp-lwt-unix-nossl/src/net.mli | 38 -------- cohttp-lwt-unix-ssl.opam | 49 ---------- 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 | 6 +- cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml | 61 ++---------- cohttp-lwt-unix/bin/cohttp_server_lwt.ml | 65 +++---------- cohttp-lwt-unix/src/client.ml | 3 +- cohttp-lwt-unix/src/client.mli | 3 +- cohttp-lwt-unix/src/cohttp_lwt_unix.ml | 14 +-- .../src/debug.ml | 0 .../src/debug.mli | 0 cohttp-lwt-unix/src/dune | 4 +- .../src/io.ml | 2 +- .../src/io.mli | 2 +- cohttp-lwt-unix/src/net.ml | 67 +++++-------- cohttp-lwt-unix/src/net.mli | 20 +++- .../src/server.ml | 42 +-------- .../src/server.mli | 27 ++---- cohttp-lwt-unix/test/test_sanity.ml | 2 +- cohttp-lwt/src/s.ml | 17 ++-- cohttp-mirage.opam | 2 +- cohttp-mirage/src/client.ml | 37 +++----- cohttp-mirage/src/client.mli | 3 +- cohttp-mirage/src/dune | 4 +- cohttp-mirage/src/server_with_conduit.ml | 18 +--- cohttp-mirage/src/server_with_conduit.mli | 10 +- cohttp_async_test/src/cohttp_async_test.ml | 20 ++-- .../src/cohttp_lwt_unix_test.ml | 15 +-- examples/async/hello_world.ml | 10 +- examples/async/receive_post.ml | 13 ++- examples/lwt_unix_doc/docker_lwt.ml | 13 +-- examples/lwt_unix_doc/server_lwt.ml | 11 +-- 53 files changed, 286 insertions(+), 919 deletions(-) delete mode 100644 cohttp-lwt-unix-nossl.opam delete mode 100644 cohttp-lwt-unix-nossl/src/client.ml delete mode 100644 cohttp-lwt-unix-nossl/src/client.mli delete mode 100644 cohttp-lwt-unix-nossl/src/cohttp_lwt_unix_nossl.ml 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-nossl/src/net.mli delete mode 100644 cohttp-lwt-unix-ssl.opam delete mode 100644 cohttp-lwt-unix-ssl/src/client.ml delete mode 100644 cohttp-lwt-unix-ssl/src/client.mli 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.ml delete mode 100644 cohttp-lwt-unix-ssl/src/net.mli rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/debug.ml (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/debug.mli (100%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/io.ml (98%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/io.mli (95%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/server.ml (59%) rename {cohttp-lwt-unix-nossl => cohttp-lwt-unix}/src/server.mli (53%) diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index f32ad5a1c5..6a0fd44bf0 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -35,8 +35,6 @@ jobs: - run: | opam pin add cohttp-async.dev . --no-action opam pin add cohttp-lwt-jsoo.dev . --no-action - opam pin add cohttp-lwt-unix-nossl.dev . --no-action - opam pin add cohttp-lwt-unix-ssl.dev . --no-action opam pin add cohttp-lwt-unix.dev . --no-action opam pin add cohttp-lwt.dev . --no-action opam pin add cohttp-mirage.dev . --no-action @@ -50,8 +48,6 @@ jobs: cohttp-lwt \ cohttp-lwt-jsoo \ cohttp-lwt-unix \ - cohttp-lwt-unix-nossl \ - cohttp-lwt-unix-ssl \ cohttp-mirage \ cohttp-top \ diff --git a/CHANGES.md b/CHANGES.md index a4b522c25b..84aeb7c9df 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -5,6 +5,7 @@ - lwt_jsoo: Forward exceptions to caller when response is null (@mefyl #738) - Remove wrapped false (@rgrinberg #734) - Use implicit executable dependency for generate.exe (@TheLortex #735) +- Revert the changes to adapt to conduit 3.0.0 (#741, @samoht) ## v3.0.0 (2020-10-02) -- unreleased @@ -44,7 +45,7 @@ let cfg = { Conduit_lwt.TCP.sockaddr= Unix.ADDR_INET (Unix.inet_addr_loopback, 8080) ; capacity= 40 } - + let run cohttp_config = Cohttp_lwt_unix.Server.create cfg Conduit_lwt.TCP.protocol Conduit_lwt.TCP.service cohttp_config diff --git a/README.md b/README.md index 77cff5144f..4af58afe24 100644 --- a/README.md +++ b/README.md @@ -132,9 +132,7 @@ findlib (`ocamlfind`) libraries: * `cohttp` - Base `Cohttp` module. No platform specific functionality * `cohttp-async` - Async backend `Cohttp_async` * `cohttp-lwt` - Lwt backend without unix specifics -* `cohttp-lwt-unix` - Unix based lwt backend with `tls` support -* `cohttp-lwt-unix-ssl` - Unix based lwt backend with `lwt_ssl` support -* `cohttp-lwt-unix-nossl` - Unix based lwt backend (only `http`) +* `cohttp-lwt-unix` - Unix based lwt backend * `cohttp-lwt-jsoo` - Jsoo (XHR) client * `cohttp-top` - Print cohttp types in the toplevel (`#require "cohttp-top"`) @@ -160,7 +158,7 @@ You can use [`Lwt.pick`](https://ocsigen.org/lwt/4.1.0/api/Lwt) to set a timeout on the execution of a thread. For example, say that you want to set a timeout on the `Client.get` thread in the example above, then you could modify the get call as follows - + ```ocaml (* [...] *) @@ -247,7 +245,7 @@ To build and execute with `dune`, first create the following `dune` file ``` cat - > dune <= "v0.11.0"} "core" {with-test} "cohttp" {=version} - "conduit-async" {>="3.0.0"} - "conduit-async-ssl" + "conduit-async" {>="1.2.0"} "magic-mime" "mirage-crypto" {with-test} "logs" diff --git a/cohttp-async/bin/cohttp_server_async.ml b/cohttp-async/bin/cohttp_server_async.ml index aa4bee0a94..8f28bf9127 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); @@ -116,19 +116,14 @@ 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 - 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 + Server.create + ~on_handler_error:(`Call (fun addr exn -> Logs.err (fun f -> f "Error from %s" (Socket.Address.to_string addr)); Logs.err (fun f -> f "%s" @@ Exn.to_string exn))) - ~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 + ~mode + (Tcp.Where_to_listen.of_port port) + (handler ~info ~docroot ~index) >>= fun _serv -> + Deferred.never () let () = let open Async_command in diff --git a/cohttp-async/src/client.ml b/cohttp-async/src/client.ml index 96d0f127fa..acbb0a3a62 100644 --- a/cohttp-async/src/client.ml +++ b/cohttp-async/src/client.ml @@ -28,44 +28,24 @@ 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 ?ssl_ctx uri = - match (Uri.scheme uri, ssl_ctx) with - | Some "httpunix", _ -> + let connect_uri ?interrupt ?ssl_config uri = + (match Uri.scheme uri with + | Some "httpunix" -> let host = Uri.host_with_default ~default:"localhost" uri in - 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 -> + return @@ `Unix_domain_socket host + | _ -> lookup uri |> Deferred.Or_error.ok_exn >>= fun (host, 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 - 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 + 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 end let read_response ic = @@ -85,13 +65,14 @@ let read_response ic = (res, pipe) end -let request ?ssl_ctx ?uri ?(body=`Empty) req = +let request ?interrupt ?ssl_config ?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 ?ssl_ctx uri >>= fun (ic, oc) -> + Net.connect_uri ?interrupt ?ssl_config uri + >>= fun (ic, oc) -> try_with (fun () -> Request.write (fun writer -> Body_raw.write_body Request.write_body body writer) req oc @@ -116,8 +97,8 @@ module Connection = struct (* we can't send concurrent requests over HTTP/1 *) type t = t' Sequencer.t - let connect ?ssl_ctx uri = - Net.connect_uri ?ssl_ctx uri + let connect ?interrupt ?ssl_config uri = + Net.connect_uri ?interrupt ?ssl_config uri >>| fun (ic, oc) -> let t = { ic ; oc } @@ -154,8 +135,8 @@ module Connection = struct Ivar.read res end -let callv ?ssl_ctx uri reqs = - Connection.connect ?ssl_ctx uri +let callv ?interrupt ?ssl_config uri reqs = + Connection.connect ?interrupt ?ssl_config uri >>| fun connection -> let responses = Pipe.map' ~max_queue_length:1 reqs ~f:(fun reqs -> @@ -165,7 +146,7 @@ let callv ?ssl_ctx uri reqs = (Pipe.closed responses >>= fun () -> Connection.close connection) |> don't_wait_for; responses -let call ?ssl_ctx ?headers ?(chunked=false) ?(body=`Empty) meth uri = +let call ?interrupt ?ssl_config ?headers ?(chunked=false) ?(body=`Empty) meth uri = (* Create a request, then make the request. Figure out an appropriate transfer encoding *) begin @@ -180,33 +161,33 @@ let call ?ssl_ctx ?headers ?(chunked=false) ?(body=`Empty) meth uri = | 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 ?ssl_ctx ~body ~uri req + end >>= fun (req, body) -> request ?interrupt ?ssl_config ~body ~uri req -let get ?ssl_ctx ?headers uri = - call ?ssl_ctx ?headers ~chunked:false `GET uri +let get ?interrupt ?ssl_config ?headers uri = + call ?interrupt ?ssl_config ?headers ~chunked:false `GET uri -let head ?ssl_ctx ?headers uri = - call ?ssl_ctx ?headers ~chunked:false `HEAD uri +let head ?interrupt ?ssl_config ?headers uri = + call ?interrupt ?ssl_config ?headers ~chunked:false `HEAD uri >>| fun (res, body) -> (match body with | `Pipe p -> Pipe.close_read p; | _ -> ()); res -let post ?ssl_ctx ?headers ?(chunked=false) ?body uri = - call ?ssl_ctx ?headers ~chunked ?body `POST uri +let post ?interrupt ?ssl_config ?headers ?(chunked=false) ?body uri = + call ?interrupt ?ssl_config ?headers ~chunked ?body `POST uri -let post_form ?ssl_ctx ?headers ~params uri = +let post_form ?interrupt ?ssl_config ?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 ?ssl_ctx ~headers ~chunked:false ~body uri + post ?interrupt ?ssl_config ~headers ~chunked:false ~body uri -let put ?ssl_ctx ?headers ?(chunked=false) ?body uri = - call ?ssl_ctx ?headers ~chunked ?body `PUT uri +let put ?interrupt ?ssl_config ?headers ?(chunked=false) ?body uri = + call ?interrupt ?ssl_config ?headers ~chunked ?body `PUT uri -let patch ?ssl_ctx ?headers ?(chunked=false) ?body uri = - call ?ssl_ctx ?headers ~chunked ?body `PATCH uri +let patch ?interrupt ?ssl_config ?headers ?(chunked=false) ?body uri = + call ?interrupt ?ssl_config ?headers ~chunked ?body `PATCH uri -let delete ?ssl_ctx ?headers ?(chunked=false) ?body uri = - call ?ssl_ctx ?headers ~chunked ?body `DELETE uri +let delete ?interrupt ?ssl_config ?headers ?(chunked=false) ?body uri = + call ?interrupt ?ssl_config ?headers ~chunked ?body `DELETE uri diff --git a/cohttp-async/src/client.mli b/cohttp-async/src/client.mli index fd8ad68e81..ea5f5da43d 100644 --- a/cohttp-async/src/client.mli +++ b/cohttp-async/src/client.mli @@ -1,7 +1,8 @@ (** Send an HTTP request with an arbitrary body The request is sent as-is. *) val request : - ?ssl_ctx:Conduit_async_ssl.context -> + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> ?uri:Uri.t -> ?body:Body.t -> Cohttp.Request.t -> @@ -20,7 +21,8 @@ val request : default port ([*:80]) or the specified one.}} *) val call : - ?ssl_ctx:Conduit_async_ssl.context -> + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -33,7 +35,8 @@ module Connection : sig type t val connect : - ?ssl_ctx:Conduit_async_ssl.context -> + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> Uri.t -> t Async_kernel.Deferred.t @@ -49,28 +52,32 @@ module Connection : sig end val callv : - ?ssl_ctx:Conduit_async_ssl.context -> + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> 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 : - ?ssl_ctx:Conduit_async_ssl.context -> + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp.Response.t * Body.t) Async_kernel.Deferred.t (** Send an HTTP HEAD request *) val head : - ?ssl_ctx:Conduit_async_ssl.context -> + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> ?headers:Cohttp.Header.t -> Uri.t -> Cohttp.Response.t Async_kernel.Deferred.t (** Send an HTTP DELETE request *) val delete : - ?ssl_ctx:Conduit_async_ssl.context -> + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -81,7 +88,8 @@ val delete : [chunked] encoding is off by default as not many servers support it *) val post : - ?ssl_ctx:Conduit_async_ssl.context -> + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -92,7 +100,8 @@ val post : [chunked] encoding is off by default as not many servers support it *) val put : - ?ssl_ctx:Conduit_async_ssl.context -> + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -103,7 +112,8 @@ val put : [chunked] encoding is off by default as not many servers support it *) val patch : - ?ssl_ctx:Conduit_async_ssl.context -> + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> ?headers:Cohttp.Header.t -> ?chunked:bool -> ?body:Body.t -> @@ -112,7 +122,8 @@ val patch : (** Send an HTTP POST request in form format *) val post_form: - ?ssl_ctx:Conduit_async_ssl.context -> + ?interrupt:unit Async_kernel.Deferred.t -> + ?ssl_config:Conduit_async.V2.Ssl.Config.t -> ?headers:Cohttp.Header.t -> params:(string * string list) list -> Uri.t -> diff --git a/cohttp-async/src/dune b/cohttp-async/src/dune index 0303c6761e..35820bdab8 100644 --- a/cohttp-async/src/dune +++ b/cohttp-async/src/dune @@ -3,6 +3,6 @@ (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) + uri-sexp ipaddr.unix conduit-async magic-mime cohttp) (preprocess (pps ppx_sexp_conv))) diff --git a/cohttp-async/src/server.ml b/cohttp-async/src/server.ml index 41abccf9cf..cd4b777f79 100644 --- a/cohttp-async/src/server.ml +++ b/cohttp-async/src/server.ml @@ -12,6 +12,10 @@ 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 = @@ -26,6 +30,11 @@ 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 *) @@ -143,70 +152,33 @@ 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 -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 -> 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 +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 handle_request let create - ?timeout ?backlog + ?max_connections + ?backlog + ?buffer_age_limit + ?(mode = `TCP) ~on_handler_error - ~protocol ~service cfg + where_to_listen handle_request = let handle_request ~body address request = handle_request ~body address request >>| fun r -> `Response r in - create_raw ?timeout ?backlog - ~on_handler_error ~protocol ~service cfg + create_raw ?max_connections ?backlog + ?buffer_age_limit ~on_handler_error ~mode where_to_listen handle_request - - diff --git a/cohttp-async/src/server.mli b/cohttp-async/src/server.mli index 83599adc30..6c2d561d3d 100644 --- a/cohttp-async/src/server.mli +++ b/cohttp-async/src/server.mli @@ -1,3 +1,13 @@ +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 = @@ -53,30 +63,33 @@ 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 : - ?timeout:int -> + ?max_connections:int -> ?backlog:int -> - on_handler_error:[ `Call of Conduit_async.flow -> exn -> unit + ?buffer_age_limit:Async_unix.Writer.buffer_age_limit -> + ?mode:mode -> + on_handler_error:[ `Call of 'address -> 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 -> unit Async.Deferred.t) + ('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 (** Build a HTTP server, based on the [Tcp.Server] interface *) val create : - ?timeout:int -> + ?max_connections:int -> ?backlog:int -> - on_handler_error:[ `Call of Conduit_async.flow -> exn -> unit + ?buffer_age_limit:Async_unix.Writer.buffer_age_limit -> + ?mode:Conduit_async.server -> + on_handler_error:[ `Call of 'address -> 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 Async_kernel.Deferred.t) - -> unit Async.Condition.t * (unit -> unit Async.Deferred.t) + ('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 diff --git a/cohttp-lwt-unix-nossl.opam b/cohttp-lwt-unix-nossl.opam deleted file mode 100644 index 95754e768a..0000000000 --- a/cohttp-lwt-unix-nossl.opam +++ /dev/null @@ -1,47 +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" -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.08"} - "dune" {>= "1.1.0"} - "conduit-lwt" {>= "3.0.0"} - "ca-certs" - "cmdliner" - "magic-mime" - "logs" - "fmt" {>= "0.8.2"} - "cohttp-lwt" {=version} - "lwt" {>= "3.0.0"} - "base-unix" - "ppx_sexp_conv" {>= "v0.13.0"} - "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" diff --git a/cohttp-lwt-unix-nossl/src/client.ml b/cohttp-lwt-unix-nossl/src/client.ml deleted file mode 100644 index b7138d5f56..0000000000 --- a/cohttp-lwt-unix-nossl/src/client.ml +++ /dev/null @@ -1,2 +0,0 @@ - -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 deleted file mode 100644 index e0b0631d28..0000000000 --- a/cohttp-lwt-unix-nossl/src/client.mli +++ /dev/null @@ -1,5 +0,0 @@ - -(** 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 deleted file mode 100644 index 5c171184c7..0000000000 --- a/cohttp-lwt-unix-nossl/src/cohttp_lwt_unix_nossl.ml +++ /dev/null @@ -1,33 +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(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-nossl/src/dune b/cohttp-lwt-unix-nossl/src/dune deleted file mode 100644 index 7cddd5e138..0000000000 --- a/cohttp-lwt-unix-nossl/src/dune +++ /dev/null @@ -1,8 +0,0 @@ -(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.fmt 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 07cb56b430..0000000000 --- a/cohttp-lwt-unix-nossl/src/net.ml +++ /dev/null @@ -1,65 +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 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 deleted file mode 100644 index 25d9cd000d..0000000000 --- a/cohttp-lwt-unix-nossl/src/net.mli +++ /dev/null @@ -1,38 +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 = 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-ssl.opam b/cohttp-lwt-unix-ssl.opam deleted file mode 100644 index 9887ff1352..0000000000 --- a/cohttp-lwt-unix-ssl.opam +++ /dev/null @@ -1,49 +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" -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.08"} - "dune" {>= "1.1.0"} - "conduit-lwt" {>= "3.0.0"} - "conduit-lwt-ssl" - "ca-certs" - "cmdliner" - "magic-mime" - "logs" - "fmt" {>= "0.8.2"} - "cohttp-lwt" {=version} - "cohttp-lwt-unix-nossl" {=version} - "ppx_sexp_conv" {>= "v0.13.0"} - "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" diff --git a/cohttp-lwt-unix-ssl/src/client.ml b/cohttp-lwt-unix-ssl/src/client.ml deleted file mode 100644 index f2f3b4a39a..0000000000 --- a/cohttp-lwt-unix-ssl/src/client.ml +++ /dev/null @@ -1,2 +0,0 @@ - -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 deleted file mode 100644 index e0b0631d28..0000000000 --- a/cohttp-lwt-unix-ssl/src/client.mli +++ /dev/null @@ -1,5 +0,0 @@ - -(** 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 deleted file mode 100644 index 2d27f99338..0000000000 --- a/cohttp-lwt-unix-ssl/src/cohttp_lwt_unix_ssl.ml +++ /dev/null @@ -1,33 +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_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 deleted file mode 100644 index c9c66c0ff8..0000000000 --- a/cohttp-lwt-unix-ssl/src/dune +++ /dev/null @@ -1,8 +0,0 @@ -(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 deleted file mode 100644 index 2cb9821590..0000000000 --- a/cohttp-lwt-unix-ssl/src/net.ml +++ /dev/null @@ -1,85 +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_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 deleted file mode 100644 index b5d8852a52..0000000000 --- a/cohttp-lwt-unix-ssl/src/net.mli +++ /dev/null @@ -1,38 +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_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 d0cc1288bd..ca913a116c 100644 --- a/cohttp-lwt-unix.opam +++ b/cohttp-lwt-unix.opam @@ -27,15 +27,13 @@ bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" depends: [ "ocaml" {>= "4.08"} "dune" {>= "1.1.0"} - "conduit-lwt" {>= "3.0.0"} - "conduit-lwt-tls" - "ca-certs" + "conduit-lwt" {>= "1.0.3"} + "conduit-lwt-unix" {>= "1.0.3"} "cmdliner" "magic-mime" "logs" "fmt" {>= "0.8.2"} "cohttp-lwt" {=version} - "cohttp-lwt-unix-nossl" {=version} "ppx_sexp_conv" {>= "v0.13.0"} "lwt" {>= "3.0.0"} "base-unix" diff --git a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml index eb4643d76a..c2fa604465 100644 --- a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml @@ -22,25 +22,6 @@ open Lwt open Cohttp open Cohttp_lwt_unix -let option_bind x f = match x with - | Some x -> f x - | None -> None - -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 Conduit_lwt_tls.TCP.protocol with - | Some flow, None -> Some (Conduit_lwt.TCP.Protocol.sock 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 - | 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 *) @@ -73,53 +54,31 @@ let handler ~verbose _ req body = in Server.respond ~headers ~status ~body () -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 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 - | Some x -> pp_val ppf x - | None -> () in - Format.printf "Connection %a closed.\n%!" - (pp_option pp_sockaddr) (sockaddr_of_flow ch) in + printf "Connection %s closed\n%!" + (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch)) in let callback = handler ~verbose in let config = Server.make ~callback ~conn_closed () 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 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 + 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 lwt_start_proxy port host verbose cert key = Lwt_main.run (start_proxy port host verbose cert key ()) open Cmdliner -let host = +let host = let doc = "IP address to listen on." in - Arg.(value & opt string "localhost" & info ["s"] ~docv:"HOST" ~doc) + Arg.(value & opt string "0.0.0.0" & 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 3580428caf..219d654b52 100644 --- a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml @@ -21,28 +21,9 @@ 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 sockaddr_of_flow - : Conduit_lwt.flow -> Unix.sockaddr option - = fun flow -> match Conduit_lwt.cast flow Conduit_lwt.TCP.protocol, - Conduit_lwt.cast flow Conduit_lwt_tls.TCP.protocol with - | Some flow, None -> Some (Conduit_lwt.TCP.Protocol.sock 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 - | 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) | _ -> Lwt.return (res,body) @@ -104,10 +85,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 %a" + "%s %s %s" (Cohttp.(Code.string_of_method (Request.meth req))) path - Fmt.(option pp_sockaddr) (sockaddr_of_flow ch)); + (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))); (* Get a canonical filename from the URL and docroot *) match Request.meth req with | (`GET | `HEAD) as meth -> @@ -120,42 +101,22 @@ 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_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 - 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) = - Log.debug (fun m -> m "connection %a closed" - Fmt.(option pp_sockaddr) (sockaddr_of_flow ch)) in + Log.debug (fun m -> m "connection %s closed" + (Sexplib0.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))) in let callback = handler ~info ~docroot ~index in let config = Server.make ~callback ~conn_closed () 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 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 + 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 lwt_start_server docroot port host index verbose tls = if verbose <> None then begin diff --git a/cohttp-lwt-unix/src/client.ml b/cohttp-lwt-unix/src/client.ml index f2f3b4a39a..ccdb97f3d6 100644 --- a/cohttp-lwt-unix/src/client.ml +++ b/cohttp-lwt-unix/src/client.ml @@ -1,2 +1 @@ - -include Cohttp_lwt.Make_client(Cohttp_lwt_unix_nossl.IO)(Net) +include Cohttp_lwt.Make_client(Io)(Net) diff --git a/cohttp-lwt-unix/src/client.mli b/cohttp-lwt-unix/src/client.mli index e0b0631d28..ab89cce47f 100644 --- a/cohttp-lwt-unix/src/client.mli +++ b/cohttp-lwt-unix/src/client.mli @@ -1,5 +1,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 = Conduit.resolvers +include Cohttp_lwt.S.Client with type ctx = Net.ctx diff --git a/cohttp-lwt-unix/src/cohttp_lwt_unix.ml b/cohttp-lwt-unix/src/cohttp_lwt_unix.ml index 2d27f99338..5c171184c7 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(Cohttp_lwt_unix_nossl.IO) - : module type of Make(Cohttp_lwt_unix_nossl.IO) with type t := t) + include (Make(Io) + : module type of Make(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) + include (Make(Io) + : module type of Make(Io) with type t := t) end module Client = Client -module Server = Cohttp_lwt_unix_nossl.Server -module Debug = Cohttp_lwt_unix_nossl.Debug +module Server = Server +module Debug = Debug module Net = Net -module IO = Cohttp_lwt_unix_nossl.IO +module IO = Io 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 index a7493e16f4..45f38cbcd2 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 - ca-certs cohttp cohttp-lwt cohttp-lwt-unix-nossl)) + (libraries fmt logs logs.lwt conduit-lwt magic-mime lwt.unix + conduit-lwt-unix cohttp cohttp-lwt logs.fmt)) diff --git a/cohttp-lwt-unix-nossl/src/io.ml b/cohttp-lwt-unix/src/io.ml similarity index 98% rename from cohttp-lwt-unix-nossl/src/io.ml rename to cohttp-lwt-unix/src/io.ml index 030d30384a..b5579d6b24 100644 --- a/cohttp-lwt-unix-nossl/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.flow +type conn = Conduit_lwt_unix.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-nossl/src/io.mli b/cohttp-lwt-unix/src/io.mli similarity index 95% rename from cohttp-lwt-unix-nossl/src/io.mli rename to cohttp-lwt-unix/src/io.mli index 0814303c84..1e90ce1b11 100644 --- a/cohttp-lwt-unix-nossl/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.flow + and type conn = Conduit_lwt_unix.flow and type error = exn diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index 33147386dd..7df92e5024 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -19,49 +19,30 @@ open Lwt.Infix -module IO = Cohttp_lwt_unix_nossl.IO - -type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] - -let authenticator = - match Ca_certs.authenticator () with - | Ok a -> a - | Error (`Msg msg) -> failwith msg - -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 "https" -> - 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 - (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 -> - let ic, oc = Conduit_lwt.io_of_flow flow in - Lwt.return (flow, ic, oc) - | Error err -> - failwith "%a" Conduit_lwt.pp_error err +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:{ctx; resolver} uri = + Resolver_lwt.resolve_uri ~uri resolver + >>= fun endp -> + Conduit_lwt_unix.endp_to_client ~ctx endp + >>= fun client -> + Conduit_lwt_unix.connect ~ctx client 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 813021f7f9..f7844eff1a 100644 --- a/cohttp-lwt-unix/src/net.mli +++ b/cohttp-lwt-unix/src/net.mli @@ -16,16 +16,30 @@ (** Basic satisfaction of {! Cohttp_lwt.Net } *) -module IO = Cohttp_lwt_unix_nossl.IO +module IO = Io -type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] +type ctx = { + ctx : Conduit_lwt_unix.ctx; + resolver : Resolver_lwt.t; +} [@@deriving sexp_of] val default_ctx : ctx +(** [default_ctx] is the default network context. It uses + [Conduit_lwt_unix.default_ctx] and [Resolver_lwt_unix.system]. *) + +val init : ?ctx:Conduit_lwt_unix.ctx -> ?resolver:Resolver_lwt.t -> unit -> ctx +(** [init ?ctx ?resolver ()] is a network 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.resolver} 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 connect_uri : ctx:ctx -> Uri.t -> - (Conduit_lwt.flow * Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel) Lwt.t + (Conduit_lwt_unix.flow * Lwt_io.input Lwt_io.channel * Lwt_io.output Lwt_io.channel) Lwt.t (** [connect_uri ~ctx uri] starts a {i flow} on the given [uri]. The choice of the protocol (with or without encryption) is done by the {i scheme} of the given [uri]: diff --git a/cohttp-lwt-unix-nossl/src/server.ml b/cohttp-lwt-unix/src/server.ml similarity index 59% rename from cohttp-lwt-unix-nossl/src/server.ml rename to cohttp-lwt-unix/src/server.ml index c52b33d996..1de7af9568 100644 --- a/cohttp-lwt-unix-nossl/src/server.ml +++ b/cohttp-lwt-unix/src/server.ml @@ -67,41 +67,7 @@ let log_on_exn = (Unix.error_message error) func arg) | exn -> Log.err (fun m -> m "Unhandled exception: %a" Fmt.exn exn) -let pp_sockaddr ppf = function - | Unix.ADDR_UNIX v -> Fmt.pf ppf "" v - | Unix.ADDR_INET (inet_addr, port) -> Fmt.pf ppf "" (Unix.string_of_inet_addr inet_addr) port - -let safe error_handler callback spec flow () = - let () = match flow with - | Conduit_lwt.TCP.T (Value file_descr) -> - let sockaddr = Conduit_lwt.TCP.Protocol.peer file_descr in - Log.debug (fun m -> m "Receive a connection from: %a.%!" pp_sockaddr sockaddr) ; - | _ -> () in - 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 -> 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 - (); fun () -> Lwt.pick [ (stop >|= Lwt_condition.signal cond); run () ] +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) diff --git a/cohttp-lwt-unix-nossl/src/server.mli b/cohttp-lwt-unix/src/server.mli similarity index 53% rename from cohttp-lwt-unix-nossl/src/server.mli rename to cohttp-lwt-unix/src/server.mli index dbbe3db351..d6e8d101c6 100644 --- a/cohttp-lwt-unix-nossl/src/server.mli +++ b/cohttp-lwt-unix/src/server.mli @@ -10,31 +10,19 @@ val respond_file : fname:string -> unit -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t -(** [create ?timeout ?backlog ?stop ?on_exn cfg protocol service t] is a new +(** [create ?timeout ?backlog ?stop ?on_exn ?mode t] is a new HTTP server. The user can decide to start a simple HTTP server (without encryption) - or one with TLS encryption. It depends on what the user gives as [cfg], - [protocol] and [service]. Using [conduit-lwt-tls], the end-user is able - to make an encrypted HTTP server with: + or one with TLS encryption. It depends on what the user gives as [mode] + and hpw [conduit-unix] is configured. - {[ - let run = - create cfg Conduit_lwt_tls.TCP.protocol Conduit_lwt_tls.TCP.service - ]} - - A simple HTTP server (with [conduit-lwt]) is: + To create a simple HTTP server listening on port 8089: {[ - let run = - create cfg Conduit_lwt.TCP.protocol Conduit_lwt.TCP.service + let run = create (`TCP 8080) ]} - [cfg] depends on the given [service] - and let the user to define which - port the server use, and, in the case of {!Conduit_lwt_tls.TCP.service}, - which TLS certificate it uses. See [Conduit] for more information about - {i protocol} and {i service}. - When provided, the [stop] thread will terminate the server if it ever becomes determined. @@ -50,6 +38,5 @@ val create : ?backlog:int -> ?stop:unit Lwt.t -> ?on_exn:(exn -> unit) -> - 'cfg -> - (_, 'flow) Conduit_lwt.protocol -> - ('cfg, 't, 'flow) Conduit_lwt.Service.service -> t -> (unit -> unit Lwt.t) + ?ctx:Net.ctx -> + ?mode:Conduit_lwt_unix.server -> t -> unit Lwt.t diff --git a/cohttp-lwt-unix/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml index 60e29446b0..55a26e0eb4 100644 --- a/cohttp-lwt-unix/test/test_sanity.ml +++ b/cohttp-lwt-unix/test/test_sanity.ml @@ -171,7 +171,7 @@ let ts = assert_equal ~printer "expert 2" body in let client_close () = - Cohttp_lwt_unix.Net.(connect_uri ~ctx) 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/src/s.ml b/cohttp-lwt/src/s.ml index 855bca60fd..ccaebe52ab 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 [@@deriving sexp] + type ctx [@@deriving sexp_of] val default_ctx : ctx val connect_uri : ctx:ctx -> Uri.t -> (IO.conn * IO.ic * IO.oc) Lwt.t @@ -41,7 +41,7 @@ module type Client = sig type ctx (** [call ?ctx ?headers ?body ?chunked meth uri] will resolve the - [uri] to a concrete network endpoint using the {!Conduit.resolvers} [ctx]. + [uri] to a concrete network endpoint using context [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 @@ -51,13 +51,14 @@ module type Client = sig In most cases you should use the more specific helper calls in the interface rather than invoke this function directly. See {!head}, {!get} and {!post} for some examples. - + Depending on [ctx], the library is able to send a simple HTTP request - or an encrypted one with a secured protocol (such as TLS). By default - (on [cohttp-lwt-unix]), [ctx] tries to initiate a secured connection - with TLS (it uses [ocaml-tls]) on [*:443] or on the specified port by - the user. If the peer is not available, [cohttp]/[conduit] tries the usual - ([*:80]) or the specified port by the user in a non-secured way. *) + or an encrypted one with a secured protocol (such as TLS). Depending on + how conduit is configured, [ctx] might initiate a secured connection + with TLS (using [ocaml-tls]) or SSL (using [ocaml-ssl]), on [*:443] or on + the specified port by the user. If neitehr [ocaml-tls] or [ocaml-ssl] are + installed on the system, [cohttp]/[conduit] tries the usual ([*:80]) or + the specified port by the user in a non-secured way. *) val call : ?ctx:ctx -> ?headers:Cohttp.Header.t -> diff --git a/cohttp-mirage.opam b/cohttp-mirage.opam index 5dc4b02bad..903fe03e8c 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" {>= "3.0.0"} + "conduit-mirage" {>= "2.0.2"} "mirage-kv" {>= "3.0.0"} "lwt" {>= "2.4.3"} "cohttp" {=version} diff --git a/cohttp-mirage/src/client.ml b/cohttp-mirage/src/client.ml index d132b4d8ba..31a1250ccc 100644 --- a/cohttp-mirage/src/client.ml +++ b/cohttp-mirage/src/client.ml @@ -19,7 +19,7 @@ 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) @@ -27,30 +27,22 @@ module Net_IO = struct module IO = HTTP_IO - type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] + type ctx = { + resolver: Resolver_lwt.t; + conduit : Conduit_mirage.t; + } - let default_ctx = Conduit.empty + let sexp_of_ctx { resolver; _ } = Resolver_lwt.sexp_of_t resolver - let failwith fmt = Fmt.kstrf (fun err -> Lwt.fail (Failure err)) fmt + let default_ctx = + { resolver = Resolver_mirage.localhost; conduit = Conduit_mirage.empty } - 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 -> - Conduit_mirage.resolve ctx edn >>= function - | Ok flow -> - let ch = Channel.create flow in - Lwt.return (flow, ch, ch) - | Error err -> - failwith "%a" Conduit_mirage.pp_error err + let connect_uri ~ctx:{resolver; conduit} uri = + Resolver_lwt.resolve_uri ~uri resolver >>= fun endp -> + Conduit_mirage.client endp >>= fun client -> + Conduit_mirage.connect conduit client >>= fun flow -> + let ch = Channel.create flow in + Lwt.return (flow, ch, ch) let close_in _ = () let close_out _ = () @@ -63,6 +55,7 @@ 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 d8c82bc7c8..af9806a910 100644 --- a/cohttp-mirage/src/client.mli +++ b/cohttp-mirage/src/client.mli @@ -1,2 +1,3 @@ include Cohttp_lwt.S.Client - with type ctx = Conduit.resolvers + +val ctx: Resolver_lwt.t -> Conduit_mirage.t -> ctx diff --git a/cohttp-mirage/src/dune b/cohttp-mirage/src/dune index c44b75112d..cc00817565 100644 --- a/cohttp-mirage/src/dune +++ b/cohttp-mirage/src/dune @@ -4,5 +4,5 @@ (synopsis "Mirage backend for cohttp") (preprocess (pps ppx_sexp_conv)) - (libraries conduit-mirage.flow cohttp-lwt mirage-channel conduit-mirage - mirage-kv mirage-flow magic-mime astring)) + (libraries conduit-mirage cohttp-lwt mirage-channel mirage-kv mirage-flow + magic-mime astring)) diff --git a/cohttp-mirage/src/server_with_conduit.ml b/cohttp-mirage/src/server_with_conduit.ml index 2fc93807ae..f0c192b51c 100644 --- a/cohttp-mirage/src/server_with_conduit.ml +++ b/cohttp-mirage/src/server_with_conduit.ml @@ -1,15 +1,5 @@ -include Make.Server(Conduit_mirage_flow) +include Make.Server(Conduit_mirage.Flow) -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 +let connect t = + let listen s f = Conduit_mirage.listen t s (listen f) in + Lwt.return listen diff --git a/cohttp-mirage/src/server_with_conduit.mli b/cohttp-mirage/src/server_with_conduit.mli index 70f7465cf3..18485b5596 100644 --- a/cohttp-mirage/src/server_with_conduit.mli +++ b/cohttp-mirage/src/server_with_conduit.mli @@ -1,8 +1,6 @@ (** HTTP server with conduit. *) -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 +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 diff --git a/cohttp_async_test/src/cohttp_async_test.ml b/cohttp_async_test/src/cohttp_async_test.ml index ff4bc91322..cac24c5e4b 100644 --- a/cohttp_async_test/src/cohttp_async_test.ml +++ b/cohttp_async_test/src/cohttp_async_test.ml @@ -24,23 +24,21 @@ let const rsp _req _body = rsp >>| response let response_sequence = Cohttp_test.response_sequence failwith let get_port = - let port = ref 10_000 in + let port = ref 10_080 in (fun () -> let v = !port in Int.incr port ; v ) let temp_server ?port spec callback = let port = match port with | None -> get_port () | Some p -> p in - 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 - 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 + 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) + (fun ~body _sock req -> spec req body) in + server >>= fun server -> + callback uri >>= fun res -> + Server.close server >>| fun () -> + res let test_server_s ?port ?(name="Cohttp Server Test") spec f = temp_server ?port spec begin fun uri -> 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 091efd5267..624b2b5546 100644 --- a/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml +++ b/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml @@ -28,24 +28,15 @@ 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 -> get_port () + | None -> Cohttp_test.next_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://localhost:" ^ (string_of_int port)) in + let uri = Uri.of_string ("http://0.0.0.0:" ^ (string_of_int port)) in let server_failed, server_failed_wake = Lwt.task () in let server = Lwt.catch - (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 ()) + (fun () -> Server.create ~backlog:40 ~mode:(`TCP (`Port port)) 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 720b77070e..b566fb6646 100644 --- a/examples/async/hello_world.ml +++ b/examples/async/hello_world.ml @@ -1,6 +1,7 @@ (* This file is in the public domain *) open Base +open Async_kernel open Cohttp_async (* given filename: hello_world.ml compile with: @@ -18,13 +19,12 @@ 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 - ~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 + Cohttp_async.Server.create ~on_handler_error:`Raise + (Async.Tcp.Where_to_listen.of_port port) handler + >>= fun _ -> Deferred.never () let () = let module Command = Async_command in diff --git a/examples/async/receive_post.ml b/examples/async/receive_post.ml index 2279231fe8..91ef78b918 100644 --- a/examples/async/receive_post.ml +++ b/examples/async/receive_post.ml @@ -5,20 +5,19 @@ 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 - ~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 -> + Cohttp_async.Server.create ~on_handler_error:`Raise + (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) in - server + | _ -> Server.respond `Method_not_allowed + ) + >>= fun _ -> Deferred.never () let () = let module Command = Async_command in diff --git a/examples/lwt_unix_doc/docker_lwt.ml b/examples/lwt_unix_doc/docker_lwt.ml index 1ae6896e7e..2bbc69f625 100644 --- a/examples/lwt_unix_doc/docker_lwt.ml +++ b/examples/lwt_unix_doc/docker_lwt.ml @@ -1,18 +1,9 @@ open Lwt.Infix +open Cohttp_lwt_unix -let resolve_unix_socket : Conduit_lwt.Endpoint.t -> 'edn option Lwt.t = function - | IP _ -> Lwt.return_none - | Domain v -> ( - match Domain_name.to_string v with - | "docker" -> Lwt.return_some (Unix.ADDR_UNIX "/var/run/docker.sock") - | _ -> Lwt.return_none ) let t = - let ctx = - Conduit_lwt.add ~priority:0 (* highest priority *) Conduit_lwt.TCP.protocol - resolve_unix_socket Conduit.empty - in - Cohttp_lwt_unix.Client.get ~ctx (Uri.of_string "http://docker/version") + Client.get (Uri.of_string "http://docker/version") >>= fun (resp, body) -> let open Cohttp in let code = resp |> Response.status |> Code.code_of_status in diff --git a/examples/lwt_unix_doc/server_lwt.ml b/examples/lwt_unix_doc/server_lwt.ml index 6705f8e08b..60b30f3e60 100644 --- a/examples/lwt_unix_doc/server_lwt.ml +++ b/examples/lwt_unix_doc/server_lwt.ml @@ -12,13 +12,6 @@ let server = meth headers body ) >>= fun body -> Server.respond_string ~status:`OK ~body () in - let tcp_config = - { - Conduit_lwt.TCP.sockaddr = Unix.ADDR_INET (Unix.inet_addr_loopback, 8000); - capacity = 40; - } - in - Server.create tcp_config Conduit_lwt.TCP.protocol Conduit_lwt.TCP.service - (Server.make ~callback ()) + Server.create ~mode:(`TCP (`Port 8000)) (Server.make ~callback ()) -let _ = Lwt_main.run (server ()) +let () = ignore (Lwt_main.run server)