From f91f1c354da94e21f56a13a0703092bdc06db5ff Mon Sep 17 00:00:00 2001
From: Clombrong <cromblong@egregore.fun>
Date: Sat, 28 Jun 2025 09:25:05 +0200
Subject: feat(portal_tcp): add upgrade_to_tls function

---
 portal/tcp/dune      |  2 +-
 portal/tcp/portal.ml | 13 +++++++++++++
 2 files changed, 14 insertions(+), 1 deletion(-)

(limited to 'portal/tcp')

diff --git a/portal/tcp/dune b/portal/tcp/dune
index 971ed81..42f4fb4 100644
--- a/portal/tcp/dune
+++ b/portal/tcp/dune
@@ -2,5 +2,5 @@
  (name portal_tcp)
  (implements portal)
  (public_name portal-tcp)
- (libraries lwt lwt.unix markup markup-lwt tls tls-lwt)
+ (libraries lwt lwt.unix markup markup-lwt tls tls-lwt ca-certs)
  (preprocess (pps lwt_ppx)))
diff --git a/portal/tcp/portal.ml b/portal/tcp/portal.ml
index e1b76b1..5b329b8 100644
--- a/portal/tcp/portal.ml
+++ b/portal/tcp/portal.ml
@@ -172,3 +172,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
-- 
cgit v1.2.3