Tls: in Config.{client,server} avoid raising an exception

Instead, a result value is returned. Addresses mirleft#411

Author: hannesm

async/examples/test_client.ml

@@ -2,7 +2,9 @@ open! Core
 open! Async
 open Deferred.Or_error.Let_syntax
 
-let config = Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) ()
+let config = match Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) () with
+  | Ok cfg -> cfg
+  | Error `Msg msg -> invalid_arg msg
 
 let test_client () =
   let host = "127.0.0.1" in

async/examples/test_server.ml

@@ -12,12 +12,15 @@ let serve_tls ~low_level port handler =
     Tls_async.X509_async.Private_key.of_pem_file server_key |> Deferred.Or_error.ok_exn
   in
   let config =
-    Tls.Config.(
-      server
-        ~version:(`TLS_1_0, `TLS_1_2)
-        ~certificates:(`Single (certificate, priv_key))
-        ~ciphers:Ciphers.supported
-        ())
+    match Tls.Config.(
+        server
+          ~version:(`TLS_1_0, `TLS_1_2)
+          ~certificates:(`Single (certificate, priv_key))
+          ~ciphers:Ciphers.supported
+          ())
+    with
+    | Ok cfg -> cfg
+    | Error `Msg msg -> invalid_arg msg
   in
   let where_to_listen = Tcp.Where_to_listen.of_port port in
   let on_handler_error = `Ignore in

bench/speed.ml

@@ -62,11 +62,18 @@ type state =
   ; client_out : int
   ; direction : [ `To_server | `To_client ] }
 
+let get_ok = function
+  | Ok cfg -> cfg
+  | Error `Msg msg -> invalid_arg msg
+
 let make ?groups ~cipher ~digest ~key version direction =
   let cert = cert ~digest ~key in
-  let client_cfg = Tls.Config.client ?groups ~version:(version, version)
-    ~ciphers:[ cipher ] ~authenticator ()
-  and server_cfg = Tls.Config.server ~certificates:(`Single ([ cert ], key)) () in
+  let client_cfg =
+    get_ok (Tls.Config.client ?groups ~version:(version, version)
+                 ~ciphers:[ cipher ] ~authenticator ())
+  and server_cfg =
+    get_ok (Tls.Config.server ~certificates:(`Single ([ cert ], key)) ())
+  in
   let client_state, client_out = Tls.Engine.client client_cfg
   and server_state = Tls.Engine.server server_cfg in
   { flow= To_server (client_state, server_state, Some client_out)

lib/config.ml

@@ -56,8 +56,7 @@ type server
 (** {1 Constructors} *)
 
 (** [client authenticator ?peer_name ?ciphers ?version ?hashes ?reneg ?certificates ?alpn_protocols] is
-    [client] configuration with the given parameters.
-    @raise Invalid_argument if the configuration is invalid *)
+    [client] configuration with the given parameters. Returns an error if the configuration is invalid. *)
 val client :
   authenticator : X509.Authenticator.t ->
   ?peer_name : [ `host ] Domain_name.t ->
@@ -72,11 +71,10 @@ val client :
   ?alpn_protocols : string list ->
   ?groups : group list ->
   ?ip : Ipaddr.t ->
-  unit -> client
+  unit -> (client, [> `Msg of string ]) result
 
 (** [server ?ciphers ?version ?hashes ?reneg ?certificates ?acceptable_cas ?authenticator ?alpn_protocols]
-    is [server] configuration with the given parameters.
-    @raise Invalid_argument if the configuration is invalid *)
+    is [server] configuration with the given parameters. Returns an error if the configuration is invalid. *)
 val server :
   ?ciphers : Ciphersuite.ciphersuite list ->
   ?version : tls_version * tls_version ->
@@ -91,7 +89,7 @@ val server :
   ?groups : group list ->
   ?zero_rtt : int32 ->
   ?ip : Ipaddr.t ->
-  unit -> server
+  unit -> (server, [> `Msg of string ]) result
 
 (** [peer client name] is [client] with [name] as [peer_name] *)
 val peer : client -> [ `host ] Domain_name.t -> client

lib/config.mli

@@ -6,7 +6,7 @@
 (executable
  (name starttls_server)
  (modules starttls_server)
- (libraries tls-lwt lwt.unix))
+ (libraries tls-lwt lwt.unix ex_common))
 
 (executable
  (name echo_server)

lwt/examples/dune

@@ -34,7 +34,7 @@ let echo_client ?ca hostname port =
     ~cert:server_cert
     ~priv_key:server_key >>= fun certificate ->
   Tls_lwt.connect_ext
-    Tls.Config.(client ~authenticator ~cached_session ~certificates:(`Single certificate) ~ciphers:Ciphers.supported ())
+    (get_ok Tls.Config.(client ~authenticator ~cached_session ~certificates:(`Single certificate) ~ciphers:Ciphers.supported ()))
     (hostname, port) >>= fun (ic, oc) ->
   Lwt.join [
     lines ic    |> Lwt_stream.iter_s (printf "+ %s\n%!") ;

lwt/examples/echo_client.ml

@@ -7,7 +7,7 @@ let echo_client host port =
   let port = int_of_string port in
   let authenticator = null_auth in
   Tls_lwt.Unix.connect
-    Tls.Config.(client ~authenticator ~alpn_protocols:["http/1.1"; "h2"] ())
+    (get_ok Tls.Config.(client ~authenticator ~alpn_protocols:["http/1.1"; "h2"] ()))
     (host, port) >>= fun t ->
   match Tls_lwt.Unix.epoch t with
   | Error () -> printl "Error"

lwt/examples/echo_client_alpn.ml

@@ -37,7 +37,7 @@ let serve_ssl port callback =
   yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () ->
   let rec loop s =
     let authenticator = null_auth in
-    let config = Tls.Config.server ~version:(`TLS_1_0, `TLS_1_3) ~ciphers:Tls.Config.Ciphers.supported ~reneg:true ~certificates:(`Single cert) ~authenticator () in
+    let config = get_ok (Tls.Config.server ~version:(`TLS_1_0, `TLS_1_3) ~ciphers:Tls.Config.Ciphers.supported ~reneg:true ~certificates:(`Single cert) ~authenticator ()) in
     (Lwt.catch
        (fun () -> Tls_lwt.accept_ext config s >|= fun r -> `R r)
        (function

lwt/examples/echo_server.ml

@@ -46,7 +46,7 @@ let serve_ssl alpn_protocols port callback =
   let ps = string_of_int port in
   yap ~tag ("-> start @ " ^ ps ^ " (use `openssl s_client -connect host:" ^ ps ^ " -alpn <proto>`), available protocols: " ^ String.concat "," alpn_protocols) >>= fun () ->
   let rec loop () =
-    let config = Tls.Config.server ~certificates:(`Single certificate) ~alpn_protocols () in
+    let config = get_ok (Tls.Config.server ~certificates:(`Single certificate) ~alpn_protocols ()) in
     server_s >>= fun s ->
     Tls_lwt.Unix.accept config s >>= fun (t, addr) ->
     yap ~tag "-> connect" >>= fun () ->

lwt/examples/echo_server_alpn.ml

@@ -39,7 +39,7 @@ let serve_ssl port callback =
   let ps = string_of_int port in
   yap ~tag ("-> start @ " ^ ps ^ " (use `openssl s_client -connect host:" ^ ps ^ " -servername foo` (or -servername bar))") >>= fun () ->
   let rec loop () =
-    let config = Tls.Config.server ~certificates:(`Multiple [barcert ; foocert]) () in
+    let config = get_ok (Tls.Config.server ~certificates:(`Multiple [barcert ; foocert]) ()) in
     server_s >>= fun s ->
     Tls_lwt.Unix.accept config s >>= fun (t, addr) ->
     yap ~tag "-> connect" >>= fun () ->

lwt/examples/echo_server_sni.ml

@@ -49,3 +49,7 @@ let setup_log =
   Term.(const setup_log
         $ Fmt_cli.style_renderer ()
         $ Logs_cli.level ())
+
+let get_ok = function
+  | Ok cfg -> cfg
+  | Error `Msg msg -> invalid_arg msg

lwt/examples/ex_common.ml

@@ -53,7 +53,7 @@ let serve_ssl port callback =
 
   yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () ->
   let rec loop s =
-    let config = Tls.Config.server ~ticket_cache ~reneg:true ~certificates:(`Single cert) ~version:(`TLS_1_2, `TLS_1_3) ~zero_rtt:32768l () in
+    let config = get_ok (Tls.Config.server ~ticket_cache ~reneg:true ~certificates:(`Single cert) ~version:(`TLS_1_2, `TLS_1_3) ~zero_rtt:32768l ()) in
     (Lwt.catch
        (fun () -> Tls_lwt.Unix.accept config s >|= fun r -> `R r)
        (function

lwt/examples/fuzz_server.ml

@@ -6,7 +6,7 @@ let http_client ?ca ?fp hostname port =
   let port          = int_of_string port in
   auth ?ca ?fp () >>= fun authenticator ->
   Tls_lwt.connect_ext
-    (Tls.Config.client ~authenticator ())
+    (get_ok (Tls.Config.client ~authenticator ()))
     (hostname, port) >>= fun (ic, oc) ->
   let req = String.concat "\r\n" [
     "GET / HTTP/1.1" ; "Host: " ^ hostname ; "Connection: close" ; "" ; ""

lwt/examples/http_client.ml

@@ -5,7 +5,7 @@ open Ex_common
 let http_client ?ca ?fp hostname port =
   let port          = int_of_string port in
   auth ?ca ?fp () >>= fun authenticator ->
-  let config = Tls.Config.client ~authenticator () in
+  let config = get_ok (Tls.Config.client ~authenticator ()) in
   Tls_lwt.Unix.connect config (hostname, port) >>= fun t ->
   Tls_lwt.Unix.write t "foo\n" >>= fun () ->
   let cs = Bytes.create 4 in
@@ -16,7 +16,7 @@ let http_client ?ca ?fp hostname port =
   in
   Tls_lwt.Unix.close t >>= fun () ->
   Printf.printf "closed session\n" ;
-  let config = Tls.Config.client ~authenticator ~cached_session () in
+  let config = get_ok (Tls.Config.client ~authenticator ~cached_session ()) in
   Tls_lwt.connect_ext config (hostname, port) >>= fun (ic, oc) ->
   let req = String.concat "\r\n" [
     "GET / HTTP/1.1" ; "Host: " ^ hostname ; "Connection: close" ; "" ; ""

lwt/examples/resume_client.ml

@@ -86,7 +86,7 @@ let serve_ssl port callback =
   yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () ->
   let rec loop s =
     let authenticator ?ip:_ ~host:_ _ = Ok None in
-    let config = Tls.Config.server ~certificates:(`Single cert) ~ticket_cache ~authenticator () in
+    let config = get_ok (Tls.Config.server ~certificates:(`Single cert) ~ticket_cache ~authenticator ()) in
     (Lwt.catch
        (fun () ->
           Lwt_unix.accept s >>= fun (s, addr) ->

lwt/examples/resume_echo_server.ml

@@ -1,4 +1,5 @@
 open Lwt.Infix
+open Ex_common
 
 let capability = "[CAPABILITY IMAP4rev1 LITERAL+ SASL-IR LOGIN-REFERRALS ID ENABLE IDLE STARTTLS AUTH=PLAIN] server ready.\r\n"
 
@@ -56,7 +57,7 @@ let start_server () =
       Lwt_io.close oc >>= fun () ->
       cert () >>= fun cert ->
       Tls_lwt.Unix.server_of_fd
-        (Tls.Config.server ~certificates:(`Single cert) ()) sock_cl >>= fun s ->
+        (get_ok (Tls.Config.server ~certificates:(`Single cert) ())) sock_cl >>= fun s ->
       let ic,oc = Tls_lwt.of_t s in
       write oc ("* OK " ^ capability) >>= fun () ->
       wait_cmd sock_cl ic oc

lwt/examples/starttls_server.ml

@@ -18,7 +18,7 @@ let test_client _ =
   let host = "127.0.0.1" in
   let authenticator = null_auth in
   Tls_lwt.Unix.connect
-    Tls.Config.(client ~version:(`TLS_1_0, `TLS_1_3) (* ~certificates:(`Single cert) *) ?cached_ticket:!mypsk ~ticket_cache ~authenticator ~ciphers:Ciphers.supported ())
+    (get_ok Tls.Config.(client ~version:(`TLS_1_0, `TLS_1_3) (* ~certificates:(`Single cert) *) ?cached_ticket:!mypsk ~ticket_cache ~authenticator ~ciphers:Ciphers.supported ()))
     (host, port) >>= fun t ->
   let (ic, oc) = Tls_lwt.of_t t in
   let req = String.concat "\r\n" [

lwt/examples/test_client.ml

@@ -14,7 +14,8 @@ let serve_ssl port callback =
     ~priv_key:server_ec_key >>= fun ec_certificate ->
   let certificates = `Multiple [ certificate ; ec_certificate ] in
   let config =
-    Tls.Config.(server ~version:(`TLS_1_0, `TLS_1_3) ~certificates ~ciphers:Ciphers.supported ()) in
+    get_ok (Tls.Config.(server ~version:(`TLS_1_0, `TLS_1_3) ~certificates ~ciphers:Ciphers.supported ()))
+  in
 
   let server_s =
     let open Lwt_unix in

lwt/examples/test_server.ml

@@ -301,13 +301,15 @@ let accept_ext conf fd =
 and connect_ext conf addr =
   Unix.connect conf addr >|= of_t
 
-let accept certificate =
-  let config = Tls.Config.server ~certificates:certificate () in
-  accept_ext config
+let accept certificate fd =
+  match Tls.Config.server ~certificates:certificate () with
+  | Ok config -> accept_ext config fd >|= fun w -> Ok w
+  | Error _ as e -> Lwt.return e
 
 and connect authenticator addr =
-  let config = Tls.Config.client ~authenticator () in
-  connect_ext config addr
+  match Tls.Config.client ~authenticator () with
+  | Ok config -> connect_ext config addr >|= fun w -> Ok w
+  | Error _ as e -> Lwt.return e
 
 (* Boot the entropy loop at module init time. *)
 let () = Mirage_crypto_rng_lwt.initialize (module Mirage_crypto_rng.Fortuna)

lwt/tls_lwt.ml

@@ -104,7 +104,7 @@ val accept_ext : Tls.Config.server -> Lwt_unix.file_descr ->
     output channel from the accepted connection on [fd], using the
     default configuration with the given [own_cert]. *)
 val accept : Tls.Config.own_cert -> Lwt_unix.file_descr ->
-  ((ic * oc) * Lwt_unix.sockaddr) Lwt.t
+  ((ic * oc) * Lwt_unix.sockaddr, [> `Msg of string]) result Lwt.t
 
 (** [connect_ext client (host, port)] is [ic, oc], the input
     and output channel of a TLS connection to [host] on [port] using
@@ -114,7 +114,7 @@ val connect_ext : Tls.Config.client -> string * int -> (ic * oc) Lwt.t
 (** [connect authenticator (host, port)] is [ic, oc], the input
     and output channel of a TLS connection to [host] on [port] using the
     default configuration and the [authenticator]. *)
-val connect : X509.Authenticator.t -> string * int -> (ic * oc) Lwt.t
+val connect : X509.Authenticator.t -> string * int -> (ic * oc, [> `Msg of string ]) result Lwt.t
 
 (** [of_t t] is [ic, oc], the input and output channel.  [close]
     defaults to [!Unix.close]. *)

lwt/tls_lwt.mli

@@ -33,15 +33,19 @@ module Flow = struct
           tag descr (Tls.Engine.string_of_failure a)
 end
 
+let get_ok = function
+  | Ok cfg -> cfg
+  | Error `Msg msg -> invalid_arg msg
+
 let loop_chatter ~certificate ~loops ~size =
 
   Printf.eprintf "Looping %d times, %d bytes.\n%!" loops size;
 
   let message  = Mirage_crypto_rng.generate size
-  and server   = Tls.(Engine.server (Config.server ~certificates:(`Single certificate) ()))
+  and server   = Tls.(Engine.server (get_ok (Config.server ~certificates:(`Single certificate) ())))
   and (client, init) =
     let authenticator ?ip:_ ~host:_ _ = Ok None in
-    Tls.(Engine.client @@ Config.client ~authenticator ())
+    Tls.(Engine.client @@ get_ok (Config.client ~authenticator ()))
   in
   Testlib.time @@ fun () ->