diff options
Diffstat (limited to 'portal')
| -rw-r--r-- | portal/tcp/dune | 2 | ||||
| -rw-r--r-- | portal/tcp/portal.ml | 25 |
2 files changed, 25 insertions, 2 deletions
diff --git a/portal/tcp/dune b/portal/tcp/dune index 97c1f62..971ed81 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) + (libraries lwt lwt.unix markup markup-lwt tls tls-lwt) (preprocess (pps lwt_ppx))) diff --git a/portal/tcp/portal.ml b/portal/tcp/portal.ml index 18e08b9..e1b76b1 100644 --- a/portal/tcp/portal.ml +++ b/portal/tcp/portal.ml @@ -2,7 +2,7 @@ open Lwt.Syntax open Lwt.Infix open Markup -type socket = Plain of Lwt_unix.file_descr +type socket = Plain of Lwt_unix.file_descr | Tls of Tls_lwt.Unix.t type t = { mutable stream : (signal, async) stream; @@ -90,8 +90,23 @@ let socket_to_stream (sock : socket) = Lwt_bytes.proxy recv_buffer 0 len |> Lwt_bytes.to_string |> Lwt.return_some + and from_tls t () = + let* len = + try%lwt Tls_lwt.Unix.read_bytes t recv_buffer 0 4096 + with + | Unix.Unix_error (Unix.ECONNRESET, _, _) + | Unix.Unix_error (Unix.EPIPE, _, _) + | End_of_file -> Lwt.return 0 + | exn -> Lwt.fail exn + in match len with + | 0 -> Lwt.return_none + | len -> + Lwt_bytes.proxy recv_buffer 0 len + |> Lwt_bytes.to_string + |> Lwt.return_some in let from_socket = match sock with | Plain p -> from_plain p + | Tls t -> from_tls t in Lwt_stream.from from_socket in let send_buffer = Lwt_bytes.create 1024 in @@ -102,9 +117,16 @@ let socket_to_stream (sock : socket) = | Unix.Unix_error (Unix.ECONNRESET, _, _) | Unix.Unix_error (Unix.EPIPE, _, _) -> Lwt.return_unit | exn -> Lwt.fail exn + and flush_tls t len = + try%lwt Tls_lwt.Unix.write_bytes t send_buffer 0 len + with + | Unix.Unix_error (Unix.ECONNRESET, _, _) + | Unix.Unix_error (Unix.EPIPE, _, _) -> Lwt.return_unit + | exn -> Lwt.fail exn in let flush_socket = match sock with | Plain p -> flush_plain p + | Tls t -> flush_tls t in let flush_buffer () = let len = !send_pos in @@ -124,6 +146,7 @@ let socket_to_stream (sock : socket) = in let close_sock = match sock with | Plain p -> (fun () -> Lwt_unix.close p) + | Tls t -> (fun () -> Tls_lwt.Unix.close t) in let outbound_stream, outbound_push = Lwt_stream.create () in let push = function |