HTTPS support for the Lwt bindings (#2)

.travis.yml

@@ -13,5 +13,7 @@ env:
   - POST_INSTALL_HOOK="opam install --with-test httpaf-async httpaf-lwt-unix && opam exec -- make examples"
   matrix:
   - OCAML_VERSION="4.07"
-  - OCAML_VERSION="4.06"
+  - |
+    PRE_INSTALL_HOOK="sudo apt-get install -y libgmp-dev; opam install tls"
+    OCAML_VERSION="4.06"
   - OCAML_VERSION="4.05"

certificates/server.key

@@ -0,0 +1,15 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIICXQIBAAKBgQC2QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJv
+K+aOANKIsOOr9v4RiEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTRE
+BE/t1soVT3a/vVJWCLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQAB
+AoGAd/CShG8g/JBMh9Nz/8KAuKHRHc2BvysIM1C62cSosgaFmdRrazJfBrEv3Nlc
+2/0uc2dVYIxuvm8bIFqi2TWOdX9jWJf6oXwEPXCD0SaDbJTaoh0b+wjyHuaGlttY
+Ztvmf8mK1BOhyl3vNMxh/8Re0dGvGgPZHpn8zanaqfGVz+ECQQDngieUpwzxA0QZ
+GZKRYhHoLEaPiQzBaXphqWcCLLN7oAKxZlUCUckxRRe0tKINf0cB3Kr9gGQjPpm0
+YoqXo8mNAkEAyYgdd+JDi9FH3Cz6ijvPU0hYkriwTii0V09+Ar5DvYQNzNEIEJu8
+Q3Yte/TPRuK8zhnp97Bsy9v/Ji/LSWbtZQJBAJe9y8u3otfmWCBLjrIUIcCYJLe4
+ENBFHp4ctxPJ0Ora+mjkthuLF+BfdSZQr1dBcX1a8giuuvQO+Bgv7r9t75ECQC7F
+omEyaA7JEW5uGe9/Fgz0G2ph5rkdBU3GKy6jzcDsJu/EC6UfH8Bgawn7tSd0c/E5
+Xm2Xyog9lKfeK8XrV2kCQQCTico5lQPjfIwjhvn45ALc/0OrkaK0hQNpXgUNFJFQ
+tuX2WMD5flMyA5PCx5XBU8gEMHYa8Kr5d6uoixnbS0cZ
+-----END RSA PRIVATE KEY-----

certificates/server.pem

@@ -0,0 +1,15 @@
+-----BEGIN CERTIFICATE-----
+MIICYzCCAcwCCQDLbE6ES1ih1DANBgkqhkiG9w0BAQUFADB2MQswCQYDVQQGEwJB
+VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0
+cyBQdHkgTHRkMRUwEwYDVQQDDAxZT1VSIE5BTUUhISExGDAWBgkqhkiG9w0BCQEW
+CW1lQGJhci5kZTAeFw0xNDAyMTcyMjA4NDVaFw0xNTAyMTcyMjA4NDVaMHYxCzAJ
+BgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l
+dCBXaWRnaXRzIFB0eSBMdGQxFTATBgNVBAMMDFlPVVIgTkFNRSEhITEYMBYGCSqG
+SIb3DQEJARYJbWVAYmFyLmRlMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC2
+QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJvK+aOANKIsOOr9v4R
+iEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTREBE/t1soVT3a/vVJW
+CLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQABMA0GCSqGSIb3DQEB
+BQUAA4GBAIo4ZppIlp3JRyltRC1/AyCC0tsh5TdM3W7258wdoP3lEe08UlLwpnPc
+aJ/cX8rMG4Xf4it77yrbVrU3MumBEGN5TW4jn4+iZyFbp6TT3OUF55nsXDjNHBbu
+deDVpGuPTI6CZQVhU5qEMF3xmlokG+VV+HCDTglNQc+fdLM0LoNF
+-----END CERTIFICATE-----

examples/lwt/dune

@@ -1,6 +1,6 @@
 (executables
  (libraries httpaf httpaf-lwt-unix httpaf_examples base stdio lwt lwt.unix)
- (names lwt_get lwt_post lwt_echo_post))
+ (names lwt_get lwt_post lwt_echo_post lwt_https_get lwt_https_server))
 
 (alias
  (name examples)

examples/lwt/lwt_https_get.ml

@@ -0,0 +1,44 @@
+open Base
+open Lwt.Infix
+module Arg = Caml.Arg
+
+open Httpaf
+open Httpaf_lwt_unix
+
+let error_handler _ = assert false
+
+let main port host =
+  Lwt_unix.getaddrinfo host (Int.to_string port) [Unix.(AI_FAMILY PF_INET)]
+  >>= fun addresses ->
+  let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+  Lwt_unix.connect socket (List.hd_exn addresses).Unix.ai_addr
+  >>= fun () ->
+  let finished, notify_finished = Lwt.wait () in
+  let response_handler =
+    Httpaf_examples.Client.print ~on_eof:(Lwt.wakeup_later notify_finished)
+  in
+  let headers = Headers.of_list [ "host", host ] in
+  Client.TLS.request
+    ~error_handler
+    ~response_handler
+    socket
+    (Request.create ~headers `GET "/")
+  >>= fun request_body ->
+  Body.close_writer request_body;
+  finished
+;;
+
+let () =
+  let host = ref None in
+  let port = ref 443 in
+  Arg.parse
+    ["-p", Set_int port, " Port number (443 by default)"]
+    (fun host_argument -> host := Some host_argument)
+    "lwt_https_get.exe [-p N] HOST";
+  let host =
+    match !host with
+    | None -> failwith "No hostname provided"
+    | Some host -> host
+  in
+  Lwt_main.run (main !port host)
+;;

examples/lwt/lwt_https_server.ml

@@ -0,0 +1,41 @@
+open Base
+open Lwt.Infix
+module Arg = Caml.Arg
+
+open Httpaf_lwt_unix
+
+let request_handler (_ : Unix.sockaddr) = Httpaf_examples.Server.echo_post
+let error_handler (_ : Unix.sockaddr) = Httpaf_examples.Server.error_handler
+
+let main port =
+  let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in
+  let certfile = "./certificates/server.pem" in
+  let keyfile = "./certificates/server.key" in
+  Lwt.async (fun () ->
+    Lwt_io.establish_server_with_client_socket
+      listen_address
+      (Server.TLS.create_connection_handler
+        ?server:None
+        ~certfile
+        ~keyfile
+        ?config:None
+        ~request_handler
+        ~error_handler)
+    >|= fun _server ->
+      Stdio.printf "Listening on port %i and echoing POST requests.\n" port;
+      Stdio.printf "To send a POST request, try one of the following\n\n";
+      Stdio.printf "  echo \"Testing echo POST\" | dune exec examples/async/async_post.exe\n";
+      Stdio.printf "  echo \"Testing echo POST\" | dune exec examples/lwt/lwt_post.exe\n";
+      Stdio.printf "  echo \"Testing echo POST\" | curl -XPOST --data @- http://localhost:8080\n\n%!");
+  let forever, _ = Lwt.wait () in
+  Lwt_main.run forever
+;;
+
+let () =
+  let port = ref 8080 in
+  Arg.parse
+    ["-p", Arg.Set_int port, " Listening port number (8080 by default)"]
+    ignore
+    "Echoes POST requests. Runs forever.";
+  main !port
+;;

httpaf-lwt-unix.opam

@@ -20,4 +20,5 @@ depends: [
   "httpaf-lwt"
   "lwt"
 ]
+depopts: ["tls" "lwt_ssl"]
 synopsis: "Lwt + Unix support for http/af"

lwt-unix/dune

@@ -1,6 +1,37 @@
+(* -*- tuareg -*- *)
+(* This was inspired by `conduit-lwt-unix`'s dune file *)
+
+let v ~ssl ~tls () =
+  let ssl, ssl_d =
+    if ssl then "ssl_io_real", "lwt_ssl "
+    else "ssl_io_dummy", ""
+  in
+  let tls, tls_d =
+    if tls then "tls_io_real", "tls.lwt "
+    else "tls_io_dummy", ""
+  in
+  Printf.sprintf {|
+(rule (copy %s.ml ssl_io.ml))
+(rule (copy %s.ml tls_io.ml))
+
 (library
  (name httpaf_lwt_unix)
  (public_name httpaf-lwt-unix)
- (libraries faraday-lwt-unix httpaf httpaf-lwt lwt.unix)
+ (libraries faraday-lwt-unix httpaf httpaf-lwt lwt.unix %s%s)
+ (modules httpaf_lwt_unix tls_io ssl_io)
  (flags
   (:standard -safe-string)))
+|} ssl tls ssl_d tls_d
+
+let main () =
+  let is_installed s = Printf.kprintf Sys.command "ocamlfind query %s" s = 0 in
+  let ssl = is_installed "lwt_ssl" in
+  let tls = is_installed "tls.lwt" in
+  Printf.printf
+    "Configuration\n\
+    \  ssl    : %b\n\
+    \  tls    : %b\n%!"
+    ssl tls;
+  v ~ssl ~tls ()
+
+let () = Jbuild_plugin.V1.send @@ main ()

lwt-unix/httpaf_lwt_unix.ml

@@ -82,6 +82,70 @@ module Io
       Lwt.return_unit
 end
 
-module Server = Httpaf_lwt.Server (Io)
+module Config = Httpaf.Config
+
+module Server = struct
+  include Httpaf_lwt.Server (Io)
+
+  module TLS = struct
+    include Httpaf_lwt.Server (Tls_io.Io)
+
+    let create_connection_handler
+      ?server
+      ?certfile
+      ?keyfile
+      ?(config=Config.default)
+      ~request_handler
+      ~error_handler =
+      let make_tls_server = Tls_io.make_server ?server ?certfile ?keyfile in
+      fun client_addr socket ->
+        make_tls_server socket >>= fun tls_server ->
+        create_connection_handler
+          ~config
+          ~request_handler
+          ~error_handler
+          client_addr
+          (socket, tls_server)
+  end
+
+  module SSL = struct
+    include Httpaf_lwt.Server (Ssl_io.Io)
+
+    let create_connection_handler
+      ?server
+      ?certfile
+      ?keyfile
+      ?(config=Config.default)
+      ~request_handler
+      ~error_handler =
+      let make_ssl_server = Ssl_io.make_server ?server ?certfile ?keyfile in
+      fun client_addr socket ->
+        make_ssl_server socket >>= fun ssl_server ->
+        create_connection_handler
+          ~config
+          ~request_handler
+          ~error_handler
+          client_addr
+          ssl_server
+  end
+end
+
+module Client = struct
+  include Httpaf_lwt.Client (Io)
+
+  module TLS = struct
+    include Httpaf_lwt.Client (Tls_io.Io)
 
-module Client = Httpaf_lwt.Client (Io)
+    let request ?client ?(config=Config.default) socket request_headers ~error_handler ~response_handler =
+      Tls_io.make_client ?client socket >|= fun tls_client ->
+      request ~config (socket, tls_client) request_headers ~error_handler ~response_handler
+  end
+
+  module SSL = struct
+    include Httpaf_lwt.Client (Ssl_io.Io)
+
+    let request ?client ?(config=Config.default) socket request_headers ~error_handler ~response_handler =
+      Ssl_io.make_client ?client socket >|= fun ssl_client ->
+      request ~config ssl_client request_headers ~error_handler ~response_handler
+  end
+end

lwt-unix/httpaf_lwt_unix.mli

@@ -47,15 +47,63 @@ module Server : sig
     -> Unix.sockaddr
     -> Lwt_unix.file_descr
     -> unit Lwt.t
+
+  module TLS : sig
+    val create_connection_handler
+      :  ?server         : Tls_io.server
+      -> ?certfile       : string
+      -> ?keyfile        : string
+      -> ?config         : Config.t
+      -> request_handler : (Unix.sockaddr -> Server_connection.request_handler)
+      -> error_handler   : (Unix.sockaddr -> Server_connection.error_handler)
+      -> Unix.sockaddr
+      -> Lwt_unix.file_descr
+      -> unit Lwt.t
+  end
+
+  module SSL : sig
+    val create_connection_handler
+      :  ?server         : Ssl_io.server
+      -> ?certfile       : string
+      -> ?keyfile        : string
+      -> ?config         : Config.t
+      -> request_handler : (Unix.sockaddr -> Server_connection.request_handler)
+      -> error_handler   : (Unix.sockaddr -> Server_connection.error_handler)
+      -> Unix.sockaddr
+      -> Lwt_unix.file_descr
+      -> unit Lwt.t
+  end
 end
 
 (* For an example, see [examples/lwt_get.ml]. *)
 module Client : sig
   val request
-    :  ?config          : Httpaf.Config.t
+    :  ?config          : Config.t
     -> Lwt_unix.file_descr
     -> Request.t
     -> error_handler    : Client_connection.error_handler
     -> response_handler : Client_connection.response_handler
-    -> [`write] Httpaf.Body.t
+    -> [`write] Body.t
+
+  module TLS : sig
+    val request
+      :  ?client          : Tls_io.client
+      -> ?config          : Config.t
+      -> Lwt_unix.file_descr
+      -> Request.t
+      -> error_handler    : Client_connection.error_handler
+      -> response_handler : Client_connection.response_handler
+      -> [`write] Body.t Lwt.t
+  end
+
+  module SSL : sig
+    val request
+      :  ?client          : Ssl_io.client
+      -> ?config          : Config.t
+      -> Lwt_unix.file_descr
+      -> Request.t
+      -> error_handler    : Client_connection.error_handler
+      -> response_handler : Client_connection.response_handler
+      -> [`write] Body.t Lwt.t
+  end
 end

lwt-unix/ssl_io_dummy.ml

@@ -0,0 +1,64 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2019 António Nuno Monteiro
+ *
+ *  All rights reserved.
+ *
+ *  Redistribution and use in source and binary forms, with or without
+ *  modification, are permitted provided that the following conditions are met:
+ *
+ *  1. Redistributions of source code must retain the above copyright notice,
+ *  this list of conditions and the following disclaimer.
+ *
+ *  2. Redistributions in binary form must reproduce the above copyright
+ *  notice, this list of conditions and the following disclaimer in the
+ *  documentation and/or other materials provided with the distribution.
+ *
+ *  3. Neither the name of the copyright holder nor the names of its
+ *  contributors may be used to endorse or promote products derived from this
+ *  software without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ *  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ *  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ *  ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ *  LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ *  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ *  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ *  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ *  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ *  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ *  POSSIBILITY OF SUCH DAMAGE.
+ *---------------------------------------------------------------------------*)
+
+type nothing = [ `Ssl_not_available ]
+
+module Io :
+  Httpaf_lwt.IO
+    with type socket = Lwt_unix.file_descr * nothing
+     and type addr = Unix.sockaddr = struct
+  type socket = Lwt_unix.file_descr * nothing
+
+  type addr = Unix.sockaddr
+
+  let read _ _bigstring ~off:_ ~len:_ = Lwt.fail_with "Ssl not available"
+
+  let writev _ _iovecs = Lwt.fail_with "Ssl not available"
+
+  let shutdown_send _ = failwith "Ssl not available"
+
+  let shutdown_receive _ = failwith "Ssl not available"
+
+  let close _ = failwith "Ssl not available"
+end
+
+type client = nothing
+
+type server = nothing
+
+let[@ocaml.warning "-21"] make_client ?client:_ =
+  failwith "Ssl not available";
+  fun _socket -> Lwt.fail_with "Ssl not available"
+
+let[@ocaml.warning "-21"] make_server ?server:_ ?certfile:_ ?keyfile:_ =
+  failwith "Ssl not available";
+  fun _socket -> Lwt.fail_with "Ssl not available"