Added Server.TLS module mirroring SSL pattern and fixed ALPN.

async/h2_async.ml

@@ -101,6 +101,50 @@ module Server = struct
           client_addr
           ssl_server
   end
+
+  module TLS = struct
+    let create_connection_handler
+          ?(config = H2.Config.default)
+          ~request_handler
+          ~error_handler
+          client_addr
+          socket
+      =
+      let connection =
+        H2.Server_connection.create
+          ~config
+          ~error_handler:(error_handler client_addr)
+          (request_handler client_addr)
+      in
+      Gluten_async.Server.TLS.create_connection_handler
+        ~read_buffer_size:config.read_buffer_size
+        ~protocol:(module H2.Server_connection)
+        connection
+        client_addr
+        socket
+
+    let create_connection_handler_with_default
+          ~certfile
+          ~keyfile
+          ?config
+          ~request_handler
+          ~error_handler
+      =
+      let make_tls_server =
+        Gluten_async.Server.TLS.create_default
+          ~alpn_protocols:[ "h2" ]
+          ~certfile
+          ~keyfile
+      in
+      fun client_addr socket ->
+        make_tls_server client_addr socket >>= fun tls_server ->
+        create_connection_handler
+          ?config
+          ~request_handler
+          ~error_handler
+          client_addr
+          tls_server
+  end
 end
 
 module Client = struct
@@ -168,7 +212,7 @@ module Client = struct
           ~error_handler
           socket
       =
-      Client_runtime.create_default ~alpn_protocols:[ "http/1.1" ] socket
+      Client_runtime.create_default ~alpn_protocols:[ "h2" ] socket
       >>= fun ssl_client ->
       create_connection ~config ?push_handler ~error_handler ssl_client
 
@@ -213,7 +257,7 @@ module Client = struct
           where_to_connect
       =
       Client_runtime.create_default
-        ~alpn_protocols:[ "http/1.1" ]
+        ~alpn_protocols:[ "h2" ]
         socket
         where_to_connect
       >>= fun tls_client ->

async/h2_async.mli

@@ -55,6 +55,22 @@ module Server : sig
       -> ([ `Active ], 'a) Socket.t
       -> unit Deferred.t
   end
+
+  module TLS : sig
+    include
+      H2_async_intf.Server
+      with type 'a socket := 'a Gluten_async.Server.TLS.socket
+
+    val create_connection_handler_with_default :
+       certfile:string
+      -> keyfile:string
+      -> ?config:Config.t
+      -> request_handler:('a -> Server_connection.request_handler)
+      -> error_handler:('a -> Server_connection.error_handler)
+      -> (Socket.Address.Inet.t as 'a)
+      -> ([ `Active ], 'a) Socket.t
+      -> unit Deferred.t
+  end
 end
 
 module Client : sig

examples/async/async_tls_https_echo_server_post.ml

@@ -0,0 +1,76 @@
+open Core
+open Async
+open H2
+open H2_async
+
+let error_handler _ ?request:_ error start_response =
+  let response_body = start_response Headers.empty in
+  (match error with
+  | `Exn exn ->
+    Body.Writer.write_string response_body (Exn.to_string exn);
+    Body.Writer.write_string response_body "\n"
+  | #Status.standard as error ->
+    Body.Writer.write_string response_body (Status.default_reason_phrase error));
+  Body.Writer.close response_body
+
+let request_handler sock reqd =
+  eprintf "Received request from %s\n%!" (Socket.Address.Inet.to_string sock);
+  match Reqd.request reqd with
+  | { Request.meth = `POST; headers; _ } ->
+    let response =
+      let content_type =
+        match Headers.get headers "content-type" with
+        | None -> "application/octet-stream"
+        | Some x -> x
+      in
+      Response.create
+        ~headers:(Headers.of_list [ "content-type", content_type ])
+        `OK
+    in
+    let request_body = Reqd.request_body reqd in
+    let response_body = Reqd.respond_with_streaming reqd response in
+    let rec on_read buffer ~off ~len =
+      Body.Writer.write_bigstring response_body buffer ~off ~len;
+      Body.Reader.schedule_read request_body ~on_eof ~on_read
+    and on_eof () =
+      print_endline "eof";
+      Body.Writer.close response_body
+    in
+    Body.Reader.schedule_read (Reqd.request_body reqd) ~on_eof ~on_read
+  | _ -> Reqd.respond_with_string reqd (Response.create `Method_not_allowed) ""
+
+let main port max_accepts_per_batch () =
+  let where_to_listen =
+    Tcp.Where_to_listen.bind_to
+      Tcp.Bind_to_address.Localhost
+      (Tcp.Bind_to_port.On_port port)
+  in
+  Tcp.(
+    Server.create_sock
+      ~on_handler_error:`Ignore
+      ~backlog:10_000
+      ~max_connections:10_000
+      ~max_accepts_per_batch
+      where_to_listen)
+    (Server.TLS.create_connection_handler_with_default
+       ~certfile:"./certificates/server.pem"
+       ~keyfile:"./certificates/server.key"
+       ~request_handler
+       ~error_handler)
+  >>= fun _server -> Deferred.never ()
+
+let () =
+  Command.async_spec
+    ~summary:"Start a hello world tls-async server"
+    Command.Spec.(
+      empty
+      +> flag
+           "-port"
+           (optional_with_default 8080 int)
+           ~doc:"int Source port to listen on"
+      +> flag
+           "-a"
+           (optional_with_default 1 int)
+           ~doc:"int Maximum accepts per batch")
+    main
+  |> Command_unix.run

examples/async/dune

@@ -1,6 +1,8 @@
 (executables
  (libraries h2 h2-async async core core_unix.command_unix)
- (names async_ssl_https_echo_server_post async_tls_https_echo_client_post))
+ (names async_ssl_https_echo_server_post
+        async_tls_https_echo_client_post
+        async_tls_https_echo_server_post))
 
 (alias
  (name examples)