Merge pull request #440 from hannesm/x509-0.15.0

adapt to x509 0.15.0 changes

async/examples/test_client.ml

@@ -2,7 +2,7 @@ open! Core
 open! Async
 open Deferred.Or_error.Let_syntax
 
-let config = Tls.Config.client ~authenticator:(fun ~host:_ _ -> Ok None) ()
+let config = Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) ()
 
 let test_client () =
   let host = "127.0.0.1" in

async/x509_async.ml

@@ -94,8 +94,8 @@ module Authenticator = struct
 
     type t =
       | Chain_of_trust of Chain_of_trust.t
-      | Cert_fingerprints of
-          Mirage_crypto.Hash.hash * ([ `host ] Domain_name.t * string) list
+      | Cert_fingerprint of Mirage_crypto.Hash.hash * string
+      | Key_fingerprint of Mirage_crypto.Hash.hash * string
 
     let ca_file ?allowed_hashes ?crls filename () =
       let trust_anchors = `File filename in
@@ -107,7 +107,9 @@ module Authenticator = struct
       Chain_of_trust { trust_anchors; allowed_hashes; crls }
     ;;
 
-    let cert_fingerprints hash fingerprints = Cert_fingerprints (hash, fingerprints)
+    let cert_fingerprint hash fingerprint = Cert_fingerprint (hash, fingerprint)
+
+    let key_fingerprint hash fingerprint = Key_fingerprint (hash, fingerprint)
 
     let cleanup_fingerprint fingerprint =
       let known_delimiters = [ ':'; ' ' ] in
@@ -129,20 +131,25 @@ module Authenticator = struct
       X509.Authenticator.chain_of_trust ?allowed_hashes ?crls ~time cas
     ;;
 
-    let cert_fingerprint ~time hash fingerprints =
-      let fingerprints =
-        List.map fingerprints ~f:(Tuple.T2.map_snd ~f:cleanup_fingerprint)
-      in
-      X509.Authenticator.server_cert_fingerprint ~time ~hash ~fingerprints
+    let of_cert_fingerprint ~time hash fingerprint =
+      let fingerprint = cleanup_fingerprint fingerprint in
+      X509.Authenticator.server_cert_fingerprint ~time ~hash ~fingerprint
+    ;;
+
+    let of_key_fingerprint ~time hash fingerprint =
+      let fingerprint = cleanup_fingerprint fingerprint in
+      X509.Authenticator.server_key_fingerprint ~time ~hash ~fingerprint
     ;;
 
     let time = Fn.compose Ptime.of_float_s Unix.gettimeofday
 
     let to_authenticator ~time param =
       match param with
       | Chain_of_trust chain_of_trust -> of_cas ~time chain_of_trust
-      | Cert_fingerprints (hash, fingerprints) ->
-        cert_fingerprint ~time hash fingerprints |> Deferred.Or_error.return
+      | Cert_fingerprint (hash, fingerprint) ->
+        of_cert_fingerprint ~time hash fingerprint |> Deferred.Or_error.return
+      | Key_fingerprint (hash, fingerprint) ->
+        of_key_fingerprint ~time hash fingerprint |> Deferred.Or_error.return
     ;;
   end
 end

async/x509_async.mli

@@ -29,9 +29,16 @@ module Authenticator : sig
 
     (** The fingerprint can be collected from a browser or by invoking an openssl command
         like 'openssl x509 -in <pem_file> -noout -fingerprint -sha256' *)
-    val cert_fingerprints
+    val cert_fingerprint
       :  Mirage_crypto.Hash.hash
-      -> ([ `host ] Domain_name.t * string) list
+      -> string
+      -> t
+
+    (** The fingerprint can be collected from a browser or by invoking an openssl command
+        like 'openssl x509 -in <pem_file> -noout -pubkey | openssl pkey -pubin -outform DER | openssl dgst -sha256' *)
+    val key_fingerprint
+      :  Mirage_crypto.Hash.hash
+      -> string
       -> t
 
     (** Async programs often don't use [Ptime_clock], so this is provided as a convenience

lib/config.ml

@@ -55,6 +55,7 @@ type config = {
   alpn_protocols : string list ;
   groups : group list ;
   zero_rtt : int32 ;
+  ip : Ipaddr_sexp.t option ;
 } [@@deriving sexp_of]
 
 let ciphers13 cfg =
@@ -186,6 +187,7 @@ let default_config = {
   groups = supported_groups ;
   ticket_cache = None ;
   zero_rtt = 0l ;
+  ip = None ;
 }
 
 (* There are inter-configuration option constraints that are checked and
@@ -528,7 +530,7 @@ let with_acceptable_cas conf acceptable_cas = { conf with acceptable_cas }
 let (<?>) ma b = match ma with None -> b | Some a -> a
 
 let client
-  ~authenticator ?peer_name ?ciphers ?version ?signature_algorithms ?reneg ?certificates ?cached_session ?cached_ticket ?ticket_cache ?alpn_protocols ?groups () =
+  ~authenticator ?peer_name ?ciphers ?version ?signature_algorithms ?reneg ?certificates ?cached_session ?cached_ticket ?ticket_cache ?alpn_protocols ?groups ?ip () =
   let ciphers', groups = ciphers_and_groups ?ciphers ?groups default_config.ciphers in
   let ciphers, signature_algorithms = ciphers_and_sig_alg ?ciphers ?signature_algorithms ciphers' in
   let config =
@@ -545,6 +547,7 @@ let client
         ticket_cache = ticket_cache ;
         cached_ticket = cached_ticket ;
         groups ;
+        ip ;
     } in
   let config = validate_common config in
   validate_client config ;
@@ -553,7 +556,7 @@ let client
   config
 
 let server
-    ?ciphers ?version ?signature_algorithms ?reneg ?certificates ?acceptable_cas ?authenticator ?session_cache ?ticket_cache ?alpn_protocols ?groups ?zero_rtt () =
+    ?ciphers ?version ?signature_algorithms ?reneg ?certificates ?acceptable_cas ?authenticator ?session_cache ?ticket_cache ?alpn_protocols ?groups ?zero_rtt ?ip () =
   let ciphers', groups = ciphers_and_groups ?ciphers ?groups default_config.ciphers in
   let ciphers, signature_algorithms = ciphers_and_sig_alg ?ciphers ?signature_algorithms ciphers' in
   let config =
@@ -570,6 +573,7 @@ let server
         ticket_cache = ticket_cache ;
         groups ;
         zero_rtt = zero_rtt <?> default_config.zero_rtt ;
+        ip ;
     } in
   let config = validate_server config in
   let config = validate_common config in

lib/config.mli

@@ -43,6 +43,7 @@ type config = private {
   alpn_protocols : string list ; (** optional ordered list of accepted alpn_protocols *)
   groups : group list ; (** the first FFDHE will be used for TLS 1.2 and below if a DHE ciphersuite is used *)
   zero_rtt : int32 ;
+  ip : Ipaddr.t option ;
 } [@@deriving sexp_of]
 
 (** [ciphers13 config] are the ciphersuites for TLS 1.3 in the configuration. *)
@@ -72,6 +73,7 @@ val client :
   ?ticket_cache : ticket_cache ->
   ?alpn_protocols : string list ->
   ?groups : group list ->
+  ?ip : Ipaddr.t ->
   unit -> client
 
 (** [server ?ciphers ?version ?hashes ?reneg ?certificates ?acceptable_cas ?authenticator ?alpn_protocols]
@@ -90,6 +92,7 @@ val server :
   ?alpn_protocols : string list ->
   ?groups : group list ->
   ?zero_rtt : int32 ->
+  ?ip : Ipaddr.t ->
   unit -> server
 
 (** [peer client name] is [client] with [name] as [peer_name] *)

lib/dune

@@ -1,5 +1,5 @@
 (library
  (name tls)
  (public_name tls)
- (libraries cstruct cstruct-sexp logs hkdf mirage-crypto mirage-crypto-rng mirage-crypto-pk x509 sexplib domain-name fmt mirage-crypto-ec rresult)
+ (libraries cstruct cstruct-sexp logs hkdf mirage-crypto mirage-crypto-rng mirage-crypto-pk x509 sexplib domain-name fmt mirage-crypto-ec rresult ipaddr ipaddr-sexp)
  (preprocess (pps ppx_sexp_conv ppx_cstruct)))

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 cfg.peer_name >>= fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
+  validate_chain cfg.authenticator cs cfg.ip 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 cfg.peer_name >>= fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
+  validate_chain cfg.authenticator cs cfg.ip 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 state.config.peer_name >>=
+  validate_chain state.config.authenticator certs state.config.ip state.config.peer_name >>=
   fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
   let session =
     let common_session_data13 = {

lib/handshake_common.ml

@@ -467,9 +467,9 @@ let verify_digitally_signed version ?context_string sig_algs data signature_data
           (X509.Public_key.verify hash ~scheme ~signature pubkey (`Message data))
       | Error re -> Error (`Fatal (`ReaderError re)))
 
-let validate_chain authenticator certificates hostname =
+let validate_chain authenticator certificates ip hostname =
   let authenticate authenticator host certificates =
-    match authenticator ~host certificates with
+    match authenticator ?ip ~host certificates with
     | Error err  -> Error (`Error (`AuthenticationFailure err))
     | Ok anchor -> Ok anchor
 

lib/handshake_server.ml

@@ -79,8 +79,8 @@ let private_key (session : session_data) =
     | Some priv -> Ok priv
     | None      -> Error (`Fatal `InvalidSession) (* TODO: assert false / ensure via typing in config *)
 
-let validate_certs certs authenticator (session : session_data) =
-  validate_chain authenticator certs None >>| fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
+let validate_certs certs authenticator ip (session : session_data) =
+  validate_chain authenticator certs ip None >>| fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
   let common_session_data = {
     session.common_session_data with
     received_certificates ;
@@ -91,12 +91,12 @@ let validate_certs certs authenticator (session : session_data) =
   { session with common_session_data }
 
 let answer_client_certificate_RSA state (session : session_data) certs raw log =
-  validate_certs certs state.config.authenticator session >>| fun session ->
+  validate_certs certs state.config.authenticator state.config.ip session >>| fun session ->
   let machina = AwaitClientKeyExchange_RSA (session, log @ [raw]) in
   ({ state with machina = Server machina }, [])
 
 let answer_client_certificate_DHE state (session : session_data) dh_sent certs raw log =
-  validate_certs certs state.config.authenticator session >>| fun session ->
+  validate_certs certs state.config.authenticator state.config.ip session >>| fun session ->
   let machina = AwaitClientKeyExchange_DHE (session, dh_sent, log @ [raw]) in
   ({ state with machina = Server machina }, [])
 

lib/handshake_server13.ml

@@ -368,7 +368,7 @@ let answer_client_certificate state cert (sd : session_data13) client_fini dec_c
     (* TODO what to do with ctx? send through authenticator? *)
     (* TODO what to do with extensions? *)
     let certs = List.map fst cert_exts in
-    validate_chain auth certs None >>| fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
+    validate_chain auth certs state.config.Config.ip None >>| fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
     let sd' = let common_session_data13 = {
         sd.common_session_data13 with
         received_certificates ;

lwt/examples/echo_client.ml

@@ -26,7 +26,7 @@ let cached_session : Tls.Core.epoch_data =
 
 let echo_client ?ca hostname port =
   let open Lwt_io in
-  auth ~hostname ?ca () >>= fun authenticator ->
+  auth ?ca () >>= fun authenticator ->
   X509_lwt.private_of_pems
     ~cert:server_cert
     ~priv_key:server_key >>= fun certificate ->

lwt/examples/ex_common.ml

@@ -25,14 +25,14 @@ let print_fail where fail =
   Printf.eprintf "(TLS FAIL (%s): %s)\n%!"
     where (Tls.Engine.string_of_failure fail)
 
-let null_auth ~host:_ _ = Ok None
+let null_auth ?ip:_ ~host:_ _ = Ok None
 
-let auth ~hostname ?ca ?fp () =
+let auth ?ca ?fp () =
   match ca with
   | Some "NONE" when fp = None -> Lwt.return null_auth
   | _ ->
     let a = match ca, fp with
-      | None, Some fp  -> `Hex_key_fingerprints (`SHA256, [ Domain_name.(host_exn (of_string_exn hostname)), fp ])
+      | None, Some fp  -> `Hex_key_fingerprint (`SHA256, fp)
       | None, _ -> `Ca_dir ca_cert_dir
       | Some f, _ -> `Ca_file f
     in

lwt/examples/http_client.ml

@@ -4,7 +4,7 @@ open Ex_common
 
 let http_client ?ca ?fp hostname port =
   let port          = int_of_string port in
-  auth ~hostname ?ca ?fp () >>= fun authenticator ->
+  auth ?ca ?fp () >>= fun authenticator ->
   Tls_lwt.connect_ext
     (Tls.Config.client ~authenticator ())
     (hostname, port) >>= fun (ic, oc) ->

lwt/examples/resume_client.ml

@@ -4,7 +4,7 @@ open Ex_common
 
 let http_client ?ca ?fp hostname port =
   let port          = int_of_string port in
-  auth ~hostname ?ca ?fp () >>= fun authenticator ->
+  auth ?ca ?fp () >>= fun authenticator ->
   let config = Tls.Config.client ~authenticator () in
   Tls_lwt.Unix.connect config (hostname, port) >>= fun t ->
   Tls_lwt.Unix.write t (Cstruct.of_string "foo\n") >>= fun () ->

lwt/examples/resume_echo_server.ml

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

lwt/x509_lwt.ml

@@ -91,19 +91,19 @@ let authenticator ?allowed_hashes ?crls param =
     X509.Authenticator.chain_of_trust ?allowed_hashes ?crls ~time cas
   and dotted_hex_to_cs hex =
     Cstruct.of_hex (String.map (function ':' -> ' ' | x -> x) hex)
-  and fingerp hash fingerprints =
-    X509.Authenticator.server_key_fingerprint ~time ~hash ~fingerprints
-  and cert_fingerp hash fingerprints =
-    X509.Authenticator.server_cert_fingerprint ~time ~hash ~fingerprints
+  and fingerp hash fingerprint =
+    X509.Authenticator.server_key_fingerprint ~time ~hash ~fingerprint
+  and cert_fingerp hash fingerprint =
+    X509.Authenticator.server_cert_fingerprint ~time ~hash ~fingerprint
   in
   match param with
   | `Ca_file path -> certs_of_pem path >>= of_cas
   | `Ca_dir path  -> certs_of_pem_dir path >>= of_cas
-  | `Key_fingerprints (hash, fps) -> return (fingerp hash fps)
-  | `Hex_key_fingerprints (hash, fps) ->
-    let fps = List.map (fun (n, v) -> (n, dotted_hex_to_cs v)) fps in
-    return (fingerp hash fps)
-  | `Cert_fingerprints (hash, fps) -> return (cert_fingerp hash fps)
-  | `Hex_cert_fingerprints (hash, fps) ->
-    let fps = List.map (fun (n, v) -> (n, dotted_hex_to_cs v)) fps in
-    return (cert_fingerp hash fps)
+  | `Key_fingerprint (hash, fp) -> return (fingerp hash fp)
+  | `Hex_key_fingerprint (hash, fp) ->
+    let fp = dotted_hex_to_cs fp in
+    return (fingerp hash fp)
+  | `Cert_fingerprint (hash, fp) -> return (cert_fingerp hash fp)
+  | `Hex_cert_fingerprint (hash, fp) ->
+    let fp = dotted_hex_to_cs fp in
+    return (cert_fingerp hash fp)

lwt/x509_lwt.mli

@@ -18,9 +18,9 @@ val certs_of_pem_dir : Lwt_io.file_name -> X509.Certificate.t list Lwt.t
 val authenticator : ?allowed_hashes:Mirage_crypto.Hash.hash list -> ?crls:Lwt_io.file_name ->
   [ `Ca_file of Lwt_io.file_name
   | `Ca_dir  of Lwt_io.file_name
-  | `Key_fingerprints of Mirage_crypto.Hash.hash * ([`host] Domain_name.t * Cstruct.t) list
-  | `Hex_key_fingerprints of Mirage_crypto.Hash.hash * ([`host] Domain_name.t * string) list
-  | `Cert_fingerprints of Mirage_crypto.Hash.hash * ([`host] Domain_name.t * Cstruct.t) list
-  | `Hex_cert_fingerprints of Mirage_crypto.Hash.hash * ([`host] Domain_name.t * string) list
+  | `Key_fingerprint of Mirage_crypto.Hash.hash * Cstruct.t
+  | `Hex_key_fingerprint of Mirage_crypto.Hash.hash * string
+  | `Cert_fingerprint of Mirage_crypto.Hash.hash * Cstruct.t
+  | `Hex_cert_fingerprint of Mirage_crypto.Hash.hash * string
   ]
   -> X509.Authenticator.t Lwt.t

mirage/tls_mirage.ml

@@ -218,7 +218,7 @@ module X509 (KV : Mirage_kv.RO) (C: Mirage_clock.PCLOCK) = struct
 
   let err_fail pp = function
     | Ok x -> return x
-    | Error e -> Fmt.kstrf fail_with "%a" pp e
+    | Error e -> Fmt.kstr fail_with "%a" pp e
 
   let pp_msg ppf = function `Msg m -> Fmt.string ppf m
 

tests/feedback.ml

@@ -33,7 +33,7 @@ let loop_chatter ~certificate ~loops ~size =
   let message  = Mirage_crypto_rng.generate size
   and server   = Tls.(Engine.server (Config.server ~certificates:(`Single certificate) ()))
   and (client, init) =
-    let authenticator ~host:_ _ = Ok None in
+    let authenticator ?ip:_ ~host:_ _ = Ok None in
     Tls.(Engine.client @@ Config.client ~authenticator ())
   in
   Testlib.time @@ fun () ->

tls-mirage.opam

@@ -18,7 +18,7 @@ depends: [
   "dune" {>= "1.0"}
   "tls" {= version}
   "x509" {>= "0.13.0"}
-  "fmt"
+  "fmt" {>= "0.8.7"}
   "lwt" {>= "3.0.0"}
   "mirage-flow" {>= "2.0.0"}
   "mirage-kv" {>= "3.0.0"}

tls.opam

@@ -25,16 +25,18 @@ depends: [
   "mirage-crypto-ec" {>= "0.10.0"}
   "mirage-crypto-pk"
   "mirage-crypto-rng" {>= "0.8.0"}
-  "x509" {>= "0.13.0"}
+  "x509" {>= "0.15.0"}
   "domain-name" {>= "0.3.0"}
-  "fmt"
+  "fmt" {>= "0.8.7"}
   "rresult"
   "cstruct-unix" {with-test & >= "3.0.0"}
   "ounit2" {with-test & >= "2.2.0"}
   "lwt" {>= "3.0.0"}
   "ptime" {>= "0.8.1"}
   "hkdf"
   "logs"
+  "ipaddr"
+  "ipaddr-sexp"
   "alcotest" {with-test}
   "randomconv" {with-test}
 ]