From 7a1d1525d6964aaa777e555509b13e96dcba65b1 Mon Sep 17 00:00:00 2001
From: Tim McGilchrist <timmcgil@gmail.com>
Date: Thu, 19 Mar 2026 17:46:17 +1100
Subject: [PATCH] Add Async TLS support.

Implemented make_server using Tls_async.upgrade_server_handler for
per-connection TLS upgrade, added reader_writer_of_sock helper, fixed
make_default_client for tls 2.0.3 result type. Reused the existing
commented out signature and module for Server.TLS
---
 async/gluten_async.ml  | 12 +++++---
 async/gluten_async.mli | 15 ++++++---
 async/tls_io.real.ml   | 69 +++++++++++++++++++++++++++++++-----------
 3 files changed, 70 insertions(+), 26 deletions(-)

diff --git a/async/gluten_async.ml b/async/gluten_async.ml
index ac2872f..3c8597c 100644
--- a/async/gluten_async.ml
+++ b/async/gluten_async.ml
@@ -208,11 +208,15 @@ module Server = struct
       fun _client_addr socket -> make_ssl_server socket
   end
 
-  (* module TLS = struct include Make_server (Tls_io.Io)
+  module TLS = struct
+    include Make_server (Tls_io.Io)
 
-     let create_default ?alpn_protocols ~certfile ~keyfile = let make_ssl_server
-     = Ssl_io.make_server ?alpn_protocols ~certfile ~keyfile in fun _client_addr
-     socket -> make_ssl_server socket end *)
+    let create_default ?alpn_protocols ~certfile ~keyfile =
+      let make_tls_server =
+        Tls_io.make_server ?alpn_protocols ~certfile ~keyfile
+      in
+      fun _client_addr socket -> make_tls_server socket
+  end
 end
 
 module Make_client (Io : Gluten_async_intf.IO) = struct
diff --git a/async/gluten_async.mli b/async/gluten_async.mli
index c66eb89..1c21f7a 100644
--- a/async/gluten_async.mli
+++ b/async/gluten_async.mli
@@ -51,12 +51,17 @@ module Server : sig
       -> 'a socket Deferred.t
   end
 
-  (* module TLS : sig include Gluten_async_intf.Server with type socket =
-     Tls_io.descriptor and type addr := Socket.Address.t
+  module TLS : sig
+    include Gluten_async_intf.Server with type 'a socket = 'a Tls_io.descriptor
 
-     val create_default : ?alpn_protocols:string list -> certfile:string ->
-     keyfile:string -> 'b -> ([ `Active ], 'a) Socket.t -> socket Deferred.t
-     end *)
+    val create_default :
+       ?alpn_protocols:string list
+      -> certfile:string
+      -> keyfile:string
+      -> ([< Socket.Address.t ] as 'a)
+      -> ([ `Active ], 'a) Socket.t
+      -> 'a socket Deferred.t
+  end
 end
 
 module Client : sig
diff --git a/async/tls_io.real.ml b/async/tls_io.real.ml
index f86e16a..223c5e8 100644
--- a/async/tls_io.real.ml
+++ b/async/tls_io.real.ml
@@ -112,25 +112,60 @@ let make_default_client :
  fun ?alpn_protocols ?host socket where_to_connect ->
   let config =
     Tls.Config.client ?alpn_protocols ~authenticator:null_auth ()
-    |> Result.ok
-    |> Option.value_exn
+    |> Result.map_error ~f:(fun (`Msg msg) -> msg)
+    |> Result.ok_or_failwith
   in
   connect ~config ~socket ~where_to_connect ~host
 
-(* let make_server ?alpn_protocols ~certfile ~keyfile _socket =
-   Tls_async.X509_async.Certificate.of_pem_file certfile |>
-   Deferred.Or_error.ok_exn >>= fun certificate ->
-   Tls_async.X509_async.Private_key.of_pem_file keyfile |>
-   Deferred.Or_error.ok_exn >>= fun priv_key -> let _config = Tls.Config.(
-   server ?alpn_protocols ~version:(`TLS_1_0, `TLS_1_2) ~certificates:(`Single
-   (certificate, priv_key)) ~ciphers:Ciphers.supported ()) in failwithf
-   "Gluten_async.TLS.make_server: unimplemented" () *)
+let reader_writer_of_sock
+    ?buffer_age_limit
+    ?reader_buffer_size
+    ?writer_buffer_size
+    s
+  =
+  let fd = Socket.fd s in
+  ( Reader.create ?buf_len:reader_buffer_size fd
+  , Writer.create ?buffer_age_limit ?buf_len:writer_buffer_size fd )
 
-let[@ocaml.warning "-21"] make_server
-    ?alpn_protocols:_
-    ~certfile:_
-    ~keyfile:_
-    _socket
+let make_server :
+     ?alpn_protocols:string list
+  -> certfile:string
+  -> keyfile:string
+  -> ([ `Active ], ([< Socket.Address.t ] as 'a)) Socket.t
+  -> 'a descriptor Deferred.t
   =
-  failwith "Tls_async Server not implemented";
-  fun _socket -> Core.failwith "Tls_async Server not implemented"
+ fun ?alpn_protocols ~certfile ~keyfile socket ->
+  let outer_reader, outer_writer = reader_writer_of_sock socket in
+  Tls_async.X509_async.Certificate.of_pem_file certfile
+  |> Deferred.Or_error.ok_exn
+  >>= fun certificate ->
+  Tls_async.X509_async.Private_key.of_pem_file keyfile
+  |> Deferred.Or_error.ok_exn
+  >>= fun priv_key ->
+  let config =
+    Tls.Config.server
+      ?alpn_protocols
+      ~certificates:(`Single (certificate, priv_key))
+      ()
+    |> Result.map_error ~f:(fun (`Msg msg) -> msg)
+    |> Result.ok_or_failwith
+  in
+  let descriptor_ivar = Ivar.create () in
+  don't_wait_for
+    (Tls_async.upgrade_server_handler
+       ~config
+       (fun _session inner_reader inner_writer ->
+         let closed = Ivar.create () in
+         don't_wait_for
+           (Deferred.all_unit
+              [ Reader.close_finished inner_reader
+              ; Writer.close_finished inner_writer
+              ]
+           >>| fun () ->
+           (Ivar.fill [@ocaml.alert "-deprecated"]) closed ());
+         (Ivar.fill [@ocaml.alert "-deprecated"]) descriptor_ivar
+           (inner_reader, inner_writer, Ivar.read closed);
+         Ivar.read closed)
+       outer_reader
+       outer_writer);
+  Ivar.read descriptor_ivar