SSL/TLS improvements / fail earlier (#46)

anmonteiro · Apr 10, 2019 · 3a6dab2 · 3a6dab2
1 parent 744907e
commit 3a6dab2
Show file tree

Hide file tree

Showing 8 changed files with 68 additions and 46 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -17,6 +17,11 @@ Unreleased
 - h2: in the client implementation, call the stream level error handler when
   receiving an `RST_STREAM` frame
   ([#42](https://github.com/anmonteiro/ocaml-h2/pull/42))
+- h2-lwt-unix: fail earlier when setting up a SSL/TLS server without the
+  depopts being available
+  ([#46](https://github.com/anmonteiro/ocaml-h2/pull/46))
+- h2-lwt-unix: improve the default ALPN negotiation mechanism in the SSL
+  binding ([#46](https://github.com/anmonteiro/ocaml-h2/pull/46))
 
 0.2.0 2019-04-06
 --------------

diff --git a/esy.lock/index.json b/esy.lock/index.json
@@ -1004,8 +1004,8 @@
       ],
       "devDependencies": [ "ocaml@4.7.1004@d41d8cd9" ]
     },
-    "@opam/octavius@opam:1.2.0@4840f5a0": {
-      "id": "@opam/octavius@opam:1.2.0@4840f5a0",
+    "@opam/octavius@opam:1.2.0@70279919": {
+      "id": "@opam/octavius@opam:1.2.0@70279919",
       "name": "@opam/octavius",
       "version": "opam:1.2.0",
       "source": {
@@ -1119,7 +1119,7 @@
       "dependencies": [
         "ocaml@4.7.1004@d41d8cd9", "@opam/uutf@opam:1.0.2@4440868f",
         "@opam/stdio@opam:v0.12.0@1d18adcb",
-        "@opam/octavius@opam:1.2.0@4840f5a0",
+        "@opam/octavius@opam:1.2.0@70279919",
         "@opam/ocaml-migrate-parsetree@opam:1.2.0@23e55f71",
         "@opam/fpath@opam:0.7.2@45477b93", "@opam/dune@opam:1.9.0@a7408d38",
         "@opam/cmdliner@opam:1.0.3@96d31520",
@@ -1130,7 +1130,7 @@
       "devDependencies": [
         "ocaml@4.7.1004@d41d8cd9", "@opam/uutf@opam:1.0.2@4440868f",
         "@opam/stdio@opam:v0.12.0@1d18adcb",
-        "@opam/octavius@opam:1.2.0@4840f5a0",
+        "@opam/octavius@opam:1.2.0@70279919",
         "@opam/ocaml-migrate-parsetree@opam:1.2.0@23e55f71",
         "@opam/fpath@opam:0.7.2@45477b93",
         "@opam/cmdliner@opam:1.0.3@96d31520",

diff --git a/esy.lock/opam/octavius.1.2.0/opam b/esy.lock/opam/octavius.1.2.0/opam
@@ -11,7 +11,7 @@ bug-reports: "https://github.com/ocaml-doc/octavius/issues"
 tags: ["doc" "ocamldoc" "org:ocaml-doc"]
 
 depends: [
-  "ocaml" {>= "4.03.0"}
+  "ocaml" {>= "4.03.0" & < "4.08.0"}
   "ocamlfind" {build}
   "jbuilder" {build & >= "1.0+beta7"}
 ]

diff --git a/lwt-unix/h2_lwt_unix.ml b/lwt-unix/h2_lwt_unix.ml
@@ -116,17 +116,16 @@ module Server = struct
         ?(config = Config.default)
         ~request_handler
         ~error_handler
-        client_addr
-        socket
       =
-      Tls_io.make_server ?server ?certfile ?keyfile socket
-      >>= fun tls_server ->
-      create_connection_handler
-        ~config
-        ~request_handler
-        ~error_handler
-        client_addr
-        (socket, tls_server)
+      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
@@ -139,17 +138,16 @@ module Server = struct
         ?(config = Config.default)
         ~request_handler
         ~error_handler
-        client_addr
-        socket
       =
-      Ssl_io.make_server ?server ?certfile ?keyfile socket
-      >>= fun ssl_server ->
-      create_connection_handler
-        ~config
-        ~request_handler
-        ~error_handler
-        client_addr
-        ssl_server
+      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
 
@@ -160,23 +158,27 @@ module Client = struct
     include H2_lwt.Client (Tls_io.Io)
 
     let create_connection
-        ?client ?(config = Config.default) ?push_handler ~error_handler socket
+        ?client ?(config = Config.default) ?push_handler ~error_handler
       =
-      Tls_io.make_client ?client socket >>= fun tls_client ->
-      create_connection
-        ~config
-        ?push_handler
-        ~error_handler
-        (socket, tls_client)
+      let make_tls_client = Tls_io.make_client ?client in
+      fun socket ->
+        make_tls_client socket >>= fun tls_client ->
+        create_connection
+          ~config
+          ?push_handler
+          ~error_handler
+          (socket, tls_client)
   end
 
   module SSL = struct
     include H2_lwt.Client (Ssl_io.Io)
 
     let create_connection
-        ?client ?(config = Config.default) ?push_handler ~error_handler socket
+        ?client ?(config = Config.default) ?push_handler ~error_handler
       =
-      Ssl_io.make_client ?client socket >>= fun ssl_client ->
-      create_connection ~config ?push_handler ~error_handler ssl_client
+      let make_ssl_client = Ssl_io.make_client ?client in
+      fun socket ->
+        make_ssl_client socket >>= fun ssl_client ->
+        create_connection ~config ?push_handler ~error_handler ssl_client
   end
 end
diff --git a/lwt-unix/ssl_io_dummy.ml b/lwt-unix/ssl_io_dummy.ml
@@ -57,7 +57,10 @@ type client = nothing
 
 type server = nothing
 
-let make_client ?client:_ _socket = Lwt.fail_with "Ssl not available"
+let[@ocaml.warning "-21"] make_client ?client:_ =
+  failwith "Ssl not available";
+  fun _socket -> Lwt.fail_with "Ssl not available"
 
-let make_server ?server:_ ?certfile:_ ?keyfile:_ _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"
diff --git a/lwt-unix/ssl_io_real.ml b/lwt-unix/ssl_io_real.ml
@@ -126,7 +126,8 @@ let make_client ?client socket =
     Ssl.honor_cipher_order client_ctx;
     Lwt_ssl.ssl_connect socket client_ctx
 
-(* TODO: this needs error handling or it'll crash the server *)
+(* This function does not perform error handling and will therefore crash a
+ * server in case e.g. the handshake fails. *)
 let make_server ?server ?certfile ?keyfile socket =
   match server, certfile, keyfile with
   | Some server, _, _ ->
@@ -135,11 +136,17 @@ let make_server ?server ?certfile ?keyfile socket =
     let server_ctx = Ssl.create_context Ssl.TLSv1_3 Ssl.Server_context in
     Ssl.disable_protocols server_ctx [ Ssl.SSLv23 ];
     Ssl.use_certificate server_ctx cert priv_key;
-    (* let rec first_match l1 = function | [] -> None | x::_ when List.mem x l1
-       -> Some x | _::xs -> first_match l1 xs in *)
+    let rec first_match l1 = function
+      | [] ->
+        None
+      | x :: _ when List.mem x l1 ->
+        Some x
+      | _ :: xs ->
+        first_match l1 xs
+    in
     Ssl.set_context_alpn_protos server_ctx [ "h2" ];
-    (* Ssl.set_context_alpn_select_callback server_ctx (fun client_protos ->
-       first_match client_protos ["h2"] ); *)
+    Ssl.set_context_alpn_select_callback server_ctx (fun client_protos ->
+        first_match client_protos [ "h2" ]);
     Lwt_ssl.ssl_accept socket server_ctx
   | _ ->
     Lwt.fail

diff --git a/lwt-unix/tls_io_dummy.ml b/lwt-unix/tls_io_dummy.ml
@@ -57,7 +57,10 @@ type client = nothing
 
 type server = nothing
 
-let make_client ?client:_ _socket = Lwt.return `Tls_not_available
+let[@ocaml.warning "-21"] make_client ?client:_ =
+  failwith "TLS not available";
+  fun _socket -> Lwt.return `Tls_not_available
 
-let make_server ?server:_ ?certfile:_ ?keyfile:_ _socket =
-  Lwt.return `Tls_not_available
+let[@ocaml.warning "-21"] make_server ?server:_ ?certfile:_ ?keyfile:_ =
+  failwith "TLS not available";
+  fun _socket -> Lwt.fail_with "TLS not available"
diff --git a/lwt-unix/tls_io_real.ml b/lwt-unix/tls_io_real.ml
@@ -120,6 +120,8 @@ let make_client ?client socket =
     in
     Tls_lwt.Unix.client_of_fd config socket
 
+(* This function does not perform error handling and will therefore crash a
+ * server in case e.g. the handshake fails. *)
 let make_server ?server ?certfile ?keyfile socket =
   let server =
     match server, certfile, keyfile with