From a66fa773a5b8de5355fab3fd8c17deadd3339069 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 1 Mar 2023 13:10:47 +0100 Subject: [PATCH] remove ppx (cstruct and sexplib), removing sexplib converters (#473) This reduces the build dependency cone, and also the binary size of the library --- async/io.ml | 14 +- eio/tests/tls_eio.md | 6 +- eio/tls_eio.ml | 2 +- lib/ciphersuite.ml | 75 +++- lib/config.ml | 91 +++-- lib/config.mli | 12 +- lib/core.ml | 227 +++++++----- lib/dune | 3 +- lib/engine.ml | 51 ++- lib/engine.mli | 8 +- lib/handshake_client.ml | 14 +- lib/handshake_client13.ml | 9 +- lib/handshake_common.ml | 9 +- lib/handshake_server.ml | 26 +- lib/handshake_server13.ml | 25 +- lib/packet.ml | 562 ++++++++++++++++++++++++++--- lib/reader.ml | 56 ++- lib/reader.mli | 4 +- lib/state.ml | 248 ++++++++----- lib/tracing.ml | 21 -- lib/tracing.mli | 13 - lwt/examples/echo_server.ml | 4 +- lwt/examples/ex_common.ml | 2 +- lwt/examples/fuzz_server.ml | 4 +- lwt/examples/resume_client.ml | 1 - lwt/examples/resume_echo_server.ml | 4 +- lwt/examples/test_client.ml | 6 +- lwt/tls_lwt.ml | 2 +- mirage/tls_mirage.ml | 2 +- tests/feedback.ml | 2 +- tests/key_derivation.ml | 4 +- tls.opam | 5 - 32 files changed, 1058 insertions(+), 454 deletions(-) delete mode 100644 lib/tracing.ml delete mode 100644 lib/tracing.mli diff --git a/async/io.ml b/async/io.ml index fe3704f7..bb62b46e 100644 --- a/async/io.ml +++ b/async/io.ml @@ -3,10 +3,20 @@ open! Async include Io_intf module Tls_error = struct + module Alert = struct + type t = Tls.Packet.alert_type + let sexp_of_t a = + Sexplib.Sexp.Atom (Tls.Packet.alert_type_to_string a) + end + module Fail = struct + type t = Tls.Engine.failure + let sexp_of_t a = + Sexplib.Sexp.Atom (Fmt.to_to_string Tls.Engine.pp_failure a) + end type t = - | Tls_alert of Tls.Packet.alert_type + | Tls_alert of Alert.t (** [Tls_alert] exception received from the other endpoint *) - | Tls_failure of Tls.Engine.failure + | Tls_failure of Fail.t (** [Tls_failure] exception while processing incoming data *) | Connection_closed | Connection_not_ready diff --git a/eio/tests/tls_eio.md b/eio/tests/tls_eio.md index dace2d70..285acea1 100644 --- a/eio/tests/tls_eio.md +++ b/eio/tests/tls_eio.md @@ -19,11 +19,7 @@ let mypsk = ref None let ticket_cache = { Tls.Config.lookup = (fun _ -> None) ; - ticket_granted = (fun psk epoch -> - Logs.info (fun m -> m "ticket granted %a %a" - Sexplib.Sexp.pp_hum (Tls.Core.sexp_of_psk13 psk) - Sexplib.Sexp.pp_hum (Tls.Core.sexp_of_epoch_data epoch)) ; - mypsk := Some (psk, epoch)) ; + ticket_granted = (fun psk epoch -> mypsk := Some (psk, epoch)) ; lifetime = 0l ; timestamp = Ptime_clock.now } diff --git a/eio/tls_eio.ml b/eio/tls_eio.ml index 2e4eaab9..70ccc198 100644 --- a/eio/tls_eio.ml +++ b/eio/tls_eio.ml @@ -228,5 +228,5 @@ let () = | Tls_alert typ -> Some ("TLS alert from peer: " ^ Tls.Packet.alert_type_to_string typ) | Tls_failure f -> - Some ("TLS failure: " ^ Tls.Engine.string_of_failure f) + Some ("TLS failure: " ^ Fmt.to_to_string Tls.Engine.pp_failure f) | _ -> None) diff --git a/lib/ciphersuite.ml b/lib/ciphersuite.ml index 56cd46e8..8035666b 100644 --- a/lib/ciphersuite.ml +++ b/lib/ciphersuite.ml @@ -1,8 +1,16 @@ (** Ciphersuite definitions and some helper functions. *) (** sum type of all possible key exchange methods *) -type key_exchange_algorithm_dhe = [ `FFDHE | `ECDHE ] [@@deriving sexp_of] -type key_exchange_algorithm = [ key_exchange_algorithm_dhe | `RSA ] [@@deriving sexp_of] +type key_exchange_algorithm_dhe = [ `FFDHE | `ECDHE ] +type key_exchange_algorithm = [ key_exchange_algorithm_dhe | `RSA ] + +let pp_key_exchange_algorithm_dhe ppf = function + | `FFDHE -> Fmt.string ppf "FFDHE" + | `ECDHE -> Fmt.string ppf "ECDHE" + +let pp_key_exchange_algorithm ppf = function + | #key_exchange_algorithm_dhe as d -> pp_key_exchange_algorithm_dhe ppf d + | `RSA -> Fmt.string ppf "RSA" (** [required_usage kex] is [usage] which a certificate must have if it is used in the given [kex] method *) let required_usage = function @@ -13,7 +21,11 @@ type block_cipher = | TRIPLE_DES_EDE_CBC | AES_128_CBC | AES_256_CBC - [@@deriving sexp_of] + +let pp_block_cipher ppf = function + | TRIPLE_DES_EDE_CBC -> Fmt.string ppf "3DES EDE CBC" + | AES_128_CBC -> Fmt.string ppf "AES128 CBC" + | AES_256_CBC -> Fmt.string ppf "AES256 CBC" type aead_cipher = | AES_128_CCM @@ -21,24 +33,35 @@ type aead_cipher = | AES_128_GCM | AES_256_GCM | CHACHA20_POLY1305 - [@@deriving sexp_of] -module H = struct - type t = Mirage_crypto.Hash.hash +let pp_aead_cipher ppf = function + | AES_128_CCM -> Fmt.string ppf "AES128 CCM" + | AES_256_CCM -> Fmt.string ppf "AES256 CCM" + | AES_128_GCM -> Fmt.string ppf "AES128 GCM" + | AES_256_GCM -> Fmt.string ppf "AES256 GCM" + | CHACHA20_POLY1305 -> Fmt.string ppf "CHACHA20 POLY1305" - let hs = - [ (`MD5, "md5") ; (`SHA1, "sha1") ; (`SHA224, "sha224") ; - (`SHA256, "sha256") ; (`SHA384, "sha384") ; (`SHA512, "sha512") ] +type payload_protection13 = [ `AEAD of aead_cipher ] - let sexp_of_t h = Sexplib.Sexp.Atom (List.assoc h hs) -end - -type payload_protection13 = [ `AEAD of aead_cipher ] [@@deriving sexp_of] +let pp_payload_protection13 ppf = function + | `AEAD a -> Fmt.pf ppf "AEAD %a" pp_aead_cipher a type payload_protection = [ payload_protection13 - | `Block of block_cipher * H.t - ] [@@deriving sexp_of] + | `Block of block_cipher * Mirage_crypto.Hash.hash + ] + +let pp_hash ppf = function + | `MD5 -> Fmt.string ppf "MD5" + | `SHA1 -> Fmt.string ppf "SHA1" + | `SHA224 -> Fmt.string ppf "SHA224" + | `SHA256 -> Fmt.string ppf "SHA256" + | `SHA384 -> Fmt.string ppf "SHA384" + | `SHA512 -> Fmt.string ppf "SHA512" + +let pp_payload_protection ppf = function + | #payload_protection13 as p -> pp_payload_protection13 ppf p + | `Block (b, h) -> Fmt.pf ppf "BLOCK %a %a" pp_block_cipher b pp_hash h (* this is K_LEN, max 8 N_MIN from RFC5116 sections 5.1 & 5.2 -- as defined in TLS1.3 RFC 8446 Section 5.3 *) let kn_13 = function @@ -74,7 +97,7 @@ type ciphersuite13 = [ | `AES_256_GCM_SHA384 | `CHACHA20_POLY1305_SHA256 | `AES_128_CCM_SHA256 -] [@@deriving sexp_of] +] let privprot13 = function | `AES_128_GCM_SHA256 -> AES_128_GCM @@ -132,7 +155,7 @@ type ciphersuite = [ | `ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 | `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 | `ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 -] [@@deriving sexp_of] + ] let ciphersuite_to_ciphersuite13 : ciphersuite -> ciphersuite13 option = function | #ciphersuite13 as cs -> Some cs @@ -217,8 +240,6 @@ let ciphersuite_to_any_ciphersuite = function | `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 -> Packet.TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 | `ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 -> Packet.TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 -let ciphersuite_to_string x = Packet.any_ciphersuite_to_string (ciphersuite_to_any_ciphersuite x) - (** [get_kex_privprot ciphersuite] is [(kex, privacy_protection)] where it dissects the [ciphersuite] into a pair containing the key exchange method [kex], and its [privacy_protection] *) let get_keytype_kex_privprot = function | `RSA_WITH_3DES_EDE_CBC_SHA -> (`RSA, `RSA, `Block (TRIPLE_DES_EDE_CBC, `SHA1)) @@ -272,6 +293,22 @@ let ciphersuite_keytype c = let keytype, _kex, _pp = get_keytype_kex_privprot c in keytype +let pp_ciphersuite ppf cs = + let keytype, kex, pp = get_keytype_kex_privprot cs in + let pp_keytype ppf = function + | `EC -> Fmt.string ppf "ECDSA" + | `RSA -> Fmt.string ppf "RSA" + in + match cs with + | #ciphersuite13 -> Fmt.pf ppf "%a" pp_payload_protection pp + | _ -> Fmt.pf ppf "%a %a %a" pp_key_exchange_algorithm kex pp_keytype keytype + pp_payload_protection pp + +let pp_any_ciphersuite ppf cs = + match any_ciphersuite_to_ciphersuite cs with + | Some cs -> pp_ciphersuite ppf cs + | None -> Fmt.pf ppf "ciphersuite %04X" (Packet.any_ciphersuite_to_int cs) + let ciphersuite_fs cs = match ciphersuite_kex cs with | #key_exchange_algorithm_dhe -> true diff --git a/lib/config.ml b/lib/config.ml index f8e02d0c..d9a3a743 100644 --- a/lib/config.ml +++ b/lib/config.ml @@ -1,31 +1,39 @@ open Core -open Sexplib.Std - let src = Logs.Src.create "tls.config" ~doc:"TLS config" module Log = (val Logs.src_log src : Logs.LOG) -type certchain = Cert.t list * Priv.t [@@deriving sexp_of] +type certchain = X509.Certificate.t list * X509.Private_key.t type own_cert = [ | `None | `Single of certchain | `Multiple of certchain list | `Multiple_default of certchain * certchain list -] [@@deriving sexp_of] +] + +let pp_cert ppf cs = + let from, until = X509.Certificate.validity cs in + Fmt.pf ppf "subject %a@ issuer %a@ valid from %a until %a" + X509.Distinguished_name.pp (X509.Certificate.subject cs) + X509.Distinguished_name.pp (X509.Certificate.issuer cs) + (Ptime.pp_human ~tz_offset_s:0 ()) from + (Ptime.pp_human ~tz_offset_s:0 ()) until + +let pp_certchain ppf (chain, _) = + Fmt.(list ~sep:(any "@.") pp_cert) ppf chain + +let pp_own_cert ppf = function + | `None -> Fmt.string ppf "NONE" + | `Single chain -> pp_certchain ppf chain + | `Multiple cs -> + Fmt.pf ppf "multiple: %a" Fmt.(list ~sep:(any "@.@.") pp_certchain) cs + | `Multiple_default (c, cs) -> + Fmt.pf ppf "multiple default:@.%a@.others:@.%a" + pp_certchain c + Fmt.(list ~sep:(any "@.@.") pp_certchain) cs type session_cache = SessionID.t -> epoch_data option -let sexp_of_session_cache _ = Sexplib.Sexp.Atom "SESSION_CACHE" - -module Auth = struct - type t = X509.Authenticator.t - let sexp_of_t _ = Sexplib.Sexp.Atom "Authenticator" -end - -module DN = struct - type t = X509.Distinguished_name.t - let sexp_of_t _ = Sexplib.Sexp.Atom "distinguished name" -end type ticket_cache = { lookup : Cstruct.t -> (psk13 * epoch_data) option ; @@ -34,28 +42,50 @@ type ticket_cache = { timestamp : unit -> Ptime.t } -type ticket_cache_opt = ticket_cache option -let sexp_of_ticket_cache_opt _ = Sexplib.Sexp.Atom "TICKET_CACHE" - (* TODO: min_rsa, min_dh *) type config = { ciphers : Ciphersuite.ciphersuite list ; protocol_versions : tls_version * tls_version ; signature_algorithms : signature_algorithm list ; use_reneg : bool ; - authenticator : Auth.t option ; - peer_name : Peer_name.t option ; + authenticator : X509.Authenticator.t option ; + peer_name : [`host] Domain_name.t option ; own_certificates : own_cert ; - acceptable_cas : DN.t list ; + acceptable_cas : X509.Distinguished_name.t list ; session_cache : session_cache ; - ticket_cache : ticket_cache_opt ; + ticket_cache : ticket_cache option ; cached_session : epoch_data option ; cached_ticket : (psk13 * epoch_data) option ; alpn_protocols : string list ; groups : group list ; zero_rtt : int32 ; - ip : Ipaddr_sexp.t option ; -} [@@deriving sexp_of] + ip : Ipaddr.t option ; +} + +let pp_config ppf cfg = + Fmt.pf ppf + "ciphers: %a@. \ + minimal protocol version: %a@. \ + maximum protocol version: %a@. \ + signature algorithms: %a@. \ + renegotiation enabled %B@. \ + peer name: %a@. \ + own certificate: %a@. \ + acceptable CAs: %a@. \ + alpn protocols: %a@. \ + groups: %a@. \ + IP: %a@." + Fmt.(list ~sep:(any ", ") Ciphersuite.pp_ciphersuite) cfg.ciphers + pp_tls_version (fst cfg.protocol_versions) + pp_tls_version (snd cfg.protocol_versions) + Fmt.(list ~sep:(any ", ") pp_signature_algorithm) cfg.signature_algorithms + cfg.use_reneg + Fmt.(option ~none:(any "none provided") Domain_name.pp) cfg.peer_name + pp_own_cert cfg.own_certificates + Fmt.(list ~sep:(any ", ") X509.Distinguished_name.pp) cfg.acceptable_cas + Fmt.(list ~sep:(any ", ") string) cfg.alpn_protocols + Fmt.(list ~sep:(any ", ") pp_group) cfg.groups + Fmt.(option ~none:(any "none provided") Ipaddr.pp) cfg.ip let ciphers13 cfg = List.rev @@ -510,11 +540,8 @@ let validate_keys_sig_algs config = then invalid "certificate provided which does not allow any signature algorithm" -type client = config [@@deriving sexp_of] -type server = config [@@deriving sexp_of] - -let client_of_sexp _ = invalid_arg "couldn't decode client configuration" -let server_of_sexp _ = invalid_arg "couldn't decode server configuration" +type client = config +type server = config let of_server conf = conf and of_client conf = conf @@ -551,8 +578,7 @@ let client } in let config = validate_common config in validate_client config ; - Log.debug (fun m -> m "client with %s" - (Sexplib.Sexp.to_string_hum (sexp_of_config config))); + Log.debug (fun m -> m "client with %a" pp_config config); config let server @@ -578,6 +604,5 @@ let server let config = validate_server config in let config = validate_common config in validate_keys_sig_algs config; - Log.debug (fun m -> m "server with %s" - (Sexplib.Sexp.to_string_hum (sexp_of_config config))); + Log.debug (fun m -> m "server with %a" pp_config config); config diff --git a/lib/config.mli b/lib/config.mli index e770c6c6..cf547f79 100644 --- a/lib/config.mli +++ b/lib/config.mli @@ -5,7 +5,7 @@ open Core (** {1 Config type} *) (** certificate chain and private key of the first certificate *) -type certchain = Cert.t list * X509.Private_key.t +type certchain = X509.Certificate.t list * X509.Private_key.t (** polymorphic variant of own certificates *) type own_cert = [ @@ -24,8 +24,6 @@ type ticket_cache = { timestamp : unit -> Ptime.t } -type ticket_cache_opt = ticket_cache option - (** configuration parameters *) type config = private { ciphers : Ciphersuite.ciphersuite list ; (** ordered list (regarding preference) of supported cipher suites *) @@ -37,23 +35,23 @@ type config = private { 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 ; - ticket_cache : ticket_cache_opt ; + ticket_cache : ticket_cache option ; cached_session : epoch_data option ; cached_ticket : (psk13 * epoch_data) option ; 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. *) val ciphers13 : config -> Ciphersuite.ciphersuite13 list (** opaque type of a client configuration *) -type client [@@deriving sexp] +type client (** opaque type of a server configuration *) -type server [@@deriving sexp] +type server (** {1 Constructors} *) diff --git a/lib/core.ml b/lib/core.ml index c4b2c36d..f7561d70 100644 --- a/lib/core.ml +++ b/lib/core.ml @@ -1,7 +1,5 @@ (** Core type definitions *) -open Sexplib.Conv - open Packet open Ciphersuite @@ -13,15 +11,26 @@ let guard p e = if p then Ok () else Error e let map_reader_error r = Result.map_error (fun re -> `Fatal (`ReaderError re)) r -type tls13 = [ `TLS_1_3 ] [@@deriving sexp_of] +type tls13 = [ `TLS_1_3 ] + +let pp_tls13 ppf `TLS_1_3 = Fmt.string ppf "TLS 1.3" type tls_before_13 = [ | `TLS_1_0 | `TLS_1_1 | `TLS_1_2 -] [@@deriving sexp_of] +] + +let pp_tls_before_13 ppf = function + | `TLS_1_0 -> Fmt.string ppf "TLS 1.0" + | `TLS_1_1 -> Fmt.string ppf "TLS 1.1" + | `TLS_1_2 -> Fmt.string ppf "TLS 1.2" -type tls_version = [ tls13 | tls_before_13 ] [@@deriving sexp_of] +type tls_version = [ tls13 | tls_before_13 ] + +let pp_tls_version ppf = function + | #tls13 as v -> pp_tls13 ppf v + | #tls_before_13 as v -> pp_tls_before_13 ppf v let pair_of_tls_version = function | `TLS_1_0 -> (3, 1) @@ -63,7 +72,12 @@ type tls_any_version = [ | tls_version | `SSL_3 | `TLS_1_X of int -] [@@deriving sexp_of] +] + +let pp_tls_any_version ppf = function + | #tls_version as v -> pp_tls_version ppf v + | `SSL_3 -> Fmt.string ppf "SSL3" + | `TLS_1_X x -> Fmt.pf ppf "TLS1.%u" x let any_version_to_version = function | #tls_version as v -> Some v @@ -100,23 +114,27 @@ let min_protocol_version (lo, _) = lo type tls_hdr = { content_type : content_type; version : tls_any_version; -} [@@deriving sexp_of] +} + +let pp_tls_hdr ppf { content_type ; version } = + Fmt.pf ppf "content type: %a version: %a" pp_content_type content_type + pp_tls_any_version version module SessionID = struct - type t = Cstruct_sexp.t [@@deriving sexp_of] + type t = Cstruct.t let compare = Cstruct.compare let hash t = Hashtbl.hash (Cstruct.to_bigarray t) let equal = Cstruct.equal end module PreSharedKeyID = struct - type t = Cstruct_sexp.t [@@deriving sexp_of] + type t = Cstruct.t let compare = Cstruct.compare let hash t = Hashtbl.hash (Cstruct.to_bigarray t) let equal = Cstruct.equal end -type psk_identity = (Cstruct_sexp.t * int32) * Cstruct_sexp.t [@@deriving sexp_of] +type psk_identity = (Cstruct.t * int32) * Cstruct.t let binders_len psks = let binder_len (_, binder) = @@ -134,7 +152,18 @@ type group = [ | `P256 | `P384 | `P521 -] [@@deriving sexp_of] +] + +let pp_group ppf = function + | `FFDHE2048 -> Fmt.string ppf "FFDHE2048" + | `FFDHE3072 -> Fmt.string ppf "FFDHE3072" + | `FFDHE4096 -> Fmt.string ppf "FFDHE4096" + | `FFDHE6144 -> Fmt.string ppf "FFDHE6144" + | `FFDHE8192 -> Fmt.string ppf "FFDHE8192" + | `X25519 -> Fmt.string ppf "X25519" + | `P256 -> Fmt.string ppf "P256" + | `P384 -> Fmt.string ppf "P384" + | `P521 -> Fmt.string ppf "P521" let named_group_to_group = function | FFDHE2048 -> Some `FFDHE2048 @@ -189,7 +218,7 @@ type signature_algorithm = [ | `RSA_PSS_PSS_SHA256 | `RSA_PSS_PSS_SHA384 | `RSA_PSS_PSS_SHA512 *) -] [@@deriving sexp_of] +] let hash_of_signature_algorithm = function | `RSA_PKCS1_MD5 -> `MD5 @@ -223,6 +252,29 @@ let signature_scheme_of_signature_algorithm = function | `ECDSA_SECP521R1_SHA512 -> `ECDSA | `ED25519 -> `ED25519 +let pp_signature_algorithm ppf sa = + let h = hash_of_signature_algorithm sa + and ss = signature_scheme_of_signature_algorithm sa + in + let pp_signature_scheme ppf = function + | `RSA_PKCS1 -> Fmt.string ppf "RSA-PKCS1" + | `RSA_PSS -> Fmt.string ppf "RSA-PSS" + | `ECDSA -> Fmt.string ppf "ECDSA" + | `ED25519 -> Fmt.string ppf "ED25519" + in + match ss with + | `ED25519 -> Fmt.pf ppf "%a" pp_signature_scheme ss + | `ECDSA -> + let group_to_string = function + | `ECDSA_SECP256R1_SHA1 -> "SECP256R1" + | `ECDSA_SECP256R1_SHA256 -> "SECP256R1" + | `ECDSA_SECP384R1_SHA384 -> "SECP384R1" + | `ECDSA_SECP521R1_SHA512 -> "SECP521R1" + | _ -> assert false + in + Fmt.pf ppf "%a %s %a" pp_signature_scheme ss (group_to_string sa) pp_hash h + | _ -> Fmt.pf ppf "%a %a" pp_signature_scheme ss pp_hash h + let rsa_sigalg = function | `RSA_PSS_RSAENC_SHA256 | `RSA_PSS_RSAENC_SHA384 | `RSA_PSS_RSAENC_SHA512 | `RSA_PKCS1_SHA256 | `RSA_PKCS1_SHA384 | `RSA_PKCS1_SHA512 @@ -247,47 +299,42 @@ 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 Peer_name.t + | `Hostname of [`host] Domain_name.t | `MaxFragmentLength of max_fragment_length | `SupportedGroups of Packet.named_group list - | `SecureRenegotiation of Cstruct_sexp.t + | `SecureRenegotiation of Cstruct.t | `Padding of int | `SignatureAlgorithms of signature_algorithm list | `ExtendedMasterSecret | `ALPN of string list - | `KeyShare of (Packet.named_group * Cstruct_sexp.t) list + | `KeyShare of (Packet.named_group * Cstruct.t) list | `EarlyDataIndication | `PreSharedKeys of psk_identity list | `SupportedVersions of tls_any_version list | `PostHandshakeAuthentication - | `Cookie of Cstruct_sexp.t + | `Cookie of Cstruct.t | `PskKeyExchangeModes of psk_key_exchange_mode list | `ECPointFormats - | `UnknownExtension of (int * Cstruct_sexp.t) -] [@@deriving sexp_of] + | `UnknownExtension of (int * Cstruct.t) +] type server13_extension = [ - | `KeyShare of (group * Cstruct_sexp.t) + | `KeyShare of (group * Cstruct.t) | `PreSharedKey of int | `SelectedVersion of tls_version (* only used internally in writer!! *) -] [@@deriving sexp_of] +] type server_extension = [ server13_extension | `Hostname | `MaxFragmentLength of max_fragment_length - | `SecureRenegotiation of Cstruct_sexp.t + | `SecureRenegotiation of Cstruct.t | `ExtendedMasterSecret | `ALPN of string | `ECPointFormats - | `UnknownExtension of (int * Cstruct_sexp.t) -] [@@deriving sexp_of] + | `UnknownExtension of (int * Cstruct.t) +] type encrypted_extension = [ | `Hostname @@ -295,37 +342,37 @@ type encrypted_extension = [ | `SupportedGroups of group list | `ALPN of string | `EarlyDataIndication - | `UnknownExtension of (int * Cstruct_sexp.t) -] [@@deriving sexp_of] + | `UnknownExtension of (int * Cstruct.t) +] type hello_retry_extension = [ | `SelectedGroup of group (* only used internally in writer!! *) - | `Cookie of Cstruct_sexp.t + | `Cookie of Cstruct.t | `SelectedVersion of tls_version (* only used internally in writer!! *) - | `UnknownExtension of (int * Cstruct_sexp.t) -] [@@deriving sexp_of] + | `UnknownExtension of (int * Cstruct.t) +] type client_hello = { client_version : tls_any_version; - client_random : Cstruct_sexp.t; + client_random : Cstruct.t; sessionid : SessionID.t option; ciphersuites : any_ciphersuite list; extensions : client_extension list -} [@@deriving sexp_of] +} type server_hello = { server_version : tls_version; - server_random : Cstruct_sexp.t; + server_random : Cstruct.t; sessionid : SessionID.t option; ciphersuite : ciphersuite; extensions : server_extension list -} [@@deriving sexp_of] +} type dh_parameters = { - dh_p : Cstruct_sexp.t; - dh_g : Cstruct_sexp.t; - dh_Ys : Cstruct_sexp.t; -} [@@deriving sexp_of] + dh_p : Cstruct.t; + dh_g : Cstruct.t; + dh_Ys : Cstruct.t; +} type hello_retry = { retry_version : tls_version ; @@ -333,20 +380,20 @@ type hello_retry = { sessionid : SessionID.t option ; selected_group : group ; extensions : hello_retry_extension list -} [@@deriving sexp_of] +} type session_ticket_extension = [ | `EarlyDataIndication of int32 - | `UnknownExtension of int * Cstruct_sexp.t -] [@@deriving sexp_of] + | `UnknownExtension of int * Cstruct.t +] type session_ticket = { lifetime : int32 ; age_add : int32 ; - nonce : Cstruct_sexp.t ; - ticket : Cstruct_sexp.t ; + nonce : Cstruct.t ; + ticket : Cstruct.t ; extensions : session_ticket_extension list -} [@@deriving sexp_of] +} type certificate_request_extension = [ (* | `StatusRequest *) @@ -355,7 +402,7 @@ type certificate_request_extension = [ | `CertificateAuthorities of X509.Distinguished_name.t list (* | `OidFilters *) (* | `SignatureAlgorithmsCert *) - | `UnknownExtension of (int * Cstruct_sexp.t) + | `UnknownExtension of (int * Cstruct.t) ] type tls_handshake = @@ -365,69 +412,77 @@ type tls_handshake = | ServerHelloDone | ClientHello of client_hello | ServerHello of server_hello - | Certificate of Cstruct_sexp.t - | ServerKeyExchange of Cstruct_sexp.t - | CertificateRequest of Cstruct_sexp.t - | ClientKeyExchange of Cstruct_sexp.t - | CertificateVerify of Cstruct_sexp.t - | Finished of Cstruct_sexp.t + | Certificate of Cstruct.t + | ServerKeyExchange of Cstruct.t + | CertificateRequest of Cstruct.t + | ClientKeyExchange of Cstruct.t + | CertificateVerify of Cstruct.t + | Finished of Cstruct.t | SessionTicket of session_ticket | KeyUpdate of key_update_request_type | EndOfEarlyData - [@@deriving sexp_of] - -type tls_alert = alert_level * alert_type [@@deriving sexp_of] - -(** the master secret of a TLS connection *) -type master_secret = Cstruct_sexp.t [@@deriving sexp_of] -module Cert = struct - include X509.Certificate - let sexp_of_t _ = Sexplib.Sexp.Atom "certificate" +let pp_handshake ppf = function + | HelloRequest -> Fmt.string ppf "HelloRequest" + | HelloRetryRequest _ -> Fmt.string ppf "HelloRetryRequest" + | EncryptedExtensions _ -> Fmt.string ppf "EncryptedExtensions" + | ServerHelloDone -> Fmt.string ppf "ServerHelloDone" + | ClientHello _ -> Fmt.string ppf "ClientHello" + | ServerHello _ -> Fmt.string ppf "ServerHello" + | Certificate _ -> Fmt.string ppf "Certificate" + | ServerKeyExchange _ -> Fmt.string ppf "ServerKeyExchange" + | CertificateRequest _ -> Fmt.string ppf "CertificateRequest" + | ClientKeyExchange _ -> Fmt.string ppf "ClientKeyExchange" + | CertificateVerify _ -> Fmt.string ppf "CertificateVerify" + | Finished _ -> Fmt.string ppf "Finished" + | SessionTicket _ -> Fmt.string ppf "SessionTicket" + | KeyUpdate _ -> Fmt.string ppf "KeyUpdate" + | EndOfEarlyData -> Fmt.string ppf "EndOfEarlyData" + +let src = Logs.Src.create "tls.tracing" ~doc:"TLS tracing" +module Tracing = struct + include (val Logs.src_log src : Logs.LOG) + let cs ~tag buf = debug (fun m -> m "%s@.%a" tag Cstruct.hexdump_pp buf) + let hs ~tag hs = debug (fun m -> m "%s %a" tag pp_handshake hs) end -module Priv = struct - include X509.Private_key - let sexp_of_t _ = Sexplib.Sexp.Atom "private key" -end +type tls_alert = alert_level * alert_type -module Ptime = struct - include Ptime - let sexp_of_t ts = Sexplib.Sexp.Atom (Ptime.to_rfc3339 ts) -end +(** the master secret of a TLS connection *) +type master_secret = Cstruct.t type psk13 = { - identifier : Cstruct_sexp.t ; + identifier : Cstruct.t ; obfuscation : int32 ; - secret : Cstruct_sexp.t ; + secret : Cstruct.t ; lifetime : int32 ; early_data : int32 ; issued_at : Ptime.t ; (* origin : [ `Resumption | `External ] (* using different labels for binder_key *) *) -} [@@deriving sexp_of] +} -type epoch_state = [ `ZeroRTT | `Established ] [@@deriving sexp_of] +type epoch_state = [ `ZeroRTT | `Established ] (** information about an open session *) type epoch_data = { state : epoch_state ; protocol_version : tls_version ; ciphersuite : Ciphersuite.ciphersuite ; - peer_random : Cstruct_sexp.t ; - peer_certificate_chain : Cert.t list ; - peer_certificate : Cert.t option ; - peer_name : Peer_name.t option ; - trust_anchor : Cert.t option ; - received_certificates : Cert.t list ; - own_random : Cstruct_sexp.t ; - own_certificate : Cert.t list ; - own_private_key : Priv.t option ; - own_name : Peer_name.t option ; + peer_random : Cstruct.t ; + peer_certificate_chain : X509.Certificate.t list ; + peer_certificate : X509.Certificate.t option ; + peer_name : [`host] Domain_name.t option ; + trust_anchor : X509.Certificate.t option ; + received_certificates : X509.Certificate.t list ; + own_random : Cstruct.t ; + own_certificate : X509.Certificate.t list ; + own_private_key : X509.Private_key.t option ; + own_name : [`host] Domain_name.t option ; master_secret : master_secret ; session_id : SessionID.t ; extended_ms : bool ; alpn_protocol : string option ; -} [@@deriving sexp_of] +} let supports_key_usage ?(not_present = false) usage cert = match X509.Extension.(find Key_usage (X509.Certificate.extensions cert)) with diff --git a/lib/dune b/lib/dune index c2112ee7..ccbf124a 100644 --- a/lib/dune +++ b/lib/dune @@ -1,5 +1,4 @@ (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 ipaddr ipaddr-sexp) - (preprocess (pps ppx_sexp_conv ppx_cstruct))) + (libraries cstruct logs hkdf mirage-crypto mirage-crypto-rng mirage-crypto-pk x509 domain-name fmt mirage-crypto-ec ipaddr)) diff --git a/lib/engine.ml b/lib/engine.ml index b6fc74fb..5c9553e7 100644 --- a/lib/engine.ml +++ b/lib/engine.ml @@ -6,7 +6,7 @@ type state = State.state type client_hello_errors = State.client_hello_errors type error = State.error type fatal = State.fatal -type failure = State.failure [@@deriving sexp_of] +type failure = State.failure let alert_of_authentication_failure = function | `LeafCertificateExpired _ -> Packet.CERTIFICATE_EXPIRED @@ -76,11 +76,7 @@ let alert_of_failure = function | `Error x -> alert_of_error x | `Fatal x -> alert_of_fatal x -let string_of_failure = function - | `Error (`AuthenticationFailure v) -> - let s = Fmt.to_to_string X509.Validation.pp_validation_error v in - "authentication failure: " ^ s - | f -> Sexplib.Sexp.to_string_hum (sexp_of_failure f) +let pp_failure = State.pp_failure type ret = ([ `Ok of state | `Eof | `Alert of Packet.alert_type ] @@ -110,7 +106,14 @@ let new_state config role = fragment = Cstruct.create 0 ; } -type raw_record = tls_hdr * Cstruct_sexp.t [@@deriving sexp_of] +type raw_record = tls_hdr * Cstruct.t + +let pp_raw_record ppf (hdr, data) = + Fmt.pf ppf "%a (%u bytes data)" pp_tls_hdr hdr (Cstruct.length data) + +let pp_frame ppf (ty, data) = + Fmt.pf ppf "%a (%u bytes data)" Packet.pp_content_type ty + (Cstruct.length data) (* well-behaved pure encryptor *) let encrypt (version : tls_version) (st : crypto_state) ty buf = @@ -354,11 +357,11 @@ module Alert = struct let handle buf = let* alert = map_reader_error (Reader.parse_alert buf) in let _, a_type = alert in - Tracing.sexpf ~tag:"alert-in" ~f:sexp_of_tls_alert alert ; + Tracing.debug (fun m -> m "alert-in %a" pp_alert alert) ; let err = match a_type with | CLOSE_NOTIFY -> `Eof | _ -> `Alert a_type in - Tracing.sexpf ~tag:"alert-out" ~f:sexp_of_tls_alert (Packet.WARNING, Packet.CLOSE_NOTIFY) ; + Tracing.debug (fun m -> m "alert-out %a" pp_alert (Packet.WARNING, Packet.CLOSE_NOTIFY)) ; Ok (err, [`Record close_notify]) end @@ -471,7 +474,7 @@ let decrement_early_data hs ty buf = (* the main thingy *) let handle_raw_record state (hdr, buf as record : raw_record) = - Tracing.sexpf ~tag:"record-in" ~f:sexp_of_raw_record record ; + Tracing.debug (fun m -> m "record-in %a" pp_raw_record record) ; let hs = state.handshake in let version = hs.protocol_version in let* () = @@ -489,20 +492,20 @@ let handle_raw_record state (hdr, buf as record : raw_record) = in let* dec_st, dec, ty = decrypt ~trial version state.decryptor hdr.content_type buf in let* handshake = decrement_early_data hs ty buf in - Tracing.sexpf ~tag:"frame-in" ~f:sexp_of_record (ty, dec) ; + Tracing.debug (fun m -> m "frame-in %a" pp_frame (ty, dec)) ; let* handshake, items, data, err = handle_packet handshake dec ty in let encryptor, decryptor, encs = List.fold_left (fun (enc, dec, es) -> function | `Change_enc enc' -> (Some enc', dec, es) | `Change_dec dec' -> (enc, Some dec', es) | `Record r -> - Tracing.sexpf ~tag:"frame-out" ~f:sexp_of_record r ; + Tracing.debug (fun m -> m "frame-out %a" pp_frame r) ; let (enc', encbuf) = encrypt_records enc handshake.protocol_version [r] in (enc', dec, es @ encbuf)) (state.encryptor, dec_st, []) items in - List.iter (Tracing.sexpf ~tag:"record-out" ~f:sexp_of_record) encs ; + List.iter (fun f -> Tracing.debug (fun m -> m "record-out %a" pp_frame f)) encs ; let state' = { state with handshake ; encryptor ; decryptor } in Ok (state', encs, data, err) @@ -518,9 +521,6 @@ let assemble_records (version : tls_version) rs = (* main entry point *) let handle_tls state buf = - - Tracing.sexpf ~tag:"state-in" ~f:sexp_of_state state ; - Tracing.cs ~tag:"wire-in" buf ; let rec handle_records st = function @@ -549,10 +549,10 @@ let handle_tls state buf = | Ok (state, resp, data, err) -> let res = match err with | `Eof -> - Tracing.sexpf ~tag:"eof-out" ~f:Sexplib.Conv.sexp_of_unit () ; + Tracing.debug (fun m -> m "eof-out") ; `Eof | `Alert al -> - Tracing.sexpf ~tag:"ok-alert-out" ~f:Packet.sexp_of_alert_type al ; + Tracing.debug (fun m -> m "ok-alert-out %s" (Packet.alert_type_to_string al)); `Alert al | `No_err -> (* Tracing.sexpf ~tag:"state-out" ~f:sexp_of_state state ; *) @@ -565,16 +565,16 @@ let handle_tls state buf = let record = Alert.make alert in let _, enc = encrypt_records state.encryptor version [record] in let resp = assemble_records version enc in - Tracing.sexpf ~tag:"fail-alert-out" ~f:sexp_of_tls_alert (Packet.FATAL, alert) ; - Tracing.sexpf ~tag:"failure" ~f:sexp_of_failure x ; + Tracing.debug (fun m -> m "fail-alert-out %a" Packet.pp_alert (Packet.FATAL, alert)) ; + Tracing.debug (fun m -> m "failure %a" pp_failure x) ; Error (x, `Response resp) let send_records (st : state) records = let version = st.handshake.protocol_version in - List.iter (Tracing.sexpf ~tag:"frame-out" ~f:sexp_of_record) records ; + List.iter (fun f -> Tracing.debug (fun m -> m "frame-out %a" pp_frame f)) records ; let (encryptor, encs) = encrypt_records st.encryptor version records in - List.iter (Tracing.sexpf ~tag:"record-out" ~f:sexp_of_record) encs ; + List.iter (fun f -> Tracing.debug (fun m -> m "record-out %a" pp_frame f)) encs ; let data = assemble_records version encs in Tracing.cs ~tag:"wire-out" data ; ({ st with encryptor }, data) @@ -591,7 +591,7 @@ let handshake_in_progress s = match s.handshake.machina with let send_application_data st css = match can_handle_appdata st with | true -> - Tracing.css ~tag:"application-data-out" css ; + List.iter (fun cs -> Tracing.cs ~tag:"application-data-out" cs) css ; let datas = match st.encryptor with (* Mitigate implicit IV in CBC mode: prepend empty fragment *) | Some { cipher_st = CBC { iv_mode = Iv _ ; _ } ; _ } -> Cstruct.create 0 :: css @@ -728,8 +728,7 @@ let client config = } in let state = { state with handshake } in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake ch ; - Tracing.sexpf ~tag:"state-out" ~f:sexp_of_state state ; + Tracing.hs ~tag:"handshake-out" ch ; send_records state [(Packet.HANDSHAKE, raw)] let server config = new_state Config.(of_server config) `Server @@ -737,7 +736,7 @@ let server config = new_state Config.(of_server config) `Server type epoch = [ | `InitialEpoch | `Epoch of epoch_data -] [@@deriving sexp_of] +] let epoch state = match epoch_of_hs state.handshake with diff --git a/lib/engine.mli b/lib/engine.mli index 082956c9..aa3ed4d2 100644 --- a/lib/engine.mli +++ b/lib/engine.mli @@ -127,13 +127,13 @@ type fatal = [ type failure = [ | `Error of error | `Fatal of fatal -] [@@deriving sexp_of] +] (** [alert_of_failure failure] is [alert], the TLS alert type for this failure. *) val alert_of_failure : failure -> Packet.alert_type -(** [string_of_failure failure] is [string], the string representation of the [failure]. *) -val string_of_failure : failure -> string +(** [pp_failure failure] pretty-prints failure. *) +val pp_failure : failure Fmt.t (** {1 Protocol handling} *) @@ -192,7 +192,7 @@ val key_update : ?request:bool -> state -> (state * Cstruct.t, failure) result type epoch = [ | `InitialEpoch | `Epoch of Core.epoch_data -] [@@deriving sexp_of] +] (** [epoch state] is [epoch], which contains the session information. *) diff --git a/lib/handshake_client.ml b/lib/handshake_client.ml index 2510eab4..9252e10d 100644 --- a/lib/handshake_client.ml +++ b/lib/handshake_client.ml @@ -156,7 +156,7 @@ let answer_server_hello state (ch : client_hello) sh secrets raw log = (List.mem `ExtendedMasterSecret sh.extensions && epoch.extended_ms)) in - Tracing.sexpf ~tag:"version" ~f:sexp_of_tls_version sh.server_version ; + Tracing.debug (fun m -> m "version %a" pp_tls_version sh.server_version) ; trace_cipher sh.ciphersuite ; let state = { state with protocol_version = sh.server_version } in @@ -408,10 +408,10 @@ let answer_server_hello_done state (session : session_data) sigalgs kex premaste let machina = AwaitServerChangeCipherSpec (session, server_ctx, checksum, ps) and ccst, ccs = change_cipher_spec in - List.iter (Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake) msgs; + List.iter (Tracing.hs ~tag:"handshake-out") msgs; Tracing.cs ~tag:"change-cipher-spec-out" ccs ; Tracing.cs ~tag:"master-secret" master_secret; - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake fin; + Tracing.hs ~tag:"handshake-out" fin; Ok ({ state with machina = Client machina }, List.map (fun x -> `Record (Packet.HANDSHAKE, x)) raw_msgs @ @@ -447,7 +447,7 @@ let answer_server_finished_resume state (session : session_data) fin raw log = in let finished = Finished client in let raw_finished = Writer.assemble_handshake finished in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake finished ; + Tracing.hs ~tag:"handshake-out" finished ; Ok ({ state with machina = Client machina ; session = `TLS session :: state.session }, [`Record (Packet.HANDSHAKE, raw_finished)]) @@ -457,7 +457,7 @@ let answer_hello_request state = let ch = { dch with extensions = dch.extensions @ exts ; sessionid = None } in let raw = Writer.assemble_handshake (ClientHello ch) in let machina = AwaitServerHelloRenegotiate (session, ch, [raw]) in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake (ClientHello ch) ; + Tracing.hs ~tag:"handshake-out" (ClientHello ch) ; ({ state with machina = Client machina }, [`Record (Packet.HANDSHAKE, raw)]) in @@ -468,7 +468,7 @@ let answer_hello_request state = | true , _ -> Error (`Fatal `InvalidSession) (* I'm pretty sure this can be an assert false *) | false, _ -> let no_reneg = Writer.assemble_alert ~level:Packet.WARNING Packet.NO_RENEGOTIATION in - Tracing.sexpf ~tag:"alert-out" ~f:sexp_of_tls_alert (Packet.WARNING, Packet.NO_RENEGOTIATION) ; + Tracing.debug (fun m -> m "alert-out (warning, no_renegotiation)") ; Ok (state, [`Record (Packet.ALERT, no_reneg)]) let handle_change_cipher_spec cs state packet = @@ -498,7 +498,7 @@ let handle_change_cipher_spec cs state packet = let handle_handshake cs hs buf = let open Reader in let* handshake = map_reader_error (parse_handshake buf) in - Tracing.sexpf ~tag:"handshake-in" ~f:sexp_of_tls_handshake handshake ; + Tracing.hs ~tag:"handshake-in" handshake ; match cs, handshake with | AwaitServerHello (ch, secrets, log), ServerHello sh -> answer_server_hello hs ch sh secrets buf log diff --git a/lib/handshake_client13.ml b/lib/handshake_client13.ml index c6ecfa8c..a63eb47f 100644 --- a/lib/handshake_client13.ml +++ b/lib/handshake_client13.ml @@ -81,7 +81,7 @@ let answer_hello_retry_request state (ch : client_hello) hrr _secrets raw log = let ch0_hdr = Writer.assemble_message_hash (Cstruct.length ch0_data) in let st = AwaitServerHello13 (new_ch, [secret], Cstruct.concat [ ch0_hdr ; ch0_data ; raw ; new_ch_raw ]) in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake (ClientHello new_ch); + Tracing.hs ~tag:"handshake-out" (ClientHello new_ch); Ok ({ state with machina = Client13 st ; protocol_version = `TLS_1_3 }, [`Record (Packet.HANDSHAKE, new_ch_raw)]) let answer_encrypted_extensions state (session : session_data13) server_hs_secret client_hs_secret ee raw log = @@ -159,6 +159,7 @@ let answer_finished state (session : session_data13) server_hs_secret client_hs_ Certificate (Writer.assemble_certificates_1_3 Cstruct.empty cs) in let cert_raw = Writer.assemble_handshake certificate in + Tracing.hs ~tag:"handshake-out" certificate ; let log = log <+> cert_raw in match own_private_key with | None -> @@ -170,6 +171,7 @@ let answer_finished state (session : session_data13) server_hs_secret client_hs_ tbs sigalgs state.config.Config.signature_algorithms priv in let cv = CertificateVerify signed in + Tracing.hs ~tag:"handshake-out" cv ; let cv_raw = Writer.assemble_handshake cv in Ok ([ cert_raw ; cv_raw ], log <+> cv_raw) else @@ -183,7 +185,7 @@ let answer_finished state (session : session_data13) server_hs_secret client_hs_ let session = { session with resumption_secret ; client_app_secret ; server_app_secret } in let machina = Client13 Established13 in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake (Finished myfin); + Tracing.hs ~tag:"handshake-out" (Finished myfin); Ok ({ state with machina ; session = `TLS13 session :: state.session }, List.map (fun data -> `Record (Packet.HANDSHAKE, data)) c_cv @ @@ -227,6 +229,7 @@ let handle_key_update state req = Handshake_crypto13.app_secret_n_1 session.master_secret session.client_app_secret in let ku = KeyUpdate Packet.UPDATE_NOT_REQUESTED in + Tracing.hs ~tag:"handshake-out" ku ; let ku_raw = Writer.assemble_handshake ku in { session' with client_app_secret }, [ `Record (Packet.HANDSHAKE, ku_raw); `Change_enc client_ctx ] @@ -239,7 +242,7 @@ let handle_key_update state req = let handle_handshake cs hs buf = let open Reader in let* handshake = map_reader_error (parse_handshake buf) in - Tracing.sexpf ~tag:"handshake-in" ~f:sexp_of_tls_handshake handshake; + Tracing.hs ~tag:"handshake-in" handshake; match cs, handshake with | AwaitServerHello13 (ch, secrets, log), ServerHello sh -> answer_server_hello hs ch sh secrets buf log diff --git a/lib/handshake_common.ml b/lib/handshake_common.ml index f46cb5d5..68e1d1cc 100644 --- a/lib/handshake_common.ml +++ b/lib/handshake_common.ml @@ -7,14 +7,7 @@ let src = Logs.Src.create "handshake" ~doc:"TLS handshake" module Log = (val Logs.src_log src : Logs.LOG) let trace_cipher cipher = - let kex = Ciphersuite.ciphersuite_kex cipher - and papr = Ciphersuite.ciphersuite_privprot cipher - in - let sexp = lazy (Sexplib.Sexp.(List Ciphersuite.( - [ sexp_of_key_exchange_algorithm kex ; - sexp_of_payload_protection papr ]))) - in - Tracing.sexp ~tag:"cipher" sexp + Tracing.debug (fun m -> m "%a" Ciphersuite.pp_ciphersuite cipher) let empty = function [] -> true | _ -> false diff --git a/lib/handshake_server.ml b/lib/handshake_server.ml index 97bc6597..1861d34d 100644 --- a/lib/handshake_server.ml +++ b/lib/handshake_server.ml @@ -10,7 +10,7 @@ let state_version state = match state.protocol_version with let hello_request state = if state.config.use_reneg then let hr = HelloRequest in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake hr ; + Tracing.hs ~tag:"handshake-out" hr ; let state = { state with machina = Server AwaitClientHelloRenegotiate } in Ok (state, [`Record (Packet.HANDSHAKE, Writer.assemble_handshake hr)]) else @@ -35,7 +35,7 @@ let answer_client_finished state (session : session_data) client_fin raw log = let session = { session with renegotiation = (client, server) } and machina = Server Established in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake fin ; + Tracing.hs ~tag:"handshake-out" fin ; Ok ({ state with machina ; session = `TLS session :: state.session }, [`Record (Packet.HANDSHAKE, fin_raw)]) @@ -230,8 +230,8 @@ let server_hello config (client_hello : client_hello) (session : session_data) v extensions = secren :: host @ ems @ alpn @ ecpointformat } in trace_cipher session.ciphersuite ; - Tracing.sexpf ~tag:"version" ~f:sexp_of_tls_version version ; - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake sh ; + Tracing.debug (fun m -> m "version %a" pp_tls_version version) ; + Tracing.hs ~tag:"handshake-out" sh ; let common_session_data = { session.common_session_data with server_random } in (Writer.assemble_handshake sh, { session with common_session_data ; session_id }) @@ -303,7 +303,7 @@ let answer_client_hello_common state reneg ch raw = let extended_ms = List.mem `ExtendedMasterSecret ch.extensions in - Tracing.sexpf ~tag:"cipher" ~f:Ciphersuite.sexp_of_ciphersuite cipher ; + Log.debug (fun m -> m "cipher %a" Ciphersuite.pp_ciphersuite cipher) ; let* alpn_protocol = alpn_protocol config ch in @@ -340,7 +340,7 @@ let answer_client_hello_common state reneg ch raw = | certs -> let cs = List.map X509.Certificate.encode_der certs in let cert = Certificate (Writer.assemble_certificates cs) in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake cert ; + Tracing.hs ~tag:"handshake-out" cert ; [ Writer.assemble_handshake cert ] and cert_request version config (session : session_data) = @@ -368,7 +368,7 @@ let answer_client_hello_common state reneg ch raw = Error (`Fatal (`BadRecordVersion (version :> tls_any_version))) in let certreq = CertificateRequest data in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake certreq ; + Tracing.hs ~tag:"handshake-out" certreq ; let common_session_data = { session.common_session_data with client_auth = true } in Ok ([ assemble_handshake certreq ], { session with common_session_data }) @@ -406,7 +406,7 @@ let answer_client_hello_common state reneg ch raw = let* sgn = signature version data sig_algs config.signature_algorithms priv in let kex = ServerKeyExchange (written <+> sgn) in let hs = Writer.assemble_handshake kex in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake kex ; + Tracing.hs ~tag:"handshake-out" kex ; Ok (hs, secret) in @@ -433,7 +433,7 @@ let answer_client_hello_common state reneg ch raw = else AwaitClientKeyExchange_DHE (session, dh, log) in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake ServerHelloDone ; + Tracing.hs ~tag:"handshake-out" ServerHelloDone ; Ok (outs, machina) | `RSA -> let outs = sh :: certificates @ cert_req @ [ hello_done ] in @@ -444,7 +444,7 @@ let answer_client_hello_common state reneg ch raw = else AwaitClientKeyExchange_RSA (session, log) in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake ServerHelloDone ; + Tracing.hs ~tag:"handshake-out" ServerHelloDone ; Ok (outs, machina) in @@ -528,7 +528,7 @@ let answer_client_hello state (ch : client_hello) raw = let fin = Finished server in let fin_raw = Writer.assemble_handshake fin in Tracing.cs ~tag:"change-cipher-spec-out" (snd ccs) ; - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake fin ; + Tracing.hs ~tag:"handshake-out" fin ; let machina = AwaitClientChangeCipherSpecResume (session, client_ctx, server, log @ [fin_raw]) in Ok ({ state with machina = Server machina }, [ `Record (Packet.HANDSHAKE, sh) ; @@ -598,7 +598,7 @@ let answer_client_hello_reneg state (ch : client_hello) raw = answer_client_hello_common state (Some reneg) ch raw | false, _ -> let no_reneg = Writer.assemble_alert ~level:Packet.WARNING Packet.NO_RENEGOTIATION in - Tracing.sexpf ~tag:"alert-out" ~f:sexp_of_tls_alert (Packet.WARNING, Packet.NO_RENEGOTIATION) ; + Tracing.debug (fun m -> m "alert-out (warning, no_renegotiation)") ; Ok (state, [`Record (Packet.ALERT, no_reneg)]) | true , _ -> Error (`Fatal `InvalidSession) (* I'm pretty sure this can be an assert false *) @@ -633,7 +633,7 @@ let handle_change_cipher_spec ss state packet = let handle_handshake ss hs buf = let* handshake = map_reader_error (Reader.parse_handshake buf) in - Tracing.sexpf ~tag:"handshake-in" ~f:sexp_of_tls_handshake handshake; + Tracing.hs ~tag:"handshake-in" handshake; match ss, handshake with | AwaitClientHello, ClientHello ch -> answer_client_hello hs ch buf diff --git a/lib/handshake_server13.ml b/lib/handshake_server13.ml index 7d7fe406..f8f6c80e 100644 --- a/lib/handshake_server13.ml +++ b/lib/handshake_server13.ml @@ -14,7 +14,7 @@ let answer_client_hello ~hrr state ch raw = guard (not (hrr && List.mem `EarlyDataIndication ch.extensions)) (`Fatal (`InvalidClientHello `Has0rttAfterHRR)) in - Tracing.sexpf ~tag:"version" ~f:sexp_of_tls_version `TLS_1_3 ; + Tracing.debug (fun m -> m "version %a" pp_tls_version `TLS_1_3) ; let ciphers = List.filter_map Ciphersuite.any_ciphersuite_to_ciphersuite13 ch.ciphersuites @@ -85,7 +85,7 @@ let answer_client_hello ~hrr state ch raw = let cookie = Mirage_crypto.Hash.digest (Ciphersuite.hash13 cipher) raw in let hrr = { retry_version = `TLS_1_3 ; ciphersuite = cipher ; sessionid = ch.sessionid ; selected_group = group ; extensions = [ `Cookie cookie ] } in let hrr_raw = Writer.assemble_handshake (HelloRetryRequest hrr) in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake (HelloRetryRequest hrr) ; + Tracing.hs ~tag:"handshake-out" (HelloRetryRequest hrr) ; (* there is no early data anymore if HRR was sent (see 4.1.2) *) (* but the client wouldn't know until it received the HRR *) let early_data_left = if List.mem `EarlyDataIndication ch.extensions then config.Config.zero_rtt else 0l in @@ -97,8 +97,8 @@ let answer_client_hello ~hrr state ch raw = | Some _ -> [`Record change_cipher_spec])) end | Some group, Some cipher -> - Log.debug (fun m -> m "cipher %a" Sexplib.Sexp.pp_hum (Ciphersuite.sexp_of_ciphersuite13 cipher)) ; - Log.debug (fun m -> m "group %a" Sexplib.Sexp.pp_hum (Core.sexp_of_group group)) ; + Log.debug (fun m -> m "cipher %a" Ciphersuite.pp_ciphersuite cipher) ; + Log.debug (fun m -> m "group %a" pp_group group) ; match List.mem group groups, keyshare group with | false, _ | _, None -> Error (`Fatal `NoSupportedGroup) (* TODO: better error type? *) @@ -217,7 +217,7 @@ let answer_client_hello ~hrr state ch raw = let sh, session = base_server_hello ?epoch cipher (`KeyShare (group, public) :: exts) in let sh_raw = Writer.assemble_handshake (ServerHello sh) in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake (ServerHello sh) ; + Tracing.hs ~tag:"handshake-out" (ServerHello sh) ; let log = log <+> raw <+> sh_raw in let server_hs_secret, server_ctx, client_hs_secret, client_ctx = hs_ctx hs_secret log in @@ -254,7 +254,7 @@ let answer_client_hello ~hrr state ch raw = in (* TODO also max_fragment_length ; client_certificate_url ; trusted_ca_keys ; user_mapping ; client_authz ; server_authz ; cert_type ; use_srtp ; heartbeat ; alpn ; status_request_v2 ; signed_cert_timestamp ; client_cert_type ; server_cert_type *) let ee_raw = Writer.assemble_handshake ee in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake ee ; + Tracing.hs ~tag:"handshake-out" ee ; let log = Cstruct.append log ee_raw in let* c_out, log, session' = @@ -273,7 +273,7 @@ let answer_client_hello ~hrr state ch raw = in CertificateRequest (Writer.assemble_certificate_request_1_3 exts) in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake certreq ; + Tracing.hs ~tag:"handshake-out" certreq ; let raw_cert_req = Writer.assemble_handshake certreq in let common_session_data13 = { session.common_session_data13 with client_auth = true } in [raw_cert_req], log <+> raw_cert_req, { session with common_session_data13 } @@ -282,7 +282,7 @@ let answer_client_hello ~hrr state ch raw = let certs = List.map X509.Certificate.encode_der chain in let cert = Certificate (Writer.assemble_certificates_1_3 Cstruct.empty certs) in let cert_raw = Writer.assemble_handshake cert in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake cert ; + Tracing.hs ~tag:"handshake-out" cert ; let log = log <+> cert_raw in let tbs = Mirage_crypto.Hash.digest (Ciphersuite.hash13 cipher) log in @@ -293,7 +293,7 @@ let answer_client_hello ~hrr state ch raw = in let cv = CertificateVerify signed in let cv_raw = Writer.assemble_handshake cv in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake cv ; + Tracing.hs ~tag:"handshake-out" cv ; let log = log <+> cv_raw in Ok (out @ [cert_raw; cv_raw], log, session) in @@ -305,7 +305,7 @@ let answer_client_hello ~hrr state ch raw = let fin = Finished f_data in let fin_raw = Writer.assemble_handshake fin in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake fin ; + Tracing.hs ~tag:"handshake-out" fin ; let log = log <+> fin_raw in let server_app_secret, server_app_ctx, client_app_secret, client_app_ctx = @@ -335,7 +335,7 @@ let answer_client_hello ~hrr state ch raw = | x -> [ `EarlyDataIndication x ] in let st = { lifetime = cache.Config.lifetime ; age_add ; nonce ; ticket = psk_id ; extensions } in - Tracing.sexpf ~tag:"handshake-out" ~f:sexp_of_tls_handshake (SessionTicket st); + Tracing.hs ~tag:"handshake-out" (SessionTicket st) ; let st_raw = Writer.assemble_handshake (SessionTicket st) in (Some st, [st_raw]) in @@ -469,6 +469,7 @@ let handle_key_update state req = app_secret_n_1 session.master_secret session.server_app_secret in let ku = KeyUpdate Packet.UPDATE_NOT_REQUESTED in + Tracing.hs ~tag:"handshake-out" ku ; let ku_raw = Writer.assemble_handshake ku in { session' with server_app_secret }, [ `Record (Packet.HANDSHAKE, ku_raw); `Change_enc server_ctx ] @@ -481,7 +482,7 @@ let handle_key_update state req = let handle_handshake cs hs buf = let open Reader in let* handshake = map_reader_error (parse_handshake buf) in - Tracing.sexpf ~tag:"handshake-in" ~f:sexp_of_tls_handshake handshake; + Tracing.hs ~tag:"handshake-in" handshake; match cs, handshake with | AwaitClientHelloHRR13, ClientHello ch -> answer_client_hello ~hrr:true hs ch buf diff --git a/lib/packet.ml b/lib/packet.ml index 2ff4118c..7c819bf3 100644 --- a/lib/packet.ml +++ b/lib/packet.ml @@ -9,26 +9,52 @@ let set_uint24_len buf num = Cstruct.set_uint8 buf 2 (num mod 0x100) (* TLS record content type *) -[%%cenum type content_type = - | CHANGE_CIPHER_SPEC [@id 20] - | ALERT [@id 21] - | HANDSHAKE [@id 22] - | APPLICATION_DATA [@id 23] - | HEARTBEAT [@id 24] - [@@uint8_t] [@@sexp] -] + | CHANGE_CIPHER_SPEC + | ALERT + | HANDSHAKE + | APPLICATION_DATA + | HEARTBEAT + +let content_type_to_int = function + | CHANGE_CIPHER_SPEC -> 20 + | ALERT -> 21 + | HANDSHAKE -> 22 + | APPLICATION_DATA -> 23 + | HEARTBEAT -> 24 +and int_to_content_type = function + | 20 -> Some CHANGE_CIPHER_SPEC + | 21 -> Some ALERT + | 22 -> Some HANDSHAKE + | 23 -> Some APPLICATION_DATA + | 24 -> Some HEARTBEAT + | _ -> None + +let pp_content_type ppf = function + | CHANGE_CIPHER_SPEC -> Fmt.string ppf "change cipher spec" + | ALERT -> Fmt.string ppf "alert" + | HANDSHAKE -> Fmt.string ppf "handshake" + | APPLICATION_DATA -> Fmt.string ppf "application data" + | HEARTBEAT -> Fmt.string ppf "heartbeat" (* TLS alert level *) -[%%cenum type alert_level = - | WARNING [@id 1] - | FATAL [@id 2] - [@@uint8_t] [@@sexp] -] + | WARNING + | FATAL + +let pp_alert_level ppf = function + | WARNING -> Fmt.string ppf "warning" + | FATAL -> Fmt.string ppf "fatal" + +let alert_level_to_int = function + | WARNING -> 1 + | FATAL -> 2 +and int_to_alert_level = function + | 1 -> Some WARNING + | 2 -> Some FATAL + | _ -> None (* TLS alert types *) -[%%cenum type alert_type = | CLOSE_NOTIFY [@id 0] (*RFC5246*) | UNEXPECTED_MESSAGE [@id 10] (*RFC5246*) @@ -64,11 +90,119 @@ type alert_type = | UNKNOWN_PSK_IDENTITY [@id 115] (*RFC4279*) | CERTIFICATE_REQUIRED [@id 116] (*RFC8446*) | NO_APPLICATION_PROTOCOL [@id 120] (*RFC7301*) - [@@uint8_t] [@@sexp] -] + +let alert_type_to_string = function + | CLOSE_NOTIFY -> "close notify" + | UNEXPECTED_MESSAGE -> "unexpected message" + | BAD_RECORD_MAC -> "bad record mac" + | DECRYPTION_FAILED -> "decryption failed" + | RECORD_OVERFLOW -> "record overflow" + | DECOMPRESSION_FAILURE -> "decompression failure" + | HANDSHAKE_FAILURE -> "handshake failure" + | NO_CERTIFICATE_RESERVED -> "no certificate" + | BAD_CERTIFICATE -> "bad certificate" + | UNSUPPORTED_CERTIFICATE -> "unsupported certificate" + | CERTIFICATE_REVOKED -> "certificate revoked" + | CERTIFICATE_EXPIRED -> "certificate expired" + | CERTIFICATE_UNKNOWN -> "certificate unknown" + | ILLEGAL_PARAMETER -> "illegal parameter" + | UNKNOWN_CA -> "unknown CA" + | ACCESS_DENIED -> "access denied" + | DECODE_ERROR -> "decode error" + | DECRYPT_ERROR -> "decrypt error" + | EXPORT_RESTRICTION_RESERVED -> "export restrictions" + | PROTOCOL_VERSION -> "protocol version" + | INSUFFICIENT_SECURITY -> "insufficient security" + | INTERNAL_ERROR -> "internal error" + | INAPPROPRIATE_FALLBACK -> "inappropriate fallback" + | USER_CANCELED -> "user canceled" + | NO_RENEGOTIATION -> "no renegotiation" + | MISSING_EXTENSION -> "missing extension" + | UNSUPPORTED_EXTENSION -> "unsupported extension" + | CERTIFICATE_UNOBTAINABLE -> "certificate unobtainable" + | UNRECOGNIZED_NAME -> "unrecognized name" + | BAD_CERTIFICATE_STATUS_RESPONSE -> "bad certificate status response" + | BAD_CERTIFICATE_HASH_VALUE -> "bad certificate hash value" + | UNKNOWN_PSK_IDENTITY -> "unknown psk identity" + | CERTIFICATE_REQUIRED -> "certificate required" + | NO_APPLICATION_PROTOCOL -> "no application protocol" + +let alert_type_to_int = function + | CLOSE_NOTIFY -> 0 (*RFC5246*) + | UNEXPECTED_MESSAGE -> 10 (*RFC5246*) + | BAD_RECORD_MAC -> 20 (*RFC5246*) + | DECRYPTION_FAILED -> 21 (*RFC5246*) + | RECORD_OVERFLOW -> 22 (*RFC5246*) + | DECOMPRESSION_FAILURE -> 30 (*RFC5246*) + | HANDSHAKE_FAILURE -> 40 (*RFC5246*) + | NO_CERTIFICATE_RESERVED -> 41 (*RFC5246*) + | BAD_CERTIFICATE -> 42 (*RFC5246*) + | UNSUPPORTED_CERTIFICATE -> 43 (*RFC5246*) + | CERTIFICATE_REVOKED -> 44 (*RFC5246*) + | CERTIFICATE_EXPIRED -> 45 (*RFC5246*) + | CERTIFICATE_UNKNOWN -> 46 (*RFC5246*) + | ILLEGAL_PARAMETER -> 47 (*RFC5246*) + | UNKNOWN_CA -> 48 (*RFC5246*) + | ACCESS_DENIED -> 49 (*RFC5246*) + | DECODE_ERROR -> 50 (*RFC5246*) + | DECRYPT_ERROR -> 51 (*RFC5246*) + | EXPORT_RESTRICTION_RESERVED -> 60 (*RFC5246*) + | PROTOCOL_VERSION -> 70 (*RFC5246*) + | INSUFFICIENT_SECURITY -> 71 (*RFC5246*) + | INTERNAL_ERROR -> 80 (*RFC5246*) + | INAPPROPRIATE_FALLBACK -> 86 (*draft-ietf-tls-downgrade-scsv*) + | USER_CANCELED -> 90 (*RFC5246*) + | NO_RENEGOTIATION -> 100 (*RFC5246*) + | MISSING_EXTENSION -> 109 (*RFC8446*) + | UNSUPPORTED_EXTENSION -> 110 (*RFC5246*) + | CERTIFICATE_UNOBTAINABLE -> 111 (*RFC6066*) + | UNRECOGNIZED_NAME -> 112 (*RFC6066*) + | BAD_CERTIFICATE_STATUS_RESPONSE -> 113 (*RFC6066*) + | BAD_CERTIFICATE_HASH_VALUE -> 114 (*RFC6066*) + | UNKNOWN_PSK_IDENTITY -> 115 (*RFC4279*) + | CERTIFICATE_REQUIRED -> 116 (*RFC8446*) + | NO_APPLICATION_PROTOCOL -> 120 (*RFC7301*) +and int_to_alert_type = function + | 0 -> Some CLOSE_NOTIFY + | 10 -> Some UNEXPECTED_MESSAGE + | 20 -> Some BAD_RECORD_MAC + | 21 -> Some DECRYPTION_FAILED + | 22 -> Some RECORD_OVERFLOW + | 30 -> Some DECOMPRESSION_FAILURE + | 40 -> Some HANDSHAKE_FAILURE + | 41 -> Some NO_CERTIFICATE_RESERVED + | 42 -> Some BAD_CERTIFICATE + | 43 -> Some UNSUPPORTED_CERTIFICATE + | 44 -> Some CERTIFICATE_REVOKED + | 45 -> Some CERTIFICATE_EXPIRED + | 46 -> Some CERTIFICATE_UNKNOWN + | 47 -> Some ILLEGAL_PARAMETER + | 48 -> Some UNKNOWN_CA + | 49 -> Some ACCESS_DENIED + | 50 -> Some DECODE_ERROR + | 51 -> Some DECRYPT_ERROR + | 60 -> Some EXPORT_RESTRICTION_RESERVED + | 70 -> Some PROTOCOL_VERSION + | 71 -> Some INSUFFICIENT_SECURITY + | 80 -> Some INTERNAL_ERROR + | 86 -> Some INAPPROPRIATE_FALLBACK + | 90 -> Some USER_CANCELED + | 100 -> Some NO_RENEGOTIATION + | 109 -> Some MISSING_EXTENSION + | 110 -> Some UNSUPPORTED_EXTENSION + | 111 -> Some CERTIFICATE_UNOBTAINABLE + | 112 -> Some UNRECOGNIZED_NAME + | 113 -> Some BAD_CERTIFICATE_STATUS_RESPONSE + | 114 -> Some BAD_CERTIFICATE_HASH_VALUE + | 115 -> Some UNKNOWN_PSK_IDENTITY + | 116 -> Some CERTIFICATE_REQUIRED + | 120 -> Some NO_APPLICATION_PROTOCOL + | _ -> None + +let pp_alert ppf (lvl, typ) = + Fmt.pf ppf "ALERT %a %s" pp_alert_level lvl (alert_type_to_string typ) (* TLS handshake type *) -[%%cenum type handshake_type = | HELLO_REQUEST [@id 0] | CLIENT_HELLO [@id 1] @@ -89,11 +223,50 @@ type handshake_type = | SUPPLEMENTAL_DATA [@id 23] (*RFC4680*) | KEY_UPDATE [@id 24] (*RFC8446*) | MESSAGE_HASH [@id 254] (*RFC8446*) - [@@uint8_t] [@@sexp] -] + +let handshake_type_to_int = function + | HELLO_REQUEST -> 0 + | CLIENT_HELLO -> 1 + | SERVER_HELLO -> 2 + | HELLO_VERIFY_REQUEST -> 3 (*RFC6347*) + | SESSION_TICKET -> 4 (*RFC4507, RFC8446*) + | END_OF_EARLY_DATA -> 5 (*RFC8446*) + | ENCRYPTED_EXTENSIONS -> 8 (*RFC8446*) + | CERTIFICATE -> 11 + | SERVER_KEY_EXCHANGE -> 12 + | CERTIFICATE_REQUEST -> 13 + | SERVER_HELLO_DONE -> 14 + | CERTIFICATE_VERIFY -> 15 + | CLIENT_KEY_EXCHANGE -> 16 + | FINISHED -> 20 + | CERTIFICATE_URL -> 21 (*RFC4366*) + | CERTIFICATE_STATUS -> 22 (*RFC4366*) + | SUPPLEMENTAL_DATA -> 23 (*RFC4680*) + | KEY_UPDATE -> 24 (*RFC8446*) + | MESSAGE_HASH -> 254 (*RFC8446*) +and int_to_handshake_type = function + | 0 -> Some HELLO_REQUEST + | 1 -> Some CLIENT_HELLO + | 2 -> Some SERVER_HELLO + | 3 -> Some HELLO_VERIFY_REQUEST + | 4 -> Some SESSION_TICKET + | 5 -> Some END_OF_EARLY_DATA + | 8 -> Some ENCRYPTED_EXTENSIONS + | 11 -> Some CERTIFICATE + | 12 -> Some SERVER_KEY_EXCHANGE + | 13 -> Some CERTIFICATE_REQUEST + | 14 -> Some SERVER_HELLO_DONE + | 15 -> Some CERTIFICATE_VERIFY + | 16 -> Some CLIENT_KEY_EXCHANGE + | 20 -> Some FINISHED + | 21 -> Some CERTIFICATE_URL + | 22 -> Some CERTIFICATE_STATUS + | 23 -> Some SUPPLEMENTAL_DATA + | 24 -> Some KEY_UPDATE + | 254 -> Some MESSAGE_HASH + | _ -> None (* TLS certificate types *) -[%%cenum type client_certificate_type = | RSA_SIGN [@id 1] (*RFC5246*) | DSS_SIGN [@id 2] (*RFC5246*) @@ -105,20 +278,48 @@ type client_certificate_type = | ECDSA_SIGN [@id 64] (*RFC4492*) | RSA_FIXED_ECDH [@id 65] (*RFC4492*) | ECDSA_FIXED_ECDH [@id 66] (*RFC4492*) - [@@uint8_t] [@@sexp] -] + +let client_certificate_type_to_int = function + | RSA_SIGN -> 1 (*RFC5246*) + | DSS_SIGN -> 2 (*RFC5246*) + | RSA_FIXED_DH -> 3 (*RFC5246*) + | DSS_FIXED_DH -> 4 (*RFC5246*) + | RSA_EPHEMERAL_DH_RESERVED -> 5 (*RFC5246*) + | DSS_EPHEMERAL_DH_RESERVED -> 6 (*RFC5246*) + | FORTEZZA_DMS_RESERVED -> 20 (*RFC5246*) + | ECDSA_SIGN -> 64 (*RFC4492*) + | RSA_FIXED_ECDH -> 65 (*RFC4492*) + | ECDSA_FIXED_ECDH -> 66 (*RFC4492*) +and int_to_client_certificate_type = function + | 1 -> Some RSA_SIGN + | 2 -> Some DSS_SIGN + | 3 -> Some RSA_FIXED_DH + | 4 -> Some DSS_FIXED_DH + | 5 -> Some RSA_EPHEMERAL_DH_RESERVED + | 6 -> Some DSS_EPHEMERAL_DH_RESERVED + | 20 -> Some FORTEZZA_DMS_RESERVED + | 64 -> Some ECDSA_SIGN + | 65 -> Some RSA_FIXED_ECDH + | 66 -> Some ECDSA_FIXED_ECDH + | _ -> None (* TLS compression methods, used in hello packets *) -[%%cenum type compression_method = | NULL [@id 0] | DEFLATE [@id 1] | LZS [@id 64] - [@@uint8_t] [@@sexp] -] + +let compression_method_to_int = function + | NULL -> 0 + | DEFLATE -> 1 + | LZS -> 64 +and int_to_compression_method = function + | 0 -> Some NULL + | 1 -> Some DEFLATE + | 64 -> Some LZS + | _ -> None (* TLS extensions in hello packets from RFC 6066, formerly RFC 4366 *) -[%%cenum type extension_type = | SERVER_NAME [@id 0] | MAX_FRAGMENT_LENGTH [@id 1] @@ -165,29 +366,136 @@ type extension_type = | KEY_SHARE [@id 51] (*RFC8446*) | RENEGOTIATION_INFO [@id 0xFF01] (*RFC5746*) | DRAFT_SUPPORT [@id 0xFF02] (*draft*) - [@@uint16_t] [@@sexp] -] + +let extension_type_to_int = function + | SERVER_NAME -> 0 + | MAX_FRAGMENT_LENGTH -> 1 + | CLIENT_CERTIFICATE_URL -> 2 + | TRUSTED_CA_KEYS -> 3 + | TRUNCATED_HMAC -> 4 + | STATUS_REQUEST -> 5 + | USER_MAPPING -> 6 (*RFC4681*) + | CLIENT_AUTHZ -> 7 (*RFC5878*) + | SERVER_AUTHZ -> 8 (*RFC5878*) + | CERT_TYPE -> 9 (*RFC6091*) + | SUPPORTED_GROUPS -> 10 (*RFC4492, RFC8446*) + | EC_POINT_FORMATS -> 11 (*RFC4492*) + | SRP -> 12 (*RFC5054*) + | SIGNATURE_ALGORITHMS -> 13 (*RFC5246*) + | USE_SRTP -> 14 (*RFC5764*) + | HEARTBEAT -> 15 (*RFC6520*) + | APPLICATION_LAYER_PROTOCOL_NEGOTIATION -> 16 (*RFC7301*) + | STATUS_REQUEST_V2 -> 17 (*RFC6961*) + | SIGNED_CERTIFICATE_TIMESTAMP -> 18 (*RFC6962*) + | CLIENT_CERTIFICATE_TYPE -> 19 (*RFC7250*) + | SERVER_CERTIFICATE_TYPE -> 20 (*RFC7250*) + | PADDING -> 21 (*RFC7685*) + | ENCRYPT_THEN_MAC -> 22 (*RFC7366*) + | EXTENDED_MASTER_SECRET -> 23 (*RFC7627*) + | TOKEN_BINDING -> 24 (*RFC8472*) + | CACHED_INFO -> 25 (*RFC7924*) + | TLS_LTS -> 26 (*draft-gutmann-tls-lts*) + | COMPRESSED_CERTIFICATE -> 27 (*draft-ietf-tls-certificate-compression*) + | RECORD_SIZE_LIMIT -> 28 (*RFC8449*) + | PWD_PROTECT -> 29 (*RFC-harkins-tls-dragonfly-03*) + | PWD_CLEAR -> 30 (*RFC-harkins-tls-dragonfly-03*) + | PASSWORD_SALT -> 31 (*RFC-harkins-tls-dragonfly-03*) + | SESSION_TICKET -> 35 (*RFC4507*) + | PRE_SHARED_KEY -> 41 (*RFC8446*) + | EARLY_DATA -> 42 (*RFC8446*) + | SUPPORTED_VERSIONS -> 43 (*RFC8446*) + | COOKIE -> 44 (*RFC8446*) + | PSK_KEY_EXCHANGE_MODES -> 45 (*RFC8446*) + | CERTIFICATE_AUTHORITIES -> 47 (*RFC8446*) + | OID_FILTERS -> 48 (*RFC8446*) + | POST_HANDSHAKE_AUTH -> 49 (*RFC8446*) + | SIGNATURE_ALGORITHMS_CERT -> 50 (*RFC8446*) + | KEY_SHARE -> 51 (*RFC8446*) + | RENEGOTIATION_INFO -> 0xFF01 (*RFC5746*) + | DRAFT_SUPPORT -> 0xFF02 (*draft*) +and int_to_extension_type = function + | 0 -> Some SERVER_NAME + | 1 -> Some MAX_FRAGMENT_LENGTH + | 2 -> Some CLIENT_CERTIFICATE_URL + | 3 -> Some TRUSTED_CA_KEYS + | 4 -> Some TRUNCATED_HMAC + | 5 -> Some STATUS_REQUEST + | 6 -> Some USER_MAPPING + | 7 -> Some CLIENT_AUTHZ + | 8 -> Some SERVER_AUTHZ + | 9 -> Some CERT_TYPE + | 10 -> Some SUPPORTED_GROUPS + | 11 -> Some EC_POINT_FORMATS + | 12 -> Some SRP + | 13 -> Some SIGNATURE_ALGORITHMS + | 14 -> Some USE_SRTP + | 15 -> Some HEARTBEAT + | 16 -> Some APPLICATION_LAYER_PROTOCOL_NEGOTIATION + | 17 -> Some STATUS_REQUEST_V2 + | 18 -> Some SIGNED_CERTIFICATE_TIMESTAMP + | 19 -> Some CLIENT_CERTIFICATE_TYPE + | 20 -> Some SERVER_CERTIFICATE_TYPE + | 21 -> Some PADDING + | 22 -> Some ENCRYPT_THEN_MAC + | 23 -> Some EXTENDED_MASTER_SECRET + | 24 -> Some TOKEN_BINDING + | 25 -> Some CACHED_INFO + | 26 -> Some TLS_LTS + | 27 -> Some COMPRESSED_CERTIFICATE + | 28 -> Some RECORD_SIZE_LIMIT + | 29 -> Some PWD_PROTECT + | 30 -> Some PWD_CLEAR + | 31 -> Some PASSWORD_SALT + | 35 -> Some SESSION_TICKET + | 41 -> Some PRE_SHARED_KEY + | 42 -> Some EARLY_DATA + | 43 -> Some SUPPORTED_VERSIONS + | 44 -> Some COOKIE + | 45 -> Some PSK_KEY_EXCHANGE_MODES + | 47 -> Some CERTIFICATE_AUTHORITIES + | 48 -> Some OID_FILTERS + | 49 -> Some POST_HANDSHAKE_AUTH + | 50 -> Some SIGNATURE_ALGORITHMS_CERT + | 51 -> Some KEY_SHARE + | 0xFF01 -> Some RENEGOTIATION_INFO + | 0xFF02 -> Some DRAFT_SUPPORT + | _ -> None + +let extension_type_to_string et = string_of_int (extension_type_to_int et) (* TLS maximum fragment length *) -[%%cenum type max_fragment_length = | TWO_9 [@id 1] | TWO_10 [@id 2] | TWO_11 [@id 3] | TWO_12 [@id 4] - [@@uint8_t] [@@sexp] -] + +let max_fragment_length_to_int = function + | TWO_9 -> 1 + | TWO_10 -> 2 + | TWO_11 -> 3 + | TWO_12 -> 4 +and int_to_max_fragment_length = function + | 1 -> Some TWO_9 + | 2 -> Some TWO_10 + | 3 -> Some TWO_11 + | 4 -> Some TWO_12 + | _ -> None (* TLS 1.3 pre-shared key mode (4.2.9) *) -[%%cenum type psk_key_exchange_mode = | PSK_KE [@id 0] | PSK_KE_DHE [@id 1] - [@@uint8_t] [@@sexp] -] + +let psk_key_exchange_mode_to_int = function + | PSK_KE -> 0 + | PSK_KE_DHE -> 1 +and int_to_psk_key_exchange_mode = function + | 0 -> Some PSK_KE + | 1 -> Some PSK_KE_DHE + | _ -> None (* TLS 1.3 4.2.3 *) -[%%cenum type signature_alg = | RSA_PKCS1_MD5 [@id 0x0101] (* deprecated, TLS 1.2 only *) | RSA_PKCS1_SHA1 [@id 0x0201] (* deprecated, TLS 1.2 only *) @@ -208,8 +516,47 @@ type signature_alg = | RSA_PSS_PSS_SHA384 [@id 0x080a] | RSA_PSS_PSS_SHA512 [@id 0x080b] (* private use 0xFE00 - 0xFFFF *) - [@@uint16_t] [@@sexp] -] + +let signature_alg_to_int = function + | RSA_PKCS1_MD5 -> 0x0101 (* deprecated, TLS 1.2 only *) + | RSA_PKCS1_SHA1 -> 0x0201 (* deprecated, TLS 1.2 only *) + | RSA_PKCS1_SHA224 -> 0x0301 + | RSA_PKCS1_SHA256 -> 0x0401 + | RSA_PKCS1_SHA384 -> 0x0501 + | RSA_PKCS1_SHA512 -> 0x0601 + | ECDSA_SECP256R1_SHA1 -> 0x0203 (* deprecated, TLS 1.2 only *) + | ECDSA_SECP256R1_SHA256 -> 0x0403 + | ECDSA_SECP384R1_SHA384 -> 0x0503 + | ECDSA_SECP521R1_SHA512 -> 0x0603 + | RSA_PSS_RSAENC_SHA256 -> 0x0804 + | RSA_PSS_RSAENC_SHA384 -> 0x0805 + | RSA_PSS_RSAENC_SHA512 -> 0x0806 + | ED25519 -> 0x0807 + | ED448 -> 0x0808 + | RSA_PSS_PSS_SHA256 -> 0x0809 + | RSA_PSS_PSS_SHA384 -> 0x080a + | RSA_PSS_PSS_SHA512 -> 0x080b + (* private use 0xFE00 - 0xFFFF *) +and int_to_signature_alg = function + | 0x0101 -> Some RSA_PKCS1_MD5 + | 0x0201 -> Some RSA_PKCS1_SHA1 + | 0x0301 -> Some RSA_PKCS1_SHA224 + | 0x0401 -> Some RSA_PKCS1_SHA256 + | 0x0501 -> Some RSA_PKCS1_SHA384 + | 0x0601 -> Some RSA_PKCS1_SHA512 + | 0x0203 -> Some ECDSA_SECP256R1_SHA1 + | 0x0403 -> Some ECDSA_SECP256R1_SHA256 + | 0x0503 -> Some ECDSA_SECP384R1_SHA384 + | 0x0603 -> Some ECDSA_SECP521R1_SHA512 + | 0x0804 -> Some RSA_PSS_RSAENC_SHA256 + | 0x0805 -> Some RSA_PSS_RSAENC_SHA384 + | 0x0806 -> Some RSA_PSS_RSAENC_SHA512 + | 0x0807 -> Some ED25519 + | 0x0808 -> Some ED448 + | 0x0809 -> Some RSA_PSS_PSS_SHA256 + | 0x080a -> Some RSA_PSS_PSS_SHA384 + | 0x080b -> Some RSA_PSS_PSS_SHA512 + | _ -> None let to_signature_alg = function | `RSA_PKCS1_MD5 -> RSA_PKCS1_MD5 @@ -245,14 +592,16 @@ let of_signature_alg = function | _ -> None (* EC RFC4492*) -[%%cenum type ec_curve_type = (* 1 and 2 are deprecated in RFC 8422 *) | NAMED_CURVE [@id 3] - [@@uint8_t] [@@sexp] -] -[%%cenum +let ec_curve_type_to_int = function + | NAMED_CURVE -> 3 +and int_to_ec_curve_type = function + | 3 -> Some NAMED_CURVE + | _ -> None + type named_group = (* OBSOLETE_RESERVED 0x0001 - 0x0016 *) | SECP256R1 [@id 23] @@ -269,11 +618,36 @@ type named_group = (* FFDHE_PRIVATE_USE 0x01FC - 0x01FF *) (* ECDHE_PRIVATE_USE 0xFE00 - 0xFEFF *) (* OBSOLETE_RESERVED 0xFF01 - 0xFF02 *) - [@@uint16_t] [@@sexp] -] + +let named_group_to_int = function + | SECP256R1 -> 23 + | SECP384R1 -> 24 + | SECP521R1 -> 25 + (* OBSOLETE_RESERVED 0x001A - 0x001C *) + | X25519 -> 29 (*RFC8446*) + | X448 -> 30 (*RFC8446*) + | FFDHE2048 -> 256 (*RFC8446*) + | FFDHE3072 -> 257 (*RFC8446*) + | FFDHE4096 -> 258 (*RFC8446*) + | FFDHE6144 -> 259 (*RFC8446*) + | FFDHE8192 -> 260 (*RFC8446*) + (* FFDHE_PRIVATE_USE 0x01FC - 0x01FF *) + (* ECDHE_PRIVATE_USE 0xFE00 - 0xFEFF *) + (* OBSOLETE_RESERVED 0xFF01 - 0xFF02 *) +and int_to_named_group = function + | 23 -> Some SECP256R1 + | 24 -> Some SECP384R1 + | 25 -> Some SECP521R1 + | 29 -> Some X25519 + | 30 -> Some X448 + | 256 -> Some FFDHE2048 + | 257 -> Some FFDHE3072 + | 258 -> Some FFDHE4096 + | 259 -> Some FFDHE6144 + | 260 -> Some FFDHE8192 + | _ -> None (** enum of all TLS ciphersuites *) -[%%cenum type any_ciphersuite = | TLS_RSA_WITH_3DES_EDE_CBC_SHA [@id 0x000A] | TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA [@id 0x0016] @@ -319,15 +693,105 @@ type any_ciphersuite = | TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 [@id 0xCCA8] (*RFC7905*) | TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 [@id 0xCCA9] (*RFC7905*) | TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 [@id 0xCCAA] (*RFC7905*) - [@@uint16_t] [@@sexp] -] -[%%cenum +let any_ciphersuite_to_int = function + | TLS_RSA_WITH_3DES_EDE_CBC_SHA -> 0x000A + | TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA -> 0x0016 + | TLS_RSA_WITH_AES_128_CBC_SHA -> 0x002F + | TLS_DHE_RSA_WITH_AES_128_CBC_SHA -> 0x0033 + | TLS_RSA_WITH_AES_256_CBC_SHA -> 0x0035 + | TLS_DHE_RSA_WITH_AES_256_CBC_SHA -> 0x0039 + | TLS_RSA_WITH_AES_128_CBC_SHA256 -> 0x003C + | TLS_RSA_WITH_AES_256_CBC_SHA256 -> 0x003D + | TLS_DHE_RSA_WITH_AES_128_CBC_SHA256 -> 0x0067 + | TLS_DHE_RSA_WITH_AES_256_CBC_SHA256 -> 0x006B + | TLS_RSA_WITH_AES_128_GCM_SHA256 -> 0x009C (*RFC5288*) + | TLS_RSA_WITH_AES_256_GCM_SHA384 -> 0x009D (*RFC5288*) + | TLS_DHE_RSA_WITH_AES_128_GCM_SHA256 -> 0x009E (*RFC5288*) + | TLS_DHE_RSA_WITH_AES_256_GCM_SHA384 -> 0x009F (*RFC5288*) + | TLS_EMPTY_RENEGOTIATION_INFO_SCSV -> 0x00FF (*RFC5746*) + | TLS_AES_128_GCM_SHA256 -> 0x1301 (*RFC8446*) + | TLS_AES_256_GCM_SHA384 -> 0x1302 (*RFC8446*) + | TLS_CHACHA20_POLY1305_SHA256 -> 0x1303 (*RFC8446*) + | TLS_AES_128_CCM_SHA256 -> 0x1304 (*RFC8446*) + | TLS_FALLBACK_SCSV -> 0x5600 (*draft-ietf-tls-downgrade-scsv*) + | TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA -> 0xC008 + | TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA -> 0xC009 + | TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA -> 0xC00A + | TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA -> 0xC012 + | TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA -> 0xC013 + | TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA -> 0xC014 + | TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 -> 0xC023 (*RFC5289*) + | TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 -> 0xC024 (*RFC5289*) + | TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256 -> 0xC027 (*RFC5289*) + | TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384 -> 0xC028 (*RFC5289*) + | TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 -> 0xC02B (*RFC5289*) + | TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 -> 0xC02C (*RFC5289*) + | TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256 -> 0xC02F (*RFC5289*) + | TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384 -> 0xC030 (*RFC5289*) + | TLS_RSA_WITH_AES_128_CCM -> 0xC09C (*RFC6655*) + | TLS_RSA_WITH_AES_256_CCM -> 0xC09D (*RFC6655*) + | TLS_DHE_RSA_WITH_AES_128_CCM -> 0xC09E (*RFC6655*) + | TLS_DHE_RSA_WITH_AES_256_CCM -> 0xC09F (*RFC6655*) + | TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> 0xCCA8 (*RFC7905*) + | TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 -> 0xCCA9 (*RFC7905*) + | TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> 0xCCAA (*RFC7905*) + +and int_to_any_ciphersuite = function + | 0x000A -> Some TLS_RSA_WITH_3DES_EDE_CBC_SHA + | 0x0016 -> Some TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA + | 0x002F -> Some TLS_RSA_WITH_AES_128_CBC_SHA + | 0x0033 -> Some TLS_DHE_RSA_WITH_AES_128_CBC_SHA + | 0x0035 -> Some TLS_RSA_WITH_AES_256_CBC_SHA + | 0x0039 -> Some TLS_DHE_RSA_WITH_AES_256_CBC_SHA + | 0x003C -> Some TLS_RSA_WITH_AES_128_CBC_SHA256 + | 0x003D -> Some TLS_RSA_WITH_AES_256_CBC_SHA256 + | 0x0067 -> Some TLS_DHE_RSA_WITH_AES_128_CBC_SHA256 + | 0x006B -> Some TLS_DHE_RSA_WITH_AES_256_CBC_SHA256 + | 0x009C -> Some TLS_RSA_WITH_AES_128_GCM_SHA256 + | 0x009D -> Some TLS_RSA_WITH_AES_256_GCM_SHA384 + | 0x009E -> Some TLS_DHE_RSA_WITH_AES_128_GCM_SHA256 + | 0x009F -> Some TLS_DHE_RSA_WITH_AES_256_GCM_SHA384 + | 0x00FF -> Some TLS_EMPTY_RENEGOTIATION_INFO_SCSV + | 0x1301 -> Some TLS_AES_128_GCM_SHA256 + | 0x1302 -> Some TLS_AES_256_GCM_SHA384 + | 0x1303 -> Some TLS_CHACHA20_POLY1305_SHA256 + | 0x1304 -> Some TLS_AES_128_CCM_SHA256 + | 0x5600 -> Some TLS_FALLBACK_SCSV + | 0xC008 -> Some TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA + | 0xC009 -> Some TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA + | 0xC00A -> Some TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA + | 0xC012 -> Some TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA + | 0xC013 -> Some TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA + | 0xC014 -> Some TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA + | 0xC023 -> Some TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 + | 0xC024 -> Some TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 + | 0xC027 -> Some TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256 + | 0xC028 -> Some TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384 + | 0xC02B -> Some TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 + | 0xC02C -> Some TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 + | 0xC02F -> Some TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + | 0xC030 -> Some TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384 + | 0xC09C -> Some TLS_RSA_WITH_AES_128_CCM + | 0xC09D -> Some TLS_RSA_WITH_AES_256_CCM + | 0xC09E -> Some TLS_DHE_RSA_WITH_AES_128_CCM + | 0xC09F -> Some TLS_DHE_RSA_WITH_AES_256_CCM + | 0xCCA8 -> Some TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 + | 0xCCA9 -> Some TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 + | 0xCCAA -> Some TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 + | _ -> None + type key_update_request_type = | UPDATE_NOT_REQUESTED [@id 0] | UPDATE_REQUESTED [@id 1] - [@@uint8_t] [@@sexp] -] + +let key_update_request_type_to_int = function + | UPDATE_NOT_REQUESTED -> 0 + | UPDATE_REQUESTED -> 1 +and int_to_key_update_request_type = function + | 0 -> Some UPDATE_NOT_REQUESTED + | 1 -> Some UPDATE_REQUESTED + | _ -> None let helloretryrequest = Mirage_crypto.Hash.digest `SHA256 (Cstruct.of_string "HelloRetryRequest") let downgrade12 = Cstruct.of_hex "44 4F 57 4E 47 52 44 01" diff --git a/lib/reader.ml b/lib/reader.ml index 10908d10..36a5924a 100644 --- a/lib/reader.ml +++ b/lib/reader.ml @@ -2,8 +2,6 @@ open Packet open Core open Cstruct -open Sexplib.Conv - type error = | TrailingBytes of string | WrongLength of string @@ -12,7 +10,19 @@ type error = | Overflow of int | UnknownVersion of (int * int) | UnknownContent of int - [@@deriving sexp_of] + +let pp_error ppf = + let re = "reader error:" + and unk = "unknown" + in + function + | TrailingBytes msg -> Fmt.pf ppf "%s trailing bytes: %s" re msg + | WrongLength msg -> Fmt.pf ppf "%s wrong length: %s" re msg + | Unknown msg -> Fmt.pf ppf "%s %s %s" unk re msg + | Underflow -> Fmt.pf ppf "%s underflow" re + | Overflow n -> Fmt.pf ppf "%s overflow %u" re n + | UnknownVersion (m, n) -> Fmt.pf ppf "%s %s version %u.%u" re unk m n + | UnknownContent c -> Fmt.pf ppf "%s %s content %u" re unk c exception Reader_error of error @@ -83,36 +93,20 @@ let validate_alert (lvl, typ) = match lvl, typ with (* from RFC, find out which ones must be always FATAL and report if this does not meet the expectations *) - | WARNING, UNEXPECTED_MESSAGE -> raise_unknown "unexpected_message must always be fatal" - | WARNING, BAD_RECORD_MAC -> raise_unknown "bad_record_mac must always be fatal" - | WARNING, DECRYPTION_FAILED -> raise_unknown "decryption_failed must always be fatal" - | WARNING, RECORD_OVERFLOW -> raise_unknown "record_overflow must always be fatal" - | WARNING, DECOMPRESSION_FAILURE -> raise_unknown "decompression_failure must always be fatal" - | WARNING, HANDSHAKE_FAILURE -> raise_unknown "handshake_failure must always be fatal" - | WARNING, BAD_CERTIFICATE -> raise_unknown "bad_certificate must always be fatal" - | WARNING, UNSUPPORTED_CERTIFICATE -> raise_unknown "unsupported_certificate must always be fatal" - | WARNING, CERTIFICATE_REVOKED -> raise_unknown "certificate_revoked must always be fatal" - | WARNING, CERTIFICATE_UNKNOWN -> raise_unknown "certificate_unknown must always be fatal" - | WARNING, ILLEGAL_PARAMETER -> raise_unknown "illegal_parameter must always be fatal" - | WARNING, UNKNOWN_CA -> raise_unknown "unknown_ca must always be fatal" - | WARNING, ACCESS_DENIED -> raise_unknown "access_denied must always be fatal" - | WARNING, DECODE_ERROR -> raise_unknown "decode_error must always be fatal" - | WARNING, DECRYPT_ERROR -> raise_unknown "decrypt_error must always be fatal" - | WARNING, PROTOCOL_VERSION -> raise_unknown "protocol_version must always be fatal" - | WARNING, INSUFFICIENT_SECURITY -> raise_unknown "insufficient_security must always be fatal" - | WARNING, INTERNAL_ERROR -> raise_unknown "internal_error must always be fatal" - | WARNING, INAPPROPRIATE_FALLBACK -> raise_unknown "inappropriate_fallback must always be fatal" - | WARNING, MISSING_EXTENSION -> raise_unknown "missing_extension must always be fatal" - | WARNING, UNSUPPORTED_EXTENSION -> raise_unknown "unsupported_extension must always be fatal" - | WARNING, UNRECOGNIZED_NAME -> raise_unknown "unrecognized_name must always be fatal" - | WARNING, BAD_CERTIFICATE_STATUS_RESPONSE -> raise_unknown "bad_certificate_status_response must always be fatal" - | WARNING, UNKNOWN_PSK_IDENTITY -> raise_unknown "unknown_psk_identity must always be fatal" - | WARNING, CERTIFICATE_REQUIRED -> raise_unknown "certificate_required must always be fatal" - | WARNING, NO_APPLICATION_PROTOCOL -> raise_unknown "no_application_protocol must always be fatal" + | WARNING, (UNEXPECTED_MESSAGE | BAD_RECORD_MAC | DECRYPTION_FAILED | + RECORD_OVERFLOW | DECOMPRESSION_FAILURE | HANDSHAKE_FAILURE | + BAD_CERTIFICATE | UNSUPPORTED_CERTIFICATE | CERTIFICATE_REVOKED | + CERTIFICATE_UNKNOWN | ILLEGAL_PARAMETER | UNKNOWN_CA | + ACCESS_DENIED | DECODE_ERROR | DECRYPT_ERROR | PROTOCOL_VERSION | + INSUFFICIENT_SECURITY | INTERNAL_ERROR | INAPPROPRIATE_FALLBACK | + MISSING_EXTENSION | UNSUPPORTED_EXTENSION | UNRECOGNIZED_NAME | + BAD_CERTIFICATE_STATUS_RESPONSE | UNKNOWN_PSK_IDENTITY | + CERTIFICATE_REQUIRED | NO_APPLICATION_PROTOCOL as x) -> + raise_unknown (alert_type_to_string x ^ " must always be fatal") (* those are always warnings *) - | FATAL, USER_CANCELED -> raise_unknown "user_canceled must always be a warning" - | FATAL, NO_RENEGOTIATION -> raise_unknown "no_renegotiation must always be a warning" + | FATAL, (USER_CANCELED | NO_RENEGOTIATION as x) -> + raise_unknown (alert_type_to_string x ^ " must always be a warning") | lvl, typ -> (lvl, typ) diff --git a/lib/reader.mli b/lib/reader.mli index b172a623..59c3d5dc 100644 --- a/lib/reader.mli +++ b/lib/reader.mli @@ -6,7 +6,9 @@ type error = | Underflow | Overflow of int | UnknownVersion of (int * int) - | UnknownContent of int [@@deriving sexp_of] + | UnknownContent of int + +val pp_error : error Fmt.t val parse_version : Cstruct.t -> (Core.tls_version, error) result val parse_any_version : Cstruct.t -> (Core.tls_any_version, error) result diff --git a/lib/state.ml b/lib/state.ml index 1c0953bf..df9d4ae1 100644 --- a/lib/state.ml +++ b/lib/state.ml @@ -1,9 +1,6 @@ (* Defines all high-level datatypes for the TLS library. It is opaque to clients of this library, and only used from within the library. *) -open Sexplib -open Sexplib.Conv - open Core open Mirage_crypto @@ -11,9 +8,8 @@ type hmac_key = Cstruct.t (* initialisation vector style, depending on TLS version *) type iv_mode = - | Iv of Cstruct_sexp.t (* traditional CBC (reusing last cipherblock) *) + | Iv of Cstruct.t (* traditional CBC (reusing last cipherblock) *) | Random_iv (* TLS 1.1 and higher explicit IV (we use random) *) - [@@deriving sexp_of] type 'k cbc_cipher = (module Cipher_block.S.CBC with type key = 'k) type 'k cbc_state = { @@ -40,21 +36,13 @@ type cipher_st = | CBC : 'k cbc_state -> cipher_st | AEAD : 'k aead_state -> cipher_st -(* Sexplib stubs -- rethink how to play with crypto. *) -let sexp_of_cipher_st = function - | CBC _ -> Sexp.Atom "" - | AEAD _ -> Sexp.Atom "" - -(* *** *) - (* context of a TLS connection (both in and out has each one of these) *) type crypto_context = { sequence : int64 ; (* sequence number *) cipher_st : cipher_st ; (* cipher state *) -} [@@deriving sexp_of] - +} (* the raw handshake log we need to carry around *) -type hs_log = Cstruct_sexp.t list [@@deriving sexp_of] +type hs_log = Cstruct.t list type dh_secret = [ | `Finite_field of Mirage_crypto_pk.Dh.secret @@ -63,27 +51,24 @@ type dh_secret = [ | `P521 of Mirage_crypto_ec.P521.Dh.secret | `X25519 of Mirage_crypto_ec.X25519.secret ] -let sexp_of_dh_secret _ = Sexp.Atom "dh_secret" -let dh_secret_of_sexp = Conv.of_sexp_error "dh_secret_of_sexp: not implemented" - (* a collection of client and server verify bytes for renegotiation *) -type reneg_params = Cstruct_sexp.t * Cstruct_sexp.t [@@deriving sexp_of] +type reneg_params = Cstruct.t * Cstruct.t type common_session_data = { - server_random : Cstruct_sexp.t ; (* 32 bytes random from the server hello *) - client_random : Cstruct_sexp.t ; (* 32 bytes random from the client hello *) - peer_certificate_chain : Cert.t list ; - peer_certificate : Cert.t option ; - trust_anchor : Cert.t option ; - received_certificates : Cert.t list ; - own_certificate : Cert.t list ; - own_private_key : Priv.t option ; - own_name : Peer_name.t option ; + server_random : Cstruct.t ; (* 32 bytes random from the server hello *) + client_random : Cstruct.t ; (* 32 bytes random from the client hello *) + peer_certificate_chain : X509.Certificate.t list ; + peer_certificate : X509.Certificate.t option ; + trust_anchor : X509.Certificate.t option ; + received_certificates : X509.Certificate.t list ; + own_certificate : X509.Certificate.t list ; + own_private_key : X509.Private_key.t option ; + own_name : [`host] Domain_name.t option ; client_auth : bool ; master_secret : master_secret ; alpn_protocol : string option ; (* selected alpn protocol after handshake *) -} [@@deriving sexp_of] +} type session_data = { common_session_data : common_session_data ; @@ -91,9 +76,9 @@ type session_data = { ciphersuite : Ciphersuite.ciphersuite ; group : group option ; renegotiation : reneg_params ; (* renegotiation data *) - session_id : Cstruct_sexp.t ; + session_id : Cstruct.t ; extended_ms : bool ; -} [@@deriving sexp_of] +} (* state machine of the server *) type server_handshake_state = @@ -105,11 +90,10 @@ type server_handshake_state = | AwaitClientKeyExchange_DHE of session_data * dh_secret * hs_log (* server hello done is sent, and DHE_RSA key exchange used, waiting for client key exchange *) | AwaitClientCertificateVerify of session_data * crypto_context * crypto_context * hs_log | AwaitClientChangeCipherSpec of session_data * crypto_context * crypto_context * hs_log (* client key exchange received, next should be change cipher spec *) - | AwaitClientChangeCipherSpecResume of session_data * crypto_context * Cstruct_sexp.t * hs_log (* resumption: next should be change cipher spec *) + | AwaitClientChangeCipherSpecResume of session_data * crypto_context * Cstruct.t * hs_log (* resumption: next should be change cipher spec *) | AwaitClientFinished of session_data * hs_log (* change cipher spec received, next should be the finished including a hmac over all handshake packets *) - | AwaitClientFinishedResume of session_data * Cstruct_sexp.t * hs_log (* change cipher spec received, next should be the finished including a hmac over all handshake packets *) + | AwaitClientFinishedResume of session_data * Cstruct.t * hs_log (* change cipher spec received, next should be the finished including a hmac over all handshake packets *) | Established (* handshake successfully completed *) - [@@deriving sexp_of] (* state machine of the client *) type client_handshake_state = @@ -119,20 +103,19 @@ type client_handshake_state = | AwaitCertificate_RSA of session_data * hs_log (* certificate expected with RSA key exchange *) | AwaitCertificate_DHE of session_data * hs_log (* certificate expected with DHE key exchange *) | AwaitServerKeyExchange_DHE of session_data * hs_log (* server key exchange expected with DHE *) - | AwaitCertificateRequestOrServerHelloDone of session_data * Cstruct_sexp.t * Cstruct_sexp.t * hs_log (* server hello done expected, client key exchange and premastersecret are ready *) - | AwaitServerHelloDone of session_data * signature_algorithm list option * Cstruct_sexp.t * Cstruct_sexp.t * hs_log (* server hello done expected, client key exchange and premastersecret are ready *) - | AwaitServerChangeCipherSpec of session_data * crypto_context * Cstruct_sexp.t * hs_log (* change cipher spec expected *) + | AwaitCertificateRequestOrServerHelloDone of session_data * Cstruct.t * Cstruct.t * hs_log (* server hello done expected, client key exchange and premastersecret are ready *) + | AwaitServerHelloDone of session_data * signature_algorithm list option * Cstruct.t * Cstruct.t * hs_log (* server hello done expected, client key exchange and premastersecret are ready *) + | AwaitServerChangeCipherSpec of session_data * crypto_context * Cstruct.t * hs_log (* change cipher spec expected *) | AwaitServerChangeCipherSpecResume of session_data * crypto_context * crypto_context * hs_log (* change cipher spec expected *) - | AwaitServerFinished of session_data * Cstruct_sexp.t * hs_log (* finished expected with a hmac over all handshake packets *) + | AwaitServerFinished of session_data * Cstruct.t * hs_log (* finished expected with a hmac over all handshake packets *) | AwaitServerFinishedResume of session_data * hs_log (* finished expected with a hmac over all handshake packets *) | Established (* handshake successfully completed *) - [@@deriving sexp_of] type kdf = { - secret : Cstruct_sexp.t ; + secret : Cstruct.t ; cipher : Ciphersuite.ciphersuite13 ; - hash : Ciphersuite.H.t ; -} [@@deriving sexp_of] + hash : Mirage_crypto.Hash.hash ; +} (* TODO needs log of CH..CF for post-handshake auth *) (* TODO drop master_secret!? *) @@ -140,38 +123,35 @@ type session_data13 = { common_session_data13 : common_session_data ; ciphersuite13 : Ciphersuite.ciphersuite13 ; master_secret : kdf ; - resumption_secret : Cstruct_sexp.t ; + resumption_secret : Cstruct.t ; state : epoch_state ; resumed : bool ; - client_app_secret : Cstruct_sexp.t ; - server_app_secret : Cstruct_sexp.t ; -} [@@deriving sexp_of] + client_app_secret : Cstruct.t ; + server_app_secret : Cstruct.t ; +} type client13_handshake_state = - | AwaitServerHello13 of client_hello * (group * dh_secret) list * Cstruct_sexp.t (* this is for CH1 ~> HRR ~> CH2 <~ WAIT SH *) - | AwaitServerEncryptedExtensions13 of session_data13 * Cstruct_sexp.t * Cstruct_sexp.t * Cstruct_sexp.t - | AwaitServerCertificateRequestOrCertificate13 of session_data13 * Cstruct_sexp.t * Cstruct_sexp.t * Cstruct_sexp.t - | AwaitServerCertificate13 of session_data13 * Cstruct_sexp.t * Cstruct_sexp.t * signature_algorithm list option * Cstruct_sexp.t - | AwaitServerCertificateVerify13 of session_data13 * Cstruct_sexp.t * Cstruct_sexp.t * signature_algorithm list option * Cstruct_sexp.t - | AwaitServerFinished13 of session_data13 * Cstruct_sexp.t * Cstruct_sexp.t * signature_algorithm list option * Cstruct_sexp.t + | AwaitServerHello13 of client_hello * (group * dh_secret) list * Cstruct.t (* this is for CH1 ~> HRR ~> CH2 <~ WAIT SH *) + | AwaitServerEncryptedExtensions13 of session_data13 * Cstruct.t * Cstruct.t * Cstruct.t + | AwaitServerCertificateRequestOrCertificate13 of session_data13 * Cstruct.t * Cstruct.t * Cstruct.t + | AwaitServerCertificate13 of session_data13 * Cstruct.t * Cstruct.t * signature_algorithm list option * Cstruct.t + | AwaitServerCertificateVerify13 of session_data13 * Cstruct.t * Cstruct.t * signature_algorithm list option * Cstruct.t + | AwaitServerFinished13 of session_data13 * Cstruct.t * Cstruct.t * signature_algorithm list option * Cstruct.t | Established13 - [@@deriving sexp_of] type server13_handshake_state = | AwaitClientHelloHRR13 (* if we sent out HRR (also to-be-used for tls13-only) *) - | AwaitClientCertificate13 of session_data13 * Cstruct_sexp.t * crypto_context * session_ticket option * Cstruct_sexp.t - | AwaitClientCertificateVerify13 of session_data13 * Cstruct_sexp.t * crypto_context * session_ticket option * Cstruct_sexp.t - | AwaitClientFinished13 of Cstruct_sexp.t * crypto_context * session_ticket option * Cstruct_sexp.t - | AwaitEndOfEarlyData13 of Cstruct_sexp.t * crypto_context * crypto_context * session_ticket option * Cstruct_sexp.t + | AwaitClientCertificate13 of session_data13 * Cstruct.t * crypto_context * session_ticket option * Cstruct.t + | AwaitClientCertificateVerify13 of session_data13 * Cstruct.t * crypto_context * session_ticket option * Cstruct.t + | AwaitClientFinished13 of Cstruct.t * crypto_context * session_ticket option * Cstruct.t + | AwaitEndOfEarlyData13 of Cstruct.t * crypto_context * crypto_context * session_ticket option * Cstruct.t | Established13 - [@@deriving sexp_of] type handshake_machina_state = | Client of client_handshake_state | Server of server_handshake_state | Client13 of client13_handshake_state | Server13 of server13_handshake_state - [@@deriving sexp_of] (* state during a handshake, used in the handlers *) type handshake_state = { @@ -180,14 +160,14 @@ type handshake_state = { early_data_left : int32 ; machina : handshake_machina_state ; (* state machine state *) config : Config.config ; (* given config *) - hs_fragment : Cstruct_sexp.t ; (* handshake messages can be fragmented, leftover from before *) -} [@@deriving sexp_of] + hs_fragment : Cstruct.t ; (* handshake messages can be fragmented, leftover from before *) +} (* connection state: initially None, after handshake a crypto context *) -type crypto_state = crypto_context option [@@deriving sexp_of] +type crypto_state = crypto_context option (* record consisting of a content type and a byte vector *) -type record = Packet.content_type * Cstruct_sexp.t [@@deriving sexp_of] +type record = Packet.content_type * Cstruct.t (* response returned by a handler *) type rec_resp = [ @@ -204,33 +184,35 @@ type state = { handshake : handshake_state ; (* the current handshake state *) decryptor : crypto_state ; (* the current decryption state *) encryptor : crypto_state ; (* the current encryption state *) - fragment : Cstruct_sexp.t ; (* the leftover fragment from TCP fragmentation *) -} [@@deriving sexp_of] - -module V_err = struct - type t = X509.Validation.validation_error - let sexp_of_t v = - let s = Fmt.to_to_string X509.Validation.pp_validation_error v in - Sexplib.Sexp.Atom s -end - -module Ec_err = struct - type t = Mirage_crypto_ec.error - let t_of_sexp _ = failwith "couldn't convert validatin error from sexp" - let sexp_of_t v = - let s = Fmt.to_to_string Mirage_crypto_ec.pp_error v in - Sexplib.Sexp.Atom s -end + fragment : Cstruct.t ; (* the leftover fragment from TCP fragmentation *) +} type error = [ - | `AuthenticationFailure of V_err.t + | `AuthenticationFailure of X509.Validation.validation_error | `NoConfiguredCiphersuite of Ciphersuite.ciphersuite list | `NoConfiguredVersions of tls_version list | `NoConfiguredSignatureAlgorithm of signature_algorithm list | `NoMatchingCertificateFound of string | `NoCertificateConfigured | `CouldntSelectCertificate -] [@@deriving sexp_of] +] + +let pp_error ppf = function + | `AuthenticationFailure v -> + Fmt.pf ppf "authentication failure: %a" X509.Validation.pp_validation_error v + | `NoConfiguredCiphersuite cs -> + Fmt.pf ppf "no configured ciphersuite: %a" + Fmt.(list ~sep:(any ", ") Ciphersuite.pp_ciphersuite) cs + | `NoConfiguredVersions vs -> + Fmt.pf ppf "no configured version: %a" + Fmt.(list ~sep:(any ", ") pp_tls_version) vs + | `NoConfiguredSignatureAlgorithm sas -> + Fmt.pf ppf "no configure signature algorithm: %a" + Fmt.(list ~sep:(any ", ") pp_signature_algorithm) sas + | `NoMatchingCertificateFound host -> + Fmt.pf ppf "no matching certificate found for %s" host + | `NoCertificateConfigured -> Fmt.string ppf "no certificate configured" + | `CouldntSelectCertificate -> Fmt.string ppf "couldn't select certificate" type client_hello_errors = [ | `EmptyCiphersuites @@ -242,11 +224,43 @@ type client_hello_errors = [ | `NoKeyShareExtension | `NoSupportedGroupExtension | `NotSetSupportedGroup of Packet.named_group list - | `NotSetKeyShare of (Packet.named_group * Cstruct_sexp.t) list - | `NotSubsetKeyShareSupportedGroup of (Packet.named_group list * (Packet.named_group * Cstruct_sexp.t) list) + | `NotSetKeyShare of (Packet.named_group * Cstruct.t) list + | `NotSubsetKeyShareSupportedGroup of Packet.named_group list * (Packet.named_group * Cstruct.t) list | `Has0rttAfterHRR | `NoCookie -] [@@deriving sexp_of] +] + +let pp_client_hello_error ppf = function + | `EmptyCiphersuites -> Fmt.string ppf "empty ciphersuites" + | `NotSetCiphersuites cs -> + Fmt.pf ppf "ciphersuites not a set: %a" + Fmt.(list ~sep:(any ", ") Ciphersuite.pp_any_ciphersuite) cs + | `NoSupportedCiphersuite cs -> + Fmt.pf ppf "no supported ciphersuite %a" + Fmt.(list ~sep:(any ", ") Ciphersuite.pp_any_ciphersuite) cs + | `NotSetExtension _ -> Fmt.string ppf "extensions not a set" + | `NoSignatureAlgorithmsExtension -> + Fmt.string ppf "no signature algorithms extension" + | `NoGoodSignatureAlgorithms sas -> + Fmt.pf ppf "no good signature algorithm: %a" + Fmt.(list ~sep:(any ", ") pp_signature_algorithm) sas + | `NoKeyShareExtension -> Fmt.string ppf "no keyshare extension" + | `NoSupportedGroupExtension -> + Fmt.string ppf "no supported group extension" + | `NotSetSupportedGroup groups -> + Fmt.pf ppf "supported groups not a set: %a" + Fmt.(list ~sep:(any ", ") int) (List.map Packet.named_group_to_int groups) + | `NotSetKeyShare ks -> + Fmt.pf ppf "key share not a set: %a" + Fmt.(list ~sep:(any ", ") int) + (List.map (fun (g, _) -> Packet.named_group_to_int g) ks) + | `NotSubsetKeyShareSupportedGroup (ng, ks) -> + Fmt.pf ppf "key share not a subset of supported groups: %a@ keyshare %a" + Fmt.(list ~sep:(any ", ") int) (List.map Packet.named_group_to_int ng) + Fmt.(list ~sep:(any ", ") int) + (List.map (fun (g, _) -> Packet.named_group_to_int g) ks) + | `Has0rttAfterHRR -> Fmt.string ppf "has 0RTT after HRR" + | `NoCookie -> Fmt.string ppf "no cookie" type fatal = [ | `NoSecureRenegotiation @@ -272,7 +286,7 @@ type fatal = [ | `HandshakeFragmentsNotEmpty | `InsufficientDH | `InvalidDH - | `BadECDH of Ec_err.t + | `BadECDH of Mirage_crypto_ec.error | `InvalidRenegotiation | `InvalidClientHello of client_hello_errors | `InvalidServerHello @@ -290,12 +304,70 @@ type fatal = [ | `MissingContentType | `Downgrade12 | `Downgrade11 -] [@@deriving sexp_of] +] + +let pp_fatal ppf = function + | `NoSecureRenegotiation -> Fmt.string ppf "no secure renegotiation" + | `NoSupportedGroup -> Fmt.string ppf "no supported group" + | `NoVersions vs -> + Fmt.pf ppf "no versions %a" Fmt.(list ~sep:(any ", ") pp_tls_any_version) vs + | `ReaderError re -> Fmt.pf ppf "reader error: %a" Reader.pp_error re + | `NoCertificateReceived -> Fmt.string ppf "no certificate received" + | `NoCertificateVerifyReceived -> + Fmt.string ppf "no certificate verify received" + | `NotRSACertificate -> Fmt.string ppf "not a RSA certificate" + | `KeyTooSmall -> Fmt.string ppf "key too small" + | `SignatureVerificationFailed msg -> + Fmt.pf ppf "signature verification failed: %s" msg + | `SigningFailed msg -> Fmt.pf ppf "signing failed: %s" msg + | `BadCertificateChain -> Fmt.string ppf "bad certificate chain" + | `MACMismatch -> Fmt.string ppf "MAC mismatch" + | `MACUnderflow -> Fmt.string ppf "MAC underflow" + | `RecordOverflow n -> Fmt.pf ppf "record overflow %u" n + | `UnknownRecordVersion (m, n) -> + Fmt.pf ppf "unknown record version %u.%u" m n + | `UnknownContentType c -> Fmt.pf ppf "unknown content type %u" c + | `CannotHandleApplicationDataYet -> + Fmt.string ppf "cannot handle application data yet" + | `NoHeartbeat -> Fmt.string ppf "no heartbeat" + | `BadRecordVersion v -> + Fmt.pf ppf "bad record version %a" pp_tls_any_version v + | `BadFinished -> Fmt.string ppf "bad finished" + | `HandshakeFragmentsNotEmpty -> + Fmt.string ppf "handshake fragments not empty" + | `InsufficientDH -> Fmt.string ppf "insufficient DH" + | `InvalidDH -> Fmt.string ppf "invalid DH" + | `BadECDH e -> Fmt.pf ppf "bad ECDH %a" Mirage_crypto_ec.pp_error e + | `InvalidRenegotiation -> Fmt.string ppf "invalid renegotiation" + | `InvalidClientHello ce -> + Fmt.pf ppf "invalid client hello: %a" pp_client_hello_error ce + | `InvalidServerHello -> Fmt.string ppf "invalid server hello" + | `InvalidRenegotiationVersion v -> + Fmt.pf ppf "invalid renegotiation version %a" pp_tls_version v + | `InappropriateFallback -> Fmt.string ppf "inappropriate fallback" + | `UnexpectedCCS -> Fmt.string ppf "unexpected change cipher spec" + | `UnexpectedHandshake hs -> + Fmt.pf ppf "unexpected handshake %a" pp_handshake hs + | `InvalidCertificateUsage -> Fmt.string ppf "invalid certificate usage" + | `InvalidCertificateExtendedUsage -> + Fmt.string ppf "invalid certificate extended usage" + | `InvalidSession -> Fmt.string ppf "invalid session" + | `NoApplicationProtocol -> Fmt.string ppf "no application protocol" + | `HelloRetryRequest -> Fmt.string ppf "hello retry request" + | `InvalidMessage -> Fmt.string ppf "invalid message" + | `Toomany0rttbytes -> Fmt.string ppf "too many 0RTT bytes" + | `MissingContentType -> Fmt.string ppf "missing content type" + | `Downgrade12 -> Fmt.string ppf "downgrade 1.2" + | `Downgrade11 -> Fmt.string ppf "downgrade 1.1" type failure = [ | `Error of error | `Fatal of fatal -] [@@deriving sexp_of] +] + +let pp_failure ppf = function + | `Error e -> pp_error ppf e + | `Fatal f -> pp_fatal ppf f let common_data_to_epoch common is_server peer_name = let own_random, peer_random = diff --git a/lib/tracing.ml b/lib/tracing.ml deleted file mode 100644 index 05d1bda1..00000000 --- a/lib/tracing.ml +++ /dev/null @@ -1,21 +0,0 @@ -(* This is so not thread-safe it's not even funny. *) - -let src = Logs.Src.create "tls.tracing" ~doc:"TLS tracing" -module Log = (val Logs.src_log src : Logs.LOG) - -let form_trace id sexp = - let open Sexplib in - Sexp.(List [ Atom id ; sexp ]) - -let sexp ~tag lz = - Log.debug (fun m -> m "%a" Sexplib.Sexp.pp_hum (form_trace tag (Lazy.force lz))) - -let sexps ~tag lzs = List.iter (sexp ~tag) lzs - -let sexpf ~tag ~f x = sexp ~tag @@ lazy (f x) - -let sexpfs ~tag ~f xs = List.iter (sexpf ~tag ~f) xs - -let cs ~tag = sexpf ~tag ~f:(fun cs -> Cstruct.hexdump cs ; Sexplib.Sexp.Atom "") - -let css ~tag css = List.iter (cs ~tag) css diff --git a/lib/tracing.mli b/lib/tracing.mli deleted file mode 100644 index f4ebf0c5..00000000 --- a/lib/tracing.mli +++ /dev/null @@ -1,13 +0,0 @@ - -open Sexplib - -val sexp : tag:string -> Sexp.t Lazy.t -> unit -val sexps : tag:string -> Sexp.t Lazy.t list -> unit - -val sexpf : tag:string -> f:('a -> Sexp.t) -> 'a -> unit -val sexpfs : tag:string -> f:('a -> Sexp.t) -> 'a list -> unit - -val cs : tag:string -> Cstruct.t -> unit -val css : tag:string -> Cstruct.t list -> unit - -val src : Logs.src diff --git a/lwt/examples/echo_server.ml b/lwt/examples/echo_server.ml index fa862291..8ba0e9db 100644 --- a/lwt/examples/echo_server.ml +++ b/lwt/examples/echo_server.ml @@ -28,7 +28,7 @@ let serve_ssl port callback = | Tls_lwt.Tls_alert a -> yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a | Tls_lwt.Tls_failure a -> - yap ~tag @@ "handler: " ^ Tls.Engine.string_of_failure a + yap ~tag @@ "handler: " ^ Fmt.to_to_string Tls.Engine.pp_failure a | Unix.Unix_error (e, f, p) -> yap ~tag @@ "handler: " ^ (string_of_unix_err e f p) | _exn -> yap ~tag "handler: exception") @@ -43,7 +43,7 @@ let serve_ssl port callback = (function | Unix.Unix_error (e, f, p) -> return (`L (string_of_unix_err e f p)) | Tls_lwt.Tls_alert a -> return (`L (Tls.Packet.alert_type_to_string a)) - | Tls_lwt.Tls_failure f -> return (`L (Tls.Engine.string_of_failure f)) + | Tls_lwt.Tls_failure f -> return (`L (Fmt.to_to_string Tls.Engine.pp_failure f)) | exn -> return (`L ("loop: exception: " ^ Printexc.to_string exn)))) >>= function | `R (channels, addr) -> yap ~tag "-> connect" >>= fun () -> ( handle channels addr ; loop s ) diff --git a/lwt/examples/ex_common.ml b/lwt/examples/ex_common.ml index a0353dd9..51a92fff 100644 --- a/lwt/examples/ex_common.ml +++ b/lwt/examples/ex_common.ml @@ -23,7 +23,7 @@ let print_alert where alert = let print_fail where fail = Printf.eprintf "(TLS FAIL (%s): %s)\n%!" - where (Tls.Engine.string_of_failure fail) + where (Fmt.to_to_string Tls.Engine.pp_failure fail) let null_auth ?ip:_ ~host:_ _ = Ok None diff --git a/lwt/examples/fuzz_server.ml b/lwt/examples/fuzz_server.ml index 8f69e03e..0d64f94a 100644 --- a/lwt/examples/fuzz_server.ml +++ b/lwt/examples/fuzz_server.ml @@ -45,7 +45,7 @@ let serve_ssl port callback = | Tls_lwt.Tls_alert a -> yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a | Tls_lwt.Tls_failure a -> - yap ~tag @@ "handler: " ^ Tls.Engine.string_of_failure a + yap ~tag @@ "handler: " ^ Fmt.to_to_string Tls.Engine.pp_failure a | Unix.Unix_error (e, f, p) -> yap ~tag @@ "handler: " ^ (string_of_unix_err e f p) | _exn -> yap ~tag "handler: exception") @@ -59,7 +59,7 @@ let serve_ssl port callback = (function | Unix.Unix_error (e, f, p) -> return (`L (string_of_unix_err e f p)) | Tls_lwt.Tls_alert a -> return (`L (Tls.Packet.alert_type_to_string a)) - | Tls_lwt.Tls_failure f -> return (`L (Tls.Engine.string_of_failure f)) + | Tls_lwt.Tls_failure f -> return (`L (Fmt.to_to_string Tls.Engine.pp_failure f)) | exn -> let str = Printexc.to_string exn in return (`L ("loop: exception " ^ str)))) >>= function | `R (t, addr) -> let channels = Tls_lwt.of_t t in diff --git a/lwt/examples/resume_client.ml b/lwt/examples/resume_client.ml index f7b0d526..63c985f2 100644 --- a/lwt/examples/resume_client.ml +++ b/lwt/examples/resume_client.ml @@ -14,7 +14,6 @@ let http_client ?ca ?fp hostname port = | Ok e -> e | Error () -> invalid_arg "error retrieving epoch" in - Printf.printf "cached session: %s\n" (Sexplib.Sexp.to_string_hum (Tls.Core.sexp_of_epoch_data cached_session)) ; Tls_lwt.Unix.close t >>= fun () -> Printf.printf "closed session\n" ; let config = Tls.Config.client ~authenticator ~cached_session () in diff --git a/lwt/examples/resume_echo_server.ml b/lwt/examples/resume_echo_server.ml index b7a48ed5..0684640c 100644 --- a/lwt/examples/resume_echo_server.ml +++ b/lwt/examples/resume_echo_server.ml @@ -74,7 +74,7 @@ let serve_ssl port callback = | Tls_lwt.Tls_alert a -> yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a | Tls_lwt.Tls_failure a -> - yap ~tag @@ "handler: " ^ Tls.Engine.string_of_failure a + yap ~tag @@ "handler: " ^ Fmt.to_to_string Tls.Engine.pp_failure a | Unix.Unix_error (e, f, p) -> yap ~tag @@ "handler: " ^ (string_of_unix_err e f p) | _exn -> yap ~tag "handler: exception") @@ -96,7 +96,7 @@ let serve_ssl port callback = (function | Unix.Unix_error (e, f, p) -> return (`L (string_of_unix_err e f p)) | Tls_lwt.Tls_alert a -> return (`L (Tls.Packet.alert_type_to_string a)) - | Tls_lwt.Tls_failure f -> return (`L (Tls.Engine.string_of_failure f)) + | Tls_lwt.Tls_failure f -> return (`L (Fmt.to_to_string Tls.Engine.pp_failure f)) | exn -> let str = Printexc.to_string exn in return (`L ("loop: exception " ^ str)))) >>= function | `R t -> yap ~tag "-> connect" >>= fun () -> diff --git a/lwt/examples/test_client.ml b/lwt/examples/test_client.ml index 5b992091..637cbd0c 100644 --- a/lwt/examples/test_client.ml +++ b/lwt/examples/test_client.ml @@ -5,11 +5,7 @@ let mypsk = ref None let ticket_cache = { Tls.Config.lookup = (fun _ -> None) ; - ticket_granted = (fun psk epoch -> - Logs.info (fun m -> m "ticket granted %a %a" - Sexplib.Sexp.pp_hum (Tls.Core.sexp_of_psk13 psk) - Sexplib.Sexp.pp_hum (Tls.Core.sexp_of_epoch_data epoch)) ; - mypsk := Some (psk, epoch)) ; + ticket_granted = (fun psk epoch -> mypsk := Some (psk, epoch)) ; lifetime = 0l ; timestamp = Ptime_clock.now } diff --git a/lwt/tls_lwt.ml b/lwt/tls_lwt.ml index 2740376d..d0b94a84 100644 --- a/lwt/tls_lwt.ml +++ b/lwt/tls_lwt.ml @@ -283,5 +283,5 @@ let () = | Tls_alert typ -> Some ("TLS alert from peer: " ^ Tls.Packet.alert_type_to_string typ) | Tls_failure f -> - Some ("TLS failure: " ^ Tls.Engine.string_of_failure f) + Some ("TLS failure: " ^ Fmt.to_to_string Tls.Engine.pp_failure f) | _ -> None) diff --git a/mirage/tls_mirage.ml b/mirage/tls_mirage.ml index 4e3087bf..f1beacc5 100644 --- a/mirage/tls_mirage.ml +++ b/mirage/tls_mirage.ml @@ -12,7 +12,7 @@ module Make (F : Mirage_flow.S) = struct type write_error = [ Mirage_flow.write_error | error ] let pp_error ppf = function - | `Tls_failure f -> Fmt.string ppf @@ Tls.Engine.string_of_failure f + | `Tls_failure f -> Tls.Engine.pp_failure ppf f | `Tls_alert a -> Fmt.string ppf @@ Tls.Packet.alert_type_to_string a | `Read e -> F.pp_error ppf e | `Write e -> F.pp_write_error ppf e diff --git a/tests/feedback.ml b/tests/feedback.ml index c669aa03..383b3cd3 100644 --- a/tests/feedback.ml +++ b/tests/feedback.ml @@ -22,7 +22,7 @@ module Flow = struct (rewrap_st (state, st'), ans, appdata) | Error (a, _) -> failwith @@ Printf.sprintf "[%s] %s error: %s" - tag descr (Sexplib.Sexp.to_string_hum (Tls.Engine.sexp_of_failure a)) + tag descr (Fmt.to_to_string Tls.Engine.pp_failure a) | Ok _ -> failwith "decoded alert" end diff --git a/tests/key_derivation.ml b/tests/key_derivation.ml index d08b35d0..2875b0bd 100644 --- a/tests/key_derivation.ml +++ b/tests/key_derivation.ml @@ -531,7 +531,7 @@ let self_signature () = (Mirage_crypto.Hash.digest hash log) cert with | Ok () -> () - | Error e -> Alcotest.fail ("self-verification failed " ^ (Tls.Engine.string_of_failure e)) + | Error e -> Alcotest.fail ("self-verification failed " ^ Fmt.to_to_string Tls.Engine.pp_failure e) let wire_signature () = (* let buf = Writer.assemble_handshake (CertificateVerify data) in @@ -542,7 +542,7 @@ let wire_signature () = (Mirage_crypto.Hash.digest hash log) cert with | Ok () -> () - | Error e -> Alcotest.fail ("trace-verification failed " ^ (Tls.Engine.string_of_failure e)) + | Error e -> Alcotest.fail ("trace-verification failed " ^ Fmt.to_to_string Tls.Engine.pp_failure e) let res_secret_00 = Cstruct.of_hex {| 4e cd 0e b6 ec 3b 4d 87 f5 d6 02 8f 92 2c a4 c5 diff --git a/tls.opam b/tls.opam index 94b2bd90..ea694a18 100644 --- a/tls.opam +++ b/tls.opam @@ -16,11 +16,7 @@ build: [ depends: [ "ocaml" {>= "4.08.0"} "dune" {>= "3.0"} - "ppx_sexp_conv" {>= "v0.9.0"} - "ppx_cstruct" {>= "3.0.0"} "cstruct" {>= "6.0.0"} - "cstruct-sexp" - "sexplib" "mirage-crypto" {>= "0.11.0"} "mirage-crypto-ec" {>= "0.10.0"} "mirage-crypto-pk" @@ -33,7 +29,6 @@ depends: [ "hkdf" "logs" "ipaddr" - "ipaddr-sexp" "alcotest" {with-test} "randomconv" {with-test} ]