Skip to content

Commit

Permalink
remove sexp
Browse files Browse the repository at this point in the history
  • Loading branch information
@hannesm
hannesm committed Feb 22, 2023
1 parent 9972c9f commit 9ec45e5
Show file tree
Hide file tree
Showing 27 changed files with 562 additions and 395 deletions.
2 changes: 1 addition & 1 deletion eio/tls_eio.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
75 changes: 56 additions & 19 deletions lib/ciphersuite.ml
View file
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -13,32 +21,47 @@ 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
| AES_256_CCM
| 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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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))
Expand Down Expand Up @@ -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
Expand Down
91 changes: 58 additions & 33 deletions lib/config.ml
View file
Original file line number Diff line number Diff line change
@@ -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 ;
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
12 changes: 5 additions & 7 deletions lib/config.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 = [
Expand All @@ -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 *)
Expand All @@ -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} *)

Expand Down
Loading

0 comments on commit 9ec45e5

Please sign in to comment.