peer_name should be strongly typed

async/examples/test_client.ml

@@ -9,7 +9,9 @@ let test_client () =
   let port = 8443 in
   let hnp = Host_and_port.create ~host ~port in
   let%bind (_ : Tls_async.Session.t), rd, wr =
-    Tls_async.connect config (Tcp.Where_to_connect.of_host_and_port hnp) ~host:(Some host)
+    (* we can't build a [[ `host ] Domain_name.t] from an IP address *)
+    let host = None in
+    Tls_async.connect config (Tcp.Where_to_connect.of_host_and_port hnp) ~host
   in
   let req =
     String.concat

async/io_intf.ml

@@ -22,7 +22,11 @@ module type S = sig
 
   (** [client_of_fd client ~host fd] is [t], after client-side
       TLS handshake of [fd] using [client] configuration and [host]. *)
-  val client_of_fd : Tls.Config.client -> ?host:string -> Fd.t -> t Deferred.Or_error.t
+  val client_of_fd
+    :  Tls.Config.client
+    -> ?host:[ `host ] Domain_name.t
+    -> Fd.t
+    -> t Deferred.Or_error.t
 
   (** {2 Common stream operations} *)
 

async/tls_async.mli

@@ -32,6 +32,6 @@ val connect
   :  ?socket:([ `Unconnected ], 'addr) Socket.t
   -> (Tls.Config.client
       -> 'addr Tcp.Where_to_connect.t
-      -> host:string option
+      -> host:[ `host ] Domain_name.t option
       -> (Session.t * Reader.t * Writer.t) Deferred.Or_error.t)
        Tcp.with_connect_options

lib/config.ml

@@ -18,6 +18,11 @@ type own_cert = [
 type session_cache = SessionID.t -> epoch_data option
 let sexp_of_session_cache _ = Sexplib.Sexp.Atom "SESSION_CACHE"
 
+module Peer_name = struct
+  type t = [ `host ] Domain_name.t
+  let sexp_of_t t = Sexplib.Sexp.Atom (Domain_name.to_string t)
+end
+
 module Auth = struct
   type t = X509.Authenticator.t
   let sexp_of_t _ = Sexplib.Sexp.Atom "Authenticator"
@@ -45,7 +50,7 @@ type config = {
   signature_algorithms : signature_algorithm list ;
   use_reneg : bool ;
   authenticator : Auth.t option ;
-  peer_name : string option ;
+  peer_name : Peer_name.t option ;
   own_certificates : own_cert ;
   acceptable_cas : DN.t list ;
   session_cache : session_cache ;

lib/config.mli

@@ -33,7 +33,7 @@ type config = private {
   signature_algorithms : signature_algorithm list ; (** ordered list of supported signature algorithms (regarding preference) *)
   use_reneg : bool ; (** endpoint should accept renegotiation requests *)
   authenticator : X509.Authenticator.t option ; (** optional X509 authenticator *)
-  peer_name : string option ; (** optional name of other endpoint (used for SNI RFC4366) *)
+  peer_name : [ `host ] Domain_name.t option ; (** optional name of other endpoint (used for SNI RFC4366) *)
   own_certificates : own_cert ; (** optional default certificate chain and other certificate chains *)
   acceptable_cas : X509.Distinguished_name.t list ; (** ordered list of acceptable certificate authorities *)
   session_cache : session_cache ;
@@ -61,7 +61,7 @@ type server [@@deriving sexp]
     @raise Invalid_argument if the configuration is invalid *)
 val client :
   authenticator : X509.Authenticator.t ->
-  ?peer_name : string ->
+  ?peer_name : [ `host ] Domain_name.t ->
   ?ciphers : Ciphersuite.ciphersuite list ->
   ?version : tls_version * tls_version ->
   ?signature_algorithms : signature_algorithm list ->
@@ -93,7 +93,7 @@ val server :
   unit -> server
 
 (** [peer client name] is [client] with [name] as [peer_name] *)
-val peer : client -> string -> client
+val peer : client -> [ `host ] Domain_name.t -> client
 
 (** {1 Note on ALPN protocol selection}
 

lib/core.ml

@@ -239,8 +239,13 @@ let pk_matches_sa pk sa =
   | `P521 _, `ECDSA_SECP521R1_SHA512 -> true
   | _ -> false
 
+module Peer_name = struct
+  type t = [ `host ] Domain_name.t
+  let sexp_of_t t = Sexplib.Sexp.Atom (Domain_name.to_string t)
+end
+
 type client_extension = [
-  | `Hostname of string
+  | `Hostname of Peer_name.t
   | `MaxFragmentLength of max_fragment_length
   | `SupportedGroups of Packet.named_group list
   | `SecureRenegotiation of Cstruct_sexp.t
@@ -403,7 +408,7 @@ type epoch_data = {
   peer_random            : Cstruct_sexp.t ;
   peer_certificate_chain : Cert.t list ;
   peer_certificate       : Cert.t option ;
-  peer_name              : string option ;
+  peer_name              : Peer_name.t option ;
   trust_anchor           : Cert.t option ;
   received_certificates  : Cert.t list ;
   own_random             : Cstruct_sexp.t ;

lib/handshake_client.ml

@@ -204,7 +204,7 @@ let validate_keyusage certificate kex =
 
 let answer_certificate_RSA state (session : session_data) cs raw log =
   let cfg = state.config in
-  validate_chain cfg.authenticator cs (host_name_opt cfg.peer_name) >>= fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
+  validate_chain cfg.authenticator cs cfg.peer_name >>= fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
   validate_keyusage peer_certificate `RSA >>= fun () ->
   let session =
     let common_session_data = { session.common_session_data with received_certificates ; peer_certificate ; peer_certificate_chain ; trust_anchor } in
@@ -230,7 +230,7 @@ let answer_certificate_RSA state (session : session_data) cs raw log =
 
 let answer_certificate_DHE state (session : session_data) cs raw log =
   let cfg = state.config in
-  validate_chain cfg.authenticator cs (host_name_opt cfg.peer_name) >>= fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
+  validate_chain cfg.authenticator cs cfg.peer_name >>= fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
   validate_keyusage peer_certificate `FFDHE >>| fun () ->
   let session =
     let common_session_data = { session.common_session_data with received_certificates ; peer_certificate ; peer_certificate_chain ; trust_anchor } in

lib/handshake_client13.ml

@@ -105,7 +105,7 @@ let answer_encrypted_extensions state (session : session_data13) server_hs_secre
 let answer_certificate state (session : session_data13) server_hs_secret client_hs_secret sigalgs certs raw log =
   (* certificates are (cs, ext) list - ext being statusrequest or signed_cert_timestamp *)
   let certs = List.map fst certs in
-  validate_chain state.config.authenticator certs (host_name_opt state.config.peer_name) >>=
+  validate_chain state.config.authenticator certs state.config.peer_name >>=
   fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
   let session =
     let common_session_data13 = {

lib/handshake_common.ml

@@ -26,17 +26,8 @@ let empty = function [] -> true | _ -> false
 let change_cipher_spec =
   (Packet.CHANGE_CIPHER_SPEC, Writer.assemble_change_cipher_spec)
 
-let host_name_opt = function
-  | None   -> None
-  | Some x -> match Domain_name.of_string x with
-    | Error _ -> None
-    | Ok domain -> match Domain_name.host domain with
-      | Error _ -> None
-      | Ok host -> Some host
-
 let hostname (h : client_hello) : [ `host ] Domain_name.t option =
-  host_name_opt
-    (map_find ~f:(function `Hostname s -> Some s | _ -> None) h.extensions)
+  map_find ~f:(function `Hostname s -> Some s | _ -> None) h.extensions
 
 let groups (h : client_hello) =
   match map_find ~f:(function `SupportedGroups g -> Some g | _ -> None) h.extensions with

lib/reader.ml

@@ -347,8 +347,16 @@ let parse_client_extension raw =
     match int_to_extension_type etype with
     | Some SERVER_NAME ->
        (match parse_hostnames buf with
-        | [name] -> `Hostname name
-        | _      -> raise_unknown "bad server name indication (multiple names)")
+       | [name] ->
+         (match Domain_name.of_string name with
+         | Error (`Msg err) ->
+           raise_unknown ("unable to canonicalize " ^ name ^ "into a domain name: " ^ err)
+         | Ok domain_name ->
+           (match Domain_name.host domain_name with
+           | Error (`Msg err) ->
+             raise_unknown ("unable to build a hostname from " ^ name ^ ": " ^ err)
+           | Ok hostname -> `Hostname hostname))
+       | _      -> raise_unknown "bad server name indication (multiple names)")
     | Some SUPPORTED_GROUPS ->
        let gs = parse_supported_groups buf in
        `SupportedGroups gs

lib/writer.ml

@@ -87,6 +87,7 @@ let assemble_ciphersuite c =
   assemble_any_ciphersuite acs
 
 let assemble_hostname host =
+  let host = Domain_name.to_string host in
   (* 8 bit hostname type; 16 bit length; value *)
   let vallength = String.length host in
   let buf = create 3 in

lwt/tls_lwt.ml

@@ -211,7 +211,10 @@ module Unix = struct
   let connect conf (host, port) =
     resolve host (string_of_int port) >>= fun addr ->
     let fd = Lwt_unix.(socket (Unix.domain_of_sockaddr addr) SOCK_STREAM 0) in
-    Lwt.catch (fun () -> Lwt_unix.connect fd addr >>= fun () -> client_of_fd conf ~host fd)
+    Lwt.catch (fun () -> 
+      (* A different exception could be raised here. [Invalid_argument] is a bit generic. *)
+      let host = Domain_name.of_string_exn host |> Domain_name.host_exn in
+      Lwt_unix.connect fd addr >>= fun () -> client_of_fd conf ~host fd)
       (fun exn -> safely (Lwt_unix.close fd) >>= fun () -> fail exn)
 
   let read_bytes t bs off len =

lwt/tls_lwt.mli

@@ -31,7 +31,7 @@ module Unix : sig
 
   (** [client_of_fd client ~host fd] is [t], after client-side
       TLS handshake of [fd] using [client] configuration and [host]. *)
-  val client_of_fd : Tls.Config.client -> ?host:string -> Lwt_unix.file_descr -> t Lwt.t
+  val client_of_fd : Tls.Config.client -> ?host:[ `host ] Domain_name.t -> Lwt_unix.file_descr -> t Lwt.t
 
   (** [accept server fd] is [t, sockaddr], after accepting a
       client on [fd] and upgrading to a TLS connection. *)

mirage/tls_mirage.mli

@@ -37,8 +37,8 @@ module Make (F : Mirage_flow.S) : sig
 
   (** [client_of_flow client ~host flow] upgrades the existing connection
       to TLS using the [client] configuration, using [host] as peer name. *)
-  val client_of_flow : Tls.Config.client -> ?host:string -> FLOW.flow ->
-    (flow, write_error) result Lwt.t
+  val client_of_flow : Tls.Config.client -> ?host:[ `host ] Domain_name.t ->
+     FLOW.flow -> (flow, write_error) result Lwt.t
 
   (** [server_of_flow server flow] upgrades the flow to a TLS
       connection using the [server] configuration. *)

tests/readertests.ml

@@ -1212,9 +1212,9 @@ let good_client_hellos =
           ([1; 0; 0; 40; 3; 3] @ rand @ [(* session id *) 0; (* cipher *) 0; 0; (* comp *) 0; (* exts *) 0; 0] , ch ) ;
 
           (* some hostname *)
-          ([1; 0; 0; 52; 3; 3] @ rand @ [(* session id *) 0; (* cipher *) 0; 0; (* comp *) 0; (* exts *) 0; 12; 0; 0; 0; 8; 0; 6; 0; 0; 3; 102; 111; 111] , { ch with extensions = [`Hostname "foo"] } ) ;
+          ([1; 0; 0; 52; 3; 3] @ rand @ [(* session id *) 0; (* cipher *) 0; 0; (* comp *) 0; (* exts *) 0; 12; 0; 0; 0; 8; 0; 6; 0; 0; 3; 102; 111; 111] , { ch with extensions = [make_hostname_ext "foo"] } ) ;
           (* some other hostname *)
-          ([1; 0; 0; 59; 3; 3] @ rand @ [(* session id *) 0; (* cipher *) 0; 0; (* comp *) 0; (* exts *) 0; 19; 0; 0; 0; 15; 0; 13; 0; 0; 10; 102; 111; 111; 98; 97; 114; 46; 99; 111; 109] , { ch with extensions = [`Hostname "foobar.com"] } ) ;
+          ([1; 0; 0; 59; 3; 3] @ rand @ [(* session id *) 0; (* cipher *) 0; 0; (* comp *) 0; (* exts *) 0; 19; 0; 0; 0; 15; 0; 13; 0; 0; 10; 102; 111; 111; 98; 97; 114; 46; 99; 111; 109] , { ch with extensions = [make_hostname_ext "foobar.com"] } ) ;
 
           (* max fragment length *)
           ([1; 0; 0; 45; 3; 3] @ rand @ [(* session id *) 0; (* cipher *) 0; 0; (* comp *) 0; (* exts *) 0; 5; 0; 1; 0; 1; 3] , { ch with extensions = [`MaxFragmentLength Packet.TWO_11] } ) ;
@@ -1317,16 +1317,16 @@ let good_client_hellos =
 
 
           ( [ 0x01; (* client hello *)
-              0x00; 0x00; 0x72; (* length *)
+              0x00; 0x00; 0x74; (* length *)
               0x03; 0x04; (* version *)
               0xf1; 0xb2; 0x50; 0x16; 0x4b; 0x77; 0x50; 0xb3; 0xdc; 0xcb; 0x1c; 0x6a; 0xae; 0x1a; 0x94; 0x87;
               0xc4; 0x17; 0xbb; 0xa4; 0xf7; 0x92; 0xf8; 0x16; 0x56; 0x12; 0x03; 0x38; 0x1e; 0xe5; 0xc1; 0xae; (* client random *)
               0x00; (* session id *)
               0x00; 0x10; 0x00; 0x35; 0x00; 0x39; 0x00; 0x2f; 0x00; 0x33; 0x00; 0x16; 0x00; 0x0a; 0x00; 0x05; 0x00; 0x04; (* ciphersuites *)
               0x01; 0x00; (* compression *)
-              0x00; 0x39; (* extensions *)
+              0x00; 0x3b; (* extensions *)
               0xff; 0x01; 0x00; 0x01; 0x00; (* secure reneg *)
-              0x00; 0x00; 0x00; 0x0e; 0x00; 0x0c; 0x00; 0x00; 0x09; 0x31; 0x32; 0x37; 0x2e; 0x30; 0x2e; 0x30; 0x2e; 0x31; (* SNI 127.0.0.1 *)
+              0x00; 0x00; 0x00; 0x10; 0x00; 0x0e; 0x00; 0x00; 0x0b; 0x65; 0x78; 0x61; 0x6d; 0x70; 0x6c; 0x65; 0x2e; 0x63; 0x6f; 0x6d; (* SNI example.com *)
               0x00; 0x0d; 0x00; 0x0c; 0x00; 0x0a; 0x06; 0x01; 0x05; 0x01; 0x04; 0x01; 0x02; 0x01; 0x01; 0x01; (* SignatureAlgorithms *)
               0x00; 0x10; 0x00; 0x0e; 0x00; 0x0c; (* ALPN *)
               0x02; 0x68; 0x32;
@@ -1336,7 +1336,7 @@ let good_client_hellos =
                       client_random = list_to_cstruct [ 0xf1; 0xb2; 0x50; 0x16; 0x4b; 0x77; 0x50; 0xb3; 0xdc; 0xcb; 0x1c; 0x6a; 0xae; 0x1a; 0x94; 0x87; 0xc4; 0x17; 0xbb; 0xa4; 0xf7; 0x92; 0xf8; 0x16; 0x56; 0x12; 0x03; 0x38; 0x1e; 0xe5; 0xc1; 0xae ] ;
                       ciphersuites = Packet.([TLS_RSA_WITH_AES_256_CBC_SHA ; TLS_DHE_RSA_WITH_AES_256_CBC_SHA ; TLS_RSA_WITH_AES_128_CBC_SHA ; TLS_DHE_RSA_WITH_AES_128_CBC_SHA ; TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA ; TLS_RSA_WITH_3DES_EDE_CBC_SHA]) ;
                       extensions = [ `SecureRenegotiation (Cstruct.create 0) ;
-                                     `Hostname "127.0.0.1" ;
+                                     make_hostname_ext "example.com" ;
                                      `SignatureAlgorithms
                                        [`RSA_PKCS1_SHA512 ;
                                         `RSA_PKCS1_SHA384 ;

tests/readerwritertests.ml

@@ -373,15 +373,15 @@ let rw_handshake_client_hello_vals =
                         ciphersuites = Packet.([ TLS_NULL_WITH_NULL_NULL ; TLS_RSA_WITH_NULL_MD5 ; TLS_RSA_WITH_AES_256_CBC_SHA ]) ;
                         sessionid = (Some client_random) } ;
 
-          ClientHello { ch with extensions = [ `Hostname "foobar" ] } ;
-          ClientHello { ch with extensions = [ `Hostname "foobarblubb" ] } ;
+          ClientHello { ch with extensions = [ make_hostname_ext "foobar" ] } ;
+          ClientHello { ch with extensions = [ make_hostname_ext "foobarblubb" ] } ;
 
-          ClientHello { ch with extensions = [ `Hostname "foobarblubb" ; `SupportedGroups Packet.([SECP521R1; SECP384R1]) ] } ;
+          ClientHello { ch with extensions = [ make_hostname_ext "foobarblubb" ; `SupportedGroups Packet.([SECP521R1; SECP384R1]) ] } ;
 
           ClientHello { ch with extensions = [ `ALPN ["h2"; "http/1.1"] ] } ;
 
           ClientHello { ch with extensions = [
-                             `Hostname "foobarblubb" ;
+                             make_hostname_ext "foobarblubb" ;
                              `SupportedGroups Packet.([SECP521R1; SECP384R1]) ;
                              `SignatureAlgorithms [`RSA_PKCS1_MD5] ;
                              `ALPN ["h2"; "http/1.1"]
@@ -390,13 +390,13 @@ let rw_handshake_client_hello_vals =
           ClientHello { ch with
                         ciphersuites = Packet.([ TLS_NULL_WITH_NULL_NULL ; TLS_RSA_WITH_NULL_MD5 ; TLS_RSA_WITH_AES_256_CBC_SHA ]) ;
                         sessionid = (Some client_random) ;
-                        extensions = [ `Hostname "foobarblubb" ] } ;
+                        extensions = [ make_hostname_ext "foobarblubb" ] } ;
 
           ClientHello { ch with
                         ciphersuites = Packet.([ TLS_NULL_WITH_NULL_NULL ; TLS_RSA_WITH_NULL_MD5 ; TLS_RSA_WITH_AES_256_CBC_SHA ]) ;
                         sessionid = (Some client_random) ;
                         extensions = [
-                             `Hostname "foobarblubb" ;
+                             make_hostname_ext "foobarblubb" ;
                              `SupportedGroups Packet.([SECP521R1; SECP384R1]) ;
                              `SignatureAlgorithms [`RSA_PKCS1_SHA1; `RSA_PKCS1_SHA512] ;
                              `ALPN ["h2"; "http/1.1"]
@@ -406,7 +406,7 @@ let rw_handshake_client_hello_vals =
                         ciphersuites = Packet.([ TLS_NULL_WITH_NULL_NULL ; TLS_RSA_WITH_NULL_MD5 ; TLS_RSA_WITH_AES_256_CBC_SHA ]) ;
                         sessionid = (Some client_random) ;
                         extensions = [
-                             `Hostname "foobarblubb" ;
+                             make_hostname_ext "foobarblubb" ;
                              `SupportedGroups Packet.([SECP521R1; SECP384R1]) ;
                              `SignatureAlgorithms [`RSA_PKCS1_MD5; `RSA_PKCS1_SHA256] ;
                              `SecureRenegotiation client_random ;

tests/testlib.ml

@@ -69,3 +69,6 @@ let assert_server_extension_equal a b =
 
 let cs_mmap file =
   Unix_cstruct.of_fd Unix.(openfile file [O_RDONLY] 0)
+
+let make_hostname_ext h =
+  (`Hostname (Domain_name.of_string_exn h |> Domain_name.host_exn))