From 5fc1a4c1f4fdf19ae654be87ad7ecdd2a6944472 Mon Sep 17 00:00:00 2001
From: Alexander Diemand <codieplusplus@apax.net>
Date: Thu, 9 Feb 2023 23:26:17 +0100
Subject: [PATCH] create TLS client & server with full set of arguments

Signed-off-by: Alexander Diemand <codieplusplus@apax.net>
---
 lwt-unix/gluten_lwt_unix.ml  |  4 ++++
 lwt-unix/gluten_lwt_unix.mli | 28 ++++++++++++++++++++++++++++
 lwt-unix/tls_io.real.ml      | 30 ++++++++++++++++++++++++++++++
 3 files changed, 62 insertions(+)

diff --git a/lwt-unix/gluten_lwt_unix.ml b/lwt-unix/gluten_lwt_unix.ml
index e1a694d..e201641 100644
--- a/lwt-unix/gluten_lwt_unix.ml
+++ b/lwt-unix/gluten_lwt_unix.ml
@@ -83,6 +83,8 @@ module Server = struct
   module TLS = struct
     include Gluten_lwt.Server (Tls_io.Io)
 
+    let create_full ?ciphers ?version ?signature_algorithms ?reneg ?certificates ?acceptable_cas ?authenticator ?alpn_protocols ?zero_rtt ?ip client_addr socket =
+      Tls_io.make_full_server ?ciphers ?version ?signature_algorithms ?reneg ?certificates ?acceptable_cas ?authenticator ?alpn_protocols ?zero_rtt ?ip client_addr socket
     let create_default ?alpn_protocols ~certfile ~keyfile =
       let make_tls_server =
         Tls_io.make_server ?alpn_protocols ~certfile ~keyfile
@@ -107,6 +109,8 @@ module Client = struct
   module TLS = struct
     include Gluten_lwt.Client (Tls_io.Io)
 
+    let create_full authenticator ?peer_name ?ciphers ?version ?signature_algorithms ?reneg ?certificates ?alpn_protocols ?ip socket =
+      Tls_io.make_full_client authenticator ?peer_name ?ciphers ?version ?signature_algorithms ?reneg ?certificates ?alpn_protocols ?ip socket
     let create_default ?alpn_protocols socket =
       Tls_io.make_client ?alpn_protocols socket
   end
diff --git a/lwt-unix/gluten_lwt_unix.mli b/lwt-unix/gluten_lwt_unix.mli
index b50c88e..d78573d 100644
--- a/lwt-unix/gluten_lwt_unix.mli
+++ b/lwt-unix/gluten_lwt_unix.mli
@@ -42,6 +42,21 @@ module Server : sig
         with type socket = Tls_io.descriptor
          and type addr = Unix.sockaddr
 
+    val create_full
+      :  ?ciphers:Tls.Ciphersuite.ciphersuite list
+      -> ?version:(Tls.Core.tls_version * Tls.Core.tls_version)
+      -> ?signature_algorithms:Tls.Core.signature_algorithm list
+      -> ?reneg:bool
+      -> ?certificates:Tls.Config.own_cert
+      -> ?acceptable_cas:X509.Distinguished_name.t list
+      -> ?authenticator:X509.Authenticator.t
+      -> ?alpn_protocols:string list
+      -> ?zero_rtt:int32
+      -> ?ip:Ipaddr.t
+      -> Unix.sockaddr
+      -> Lwt_unix.file_descr
+      -> socket Lwt.t
+
     val create_default
       :  ?alpn_protocols:string list
       -> certfile:string
@@ -74,6 +89,19 @@ module Client : sig
   module TLS : sig
     include Gluten_lwt.Client with type socket = Tls_io.descriptor
 
+    val create_full
+      :  X509.Authenticator.t
+      -> ?peer_name:[ `host ] Domain_name.t
+      -> ?ciphers:Tls.Ciphersuite.ciphersuite list
+      -> ?version:(Tls.Core.tls_version * Tls.Core.tls_version)
+      -> ?signature_algorithms:Tls.Core.signature_algorithm list
+      -> ?reneg:bool
+      -> ?certificates:Tls.Config.own_cert
+      -> ?alpn_protocols:string list
+      -> ?ip:Ipaddr.t
+      -> Lwt_unix.file_descr
+      -> socket Lwt.t
+
     val create_default
       :  ?alpn_protocols:string list
       -> Lwt_unix.file_descr
diff --git a/lwt-unix/tls_io.real.ml b/lwt-unix/tls_io.real.ml
index f894101..368bc64 100644
--- a/lwt-unix/tls_io.real.ml
+++ b/lwt-unix/tls_io.real.ml
@@ -78,12 +78,42 @@ struct
   let shutdown_receive _tls = ()
 end
 
+let make_full_client authenticator ?peer_name ?ciphers ?version ?signature_algorithms ?reneg ?certificates ?alpn_protocols ?ip socket =
+  let config = Tls.Config.client
+    ~authenticator:authenticator
+    ?peer_name
+    ?ciphers
+    ?version
+    ?signature_algorithms
+    ?reneg
+    ?certificates
+    ?alpn_protocols
+    ?ip
+    () in
+  Tls_lwt.Unix.client_of_fd config socket
+
 let null_auth ?ip:_ ~host:_ _ = Ok None
 
 let make_client ?alpn_protocols socket =
   let config = Tls.Config.client ?alpn_protocols ~authenticator:null_auth () in
   Tls_lwt.Unix.client_of_fd config socket
 
+let make_full_server ?ciphers ?version ?signature_algorithms ?reneg ?certificates ?acceptable_cas ?authenticator ?alpn_protocols ?zero_rtt ?ip _client_addr socket =
+  let config = Tls.Config.server
+    ?ciphers
+    ?version
+    ?signature_algorithms
+    ?reneg
+    ?certificates
+    ?acceptable_cas
+    ?authenticator
+    ?alpn_protocols
+    ?zero_rtt
+    ?ip
+    ()
+  in
+  Tls_lwt.Unix.server_of_fd config socket
+
 let make_server ?alpn_protocols ~certfile ~keyfile socket =
   X509_lwt.private_of_pems ~cert:certfile ~priv_key:keyfile
   >>= fun certificate ->