feat(portal_tcp): add upgrade_to_tls function

1 files changed, 13 insertions, 0 deletions

diff --git a/portal/tcp/portal.ml b/portal/tcp/portal.ml
index a817645..47f8c04 100644
--- a/portal/tcp/portal.ml
+++ b/portal/tcp/portal.ml
@@ -173,3 +173,16 @@ let connect (domain : string) : t Lwt.t =
   let _socket = Plain s
   in let stream, push = socket_to_stream _socket
      in {stream; push; _socket=_socket}
+
+(** [upgrade_to_tls fd] returns a promise to an [Tls_lwt.Unix.t] socket that wraps
+    [fd] with STARTTLS. *)
+let upgrade_to_tls (fd : Lwt_unix.file_descr) : Tls_lwt.Unix.t Lwt.t =
+  let handle_msg = function
+    | Ok thing -> thing
+    | Error `Msg m -> failwith m
+  in
+  try
+    let authenticator = Ca_certs.authenticator () |> handle_msg in
+    let tls_config = Tls.Config.client ~authenticator () |> handle_msg in
+    Tls_lwt.Unix.client_of_fd tls_config fd
+  with Failure msg -> Lwt.fail_with msg