Support the newly-released Async_ssl

.travis-ci.sh

@@ -1,4 +1,4 @@
-OPAM_DEPENDS="lwt async ssl uri re"
+OPAM_DEPENDS="lwt async async_ssl ssl uri re"
 
 case "$OCAML_VERSION,$OPAM_VERSION" in
 4.00.1,1.0.0) ppa=avsm/ocaml40+opam10 ;;

_oasis

@@ -56,7 +56,7 @@ Library cohttp_async
   Path: async
   Findlibname: async
   FindlibParent: cohttp
-  BuildDepends: uri, cohttp, threads, async
+  BuildDepends: uri, cohttp, threads, async, async_ssl
   Modules: Cohttp_async
 
 Document cohttp

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 94b391cd2b40dcfc668217d672bfe48a)
+# DO NOT EDIT (digest: e97b0f440e37c91188c29722805bd766)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -62,6 +62,7 @@
 # Library cohttp_async
 "async/cohttp_async.cmxs": use_cohttp_async
 <async/*.ml{,i}>: pkg_async
+<async/*.ml{,i}>: pkg_async_ssl
 <async/*.ml{,i}>: pkg_fieldslib
 <async/*.ml{,i}>: pkg_fieldslib.syntax
 <async/*.ml{,i}>: pkg_re
@@ -234,6 +235,7 @@
 <lib_test/test_net_lwt_client_and_server.{native,byte}>: custom
 # Executable test_net_async
 <lib_test/test_net_async.{native,byte}>: pkg_async
+<lib_test/test_net_async.{native,byte}>: pkg_async_ssl
 <lib_test/test_net_async.{native,byte}>: pkg_fieldslib
 <lib_test/test_net_async.{native,byte}>: pkg_fieldslib.syntax
 <lib_test/test_net_async.{native,byte}>: pkg_oUnit
@@ -248,6 +250,7 @@
 <lib_test/test_net_async.{native,byte}>: custom
 # Executable test_net_async_http10
 <lib_test/test_net_async_http10.{native,byte}>: pkg_async
+<lib_test/test_net_async_http10.{native,byte}>: pkg_async_ssl
 <lib_test/test_net_async_http10.{native,byte}>: pkg_fieldslib
 <lib_test/test_net_async_http10.{native,byte}>: pkg_fieldslib.syntax
 <lib_test/test_net_async_http10.{native,byte}>: pkg_oUnit
@@ -262,6 +265,7 @@
 <lib_test/test_net_async_http10.{native,byte}>: custom
 # Executable test_net_async_multi_get
 <lib_test/test_net_async_multi_get.{native,byte}>: pkg_async
+<lib_test/test_net_async_multi_get.{native,byte}>: pkg_async_ssl
 <lib_test/test_net_async_multi_get.{native,byte}>: pkg_fieldslib
 <lib_test/test_net_async_multi_get.{native,byte}>: pkg_fieldslib.syntax
 <lib_test/test_net_async_multi_get.{native,byte}>: pkg_oUnit
@@ -276,6 +280,7 @@
 <lib_test/test_net_async_multi_get.{native,byte}>: custom
 # Executable test_net_async_server
 <lib_test/test_net_async_server.{native,byte}>: pkg_async
+<lib_test/test_net_async_server.{native,byte}>: pkg_async_ssl
 <lib_test/test_net_async_server.{native,byte}>: pkg_fieldslib
 <lib_test/test_net_async_server.{native,byte}>: pkg_fieldslib.syntax
 <lib_test/test_net_async_server.{native,byte}>: pkg_oUnit
@@ -288,6 +293,7 @@
 <lib_test/test_net_async_server.{native,byte}>: use_cohttp
 <lib_test/test_net_async_server.{native,byte}>: use_cohttp_async
 <lib_test/*.ml{,i}>: pkg_async
+<lib_test/*.ml{,i}>: pkg_async_ssl
 <lib_test/*.ml{,i}>: pkg_fieldslib
 <lib_test/*.ml{,i}>: pkg_fieldslib.syntax
 <lib_test/*.ml{,i}>: pkg_oUnit
@@ -302,6 +308,7 @@
 <lib_test/test_net_async_server.{native,byte}>: custom
 # Executable cohttp-server
 <bin/cohttp_server_async.{native,byte}>: pkg_async
+<bin/cohttp_server_async.{native,byte}>: pkg_async_ssl
 <bin/cohttp_server_async.{native,byte}>: pkg_fieldslib
 <bin/cohttp_server_async.{native,byte}>: pkg_fieldslib.syntax
 <bin/cohttp_server_async.{native,byte}>: pkg_re
@@ -313,6 +320,7 @@
 <bin/cohttp_server_async.{native,byte}>: use_cohttp
 <bin/cohttp_server_async.{native,byte}>: use_cohttp_async
 <bin/*.ml{,i}>: pkg_async
+<bin/*.ml{,i}>: pkg_async_ssl
 <bin/*.ml{,i}>: pkg_fieldslib
 <bin/*.ml{,i}>: pkg_fieldslib.syntax
 <bin/*.ml{,i}>: pkg_re
@@ -326,6 +334,7 @@
 <bin/cohttp_server_async.{native,byte}>: custom
 # Executable async-hello-world
 <examples/async/hello_world.{native,byte}>: pkg_async
+<examples/async/hello_world.{native,byte}>: pkg_async_ssl
 <examples/async/hello_world.{native,byte}>: pkg_fieldslib
 <examples/async/hello_world.{native,byte}>: pkg_fieldslib.syntax
 <examples/async/hello_world.{native,byte}>: pkg_re
@@ -337,6 +346,7 @@
 <examples/async/hello_world.{native,byte}>: use_cohttp
 <examples/async/hello_world.{native,byte}>: use_cohttp_async
 <examples/async/*.ml{,i}>: pkg_async
+<examples/async/*.ml{,i}>: pkg_async_ssl
 <examples/async/*.ml{,i}>: pkg_fieldslib
 <examples/async/*.ml{,i}>: pkg_fieldslib.syntax
 <examples/async/*.ml{,i}>: pkg_re

async/cohttp_async.ml

@@ -17,6 +17,7 @@
 
 open Core.Std
 open Async.Std
+open Async_ssl.Std
 
 module IO = struct
   let check_debug norm_fn debug_fn =
@@ -34,7 +35,7 @@ module IO = struct
   type oc = Writer.t
 
   let iter fn x =
-    Deferred.List.iter x ~f:fn 
+    Deferred.List.iter x ~f:fn
 
   let read_line =
     check_debug
@@ -66,11 +67,11 @@ module IO = struct
 
   let write =
     check_debug
-      (fun oc buf -> 
-         Writer.write oc buf; 
+      (fun oc buf ->
+         Writer.write oc buf;
          return ())
-      (fun oc buf -> 
-         eprintf "\n%4d >>> %s" (Pid.to_int (Unix.getpid ())) buf; 
+      (fun oc buf ->
+         eprintf "\n%4d >>> %s" (Pid.to_int (Unix.getpid ())) buf;
          Writer.write oc buf;
          return ())
 
@@ -93,11 +94,24 @@ module IO = struct
 end
 
 module Net = struct
-  let connect ?interrupt uri =
+  let connect ?interrupt ?ssl:(ssl=false) uri =
     let host = Option.value (Uri.host uri) ~default:"localhost" in
     match Uri_services.tcp_port_of_uri ~default:"http" uri with
     |None -> raise (Failure "Net.connect") (* TODO proper exception *)
-    |Some port -> Tcp.connect ?interrupt (Tcp.to_host_and_port host port)
+    |Some port ->
+      Tcp.connect ?interrupt (Tcp.to_host_and_port host port)
+      >>= fun (socket, net_to_ssl, ssl_to_net) ->
+      match ssl with
+      | false -> return (socket, net_to_ssl, ssl_to_net)
+      | true ->
+        let net_to_ssl = Reader.pipe net_to_ssl in
+        let ssl_to_net = Writer.pipe ssl_to_net in
+        let app_to_ssl, app_wr = Pipe.create () in
+        let app_rd, ssl_to_app = Pipe.create () in
+        don't_wait_for (Ssl.client ~app_to_ssl ~ssl_to_app ~net_to_ssl ~ssl_to_net ());
+        Reader.of_pipe (Info.of_string "cohttp_client_reader") app_rd >>= fun app_rd ->
+        Writer.of_pipe (Info.of_string "cohttp_client_writer") app_wr >>| fun (app_wr,_) ->
+        socket, app_rd, app_wr
 end
 
 module Request = struct
@@ -116,7 +130,7 @@ let pipe_of_body read_chunk ic oc =
   let finished =
     Deferred.repeat_until_finished ()
       (fun () ->
-         read_chunk ic 
+         read_chunk ic
          >>= function
          | Chunk buf ->
            begin
@@ -126,7 +140,7 @@ let pipe_of_body read_chunk ic oc =
              | `Ok _ -> `Repeat ()
            end
          | Final_chunk buf ->
-           Pipe.write_when_ready wr ~f:(fun wrfn -> wrfn buf) 
+           Pipe.write_when_ready wr ~f:(fun wrfn -> wrfn buf)
            >>| fun _ -> `Finished ()
          | Done -> return (`Finished ())
       ) in
@@ -173,7 +187,7 @@ module Body = struct
     | `String s -> Response.write_body response wr s
     | `Pipe p ->
       Pipe.iter p ~f:(fun buf ->
-          Response.write_body response wr buf 
+          Response.write_body response wr buf
           >>= fun () ->
           match Response.flush response with
           | true -> Writer.flushed wr
@@ -182,25 +196,25 @@ end
 
 module Client = struct
 
-  let call ?interrupt ?headers ?(chunked=false) ?(body=`Empty) meth uri =
+  let call ?interrupt ?ssl ?headers ?(chunked=false) ?(body=`Empty) meth uri =
     (* Convert the body Pipe to a list of chunks. *)
     (match body with
      | `Empty -> return []
      | `String s -> return [s]
-     | `Pipe body -> Pipe.to_list body 
+     | `Pipe body -> Pipe.to_list body
     ) >>= fun body_bufs ->
     (* Figure out an appropriate transfer encoding *)
     let req =
       match body_bufs,chunked with
       | [],true     (* Dont used chunked encoding with an empty body *)
       | _,false ->  (* If we dont want chunked, calculate a content length *)
         let body_length = List.fold ~init:0 ~f:(fun a b -> String.length b + a) body_bufs in
-        Request.make_for_client ?headers ~chunked:false ~body_length meth uri 
+        Request.make_for_client ?headers ~chunked:false ~body_length meth uri
       | _,true ->   (* Use chunked encoding if there is a body *)
         Request.make_for_client ?headers ~chunked meth uri
     in
     (* Connect to the remote side *)
-    Net.connect ?interrupt uri
+    Net.connect ?interrupt ?ssl uri
     >>= fun (_,ic,oc) ->
     (* Write request down the wire *)
     Request.write_header req oc
@@ -218,10 +232,10 @@ module Client = struct
       let rd = pipe_of_body (Response.read_body_chunk res) ic oc in
       return (res, `Pipe rd)
 
-  let get ?interrupt ?headers uri =
+  let get ?interrupt ?ssl ?headers uri =
     call ?interrupt ?headers ~chunked:false `GET uri
 
-  let head ?interrupt ?headers uri =
+  let head ?interrupt ?ssl ?headers uri =
     call ?interrupt ?headers ~chunked:false `HEAD uri
     >>= begin fun (res, body) ->
       (match body with
@@ -230,17 +244,17 @@ module Client = struct
       return res
     end
 
-  let post ?interrupt ?headers ?(chunked=false) ?body uri =
-    call ?interrupt ?headers ~chunked ?body `POST uri
+  let post ?interrupt ?ssl ?headers ?(chunked=false) ?body uri =
+    call ?interrupt ?ssl ?headers ~chunked ?body `POST uri
 
-  let put ?interrupt ?headers ?(chunked=false) ?body uri =
-    call ?interrupt ?headers ~chunked ?body `PUT uri
+  let put ?interrupt ?ssl ?headers ?(chunked=false) ?body uri =
+    call ?interrupt ?ssl ?headers ~chunked ?body `PUT uri
 
-  let patch ?interrupt ?headers ?(chunked=false) ?body uri =
-    call ?interrupt ?headers ~chunked ?body `PATCH uri
+  let patch ?interrupt ?ssl ?headers ?(chunked=false) ?body uri =
+    call ?interrupt ?ssl ?headers ~chunked ?body `PATCH uri
 
-  let delete ?interrupt ?headers uri =
-    call ?interrupt ?headers ~chunked:false `DELETE uri
+  let delete ?interrupt ?ssl ?headers uri =
+    call ?interrupt ?ssl ?headers ~chunked:false `DELETE uri
 end
 
 module Server = struct
@@ -262,12 +276,32 @@ module Server = struct
       let read_chunk = Request.read_body_chunk req in
       `Pipe (pipe_of_body read_chunk rd wr)
 
-  let handle_client handle_request sock rd wr =
+  let handle_client ?ssl handle_request sock rd wr =
+    begin match ssl with
+    | None -> return (rd, wr)
+    | Some (`Crt_file_path crt_file, `Key_file_path key_file) ->
+      let net_to_ssl = Reader.pipe rd in
+      let ssl_to_net = Writer.pipe wr in
+      let app_to_ssl, app_wr = Pipe.create () in
+      let app_rd, ssl_to_app = Pipe.create () in
+      Ssl.server
+        ~crt_file
+        ~key_file
+        ~app_to_ssl
+        ~ssl_to_app
+        ~net_to_ssl
+        ~ssl_to_net
+        () |> don't_wait_for;
+      Reader.of_pipe (Info.of_string "cohttp_server_reader") app_rd >>= fun app_rd ->
+      Writer.of_pipe (Info.of_string "cohttp_server_writer") app_wr >>| fun (app_wr,_) ->
+      app_rd, app_wr
+    end
+    >>= fun (reader, writer) ->
     let requests_pipe =
       Reader.read_all rd (fun rd ->
-        Request.read rd 
+        Request.read rd
         >>| function
-        | `Eof | `Invalid _ -> `Eof	
+        | `Eof | `Invalid _ -> `Eof
         | `Ok req ->
           let body = read_body req rd wr in
           if not (Request.is_keep_alive req)
@@ -333,11 +367,11 @@ module Server = struct
     |Error exn -> respond_with_string ~code:`Not_found error_body
 
 
-  let create ?max_connections ?max_pending_connections 
+  let create ?max_connections ?ssl ?max_pending_connections
       ?buffer_age_limit ?on_handler_error where_to_listen handle_request =
-    Tcp.Server.create ?max_connections ?max_pending_connections 
-      ?buffer_age_limit ?on_handler_error 
-      where_to_listen (handle_client handle_request)
+    Tcp.Server.create ?max_connections ?max_pending_connections
+      ?buffer_age_limit ?on_handler_error
+      where_to_listen (handle_client ?ssl handle_request)
     >>| fun server ->
     { server }