diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000000..e69de29bb2 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 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 diff --git a/cohttp-async.opam b/cohttp-async.opam index fd838ba36f..786836bbe0 100644 --- a/cohttp-async.opam +++ b/cohttp-async.opam @@ -31,7 +31,8 @@ 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" "fmt" {>= "0.8.2"} @@ -41,6 +42,7 @@ depends: [ "ounit" {with-test} "uri" {>= "2.0.0"} "uri-sexp" + "ipaddr" ] build: [ ["dune" "subst"] {pinned} diff --git a/cohttp-async/bin/cohttp_server_async.ml b/cohttp-async/bin/cohttp_server_async.ml index c6c0e514d3..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); @@ -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 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/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 -> 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/src/server.ml b/cohttp-async/src/server.ml index 4e53317b1d..41abccf9cf 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 -> 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..83599adc30 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 = @@ -38,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 -> @@ -62,33 +53,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 -> 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 -> unit Async.Deferred.t) 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/cohttp_lwt_xhr.ml b/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml index 1aa3c4e0db..47b653bba7 100644 --- a/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml @@ -122,9 +122,7 @@ module Make_api(X : sig module Request = X.Request module Response = X.Response - let default_ctx = () type ctx = unit - let sexp_of_ctx _ = Sexplib0.Sexp.List [] let call ?ctx:_ ?headers ?body ?chunked:_ meth uri = X.call ?headers ?body meth uri 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-nossl.opam b/cohttp-lwt-unix-nossl.opam new file mode 100644 index 0000000000..edffa284cd --- /dev/null +++ b/cohttp-lwt-unix-nossl.opam @@ -0,0 +1,46 @@ +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" {>= "3.0.0"} + "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" 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 98% rename from cohttp-lwt-unix/src/io.ml rename to cohttp-lwt-unix-nossl/src/io.ml index b5579d6b24..030d30384a 100644 --- a/cohttp-lwt-unix/src/io.ml +++ b/cohttp-lwt-unix-nossl/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-nossl/src/io.mli similarity index 95% rename from cohttp-lwt-unix/src/io.mli rename to cohttp-lwt-unix-nossl/src/io.mli index 1e90ce1b11..0814303c84 100644 --- a/cohttp-lwt-unix/src/io.mli +++ b/cohttp-lwt-unix-nossl/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 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 66% rename from cohttp-lwt-unix/src/server.ml rename to cohttp-lwt-unix-nossl/src/server.ml index 3aea6dc1ba..cc4af0a224 100644 --- a/cohttp-lwt-unix/src/server.ml +++ b/cohttp-lwt-unix-nossl/src/server.ml @@ -67,7 +67,32 @@ 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 -> 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 () ] diff --git a/cohttp-lwt-unix/src/server.mli b/cohttp-lwt-unix-nossl/src/server.mli similarity index 90% rename from cohttp-lwt-unix/src/server.mli rename to cohttp-lwt-unix-nossl/src/server.mli index 2bf30975c5..d24c938780 100644 --- a/cohttp-lwt-unix/src/server.mli +++ b/cohttp-lwt-unix-nossl/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 -> unit Lwt.t) diff --git a/cohttp-lwt-unix-ssl.opam b/cohttp-lwt-unix-ssl.opam new file mode 100644 index 0000000000..ab71da9fd2 --- /dev/null +++ b/cohttp-lwt-unix-ssl.opam @@ -0,0 +1,48 @@ +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" {>= "3.0.0"} + "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" 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 25244d0a88..efb566b7cb 100644 --- a/cohttp-lwt-unix.opam +++ b/cohttp-lwt-unix.opam @@ -27,12 +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" {>= "3.0.0"} + "conduit-lwt-tls" + "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} diff --git a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml index f58aa090ec..eb4643d76a 100644 --- a/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml @@ -22,6 +22,25 @@ 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 *) @@ -54,18 +73,44 @@ let handler ~verbose _ req body = in Server.respond ~headers ~status ~body () -let start_proxy port host verbose cert key () = +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 = 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 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 lwt_start_proxy port host verbose cert key = Lwt_main.run (start_proxy port host verbose cert key ()) @@ -74,7 +119,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..3580428caf 100644 --- a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml @@ -21,9 +21,27 @@ 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) @@ -86,10 +104,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 +120,42 @@ 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 start_server docroot port host index tls () = +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 = 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 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 lwt_start_server docroot port host index verbose tls = if verbose <> None then begin diff --git a/cohttp-lwt-unix/bin/dune b/cohttp-lwt-unix/bin/dune index 833d0986a5..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) - (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) + (package cohttp-lwt-unix) + (public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt)) diff --git a/cohttp-lwt-unix/src/client.ml b/cohttp-lwt-unix/src/client.ml index 2af115ccde..f2f3b4a39a 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 +include Cohttp_lwt.Make_client(Cohttp_lwt_unix_nossl.IO)(Net) diff --git a/cohttp-lwt-unix/src/client.mli b/cohttp-lwt-unix/src/client.mli index 1301262073..e0b0631d28 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 ctx = Conduit.resolvers 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 1ce34e90af..a7493e16f4 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-tls magic-mime lwt.unix + 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 a0d2665423..33147386dd 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -19,28 +19,49 @@ open Lwt.Infix -module IO = Io +module IO = Cohttp_lwt_unix_nossl.IO -type ctx = { - ctx: Conduit_lwt_unix.ctx; - resolver: Resolver_lwt.t; -} [@@deriving sexp_of] +type ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] -let init ?(ctx=Conduit_lwt_unix.default_ctx) - ?(resolver=Resolver_lwt_unix.system) () = - { ctx; resolver } +let authenticator = + match Ca_certs.authenticator () with + | Ok a -> a + | Error (`Msg msg) -> failwith msg -let default_ctx = { - resolver = Resolver_lwt_unix.system; - ctx = Conduit_lwt_unix.default_ctx; -} +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 = - 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 + 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 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..b5d8852a52 100644 --- a/cohttp-lwt-unix/src/net.mli +++ b/cohttp-lwt-unix/src/net.mli @@ -16,21 +16,21 @@ (** Basic satisfaction of {! Cohttp_lwt.Net } *) -module IO = Io +module IO = Cohttp_lwt_unix_nossl.IO -type ctx = { - ctx : Conduit_lwt_unix.ctx; - resolver : Resolver_lwt.t; -} [@@deriving sexp_of] - -val init : ?ctx:Conduit_lwt_unix.ctx -> ?resolver:Resolver_lwt.t -> unit -> ctx +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_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 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-unix/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml index e5f0c402ca..60e29446b0 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 (); @@ -95,10 +88,18 @@ 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 ts = Cohttp_lwt_unix_test.test_server_s server begin fun uri -> + let ctx = Cohttp_lwt_unix.Net.default_ctx in let t () = - Client.get uri >>= fun (_, body) -> + Client.get ~ctx uri >>= fun (_, body) -> body |> Body.to_string >|= fun body -> assert_equal body message in let pipelined_chunk () = @@ -110,7 +111,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 ~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 @@ -128,7 +129,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 ~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); @@ -148,29 +149,29 @@ let ts = assert_equal l 3 in let massive_chunked () = - Client.get 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 uri >>= fun resp_head -> + Client.head ~ctx uri >>= fun resp_head -> assert_equal (Response.status resp_head) `OK; - Client.get 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 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 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 ~ctx:default_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 () -> @@ -192,4 +193,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..927819c682 100644 --- a/cohttp-lwt-unix/test/test_sanity_noisy.ml +++ b/cohttp-lwt-unix/test/test_sanity_noisy.ml @@ -44,12 +44,13 @@ 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.default_ctx in let empty_chunk () = - Client.get 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 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 @@ -63,7 +64,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 ~ctx 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 +80,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/src/client.ml b/cohttp-lwt/src/client.ml index 3af601d834..982626f814 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 ctx = Net.ctx let read_response ~closefn ic _oc meth = Response.read ic >>= begin function @@ -47,7 +46,7 @@ module Make | `DELETE -> false | _ -> true - let call ?(ctx=default_ctx) ?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 @@ -94,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=default_ctx) 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/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-lwt/src/s.ml b/cohttp-lwt/src/s.ml index f9a3d1500d..b5a618edec 100644 --- a/cohttp-lwt/src/s.ml +++ b/cohttp-lwt/src/s.ml @@ -21,8 +21,10 @@ 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 + + type ctx [@@deriving sexp] + + 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 @@ -36,9 +38,7 @@ 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 ctx [@@deriving sexp_of] - val default_ctx : ctx + type ctx (** [call ?ctx ?headers ?body ?chunked meth uri] will resolve the [uri] to a concrete network endpoint using the resolver initialized diff --git a/cohttp-mirage.opam b/cohttp-mirage.opam index e0a6b8defe..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" diff --git a/cohttp-mirage/src/client.ml b/cohttp-mirage/src/client.ml index f40997bf02..d132b4d8ba 100644 --- a/cohttp-mirage/src/client.ml +++ b/cohttp-mirage/src/client.ml @@ -19,29 +19,38 @@ 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 ctx = (Conduit.resolvers[@sexp.opaque]) [@@deriving sexp] + + 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 = - 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) + 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 close_in _ = () let close_out _ = () @@ -54,7 +63,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..d8c82bc7c8 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 ctx = Conduit.resolvers diff --git a/cohttp-mirage/src/dune b/cohttp-mirage/src/dune index 95fb33a2ab..ca62bfd2fc 100644 --- a/cohttp-mirage/src/dune +++ b/cohttp-mirage/src/dune @@ -1,7 +1,9 @@ (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) + (preprocess + (pps ppx_sexp_conv)) + (libraries conduit-mirage.flow cohttp-lwt mirage-channel conduit-mirage + 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 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 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/cohttp_async_test.ml b/cohttp_async_test/src/cohttp_async_test.ml index 463b26446c..ff4bc91322 100644 --- a/cohttp_async_test/src/cohttp_async_test.ml +++ b/cohttp_async_test/src/cohttp_async_test.ml @@ -24,21 +24,23 @@ 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 = 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 ()) + (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 test_server_s ?port ?(name="Cohttp Server Test") spec f = temp_server ?port spec begin fun uri -> 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/cohttp_lwt_unix_test.ml b/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml index 114e239223..091efd5267 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) 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)) diff --git a/examples/async/hello_world.ml b/examples/async/hello_world.ml index b566fb6646..720b77070e 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: @@ -19,12 +18,13 @@ 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; - 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..2279231fe8 100644 --- a/examples/async/receive_post.ml +++ b/examples/async/receive_post.ml @@ -5,19 +5,20 @@ 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; - 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