require tls 1.3, avoid renegotiation (client certificate is now already encrypted)

albatross.opam

@@ -22,7 +22,7 @@ depends: [
   "astring"
   "jsonm"
   "x509" {>= "0.11.0"}
-  "tls" {>= "0.11.0"}
+  "tls" {>= "0.12.0"}
   "mirage-crypto-pk"
   "mirage-crypto-rng"
   "asn1-combinators" {>= "0.2.0"}

tls/albatross_tls_common.ml

@@ -9,26 +9,11 @@ let tls_config cacert cert priv_key =
   X509_lwt.certs_of_pem cacert >>= (function
       | [ ca ] -> Lwt.return ca
       | _ -> Lwt.fail_with "expect single ca as cacert") >|= fun ca ->
-  (Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2)
-          ~reneg:true ~certificates:(`Single cert) ()),
-   ca)
-
-let client_auth ca tls =
-  let authenticator =
   let time () = Some (Ptime_clock.now ()) in
-    X509.Authenticator.chain_of_trust ~time (* ~crls:!state.Vmm_engine.crls *) [ca]
+  Tls.Config.server
-  in
+    ~version:(`TLS_1_3, `TLS_1_3)
-  Lwt.catch
+    ~authenticator:(X509.Authenticator.chain_of_trust ~time [ca])
-    (fun () -> Tls_lwt.Unix.reneg ~authenticator tls)
+    ~certificates:(`Single cert) ()
-    (fun e ->
-       (match e with
-        | Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a))
-        | Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f))
-        | exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ;
-       Lwt.fail e) >>= fun () ->
-  (match Tls_lwt.Unix.epoch tls with
-   | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain
-   | `Error -> Lwt.fail_with "error while getting epoch")
 
 let read version fd tls =
   (* now we busy read and process output *)
@@ -51,9 +36,11 @@ let process fd =
     Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire (hdr, pay));
     pay
 
-let handle ca tls =
+let handle tls =
-  client_auth ca tls >>= fun chain ->
+  match Tls_lwt.Unix.epoch tls with
-  match Vmm_tls.handle chain with
+  | `Error -> Lwt.fail_with "error while getting epoch"
+  | `Ok epoch ->
+    match Vmm_tls.handle epoch.Tls.Core.peer_certificate_chain with
     | Error `Msg msg ->
       Logs.err (fun m -> m "failed to handle TLS connection %s" msg);
       Lwt.return_unit

tls/albatross_tls_endpoint.ml

@@ -19,7 +19,7 @@ let jump _ cacert cert priv_key port tmpdir =
   Albatross_cli.set_tmpdir tmpdir;
   Lwt_main.run
     (server_socket port >>= fun socket ->
-     tls_config cacert cert priv_key >>= fun (config, ca) ->
+     tls_config cacert cert priv_key >>= fun config ->
      let rec loop () =
        Lwt.catch (fun () ->
            Lwt_unix.accept socket >>= fun (fd, _addr) ->
@@ -31,7 +31,7 @@ let jump _ cacert cert priv_key port tmpdir =
            Lwt.async (fun () ->
                Lwt.catch
                  (fun () ->
-                    handle ca t >>= fun () ->
+                    handle t >>= fun () ->
                     Vmm_tls_lwt.close t)
                  (fun e ->
                     Logs.err (fun m -> m "error while handle() %s" (Printexc.to_string e)) ;

tls/albatross_tls_inetd.ml

@@ -8,7 +8,7 @@ let jump cacert cert priv_key tmpdir =
   Mirage_crypto_rng_unix.initialize ();
   Albatross_cli.set_tmpdir tmpdir;
   Lwt_main.run
-    (tls_config cacert cert priv_key >>= fun (config, ca) ->
+    (tls_config cacert cert priv_key >>= fun config ->
      let fd = Lwt_unix.of_unix_file_descr Unix.stdin in
      Lwt.catch
        (fun () -> Tls_lwt.Unix.server_of_fd config fd)
@@ -17,7 +17,7 @@ let jump cacert cert priv_key tmpdir =
           Lwt.fail exn) >>= fun t ->
      Lwt.catch
        (fun () ->
-          handle ca t >>= fun () ->
+          handle t >>= fun () ->
           Vmm_tls_lwt.close t)
        (fun e ->
           Logs.err (fun m -> m "error while handle() %s" (Printexc.to_string e)) ;