Merge pull request #692 from dinosaure/conduit-3.0.0

Conduit 3.0.0

.ocamlformat

@@ -0,0 +1,2 @@
+version = 0.15.0
+disable = true

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}

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

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))

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

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 ->

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)))