diff options
| author | Clombrong <cromblong@egregore.fun> | 2025-06-28 09:25:05 +0200 |
|---|---|---|
| committer | Clombrong <cromblong@egregore.fun> | 2025-06-28 13:16:00 +0200 |
| commit | f91f1c354da94e21f56a13a0703092bdc06db5ff (patch) | |
| tree | a890171a4702c8468dff76684885d41ab57c919a /portal/tcp | |
| parent | bfc0c0bc1bd41464b3beac4747d4458f1315a2ee (diff) | |
feat(portal_tcp): add upgrade_to_tls function
Diffstat (limited to 'portal/tcp')
| -rw-r--r-- | portal/tcp/dune | 2 | ||||
| -rw-r--r-- | portal/tcp/portal.ml | 13 |
2 files changed, 14 insertions, 1 deletions
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 |