swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

366
unikernel/duniverse/ocaml-tls/lib/ciphersuite.ml Normal file
View file

@ -0,0 +1,366 @@
(** Ciphersuite definitions and some helper functions. *)
(** sum type of all possible key exchange methods *)
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
| #key_exchange_algorithm_dhe -> `Digital_signature
| `RSA -> `Key_encipherment
type block_cipher =
| TRIPLE_DES_EDE_CBC
| AES_128_CBC
| AES_256_CBC
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
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"
type payload_protection13 = [ `AEAD of aead_cipher ]
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 * Digestif.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
| AES_128_GCM -> (16, 12)
| AES_256_GCM -> (32, 12)
| AES_128_CCM -> (16, 12)
| AES_256_CCM -> (32, 12)
| CHACHA20_POLY1305 -> (32, 12)
(** [key_length iv payload_protection] is [(key size, IV size, mac size)] where key IV, and mac sizes are the required bytes for the given [payload_protection] *)
(* NB only used for <= TLS 1.2, IV length for AEAD defined in RFC 5288 Section 3 (for GCM), salt[4] for CCM in RFC 6655 Section 3 *)
let key_length iv pp =
let mac_size m =
let module H = (val Digestif.module_of_hash' m) in
H.digest_size
in
match pp with
| `AEAD AES_128_CCM -> (16, 4 , 0)
| `AEAD AES_256_CCM -> (32, 4 , 0)
| `AEAD AES_128_GCM -> (16, 4 , 0)
| `AEAD AES_256_GCM -> (32, 4 , 0)
| `AEAD CHACHA20_POLY1305 -> (32, 12, 0)
| `Block (bc, mac) ->
let keylen, ivlen = match bc with
| TRIPLE_DES_EDE_CBC -> (24, 8)
| AES_128_CBC -> (16, 16)
| AES_256_CBC -> (32, 16)
and maclen = mac_size mac
in
match iv with
| None -> (keylen, 0, maclen)
| Some () -> (keylen, ivlen, maclen)
type ciphersuite13 = [
| `AES_128_GCM_SHA256
| `AES_256_GCM_SHA384
| `CHACHA20_POLY1305_SHA256
| `AES_128_CCM_SHA256
]
let privprot13 = function
| `AES_128_GCM_SHA256 -> AES_128_GCM
| `AES_256_GCM_SHA384 -> AES_256_GCM
| `CHACHA20_POLY1305_SHA256 -> CHACHA20_POLY1305
| `AES_128_CCM_SHA256 -> AES_128_CCM
let hash13 = function
| `AES_128_GCM_SHA256 -> `SHA256
| `AES_256_GCM_SHA384 -> `SHA384
| `CHACHA20_POLY1305_SHA256 -> `SHA256
| `AES_128_CCM_SHA256 -> `SHA256
let any_ciphersuite_to_ciphersuite13 = function
| Packet.TLS_AES_128_GCM_SHA256 -> Some `AES_128_GCM_SHA256
| Packet.TLS_AES_256_GCM_SHA384 -> Some `AES_256_GCM_SHA384
| Packet.TLS_CHACHA20_POLY1305_SHA256 -> Some `CHACHA20_POLY1305_SHA256
| Packet.TLS_AES_128_CCM_SHA256 -> Some `AES_128_CCM_SHA256
| _ -> None
type ciphersuite = [
ciphersuite13
| `DHE_RSA_WITH_AES_128_GCM_SHA256
| `DHE_RSA_WITH_AES_256_GCM_SHA384
| `DHE_RSA_WITH_AES_256_CCM
| `DHE_RSA_WITH_AES_128_CCM
| `DHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `DHE_RSA_WITH_AES_256_CBC_SHA256
| `DHE_RSA_WITH_AES_128_CBC_SHA256
| `DHE_RSA_WITH_AES_256_CBC_SHA
| `DHE_RSA_WITH_AES_128_CBC_SHA
| `DHE_RSA_WITH_3DES_EDE_CBC_SHA
| `ECDHE_RSA_WITH_AES_128_GCM_SHA256
| `ECDHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `ECDHE_RSA_WITH_AES_256_CBC_SHA384
| `ECDHE_RSA_WITH_AES_128_CBC_SHA256
| `ECDHE_RSA_WITH_AES_256_CBC_SHA
| `ECDHE_RSA_WITH_AES_128_CBC_SHA
| `ECDHE_RSA_WITH_3DES_EDE_CBC_SHA
| `RSA_WITH_AES_256_CBC_SHA256
| `RSA_WITH_AES_128_CBC_SHA256
| `RSA_WITH_AES_256_CBC_SHA
| `RSA_WITH_AES_128_CBC_SHA
| `RSA_WITH_3DES_EDE_CBC_SHA
| `RSA_WITH_AES_128_GCM_SHA256
| `RSA_WITH_AES_256_GCM_SHA384
| `RSA_WITH_AES_256_CCM
| `RSA_WITH_AES_128_CCM
| `ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA256
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384
| `ECDHE_ECDSA_WITH_AES_128_GCM_SHA256
| `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384
| `ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256
]
let ciphersuite_to_ciphersuite13 : ciphersuite -> ciphersuite13 option = function
| #ciphersuite13 as cs -> Some cs
| _ -> None
let any_ciphersuite_to_ciphersuite = function
| Packet.TLS_DHE_RSA_WITH_AES_256_CBC_SHA256 -> Some `DHE_RSA_WITH_AES_256_CBC_SHA256
| Packet.TLS_DHE_RSA_WITH_AES_128_CBC_SHA256 -> Some `DHE_RSA_WITH_AES_128_CBC_SHA256
| Packet.TLS_DHE_RSA_WITH_AES_256_CBC_SHA -> Some `DHE_RSA_WITH_AES_256_CBC_SHA
| Packet.TLS_DHE_RSA_WITH_AES_128_CBC_SHA -> Some `DHE_RSA_WITH_AES_128_CBC_SHA
| Packet.TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA -> Some `DHE_RSA_WITH_3DES_EDE_CBC_SHA
| Packet.TLS_RSA_WITH_AES_256_CBC_SHA256 -> Some `RSA_WITH_AES_256_CBC_SHA256
| Packet.TLS_RSA_WITH_AES_128_CBC_SHA256 -> Some `RSA_WITH_AES_128_CBC_SHA256
| Packet.TLS_RSA_WITH_AES_256_CBC_SHA -> Some `RSA_WITH_AES_256_CBC_SHA
| Packet.TLS_RSA_WITH_AES_128_CBC_SHA -> Some `RSA_WITH_AES_128_CBC_SHA
| Packet.TLS_RSA_WITH_3DES_EDE_CBC_SHA -> Some `RSA_WITH_3DES_EDE_CBC_SHA
| Packet.TLS_RSA_WITH_AES_128_CCM -> Some `RSA_WITH_AES_128_CCM
| Packet.TLS_RSA_WITH_AES_256_CCM -> Some `RSA_WITH_AES_256_CCM
| Packet.TLS_DHE_RSA_WITH_AES_128_CCM -> Some `DHE_RSA_WITH_AES_128_CCM
| Packet.TLS_DHE_RSA_WITH_AES_256_CCM -> Some `DHE_RSA_WITH_AES_256_CCM
| Packet.TLS_RSA_WITH_AES_128_GCM_SHA256 -> Some `RSA_WITH_AES_128_GCM_SHA256
| Packet.TLS_RSA_WITH_AES_256_GCM_SHA384 -> Some `RSA_WITH_AES_256_GCM_SHA384
| Packet.TLS_DHE_RSA_WITH_AES_128_GCM_SHA256 -> Some `DHE_RSA_WITH_AES_128_GCM_SHA256
| Packet.TLS_DHE_RSA_WITH_AES_256_GCM_SHA384 -> Some `DHE_RSA_WITH_AES_256_GCM_SHA384
| Packet.TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256 -> Some `ECDHE_RSA_WITH_AES_128_GCM_SHA256
| Packet.TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384 -> Some `ECDHE_RSA_WITH_AES_256_GCM_SHA384
| Packet.TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384 -> Some `ECDHE_RSA_WITH_AES_256_CBC_SHA384
| Packet.TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256 -> Some `ECDHE_RSA_WITH_AES_128_CBC_SHA256
| Packet.TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA -> Some `ECDHE_RSA_WITH_AES_256_CBC_SHA
| Packet.TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA -> Some `ECDHE_RSA_WITH_AES_128_CBC_SHA
| Packet.TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA -> Some `ECDHE_RSA_WITH_3DES_EDE_CBC_SHA
| Packet.TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> Some `ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| Packet.TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> Some `DHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| Packet.TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA -> Some `ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA
| Packet.TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA -> Some `ECDHE_ECDSA_WITH_AES_128_CBC_SHA
| Packet.TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA -> Some `ECDHE_ECDSA_WITH_AES_256_CBC_SHA
| Packet.TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 -> Some `ECDHE_ECDSA_WITH_AES_128_CBC_SHA256
| Packet.TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 -> Some `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384
| Packet.TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 -> Some `ECDHE_ECDSA_WITH_AES_128_GCM_SHA256
| Packet.TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 -> Some `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384
| Packet.TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 -> Some `ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256
| x -> any_ciphersuite_to_ciphersuite13 x
let ciphersuite_to_any_ciphersuite = function
| `DHE_RSA_WITH_AES_256_CBC_SHA256 -> Packet.TLS_DHE_RSA_WITH_AES_256_CBC_SHA256
| `DHE_RSA_WITH_AES_128_CBC_SHA256 -> Packet.TLS_DHE_RSA_WITH_AES_128_CBC_SHA256
| `DHE_RSA_WITH_AES_256_CBC_SHA -> Packet.TLS_DHE_RSA_WITH_AES_256_CBC_SHA
| `DHE_RSA_WITH_AES_128_CBC_SHA -> Packet.TLS_DHE_RSA_WITH_AES_128_CBC_SHA
| `DHE_RSA_WITH_3DES_EDE_CBC_SHA -> Packet.TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA
| `RSA_WITH_AES_256_CBC_SHA256 -> Packet.TLS_RSA_WITH_AES_256_CBC_SHA256
| `RSA_WITH_AES_128_CBC_SHA256 -> Packet.TLS_RSA_WITH_AES_128_CBC_SHA256
| `RSA_WITH_AES_256_CBC_SHA -> Packet.TLS_RSA_WITH_AES_256_CBC_SHA
| `RSA_WITH_AES_128_CBC_SHA -> Packet.TLS_RSA_WITH_AES_128_CBC_SHA
| `RSA_WITH_3DES_EDE_CBC_SHA -> Packet.TLS_RSA_WITH_3DES_EDE_CBC_SHA
| `RSA_WITH_AES_128_CCM -> Packet.TLS_RSA_WITH_AES_128_CCM
| `RSA_WITH_AES_256_CCM -> Packet.TLS_RSA_WITH_AES_256_CCM
| `DHE_RSA_WITH_AES_128_CCM -> Packet.TLS_DHE_RSA_WITH_AES_128_CCM
| `DHE_RSA_WITH_AES_256_CCM -> Packet.TLS_DHE_RSA_WITH_AES_256_CCM
| `RSA_WITH_AES_128_GCM_SHA256 -> Packet.TLS_RSA_WITH_AES_128_GCM_SHA256
| `RSA_WITH_AES_256_GCM_SHA384 -> Packet.TLS_RSA_WITH_AES_256_GCM_SHA384
| `DHE_RSA_WITH_AES_128_GCM_SHA256 -> Packet.TLS_DHE_RSA_WITH_AES_128_GCM_SHA256
| `DHE_RSA_WITH_AES_256_GCM_SHA384 -> Packet.TLS_DHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_AES_128_GCM_SHA256 -> Packet.TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256
| `ECDHE_RSA_WITH_AES_256_GCM_SHA384 -> Packet.TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_AES_256_CBC_SHA384 -> Packet.TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384
| `ECDHE_RSA_WITH_AES_128_CBC_SHA256 -> Packet.TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256
| `ECDHE_RSA_WITH_AES_256_CBC_SHA -> Packet.TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA
| `ECDHE_RSA_WITH_AES_128_CBC_SHA -> Packet.TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA
| `ECDHE_RSA_WITH_3DES_EDE_CBC_SHA -> Packet.TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA
| `ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> Packet.TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> Packet.TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `AES_128_GCM_SHA256 -> Packet.TLS_AES_128_GCM_SHA256
| `AES_256_GCM_SHA384 -> Packet.TLS_AES_256_GCM_SHA384
| `CHACHA20_POLY1305_SHA256 -> Packet.TLS_CHACHA20_POLY1305_SHA256
| `AES_128_CCM_SHA256 -> Packet.TLS_AES_128_CCM_SHA256
| `ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA -> Packet.TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA -> Packet.TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA -> Packet.TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 -> Packet.TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 -> Packet.TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384
| `ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 -> Packet.TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256
| `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
(** [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))
| `DHE_RSA_WITH_3DES_EDE_CBC_SHA -> (`RSA, `FFDHE, `Block (TRIPLE_DES_EDE_CBC, `SHA1))
| `RSA_WITH_AES_128_CBC_SHA -> (`RSA, `RSA, `Block (AES_128_CBC, `SHA1))
| `DHE_RSA_WITH_AES_128_CBC_SHA -> (`RSA, `FFDHE, `Block (AES_128_CBC, `SHA1))
| `RSA_WITH_AES_256_CBC_SHA -> (`RSA, `RSA, `Block (AES_256_CBC, `SHA1))
| `DHE_RSA_WITH_AES_256_CBC_SHA -> (`RSA, `FFDHE, `Block (AES_256_CBC, `SHA1))
| `RSA_WITH_AES_128_CBC_SHA256 -> (`RSA, `RSA, `Block (AES_128_CBC, `SHA256))
| `RSA_WITH_AES_256_CBC_SHA256 -> (`RSA, `RSA, `Block (AES_256_CBC, `SHA256))
| `DHE_RSA_WITH_AES_128_CBC_SHA256 -> (`RSA, `FFDHE, `Block (AES_128_CBC, `SHA256))
| `DHE_RSA_WITH_AES_256_CBC_SHA256 -> (`RSA, `FFDHE, `Block (AES_256_CBC, `SHA256))
| `RSA_WITH_AES_128_CCM -> (`RSA, `RSA, `AEAD AES_128_CCM)
| `RSA_WITH_AES_256_CCM -> (`RSA, `RSA, `AEAD AES_256_CCM)
| `DHE_RSA_WITH_AES_128_CCM -> (`RSA, `FFDHE, `AEAD AES_128_CCM)
| `DHE_RSA_WITH_AES_256_CCM -> (`RSA, `FFDHE, `AEAD AES_256_CCM)
| `RSA_WITH_AES_128_GCM_SHA256 -> (`RSA, `RSA, `AEAD AES_128_GCM)
| `RSA_WITH_AES_256_GCM_SHA384 -> (`RSA, `RSA, `AEAD AES_256_GCM)
| `DHE_RSA_WITH_AES_128_GCM_SHA256 -> (`RSA, `FFDHE, `AEAD AES_128_GCM)
| `DHE_RSA_WITH_AES_256_GCM_SHA384 -> (`RSA, `FFDHE, `AEAD AES_256_GCM)
| `ECDHE_RSA_WITH_AES_128_GCM_SHA256 -> (`RSA, `ECDHE, `AEAD AES_128_GCM)
| `ECDHE_RSA_WITH_AES_256_GCM_SHA384 -> (`RSA, `ECDHE, `AEAD AES_256_GCM)
| `ECDHE_RSA_WITH_AES_256_CBC_SHA384 -> (`RSA, `ECDHE, `Block (AES_256_CBC, `SHA384))
| `ECDHE_RSA_WITH_AES_128_CBC_SHA256 -> (`RSA, `ECDHE, `Block (AES_128_CBC, `SHA256))
| `ECDHE_RSA_WITH_AES_256_CBC_SHA -> (`RSA, `ECDHE, `Block (AES_256_CBC, `SHA1))
| `ECDHE_RSA_WITH_AES_128_CBC_SHA -> (`RSA, `ECDHE, `Block (AES_128_CBC, `SHA1))
| `ECDHE_RSA_WITH_3DES_EDE_CBC_SHA -> (`RSA, `ECDHE, `Block (TRIPLE_DES_EDE_CBC, `SHA1))
| `DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> (`RSA, `FFDHE, `AEAD CHACHA20_POLY1305)
| `ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 -> (`RSA, `ECDHE, `AEAD CHACHA20_POLY1305)
| `ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA -> (`EC, `ECDHE, `Block (TRIPLE_DES_EDE_CBC, `SHA1))
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA -> (`EC, `ECDHE, `Block (AES_128_CBC, `SHA1))
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA -> (`EC, `ECDHE, `Block (AES_256_CBC, `SHA1))
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 -> (`EC, `ECDHE, `Block (AES_128_CBC, `SHA256))
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 -> (`EC, `ECDHE, `Block (AES_256_CBC, `SHA384))
| `ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 -> (`EC, `ECDHE, `AEAD AES_128_GCM)
| `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 -> (`EC, `ECDHE, `AEAD AES_256_GCM)
| `ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 -> (`EC, `ECDHE, `AEAD CHACHA20_POLY1305)
| #ciphersuite13 as cs13 -> (`RSA, `FFDHE, `AEAD (privprot13 cs13)) (* this is mostly wrong *)
(** [ciphersuite_kex ciphersuite] is [kex], first projection of [get_kex_privprot] *)
let ciphersuite_kex c =
let _keytype, kex, _pp = get_keytype_kex_privprot c in
kex
(** [ciphersuite_privprot ciphersuite] is [privprot], second projection of [get_kex_privprot] *)
let ciphersuite_privprot c =
let _keytype, _kex, pp = get_keytype_kex_privprot c in
pp
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
| `RSA -> false
let ecdhe_only = function
| #ciphersuite13 -> false
| cs -> match get_keytype_kex_privprot cs with
| (_, `ECDHE, _) -> true
| _ -> false
let dhe_only = function
| #ciphersuite13 -> false
| cs -> match get_keytype_kex_privprot cs with
| (_, `FFDHE, _) -> true
| _ -> false
let ecdhe = function
| #ciphersuite13 -> true
| cs -> match get_keytype_kex_privprot cs with
| (_, `ECDHE, _) -> true
| _ -> false
let ciphersuite_tls12_only = function
| `DHE_RSA_WITH_AES_256_CBC_SHA256
| `DHE_RSA_WITH_AES_128_CBC_SHA256
| `RSA_WITH_AES_256_CBC_SHA256
| `RSA_WITH_AES_128_CBC_SHA256
| `RSA_WITH_AES_128_CCM
| `RSA_WITH_AES_256_CCM
| `DHE_RSA_WITH_AES_128_CCM
| `DHE_RSA_WITH_AES_256_CCM
| `RSA_WITH_AES_128_GCM_SHA256
| `RSA_WITH_AES_256_GCM_SHA384
| `DHE_RSA_WITH_AES_128_GCM_SHA256
| `DHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_AES_128_GCM_SHA256
| `ECDHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_AES_256_CBC_SHA384
| `ECDHE_RSA_WITH_AES_128_CBC_SHA256
| `DHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256
| `ECDHE_ECDSA_WITH_AES_128_CBC_SHA256
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384
| `ECDHE_ECDSA_WITH_AES_128_GCM_SHA256
| `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384
| `ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 -> true
| _ -> false
let ciphersuite_tls13 = function
| #ciphersuite13 -> true
| _ -> false

643
unikernel/duniverse/ocaml-tls/lib/config.ml Normal file
View file

@ -0,0 +1,643 @@
open Core
let src = Logs.Src.create "tls.config" ~doc:"TLS config"
module Log = (val Logs.src_log src : Logs.LOG)
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
]
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
type ticket_cache = {
lookup : string -> (psk13 * epoch_data) option ;
ticket_granted : psk13 -> epoch_data -> unit ;
lifetime : int32 ;
timestamp : unit -> Ptime.t
}
(* 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 : X509.Authenticator.t option ;
peer_name : [`host] Domain_name.t option ;
own_certificates : own_cert ;
acceptable_cas : X509.Distinguished_name.t list ;
session_cache : session_cache ;
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.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
(List.fold_left (fun acc cs ->
match Ciphersuite.ciphersuite_to_ciphersuite13 cs with
| None -> acc
| Some c -> c :: acc)
[] cfg.ciphers)
module Ciphers = struct
(* A good place for various pre-baked cipher lists and helper functions to
* slice and groom those lists. *)
let default13 = [
`AES_128_GCM_SHA256 ;
`AES_256_GCM_SHA384 ;
`CHACHA20_POLY1305_SHA256 ;
`AES_128_CCM_SHA256 ;
]
let default = default13 @ [
`DHE_RSA_WITH_AES_256_GCM_SHA384 ;
`DHE_RSA_WITH_AES_128_GCM_SHA256 ;
`DHE_RSA_WITH_AES_256_CCM ;
`DHE_RSA_WITH_AES_128_CCM ;
`DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 ;
`ECDHE_RSA_WITH_AES_128_GCM_SHA256 ;
`ECDHE_RSA_WITH_AES_256_GCM_SHA384 ;
`ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 ;
`ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 ;
`ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 ;
`ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 ;
]
let supported = default @ [
`DHE_RSA_WITH_AES_256_CBC_SHA256 ;
`DHE_RSA_WITH_AES_128_CBC_SHA256 ;
`DHE_RSA_WITH_AES_256_CBC_SHA ;
`DHE_RSA_WITH_AES_128_CBC_SHA ;
`ECDHE_RSA_WITH_AES_256_CBC_SHA384 ;
`ECDHE_RSA_WITH_AES_128_CBC_SHA256 ;
`ECDHE_RSA_WITH_AES_256_CBC_SHA ;
`ECDHE_RSA_WITH_AES_128_CBC_SHA ;
`ECDHE_ECDSA_WITH_AES_128_CBC_SHA ;
`ECDHE_ECDSA_WITH_AES_256_CBC_SHA ;
`ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 ;
`ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 ;
`RSA_WITH_AES_256_CBC_SHA256 ;
`RSA_WITH_AES_128_CBC_SHA256 ;
`RSA_WITH_AES_256_CBC_SHA ;
`RSA_WITH_AES_128_CBC_SHA ;
`RSA_WITH_AES_256_GCM_SHA384 ;
`RSA_WITH_AES_128_GCM_SHA256 ;
`RSA_WITH_AES_256_CCM ;
`RSA_WITH_AES_128_CCM ;
`DHE_RSA_WITH_3DES_EDE_CBC_SHA ;
`RSA_WITH_3DES_EDE_CBC_SHA ;
`ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA ;
]
(* as defined in https://httpwg.org/specs/rfc7540.html#BadCipherSuites *)
let http2 = default13 @ [
`DHE_RSA_WITH_AES_256_GCM_SHA384 ;
`DHE_RSA_WITH_AES_128_GCM_SHA256 ;
`DHE_RSA_WITH_AES_256_CCM ;
`DHE_RSA_WITH_AES_128_CCM ;
`DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 ;
`ECDHE_RSA_WITH_AES_128_GCM_SHA256 ;
`ECDHE_RSA_WITH_AES_256_GCM_SHA384 ;
`ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 ;
`ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 ;
`ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 ;
`ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 ;
]
let fs_of = List.filter Ciphersuite.ciphersuite_fs
let fs = fs_of default
end
let default_signature_algorithms =
[ `ECDSA_SECP256R1_SHA256 ;
`ECDSA_SECP384R1_SHA384 ;
`ECDSA_SECP521R1_SHA512 ;
`ED25519 ;
`RSA_PSS_RSAENC_SHA256 ;
`RSA_PSS_RSAENC_SHA384 ;
`RSA_PSS_RSAENC_SHA512 ;
`RSA_PKCS1_SHA256 ;
`RSA_PKCS1_SHA384 ;
`RSA_PKCS1_SHA512 ;
]
let supported_signature_algorithms =
default_signature_algorithms @ [
`RSA_PKCS1_SHA224 ;
`ECDSA_SECP256R1_SHA1 ;
`RSA_PKCS1_SHA1 ;
`RSA_PKCS1_MD5
]
let min_dh_size = 1024
let min_rsa_key_size = 1024
let supported_groups =
[ `X25519 ; `P384 ; `P256 ; `P521 ;
`FFDHE2048 ; `FFDHE3072 ; `FFDHE4096 ; `FFDHE6144 ; `FFDHE8192 ]
let elliptic_curve = function
| `X25519 | `P256 | `P384 | `P521 -> true
| `FFDHE2048 | `FFDHE3072 | `FFDHE4096 | `FFDHE6144 | `FFDHE8192 -> false
let default_config = {
ciphers = Ciphers.default ;
protocol_versions = (`TLS_1_2, `TLS_1_3) ;
signature_algorithms = default_signature_algorithms ;
use_reneg = false ;
authenticator = None ;
peer_name = None ;
own_certificates = `None ;
acceptable_cas = [] ;
session_cache = (fun _ -> None) ;
cached_session = None ;
cached_ticket = None ;
alpn_protocols = [] ;
groups = supported_groups ;
ticket_cache = None ;
zero_rtt = 0l ;
ip = None ;
}
(* There are inter-configuration option constraints that are checked and
adjusted here. The overall approach is if the client explicitly provided
values, these are taken as granted (a conflict will result in an error). If
the defaults are used, they are adjusted depending on the others.
The options in question are:
- ciphers, which before 1.3 include the key exchange (FFDHE, ECDHE, RSA)
- groups, which name the FFDHE and ECDHE groups used for DH
- signature_algorithms, which (since 1.2) specify the key type and algorithm
used for signatures (RSA-PKCS, RSA-PSS, ECDSA/EdDSA)
- certificate chains, which influence ciphers (before 1.3) and
signature_algorithms
Using everywhere the default (but a custom certificate / or multiple) result
in a working configuration (where, depending on the certificate key type,
some signature_algorithms and ciphersuites are removed). The provided server
certificate may remove ciphers & signature_algorithms, but will only result
in failure if these will then be empty.
An invalid configuration is for example: only FFDHE ciphersuites, but no
FFDHE groups. Or only EC signature algorithms, but only ciphers where the
key type is RSA.
At session initiation time, the server implementation selects cipher,
certificate, signature_algorithm, and group depending on its configuration
and client request.
*)
let ciphers_and_groups ?ciphers ?groups default_ciphers =
let tls13 = function #Ciphersuite.ciphersuite13 -> true | _ -> false in
match ciphers, groups with
| None, None -> Ok (default_ciphers, supported_groups)
| Some cs, None ->
Ok (cs,
let has_kex x = function
| #Ciphersuite.ciphersuite13 -> true
| c -> x = Ciphersuite.ciphersuite_kex c
in
begin
match List.exists (has_kex `ECDHE) cs, List.exists (has_kex `FFDHE) cs with
| true, true -> supported_groups
| true, false ->
Log.warn (fun m -> m "removed FFDHE groups (no FFDHE ciphersuite) from configuation");
List.filter elliptic_curve supported_groups
| false, true ->
Log.warn (fun m -> m "removed ECDHE groups (no ECDHE ciphersuite) from configuration");
List.filter (fun g -> not (elliptic_curve g)) supported_groups
| false, false -> []
end)
| None, Some g ->
Ok (begin match List.partition elliptic_curve g with
| [], [] ->
Log.warn (fun m -> m "removed DHE and ECDHE ciphersuites (empty groups provided) from configuration");
List.filter (fun c -> not (Ciphersuite.ciphersuite_fs c)) default_ciphers
| _::_, [] ->
Log.warn (fun m -> m "removed DHE ciphersuites (no FFDHE groups provided) from configuration");
List.filter (fun c -> not (Ciphersuite.dhe_only c)) default_ciphers
| [], _ :: _ ->
Log.warn (fun m -> m "removed ECDHE ciphersuites (no EC groups provided) from configuration");
List.filter (fun c -> not (Ciphersuite.ecdhe_only c)) default_ciphers
| _ -> default_ciphers
end, g)
| Some cs, Some g ->
if List.exists Ciphersuite.ecdhe_only cs && not (List.exists elliptic_curve g) then
Error (`Msg "ciphersuite with ECDHE provided, but no EC group")
else if List.exists Ciphersuite.dhe_only cs && not (List.exists (fun g -> not (elliptic_curve g)) g) then
Error (`Msg "ciphersuite with FFDHE provided, but no FF group")
else if List.exists Ciphersuite.ciphersuite_fs cs && g = [] then
Error (`Msg "ciphersuite with forward security provided, but no group")
else if List.exists elliptic_curve g && not (List.exists Ciphersuite.ecdhe cs) then
Error (`Msg "EC group provided, but no ciphersuite with ECDHE")
else if List.exists (fun g -> not (elliptic_curve g)) g &&
not (List.exists (fun c -> Ciphersuite.dhe_only c || tls13 c) cs)
then
Error (`Msg "FF group provided, but no ciphersuite with DHE")
else
Ok (cs, g)
let ciphers_and_sig_alg ?ciphers ?signature_algorithms default_ciphers =
let tls13 = function #Ciphersuite.ciphersuite13 -> true | _ -> false in
let default_sa_from_ciphers c =
let has_key k c = tls13 c || k = Ciphersuite.ciphersuite_keytype c in
match List.exists (has_key `RSA) c, List.exists (has_key `EC) c with
| true, true -> Ok supported_signature_algorithms
| true, false ->
Log.warn (fun m -> m "removed EC signature algorithms (no EC ciphersuite present)");
Ok (List.filter rsa_sigalg supported_signature_algorithms)
| false, true ->
Log.warn (fun m -> m "removed RSA signature algorithms (no RSA ciphersuite present)");
Ok (List.filter (fun sa -> not (rsa_sigalg sa)) supported_signature_algorithms)
| false, false ->
Error (`Msg "ciphersuite list without RSA and EC keys")
in
let ( let* ) = Result.bind in
match ciphers, signature_algorithms with
| None, None ->
let* sig_algs = default_sa_from_ciphers default_ciphers in
Ok (default_ciphers, sig_algs)
| Some c, None ->
let* sig_algs = default_sa_from_ciphers c in
Ok (c, sig_algs)
| None, Some sa ->
begin match List.partition rsa_sigalg sa with
| [], [] -> Error (`Msg "empty signature algorithms provided")
| _::_, [] ->
Log.warn (fun m -> m "removing EC ciphers (no EC signature algorithm provided)");
Ok (List.filter
(fun c -> tls13 c || not (Ciphersuite.ciphersuite_keytype c = `EC))
default_ciphers,
sa)
| [], _::_ ->
Log.warn (fun m -> m "removing RSA ciphers (no RSA signature algorithm provided)");
Ok (List.filter
(fun c -> tls13 c || not (Ciphersuite.ciphersuite_keytype c = `RSA))
default_ciphers,
sa)
| _::_, _::_ -> Ok (default_ciphers, sa)
end
| Some c, Some sa ->
if List.exists rsa_sigalg sa && not (List.exists (fun c -> Ciphersuite.ciphersuite_keytype c = `RSA) c) then
Error (`Msg "RSA signature algorithm, but no ciphersuites with RSA keys")
else if List.exists (fun s -> not (rsa_sigalg s)) sa && not (List.exists (fun c -> Ciphersuite.ciphersuite_keytype c = `EC) c) then
Error (`Msg "EC signature algorithm, but no ciphersuites with EC keys")
else if List.exists (fun c -> Ciphersuite.ciphersuite_keytype c = `RSA) c && not (List.exists rsa_sigalg sa) then
Error (`Msg "RSA ciphersuite, but no RSA signature algorithm")
else if List.exists (fun c -> Ciphersuite.ciphersuite_keytype c = `EC) c && not (List.exists (fun s -> not (rsa_sigalg s)) sa) then
Error (`Msg "EC ciphersuite, but no EC signature algorithm")
else
Ok (c, sa)
let validate_common config =
let ( let* ) = Result.bind in
let (v_min, v_max) = config.protocol_versions in
if v_max < v_min then
Error (`Msg "bad version range")
else
let* ciphers, signature_algorithms =
match v_min, v_max with
| _, `TLS_1_1 | _, `TLS_1_0 ->
Log.warn (fun m -> m "TLS 1.0 or TLS 1.1 as maximum version configured, removing 1.2 and 1.3 ciphersuites");
Ok (List.filter (fun c ->
not (Ciphersuite.ciphersuite_tls12_only c || Ciphersuite.ciphersuite_tls13 c))
config.ciphers,
[])
| _, `TLS_1_2 ->
if config.signature_algorithms = [] then
Error (`Msg "TLS 1.2 configured but no signature algorithms provided")
else begin
Log.warn (fun m -> m "TLS 1.2 as maximum version configured, removing 1.3 cipher suites");
Ok (List.filter
(fun c -> not (Ciphersuite.ciphersuite_tls13 c)) config.ciphers,
config.signature_algorithms)
end
| `TLS_1_3, `TLS_1_3 ->
let sa = List.filter tls13_sigalg config.signature_algorithms in
if sa = [] then
Error (`Msg "TLS 1.3 configured but no 1.3 signature algorithms provided")
else begin
Log.warn (fun m -> m "only TLS 1.3 configured, removing pre-1.3 cipher suites and signature algorithms");
Ok (List.filter Ciphersuite.ciphersuite_tls13 config.ciphers, sa)
end
| _ -> Ok (config.ciphers, config.signature_algorithms)
in
if not (Utils.List_set.is_proper_set ciphers) then
Error (`Msg "set of ciphers is not a proper set")
else if List.length ciphers = 0 then
Error (`Msg "set of ciphers is empty")
else if not (Utils.List_set.is_proper_set config.groups) then
Error (`Msg "set of groups is not a proper set")
else if not (Utils.List_set.is_proper_set signature_algorithms) then
Error (`Msg "set of signature algorithms is not a proper set")
else if List.exists (fun proto -> let len = String.length proto in len = 0 || len > 255) config.alpn_protocols then
Error (`Msg "invalid alpn protocol")
else if List.length config.alpn_protocols > 0xffff then
Error (`Msg "alpn protocols list too large")
else
Ok { config with ciphers ; signature_algorithms }
let validate_certificate_chain = function
| (s::chain, priv) ->
let ( let* ) = Result.bind in
let pub = X509.Private_key.public priv in
let* () =
match pub with
| `RSA pub when Mirage_crypto_pk.Rsa.pub_bits pub < min_rsa_key_size ->
Error (`Msg "RSA key too short!")
| _ -> Ok ()
in
let* () =
let eq_pub a b =
String.equal (X509.Public_key.fingerprint a) (X509.Public_key.fingerprint b)
in
if not (eq_pub pub (X509.Certificate.public_key s)) then
Error (`Msg "public / private key combination" )
else
Ok ()
in
( match Utils.init_and_last chain with
| Some (ch, trust) ->
(* TODO: verify that certificates are x509 v3 if TLS_1_2 *)
( match X509.Validation.verify_chain_of_trust ~time:(fun () -> None) ~host:None ~anchors:[trust] (s :: ch) with
| Ok _ -> Ok ()
| Error x ->
let s = Fmt.to_to_string X509.Validation.pp_validation_error x in
Error (`Msg ("certificate chain does not validate: " ^ s)))
| None -> Ok () )
| _ -> Error (`Msg "certificate chain")
let validate_client config =
match config.own_certificates with
| `None -> Ok ()
| `Single c -> validate_certificate_chain c
| _ -> Error (`Msg "multiple client certificates not supported in client config")
let non_overlapping cs =
let namessets =
List.filter_map (function
| (s :: _, _) -> Some s
| _ -> None)
cs
|> List.map X509.Certificate.hostnames
in
let rec check = function
| [] -> ()
| s::ss ->
if not (List.for_all (fun ss' ->
X509.Host.Set.is_empty (X509.Host.Set.inter s ss'))
ss)
then
invalid_arg "overlapping names in certificates"
else
check ss
in
check namessets
module KU = Set.Make (struct
type t = X509.Extension.key_usage
let compare a b = compare a b
end)
module PK = Map.Make (struct
type t = [ `RSA | `ED25519 | `P256 | `P384 | `P521 ]
let compare a b = compare a b
end)
let validate_server config =
let ( let* ) = Result.bind in
let open Ciphersuite in
let usages =
List.fold_left
(fun acc c -> KU.add (required_usage (ciphersuite_kex c)) acc)
KU.empty config.ciphers
in
let* certificate_chains =
match config.own_certificates with
| `Single c -> Ok [c]
| `Multiple cs -> Ok cs
| `Multiple_default (c, cs) -> Ok (c :: cs)
| `None -> Error (`Msg "no server certificate provided")
in
let* server_certs =
List.fold_left (fun acc cc ->
let* acc = acc in
match cc with
| (s::_,_) -> Ok (s :: acc)
| _ -> Error (`Msg "empty certificate chain"))
(Ok []) certificate_chains
in
let* () =
if not
(KU.for_all (fun u ->
List.exists (supports_key_usage ~not_present:true u) server_certs)
usages)
then
Error (`Msg "certificate usage does not match")
else
Ok ()
in
let* () =
List.fold_left (fun acc cc ->
let* () = acc in
validate_certificate_chain cc)
(Ok ()) certificate_chains
in
let rsa_cert, ec_cert =
let is_ec_cert c = match X509.Certificate.public_key c with
| `ED25519 _ | `P256 _ | `P384 _ | `P521 _ -> true
| _ -> false
and is_rsa_cert c = match X509.Certificate.public_key c with
| `RSA _ -> true | _ -> false
in
List.exists is_rsa_cert server_certs,
List.exists is_ec_cert server_certs
in
let ciphers =
List.filter
(function
| #Ciphersuite.ciphersuite13 -> true
| c ->
let keytype = ciphersuite_keytype c in
(rsa_cert && keytype = `RSA) || (ec_cert && keytype = `EC))
config.ciphers
in
( match config.own_certificates with
| `Multiple cs
| `Multiple_default (_, cs) ->
let add k v acc = match PK.find_opt k acc with
| None -> PK.add k [v] acc
| Some r -> PK.add k (v :: r) acc
in
let pk =
List.fold_left (fun acc cs ->
match snd cs with
| `RSA _ -> add `RSA cs acc
| `ED25519 _ -> add `ED25519 cs acc
| `P256 _ -> add `P256 cs acc
| `P384 _ -> add `P384 cs acc
| `P521 _ -> add `P521 cs acc)
PK.empty cs
in
PK.iter (fun _ chains -> non_overlapping chains) pk
| _ -> () );
Ok { config with ciphers }
let validate_keys_sig_algs config =
let ( let* ) = Result.bind in
let _, v_max = config.protocol_versions in
if v_max = `TLS_1_2 || v_max = `TLS_1_3 then
let* certificate_chains =
match config.own_certificates with
| `Single c -> Ok [c]
| `Multiple cs -> Ok cs
| `Multiple_default (c, cs) -> Ok (c :: cs)
| `None -> Error (`Msg "no server certificate provided")
in
let* server_keys =
List.fold_left (fun acc cc ->
let* acc = acc in
match cc with
| (s::_,_) -> Ok (X509.Certificate.public_key s :: acc)
| _ -> Error (`Msg "empty certificate chain"))
(Ok []) certificate_chains
in
if not
(List.for_all (fun cert ->
List.exists (pk_matches_sa cert) config.signature_algorithms)
server_keys)
then
Error (`Msg "certificate provided which does not allow any signature algorithm")
else
Ok ()
else
Ok ()
type client = config
type server = config
let of_server conf = conf
and of_client conf = conf
let peer conf name = { conf with peer_name = Some name }
let with_authenticator conf auth = { conf with authenticator = Some auth }
let with_own_certificates conf own_certificates = { conf with own_certificates }
let with_acceptable_cas conf acceptable_cas = { conf with acceptable_cas }
let (<?>) ma b = match ma with None -> b | Some a -> a
let client
~authenticator ?peer_name ?ciphers ?version ?signature_algorithms ?reneg ?certificates ?cached_session ?cached_ticket ?ticket_cache ?alpn_protocols ?groups ?ip () =
let ( let* ) = Result.bind in
let* ciphers', groups = ciphers_and_groups ?ciphers ?groups default_config.ciphers in
let* ciphers, signature_algorithms = ciphers_and_sig_alg ?ciphers ?signature_algorithms ciphers' in
let config =
{ default_config with
authenticator = Some authenticator ;
ciphers ;
protocol_versions = version <?> default_config.protocol_versions ;
signature_algorithms ;
use_reneg = reneg <?> default_config.use_reneg ;
own_certificates = certificates <?> default_config.own_certificates ;
peer_name = peer_name ;
cached_session = cached_session ;
alpn_protocols = alpn_protocols <?> default_config.alpn_protocols ;
ticket_cache = ticket_cache ;
cached_ticket = cached_ticket ;
groups ;
ip ;
} in
let* config = validate_common config in
let* () = validate_client config in
Log.debug (fun m -> m "client with %a" pp_config config);
Ok config
let server
?ciphers ?version ?signature_algorithms ?reneg ?certificates ?acceptable_cas ?authenticator ?session_cache ?ticket_cache ?alpn_protocols ?groups ?zero_rtt ?ip () =
let ( let* ) = Result.bind in
let* ciphers', groups = ciphers_and_groups ?ciphers ?groups default_config.ciphers in
let* ciphers, signature_algorithms = ciphers_and_sig_alg ?ciphers ?signature_algorithms ciphers' in
let config =
{ default_config with
ciphers ;
protocol_versions = version <?> default_config.protocol_versions ;
signature_algorithms ;
use_reneg = reneg <?> default_config.use_reneg ;
own_certificates = certificates <?> default_config.own_certificates ;
acceptable_cas = acceptable_cas <?> default_config.acceptable_cas ;
authenticator = authenticator ;
session_cache = session_cache <?> default_config.session_cache ;
alpn_protocols = alpn_protocols <?> default_config.alpn_protocols ;
ticket_cache = ticket_cache ;
groups ;
zero_rtt = zero_rtt <?> default_config.zero_rtt ;
ip ;
} in
let* config = validate_server config in
let* config = validate_common config in
let* () = validate_keys_sig_algs config in
Log.debug (fun m -> m "server with %a" pp_config config);
Ok config

174
unikernel/duniverse/ocaml-tls/lib/config.mli Normal file
View file

@ -0,0 +1,174 @@
open Core
(** Configuration of the TLS stack *)
(** {1 Config type} *)
(** certificate chain and private key of the first certificate *)
type certchain = X509.Certificate.t list * X509.Private_key.t
(** polymorphic variant of own certificates *)
type own_cert = [
| `None
| `Single of certchain
| `Multiple of certchain list
| `Multiple_default of certchain * certchain list
]
type session_cache = SessionID.t -> epoch_data option
type ticket_cache = {
lookup : string -> (psk13 * epoch_data) option ;
ticket_granted : psk13 -> epoch_data -> unit ;
lifetime : int32 ;
timestamp : unit -> Ptime.t
}
(** configuration parameters *)
type config = private {
ciphers : Ciphersuite.ciphersuite list ; (** ordered list (regarding preference) of supported cipher suites *)
protocol_versions : tls_version * tls_version ; (** supported protocol versions (min, max) *)
signature_algorithms : signature_algorithm list ; (** ordered list of supported signature algorithms (regarding preference) *)
use_reneg : bool ; (** endpoint should accept renegotiation requests *)
authenticator : X509.Authenticator.t option ; (** optional X509 authenticator *)
peer_name : [ `host ] Domain_name.t option ; (** optional name of other endpoint (used for SNI RFC4366) *)
own_certificates : own_cert ; (** optional default certificate chain and other certificate chains *)
acceptable_cas : X509.Distinguished_name.t list ; (** ordered list of acceptable certificate authorities *)
session_cache : session_cache ;
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 ;
}
(** [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
(** opaque type of a server configuration *)
type server
(** {1 Constructors} *)
(** [client authenticator ?peer_name ?ciphers ?version ?hashes ?reneg ?certificates ?alpn_protocols] is
[client] configuration with the given parameters. Returns an error if the configuration is invalid. *)
val client :
authenticator : X509.Authenticator.t ->
?peer_name : [ `host ] Domain_name.t ->
?ciphers : Ciphersuite.ciphersuite list ->
?version : tls_version * tls_version ->
?signature_algorithms : signature_algorithm list ->
?reneg : bool ->
?certificates : own_cert ->
?cached_session : epoch_data ->
?cached_ticket : psk13 * epoch_data ->
?ticket_cache : ticket_cache ->
?alpn_protocols : string list ->
?groups : group list ->
?ip : Ipaddr.t ->
unit -> (client, [> `Msg of string ]) result
(** [server ?ciphers ?version ?hashes ?reneg ?certificates ?acceptable_cas ?authenticator ?alpn_protocols]
is [server] configuration with the given parameters. Returns an error if the configuration is invalid. *)
val server :
?ciphers : Ciphersuite.ciphersuite list ->
?version : tls_version * tls_version ->
?signature_algorithms : signature_algorithm list ->
?reneg : bool ->
?certificates : own_cert ->
?acceptable_cas : X509.Distinguished_name.t list ->
?authenticator : X509.Authenticator.t ->
?session_cache : session_cache ->
?ticket_cache : ticket_cache ->
?alpn_protocols : string list ->
?groups : group list ->
?zero_rtt : int32 ->
?ip : Ipaddr.t ->
unit -> (server, [> `Msg of string ]) result
(** [peer client name] is [client] with [name] as [peer_name] *)
val peer : client -> [ `host ] Domain_name.t -> client
(** {1 Note on ALPN protocol selection}
Both {!val:client} and {!val:server} constructors accept an [alpn_protocols] list. The list for server
should be given in a descending order of preference. In the case of protocol selection, the server will
iterate its list and select the first element that the client's list also advertises.
For example, if the client advertises [["foo"; "bar"; "baz"]] and the server has [["bar"; "foo"]],
["bar"] will be selected as the protocol of the handshake. *)
(** {1 Utility functions} *)
(** [default_signature_algorithms] is a list of signature algorithms used by default *)
val default_signature_algorithms : signature_algorithm list
(** [supported_signature_algorithms] is a list of supported signature algorithms by this library *)
val supported_signature_algorithms : signature_algorithm list
(** [min_dh_size] is minimal diffie hellman group size in bits (currently 1024) *)
val min_dh_size : int
(** [supported_groups] are the Diffie-Hellman groups supported in this
library. *)
val supported_groups : group list
(** [elliptic_curve group] is [true] if group is an elliptic curve, [false]
otherwise. *)
val elliptic_curve : group -> bool
(** [min_rsa_key_size] is minimal RSA modulus key size in bits (currently 1024) *)
val min_rsa_key_size : int
(** Cipher selection *)
module Ciphers : sig
open Ciphersuite
(** Cipher selection related utilities. *)
(** {1 Cipher selection} *)
val default : ciphersuite list
(** [default] is a list of ciphersuites this library uses by default. *)
val supported : ciphersuite list
(** [supported] is a list of ciphersuites this library supports
(larger than [default]). *)
val fs : ciphersuite list
(** [fs] is a list of ciphersuites which provide forward secrecy
(sublist of [default]). *)
val http2 : ciphersuite list
(** [http2] is a list of ciphersuites which are allowed to be used with HTTP2:
not a member of
{{:https://httpwg.org/specs/rfc7540.html#BadCipherSuites}bad cipher
suites}. These are only ephemeral key exchanges with AEAD ciphers. *)
val fs_of : ciphersuite list -> ciphersuite list
(** [fs_of ciphers] selects all ciphersuites which provide forward
secrecy from [ciphers]. *)
end
(** {1 Internal use only} *)
(** [of_client client] is a client configuration for [client] *)
val of_client : client -> config
(** [of_server server] is a server configuration for [server] *)
val of_server : server -> config
(** [with_authenticator config auth] is [config] with [auth] as [authenticator] *)
val with_authenticator : config -> X509.Authenticator.t -> config
(** [with_own_certificates config cert] is [config] with [cert] as [own_cert] *)
val with_own_certificates : config -> own_cert -> config
(** [with_acceptable_cas config cas] is [config] with [cas] as [accepted_cas] *)
val with_acceptable_cas : config -> X509.Distinguished_name.t list -> config

501
unikernel/duniverse/ocaml-tls/lib/core.ml Normal file
View file

@ -0,0 +1,501 @@
(** Core type definitions *)
open Packet
open Ciphersuite
let ( let* ) = Result.bind
let guard p e = if p then Ok () else Error e
let split_str ?(start = 0) str off =
String.sub str start off,
String.sub str (start + off) (String.length str - off - start)
let map_reader_error r =
Result.map_error (fun e -> `Fatal e) r
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
]
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 ]
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)
| `TLS_1_1 -> (3, 2)
| `TLS_1_2 -> (3, 3)
| `TLS_1_3 -> (3, 4)
let compare_tls_version a b = match a, b with
| `TLS_1_0, `TLS_1_0 -> 0 | `TLS_1_0, _ -> -1 | _, `TLS_1_0 -> 1
| `TLS_1_1, `TLS_1_1 -> 0 | `TLS_1_1, _ -> -1 | _, `TLS_1_1 -> 1
| `TLS_1_2, `TLS_1_2 -> 0 | `TLS_1_2, _ -> -1 | _, `TLS_1_2 -> 1
| `TLS_1_3, `TLS_1_3 -> 0
let next = function
| `TLS_1_0 -> Some `TLS_1_1
| `TLS_1_1 -> Some `TLS_1_2
| `TLS_1_2 -> Some `TLS_1_3
| `TLS_1_3 -> None
let all_versions (min, max) =
let rec gen curr =
if compare_tls_version max curr >= 0 then
match next curr with
| None -> [curr]
| Some c -> curr :: gen c
else
[]
in
List.rev (gen min)
let tls_version_of_pair = function
| (3, 1) -> Some `TLS_1_0
| (3, 2) -> Some `TLS_1_1
| (3, 3) -> Some `TLS_1_2
| (3, 4) -> Some `TLS_1_3
| _ -> None
type tls_any_version = [
| tls_version
| `SSL_3
| `TLS_1_X of int
]
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
| _ -> None
let version_eq a b =
match a with
| #tls_version as x -> compare_tls_version x b = 0
| _ -> false
let version_ge a b =
match a with
| #tls_version as x -> compare_tls_version x b >= 0
| `SSL_3 -> false
| `TLS_1_X _ -> true
let tls_any_version_of_pair x =
match tls_version_of_pair x with
| Some v -> Some v
| None ->
match x with
| (3, 0) -> Some `SSL_3
| (3, x) -> Some (`TLS_1_X x)
| _ -> None
let pair_of_tls_any_version = function
| #tls_version as x -> pair_of_tls_version x
| `SSL_3 -> (3, 0)
| `TLS_1_X m -> (3, m)
let max_protocol_version (_, hi) = hi
let min_protocol_version (lo, _) = lo
type tls_hdr = {
content_type : content_type;
version : tls_any_version;
}
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 = string
let compare = String.compare
let hash t = Hashtbl.hash t
let equal = String.equal
end
module PreSharedKeyID = struct
type t = string
let compare = String.compare
let hash t = Hashtbl.hash t
let equal = String.equal
end
type psk_identity = (string * int32) * string
let binders_len psks =
let binder_len (_, binder) =
String.length binder + 1 (* binder len *)
in
2 (* binder len *) + List.fold_left (+) 0 (List.map binder_len psks)
type group = [
| `FFDHE2048
| `FFDHE3072
| `FFDHE4096
| `FFDHE6144
| `FFDHE8192
| `X25519
| `P256
| `P384
| `P521
]
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
| FFDHE3072 -> Some `FFDHE3072
| FFDHE4096 -> Some `FFDHE4096
| FFDHE6144 -> Some `FFDHE6144
| FFDHE8192 -> Some `FFDHE8192
| X25519 -> Some `X25519
| SECP256R1 -> Some `P256
| SECP384R1 -> Some `P384
| SECP521R1 -> Some `P521
| _ -> None
let group_to_named_group = function
| `FFDHE2048 -> FFDHE2048
| `FFDHE3072 -> FFDHE3072
| `FFDHE4096 -> FFDHE4096
| `FFDHE6144 -> FFDHE6144
| `FFDHE8192 -> FFDHE8192
| `X25519 -> X25519
| `P256 -> SECP256R1
| `P384 -> SECP384R1
| `P521 -> SECP521R1
let group_to_impl = function
| `FFDHE2048 -> `Finite_field Mirage_crypto_pk.Dh.Group.ffdhe2048
| `FFDHE3072 -> `Finite_field Mirage_crypto_pk.Dh.Group.ffdhe3072
| `FFDHE4096 -> `Finite_field Mirage_crypto_pk.Dh.Group.ffdhe4096
| `FFDHE6144 -> `Finite_field Mirage_crypto_pk.Dh.Group.ffdhe6144
| `FFDHE8192 -> `Finite_field Mirage_crypto_pk.Dh.Group.ffdhe8192
| `X25519 -> `X25519
| `P256 -> `P256
| `P384 -> `P384
| `P521 -> `P521
type signature_algorithm = [
| `RSA_PKCS1_MD5
| `RSA_PKCS1_SHA1
| `RSA_PKCS1_SHA224
| `RSA_PKCS1_SHA256
| `RSA_PKCS1_SHA384
| `RSA_PKCS1_SHA512
| `ECDSA_SECP256R1_SHA1
| `ECDSA_SECP256R1_SHA256
| `ECDSA_SECP384R1_SHA384
| `ECDSA_SECP521R1_SHA512
| `RSA_PSS_RSAENC_SHA256
| `RSA_PSS_RSAENC_SHA384
| `RSA_PSS_RSAENC_SHA512
| `ED25519
(* | `ED448
| `RSA_PSS_PSS_SHA256
| `RSA_PSS_PSS_SHA384
| `RSA_PSS_PSS_SHA512 *)
]
let hash_of_signature_algorithm = function
| `RSA_PKCS1_MD5 -> `MD5
| `RSA_PKCS1_SHA1 -> `SHA1
| `RSA_PKCS1_SHA224 -> `SHA224
| `RSA_PKCS1_SHA256 -> `SHA256
| `RSA_PKCS1_SHA384 -> `SHA384
| `RSA_PKCS1_SHA512 -> `SHA512
| `RSA_PSS_RSAENC_SHA256 -> `SHA256
| `RSA_PSS_RSAENC_SHA384 -> `SHA384
| `RSA_PSS_RSAENC_SHA512 -> `SHA512
| `ECDSA_SECP256R1_SHA1 -> `SHA1
| `ECDSA_SECP256R1_SHA256 -> `SHA256
| `ECDSA_SECP384R1_SHA384 -> `SHA384
| `ECDSA_SECP521R1_SHA512 -> `SHA512
| `ED25519 -> `SHA512
let signature_scheme_of_signature_algorithm = function
| `RSA_PKCS1_MD5 -> `RSA_PKCS1
| `RSA_PKCS1_SHA1 -> `RSA_PKCS1
| `RSA_PKCS1_SHA224 -> `RSA_PKCS1
| `RSA_PKCS1_SHA256 -> `RSA_PKCS1
| `RSA_PKCS1_SHA384 -> `RSA_PKCS1
| `RSA_PKCS1_SHA512 -> `RSA_PKCS1
| `RSA_PSS_RSAENC_SHA256 -> `RSA_PSS
| `RSA_PSS_RSAENC_SHA384 -> `RSA_PSS
| `RSA_PSS_RSAENC_SHA512 -> `RSA_PSS
| `ECDSA_SECP256R1_SHA1 -> `ECDSA
| `ECDSA_SECP256R1_SHA256 -> `ECDSA
| `ECDSA_SECP384R1_SHA384 -> `ECDSA
| `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
| `RSA_PKCS1_SHA224 | `RSA_PKCS1_SHA1 | `RSA_PKCS1_MD5 -> true
| `ECDSA_SECP256R1_SHA1 | `ECDSA_SECP256R1_SHA256 | `ECDSA_SECP384R1_SHA384
| `ECDSA_SECP521R1_SHA512 | `ED25519 -> false
let tls13_sigalg = function
| `RSA_PSS_RSAENC_SHA256 | `RSA_PSS_RSAENC_SHA384 | `RSA_PSS_RSAENC_SHA512
| `ECDSA_SECP256R1_SHA256 | `ECDSA_SECP384R1_SHA384
| `ECDSA_SECP521R1_SHA512 | `ED25519 -> true
| `RSA_PKCS1_SHA256 | `RSA_PKCS1_SHA384 | `RSA_PKCS1_SHA512
| `RSA_PKCS1_SHA224 | `RSA_PKCS1_SHA1 | `RSA_PKCS1_MD5
| `ECDSA_SECP256R1_SHA1 -> false
let pk_matches_sa pk sa =
match pk, sa with
| `RSA _, _ -> rsa_sigalg sa
| `ED25519 _, `ED25519
| `P256 _, (`ECDSA_SECP256R1_SHA1 | `ECDSA_SECP256R1_SHA256)
| `P384 _, `ECDSA_SECP384R1_SHA384
| `P521 _, `ECDSA_SECP521R1_SHA512 -> true
| _ -> false
type client_extension = [
| `Hostname of [`host] Domain_name.t
| `MaxFragmentLength of max_fragment_length
| `SupportedGroups of Packet.named_group list
| `SecureRenegotiation of string
| `Padding of int
| `SignatureAlgorithms of signature_algorithm list
| `ExtendedMasterSecret
| `ALPN of string list
| `KeyShare of (Packet.named_group * string) list
| `EarlyDataIndication
| `PreSharedKeys of psk_identity list
| `SupportedVersions of tls_any_version list
| `PostHandshakeAuthentication
| `Cookie of string
| `PskKeyExchangeModes of psk_key_exchange_mode list
| `ECPointFormats
| `UnknownExtension of (int * string)
]
type server13_extension = [
| `KeyShare of (group * string)
| `PreSharedKey of int
| `SelectedVersion of tls_version (* only used internally in writer!! *)
]
type server_extension = [
server13_extension
| `Hostname
| `MaxFragmentLength of max_fragment_length
| `SecureRenegotiation of string
| `ExtendedMasterSecret
| `ALPN of string
| `ECPointFormats
| `UnknownExtension of (int * string)
]
type encrypted_extension = [
| `Hostname
| `MaxFragmentLength of max_fragment_length
| `SupportedGroups of group list
| `ALPN of string
| `EarlyDataIndication
| `UnknownExtension of (int * string)
]
type hello_retry_extension = [
| `SelectedGroup of group (* only used internally in writer!! *)
| `Cookie of string
| `SelectedVersion of tls_version (* only used internally in writer!! *)
| `UnknownExtension of (int * string)
]
type client_hello = {
client_version : tls_any_version;
client_random : string;
sessionid : SessionID.t option;
ciphersuites : any_ciphersuite list;
extensions : client_extension list
}
type server_hello = {
server_version : tls_version;
server_random : string;
sessionid : SessionID.t option;
ciphersuite : ciphersuite;
extensions : server_extension list
}
type dh_parameters = {
dh_p : string;
dh_g : string;
dh_Ys : string;
}
type hello_retry = {
retry_version : tls_version ;
ciphersuite : ciphersuite13 ;
sessionid : SessionID.t option ;
selected_group : group ;
extensions : hello_retry_extension list
}
type session_ticket_extension = [
| `EarlyDataIndication of int32
| `UnknownExtension of int * string
]
type session_ticket = {
lifetime : int32 ;
age_add : int32 ;
nonce : string ;
ticket : string ;
extensions : session_ticket_extension list
}
type certificate_request_extension = [
(* | `StatusRequest *)
| `SignatureAlgorithms of signature_algorithm list
(* | `SignedCertificateTimestamp *)
| `CertificateAuthorities of X509.Distinguished_name.t list
(* | `OidFilters *)
(* | `SignatureAlgorithmsCert *)
| `UnknownExtension of (int * string)
]
type tls_handshake =
| HelloRequest
| HelloRetryRequest of hello_retry
| EncryptedExtensions of encrypted_extension list
| ServerHelloDone
| ClientHello of client_hello
| ServerHello of server_hello
| Certificate of string
| ServerKeyExchange of string
| CertificateRequest of string
| ClientKeyExchange of string
| CertificateVerify of string
| Finished of string
| SessionTicket of session_ticket
| KeyUpdate of key_update_request_type
| EndOfEarlyData
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 (Ohex.pp_hexdump ()) buf)
let hs ~tag hs = debug (fun m -> m "%s %a" tag pp_handshake hs)
end
type tls_alert = alert_level * alert_type
(** the master secret of a TLS connection *)
type master_secret = string
type psk13 = {
identifier : string ;
obfuscation : int32 ;
secret : string ;
lifetime : int32 ;
early_data : int32 ;
issued_at : Ptime.t ;
(* origin : [ `Resumption | `External ] (* using different labels for binder_key *) *)
}
type epoch_state = [ `ZeroRTT | `Established ]
(** information about an open session *)
type epoch_data = {
side : [ `Client | `Server ] ;
state : epoch_state ;
protocol_version : tls_version ;
ciphersuite : Ciphersuite.ciphersuite ;
peer_random : string ;
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 : string ;
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 ;
exporter_master_secret : master_secret ;
session_id : SessionID.t ;
extended_ms : bool ;
alpn_protocol : string option ;
tls_unique : string option ;
}
let supports_key_usage ?(not_present = false) usage cert =
match X509.Extension.(find Key_usage (X509.Certificate.extensions cert)) with
| None -> not_present
| Some (_, kus) -> List.mem usage kus
let supports_extended_key_usage ?(not_present = false) usage cert =
match X509.Extension.(find Ext_key_usage (X509.Certificate.extensions cert)) with
| None -> not_present
| Some (_, kus) -> List.mem usage kus

159
unikernel/duniverse/ocaml-tls/lib/crypto.ml Normal file
View file

@ -0,0 +1,159 @@
open Mirage_crypto
open Ciphersuite
(* on-the-wire dh_params <-> (group, pub_message) *)
let dh_params_pack { Mirage_crypto_pk.Dh.p; gg ; _ } message =
let cs_of_z = Mirage_crypto_pk.Z_extra.to_octets_be ?size:None in
{ Core.dh_p = cs_of_z p ; dh_g = cs_of_z gg ; dh_Ys = message }
and dh_params_unpack { Core.dh_p ; dh_g ; dh_Ys } =
let z_of_cs = Mirage_crypto_pk.Z_extra.of_octets_be ?bits:None in
match Mirage_crypto_pk.Dh.group ~p:(z_of_cs dh_p) ~gg:(z_of_cs dh_g) () with
| Ok dh -> Ok (dh, dh_Ys)
| Error _ as e -> e
module Ciphers = struct
(* I'm not sure how to get rid of this type, but would welcome a solution *)
(* only used as result of get_block, which is called by get_cipher below *)
type keyed = | K_CBC : 'k State.cbc_cipher * (string -> 'k) -> keyed
let get_block = function
| TRIPLE_DES_EDE_CBC ->
K_CBC ( (module DES.CBC : Block.CBC with type key = DES.CBC.key),
DES.CBC.of_secret )
| AES_128_CBC ->
K_CBC ( (module AES.CBC : Block.CBC with type key = AES.CBC.key),
AES.CBC.of_secret )
| AES_256_CBC ->
K_CBC ( (module AES.CBC : Block.CBC with type key = AES.CBC.key),
AES.CBC.of_secret )
type aead_keyed = | K_AEAD : 'k State.aead_cipher * (string -> 'k) * bool -> aead_keyed
let get_aead =
function
| AES_128_CCM | AES_256_CCM ->
K_AEAD ((module AES.CCM16 : AEAD with type key = AES.CCM16.key),
AES.CCM16.of_secret, true)
| AES_128_GCM | AES_256_GCM ->
K_AEAD ((module AES.GCM : AEAD with type key = AES.GCM.key),
AES.GCM.of_secret, true)
| CHACHA20_POLY1305 ->
K_AEAD ((module Chacha20 : AEAD with type key = Chacha20.key),
Chacha20.of_secret, false)
let get_aead_cipher ~secret ~nonce aead_cipher =
match get_aead aead_cipher with
| K_AEAD (cipher, sec, explicit_nonce) ->
let cipher_secret = sec secret in
State.(AEAD { cipher ; cipher_secret ; nonce ; explicit_nonce })
let get_cipher ~secret ~hmac_secret ~iv_mode ~nonce = function
| `Block (cipher, hmac) ->
( match get_block cipher with
| K_CBC (cipher, sec) ->
let cipher_secret = sec secret in
State.(CBC { cipher ; cipher_secret ; iv_mode ; hmac ; hmac_secret })
)
| `AEAD cipher -> get_aead_cipher ~secret ~nonce cipher
end
let sequence_buf seq =
let buf = Bytes.create 8 in
Bytes.set_int64_be buf 0 seq ;
Bytes.unsafe_to_string buf
let aead_nonce nonce seq =
let s =
let l = String.length nonce in
let buf = Bytes.make l '\x00' in
Bytes.set_int64_be buf (l - 8) seq;
Bytes.unsafe_to_string buf
in
Uncommon.xor nonce s
let adata_1_3 len =
(* additional data in TLS 1.3 is using the header (RFC 8446 Section 5.2):
- APPLICATION_TYPE
- 0x03 0x03 (for TLS version 1.2 -- binary representation is 0x03 0x03)
- <length in 16 bit>
*)
let buf = Bytes.create 5 in
Bytes.set_uint8 buf 0 (Packet.content_type_to_int Packet.APPLICATION_DATA) ;
Bytes.set_uint8 buf 1 3;
Bytes.set_uint8 buf 2 3;
Bytes.set_uint16_be buf 3 len ;
Bytes.unsafe_to_string buf
let pseudo_header seq ty (v_major, v_minor) v_length =
let buf = Bytes.create 13 in
Bytes.set_int64_be buf 0 seq;
Bytes.set_uint8 buf 8 (Packet.content_type_to_int ty);
Bytes.set_uint8 buf 9 v_major;
Bytes.set_uint8 buf 10 v_minor;
Bytes.set_uint16_be buf 11 v_length;
Bytes.unsafe_to_string buf
(* MAC used in TLS *)
let mac hash key pseudo_hdr data =
let module H = (val Digestif.module_of_hash' hash) in
H.(to_raw_string (hmacv_string ~key [ pseudo_hdr ; data ]))
let cbc_block (type a) cipher =
let module C = (val cipher : Block.CBC with type key = a) in C.block_size
(* crazy CBC padding and unpadding for TLS *)
let cbc_pad block data =
(* 1 is the padding length, encoded as 8 bit at the end of the fragment *)
let len = 1 + String.length data in
(* we might want to add additional blocks of padding *)
let padding_length = block - (len mod block) in
(* 1 is again padding length field *)
let cstruct_len = padding_length + 1 in
String.make cstruct_len (Char.unsafe_chr padding_length)
let cbc_unpad data =
let len = String.length data in
let padlen = String.get_uint8 data (pred len) in
let rec check = function
| i when i > padlen -> true
| i -> (String.get_uint8 data (len - padlen - 1 + i) = padlen) && check (succ i) in
try
if check 0 then Some (String.sub data 0 (len - padlen - 1)) else None
with Invalid_argument _ -> None
let tag_len (type a) cipher =
let module C = (val cipher : AEAD with type key = a) in
C.tag_size
let encrypt_aead (type a) ~cipher ~key ~nonce ?adata data =
let module C = (val cipher : AEAD with type key = a) in
C.authenticate_encrypt ~key ~nonce ?adata data
let decrypt_aead (type a) ~cipher ~key ~nonce ?adata data =
let module C = (val cipher : AEAD with type key = a) in
C.authenticate_decrypt ~key ~nonce ?adata data
let encrypt_cbc (type a) ~cipher ~key ~iv data =
let module C = (val cipher : Block.CBC with type key = a) in
let message = C.encrypt ~key ~iv (data ^ cbc_pad C.block_size data) in
(message, C.next_iv ~iv message)
let decrypt_cbc (type a) ~cipher ~key ~iv data =
let module C = (val cipher : Block.CBC with type key = a) in
try
let message = C.decrypt ~key ~iv data in
match cbc_unpad message with
| Some res -> Some (res, C.next_iv ~iv data)
| None -> None
with
(* This bails out immediately on mis-alignment, making it very timeable.
* However, decryption belongs to the outermost level and this operation's
* timing does not leak information ala padding oracle and friends. *)
| Invalid_argument _ -> None

5
unikernel/duniverse/ocaml-tls/lib/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name tls)
(public_name tls)
(libraries logs kdf.hkdf ohex digestif mirage-crypto mirage-crypto-rng
mirage-crypto-pk x509 domain-name fmt mirage-crypto-ec ipaddr))

761
unikernel/duniverse/ocaml-tls/lib/engine.ml Normal file
View file

@ -0,0 +1,761 @@
open Core
open State
type state = State.state
type error = State.error
type fatal = State.fatal
type failure = State.failure
let alert_of_authentication_failure = function
| `LeafCertificateExpired _ -> Packet.CERTIFICATE_EXPIRED
| _ -> Packet.BAD_CERTIFICATE
let alert_of_error = function
| `NoConfiguredVersions _ -> Packet.PROTOCOL_VERSION
| `NoConfiguredCiphersuite _ -> Packet.HANDSHAKE_FAILURE
| `NoConfiguredSignatureAlgorithm _ -> Packet.HANDSHAKE_FAILURE
| `AuthenticationFailure err -> alert_of_authentication_failure err
| `NoMatchingCertificateFound _ -> Packet.UNRECOGNIZED_NAME
| `CouldntSelectCertificate -> Packet.HANDSHAKE_FAILURE
let alert_of_fatal = function
| `Protocol_version _ -> Packet.PROTOCOL_VERSION
| `Unexpected _ -> Packet.UNEXPECTED_MESSAGE
| `Decode _ -> Packet.DECODE_ERROR
| `Handshake _ -> Packet.HANDSHAKE_FAILURE
| `Bad_mac -> Packet.BAD_RECORD_MAC
| `Record_overflow _ -> Packet.RECORD_OVERFLOW
| `Unsupported_extension -> Packet.UNSUPPORTED_EXTENSION
| `Bad_certificate _ -> Packet.BAD_CERTIFICATE
| `Missing_extension _ -> Packet.MISSING_EXTENSION
| `Inappropriate_fallback -> Packet.INAPPROPRIATE_FALLBACK
| `No_application_protocol -> Packet.NO_APPLICATION_PROTOCOL
let alert_of_failure = function
| `Error x -> Packet.FATAL, alert_of_error x
| `Fatal x -> Packet.FATAL, alert_of_fatal x
| `Alert _ -> Packet.WARNING, Packet.CLOSE_NOTIFY
let pp_failure = State.pp_failure
let string_of_failure = Fmt.to_to_string pp_failure
type ret =
(state * [ `Eof ] option
* [ `Response of string option ]
* [ `Data of string option ],
failure * [ `Response of string ]) result
let new_state config role =
let handshake_state = match role with
| `Client -> Client ClientInitial
| `Server -> Server AwaitClientHello
in
let version = max_protocol_version Config.(config.protocol_versions) in
let handshake = {
session = [] ;
protocol_version = version ;
early_data_left = 0l ;
machina = handshake_state ;
config = config ;
hs_fragment = "" ;
}
in
{
handshake = handshake ;
decryptor = None ;
encryptor = None ;
fragment = "" ;
read_closed = false ;
write_closed = false ;
}
type raw_record = tls_hdr * string
let pp_raw_record ppf (hdr, data) =
Fmt.pf ppf "%a (%u bytes data)" pp_tls_hdr hdr (String.length data)
let pp_frame ppf (ty, data) =
Fmt.pf ppf "%a (%u bytes data)" Packet.pp_content_type ty
(String.length data)
(* well-behaved pure encryptor *)
let encrypt (version : tls_version) (st : crypto_state) ty buf off len =
match st with
| None -> (st, ty, String.sub buf off len)
| Some ctx ->
match version with
| `TLS_1_3 ->
(match ctx.cipher_st with
| AEAD c ->
let buf =
let b = Bytes.create (len + 1) in
Bytes.set_uint8 b len (Packet.content_type_to_int ty);
Bytes.blit_string buf off b 0 len;
Bytes.unsafe_to_string b
in
let nonce = Crypto.aead_nonce c.nonce ctx.sequence in
let adata = Crypto.adata_1_3 (String.length buf + Crypto.tag_len c.cipher) in
let buf = Crypto.encrypt_aead ~cipher:c.cipher ~adata ~key:c.cipher_secret ~nonce buf in
(Some { ctx with sequence = Int64.succ ctx.sequence }, Packet.APPLICATION_DATA, buf)
| _ -> assert false)
| _ ->
let pseudo_hdr =
let seq = ctx.sequence
and ver = pair_of_tls_version version
in
Crypto.pseudo_header seq ty ver len
in
let c_st, enc =
match ctx.cipher_st with
| CBC c ->
let enc iv =
(* TODO only until digestif goes beyond 1.2.0 (feedable hmac) *)
let data = String.sub buf off len in
let signature = Crypto.mac c.hmac c.hmac_secret pseudo_hdr buf in
let to_encrypt = data ^ signature in
Crypto.encrypt_cbc ~cipher:c.cipher ~key:c.cipher_secret ~iv to_encrypt
in
( match c.iv_mode with
| Random_iv ->
let iv = Mirage_crypto_rng.generate (Crypto.cbc_block c.cipher) in
let m, _ = enc iv in
(CBC c, iv ^ m)
| Iv iv ->
let m, iv' = enc iv in
(CBC { c with iv_mode = Iv iv' }, m) )
| AEAD c ->
let buf = String.sub buf off len in
if c.explicit_nonce then
let explicit_nonce = Crypto.sequence_buf ctx.sequence in
let nonce = c.nonce ^ explicit_nonce
in
let msg =
Crypto.encrypt_aead ~cipher:c.cipher ~key:c.cipher_secret ~nonce ~adata:pseudo_hdr buf
in
(AEAD c, explicit_nonce ^ msg)
else
(* RFC 7905: no explicit nonce, instead TLS 1.3 construction is adapted *)
let nonce = Crypto.aead_nonce c.nonce ctx.sequence in
let msg =
Crypto.encrypt_aead ~cipher:c.cipher ~key:c.cipher_secret ~nonce ~adata:pseudo_hdr buf
in
(AEAD c, msg)
in
(Some { sequence = Int64.succ ctx.sequence ; cipher_st = c_st }, ty, enc)
(* well-behaved pure decryptor *)
let verify_mac sequence mac mac_k ty ver decrypted =
let macstart =
let module H = (val Digestif.module_of_hash' mac) in
String.length decrypted - H.digest_size
in
let* () = guard (macstart >= 0) (`Fatal (`Decode "MAC underflow")) in
let (body, mmac) = split_str decrypted macstart in
let cmac =
let ver = pair_of_tls_version ver in
let hdr = Crypto.pseudo_header sequence ty ver (String.length body) in
Crypto.mac mac mac_k hdr body in
let* () = guard (String.equal cmac mmac) (`Fatal `Bad_mac) in
Ok body
let decrypt ?(trial = false) (version : tls_version) (st : crypto_state) ty buf =
let compute_mac seq mac mac_k buf = verify_mac seq mac mac_k ty version buf in
(* hmac is computed in this failure branch from the encrypted data, in the
successful branch it is decrypted - padding (which is smaller equal than
encrypted data) *)
(* This comment is borrowed from miTLS, but applies here as well: *)
(* We implement standard mitigation for padding oracles. Still, we note a
small timing leak here: The time to verify the mac is linear in the
plaintext length. *)
(* defense against http://lasecwww.epfl.ch/memo/memo_ssl.shtml 1) in
https://www.openssl.org/~bodo/tls-cbc.txt *)
let mask_decrypt_failure seq mac mac_k =
let* _ = compute_mac seq mac mac_k buf in
Error (`Fatal `Bad_mac)
in
let dec ctx =
let seq = ctx.sequence in
match ctx.cipher_st with
| CBC c ->
let dec iv buf =
match Crypto.decrypt_cbc ~cipher:c.cipher ~key:c.cipher_secret ~iv buf with
| None ->
mask_decrypt_failure seq c.hmac c.hmac_secret
| Some (dec, iv') ->
let* msg = compute_mac seq c.hmac c.hmac_secret dec in
Ok (msg, iv')
in
( match c.iv_mode with
| Iv iv ->
let* msg, iv' = dec iv buf in
Ok (CBC { c with iv_mode = Iv iv' }, msg)
| Random_iv ->
if String.length buf < Crypto.cbc_block c.cipher then
Error (`Fatal (`Decode "MAC underflow"))
else
let iv, buf = split_str buf (Crypto.cbc_block c.cipher) in
let* msg, _ = dec iv buf in
Ok (CBC c, msg) )
| AEAD c ->
if c.explicit_nonce then
let explicit_nonce_len = 8 in
if String.length buf < explicit_nonce_len then
Error (`Fatal (`Decode "MAC underflow"))
else
let explicit_nonce, buf = split_str buf explicit_nonce_len in
let adata =
let ver = pair_of_tls_version version in
Crypto.pseudo_header seq ty ver (String.length buf - Crypto.tag_len c.cipher)
and nonce = c.nonce ^ explicit_nonce
in
match Crypto.decrypt_aead ~cipher:c.cipher ~key:c.cipher_secret ~nonce ~adata buf with
| None -> Error (`Fatal `Bad_mac)
| Some x -> Ok (AEAD c, x)
else
(* RFC 7905: no explicit nonce, instead TLS 1.3 construction is adapted *)
let adata =
let ver = pair_of_tls_version version in
Crypto.pseudo_header seq ty ver (String.length buf - Crypto.tag_len c.cipher)
and nonce = Crypto.aead_nonce c.nonce seq
in
(match Crypto.decrypt_aead ~adata ~cipher:c.cipher ~key:c.cipher_secret ~nonce buf with
| None -> Error (`Fatal `Bad_mac)
| Some x -> Ok (AEAD c, x))
in
match st, version with
| None, _ when ty = Packet.APPLICATION_DATA ->
(* the server can end up in the situation:
CH [+early_data +key_share] ; APP_DATA ---->
<--- HRR [+key_share] (does not install a decryptor,
early data now disallowed)
CH [+key_share] ----->
the APP_DATA above cannot be decrypted or used, so we drop it.
*)
Ok (None, "", Packet.APPLICATION_DATA)
| None, _ -> Ok (st, buf, ty)
| Some ctx, `TLS_1_3 ->
(match ty with
| Packet.CHANGE_CIPHER_SPEC -> Ok (st, buf, ty)
| Packet.APPLICATION_DATA ->
(match ctx.cipher_st with
| AEAD c ->
let nonce = Crypto.aead_nonce c.nonce ctx.sequence in
let unpad x =
let rec eat = function
| -1 -> Error (`Fatal (`Unexpected (`Message "missing content type")))
| idx -> match String.get_uint8 x idx with
| 0 -> eat (pred idx)
| n -> match Packet.int_to_content_type n with
| Some ct -> Ok (String.sub x 0 idx, ct)
| None -> Error (`Fatal (`Unexpected (`Content_type n)))
in
eat (pred (String.length x))
in
let adata = Crypto.adata_1_3 (String.length buf) in
(match Crypto.decrypt_aead ~adata ~cipher:c.cipher ~key:c.cipher_secret ~nonce buf with
| None ->
if trial then
Ok (Some ctx, "", Packet.APPLICATION_DATA)
else
Error (`Fatal `Bad_mac)
| Some x ->
let* data, ty = unpad x in
Ok (Some { ctx with sequence = Int64.succ ctx.sequence }, data, ty))
| _ -> Error (`Fatal (`Handshake (`Message "unexpected cipher state (must be AEAD)"))))
| ct ->
let msg = "unexpected content type (TLS 1.3, encrypted) " ^ Packet.content_type_to_string ct in
Error (`Fatal (`Handshake (`Message msg))))
| Some ctx, _ ->
let* st', msg = dec ctx in
let ctx' = { cipher_st = st' ; sequence = Int64.succ ctx.sequence } in
Ok (Some ctx', msg, ty)
(* party time *)
let rec separate_records : string -> ((tls_hdr * string) list * string, failure) result
= fun buf ->
match Reader.parse_record buf with
| Ok (`Fragment b) -> Ok ([], b)
| Ok (`Record (packet, fragment)) ->
let* tl, frag = separate_records fragment in
Ok (packet :: tl, frag)
| Error e ->
Tracing.cs ~tag:"buf-in" buf ;
Error (`Fatal e)
let encrypt_records encryptor version records =
let rec crypt st acc = function
| [] -> st, List.rev acc
| (ty, buf) :: rest ->
let bufl = String.length buf in
let rec doit st acc off =
if bufl - off >= 1 lsl 14 then
let len = 1 lsl 14 in
let st, ty, buf = encrypt version st ty buf off len in
(doit [@tailcall]) st ((ty, buf) :: acc) (off + len)
else
let st, ty, buf = encrypt version st ty buf off (bufl - off) in
st, (ty, buf) :: acc
in
let st, res = doit st [] 0 in
(crypt [@tailcall]) st (res @ acc) rest
in
crypt encryptor [] records
module Alert = struct
(* The alert protocol:
- receiving a close_notify leads to eof (never read() any further data)
- any fatal alert leads to sending a close_notify and state is closed
*)
open Packet
let make ?level typ = (ALERT, Writer.assemble_alert ?level typ)
let close_notify = make ~level:WARNING CLOSE_NOTIFY
let handle buf =
let* alert = map_reader_error (Reader.parse_alert buf) in
let _, a_type = alert in
Tracing.debug (fun m -> m "alert-in %a" pp_alert alert) ;
match a_type with
| CLOSE_NOTIFY | USER_CANCELED -> Ok true
| _ -> Error (`Alert a_type)
end
let hs_can_handle_appdata s =
(* When is a TLS session up for some application data?
- initial handshake must be finished!
- renegotiation must not be in progress
--> thus only ok for Established
- but ok if server sent a HelloRequest and can get first some appdata then ClientHello
--> or converse: client sent ClientHello, waiting for ServerHello *)
(* turns out, rules in 1.3 are slightly different -- server may send appdata after its first flight!
this means in any observable state! (apart from when a HRR was sent) *)
match s.machina with
| Server13 AwaitClientHelloHRR13 -> false
| Server Established | Server AwaitClientHelloRenegotiate | Server13 _
| Client Established | Client AwaitServerHelloRenegotiate _ | Client13 Established13 -> true
| _ -> false
let early_data s =
match s.machina with
| Server13 AwaitClientHelloHRR13
| Server13 (AwaitEndOfEarlyData13 _) | Server13 (AwaitClientFinished13 _)
| Server13 (AwaitClientCertificate13 _) | Server13 (AwaitClientCertificateVerify13 _) -> true
| _ -> false
let rec separate_handshakes buf =
match Reader.parse_handshake_frame buf with
| None, rest -> [], rest
| Some hs, rest ->
let rt, frag = separate_handshakes rest in
hs :: rt, frag
let handle_change_cipher_spec = function
| Client cs -> Handshake_client.handle_change_cipher_spec cs
| Server ss -> Handshake_server.handle_change_cipher_spec ss
(* D.4: the client may send a CCS before its second flight
(before second ClientHello or encrypted handshake flight)
the server may send it immediately after its first handshake message
(ServerHello or HelloRetryRequest) *)
| Client13 (AwaitServerEncryptedExtensions13 _)
| Client13 (AwaitServerHello13 _)
| Server13 AwaitClientHelloHRR13
| Server13 (AwaitClientCertificate13 _)
| Server13 (AwaitClientFinished13 _) -> (fun s _ -> Ok (s, []))
| _ -> (fun _ _ -> Error (`Fatal (`Unexpected (`Message "change cipher spec"))))
and handle_handshake = function
| Client cs -> Handshake_client.handle_handshake cs
| Server ss -> Handshake_server.handle_handshake ss
| Client13 cs -> Handshake_client13.handle_handshake cs
| Server13 ss -> Handshake_server13.handle_handshake ss
let non_empty cs =
if String.length cs = 0 then None else Some cs
let handle_packet hs buf = function
(* RFC 5246 -- 6.2.1.:
Implementations MUST NOT send zero-length fragments of Handshake,
Alert, or ChangeCipherSpec content types. Zero-length fragments of
Application data MAY be sent as they are potentially useful as a
traffic analysis countermeasure.
*)
| Packet.ALERT ->
let* eof = Alert.handle buf in
Ok (hs, [], None, eof)
| Packet.APPLICATION_DATA ->
if hs_can_handle_appdata hs || (early_data hs && String.length hs.hs_fragment = 0) then
(Tracing.cs ~tag:"application-data-in" buf;
Ok (hs, [], non_empty buf, false))
else
Error (`Fatal (`Unexpected (`Message "application data")))
| Packet.CHANGE_CIPHER_SPEC ->
let* hs, items = handle_change_cipher_spec hs.machina hs buf in
Ok (hs, items, None, false)
| Packet.HANDSHAKE ->
let hss, hs_fragment = separate_handshakes (hs.hs_fragment ^ buf) in
let hs = { hs with hs_fragment } in
let* hs, items =
List.fold_left (fun acc raw ->
let* hs, items = acc in
let* hs', items' = handle_handshake hs.machina hs raw in
Ok (hs', items @ items'))
(Ok (hs, [])) hss
in
Ok (hs, items, None, false)
let decrement_early_data hs ty buf =
let bytes left cipher =
let count = String.length buf - fst (Ciphersuite.kn_13 (Ciphersuite.privprot13 cipher)) in
let left' = Int32.sub left (Int32.of_int count) in
if left' < 0l then
Error (`Fatal (`Unexpected (`Message "too many 0RTT bytes")))
else
Ok left'
in
if ty = Packet.APPLICATION_DATA && early_data hs then
let cipher = match hs.session with
| `TLS13 sd::_ -> sd.ciphersuite13
| _ -> `AES_128_GCM_SHA256
(* TODO assert and ensure that all early_data states have a cipher *)
in
let* early_data_left = bytes hs.early_data_left cipher in
Ok { hs with early_data_left }
else
Ok hs
(* the main thingy *)
let handle_raw_record state (hdr, buf as record : raw_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* () =
match hs.machina, version with
| Client (AwaitServerHello _), _ -> Ok ()
| Server AwaitClientHello, _ -> Ok ()
| Server13 AwaitClientHelloHRR13, _ -> Ok ()
| _, `TLS_1_3 ->
guard (hdr.version = `TLS_1_2)
(`Fatal (`Protocol_version (`Bad_record hdr.version)))
| _, v ->
guard (version_eq hdr.version v)
(`Fatal (`Protocol_version (`Bad_record hdr.version)))
in
let trial = match hs.machina with
| Server13 (AwaitEndOfEarlyData13 _) | Server13 Established13 -> false
| Server13 _ -> hs.early_data_left > 0l && String.length hs.hs_fragment = 0
| _ -> false
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.debug (fun m -> m "frame-in %a" pp_frame (ty, dec)) ;
let* handshake, items, data, read_closed = 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.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 (fun f -> Tracing.debug (fun m -> m "record-out %a" pp_frame f)) encs ;
let read_closed = read_closed || state.read_closed in
let state' = { state with handshake ; encryptor ; decryptor ; read_closed } in
Ok (state', encs, data)
let maybe_app a b = match a, b with
| Some x, Some y -> Some (x ^ y)
| Some x, None -> Some x
| None , Some y -> Some y
| None , None -> None
let assemble_records (version : tls_version) rs =
let version = match version with `TLS_1_3 -> `TLS_1_2 | x -> x in
String.concat "" (List.map (Writer.assemble_hdr version) rs)
(* main entry point *)
let handle_tls state buf =
Tracing.cs ~tag:"wire-in" buf ;
let rec handle_records st = function
| [] -> Ok (st, [], None)
| r::rs ->
let* st, raw_rs, data = handle_raw_record st r in
let* st', raw_rs', data' = handle_records st rs in
Ok (st', raw_rs @ raw_rs', maybe_app data data')
in
match
let* in_records, fragment = separate_records (state.fragment ^ buf) in
let* state', out_records, data = handle_records state in_records in
let version = state'.handshake.protocol_version in
let resp = match out_records with
| [] -> None
| _ ->
let out = assemble_records version out_records in
Tracing.cs ~tag:"wire-out" out ;
Some out
in
Ok ({ state' with fragment }, resp, data)
with
| Ok (state, resp, data) ->
let res =
if state.read_closed then begin
Tracing.debug (fun m -> m "eof-out") ;
Some `Eof
end else
None
in
(* Tracing.sexpf ~tag:"state-out" ~f:sexp_of_state state ; *)
Ok (state, res, `Response resp, `Data data)
| Error x ->
let version = state.handshake.protocol_version in
let level, alert = alert_of_failure x in
let record = Alert.make ~level alert in
let _, enc = encrypt_records state.encryptor version [record] in
let resp = assemble_records version enc in
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 (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 (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)
let handshake_in_progress s = match s.handshake.machina with
| Client Established | Server Established -> false
| Client13 Established13 | Server13 Established13 -> false
| _ -> true
(* entry for user data *)
let send_application_data st css =
if st.write_closed || not (hs_can_handle_appdata st.handshake) then
None
else begin
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 _ ; _ } ; _ } -> "" :: css
| _ -> css
in
let ty = Packet.APPLICATION_DATA in
let data = List.map (fun cs -> (ty, cs)) datas in
Some (send_records st data)
end
let send_close_notify st =
let st = { st with write_closed = true } in
send_records st [Alert.close_notify]
let reneg ?authenticator ?acceptable_cas ?cert st =
if st.write_closed || st.read_closed then
(* this is a full handshake (with messages from both sides), thus if either
direction has closed the flow, the reneg won't succeed *)
None
else
let config = st.handshake.config in
let config = Option.fold ~none:config ~some:(Config.with_authenticator config) authenticator in
let config = Option.fold ~none:config ~some:(Config.with_acceptable_cas config) acceptable_cas in
let config = Option.fold ~none:config ~some:(Config.with_own_certificates config) cert in
let hs = { st.handshake with config } in
match hs.machina with
| Server Established ->
( match Handshake_server.hello_request hs with
| Ok (handshake, [`Record hr]) -> Some (send_records { st with handshake } [hr])
| _ -> None )
| Client Established ->
( match Handshake_client.answer_hello_request hs with
| Ok (handshake, [`Record ch]) -> Some (send_records { st with handshake } [ch])
| _ -> None )
| _ -> None
let key_update ?(request = true) state =
if state.write_closed then
Error (`Fatal (`Unexpected (`Message "write half already closed")))
else
let* state', out = Handshake_common.output_key_update ~request state in
let _, outbuf = send_records state [out] in
Ok (state', outbuf)
let client config =
let config = Config.of_client config in
let state = new_state config `Client in
let dch, _version, secrets = Handshake_client.default_client_hello config in
let ciphers, extensions = match config.Config.protocol_versions with
(* from RFC 5746 section 3.3:
Both the SSLv3 and TLS 1.0/TLS 1.1 specifications require
implementations to ignore data following the ClientHello (i.e.,
extensions) if they do not understand it. However, some SSLv3 and
TLS 1.0 implementations incorrectly fail the handshake in such a
case. This means that clients that offer the "renegotiation_info"
extension may encounter handshake failures. In order to enhance
compatibility with such servers, this document defines a second
signaling mechanism via a special Signaling Cipher Suite Value (SCSV)
"TLS_EMPTY_RENEGOTIATION_INFO_SCSV", with code point {0x00, 0xFF}.
This SCSV is not a true cipher suite (it does not correspond to any
valid set of algorithms) and cannot be negotiated. Instead, it has
the same semantics as an empty "renegotiation_info" extension, as
described in the following sections. Because SSLv3 and TLS
implementations reliably ignore unknown cipher suites, the SCSV may
be safely sent to any server. *)
| (_, `TLS_1_0) -> ([Packet.TLS_EMPTY_RENEGOTIATION_INFO_SCSV], [])
| (`TLS_1_3, _) -> ([], [])
| _ -> ([], [`SecureRenegotiation ""])
in
let client_hello =
{ dch with
ciphersuites = dch.ciphersuites @ ciphers ;
extensions = dch.extensions @ extensions }
in
let client_hello, ch, raw =
match config.Config.cached_ticket, config.Config.ticket_cache with
| None, _ | _, None ->
let ch = ClientHello client_hello in
client_hello, ch, Writer.assemble_handshake ch
| Some (psk, epoch), Some cache ->
let kex = `PskKeyExchangeModes [ Packet.PSK_KE_DHE ] in
(* what next!? *)
let now = cache.Config.timestamp () in
(* TODO check lifetime! *)
let obf_age =
let span = Ptime.Span.to_float_s (Ptime.diff now psk.issued_at) in
(* _in milliseconds_ *)
let ms = int_of_float (span *. 1000.) in
Int32.add psk.obfuscation (Int32.of_int ms)
in
let cipher = match Ciphersuite.ciphersuite_to_ciphersuite13 epoch.ciphersuite with
| None -> assert false
| Some c -> c
in
(* if all goes well, we can compute the binder key and embed into ch! *)
let early_secret = Handshake_crypto13.(derive (empty cipher) psk.secret) in
let binder_key = Handshake_crypto13.derive_secret early_secret "res binder" "" in
let hash =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
String.make H.digest_size '\x00'
in
let incomplete_psks = [ (psk.identifier, obf_age), hash ] in
let ch' = { client_hello with extensions = client_hello.extensions @ [ kex ; `PreSharedKeys incomplete_psks ] } in
let ch'_raw = Writer.assemble_handshake (ClientHello ch') in
let binders_len = binders_len incomplete_psks in
let ch_part = String.(sub ch'_raw 0 (length ch'_raw - binders_len)) in
let binder = Handshake_crypto13.finished early_secret.hash binder_key ch_part in
let blen = String.length binder in
let prefix = Bytes.create 3 in
Bytes.set_uint16_be prefix 0 (blen + 1) ;
Bytes.set_uint8 prefix 2 blen ;
let raw = String.concat "" [ ch_part ; Bytes.unsafe_to_string prefix ; binder ] in
let psks = [(psk.identifier, obf_age), binder] in
let client_hello' = { client_hello with extensions = client_hello.extensions @ [ kex ; `PreSharedKeys psks ] } in
let ch' = ClientHello client_hello' in
client_hello', ch', raw
in
let machina = AwaitServerHello (client_hello, secrets, [raw]) in
(* from RFC5246, appendix E.1
TLS clients that wish to negotiate with older servers MAY send any
value {03,XX} as the record layer version number. Typical values
would be {03,00}, the lowest version number supported by the client,
and the value of ClientHello.client_version. No single value will
guarantee interoperability with all old servers, but this is a
complex topic beyond the scope of this document. *)
let version = min_protocol_version Config.(config.protocol_versions) in
let handshake = {
state.handshake with
machina = Client machina ;
protocol_version = version
} in
let state = { state with handshake } in
Tracing.hs ~tag:"handshake-out" ch ;
send_records state [(Packet.HANDSHAKE, raw)]
let server config = new_state Config.(of_server config) `Server
let epoch state =
Option.to_result ~none:() (epoch_of_hs state.handshake)
let export_key_material (e : epoch_data) ?context label length =
match e.protocol_version with
| `TLS_1_3 ->
let hash =
let cipher = Option.get (Ciphersuite.ciphersuite_to_ciphersuite13 e.ciphersuite) in
Ciphersuite.hash13 cipher
in
let module H = (val Digestif.module_of_hash' hash) in
let ems = e.exporter_master_secret in
let prk =
let ctx = H.(to_raw_string (digest_string "")) in
Handshake_crypto13.derive_secret_no_hash hash ems ~ctx label
in
let ctx = Option.value ~default:"" context in
Handshake_crypto13.derive_secret_no_hash
hash prk ~ctx:H.(to_raw_string (digest_string ctx))
~length "exporter"
| #tls_before_13 as v ->
let seed =
let base =
match e.side with
| `Server -> e.peer_random ^ e.own_random
| `Client -> e.own_random ^ e.peer_random
in
match context with
| None -> base
| Some data ->
let len = Bytes.create 2 in
Bytes.set_uint16_be len 0 (String.length data);
String.concat "" [ base ; Bytes.unsafe_to_string len ; data ]
in
Handshake_crypto.pseudo_random_function v e.ciphersuite
length e.master_secret label seed
let channel_binding e = function
| `Tls_exporter ->
Ok (export_key_material e "EXPORTER-Channel-Binding" 32)
| `Tls_server_endpoint ->
let ( let* ) = Result.bind in
let* cert =
match e.side, e.peer_certificate, e.own_certificate with
| `Client, Some cert, _ -> Ok cert
| `Server, _, cert :: _ -> Ok cert
| `Client, _, _ -> Error (`Msg "no certificate received from the server")
| `Server, _, _ -> Error (`Msg "certificate not available")
in
let* sigalg =
Option.to_result ~none:(`Msg "unknown signature algorithm in certificate")
(Option.map snd (X509.Certificate.signature_algorithm cert))
in
let hash = match sigalg with `MD5 | `SHA1 -> `SHA256 | x -> x in
Ok (X509.Certificate.fingerprint hash cert)
| `Tls_unique ->
match e.protocol_version, e.tls_unique with
| `TLS_1_3, _ ->
Error (`Msg "tls-unique not defined for TLS 1.3")
| _, None -> Error (`Msg "couldn't find a tls-unique in the session data")
| _, Some data -> Ok data

172
unikernel/duniverse/ocaml-tls/lib/engine.mli Normal file
View file

@ -0,0 +1,172 @@
(** Transport layer security
[TLS] is an implementation of
{{:https://en.wikipedia.org/wiki/Transport_Layer_Security}transport
layer security} in OCaml. TLS is a widely used security protocol
which establishes an end-to-end secure channel (with optional
(mutual) authentication) between two endpoints. It uses TCP/IP as
transport. This library supports all four versions of TLS:
{{:https://tools.ietf.org/html/rfc8446}1.3, RFC8446},
{{:https://tools.ietf.org/html/rfc5246}1.2, RFC5246},
{{:https://tools.ietf.org/html/rfc4346}1.1, RFC4346}, and
{{:https://tools.ietf.org/html/rfc2246}1.0, RFC2246}. SSL, the
previous protocol definition, is not supported.
TLS is algorithmically agile: protocol version, key exchange
algorithm, symmetric cipher, and message authentication code are
negotiated upon connection.
This library implements several extensions of TLS,
{{:https://tools.ietf.org/html/rfc3268}AES ciphers},
{{:https://tools.ietf.org/html/rfc4366}TLS extensions} (such as
server name indication, SNI),
{{:https://tools.ietf.org/html/rfc5746}Renegotiation extension},
{{:https://tools.ietf.org/html/rfc7627}Session Hash and Extended
Master Secret Extension}.
This library does not contain insecure cipher suites (such as
single DES, export ciphers, ...). It does not expose the server
time in the server random, requires secure renegotiation.
This library consists of a core, implemented in a purely
functional matter ({!Engine}, this module), and effectful parts:
{!Tls_lwt} and {!Tls_mirage}.
{e v2.0.3} *)
(** {1 Abstract state type} *)
(** The abstract type of a TLS state. *)
type state
(** {1 Constructors} *)
(** [client client] is [tls * out] where [tls] is the initial state,
and [out] the initial client hello *)
val client : Config.client -> (state * string)
(** [server server] is [tls] where [tls] is the initial server
state *)
val server : Config.server -> state
(** {1 Protocol failures} *)
(** failures which can be mitigated by reconfiguration *)
type error = [
| `AuthenticationFailure of X509.Validation.validation_error
| `NoConfiguredCiphersuite of Ciphersuite.ciphersuite list
| `NoConfiguredVersions of Core.tls_version list
| `NoConfiguredSignatureAlgorithm of Core.signature_algorithm list
| `NoMatchingCertificateFound of string
| `CouldntSelectCertificate
]
(** failures from received garbage or lack of features *)
type fatal = [
| `Protocol_version of [
| `None_supported of Core.tls_any_version list
| `Unknown_record of int * int
| `Bad_record of Core.tls_any_version
]
| `Unexpected of [
| `Content_type of int
| `Message of string
| `Handshake of Core.tls_handshake
]
| `Decode of string
| `Handshake of [
| `Message of string
| `Fragments
| `BadDH of string
| `BadECDH of Mirage_crypto_ec.error
]
| `Bad_certificate of string
| `Missing_extension of string
| `Bad_mac
| `Record_overflow of int
| `Unsupported_extension
| `Inappropriate_fallback
| `No_application_protocol
]
(** type of failures *)
type failure = [
| `Error of error
| `Fatal of fatal
| `Alert of Packet.alert_type
]
(** [alert_of_failure failure] is [alert], the TLS alert type for this failure. *)
val alert_of_failure : failure -> Packet.alert_level * 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} *)
(** result type of {!handle_tls}: either failed to handle the incoming
buffer ([`Fail]) with {!failure} and potentially a message to send
to the other endpoint, or sucessful operation ([`Ok]) with a new
{!state}, an end of file ([`Eof]), or an incoming ([`Alert]).
Possibly some [`Response] to the other endpoint is needed, and
potentially some [`Data] for the application was received. *)
type ret =
(state * [ `Eof ] option
* [ `Response of string option ]
* [ `Data of string option ],
failure * [ `Response of string ]) result
(** [handle_tls state buffer] is [ret], depending on incoming [state]
and [buffer], the result is the appropriate {!ret} *)
val handle_tls : state -> string -> ret
(** [handshake_in_progrss state] is a predicate which indicates whether there
is a handshake in progress or scheduled. *)
val handshake_in_progress : state -> bool
(** [send_application_data tls outs] is [Some (tls', out)] where
[tls'] is the new tls state, and [out] the cstruct to send over the
wire (encrypted [outs]) when the TLS session is ready. When the TLS
session is not ready it is [None]. *)
val send_application_data : state -> string list -> (state * string) option
(** [send_close_notify tls] is [tls' * out] where [tls'] is the new
tls state, and out the (possible encrypted) close notify alert. *)
val send_close_notify : state -> state * string
(** [reneg ~authenticator ~acceptable_cas ~cert tls] initiates a renegotation on
[tls], using the provided [authenticator]. It is [tls' * out] where [tls']
is the new tls state, and [out] either a client hello or hello request
(depending on which communication endpoint [tls] is). *)
val reneg : ?authenticator:X509.Authenticator.t ->
?acceptable_cas:X509.Distinguished_name.t list -> ?cert:Config.own_cert ->
state -> (state * string) option
(** [key_update ~request state] initiates a KeyUpdate (TLS 1.3 only). If
[request] is provided and [true] (the default), the KeyUpdate message
contains a request that the peer should update their traffic key as well. *)
val key_update : ?request:bool -> state -> (state * string, failure) result
(** {1 Session information} *)
(** [epoch state] is [epoch], which contains the session
information. If there's no established session yet, an error is returned. *)
val epoch : state -> (Core.epoch_data, unit) result
(** [export_key_material epoch_data ?context label length] is the RFC 5705
exported key material of [length] bytes using [label] and, if provided,
[context]. *)
val export_key_material : Core.epoch_data -> ?context:string -> string -> int ->
string
(** [channel_binding epoch_data mode] is the RFC 5929 and RFC 9266 specified
channel binding. Please note that [`Tls_unique] will error for TLS 1.3
sessions, and [`Tls_exporter] is not recommended for TLS < 1.3 sessions
(unless the uniqueness is ensured via another path). *)
val channel_binding : Core.epoch_data ->
[ `Tls_exporter | `Tls_unique | `Tls_server_endpoint ] ->
(string, [ `Msg of string ]) result

0
unikernel/duniverse/ocaml-tls/lib/explorator.ml Normal file
View file

544
unikernel/duniverse/ocaml-tls/lib/handshake_client.ml Normal file
View file

@ -0,0 +1,544 @@
open Core
open State
open Handshake_common
open Config
let state_version state = match state.protocol_version with
| #tls_before_13 as v -> v
| _ -> assert false
let default_client_hello config =
let host = match config.peer_name with
| None -> []
| Some x -> [`Hostname x]
in
let version = max_protocol_version config.protocol_versions in
let ecc_groups = match List.filter Config.elliptic_curve config.groups with
| [] -> []
| xs -> [ `ECPointFormats ; `SupportedGroups (List.map group_to_named_group xs) ]
in
let extensions, secrets = match version with
| `TLS_1_0 | `TLS_1_1 -> (ecc_groups, [])
| `TLS_1_2 ->
(`SignatureAlgorithms config.signature_algorithms :: ecc_groups, [])
| `TLS_1_3 ->
let sig_alg = config.signature_algorithms (* TODO: filter deprecated ones *)
and groups = List.map group_to_named_group config.groups
and secrets, keyshares =
(* OTOH, we could send all the keyshares (but this is pretty substantial size) *)
(* instead we pick the first two groups and send keyshares *)
let rec gen c gs acc = match c with
| 0 -> List.rev acc
| _ -> match gs with
| [] -> List.rev acc (* TODO log? complain? *)
| g::gs' ->
let priv, share = Handshake_crypto13.dh_gen_key g in
let acc' = ((g, priv),(group_to_named_group g, share)) :: acc in
gen (pred c) gs' acc'
in
List.split (gen 2 config.groups [])
in
let all = all_versions config.protocol_versions in
let supported_versions = List.map (fun x -> (x :> tls_any_version)) all in
let point_format =
if min_protocol_version config.protocol_versions = `TLS_1_3 then
[]
else
[ `ECPointFormats ]
in
let exts =
point_format @ [`SignatureAlgorithms sig_alg ; `SupportedGroups groups ; `KeyShare keyshares ; `SupportedVersions supported_versions ]
in
(exts, secrets)
in
let alpn = match config.alpn_protocols with
| [] -> []
| protocols -> [`ALPN protocols]
in
let sessionid =
match config.use_reneg, config.cached_session with
| _, Some { session_id ; extended_ms ; _ } when extended_ms && not (String.length session_id = 0) -> Some session_id
| false, Some { session_id ; _ } when not (String.length session_id = 0) -> Some session_id
| _ -> None
in
let ch = {
client_version = (version :> tls_any_version) ;
client_random = Mirage_crypto_rng.generate 32 ;
sessionid = sessionid ;
ciphersuites = List.map Ciphersuite.ciphersuite_to_any_ciphersuite config.ciphers ;
extensions = `ExtendedMasterSecret :: host @ extensions @ alpn
}
in
(ch, version, secrets)
let common_server_hello_validation config reneg (sh : server_hello) (ch : client_hello) =
let validate_reneg data =
let err = `Fatal (`Handshake (`Message "invalid renegotiation")) in
match reneg, data with
| Some (cvd, svd), Some x -> guard (String.equal (cvd ^ svd) x) err
| Some _, None -> Error err
| None, Some x -> guard (String.length x = 0) err
| None, None -> Ok ()
in
let* () =
guard (List.mem sh.ciphersuite config.ciphers)
(`Error (`NoConfiguredCiphersuite [sh.ciphersuite]))
in
let* () =
guard (server_hello_valid sh &&
server_exts_subset_of_client sh.extensions ch.extensions)
(`Fatal `Unsupported_extension)
in
let* () =
match get_alpn_protocol sh with
| None -> Ok ()
| Some x ->
guard (List.mem x config.alpn_protocols) (`Fatal `Unsupported_extension)
in
validate_reneg (get_secure_renegotiation sh.extensions)
let common_server_hello_machina state (sh : server_hello) (ch : client_hello) raw log =
let cipher = sh.ciphersuite in
let session_id = Option.value ~default:"" sh.sessionid in
let extended_ms =
List.mem `ExtendedMasterSecret ch.extensions &&
List.mem `ExtendedMasterSecret sh.extensions
in
let alpn_protocol = get_alpn_protocol sh in
let session =
let session = empty_session in
let common_session_data = {
session.common_session_data with
client_random = ch.client_random ;
server_random = sh.server_random ;
alpn_protocol ;
} in {
session with
common_session_data ;
ciphersuite = cipher ;
session_id ;
extended_ms ;
client_version = ch.client_version ;
}
in
let state = { state with protocol_version = sh.server_version } in
match Ciphersuite.ciphersuite_kex cipher with
| #Ciphersuite.key_exchange_algorithm_dhe ->
let machina = Client (AwaitCertificate_DHE (session, log @ [raw])) in
Ok ({ state with machina }, [])
| `RSA ->
let machina = Client (AwaitCertificate_RSA (session, log @ [raw])) in
Ok ({ state with machina }, [])
let answer_server_hello state (ch : client_hello) sh secrets raw log =
let validate_version requested (lo, _) server_version =
guard (version_ge requested server_version && server_version >= lo)
(`Error (`NoConfiguredVersions [ server_version ]))
in
let cfg = state.config in
let* () = common_server_hello_validation cfg None sh ch in
let* () = validate_version ch.client_version state.config.protocol_versions sh.server_version in
let* () =
if max_protocol_version state.config.protocol_versions = `TLS_1_3 then
let* () =
guard (not (Utils.sub_equal ~off:24 ~len:8 Packet.downgrade12 sh.server_random))
(`Fatal (`Handshake (`Message "random contains downgrade TLS 1.2")))
in
guard (not (Utils.sub_equal ~off:24 ~len:8 Packet.downgrade11 sh.server_random))
(`Fatal (`Handshake (`Message "random contains downgrade TLS 1.1")))
else
Ok ()
in
let epoch_matches (epoch : epoch_data) =
epoch.ciphersuite = sh.ciphersuite &&
epoch.protocol_version = sh.server_version &&
Option.fold ~none:false ~some:(SessionID.equal epoch.session_id) sh.sessionid &&
(not cfg.use_reneg ||
(List.mem `ExtendedMasterSecret sh.extensions && epoch.extended_ms))
in
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
match sh.server_version with
| #tls13 ->
Handshake_client13.answer_server_hello state ch sh secrets raw (String.concat "" log)
| #tls_before_13 as v ->
match state.config.cached_session with
| Some epoch when epoch_matches epoch ->
let session =
let session = session_of_epoch epoch in
let common_session_data = {
session.common_session_data with
client_random = ch.client_random ;
server_random = sh.server_random ;
client_auth = match epoch.own_certificate with [] -> false | _ -> true ;
} in
{ session with
common_session_data ;
client_version = ch.client_version ;
}
in
let client_ctx, server_ctx =
Handshake_crypto.initialise_crypto_ctx v session
in
let machina = AwaitServerChangeCipherSpecResume (session, client_ctx, server_ctx, log @ [raw]) in
Ok ({ state with machina = Client machina }, [])
| _ -> common_server_hello_machina state sh ch raw log
let answer_server_hello_renegotiate state session (ch : client_hello) sh raw log =
let* () = common_server_hello_validation state.config (Some session.renegotiation) sh ch in
let* () =
guard (state.protocol_version = sh.server_version)
(`Fatal (`Handshake (`Message "invalid renegotiation version")))
in
common_server_hello_machina state sh ch raw log
let validate_keyusage certificate kex =
let usage = Ciphersuite.required_usage kex in
let* cert =
Option.to_result ~none:(`Fatal (`Bad_certificate "none received")) certificate
in
let* () =
guard (supports_key_usage ~not_present:true usage cert)
(`Fatal (`Bad_certificate "key usage"))
in
guard
(supports_extended_key_usage `Server_auth cert ||
supports_extended_key_usage ~not_present:true `Any cert)
(`Fatal (`Bad_certificate "extended key usage"))
let answer_certificate_RSA state (session : session_data) cs raw log =
let cfg = state.config in
let* peer_certificate, received_certificates, peer_certificate_chain, trust_anchor =
validate_chain cfg.authenticator cs cfg.ip cfg.peer_name
in
let* () = validate_keyusage peer_certificate `RSA in
let session =
let common_session_data = { session.common_session_data with received_certificates ; peer_certificate ; peer_certificate_chain ; trust_anchor } in
{ session with common_session_data }
in
let* version =
match session.client_version with
| `TLS_1_3 -> Ok `TLS_1_2
| #tls_before_13 as v -> Ok v
| _ -> assert false
in
let buf = Bytes.create (2 + 46) in
let _ver = Writer.assemble_protocol_version ~buf version in
Mirage_crypto_rng.generate_into buf ~off:2 46;
let premaster = Bytes.unsafe_to_string buf in
let* k = peer_key peer_certificate in
match k with
| `RSA key ->
let kex = Mirage_crypto_pk.Rsa.PKCS1.encrypt ~key premaster in
let kex = Writer.assemble_client_dh_key_exchange kex in
let machina =
AwaitCertificateRequestOrServerHelloDone
(session, kex, premaster, log @ [raw])
in
Ok ({ state with machina = Client machina }, [])
| _ -> Error (`Fatal (`Bad_certificate "not an RSA certificate"))
let answer_certificate_DHE state (session : session_data) cs raw log =
let cfg = state.config in
let* peer_certificate, received_certificates, peer_certificate_chain, trust_anchor =
validate_chain cfg.authenticator cs cfg.ip cfg.peer_name
in
let* () = validate_keyusage peer_certificate `FFDHE in
let session =
let common_session_data = { session.common_session_data with received_certificates ; peer_certificate ; peer_certificate_chain ; trust_anchor } in
{ session with common_session_data }
in
let machina = AwaitServerKeyExchange_DHE (session, log @ [raw]) in
Ok ({ state with machina = Client machina }, [])
let answer_server_key_exchange_DHE state (session : session_data) kex raw log =
let* group, shared, raw_dh_params, leftover =
if Ciphersuite.ecdhe session.ciphersuite then
let* g, share, raw, left =
map_reader_error (Reader.parse_ec_parameters kex)
in
Ok (`Ec g, share, raw, left)
else
let unpack_dh dh_params =
Result.map_error
(function `Msg m -> `Fatal (`Decode m))
(Crypto.dh_params_unpack dh_params)
in
let* dh_params, raw_dh_params, leftover =
map_reader_error (Reader.parse_dh_parameters kex)
in
let* group, shared = unpack_dh dh_params in
let* () =
guard (Mirage_crypto_pk.Dh.modulus_size group >= Config.min_dh_size)
(`Fatal (`Handshake (`BadDH "too small")))
in
Ok (`Finite_field group, shared, raw_dh_params, leftover)
in
let sigdata =
String.concat "" [
session.common_session_data.client_random ;
session.common_session_data.server_random ;
raw_dh_params
]
in
let* () =
verify_digitally_signed state.protocol_version
state.config.signature_algorithms leftover sigdata
session.common_session_data.peer_certificate
in
let* pms, kex =
let open Mirage_crypto_ec in
let map_ecdh_error =
Result.map_error (fun e -> `Fatal (`Handshake (`BadECDH e)))
in
match group with
| `Finite_field g ->
let secret, client_share = Mirage_crypto_pk.Dh.gen_key g in
let* pms =
Option.to_result
~none:(`Fatal (`Handshake (`BadDH "invalid FF")))
(Mirage_crypto_pk.Dh.shared secret shared)
in
Ok (pms, Writer.assemble_client_dh_key_exchange client_share)
| `Ec `P256 ->
let secret, client_share = P256.Dh.gen_key () in
let* pms = map_ecdh_error (P256.Dh.key_exchange secret shared) in
Ok (pms, Writer.assemble_client_ec_key_exchange client_share)
| `Ec `P384 ->
let secret, client_share = P384.Dh.gen_key () in
let* pms = map_ecdh_error (P384.Dh.key_exchange secret shared) in
Ok (pms, Writer.assemble_client_ec_key_exchange client_share)
| `Ec `P521 ->
let secret, client_share = P521.Dh.gen_key () in
let* pms = map_ecdh_error (P521.Dh.key_exchange secret shared) in
Ok (pms, Writer.assemble_client_ec_key_exchange client_share)
| `Ec `X25519 ->
let secret, client_share = X25519.gen_key () in
let* pms = map_ecdh_error (X25519.key_exchange secret shared) in
Ok (pms, Writer.assemble_client_ec_key_exchange client_share)
in
let machina =
AwaitCertificateRequestOrServerHelloDone
(session, kex, pms, log @ [raw])
in
Ok ({ state with machina = Client machina }, [])
let answer_certificate_request state (session : session_data) cr kex pms raw log =
let cfg = state.config in
let* _types, sigalgs, _cas =
match state_version state with
| `TLS_1_0 | `TLS_1_1 ->
let* types, cas =
map_reader_error (Reader.parse_certificate_request cr)
in
Ok (types, None, cas)
| `TLS_1_2 ->
let* types, sigalgs, cas =
map_reader_error (Reader.parse_certificate_request_1_2 cr)
in
Ok (types, Some sigalgs, cas)
in
(* TODO: respect _types and _cas, multiple client certificates *)
let own_certificate, own_private_key =
match cfg.own_certificates with
| `Single (chain, priv) -> (chain, Some priv)
| _ -> ([], None)
in
let session =
let common_session_data = {
session.common_session_data with
own_certificate ;
own_private_key ;
client_auth = true
} in
{ session with common_session_data }
in
let machina = AwaitServerHelloDone (session, sigalgs, kex, pms, log @ [raw]) in
Ok ({ state with machina = Client machina }, [])
let answer_server_hello_done state (session : session_data) sigalgs kex premaster raw log =
let kex = ClientKeyExchange kex in
let ckex = Writer.assemble_handshake kex in
let* msgs, raw_msgs, raws, cert_verify =
match session.common_session_data.client_auth, session.common_session_data.own_private_key with
| true, Some p ->
let cs = List.map X509.Certificate.encode_der session.common_session_data.own_certificate in
let cert = Certificate (Writer.assemble_certificates cs) in
let ccert = Writer.assemble_handshake cert in
let to_sign = log @ [ raw ; ccert ; ckex ] in
let data = String.concat "" to_sign in
let ver = state.protocol_version
and my_sigalgs = state.config.signature_algorithms in
let* signature = signature ver data sigalgs my_sigalgs p in
let cert_verify = CertificateVerify signature in
let ccert_verify = Writer.assemble_handshake cert_verify in
Ok ([ cert ; kex ; cert_verify ],
[ ccert ; ckex ; ccert_verify ],
to_sign, Some ccert_verify)
| true, None ->
let cert = Certificate (Writer.assemble_certificates []) in
let ccert = Writer.assemble_handshake cert in
Ok ([cert ; kex], [ccert ; ckex], log @ [ raw ; ccert ; ckex ], None)
| false, _ ->
Ok ([kex], [ckex], log @ [ raw ; ckex ], None)
in
let to_fin = raws @ Option.to_list cert_verify in
let master_secret =
Handshake_crypto.derive_master_secret (state_version state) session premaster raws
in
let session =
let common_session_data = { session.common_session_data with master_secret } in
{ session with common_session_data }
in
let client_ctx, server_ctx =
Handshake_crypto.initialise_crypto_ctx (state_version state) session
in
let checksum = Handshake_crypto.finished (state_version state) session.ciphersuite master_secret "client finished" to_fin in
let fin = Finished checksum in
let raw_fin = Writer.assemble_handshake fin in
let session = { session with tls_unique = checksum } in
let ps = to_fin @ [raw_fin] in
let session =
let common_session_data = { session.common_session_data with master_secret } in
{ session with common_session_data }
in
let machina = AwaitServerChangeCipherSpec (session, server_ctx, checksum, ps)
and ccst, ccs = change_cipher_spec in
List.iter (Tracing.hs ~tag:"handshake-out") msgs;
Tracing.cs ~tag:"change-cipher-spec-out" ccs ;
Tracing.cs ~tag:"master-secret" master_secret;
Tracing.hs ~tag:"handshake-out" fin;
Ok ({ state with machina = Client machina },
List.map (fun x -> `Record (Packet.HANDSHAKE, x)) raw_msgs @
[ `Record (ccst, ccs);
`Change_enc client_ctx;
`Record (Packet.HANDSHAKE, raw_fin)])
let answer_server_finished state (session : session_data) client_verify fin log =
let computed =
Handshake_crypto.finished (state_version state) session.ciphersuite session.common_session_data.master_secret "server finished" log
in
let* () =
guard (String.equal computed fin)
(`Fatal (`Handshake (`Message "couldn't verify finished")))
in
let* () =
guard (String.length state.hs_fragment = 0) (`Fatal (`Handshake `Fragments))
in
let machina = Established
and session = { session with renegotiation = (client_verify, computed) } in
Ok ({ state with machina = Client machina ; session = `TLS session :: state.session }, [])
let answer_server_finished_resume state (session : session_data) fin raw log =
let client, server =
let checksum = Handshake_crypto.finished (state_version state) session.ciphersuite session.common_session_data.master_secret in
(checksum "client finished" (log @ [raw]), checksum "server finished" log)
in
let* () =
guard (String.equal server fin)
(`Fatal (`Handshake (`Message "couldn't verify finished")))
in
let session = { session with tls_unique = server } in
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let machina = Established
and session = { session with renegotiation = (client, server) }
in
let finished = Finished client in
let raw_finished = Writer.assemble_handshake finished in
Tracing.hs ~tag:"handshake-out" finished ;
Ok ({ state with machina = Client machina ; session = `TLS session :: state.session },
[`Record (Packet.HANDSHAKE, raw_finished)])
let answer_hello_request state =
let produce_client_hello session config exts =
let dch, _, _ = default_client_hello config in
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.hs ~tag:"handshake-out" (ClientHello ch) ;
({ state with machina = Client machina }, [`Record (Packet.HANDSHAKE, raw)])
in
match state.config.use_reneg, state.session with
| true , `TLS x :: _ ->
let ext = `SecureRenegotiation (fst x.renegotiation) in
Ok (produce_client_hello x state.config [ext])
| true , _ -> Error (`Fatal (`Handshake (`Message "couldn't find session")))
| false, _ ->
let no_reneg = Writer.assemble_alert ~level:Packet.WARNING Packet.NO_RENEGOTIATION in
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 =
let* () = map_reader_error (Reader.parse_change_cipher_spec packet) in
match cs with
| AwaitServerChangeCipherSpec (session, server_ctx, client_verify, log) ->
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let machina = AwaitServerFinished (session, client_verify, log) in
Tracing.cs ~tag:"change-cipher-spec-in" packet ;
Ok ({ state with machina = Client machina }, [`Change_dec server_ctx])
| AwaitServerChangeCipherSpecResume (session, client_ctx, server_ctx, log) ->
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let ccs = change_cipher_spec in
let machina = AwaitServerFinishedResume (session, log) in
Tracing.cs ~tag:"change-cipher-spec-in" packet ;
Tracing.cs ~tag:"change-cipher-spec-out" packet ;
Ok ({ state with machina = Client machina },
[`Record ccs ; `Change_enc client_ctx; `Change_dec server_ctx])
| _ -> Error (`Fatal (`Unexpected (`Message "change cipher spec")))
let handle_handshake cs hs buf =
let* handshake = map_reader_error (Reader.parse_handshake buf) in
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
| AwaitServerHello (ch, secrets, log), HelloRetryRequest hrr ->
Handshake_client13.answer_hello_retry_request hs ch hrr secrets buf (String.concat "" log)
| AwaitServerHelloRenegotiate (session, ch, log), ServerHello sh ->
answer_server_hello_renegotiate hs session ch sh buf log
| AwaitCertificate_RSA (session, log), Certificate cs ->
let* cs = map_reader_error (Reader.parse_certificates cs) in
answer_certificate_RSA hs session cs buf log
| AwaitCertificate_DHE (session, log), Certificate cs ->
let* cs = map_reader_error (Reader.parse_certificates cs) in
answer_certificate_DHE hs session cs buf log
| AwaitServerKeyExchange_DHE (session, log), ServerKeyExchange kex ->
answer_server_key_exchange_DHE hs session kex buf log
| AwaitCertificateRequestOrServerHelloDone (session, kex, pms, log), CertificateRequest cr ->
answer_certificate_request hs session cr kex pms buf log
| AwaitCertificateRequestOrServerHelloDone (session, kex, pms, log), ServerHelloDone ->
answer_server_hello_done hs session None kex pms buf log
| AwaitServerHelloDone (session, sigalgs, kex, pms, log), ServerHelloDone ->
answer_server_hello_done hs session sigalgs kex pms buf log
| AwaitServerFinished (session, client_verify, log), Finished fin ->
answer_server_finished hs session client_verify fin log
| AwaitServerFinishedResume (session, log), Finished fin ->
answer_server_finished_resume hs session fin buf log
| Established, HelloRequest ->
answer_hello_request hs
| _, hs -> Error (`Fatal (`Unexpected (`Handshake hs)))

7
unikernel/duniverse/ocaml-tls/lib/handshake_client.mli Normal file
View file

@ -0,0 +1,7 @@
open Core
open State
val default_client_hello : Config.config -> (client_hello * tls_version * (group * dh_secret) list)
val handle_change_cipher_spec : client_handshake_state -> handshake_state -> string -> (handshake_return, failure) result
val handle_handshake : client_handshake_state -> handshake_state -> string -> (handshake_return, failure) result
val answer_hello_request : handshake_state -> (handshake_return, failure) result

307
unikernel/duniverse/ocaml-tls/lib/handshake_client13.ml Normal file
View file

@ -0,0 +1,307 @@
open State
open Core
open Handshake_common
open Config
let answer_server_hello state ch (sh : server_hello) secrets raw log =
(* assume SH valid, version 1.3, extensions are subset *)
match Ciphersuite.ciphersuite_to_ciphersuite13 sh.ciphersuite with
| None -> Error (`Fatal (`Handshake (`Message "not a TLS 1.3 ciphersuite")))
| Some cipher ->
let* () =
guard (List.mem cipher (ciphers13 state.config))
(`Fatal (`Handshake (`Message "not a configured ciphersuite")))
in
let* () = guard (String.length state.hs_fragment = 0) (`Fatal (`Handshake `Fragments)) in
(* TODO: PSK *)
(* TODO: early_secret elsewhere *)
match Utils.map_find ~f:(function `KeyShare ks -> Some ks | _ -> None) sh.extensions with
| None -> Error (`Fatal (`Handshake (`Message "missing key share extension")))
| Some (g, share) ->
match List.find_opt (fun (g', _) -> g = g') secrets with
| None -> Error (`Fatal (`Handshake (`Message "couldn't find our secret for the key share")))
| Some (_, secret) ->
let* shared = Handshake_crypto13.dh_shared secret share in
let hlen =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
H.digest_size
in
let* psk, resumed =
match
Utils.map_find ~f:(function `PreSharedKey idx -> Some idx | _ -> None) sh.extensions,
state.config.Config.cached_ticket
with
| None, _ | _, None -> Ok (String.make hlen '\x00', false)
| Some idx, Some (psk, _epoch) ->
let* () = guard (idx = 0) (`Fatal (`Handshake (`Message "resumed pre-shared idx not 0"))) in
Ok (psk.secret, true)
in
let early_secret = Handshake_crypto13.(derive (empty cipher) psk) in
let hs_secret = Handshake_crypto13.derive early_secret shared in
let log = log ^ raw in
let server_hs_secret, server_ctx, client_hs_secret, client_ctx =
Handshake_crypto13.hs_ctx hs_secret log in
let master_secret =
Handshake_crypto13.derive hs_secret (String.make hlen '\x00')
in
let session =
let base = empty_session13 cipher in
let common_session_data13 =
{ base.common_session_data13 with
server_random = sh.server_random ;
client_random = ch.client_random ;
master_secret = master_secret.secret }
in
{ base with master_secret ; common_session_data13 ; resumed }
in
let st = AwaitServerEncryptedExtensions13 (session, server_hs_secret, client_hs_secret, log) in
Ok ({ state with machina = Client13 st ; protocol_version = `TLS_1_3 },
[ `Change_enc client_ctx ; `Change_dec server_ctx ])
(* called from handshake_client.ml *)
let answer_hello_retry_request state (ch : client_hello) hrr _secrets raw log =
(* when is a HRR invalid / what do we need to check?
-> we advertised the group and cipher
-> TODO we did advertise such a keyshare already (does it matter?)
*)
let* () =
guard (`TLS_1_3 = hrr.retry_version)
(`Fatal (`Handshake (`Message "hello retry request with a version <> 1.3")))
in
let* () =
guard (List.mem hrr.selected_group state.config.groups)
(`Fatal (`Handshake (`Message "hello retry request with group we didn't advertise")))
in
let* () =
guard (List.mem hrr.ciphersuite (ciphers13 state.config))
(`Fatal (`Handshake (`Message "hello retet request with ciphersuite we didn't advertise"))) in
(* generate a fresh keyshare *)
let secret, keyshare =
let g = hrr.selected_group in
let priv, share = Handshake_crypto13.dh_gen_key g in
(g, priv), (group_to_named_group g, share)
in
(* append server extensions (i.e. cookie!) *)
let cookie = match Utils.map_find ~f:(function `Cookie c -> Some c | _ -> None) hrr.extensions with
| None -> []
| Some c -> [ `Cookie c ]
in
(* use the same extensions as in original CH, apart from PSK!? and early_data *)
let other_exts = List.filter (function `KeyShare _ -> false | _ -> true) ch.extensions in
let new_ch = { ch with extensions = `KeyShare [keyshare] :: other_exts @ cookie} in
let new_ch_raw = Writer.assemble_handshake (ClientHello new_ch) in
let ch0_data =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 hrr.ciphersuite)) in
H.(to_raw_string (digest_string log))
in
let ch0_hdr = Writer.assemble_message_hash (String.length ch0_data) in
let st = AwaitServerHello13 (new_ch, [secret], String.concat "" [ ch0_hdr ; ch0_data ; raw ; new_ch_raw ]) in
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 =
(* TODO we now know: - hostname - early_data (preserve this in session!!) *)
(* next message is either CertificateRequest or Certificate (or finished if PSK) *)
let alpn_protocol = Utils.map_find ~f:(function `ALPN proto -> Some proto | _ -> None) ee in
let session =
let common_session_data13 = { session.common_session_data13 with alpn_protocol } in
{ session with common_session_data13 }
in
let st =
if session.resumed then
AwaitServerFinished13 (session, server_hs_secret, client_hs_secret, None, log ^ raw)
else
AwaitServerCertificateRequestOrCertificate13 (session, server_hs_secret, client_hs_secret, log ^ raw)
in
Ok ({ state with machina = Client13 st }, [])
let answer_certificate state (session : session_data13) server_hs_secret client_hs_secret sigalgs certs raw log =
(* certificates are (cs, ext) list - ext being statusrequest or signed_cert_timestamp *)
let certs = List.map fst certs in
let* peer_certificate, received_certificates, peer_certificate_chain, trust_anchor =
validate_chain state.config.authenticator certs state.config.ip state.config.peer_name
in
let session =
let common_session_data13 = {
session.common_session_data13 with
received_certificates ; peer_certificate_chain ; peer_certificate ; trust_anchor
} in
{ session with common_session_data13 }
in
let st = AwaitServerCertificateVerify13 (session, server_hs_secret, client_hs_secret, sigalgs, log ^ raw) in
Ok ({ state with machina = Client13 st }, [])
let answer_certificate_verify (state : handshake_state) (session : session_data13) server_hs_secret client_hs_secret sigalgs cv raw log =
let tbs =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 session.ciphersuite13)) in
H.(to_raw_string (digest_string log))
in
let* () =
verify_digitally_signed state.protocol_version
~context_string:"TLS 1.3, server CertificateVerify"
state.config.signature_algorithms cv tbs
session.common_session_data13.peer_certificate
in
let st = AwaitServerFinished13 (session, server_hs_secret, client_hs_secret, sigalgs, log ^ raw) in
Ok ({ state with machina = Client13 st }, [])
let answer_certificate_request (state : handshake_state) (session : session_data13) server_hs_secret client_hs_secret extensions raw log =
(* TODO respect extensions (CA, OIDfilter)! *)
let session =
let common_session_data13 = { session.common_session_data13 with client_auth = true } in
{ session with common_session_data13 }
in
let sigalgs = Utils.map_find ~f:(function `SignatureAlgorithms s -> Some s | _ -> None) extensions in
let st = AwaitServerCertificate13 (session, server_hs_secret, client_hs_secret, sigalgs, log ^ raw) in
Ok ({ state with machina = Client13 st }, [])
let answer_finished state (session : session_data13) server_hs_secret client_hs_secret sigalgs fin raw log =
let hash = Ciphersuite.hash13 session.ciphersuite13 in
let f_data = Handshake_crypto13.finished hash server_hs_secret log in
let* () = guard (String.equal fin f_data) (`Fatal (`Handshake (`Message "couldn't verify finished"))) in
let* () = guard (String.length state.hs_fragment = 0) (`Fatal (`Handshake `Fragments)) in
let log = log ^ raw in
let server_app_secret, server_app_ctx, client_app_secret, client_app_ctx =
Handshake_crypto13.app_ctx session.master_secret log
in
let exporter_master_secret = Handshake_crypto13.exporter session.master_secret log in
let* c_cv, log =
if session.common_session_data13.client_auth then
let own_certificate, own_private_key =
match state.config.Config.own_certificates with
| `Single (chain, priv) -> (chain, Some priv)
| _ -> ([], None)
in
let certificate =
let cs = List.map X509.Certificate.encode_der own_certificate in
Certificate (Writer.assemble_certificates_1_3 "" 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 ->
Ok ([cert_raw], log)
| Some priv ->
let tbs =
let module H = (val Digestif.module_of_hash' hash) in
H.(to_raw_string (digest_string log))
in
let* signed =
signature `TLS_1_3 ~context_string:"TLS 1.3, client CertificateVerify"
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
Ok ([], log)
in
let myfin = Handshake_crypto13.finished hash client_hs_secret log in
let mfin = Writer.assemble_handshake (Finished myfin) in
let resumption_secret = Handshake_crypto13.resumption session.master_secret (log ^ mfin) in
let session = { session with resumption_secret ; exporter_master_secret ; client_app_secret ; server_app_secret } in
let machina = Client13 Established13 in
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 @
[ `Record (Packet.HANDSHAKE, mfin) ;
`Change_dec server_app_ctx ; `Change_enc client_app_ctx ])
let answer_session_ticket state st =
(match state.config.ticket_cache with
| None -> ()
| Some cache ->
(* looks like we'll need the resumption secret in the state (we can compute once finished is done)! *)
match state.session with
| `TLS13 session :: _ ->
let epoch = epoch_of_session false state.config.Config.peer_name `TLS_1_3 (`TLS13 session) in
let secret = Handshake_crypto13.res_secret
(Ciphersuite.hash13 session.ciphersuite13)
session.resumption_secret st.nonce
in
let issued_at = cache.timestamp () in
let early_data = match Utils.map_find ~f:(function `EarlyDataIndication x -> Some x | _ -> None) st.extensions with
| None -> 0l
| Some x -> x
in
let psk = { identifier = st.ticket ; obfuscation = st.age_add ; secret ; lifetime = st.lifetime ; early_data ; issued_at } in
cache.ticket_granted psk epoch
| _ -> ());
Ok (state, [])
let handle_key_update state req =
match state.session with
| `TLS13 session :: _ ->
let* () = guard (String.length state.hs_fragment = 0) (`Fatal (`Handshake `Fragments)) in
let server_app_secret, server_ctx =
Handshake_crypto13.app_secret_n_1 session.master_secret session.server_app_secret
in
let session' = { session with server_app_secret } in
let session', out = match req with
| Packet.UPDATE_NOT_REQUESTED -> session', []
| Packet.UPDATE_REQUESTED ->
let client_app_secret, client_ctx =
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 ]
in
let session = `TLS13 session' :: state.session in
let state' = { state with machina = Server13 Established13 ; session } in
Ok (state', `Change_dec server_ctx :: out)
| _ -> Error (`Fatal (`Handshake (`Message "couldn't find an earlier session")))
let handle_handshake cs hs buf =
let open Reader in
let* handshake = map_reader_error (parse_handshake buf) in
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
| AwaitServerEncryptedExtensions13 (sd, es, ss, log), EncryptedExtensions ee ->
answer_encrypted_extensions hs sd es ss ee buf log
| AwaitServerCertificateRequestOrCertificate13 (sd, es, ss, log), CertificateRequest cr ->
let* ctx, exts = map_reader_error (parse_certificate_request_1_3 cr) in
(* during handshake, context must be empty! *)
let* () =
guard (ctx = None)
(`Fatal (`Handshake (`Message "certificate request context must be empty")))
in
answer_certificate_request hs sd es ss exts buf log
| AwaitServerCertificateRequestOrCertificate13 (sd, es, ss, log), Certificate cs ->
let* con, cs = map_reader_error (parse_certificates_1_3 cs) in
(* during handshake, context must be empty! and we'll not get any new certificate from server *)
let* () =
guard (String.length con = 0)
(`Fatal (`Handshake (`Message "certificate context must be empty")))
in
answer_certificate hs sd es ss None cs buf log
| AwaitServerCertificate13 (sd, es, ss, sigalgs, log), Certificate cs ->
let* con, cs = map_reader_error (parse_certificates_1_3 cs) in
(* during handshake, context must be empty! and we'll not get any new certificate from server *)
let* () =
guard (String.length con = 0)
(`Fatal (`Handshake (`Message "certificate context must be empty")))
in
answer_certificate hs sd es ss sigalgs cs buf log
| AwaitServerCertificateVerify13 (sd, es, ss, sigalgs, log), CertificateVerify cv ->
answer_certificate_verify hs sd es ss sigalgs cv buf log
| AwaitServerFinished13 (sd, es, ss, sigalgs, log), Finished fin ->
answer_finished hs sd es ss sigalgs fin buf log
| Established13, SessionTicket se -> answer_session_ticket hs se
| Established13, CertificateRequest _ ->
Error (`Fatal (`Unexpected (`Handshake handshake))) (* TODO send out C, CV, F *)
| Established13, KeyUpdate req -> handle_key_update hs req
| _, hs -> Error (`Fatal (`Unexpected (`Handshake hs)))

550
unikernel/duniverse/ocaml-tls/lib/handshake_common.ml Normal file
View file

@ -0,0 +1,550 @@
open Core
open State
let src = Logs.Src.create "handshake" ~doc:"TLS handshake"
module Log = (val Logs.src_log src : Logs.LOG)
let trace_cipher cipher =
Tracing.debug (fun m -> m "%a" Ciphersuite.pp_ciphersuite cipher)
let empty = function [] -> true | _ -> false
let change_cipher_spec =
(Packet.CHANGE_CIPHER_SPEC, Writer.assemble_change_cipher_spec)
let hostname (h : client_hello) : [ `host ] Domain_name.t option =
Utils.map_find ~f:(function `Hostname s -> Some s | _ -> None) h.extensions
let groups (h : client_hello) =
match Utils.map_find ~f:(function `SupportedGroups g -> Some g | _ -> None) h.extensions with
| Some xs ->
List.fold_left (fun acc g ->
match named_group_to_group g with Some g -> g :: acc | _ -> acc)
[] xs
| None -> []
let rec find_matching host certs =
match certs with
| (s::_, _) as chain ::xs ->
if X509.Certificate.supports_hostname s host then
Some chain
else
find_matching host xs
| _::xs -> find_matching host xs (* this should never happen! *)
| [] -> None
let agreed_cert certs ?f ?signature_algorithms hostname =
let match_host ?default host certs =
match find_matching host certs with
| Some x -> Ok x
| None ->
Option.to_result
~none:(`Error (`NoMatchingCertificateFound (Domain_name.to_string host)))
default
in
let filter = function
| ([], _) -> false (* cannot happen, TODO: adapt types to avoid this case *)
| (s :: _, _) ->
match f with
| None -> true
| Some f -> f s
in
let filter_sigalg c =
match signature_algorithms with
| None -> true
| Some s -> List.exists (pk_matches_sa (snd c)) s
in
match certs, hostname with
| `None, _ -> Error (`Error `CouldntSelectCertificate)
| `Single c, _ ->
if filter c && filter_sigalg c then Ok c else Error (`Error `CouldntSelectCertificate)
| `Multiple_default (c, _), None ->
if filter c && filter_sigalg c then Ok c else Error (`Error `CouldntSelectCertificate)
| `Multiple_default (c, cs), Some h ->
let default = if filter c && filter_sigalg c then Some c else None in
begin match default, List.filter (fun c -> filter c && filter_sigalg c) cs with
| Some d, cs -> match_host ~default:d h cs
| None, c :: cs -> match_host ~default:c h (c::cs)
| None, [] -> Error (`Error `CouldntSelectCertificate)
end
| `Multiple cs, None ->
begin match List.filter (fun c -> filter c && filter_sigalg c) cs with
| cert :: _ -> Ok cert
| _ -> Error (`Error `CouldntSelectCertificate)
end
| `Multiple cs, Some h ->
match List.filter (fun c -> filter c && filter_sigalg c) cs with
| [ cert ] -> Ok cert
| c :: cs -> match_host ~default:c h (c :: cs)
| [] -> Error (`Error `CouldntSelectCertificate)
let get_secure_renegotiation exts =
Utils.map_find
exts
~f:(function `SecureRenegotiation data -> Some data | _ -> None)
let get_alpn_protocols (ch : client_hello) =
Utils.map_find ~f:(function `ALPN protocols -> Some protocols | _ -> None) ch.extensions
let alpn_protocol config ch =
match config.Config.alpn_protocols, get_alpn_protocols ch with
| _, None | [], _ -> Ok None
| configured, Some client -> match Utils.first_match client configured with
| Some proto -> Ok (Some proto)
| None ->
(* RFC7301 Section 3.2:
In the event that the server supports no protocols that the client
advertises, then the server SHALL respond with a fatal
"no_application_protocol" alert. *)
Error (`Fatal `No_application_protocol)
let get_alpn_protocol (sh : server_hello) =
Utils.map_find ~f:(function `ALPN protocol -> Some protocol | _ -> None) sh.extensions
let empty_common_session_data = {
server_random = "" ;
client_random = "" ;
peer_certificate_chain = [] ;
peer_certificate = None ;
trust_anchor = None ;
received_certificates = [] ;
own_certificate = [] ;
own_private_key = None ;
own_name = None ;
client_auth = false ;
master_secret = "" ;
alpn_protocol = None ;
}
let empty_session = {
common_session_data = empty_common_session_data ;
client_version = `TLS_1_2 ;
ciphersuite = `DHE_RSA_WITH_AES_256_CBC_SHA ;
group = Some `FFDHE2048 ;
renegotiation = "", "" ;
session_id = "" ;
extended_ms = false ;
tls_unique = "" ;
}
let empty_session13 cipher = {
common_session_data13 = empty_common_session_data ;
ciphersuite13 = cipher ;
master_secret = Handshake_crypto13.empty cipher ;
exporter_master_secret = "" ;
resumption_secret = "" ;
state = `Established ;
resumed = false ;
client_app_secret = "" ;
server_app_secret = "" ;
}
let common_session_data_of_epoch (epoch : epoch_data) common_session_data =
{
common_session_data with
peer_certificate = epoch.peer_certificate ;
trust_anchor = epoch.trust_anchor ;
own_certificate = epoch.own_certificate ;
own_private_key = epoch.own_private_key ;
received_certificates = epoch.received_certificates ;
peer_certificate_chain = epoch.peer_certificate_chain ;
master_secret = epoch.master_secret ;
own_name = epoch.own_name ;
alpn_protocol = epoch.alpn_protocol ;
}
let session_of_epoch (epoch : epoch_data) : session_data =
let empty = empty_session in
let common_session_data = common_session_data_of_epoch epoch empty.common_session_data in
{ empty with
common_session_data ;
ciphersuite = epoch.ciphersuite ;
session_id = epoch.session_id ;
extended_ms = epoch.extended_ms ;
}
let session13_of_epoch cipher (epoch : epoch_data) : session_data13 =
let empty = empty_session13 cipher in
let common_session_data13 = common_session_data_of_epoch epoch empty.common_session_data13 in
{ empty with
common_session_data13 ;
ciphersuite13 = cipher ;
state = epoch.state ;
exporter_master_secret = epoch.exporter_master_secret ;
}
let supported_protocol_version (min, max) v =
if compare_tls_version min v > 0 then
None
else if compare_tls_version v max > 0 then
None
else
Some v
let to_client_ext_type = function
| `Hostname _ -> `Hostname
| `MaxFragmentLength _ -> `MaxFragmentLength
| `SupportedGroups _ -> `SupportedGroups
| `ECPointFormats -> `ECPointFormats
| `SecureRenegotiation _ -> `SecureRenegotiation
| `Padding _ -> `Padding
| `SignatureAlgorithms _ -> `SignatureAlgorithms
| `UnknownExtension _ -> `UnknownExtension
| `ExtendedMasterSecret -> `ExtendedMasterSecret
| `ALPN _ -> `ALPN
| `KeyShare _ -> `KeyShare
| `EarlyDataIndication -> `EarlyDataIndication
| `PreSharedKeys _ -> `PreSharedKey
| `Draft _ -> `Draft
| `SupportedVersions _ -> `SupportedVersion
| `PostHandshakeAuthentication -> `PostHandshakeAuthentication
| `Cookie _ -> `Cookie
| `PskKeyExchangeModes _ -> `PskKeyExchangeMode
let to_server_ext_type = function
| `Hostname -> `Hostname
| `MaxFragmentLength _ -> `MaxFragmentLength
| `ECPointFormats -> `ECPointFormats
| `SecureRenegotiation _ -> `SecureRenegotiation
| `UnknownExtension _ -> `UnknownExtension
| `ExtendedMasterSecret -> `ExtendedMasterSecret
| `ALPN _ -> `ALPN
| `KeyShare _ -> `KeyShare
| `EarlyDataIndication -> `EarlyDataIndication
| `PreSharedKey _ -> `PreSharedKey
| `Draft _ -> `Draft
| `SelectedVersion _ -> `SupportedVersion
let extension_types t exts = List.(
exts |> map t
|> filter @@ function `UnknownExtension -> false | _ -> true
)
(* a server hello may only contain extensions which are also in the client hello *)
(* RFC5246, 7.4.7.1
An extension type MUST NOT appear in the ServerHello unless the same
extension type appeared in the corresponding ClientHello. If a
client receives an extension type in ServerHello that it did not
request in the associated ClientHello, it MUST abort the handshake
with an unsupported_extension fatal alert. *)
let server_exts_subset_of_client sexts cexts =
let (sexts', cexts') =
(extension_types to_server_ext_type sexts, extension_types to_client_ext_type cexts) in
Utils.List_set.subset sexts' (`Cookie :: cexts')
module Group = struct
type t = Packet.named_group
let compare = Stdlib.compare
end
module GroupSet = Set.Make(Group)
(* Set.of_list appeared only in 4.02, for 4.01 compatibility *)
let of_list xs = List.fold_right GroupSet.add xs GroupSet.empty
let client_hello_valid version (ch : client_hello) =
(* match ch.version with
| TLS_1_0 ->
if List.mem TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA ch.ciphersuites then
return ()
else
fail HANDSHAKE_FAILURE
| TLS_1_1 ->
if List.mem TLS_RSA_WITH_3DES_EDE_CBC_SHA ch.ciphersuites then
return ()
else
fail HANDSHAKE_FAILURE
| TLS_1_2 ->
if List.mem TLS_RSA_WITH_AES_128_CBC_SHA ch.ciphersuites then
return ()
else
fail HANDSHAKE_FAILURE *)
let sig_alg =
Utils.map_find
~f:(function `SignatureAlgorithms sa -> Some sa | _ -> None)
ch.extensions
and key_share =
Utils.map_find
~f:(function `KeyShare ks -> Some ks | _ -> None)
ch.extensions
and groups =
Utils.map_find
~f:(function `SupportedGroups gs -> Some gs | _ -> None)
ch.extensions
in
let version_good = match version with
| `TLS_1_2 | `TLS_1_X _ -> Ok ()
| `TLS_1_3 ->
( let good_sig_alg =
List.exists (fun sa -> List.mem sa Config.supported_signature_algorithms)
in
match sig_alg with
| None -> Error (`Fatal (`Missing_extension "signature algorithms"))
| Some sig_alg when good_sig_alg sig_alg ->
( match key_share, groups with
| None, _ -> Error (`Fatal (`Missing_extension "key share"))
| _, None -> Error (`Fatal (`Missing_extension "supported group"))
| Some ks, Some gs ->
match
Utils.List_set.is_proper_set gs,
Utils.List_set.is_proper_set (List.map fst ks),
GroupSet.subset (of_list (List.map fst ks)) (of_list gs)
with
| true, true, true -> Ok ()
| false, _, _ -> Error (`Fatal (`Handshake (`Message "supported group is not a set")))
| _, false, _ -> Error (`Fatal (`Handshake (`Message "key share is not a set")))
| _, _, false -> Error (`Fatal (`Handshake (`Message "key share is not a subset of supported group")) ))
| Some _ -> Error (`Fatal (`Handshake (`Message "no good signature algorithms")))
)
| `SSL_3 | `TLS_1_0 | `TLS_1_1 -> Ok ()
in
let share_ciphers =
match
Utils.first_match (List.filter_map Ciphersuite.any_ciphersuite_to_ciphersuite ch.ciphersuites) Config.Ciphers.supported
with
| None -> false
| Some _ -> true
in
match
not (empty ch.ciphersuites),
share_ciphers,
Utils.List_set.is_proper_set (extension_types to_client_ext_type ch.extensions)
with
| true, true, true -> version_good
| false, _, _ -> Error (`Fatal (`Handshake (`Message "ciphersuites is empty")))
| _, false, _ -> Error (`Fatal (`Handshake (`Message "no supported ciphersuite")))
| _, _, false -> Error (`Fatal (`Handshake (`Message "extensions is not a set")))
let server_hello_valid (sh : server_hello) =
(* let open Ciphersuite in *)
Utils.List_set.is_proper_set (extension_types to_server_ext_type sh.extensions)
(* TODO:
- EC stuff must be present if EC ciphersuite chosen
*)
let to_sign_1_3 context_string =
(* input is prepended by 64 * 0x20 (to avoid cross-version attacks) *)
(* input for signature now contains also a context string *)
let len = match context_string with
| None -> 64 + 1
| Some v -> 64 + String.length v + 1 in
let buf = Bytes.create len in
Bytes.fill buf 0 64 '\x20';
begin match context_string with
| None -> ()
| Some v -> Bytes.blit_string v 0 buf 64 (String.length v) end;
Bytes.set buf (Bytes.length buf - 1) '\x00';
Bytes.unsafe_to_string buf
let signature version ?context_string data client_sig_algs signature_algorithms (private_key : X509.Private_key.t) =
match version with
| `TLS_1_0 | `TLS_1_1 ->
let* signed =
match private_key with
| `RSA key ->
begin try
let data =
Digestif.(MD5.(to_raw_string (digest_string data)) ^
SHA1.(to_raw_string (digest_string data)))
in
Ok (Mirage_crypto_pk.Rsa.PKCS1.sig_encode ~key data)
with Mirage_crypto_pk.Rsa.Insufficient_key ->
Error (`Fatal (`Bad_certificate "RSA key too small"))
end
| k ->
(* not passing ~scheme: only non-RSA keys sig scheme is trivial *)
Result.map_error
(function `Msg m -> `Fatal (`Handshake (`Message ("signing failed: " ^ m))))
(X509.Private_key.sign `SHA1 k (`Message data))
in
Ok (Writer.assemble_digitally_signed signed)
| `TLS_1_2 ->
let* sig_alg =
match client_sig_algs with
| None ->
Ok (match private_key with
| `RSA _ -> `RSA_PKCS1_SHA1
| `ED25519 _ -> `ED25519
| _ -> `ECDSA_SECP256R1_SHA1)
| Some client_algos ->
Option.to_result
~none:(`Error (`NoConfiguredSignatureAlgorithm client_algos))
(Utils.first_match client_algos (List.filter (pk_matches_sa private_key) signature_algorithms))
in
let scheme = signature_scheme_of_signature_algorithm sig_alg
and hash = hash_of_signature_algorithm sig_alg
in
let* signature =
Result.map_error (function `Msg m -> `Fatal (`Handshake (`Message ("signing failed: " ^ m))))
(X509.Private_key.sign hash ~scheme private_key (`Message data))
in
Ok (Writer.assemble_digitally_signed_1_2 sig_alg signature)
| `TLS_1_3 ->
let to_sign =
let prefix = to_sign_1_3 context_string in
prefix ^ data
in
let* sig_alg =
let* client_algos =
(* 8446 4.2.3 "client MUST send signatureAlgorithms" *)
Option.to_result
~none:(`Error (`NoConfiguredSignatureAlgorithm []))
client_sig_algs
in
let sa = List.filter tls13_sigalg signature_algorithms in
let sa = List.filter (pk_matches_sa private_key) sa in
Option.to_result
~none:(`Error (`NoConfiguredSignatureAlgorithm client_algos))
(Utils.first_match client_algos sa)
in
let scheme = signature_scheme_of_signature_algorithm sig_alg
and hash = hash_of_signature_algorithm sig_alg
in
let* signature =
Result.map_error (function `Msg m -> `Fatal (`Handshake (`Message ("signing failed: " ^ m))))
(X509.Private_key.sign hash ~scheme private_key (`Message to_sign))
in
Ok (Writer.assemble_digitally_signed_1_2 sig_alg signature)
let peer_key = function
| None -> Error (`Fatal (`Bad_certificate "none received"))
| Some cert -> Ok (X509.Certificate.public_key cert)
let verify_digitally_signed version ?context_string sig_algs data signature_data certificate =
let* pubkey = peer_key certificate in
match version with
| `TLS_1_0 | `TLS_1_1 ->
let* signature = map_reader_error (Reader.parse_digitally_signed data) in
begin match pubkey with
| `RSA key ->
let* raw =
Option.to_result
~none:(`Fatal (`Handshake (`Message "couldn't decode PKCS1")))
(Mirage_crypto_pk.Rsa.PKCS1.sig_decode ~key signature)
in
let computed =
Digestif.(MD5.(to_raw_string (digest_string signature_data)) ^
SHA1.(to_raw_string (digest_string signature_data)))
in
guard (String.equal raw computed)
(`Fatal (`Handshake (`Message "RSA PKCS1 raw <> computed")))
| key ->
Result.map_error
(function `Msg m -> `Fatal (`Handshake (`Message ("signature verification failed: " ^ m))))
(X509.Public_key.verify `SHA1 ~signature key (`Message signature_data))
end
| `TLS_1_2 ->
let* sig_alg, signature =
map_reader_error (Reader.parse_digitally_signed_1_2 data)
in
let* () =
guard (List.mem sig_alg sig_algs)
(`Error (`NoConfiguredSignatureAlgorithm sig_algs))
in
let hash = hash_of_signature_algorithm sig_alg
and scheme = signature_scheme_of_signature_algorithm sig_alg
in
Result.map_error
(function `Msg m -> `Fatal (`Handshake (`Message ("signature verification failed: " ^ m))))
(X509.Public_key.verify hash ~scheme ~signature pubkey (`Message signature_data))
| `TLS_1_3 ->
let* sig_alg, signature =
map_reader_error (Reader.parse_digitally_signed_1_2 data)
in
let* () =
guard (List.mem sig_alg sig_algs)
(`Error (`NoConfiguredSignatureAlgorithm sig_algs))
in
let hash = hash_of_signature_algorithm sig_alg
and scheme = signature_scheme_of_signature_algorithm sig_alg
and data =
let prefix = to_sign_1_3 context_string in
prefix ^ signature_data
in
Result.map_error
(function `Msg m -> `Fatal (`Handshake (`Message ("signature verification failed: " ^ m))))
(X509.Public_key.verify hash ~scheme ~signature pubkey (`Message data))
let validate_chain authenticator certificates ip hostname =
let authenticate authenticator host certificates =
Result.map_error
(fun err -> `Error (`AuthenticationFailure err))
(authenticator ?ip ~host certificates)
and key_size min cs =
let check c =
match X509.Certificate.public_key c with
| `RSA key -> Mirage_crypto_pk.Rsa.pub_bits key >= min
| _ -> true
in
guard (List.for_all check cs) (`Fatal (`Bad_certificate "key too small"))
and parse_certificates certs =
let certificates =
let f cs =
match X509.Certificate.decode_der cs with
| Ok c -> Some c
| Error `Msg msg ->
Log.warn (fun m -> m "cannot decode certificate %s:@.%a" msg
(Ohex.pp_hexdump ()) cs);
None
in
List.filter_map f certs
in
let* () =
guard (List.length certs = List.length certificates)
(`Fatal (`Bad_certificate "couldn't decode some certificates"))
in
Ok certificates
in
(* RFC5246: must be x509v3, take signaturealgorithms into account! *)
(* RFC2246/4346: is generally x509v3, signing algorithm for certificate _must_ be same as algorithm for certificate key *)
let* certs = parse_certificates certificates in
let server = match certs with
| s::_ -> Some s
| [] -> None
in
match authenticator with
| None -> Ok (server, certs, [], None)
| Some authenticator ->
let* anchor = authenticate authenticator hostname certs in
let* () = key_size Config.min_rsa_key_size certs in
Ok (Option.fold ~none:(server, certs, [], None)
~some:(fun (chain, anchor) -> (server, certs, chain, Some anchor))
anchor)
let output_key_update ~request state =
let hs = state.handshake in
match hs.session with
| `TLS13 session :: _ ->
let* session', encryptor =
match hs.machina with
| Client13 Established13 ->
let client_app_secret, client_ctx =
Handshake_crypto13.app_secret_n_1
session.master_secret session.client_app_secret
in
Ok ({ session with client_app_secret }, client_ctx)
| Server13 Established13 ->
let server_app_secret, server_ctx =
Handshake_crypto13.app_secret_n_1
session.master_secret session.server_app_secret
in
Ok ({ session with server_app_secret }, server_ctx)
| _ -> Error (`Fatal (`Handshake (`Message "invalid state for key update")))
in
let handshake = { hs with session = `TLS13 session' :: hs.session } in
let ku =
let p =
Packet.(if request then UPDATE_REQUESTED else UPDATE_NOT_REQUESTED)
in
KeyUpdate p
in
let out = Writer.assemble_handshake ku in
Ok ({ state with encryptor = Some encryptor ; handshake },
(Packet.HANDSHAKE, out))
| _ -> Error (`Fatal (`Handshake (`Message "no earlier session found")))

111
unikernel/duniverse/ocaml-tls/lib/handshake_crypto.ml Normal file
View file

@ -0,0 +1,111 @@
open State
let halve secret =
let size = String.length secret in
let half = size - size / 2 in
String.(sub secret 0 half, sub secret (size - half) half)
let p_hash (hmac, hmac_n) key seed len =
let rec expand a to_go =
let res = hmac ~key (a ^ seed) in
if to_go > hmac_n then
res ^ expand (hmac ~key a) (to_go - hmac_n)
else String.sub res 0 to_go
in
expand (hmac ~key seed) len
let prf_mac = function
| `RSA_WITH_AES_256_GCM_SHA384
| `DHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_AES_256_GCM_SHA384
| `ECDHE_RSA_WITH_AES_256_CBC_SHA384
| `ECDHE_ECDSA_WITH_AES_256_CBC_SHA384
| `ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 -> (module Digestif.SHA384 : Digestif.S)
| _ -> (module Digestif.SHA256 : Digestif.S)
let pseudo_random_function version cipher len secret label seed =
let labelled = label ^ seed in
match version with
| `TLS_1_1 | `TLS_1_0 ->
let (s1, s2) = halve secret in
let md5 = p_hash ((fun ~key s -> Digestif.MD5.(to_raw_string (hmac_string ~key s))), Digestif.MD5.digest_size) s1 labelled len
and sha = p_hash ((fun ~key s -> Digestif.SHA1.(to_raw_string (hmac_string ~key s))), Digestif.SHA1.digest_size) s2 labelled len in
Mirage_crypto.Uncommon.xor md5 sha
| `TLS_1_2 ->
let module D = (val (prf_mac cipher)) in
p_hash ((fun ~key s -> D.(to_raw_string (hmac_string ~key s))), D.digest_size) secret labelled len
let key_block version cipher len master_secret seed =
pseudo_random_function version cipher len master_secret "key expansion" seed
let hash version cipher data =
match version with
| `TLS_1_0 | `TLS_1_1 -> Digestif.(MD5.(to_raw_string (digest_string data)) ^ SHA1.(to_raw_string (digest_string data)))
| `TLS_1_2 ->
let module H = (val prf_mac cipher) in
H.(to_raw_string (digest_string data))
let finished version cipher master_secret label ps =
let data = String.concat "" ps in
let seed = hash version cipher data in
pseudo_random_function version cipher 12 master_secret label seed
let divide_keyblock key mac iv buf =
let c_mac, rt0 = Core.split_str buf mac in
let s_mac, rt1 = Core.split_str rt0 mac in
let c_key, rt2 = Core.split_str rt1 key in
let s_key, rt3 = Core.split_str rt2 key in
let c_iv , s_iv = Core.split_str rt3 iv
in
(c_mac, s_mac, c_key, s_key, c_iv, s_iv)
let derive_master_secret version (session : session_data) premaster log =
let prf = pseudo_random_function version session.ciphersuite 48 premaster in
if session.extended_ms then
let session_hash =
let data = String.concat "" log in
hash version session.ciphersuite data
in
prf "extended master secret" session_hash
else
prf "master secret" (session.common_session_data.client_random ^ session.common_session_data.server_random)
let initialise_crypto_ctx version (session : session_data) =
let open Ciphersuite in
let client_random = session.common_session_data.client_random
and server_random = session.common_session_data.server_random
and master = session.common_session_data.master_secret
and cipher = session.ciphersuite
in
let pp = ciphersuite_privprot cipher in
let c_mac, s_mac, c_key, s_key, c_iv, s_iv =
let iv_l = match version with
| `TLS_1_0 -> Some ()
| _ -> None
in
let key_len, iv_len, mac_len = Ciphersuite.key_length iv_l pp in
let kblen = 2 * key_len + 2 * mac_len + 2 * iv_len
and rand = server_random ^ client_random
in
let keyblock = key_block version cipher kblen master rand in
divide_keyblock key_len mac_len iv_len keyblock
in
let context cipher_k iv mac_k =
let open Crypto.Ciphers in
let cipher_st =
let iv_mode = match version with
| `TLS_1_0 -> Iv iv
| _ -> Random_iv
in
get_cipher ~secret:cipher_k ~hmac_secret:mac_k ~iv_mode ~nonce:iv pp
and sequence = 0L in
{ cipher_st ; sequence }
in
let c_context = context c_key c_iv c_mac
and s_context = context s_key s_iv s_mac in
(c_context, s_context)

9
unikernel/duniverse/ocaml-tls/lib/handshake_crypto.mli Normal file
View file

@ -0,0 +1,9 @@
open State
val derive_master_secret : Core.tls_before_13 -> session_data -> string -> string list -> Core.master_secret
val initialise_crypto_ctx : Core.tls_before_13 -> session_data -> (crypto_context * crypto_context)
val finished : Core.tls_before_13 -> Ciphersuite.ciphersuite -> string -> string -> string list -> string
(** [pseudo_random_function version cipher length secret label seed] *)
val pseudo_random_function : Core.tls_before_13 -> Ciphersuite.ciphersuite ->
int -> string -> string -> string -> string

183
unikernel/duniverse/ocaml-tls/lib/handshake_crypto13.ml Normal file
View file

@ -0,0 +1,183 @@
open Core
let cdiv (x : int) (y : int) =
if x > 0 && y > 0 then (x + y - 1) / y
else if x < 0 && y < 0 then (x + y + 1) / y
else x / y
let left_pad_dh group msg =
let bytes = cdiv (Mirage_crypto_pk.Dh.modulus_size group) 8 in
let padding = String.make (bytes - String.length msg) '\x00' in
padding ^ msg
let not_all_zero r =
let* str = r in
try
for i = 0 to String.length str - 1 do
if String.unsafe_get str i != '\x00' then raise_notrace Not_found;
done;
Error (`Fatal (`Handshake (`BadDH "all zero")))
with Not_found -> Ok str
let dh_shared secret share =
(* RFC 8556, Section 7.4.1 - we need zero-padding on the left *)
let map_ecdh_error =
Result.map_error (fun e -> `Fatal (`Handshake (`BadECDH e)))
in
let open Mirage_crypto_ec in
not_all_zero
(match secret with
| `Finite_field secret ->
let group = secret.Mirage_crypto_pk.Dh.group in
let bits = Mirage_crypto_pk.Dh.modulus_size group in
let* () =
(* truncated share, better reject this *)
guard (String.length share = cdiv bits 8)
(`Fatal (`Handshake (`BadDH "truncated")))
in
let* shared =
Option.to_result
~none:(`Fatal (`Handshake (`BadDH "invalid FF")))
(Mirage_crypto_pk.Dh.shared secret share)
in
Ok (left_pad_dh group shared)
| `P256 priv -> map_ecdh_error (P256.Dh.key_exchange priv share)
| `P384 priv -> map_ecdh_error (P384.Dh.key_exchange priv share)
| `P521 priv -> map_ecdh_error (P521.Dh.key_exchange priv share)
| `X25519 priv -> map_ecdh_error (X25519.key_exchange priv share))
let dh_gen_key group =
(* RFC 8556, Section 4.2.8.1 - we need zero-padding on the left *)
match Core.group_to_impl group with
| `Finite_field mc_group ->
let sec, shared = Mirage_crypto_pk.Dh.gen_key mc_group in
`Finite_field sec, left_pad_dh mc_group shared
| `P256 ->
let secret, shared = Mirage_crypto_ec.P256.Dh.gen_key () in
`P256 secret, shared
| `P384 ->
let secret, shared = Mirage_crypto_ec.P384.Dh.gen_key () in
`P384 secret, shared
| `P521 ->
let secret, shared = Mirage_crypto_ec.P521.Dh.gen_key () in
`P521 secret, shared
| `X25519 ->
let secret, shared = Mirage_crypto_ec.X25519.gen_key () in
`X25519 secret, shared
let trace tag cs = Tracing.cs ~tag:("crypto " ^ tag) cs
let pp_hash_k_n ciphersuite =
let open Ciphersuite in
let pp = privprot13 ciphersuite
and hash = hash13 ciphersuite
in
let k, n = kn_13 pp in
(pp, hash, k, n)
let hkdflabel label context length =
let lbl = "tls13 " ^ label in
let len_llen = Bytes.create 3 in
Bytes.set_uint16_be len_llen 0 length;
Bytes.set_uint8 len_llen 2 (String.length lbl);
let clen = String.make 1 (Char.unsafe_chr (String.length context)) in
let lbl = String.concat ""
[ Bytes.unsafe_to_string len_llen ;
lbl ;
clen ;
context ]
in
trace "hkdflabel" lbl ;
lbl
let derive_secret_no_hash hash prk ?length ?(ctx = "") label =
let length = match length with
| None ->
let module H = (val Digestif.module_of_hash' hash) in
H.digest_size
| Some x -> x
in
let info = hkdflabel label ctx length in
trace "prk" prk ;
let key = Hkdf.expand ~hash ~prk ~info length in
trace ("derive_secret: " ^ label) key ;
key
let derive_secret t label log =
let module H = (val Digestif.module_of_hash' t.State.hash) in
let ctx = H.(to_raw_string (digest_string log)) in
trace "derive secret ctx" ctx ;
derive_secret_no_hash t.State.hash t.State.secret ~ctx label
let empty cipher = {
State.secret = "" ;
cipher ;
hash = Ciphersuite.hash13 cipher
}
let derive t secret_ikm =
let salt =
if String.equal t.State.secret "" then
""
else
derive_secret t "derived" ""
in
trace "derive: secret_ikm" secret_ikm ;
trace "derive: salt" salt ;
let secret = Hkdf.extract ~hash:t.State.hash ~salt secret_ikm in
trace "derive (extracted secret)" secret ;
{ t with State.secret }
let traffic_key cipher prk =
let _, hash, key_len, iv_len = pp_hash_k_n cipher in
let key_info = hkdflabel "key" "" key_len in
let key = Hkdf.expand ~hash ~prk ~info:key_info key_len in
let iv_info = hkdflabel "iv" "" iv_len in
let iv = Hkdf.expand ~hash ~prk ~info:iv_info iv_len in
(key, iv)
let ctx t label secret =
let secret, nonce = traffic_key t.State.cipher secret in
trace (label ^ " secret") secret ;
trace (label ^ " nonce") nonce ;
let pp = Ciphersuite.privprot13 t.State.cipher in
{ State.sequence = 0L ; cipher_st = Crypto.Ciphers.get_aead_cipher ~secret ~nonce pp }
let early_traffic t log =
let secret = derive_secret t "c e traffic" log in
(secret, ctx t "client early traffic" secret)
let hs_ctx t log =
Tracing.cs ~tag:"hs ctx with sec" t.State.secret ;
Tracing.cs ~tag:"log is" log ;
let server_handshake_traffic_secret = derive_secret t "s hs traffic" log
and client_handshake_traffic_secret = derive_secret t "c hs traffic" log
in
(server_handshake_traffic_secret,
ctx t "server handshake traffic" server_handshake_traffic_secret,
client_handshake_traffic_secret,
ctx t "client handshake traffic" client_handshake_traffic_secret)
let app_ctx t log =
let server_application_traffic_secret = derive_secret t "s ap traffic" log
and client_application_traffic_secret = derive_secret t "c ap traffic" log
in
(server_application_traffic_secret,
ctx t "server application traffic" server_application_traffic_secret,
client_application_traffic_secret,
ctx t "client application traffic" client_application_traffic_secret)
let app_secret_n_1 t app_secret =
let secret = derive_secret_no_hash t.State.hash app_secret "traffic upd" in
secret, ctx t "traffic update" secret
let exporter t log = derive_secret t "exp master" log
let resumption t log = derive_secret t "res master" log
let res_secret hash secret nonce =
derive_secret_no_hash hash secret ~ctx:nonce "resumption"
let finished hash secret data =
let module H = (val Digestif.module_of_hash' hash) in
let key = derive_secret_no_hash hash secret "finished" in
H.(to_raw_string (hmac_string ~key (to_raw_string (digest_string data))))

662
unikernel/duniverse/ocaml-tls/lib/handshake_server.ml Normal file
View file

@ -0,0 +1,662 @@
open Core
open State
open Handshake_common
open Config
let state_version state = match state.protocol_version with
| #tls_before_13 as v -> v
| _ -> assert false
let hello_request state =
if state.config.use_reneg then
let hr = HelloRequest in
Tracing.hs ~tag:"handshake-out" hr ;
let state = { state with machina = Server AwaitClientHelloRenegotiate } in
Ok (state, [`Record (Packet.HANDSHAKE, Writer.assemble_handshake hr)])
else
Error (`Fatal (`Handshake (`Message "renegotation is not supported")))
let answer_client_finished state (session : session_data) client_fin raw log =
let client, server =
let checksum = Handshake_crypto.finished (state_version state)
session.ciphersuite session.common_session_data.master_secret
in
(checksum "client finished" log, checksum "server finished" (log @ [raw]))
in
let* () =
guard (String.equal client client_fin)
(`Fatal (`Handshake (`Message "couldn't verify finished")))
in
let session = { session with tls_unique = client } in
let fin = Finished server in
let fin_raw = Writer.assemble_handshake fin in
(* we really do not want to have any leftover handshake fragments *)
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let session = { session with renegotiation = (client, server) }
and machina = Server Established
in
Tracing.hs ~tag:"handshake-out" fin ;
Ok ({ state with machina ; session = `TLS session :: state.session },
[`Record (Packet.HANDSHAKE, fin_raw)])
let answer_client_finished_resume state (session : session_data) server_verify client_fin _raw log =
let client_verify =
Handshake_crypto.finished (state_version state) session.ciphersuite session.common_session_data.master_secret "client finished" log
in
let* () =
guard (String.equal client_verify client_fin)
(`Fatal (`Handshake (`Message "couldn't verify finished")))
in
(* we really do not want to have any leftover handshake fragments *)
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let session = { session with renegotiation = (client_verify, server_verify) }
and machina = Server Established
in
Ok ({ state with machina ; session = `TLS session :: state.session }, [])
let establish_master_secret state (session : session_data) premastersecret raw log =
let log = log @ [raw] in
let master_secret = Handshake_crypto.derive_master_secret
(state_version state) session premastersecret log
in
let session =
let common_session_data = { session.common_session_data with master_secret } in
{ session with common_session_data }
in
let client_ctx, server_ctx =
Handshake_crypto.initialise_crypto_ctx (state_version state) session
in
let machina =
match session.common_session_data.peer_certificate with
| None -> AwaitClientChangeCipherSpec (session, server_ctx, client_ctx, log)
| Some _ -> AwaitClientCertificateVerify (session, server_ctx, client_ctx, log)
in
Tracing.cs ~tag:"master-secret" master_secret ;
({ state with machina = Server machina }, [])
let private_key (session : session_data) =
match session.common_session_data.own_private_key with
| Some priv -> Ok priv
| None -> Error (`Fatal (`Handshake (`Message "couldn't locate private key")))
let validate_certs certs authenticator ip (session : session_data) =
let* peer_certificate, received_certificates, peer_certificate_chain, trust_anchor =
validate_chain authenticator certs ip None
in
let common_session_data = {
session.common_session_data with
received_certificates ;
peer_certificate ;
peer_certificate_chain ;
trust_anchor
} in
Ok { session with common_session_data }
let answer_client_certificate_RSA state (session : session_data) certs raw log =
let* session =
validate_certs certs state.config.authenticator state.config.ip session
in
let machina = AwaitClientKeyExchange_RSA (session, log @ [raw]) in
Ok ({ state with machina = Server machina }, [])
let answer_client_certificate_DHE state (session : session_data) dh_sent certs raw log =
let* session =
validate_certs certs state.config.authenticator state.config.ip session
in
let machina = AwaitClientKeyExchange_DHE (session, dh_sent, log @ [raw]) in
Ok ({ state with machina = Server machina }, [])
let answer_client_certificate_verify state (session : session_data) sctx cctx verify raw log =
let sigdata = String.concat "" log in
let* () =
verify_digitally_signed state.protocol_version
state.config.signature_algorithms verify sigdata
session.common_session_data.peer_certificate
in
let machina = AwaitClientChangeCipherSpec (session, sctx, cctx, log @ [raw]) in
Ok ({ state with machina = Server machina }, [])
let answer_client_key_exchange_RSA state (session : session_data) kex raw log =
(* due to bleichenbacher attach, we should use a random pms *)
(* then we do not leak any decryption or padding errors! *)
let other = Writer.assemble_protocol_version state.protocol_version ^ Mirage_crypto_rng.generate 46 in
let validate_premastersecret k =
(* Client implementations MUST always send the correct version number in
PreMasterSecret. If ClientHello.client_version is TLS 1.1 or higher,
server implementations MUST check the version number as described in
the note below. If the version number is TLS 1.0 or earlier, server
implementations SHOULD check the version number, but MAY have a
configuration option to disable the check. Note that if the check
fails, the PreMasterSecret SHOULD be randomized as described below *)
(* we do not provide an option to disable the version checking (yet!) *)
match String.length k = 48, Reader.parse_any_version k with
| true, Ok c_ver when c_ver = session.client_version -> k
| _ -> other
in
let* k = private_key session in
match k with
| `RSA key ->
let pms = match Mirage_crypto_pk.Rsa.PKCS1.decrypt ~key kex with
| None -> validate_premastersecret other
| Some k -> validate_premastersecret k
in
Ok (establish_master_secret state session pms raw log)
| _ -> Error (`Fatal (`Bad_certificate "expected RSA certificate"))
let answer_client_key_exchange_DHE state session secret kex raw log =
let* pms =
let open Mirage_crypto_ec in
let map_ecdh_error =
Result.map_error (fun e -> `Fatal (`Handshake (`BadECDH e)))
in
match secret with
| `P256 priv ->
let* share = map_reader_error (Reader.parse_client_ec_key_exchange kex) in
map_ecdh_error (P256.Dh.key_exchange priv share)
| `P384 priv ->
let* share = map_reader_error (Reader.parse_client_ec_key_exchange kex) in
map_ecdh_error (P384.Dh.key_exchange priv share)
| `P521 priv ->
let* share = map_reader_error (Reader.parse_client_ec_key_exchange kex) in
map_ecdh_error (P521.Dh.key_exchange priv share)
| `X25519 priv ->
let* share = map_reader_error (Reader.parse_client_ec_key_exchange kex) in
map_ecdh_error (X25519.key_exchange priv share)
| `Finite_field secret ->
let* share = map_reader_error (Reader.parse_client_dh_key_exchange kex) in
Option.to_result
~none:(`Fatal (`Handshake (`BadDH "invalid FF")))
(Mirage_crypto_pk.Dh.shared secret share)
in
Ok (establish_master_secret state session pms raw log)
let sig_algs (client_hello : client_hello) =
Utils.map_find
~f:(function `SignatureAlgorithms xs -> Some xs | _ -> None)
client_hello.extensions
let ecc_group configured_groups requested_groups =
Utils.first_match requested_groups configured_groups
let agreed_cipher cert ecc requested =
let usage_matches cipher =
let csusage =
Ciphersuite.(required_usage @@ ciphersuite_kex cipher)
in
supports_key_usage ~not_present:true csusage cert
in
let cciphers = List.filter usage_matches requested in
if ecc then
cciphers
else
List.filter (fun x -> not (Ciphersuite.ecdhe x)) cciphers
let server_hello config (client_hello : client_hello) (session : session_data) version reneg =
(* RFC 4366: server shall reply with an empty hostname extension *)
let host = Option.fold ~none:[] ~some:(fun _ -> [`Hostname]) session.common_session_data.own_name
and server_random =
let suffix =
match version, max_protocol_version config.protocol_versions with
| `TLS_1_2, `TLS_1_3 -> Packet.downgrade12
| _, `TLS_1_3 -> Packet.downgrade11
| _ -> ""
in
let rst = Mirage_crypto_rng.generate (32 - String.length suffix) in
rst ^ suffix
and secren = match reneg with
| None -> `SecureRenegotiation ""
| Some (cvd, svd) -> `SecureRenegotiation (cvd ^ svd)
and ems = if session.extended_ms then
[`ExtendedMasterSecret]
else
[]
and session_id =
match String.length session.session_id with
| 0 -> Mirage_crypto_rng.generate 32
| _ -> session.session_id
and alpn =
match session.common_session_data.alpn_protocol with
| None -> []
| Some protocol -> [`ALPN protocol]
and ecpointformat =
match Utils.map_find ~f:(function `ECPointFormats -> Some () | _ -> None) client_hello.extensions with
| Some () when Ciphersuite.ecdhe session.ciphersuite -> [ `ECPointFormats ]
| _ -> []
in
let sh = ServerHello
{ server_version = version ;
server_random = server_random ;
sessionid = Some session_id ;
ciphersuite = session.ciphersuite ;
extensions = secren :: host @ ems @ alpn @ ecpointformat }
in
trace_cipher session.ciphersuite ;
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 })
let answer_client_hello_common state reneg ch raw =
let process_client_hello ch config =
let host = hostname ch
and groups = groups ch
and cciphers = List.filter_map Ciphersuite.any_ciphersuite_to_ciphersuite ch.ciphersuites
in
let configured_ecc_groups, other_groups = List.partition Config.elliptic_curve config.groups in
let ecc_group = ecc_group configured_ecc_groups groups
and cciphers = List.filter (fun c -> not (Ciphersuite.ciphersuite_tls13 c)) cciphers
in
let cciphers = List.filter (fun c -> List.mem c config.ciphers) cciphers in
let f =
(* from the ciphers, figure out:
- (a) RSA only (b) EC only
- (c) static RSA only (keyUsage = KeyEncipherment) (d) DHE only (keyUsage = DigitalSignature)
- (e) from the groups (they indicate the key type!)
*)
let kt_filter =
match List.partition (fun c -> Ciphersuite.ciphersuite_keytype c = `RSA) cciphers with
| _::_, [] -> begin fun s -> match X509.Certificate.public_key s with `RSA _ -> true | _ -> false end
| [], _::_ -> begin fun s -> match X509.Certificate.public_key s with `ED25519 _ | `P256 _ | `P384 _ | `P521 _ -> true | _ -> false end
| _, _ -> begin fun _s -> true end
in
let ku_filter =
match List.partition (fun c -> Ciphersuite.ciphersuite_kex c = `RSA) cciphers with
| _::_, [] -> supports_key_usage ~not_present:true `Key_encipherment
| [], _::_ -> supports_key_usage ~not_present:true `Digital_signature
| _ -> begin fun _ -> true end
in
let kt_matches_group s =
match X509.Certificate.public_key s with
| `RSA _ -> true
| `ED25519 _ -> List.mem `X25519 groups
| `P256 _ -> List.mem `P256 groups
| `P384 _ -> List.mem `P384 groups
| `P521 _ -> List.mem `P521 groups
in
fun s ->
kt_filter s && ku_filter s && kt_matches_group s
in
let signature_algorithms = sig_algs ch in
let* cciphers, chain, priv =
let* r =
agreed_cert ~f ?signature_algorithms config.own_certificates host
in
match r with
| (c::cs, priv) ->
let cciphers = agreed_cipher c (ecc_group <> None) cciphers in
Ok (cciphers, c::cs, Some priv)
| ([], _) -> Error (`Fatal (`Handshake (`Message "couldn't find certificate chain")))
in
let* cipher =
match Utils.first_match cciphers config.ciphers with
| Some x -> Ok x
| None ->
let* _ =
Option.to_result
~none:(`Fatal (`Handshake (`Message "no supported ciphersuite")))
(Utils.first_match cciphers Config.Ciphers.supported)
in
Error (`Error (`NoConfiguredCiphersuite cciphers))
in
let extended_ms = List.mem `ExtendedMasterSecret ch.extensions in
Log.debug (fun m -> m "cipher %a" Ciphersuite.pp_ciphersuite cipher) ;
let* alpn_protocol = alpn_protocol config ch in
let group =
if Ciphersuite.ecdhe cipher then
ecc_group
else match other_groups with
| [] -> None
| c::_ -> Some c
in
let session =
let session = empty_session in
let common_session_data = {
session.common_session_data with
client_random = ch.client_random ;
own_certificate = chain ;
own_private_key = priv ;
own_name = host ;
alpn_protocol = alpn_protocol
} in
{ session with
common_session_data ;
client_version = ch.client_version ;
ciphersuite = cipher ;
group = group ;
extended_ms = extended_ms ;
}
in
Ok session
and server_cert (session : session_data) =
match session.common_session_data.own_certificate with
| [] -> []
| certs ->
let cs = List.map X509.Certificate.encode_der certs in
let cert = Certificate (Writer.assemble_certificates cs) in
Tracing.hs ~tag:"handshake-out" cert ;
[ Writer.assemble_handshake cert ]
and cert_request version config (session : session_data) =
let open Writer in
match config.authenticator with
| None -> Ok ([], session)
| Some _ ->
let cas =
List.map X509.Distinguished_name.encode_der config.acceptable_cas
and certs =
[ Packet.RSA_SIGN ; Packet.ECDSA_SIGN ]
in
let* data =
match version with
| `TLS_1_0 | `TLS_1_1 ->
Ok (assemble_certificate_request certs cas)
| `TLS_1_2 ->
Ok (assemble_certificate_request_1_2 certs config.signature_algorithms cas)
in
let certreq = CertificateRequest data in
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 })
and kex_dhe config (session : session_data) version sig_algs =
let* secret, written =
match session.group with
| None -> assert false (* can not happen *)
| Some g ->
let open Mirage_crypto_ec in
match group_to_impl g with
| `Finite_field g ->
let secret, msg = Mirage_crypto_pk.Dh.gen_key g in
let dh_param = Crypto.dh_params_pack g msg in
let dh_params = Writer.assemble_dh_parameters dh_param in
Ok (`Finite_field secret, dh_params)
| `P256 ->
let secret, shared = P256.Dh.gen_key () in
let params = Writer.assemble_ec_parameters `P256 shared in
Ok (`P256 secret, params)
| `P384 ->
let secret, shared = P384.Dh.gen_key () in
let params = Writer.assemble_ec_parameters `P384 shared in
Ok (`P384 secret, params)
| `P521 ->
let secret, shared = P521.Dh.gen_key () in
let params = Writer.assemble_ec_parameters `P521 shared in
Ok (`P521 secret, params)
| `X25519 ->
let secret, shared = X25519.gen_key () in
let params = Writer.assemble_ec_parameters `X25519 shared in
Ok (`X25519 secret, params)
in
let data = String.concat "" [
session.common_session_data.client_random ;
session.common_session_data.server_random ;
written
]
in
let* priv = private_key session in
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.hs ~tag:"handshake-out" kex ;
Ok (hs, secret)
in
let* session = process_client_hello ch state.config in
let sh, session = server_hello state.config ch session state.protocol_version reneg in
let certificates = server_cert session
and hello_done = Writer.assemble_handshake ServerHelloDone
in
let* cert_req, session =
cert_request (state_version state) state.config session
in
let* out_recs, machina =
match Ciphersuite.ciphersuite_kex session.ciphersuite with
| #Ciphersuite.key_exchange_algorithm_dhe ->
let* kex, dh =
kex_dhe state.config session state.protocol_version (sig_algs ch)
in
let outs = sh :: certificates @ [ kex ] @ cert_req @ [ hello_done ] in
let log = raw :: outs in
let machina =
if session.common_session_data.client_auth then
AwaitClientCertificate_DHE (session, dh, log)
else
AwaitClientKeyExchange_DHE (session, dh, log)
in
Tracing.hs ~tag:"handshake-out" ServerHelloDone ;
Ok (outs, machina)
| `RSA ->
let outs = sh :: certificates @ cert_req @ [ hello_done ] in
let log = raw :: outs in
let machina =
if session.common_session_data.client_auth then
AwaitClientCertificate_RSA (session, log)
else
AwaitClientKeyExchange_RSA (session, log)
in
Tracing.hs ~tag:"handshake-out" ServerHelloDone ;
Ok (outs, machina)
in
Ok ({ state with machina = Server machina },
[`Record (Packet.HANDSHAKE, String.concat "" out_recs)])
(* TODO could benefit from result monadd *)
let agreed_version supported (client_hello : client_hello) =
let raw_client_versions =
match List.filter_map (function `SupportedVersions vs -> Some vs | _ -> None) client_hello.extensions with
| [] -> [client_hello.client_version]
| [vs] -> vs
| _ -> invalid_arg "bad supported version extension"
in
let supported_versions = List.fold_left (fun acc v ->
match any_version_to_version v with
| None -> acc
| Some v -> v :: acc) [] raw_client_versions
in
let client_versions = List.sort_uniq compare_tls_version supported_versions in
match
List.fold_left (fun r v ->
match supported_protocol_version supported v with
| None -> r
| Some v -> Some v)
None client_versions
with
| Some x -> Ok x
| None -> match supported_versions with
| [] -> Error (`Fatal (`Protocol_version (`None_supported raw_client_versions)))
| _ -> Error (`Error (`NoConfiguredVersions supported_versions))
let answer_client_hello state (ch : client_hello) raw =
let ensure_reneg ciphers their_data =
let reneg_cs = List.mem Packet.TLS_EMPTY_RENEGOTIATION_INFO_SCSV ciphers in
let err = `Fatal (`Handshake (`Message "invalid renegotiation")) in
match reneg_cs, their_data with
| _, Some x -> guard (String.length x = 0) err
| true, _ -> Ok ()
| _ -> Error err
and resume (ch : client_hello) state =
let epoch_matches (epoch : Core.epoch_data) version ciphers extensions =
let cciphers = List.filter_map Ciphersuite.any_ciphersuite_to_ciphersuite ciphers in
List.mem epoch.ciphersuite cciphers &&
version = epoch.protocol_version &&
(not state.config.use_reneg ||
(List.mem `ExtendedMasterSecret extensions && epoch.extended_ms))
in
match Option.bind ch.sessionid state.config.session_cache with
| Some epoch when epoch_matches epoch state.protocol_version ch.ciphersuites ch.extensions ->
let session =
let session = session_of_epoch epoch in
let common_session_data = {
session.common_session_data with
client_random = ch.client_random ;
client_auth = (epoch.peer_certificate <> None) ;
} in
{ session with common_session_data ; client_version = ch.client_version }
in
Some session
| _ -> None
and answer_resumption session state =
let version = state_version state in
let sh, session = server_hello state.config ch session version None in
(* we really do not want to have any leftover handshake fragments *)
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let client_ctx, server_ctx =
Handshake_crypto.initialise_crypto_ctx version session
in
let ccs = change_cipher_spec in
let log = [ raw ; sh ] in
let server =
Handshake_crypto.finished
version session.ciphersuite session.common_session_data.master_secret "server finished" log
in
let session = { session with tls_unique = server } in
let fin = Finished server in
let fin_raw = Writer.assemble_handshake fin in
Tracing.cs ~tag:"change-cipher-spec-out" (snd ccs) ;
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) ;
`Record ccs ;
`Change_enc server_ctx ;
`Record (Packet.HANDSHAKE, fin_raw)])
in
let process_client_hello config ch version =
let cciphers = ch.ciphersuites in
let* () = client_hello_valid version ch in
let* () =
guard (not (List.mem Packet.TLS_FALLBACK_SCSV cciphers) ||
version = max_protocol_version config.protocol_versions)
(`Fatal `Inappropriate_fallback)
in
let theirs = get_secure_renegotiation ch.extensions in
ensure_reneg cciphers theirs
in
let process protocol_version =
let* () = process_client_hello state.config ch protocol_version in
let state = { state with protocol_version } in
(match resume ch state with
| None -> answer_client_hello_common state None ch raw
| Some session -> answer_resumption session state)
in
let* v = agreed_version state.config.protocol_versions ch in
match v with
| `TLS_1_3 -> Handshake_server13.answer_client_hello ~hrr:false state ch raw
| protocol_version -> process protocol_version
let answer_client_hello_reneg state (ch : client_hello) raw =
(* ensure reneg allowed and supplied *)
let ensure_reneg our_data their_data =
let err = `Fatal (`Handshake (`Message "invalid renegotiation")) in
match our_data, their_data with
| (cvd, _), Some x -> guard (String.equal cvd x) err
| _ -> Error err
in
let process_client_hello config oldversion ours ch =
let* () = client_hello_valid oldversion ch in
let* version = agreed_version config.protocol_versions ch in
let* () =
guard (version = oldversion)
(`Fatal (`Handshake (`Message "invalid renegotiation version")))
in
let theirs = get_secure_renegotiation ch.extensions in
let* () = ensure_reneg ours theirs in
Ok version
in
let config = state.config in
match config.use_reneg, state.session with
| true , `TLS session :: _ ->
let reneg = session.renegotiation in
let* _version = process_client_hello config state.protocol_version reneg ch in
answer_client_hello_common state (Some reneg) ch raw
| false, _ ->
let no_reneg = Writer.assemble_alert ~level:Packet.WARNING Packet.NO_RENEGOTIATION in
Tracing.debug (fun m -> m "alert-out (warning, no_renegotiation)") ;
Ok (state, [`Record (Packet.ALERT, no_reneg)])
| true , _ -> Error (`Fatal (`Handshake (`Message "couldn't find an earlier session")))
let handle_change_cipher_spec ss state packet =
let* () = map_reader_error (Reader.parse_change_cipher_spec packet) in
match ss with
| AwaitClientChangeCipherSpec (session, server_ctx, client_ctx, log) ->
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let ccs = change_cipher_spec in
let machina = AwaitClientFinished (session, log)
in
Tracing.cs ~tag:"change-cipher-spec-in" packet ;
Tracing.cs ~tag:"change-cipher-spec-out" packet ;
Ok ({ state with machina = Server machina },
[`Record ccs; `Change_enc server_ctx; `Change_dec client_ctx])
| AwaitClientChangeCipherSpecResume (session, client_ctx, server_verify, log) ->
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let machina = AwaitClientFinishedResume (session, server_verify, log)
in
Tracing.cs ~tag:"change-cipher-spec-in" packet ;
Ok ({ state with machina = Server machina },
[`Change_dec client_ctx])
| _ -> Error (`Fatal (`Unexpected (`Message "change cipher spec")))
let handle_handshake ss hs buf =
let* handshake = map_reader_error (Reader.parse_handshake buf) in
Tracing.hs ~tag:"handshake-in" handshake;
match ss, handshake with
| AwaitClientHello, ClientHello ch ->
answer_client_hello hs ch buf
| AwaitClientCertificate_RSA (session, log), Certificate cs ->
let* cs = map_reader_error (Reader.parse_certificates cs) in
answer_client_certificate_RSA hs session cs buf log
| AwaitClientCertificate_DHE (session, dh_sent, log), Certificate cs ->
let* cs = map_reader_error (Reader.parse_certificates cs) in
answer_client_certificate_DHE hs session dh_sent cs buf log
| AwaitClientKeyExchange_RSA (session, log), ClientKeyExchange cs ->
let* kex = map_reader_error (Reader.parse_client_dh_key_exchange cs) in
answer_client_key_exchange_RSA hs session kex buf log
| AwaitClientKeyExchange_DHE (session, dh_sent, log), ClientKeyExchange kex ->
answer_client_key_exchange_DHE hs session dh_sent kex buf log
| AwaitClientCertificateVerify (session, sctx, cctx, log), CertificateVerify ver ->
answer_client_certificate_verify hs session sctx cctx ver buf log
| AwaitClientFinished (session, log), Finished fin ->
answer_client_finished hs session fin buf log
| AwaitClientFinishedResume (session, server_verify, log), Finished fin ->
answer_client_finished_resume hs session server_verify fin buf log
| Established, ClientHello ch -> (* client-initiated renegotiation *)
answer_client_hello_reneg hs ch buf
| AwaitClientHelloRenegotiate, ClientHello ch -> (* hello-request send, renegotiation *)
answer_client_hello_reneg hs ch buf
| _, hs -> Error (`Fatal (`Unexpected (`Handshake hs)))

6
unikernel/duniverse/ocaml-tls/lib/handshake_server.mli Normal file
View file

@ -0,0 +1,6 @@
open State
val hello_request : handshake_state -> (handshake_return, failure) result
val handle_change_cipher_spec : server_handshake_state -> handshake_state -> string -> (handshake_return, failure) result
val handle_handshake : server_handshake_state -> handshake_state -> string -> (handshake_return, failure) result

511
unikernel/duniverse/ocaml-tls/lib/handshake_server13.ml Normal file
View file

@ -0,0 +1,511 @@
open State
open Core
open Handshake_common
open Handshake_crypto13
let answer_client_hello ~hrr state ch raw =
let* () = client_hello_valid `TLS_1_3 ch in
let* () =
guard (not (hrr && List.mem `EarlyDataIndication ch.extensions))
(`Fatal (`Handshake (`Message "has 0RTT after hello retry request")))
in
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
in
let* groups =
let* gs =
Option.to_result
~none:(`Fatal (`Missing_extension "supported group"))
(Utils.map_find ~f:(function `SupportedGroups gs -> Some gs | _ -> None) ch.extensions)
in
Ok (List.filter_map Core.named_group_to_group gs)
in
let* keyshares =
let* ks =
Option.to_result
~none:(`Fatal (`Missing_extension "key share"))
(Utils.map_find ~f:(function `KeyShare ks -> Some ks | _ -> None) ch.extensions)
in
List.fold_left (fun acc (g, ks) ->
let* acc = acc in
match Core.named_group_to_group g with
| None -> Ok acc
| Some g -> Ok ((g, ks) :: acc))
(Ok []) ks
in
let base_server_hello ?epoch cipher extensions =
let ciphersuite = (cipher :> Ciphersuite.ciphersuite) in
let sh =
{ server_version = `TLS_1_3 ;
server_random = Mirage_crypto_rng.generate 32 ;
sessionid = ch.sessionid ;
ciphersuite ;
extensions }
in
let session : session_data13 =
let base = match epoch with None -> empty_session13 cipher | Some e -> session13_of_epoch cipher e in
let common_session_data13 = {
base.common_session_data13 with
server_random = sh.server_random ;
client_random = ch.client_random ;
} in
let resumed = match epoch with None -> false | Some _ -> true in
{ base with common_session_data13 ; ciphersuite13 = cipher ; resumed }
in
(sh, session)
in
let config = state.config in
match
Utils.first_match (List.map fst keyshares) config.Config.groups,
Utils.first_match ciphers (Config.ciphers13 config)
with
| _, None -> Error (`Error (`NoConfiguredCiphersuite ciphers))
| None, Some cipher ->
if hrr then
(* avoid loops CH -> HRR -> CH -> HRR -> ... *)
Error (`Fatal (`Handshake (`Message "hello retry request already sent, still no supported group")))
else
(* no keyshare, looks whether there's a supported group ++ send back HRR *)
begin match Utils.first_match groups config.Config.groups with
| None -> Error (`Fatal (`Handshake (`Message "no supported group found")))
| Some group ->
let cookie =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
H.(to_raw_string (digest_string 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.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
let machina = Server13 AwaitClientHelloHRR13 in
Ok ({ state with early_data_left ; machina },
`Record (Packet.HANDSHAKE, hrr_raw) ::
(match ch.sessionid with
| None -> []
| Some _ -> [`Record change_cipher_spec]))
end
| Some group, Some cipher ->
Log.debug (fun m -> m "cipher %a" Ciphersuite.pp_ciphersuite cipher) ;
Log.debug (fun m -> m "group %a" pp_group group) ;
if not (List.mem group groups) then
Error (`Fatal (`Handshake (`Message "keyshare group not in group list")))
else
(* we already checked above in keyshares that group is present there *)
let keyshare =
snd (List.find (fun (g, _) -> g = group) keyshares)
in
(* DHE - full handshake *)
let* log =
if hrr then
let* c =
Option.to_result
~none:(`Fatal (`Missing_extension "cookie"))
(Utils.map_find ~f:(function `Cookie c -> Some c | _ -> None) ch.extensions)
in
(* log is: 254 00 00 length c :: HRR *)
let hash_hdr = Writer.assemble_message_hash (String.length c) in
let hrr = { retry_version = `TLS_1_3 ; ciphersuite = cipher ; sessionid = ch.sessionid ; selected_group = group ; extensions = [ `Cookie c ]} in
let hs_buf = Writer.assemble_handshake (HelloRetryRequest hrr) in
Ok (String.concat "" [ hash_hdr ; c ; hs_buf ])
else
Ok ""
in
let hostname = hostname ch in
let hlen =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
H.digest_size
in
let early_secret, epoch, exts, can_use_early_data =
let secret ?(psk = String.make hlen '\x00') () = Handshake_crypto13.(derive (empty cipher) psk) in
let no_resume = secret (), None, [], false in
match
config.Config.ticket_cache,
Utils.map_find ~f:(function `PreSharedKeys ids -> Some ids | _ -> None) ch.extensions,
Utils.map_find ~f:(function `PskKeyExchangeModes ms -> Some ms | _ -> None) ch.extensions
with
| None, _, _ | _, None, _ -> no_resume
| Some _, Some _, None -> no_resume (* should this lead to an error instead? *)
| Some cache, Some ids, Some ms ->
if not (List.mem Packet.PSK_KE_DHE ms) then
no_resume
else
let idx_ids = List.mapi (fun i id -> (i, id)) ids in
match
List.filter (fun (_, ((id, _), _)) ->
match cache.Config.lookup id with None -> false | Some _ -> true)
idx_ids
with
| [] ->
Log.info (fun m -> m "found no id in psk cache") ;
no_resume
| (idx, ((id, obf_age), binder))::_ ->
(* need to verify binder, do the obf_age computations + checking,
figure out whether the id is in our psk cache, and use the resumption secret as input
and Ok the idx *)
let psk, old_epoch =
match cache.Config.lookup id with
| None -> assert false (* see above *)
| Some x -> x
in
match Ciphersuite.(any_ciphersuite_to_ciphersuite13 (ciphersuite_to_any_ciphersuite old_epoch.ciphersuite)) with
| None -> no_resume
| Some c' ->
if c' = cipher &&
match hostname, old_epoch.own_name with
| None, None -> true
| Some x, Some y -> Domain_name.equal x y
| _ -> false
then
let now = cache.Config.timestamp () in
let server_delta_t = Ptime.diff now psk.issued_at in
let client_delta_t =
match Ptime.Span.of_float_s Int32.(to_float (sub obf_age psk.obfuscation) /. 1000.) with
| None ->
Logs.debug (fun m -> m "client_delta is not computable, using 0") ;
Ptime.Span.zero
| Some x -> x
in
(* ensure server&client_delta_t are not too far off! *)
match Ptime.Span.(to_int_s (abs (sub server_delta_t client_delta_t))) with
| None ->
Logs.debug (fun m -> m "s_c_delta computation lead nowhere") ;
no_resume
| Some s_c_delta ->
if s_c_delta > 10 then begin
Logs.debug (fun m -> m "delta between client and server is %d seconds, ignoring this ticket!" s_c_delta);
no_resume
end else
(* if ticket_creation ts + lifetime > now, continue *)
let until = match Ptime.add_span psk.issued_at (Ptime.Span.of_int_s (Int32.to_int cache.Config.lifetime)) with
| None -> Ptime.epoch
| Some ts -> ts
in
if Ptime.is_earlier now ~than:until then
let early_secret = secret ~psk:psk.secret () in
let binder_key = Handshake_crypto13.derive_secret early_secret "res binder" "" in
let binders_len = binders_len ids in
let ch_part = String.(sub raw 0 (length raw - binders_len)) in
let log = log ^ ch_part in
let binder' = Handshake_crypto13.finished early_secret.hash binder_key log in
if String.equal binder binder' then begin
(* from 4.1.2 - earlydata is not allowed after hrr *)
let zero = idx = 0 && not hrr && List.mem `EarlyDataIndication ch.extensions in
early_secret, Some old_epoch, [ `PreSharedKey idx ], zero
end else
no_resume
else
no_resume
else
no_resume
in
let _, early_traffic_ctx = Handshake_crypto13.early_traffic early_secret raw in
let secret, public = Handshake_crypto13.dh_gen_key group in
let* es = Handshake_crypto13.dh_shared secret keyshare in
let hs_secret = Handshake_crypto13.derive early_secret es in
Tracing.cs ~tag:"hs secret" hs_secret.secret ;
let sh, session = base_server_hello ?epoch cipher (`KeyShare (group, public) :: exts) in
let sh_raw = Writer.assemble_handshake (ServerHello sh) in
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
let* sigalgs =
Option.to_result
~none:(`Fatal (`Missing_extension "signature algorithms"))
(Utils.map_find ~f:(function `SignatureAlgorithms sa -> Some sa | _ -> None) ch.extensions)
in
(* TODO respect certificate_signature_algs if present *)
let f = supports_key_usage ~not_present:true `Digital_signature in
let* chain, priv =
let* r = agreed_cert ~f ~signature_algorithms:sigalgs config.Config.own_certificates hostname in
match r with
| c::cs, priv -> Ok (c::cs, priv)
| _ -> Error (`Fatal (`Handshake (`Message "couldn't find certificate chain")))
in
let* alpn_protocol = alpn_protocol config ch in
let session =
let common_session_data13 = { session.common_session_data13 with
own_name = hostname ; own_certificate = chain ;
own_private_key = Some priv ; alpn_protocol }
in
{ session with common_session_data13 }
in
let ee =
let hostname_ext = Option.fold ~none:[] ~some:(fun _ -> [`Hostname]) hostname
and alpn = Option.fold ~none:[] ~some:(fun proto -> [`ALPN proto]) alpn_protocol
and early_data = if can_use_early_data && config.Config.zero_rtt <> 0l then [ `EarlyDataIndication ] else []
in
EncryptedExtensions (hostname_ext @ alpn @ early_data)
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.hs ~tag:"handshake-out" ee ;
let log = log ^ ee_raw in
let* c_out, log, session' =
if session.resumed then
Ok ([], log, session)
else
let out, log, session = match config.Config.authenticator with
| None -> [], log, session
| Some _ ->
let certreq =
let exts =
`SignatureAlgorithms config.Config.signature_algorithms ::
(match config.Config.acceptable_cas with
| [] -> []
| cas -> [ `CertificateAuthorities cas ])
in
CertificateRequest (Writer.assemble_certificate_request_1_3 exts)
in
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 }
in
let certs = List.map X509.Certificate.encode_der chain in
let cert = Certificate (Writer.assemble_certificates_1_3 "" certs) in
let cert_raw = Writer.assemble_handshake cert in
Tracing.hs ~tag:"handshake-out" cert ;
let log = log ^ cert_raw in
let tbs =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
H.(to_raw_string (digest_string log))
in
let* signed =
signature `TLS_1_3
~context_string:"TLS 1.3, server CertificateVerify"
tbs (Some sigalgs) config.Config.signature_algorithms priv
in
let cv = CertificateVerify signed in
let cv_raw = Writer.assemble_handshake cv in
Tracing.hs ~tag:"handshake-out" cv ;
let log = log ^ cv_raw in
Ok (out @ [cert_raw; cv_raw], log, session)
in
let master_secret = Handshake_crypto13.derive hs_secret (String.make hlen '\x00') in
Tracing.cs ~tag:"master-secret" master_secret.secret ;
let f_data = finished hs_secret.hash server_hs_secret log in
let fin = Finished f_data in
let fin_raw = Writer.assemble_handshake fin in
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 =
app_ctx master_secret log
in
let exporter_master_secret = Handshake_crypto13.exporter master_secret log in
let session' = { session' with server_app_secret ; client_app_secret ; exporter_master_secret } in
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
(* send sessionticket early *)
(* TODO track the nonce across handshakes / newsessionticket messages (i.e. after post-handshake auth) - needs to be unique! *)
let st, st_raw =
match session.resumed, config.Config.ticket_cache with
| true, _ | _, None -> None, []
| false, Some cache ->
let age_add =
let cs = Mirage_crypto_rng.generate 4 in
String.get_int32_be cs 0
in
let psk_id = Mirage_crypto_rng.generate 32 in
let nonce = Mirage_crypto_rng.generate 4 in
let extensions = match config.Config.zero_rtt with
| 0l -> []
| x -> [ `EarlyDataIndication x ]
in
let st = { lifetime = cache.Config.lifetime ; age_add ; nonce ; ticket = psk_id ; extensions } in
Tracing.hs ~tag:"handshake-out" (SessionTicket st) ;
let st_raw = Writer.assemble_handshake (SessionTicket st) in
(Some st, [st_raw])
in
let session =
let common_session_data13 = { session'.common_session_data13 with master_secret = master_secret.secret } in
{ session' with common_session_data13 ; master_secret }
in
let st, session =
if can_use_early_data then
(AwaitEndOfEarlyData13 (client_hs_secret, client_ctx, client_app_ctx, st, log),
`TLS13 { session with state = `ZeroRTT } :: state.session)
else if session.common_session_data13.client_auth then
(AwaitClientCertificate13 (session, client_hs_secret, client_app_ctx, st, log),
state.session)
else
(AwaitClientFinished13 (client_hs_secret, client_app_ctx, st, log),
`TLS13 session :: state.session)
in
let early_data_left = if List.mem `EarlyDataIndication ch.extensions then config.Config.zero_rtt else 0l in
Ok ({ state with machina = Server13 st ; session ; early_data_left },
`Record (Packet.HANDSHAKE, sh_raw) ::
(match ch.sessionid with
| Some _ when not hrr -> [`Record change_cipher_spec]
| _ -> []) @
[ `Change_enc server_ctx ;
`Change_dec (if can_use_early_data then early_traffic_ctx else client_ctx) ;
`Record (Packet.HANDSHAKE, ee_raw) ] @
List.map (fun data -> `Record (Packet.HANDSHAKE, data)) c_out @
[ `Record (Packet.HANDSHAKE, fin_raw) ;
`Change_enc server_app_ctx ] @
List.map (fun data -> `Record (Packet.HANDSHAKE, data)) st_raw)
let answer_client_certificate state cert (sd : session_data13) client_fini dec_ctx st raw log =
let* c = map_reader_error (Reader.parse_certificates_1_3 cert) in
match c, state.config.Config.authenticator with
| (_, []), None -> Error (`Fatal (`Handshake (`Message "couldn't find authenticator")))
| (_ctx, []), Some auth ->
begin match auth ~host:None [] with
| Ok anchor ->
let trust_anchor = match anchor with
| None -> None
| Some (_chain, ta) -> Some ta
in
let common_session_data13 = { sd.common_session_data13 with trust_anchor } in
let sd = { sd with common_session_data13 } in
let st = AwaitClientFinished13 (client_fini, dec_ctx, st, log ^ raw) in
Ok ({ state with machina = Server13 st ; session = `TLS13 sd :: state.session }, [])
| Error e -> Error (`Error (`AuthenticationFailure e))
end
| (_ctx, cert_exts), auth ->
(* TODO what to do with ctx? send through authenticator? *)
(* TODO what to do with extensions? *)
let certs = List.map fst cert_exts in
let* peer_certificate, received_certificates, peer_certificate_chain, trust_anchor =
validate_chain auth certs state.config.Config.ip None
in
let sd' = let common_session_data13 = {
sd.common_session_data13 with
received_certificates ;
peer_certificate ;
peer_certificate_chain ;
trust_anchor
} in
{ sd with common_session_data13 }
in
let st = AwaitClientCertificateVerify13 (sd', client_fini, dec_ctx, st, log ^ raw) in
Ok ({ state with machina = Server13 st }, [])
let answer_client_certificate_verify state cv (sd : session_data13) client_fini dec_ctx st raw log =
let tbs =
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 sd.ciphersuite13)) in
H.(to_raw_string (digest_string log))
in
let* () =
verify_digitally_signed `TLS_1_3
~context_string:"TLS 1.3, client CertificateVerify"
state.config.Config.signature_algorithms cv tbs
sd.common_session_data13.peer_certificate
in
let st = AwaitClientFinished13 (client_fini, dec_ctx, st, log ^ raw) in
Ok ({ state with machina = Server13 st ; session = `TLS13 sd :: state.session }, [])
let answer_client_finished state fin client_fini dec_ctx st raw log =
match state.session with
| `TLS13 session :: rest ->
let hash = Ciphersuite.hash13 session.ciphersuite13 in
let data = finished hash client_fini log in
let* () =
guard (String.equal data fin)
(`Fatal (`Handshake (`Message "couldn't verify finished")))
in
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let session' = match st, state.config.Config.ticket_cache with
| None, _ | _, None -> session
| Some st, Some cache ->
let resumption_secret = Handshake_crypto13.resumption session.master_secret (log ^ raw) in
let session = { session with resumption_secret } in
let secret = Handshake_crypto13.res_secret hash resumption_secret st.nonce in
let issued_at = cache.Config.timestamp () in
let psk = { identifier = st.ticket ; obfuscation = st.age_add ; secret ; lifetime = st.lifetime ; early_data = state.config.Config.zero_rtt ; issued_at } in
let epoch = epoch_of_session true None `TLS_1_3 (`TLS13 session) in
cache.Config.ticket_granted psk epoch ;
session
in
let state' = { state with machina = Server13 Established13 ; session = `TLS13 session' :: rest } in
Ok (state', [ `Change_dec dec_ctx ])
| _ -> Error (`Fatal (`Handshake (`Message "no session found in finished")))
let handle_end_of_early_data state cf hs_ctx cc st buf log =
let machina = AwaitClientFinished13 (cf, cc, st, log ^ buf) in
match state.session with
| `TLS13 s1 :: _ ->
let session = `TLS13 { s1 with state = `Established } :: state.session in
Ok ({ state with machina = Server13 machina ; session }, [ `Change_dec hs_ctx ])
| _ ->
Error (`Fatal (`Handshake (`Message "no session handling end of early data")))
let handle_key_update state req =
match state.session with
| `TLS13 session :: _ ->
let* () =
guard (String.length state.hs_fragment = 0)
(`Fatal (`Handshake `Fragments))
in
let client_app_secret, client_ctx =
app_secret_n_1 session.master_secret session.client_app_secret
in
let session' = { session with client_app_secret } in
let session', out = match req with
| Packet.UPDATE_NOT_REQUESTED -> session', []
| Packet.UPDATE_REQUESTED ->
let server_app_secret, server_ctx =
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 ]
in
let session = `TLS13 session' :: state.session in
let state' = { state with machina = Server13 Established13 ; session } in
Ok (state', `Change_dec client_ctx :: out)
| _ -> Error (`Fatal (`Handshake (`Message "no session while handling key update")))
let handle_handshake cs hs buf =
let* handshake = map_reader_error (Reader.parse_handshake buf) in
Tracing.hs ~tag:"handshake-in" handshake;
match cs, handshake with
| AwaitClientHelloHRR13, ClientHello ch ->
answer_client_hello ~hrr:true hs ch buf
| AwaitClientCertificate13 (sd, cf, cc, st, log), Certificate cert ->
answer_client_certificate hs cert sd cf cc st buf log
| AwaitClientCertificateVerify13 (sd, cf, cc, st, log), CertificateVerify cv ->
answer_client_certificate_verify hs cv sd cf cc st buf log
| AwaitClientFinished13 (cf, cc, st, log), Finished x ->
answer_client_finished hs x cf cc st buf log
| AwaitEndOfEarlyData13 (cf, hs_c, cc, st, log), EndOfEarlyData ->
handle_end_of_early_data hs cf hs_c cc st buf log
| Established13, KeyUpdate req ->
handle_key_update hs req
| _, hs -> Error (`Fatal (`Unexpected (`Handshake hs)))

621
unikernel/duniverse/ocaml-tls/lib/packet.ml Normal file
View file

@ -0,0 +1,621 @@
(** Magic numbers of the TLS protocol. *)
(* HACK: 24 bits type not in cstruct *)
let get_uint24_len ~off buf =
(String.get_uint16_be buf off) * 0x100 + (String.get_uint8 buf (off + 2))
let set_uint24_len ~off buf num =
Bytes.set_uint16_be buf off (num / 0x100);
Bytes.set_uint8 buf (off + 2) (num mod 0x100)
(* TLS record content type *)
type content_type =
| CHANGE_CIPHER_SPEC
| ALERT
| HANDSHAKE
| APPLICATION_DATA
let content_type_to_int = function
| CHANGE_CIPHER_SPEC -> 20
| ALERT -> 21
| HANDSHAKE -> 22
| APPLICATION_DATA -> 23
and int_to_content_type = function
| 20 -> Some CHANGE_CIPHER_SPEC
| 21 -> Some ALERT
| 22 -> Some HANDSHAKE
| 23 -> Some APPLICATION_DATA
| _ -> None
let content_type_to_string = function
| CHANGE_CIPHER_SPEC -> "change cipher spec"
| ALERT -> "alert"
| HANDSHAKE -> "handshake"
| APPLICATION_DATA -> "application data"
let pp_content_type ppf ct =
Fmt.string ppf (content_type_to_string ct)
(* TLS alert level *)
type alert_level =
| 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 *)
type alert_type =
| CLOSE_NOTIFY [@id 0] (*RFC5246*)
| UNEXPECTED_MESSAGE [@id 10] (*RFC5246*)
| BAD_RECORD_MAC [@id 20] (*RFC5246*)
| RECORD_OVERFLOW [@id 22] (*RFC5246*)
| HANDSHAKE_FAILURE [@id 40] (*RFC5246*)
| BAD_CERTIFICATE [@id 42] (*RFC5246*)
| CERTIFICATE_EXPIRED [@id 45] (*RFC5246*)
| CERTIFICATE_UNKNOWN [@id 46] (*RFC5246*)
| DECODE_ERROR [@id 50] (*RFC5246*)
| PROTOCOL_VERSION [@id 70] (*RFC5246*)
| INAPPROPRIATE_FALLBACK [@id 86] (*draft-ietf-tls-downgrade-scsv*)
| USER_CANCELED [@id 90] (*RFC5246*)
| NO_RENEGOTIATION [@id 100] (*RFC5246*)
| MISSING_EXTENSION [@id 109] (*RFC8446*)
| UNSUPPORTED_EXTENSION [@id 110] (*RFC5246*)
| UNRECOGNIZED_NAME [@id 112] (*RFC6066*)
| NO_APPLICATION_PROTOCOL [@id 120] (*RFC7301*)
| UNKNOWN of int
let alert_type_to_string = function
| CLOSE_NOTIFY -> "close notify"
| UNEXPECTED_MESSAGE -> "unexpected message"
| BAD_RECORD_MAC -> "bad record mac"
| RECORD_OVERFLOW -> "record overflow"
| HANDSHAKE_FAILURE -> "handshake failure"
| BAD_CERTIFICATE -> "bad certificate"
| CERTIFICATE_EXPIRED -> "certificate expired"
| CERTIFICATE_UNKNOWN -> "certificate unknown"
| DECODE_ERROR -> "decode error"
| PROTOCOL_VERSION -> "protocol version"
| INAPPROPRIATE_FALLBACK -> "inappropriate fallback"
| USER_CANCELED -> "user canceled"
| NO_RENEGOTIATION -> "no renegotiation"
| MISSING_EXTENSION -> "missing extension"
| UNSUPPORTED_EXTENSION -> "unsupported extension"
| UNRECOGNIZED_NAME -> "unrecognized name"
| NO_APPLICATION_PROTOCOL -> "no application protocol"
| UNKNOWN x -> "unknown " ^ string_of_int x
let alert_type_to_int = function
| CLOSE_NOTIFY -> 0 (*RFC5246*)
| UNEXPECTED_MESSAGE -> 10 (*RFC5246*)
| BAD_RECORD_MAC -> 20 (*RFC5246*)
| RECORD_OVERFLOW -> 22 (*RFC5246*)
| HANDSHAKE_FAILURE -> 40 (*RFC5246*)
| BAD_CERTIFICATE -> 42 (*RFC5246*)
| CERTIFICATE_EXPIRED -> 45 (*RFC5246*)
| CERTIFICATE_UNKNOWN -> 46 (*RFC5246*)
| DECODE_ERROR -> 50 (*RFC5246*)
| PROTOCOL_VERSION -> 70 (*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*)
| UNRECOGNIZED_NAME -> 112 (*RFC6066*)
| NO_APPLICATION_PROTOCOL -> 120 (*RFC7301*)
| UNKNOWN x -> x
and int_to_alert_type = function
| 0 -> CLOSE_NOTIFY
| 10 -> UNEXPECTED_MESSAGE
| 20 -> BAD_RECORD_MAC
| 22 -> RECORD_OVERFLOW
| 40 -> HANDSHAKE_FAILURE
| 42 -> BAD_CERTIFICATE
| 45 -> CERTIFICATE_EXPIRED
| 46 -> CERTIFICATE_UNKNOWN
| 50 -> DECODE_ERROR
| 70 -> PROTOCOL_VERSION
| 86 -> INAPPROPRIATE_FALLBACK
| 90 -> USER_CANCELED
| 100 -> NO_RENEGOTIATION
| 109 -> MISSING_EXTENSION
| 110 -> UNSUPPORTED_EXTENSION
| 112 -> UNRECOGNIZED_NAME
| 120 -> NO_APPLICATION_PROTOCOL
| x -> UNKNOWN x
let pp_alert ppf (lvl, typ) =
Fmt.pf ppf "ALERT %a %s" pp_alert_level lvl (alert_type_to_string typ)
(* TLS handshake type *)
type handshake_type =
| HELLO_REQUEST [@id 0]
| CLIENT_HELLO [@id 1]
| SERVER_HELLO [@id 2]
| HELLO_VERIFY_REQUEST [@id 3] (*RFC6347*)
| SESSION_TICKET [@id 4] (*RFC4507, RFC8446*)
| END_OF_EARLY_DATA [@id 5] (*RFC8446*)
| ENCRYPTED_EXTENSIONS [@id 8] (*RFC8446*)
| CERTIFICATE [@id 11]
| SERVER_KEY_EXCHANGE [@id 12]
| CERTIFICATE_REQUEST [@id 13]
| SERVER_HELLO_DONE [@id 14]
| CERTIFICATE_VERIFY [@id 15]
| CLIENT_KEY_EXCHANGE [@id 16]
| FINISHED [@id 20]
| CERTIFICATE_URL [@id 21] (*RFC4366*)
| CERTIFICATE_STATUS [@id 22] (*RFC4366*)
| SUPPLEMENTAL_DATA [@id 23] (*RFC4680*)
| KEY_UPDATE [@id 24] (*RFC8446*)
| MESSAGE_HASH [@id 254] (*RFC8446*)
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 *)
type client_certificate_type =
| RSA_SIGN [@id 1] (*RFC5246*)
| ECDSA_SIGN [@id 64] (*RFC4492*)
let client_certificate_type_to_int = function
| RSA_SIGN -> 1 (*RFC5246*)
| ECDSA_SIGN -> 64 (*RFC4492*)
and int_to_client_certificate_type = function
| 1 -> Some RSA_SIGN
| 64 -> Some ECDSA_SIGN
| _ -> None
(* TLS compression methods, used in hello packets *)
type compression_method =
| NULL [@id 0]
let compression_method_to_int = function
| NULL -> 0
and int_to_compression_method = function
| 0 -> Some NULL
| _ -> None
(* TLS extensions in hello packets from RFC 6066, formerly RFC 4366 *)
type extension_type =
| SERVER_NAME [@id 0]
| MAX_FRAGMENT_LENGTH [@id 1]
| SUPPORTED_GROUPS [@id 10] (*RFC4492, RFC8446*)
| EC_POINT_FORMATS [@id 11] (*RFC4492*)
| SIGNATURE_ALGORITHMS [@id 13] (*RFC5246*)
| APPLICATION_LAYER_PROTOCOL_NEGOTIATION [@id 16] (*RFC7301*)
| PADDING [@id 21] (*RFC7685*)
| EXTENDED_MASTER_SECRET [@id 23] (*RFC7627*)
| SESSION_TICKET [@id 35] (*RFC4507*)
| PRE_SHARED_KEY [@id 41] (*RFC8446*)
| EARLY_DATA [@id 42] (*RFC8446*)
| SUPPORTED_VERSIONS [@id 43] (*RFC8446*)
| COOKIE [@id 44] (*RFC8446*)
| PSK_KEY_EXCHANGE_MODES [@id 45] (*RFC8446*)
| CERTIFICATE_AUTHORITIES [@id 47] (*RFC8446*)
| POST_HANDSHAKE_AUTH [@id 49] (*RFC8446*)
| KEY_SHARE [@id 51] (*RFC8446*)
| RENEGOTIATION_INFO [@id 0xFF01] (*RFC5746*)
let extension_type_to_int = function
| SERVER_NAME -> 0
| MAX_FRAGMENT_LENGTH -> 1
| SUPPORTED_GROUPS -> 10 (*RFC4492, RFC8446*)
| EC_POINT_FORMATS -> 11 (*RFC4492*)
| SIGNATURE_ALGORITHMS -> 13 (*RFC5246*)
| APPLICATION_LAYER_PROTOCOL_NEGOTIATION -> 16 (*RFC7301*)
| PADDING -> 21 (*RFC7685*)
| EXTENDED_MASTER_SECRET -> 23 (*RFC7627*)
| 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*)
| POST_HANDSHAKE_AUTH -> 49 (*RFC8446*)
| KEY_SHARE -> 51 (*RFC8446*)
| RENEGOTIATION_INFO -> 0xFF01 (*RFC5746*)
and int_to_extension_type = function
| 0 -> Some SERVER_NAME
| 1 -> Some MAX_FRAGMENT_LENGTH
| 10 -> Some SUPPORTED_GROUPS
| 11 -> Some EC_POINT_FORMATS
| 13 -> Some SIGNATURE_ALGORITHMS
| 16 -> Some APPLICATION_LAYER_PROTOCOL_NEGOTIATION
| 21 -> Some PADDING
| 23 -> Some EXTENDED_MASTER_SECRET
| 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
| 49 -> Some POST_HANDSHAKE_AUTH
| 51 -> Some KEY_SHARE
| 0xFF01 -> Some RENEGOTIATION_INFO
| _ -> None
let extension_type_to_string et = string_of_int (extension_type_to_int et)
(* TLS maximum fragment length *)
type max_fragment_length =
| TWO_9 [@id 1]
| TWO_10 [@id 2]
| TWO_11 [@id 3]
| TWO_12 [@id 4]
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) *)
type psk_key_exchange_mode =
| PSK_KE [@id 0]
| PSK_KE_DHE [@id 1]
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 *)
type signature_alg =
| RSA_PKCS1_MD5 [@id 0x0101] (* deprecated, TLS 1.2 only *)
| RSA_PKCS1_SHA1 [@id 0x0201] (* deprecated, TLS 1.2 only *)
| RSA_PKCS1_SHA224 [@id 0x0301]
| RSA_PKCS1_SHA256 [@id 0x0401]
| RSA_PKCS1_SHA384 [@id 0x0501]
| RSA_PKCS1_SHA512 [@id 0x0601]
| ECDSA_SECP256R1_SHA1 [@id 0x0203] (* deprecated, TLS 1.2 only *)
| ECDSA_SECP256R1_SHA256 [@id 0x0403]
| ECDSA_SECP384R1_SHA384 [@id 0x0503]
| ECDSA_SECP521R1_SHA512 [@id 0x0603]
| RSA_PSS_RSAENC_SHA256 [@id 0x0804]
| RSA_PSS_RSAENC_SHA384 [@id 0x0805]
| RSA_PSS_RSAENC_SHA512 [@id 0x0806]
| ED25519 [@id 0x0807]
| ED448 [@id 0x0808]
| RSA_PSS_PSS_SHA256 [@id 0x0809]
| RSA_PSS_PSS_SHA384 [@id 0x080a]
| RSA_PSS_PSS_SHA512 [@id 0x080b]
(* private use 0xFE00 - 0xFFFF *)
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
| `RSA_PKCS1_SHA1 -> RSA_PKCS1_SHA1
| `RSA_PKCS1_SHA224 -> RSA_PKCS1_SHA224
| `RSA_PKCS1_SHA256 -> RSA_PKCS1_SHA256
| `RSA_PKCS1_SHA384 -> RSA_PKCS1_SHA384
| `RSA_PKCS1_SHA512 -> RSA_PKCS1_SHA512
| `RSA_PSS_RSAENC_SHA256 -> RSA_PSS_RSAENC_SHA256
| `RSA_PSS_RSAENC_SHA384 -> RSA_PSS_RSAENC_SHA384
| `RSA_PSS_RSAENC_SHA512 -> RSA_PSS_RSAENC_SHA512
| `ECDSA_SECP256R1_SHA1 -> ECDSA_SECP256R1_SHA1
| `ECDSA_SECP256R1_SHA256 -> ECDSA_SECP256R1_SHA256
| `ECDSA_SECP384R1_SHA384 -> ECDSA_SECP384R1_SHA384
| `ECDSA_SECP521R1_SHA512 -> ECDSA_SECP521R1_SHA512
| `ED25519 -> ED25519
let of_signature_alg = function
| RSA_PKCS1_MD5 -> Some `RSA_PKCS1_MD5
| RSA_PKCS1_SHA1 -> Some `RSA_PKCS1_SHA1
| RSA_PKCS1_SHA224 -> Some `RSA_PKCS1_SHA224
| RSA_PKCS1_SHA256 -> Some `RSA_PKCS1_SHA256
| RSA_PKCS1_SHA384 -> Some `RSA_PKCS1_SHA384
| RSA_PKCS1_SHA512 -> Some `RSA_PKCS1_SHA512
| RSA_PSS_RSAENC_SHA256 -> Some `RSA_PSS_RSAENC_SHA256
| RSA_PSS_RSAENC_SHA384 -> Some `RSA_PSS_RSAENC_SHA384
| RSA_PSS_RSAENC_SHA512 -> Some `RSA_PSS_RSAENC_SHA512
| ECDSA_SECP256R1_SHA1 -> Some `ECDSA_SECP256R1_SHA1
| ECDSA_SECP256R1_SHA256 -> Some `ECDSA_SECP256R1_SHA256
| ECDSA_SECP384R1_SHA384 -> Some `ECDSA_SECP384R1_SHA384
| ECDSA_SECP521R1_SHA512 -> Some `ECDSA_SECP521R1_SHA512
| ED25519 -> Some `ED25519
| _ -> None
(* EC RFC4492*)
type ec_curve_type =
(* 1 and 2 are deprecated in RFC 8422 *)
| NAMED_CURVE [@id 3]
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]
| SECP384R1 [@id 24]
| SECP521R1 [@id 25]
(* OBSOLETE_RESERVED 0x001A - 0x001C *)
| X25519 [@id 29] (*RFC8446*)
| X448 [@id 30] (*RFC8446*)
| FFDHE2048 [@id 256] (*RFC8446*)
| FFDHE3072 [@id 257] (*RFC8446*)
| FFDHE4096 [@id 258] (*RFC8446*)
| FFDHE6144 [@id 259] (*RFC8446*)
| FFDHE8192 [@id 260] (*RFC8446*)
(* FFDHE_PRIVATE_USE 0x01FC - 0x01FF *)
(* ECDHE_PRIVATE_USE 0xFE00 - 0xFEFF *)
(* OBSOLETE_RESERVED 0xFF01 - 0xFF02 *)
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 *)
type any_ciphersuite =
| TLS_RSA_WITH_3DES_EDE_CBC_SHA [@id 0x000A]
| TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA [@id 0x0016]
(* from RFC 3268 *)
| TLS_RSA_WITH_AES_128_CBC_SHA [@id 0x002F]
| TLS_DHE_RSA_WITH_AES_128_CBC_SHA [@id 0x0033]
| TLS_RSA_WITH_AES_256_CBC_SHA [@id 0x0035]
| TLS_DHE_RSA_WITH_AES_256_CBC_SHA [@id 0x0039]
(* from RFC 5246 *)
| TLS_RSA_WITH_AES_128_CBC_SHA256 [@id 0x003C]
| TLS_RSA_WITH_AES_256_CBC_SHA256 [@id 0x003D]
| TLS_DHE_RSA_WITH_AES_128_CBC_SHA256 [@id 0x0067]
| TLS_DHE_RSA_WITH_AES_256_CBC_SHA256 [@id 0x006B]
| TLS_RSA_WITH_AES_128_GCM_SHA256 [@id 0x009C] (*RFC5288*)
| TLS_RSA_WITH_AES_256_GCM_SHA384 [@id 0x009D] (*RFC5288*)
| TLS_DHE_RSA_WITH_AES_128_GCM_SHA256 [@id 0x009E] (*RFC5288*)
| TLS_DHE_RSA_WITH_AES_256_GCM_SHA384 [@id 0x009F] (*RFC5288*)
| TLS_EMPTY_RENEGOTIATION_INFO_SCSV [@id 0x00FF] (*RFC5746*)
| TLS_AES_128_GCM_SHA256 [@id 0x1301] (*RFC8446*)
| TLS_AES_256_GCM_SHA384 [@id 0x1302] (*RFC8446*)
| TLS_CHACHA20_POLY1305_SHA256 [@id 0x1303] (*RFC8446*)
| TLS_AES_128_CCM_SHA256 [@id 0x1304] (*RFC8446*)
| TLS_FALLBACK_SCSV [@id 0x5600] (*draft-ietf-tls-downgrade-scsv*)
(* from RFC 4492 *)
| TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA [@id 0xC008]
| TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA [@id 0xC009]
| TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA [@id 0xC00A]
| TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA [@id 0xC012]
| TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA [@id 0xC013]
| TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA [@id 0xC014]
| TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 [@id 0xC023] (*RFC5289*)
| TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384 [@id 0xC024] (*RFC5289*)
| TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256 [@id 0xC027] (*RFC5289*)
| TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384 [@id 0xC028] (*RFC5289*)
| TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 [@id 0xC02B] (*RFC5289*)
| TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 [@id 0xC02C] (*RFC5289*)
| TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256 [@id 0xC02F] (*RFC5289*)
| TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384 [@id 0xC030] (*RFC5289*)
| TLS_RSA_WITH_AES_128_CCM [@id 0xC09C] (*RFC6655*)
| TLS_RSA_WITH_AES_256_CCM [@id 0xC09D] (*RFC6655*)
| TLS_DHE_RSA_WITH_AES_128_CCM [@id 0xC09E] (*RFC6655*)
| TLS_DHE_RSA_WITH_AES_256_CCM [@id 0xC09F] (*RFC6655*)
| 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*)
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]
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 = Digestif.SHA256.(to_raw_string (digest_string "HelloRetryRequest"))
let downgrade12 = "\x44\x4F\x57\x4E\x47\x52\x44\x01"
let downgrade11 = "\x44\x4F\x57\x4E\x47\x52\x44\x00"

815
unikernel/duniverse/ocaml-tls/lib/reader.ml Normal file
View file

@ -0,0 +1,815 @@
open Packet
open Core
type error =
| TrailingBytes of string
| WrongLength of string
| Unknown of string
exception Reader_error of error
let raise_unknown msg = raise (Reader_error (Unknown msg))
and raise_wrong_length msg = raise (Reader_error (WrongLength msg))
and raise_trailing_bytes msg = raise (Reader_error (TrailingBytes msg))
let shift str amount = String.sub str amount (String.length str - amount)
let catch f x =
try Ok (f x) with
| Reader_error TrailingBytes msg -> Error (`Decode ("trailing bytes: " ^ msg))
| Reader_error WrongLength msg -> Error (`Decode ("wrong length: " ^ msg))
| Reader_error Unknown msg -> Error (`Decode msg)
| Invalid_argument msg -> Error (`Decode msg)
let parse_version_int buf =
let major = String.get_uint8 buf 0 in
let minor = String.get_uint8 buf 1 in
(major, minor)
let parse_version_exn buf =
let version = parse_version_int buf in
match tls_version_of_pair version with
| Some x -> x
| None -> raise_unknown "version"
let parse_any_version_opt buf =
let version = parse_version_int buf in
tls_any_version_of_pair version, shift buf 2
let parse_any_version_exn buf =
match parse_any_version_opt buf with
| Some x, _ -> x
| None, _ -> raise_unknown "version"
let parse_version = catch parse_version_exn
let parse_any_version = catch parse_any_version_exn
let parse_record buf =
if String.length buf < 5 then
Ok (`Fragment buf)
else
let typ = String.get_uint8 buf 0
and version = parse_version_int (shift buf 1)
in
match String.get_uint16_be buf 3 with
| x when x > (1 lsl 14 + 2048) ->
(* 2 ^ 14 + 2048 for TLSCiphertext
2 ^ 14 + 1024 for TLSCompressed
2 ^ 14 for TLSPlaintext *)
Error (`Record_overflow x)
| x when 5 + x > String.length buf -> Ok (`Fragment buf)
| x ->
match
tls_any_version_of_pair version,
int_to_content_type typ
with
| None, _ -> Error (`Protocol_version (`Unknown_record version))
| _, None -> Error (`Unexpected (`Content_type typ))
| Some version, Some content_type ->
let payload, rest = split_str ~start:5 buf x in
Ok (`Record (({ content_type ; version }, payload), rest))
let validate_alert (lvl, typ) =
let open Packet in
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 | BAD_RECORD_MAC | RECORD_OVERFLOW
| HANDSHAKE_FAILURE | BAD_CERTIFICATE | DECODE_ERROR
| PROTOCOL_VERSION | INAPPROPRIATE_FALLBACK | MISSING_EXTENSION
| UNSUPPORTED_EXTENSION | UNRECOGNIZED_NAME |
NO_APPLICATION_PROTOCOL as x) ->
raise_unknown (alert_type_to_string x ^ " must always be fatal")
(* those are always warnings *)
| FATAL, (USER_CANCELED | NO_RENEGOTIATION as x) ->
raise_unknown (alert_type_to_string x ^ " must always be a warning")
| lvl, typ -> (lvl, typ)
let parse_alert = catch @@ fun buf ->
if String.length buf <> 2 then
raise_trailing_bytes "after alert"
else
let level = String.get_uint8 buf 0 in
let typ = String.get_uint8 buf 1 in
match int_to_alert_level level, int_to_alert_type typ with
| (Some lvl, msg) -> validate_alert (lvl, msg)
| _ -> raise_unknown @@ "alert level " ^ string_of_int level
let parse_change_cipher_spec buf =
match String.length buf, String.get_uint8 buf 0 with
| 1, 1 -> Ok ()
| _ -> Error (`Decode "bad change cipher spec message")
let rec parse_count_list parsef buf acc = function
| 0 -> (List.rev acc, buf)
| n ->
match parsef buf with
| Some elem, buf' -> parse_count_list parsef buf' (elem :: acc) (pred n)
| None , buf' -> parse_count_list parsef buf' acc (pred n)
let rec parse_list parsef buf acc =
match String.length buf with
| 0 -> List.rev acc
| _ ->
match parsef buf with
| Some elem, buf' -> parse_list parsef buf' (elem :: acc)
| None , buf' -> parse_list parsef buf' acc
let parse_compression_method buf =
let cm = String.get_uint8 buf 0 in
(int_to_compression_method cm, shift buf 1)
let parse_compression_methods buf =
let count = String.get_uint8 buf 0 in
parse_count_list parse_compression_method (shift buf 1) [] count
let parse_any_ciphersuite buf =
let typ = String.get_uint16_be buf 0 in
(int_to_any_ciphersuite typ, shift buf 2)
let parse_any_ciphersuites buf =
let count = String.get_uint16_be buf 0 in
if count mod 2 <> 0 then
raise_wrong_length "ciphersuite list"
else
parse_count_list parse_any_ciphersuite (shift buf 2) [] (count / 2)
let parse_ciphersuite buf =
match parse_any_ciphersuite buf with
| None , buf' -> (None, buf')
| Some cs, buf' -> match Ciphersuite.any_ciphersuite_to_ciphersuite cs with
| None -> (None, buf')
| Some cs' -> (Some cs', buf')
let parse_hostnames buf =
match String.length buf with
| 0 -> []
| n ->
let parsef buf =
let typ = String.get_uint8 buf 0 in
let entrylen = String.get_uint16_be buf 1 in
let rt = shift buf (3 + entrylen) in
match typ with
| 0 -> let hostname = String.sub buf 3 entrylen in
(Some hostname, rt)
| _ -> (None, rt)
in
let list_length = String.get_uint16_be buf 0 in
if list_length + 2 <> n then
raise_trailing_bytes "hostname"
else
parse_list parsef (String.sub buf 2 list_length) []
let parse_fragment_length buf =
if String.length buf <> 1 then
raise_trailing_bytes "fragment length"
else
int_to_max_fragment_length (String.get_uint8 buf 0)
let parse_supported_version buf =
parse_any_version_opt buf
let parse_supported_versions buf =
let len = String.get_uint8 buf 0 in
if len mod 2 <> 0 then
raise_wrong_length "supported versions"
else
parse_count_list parse_supported_version (shift buf 1) [] (len / 2)
let parse_named_group buf =
let typ = String.get_uint16_be buf 0 in
(int_to_named_group typ, shift buf 2)
let parse_group buf =
match parse_named_group buf with
| Some x, buf -> (named_group_to_group x, buf)
| None, buf -> (None, buf)
let parse_supported_groups buf =
let count = String.get_uint16_be buf 0 in
if count mod 2 <> 0 then
raise_wrong_length "elliptic curve list"
else
let cs, rt = parse_count_list parse_named_group (shift buf 2) [] (count / 2) in
if String.length rt <> 0 then
raise_trailing_bytes "elliptic curves"
else
cs
let parse_signature_algorithm buf =
match int_to_signature_alg (String.get_uint16_be buf 0) with
| Some sig_alg -> of_signature_alg sig_alg
| _ -> None
let parse_signature_algorithms buf =
let parsef buf = parse_signature_algorithm buf, shift buf 2 in
let count = String.get_uint16_be buf 0 in
if count mod 2 <> 0 then
raise_wrong_length "signature hash"
else
parse_count_list parsef (shift buf 2) [] (count / 2)
let parse_alpn_protocol raw =
let length = String.get_uint8 raw 0 in
let protocol = String.sub raw 1 length in
(Some protocol, shift raw (1 + length))
let parse_alpn_protocols buf =
let len = String.get_uint16_be buf 0 in
if String.length buf <> len + 2 then
raise_trailing_bytes "alpn"
else
parse_list parse_alpn_protocol (String.sub buf 2 len) []
let parse_ec_point_format buf =
(* this is deprecated, we only check that uncompressed (typ 0) is present *)
let data = String.get_uint8 buf 0 in
Some (data = 0), shift buf 1
let parse_ec_point_formats buf =
let count = String.get_uint8 buf 0 in
parse_count_list parse_ec_point_format (shift buf 1) [] count
let parse_extension buf = function
| MAX_FRAGMENT_LENGTH ->
(match parse_fragment_length buf with
| Some mfl -> `MaxFragmentLength mfl
| None -> raise_unknown "maximum fragment length")
| RENEGOTIATION_INFO ->
let len' = String.get_uint8 buf 0 in
if String.length buf <> len' + 1 then
raise_trailing_bytes "renegotiation"
else
`SecureRenegotiation (String.sub buf 1 len')
| EXTENDED_MASTER_SECRET ->
if String.length buf > 0 then
raise_trailing_bytes "extended master secret"
else
`ExtendedMasterSecret
| EC_POINT_FORMATS ->
let formats, rt = parse_ec_point_formats buf in
if String.length rt <> 0 then
raise_trailing_bytes "ec point formats"
else if List.mem true formats then
`ECPointFormats
else
raise_unknown "EC Point Formats without uncompressed"
| x -> `UnknownExtension (extension_type_to_int x, buf)
let parse_keyshare_entry buf =
let parse_share data =
let size = String.get_uint16_be data 0 in
split_str ~start:2 data size
in
let g, rest = parse_named_group buf in
let share, left = parse_share rest in
match g with
| None -> None, left
| Some g -> Some (g, share), left
let parse_id buf =
let id_len = String.get_uint16_be buf 0 in
if id_len = 0 then (* id must be non-empty! *)
raise_wrong_length "PSK id is empty"
else
let age = String.get_int32_be buf (id_len + 2) in
(Some (String.sub buf 2 id_len, age), shift buf (id_len + 6))
let parse_binder buf =
let l = String.get_uint8 buf 0 in
Some (String.sub buf 1 l), shift buf (l + 1)
let parse_client_presharedkeys buf =
let id_len = String.get_uint16_be buf 0 in
let identities = parse_list parse_id (String.sub buf 2 id_len) [] in
let binders_len = String.get_uint16_be buf (id_len + 2) in
let binders = parse_list parse_binder (String.sub buf (4 + id_len) binders_len) [] in
let id_binder = List.combine identities binders in
if String.length buf <> 4 + binders_len + id_len then
raise_trailing_bytes "psk"
else
id_binder
let parse_cookie buf =
let len = String.get_uint16_be buf 0 in
(String.sub buf 2 len, shift buf (2 + len))
let parse_psk_key_exchange_mode buf =
let data = String.get_uint8 buf 0 in
(int_to_psk_key_exchange_mode data, shift buf 1)
let parse_psk_key_exchange_modes buf =
let count = String.get_uint8 buf 0 in
parse_count_list parse_psk_key_exchange_mode (shift buf 1) [] count
let parse_ext raw =
let etype = String.get_uint16_be raw 0
and length = String.get_uint16_be raw 2
in
(etype, length, String.sub raw 4 length)
let parse_client_extension raw =
let etype, len, buf = parse_ext raw in
let data =
match int_to_extension_type etype with
| Some SERVER_NAME ->
(match parse_hostnames buf with
| [name] ->
(match Domain_name.of_string name with
| Error (`Msg err) ->
raise_unknown ("unable to canonicalize " ^ name ^ "into a domain name: " ^ err)
| Ok domain_name ->
(match Domain_name.host domain_name with
| Error (`Msg err) ->
raise_unknown ("unable to build a hostname from " ^ name ^ ": " ^ err)
| Ok hostname -> `Hostname hostname))
| _ -> raise_unknown "bad server name indication (multiple names)")
| Some SUPPORTED_GROUPS ->
let gs = parse_supported_groups buf in
`SupportedGroups gs
| Some PADDING ->
let rec check = function
| 0 -> `Padding len
| n -> let idx = pred n in
if String.get_uint8 buf idx <> 0 then
raise_unknown "bad padding in padding extension"
else
check idx
in
check len
| Some SIGNATURE_ALGORITHMS ->
let algos, rt = parse_signature_algorithms buf in
if String.length rt <> 0 then
raise_trailing_bytes "signature algorithms"
else
`SignatureAlgorithms algos
| Some APPLICATION_LAYER_PROTOCOL_NEGOTIATION ->
let protocols = parse_alpn_protocols buf in
`ALPN protocols
| Some KEY_SHARE ->
let ll = String.get_uint16_be buf 0 in
if ll + 2 <> String.length buf then
raise_unknown "bad key share extension"
else
let shares = parse_list parse_keyshare_entry (String.sub buf 2 ll) [] in
`KeyShare shares
| Some PRE_SHARED_KEY ->
let ids = parse_client_presharedkeys buf in
`PreSharedKeys ids
| Some EARLY_DATA ->
if String.length buf <> 0 then
raise_trailing_bytes "early data"
else
`EarlyDataIndication
| Some SUPPORTED_VERSIONS ->
let versions, rt = parse_supported_versions buf in
if String.length rt <> 0 then
raise_trailing_bytes "supported versions"
else
`SupportedVersions versions
| Some POST_HANDSHAKE_AUTH ->
if String.length buf = 0 then
`PostHandshakeAuthentication
else
raise_unknown "non-empty post handshake authentication"
| Some COOKIE ->
let c, rt = parse_cookie buf in
if String.length rt <> 0 then
raise_trailing_bytes "cookie"
else
`Cookie c
| Some PSK_KEY_EXCHANGE_MODES ->
let modes, rt = parse_psk_key_exchange_modes buf in
if String.length rt <> 0 then
raise_trailing_bytes "psk key exchange modes"
else
`PskKeyExchangeModes modes
| Some x -> parse_extension buf x
| None -> `UnknownExtension (etype, buf)
in
(Some data, shift raw (4 + len))
let parse_server_extension raw =
let etype, len, buf = parse_ext raw in
let data =
match int_to_extension_type etype with
| Some SERVER_NAME ->
(match parse_hostnames buf with
| [] -> `Hostname
| _ -> raise_unknown "bad server name indication (multiple names)")
| Some KEY_SHARE ->
(match parse_keyshare_entry buf with
| _, xs when String.length xs <> 0 -> raise_trailing_bytes "server keyshare"
| None, _ -> raise_unknown "keyshare entry"
| Some (g, ks), _ ->
match named_group_to_group g with
| Some g -> `KeyShare (g, ks)
| None -> raise_unknown "keyshare entry")
| Some PRE_SHARED_KEY ->
if String.length buf <> 2 then
raise_trailing_bytes "server pre_shared_key"
else
`PreSharedKey (String.get_uint16_be buf 0)
| Some SUPPORTED_GROUPS | Some SIGNATURE_ALGORITHMS | Some PADDING ->
raise_unknown "invalid extension in server hello!"
| Some APPLICATION_LAYER_PROTOCOL_NEGOTIATION ->
(match parse_alpn_protocols buf with
| [protocol] -> `ALPN protocol
| _ -> raise_unknown "bad ALPN (none or multiple names)")
| Some SUPPORTED_VERSIONS ->
let version = parse_version_exn buf in
`SelectedVersion version
| Some x -> parse_extension buf x
| None -> `UnknownExtension (etype, buf)
in
(Some data, shift raw (4 + len))
let parse_encrypted_extension raw =
let etype, len, buf = parse_ext raw in
let data =
match int_to_extension_type etype with
| Some SERVER_NAME ->
(match parse_hostnames buf with
| [] -> `Hostname
| _ -> raise_unknown "bad server name indication (multiple names)")
| Some SUPPORTED_GROUPS ->
let gs = parse_supported_groups buf in
let supported = List.filter_map named_group_to_group gs in
`SupportedGroups supported
| Some APPLICATION_LAYER_PROTOCOL_NEGOTIATION ->
(match parse_alpn_protocols buf with
| [protocol] -> `ALPN protocol
| _ -> raise_unknown "bad ALPN (none or multiple names)")
| Some EARLY_DATA ->
if String.length buf <> 0 then
raise_trailing_bytes "server early_data"
else
`EarlyDataIndication
| Some x -> raise_unknown ("bad encrypted extension " ^ (extension_type_to_string x)) (* TODO maybe unknown instead? *)
| None -> `UnknownExtension (etype, buf)
in
(Some data, shift raw (4 + len))
let parse_retry_extension raw =
let etype, len, buf = parse_ext raw in
let data =
match int_to_extension_type etype with
| Some KEY_SHARE ->
begin
let group, rt = parse_group buf in
if String.length rt <> 0 then
raise_trailing_bytes "key share"
else
match group with
| None -> raise_unknown "unknown group in key share"
| Some g -> `SelectedGroup g
end
| Some SUPPORTED_VERSIONS ->
let version = parse_version_exn buf in
`SelectedVersion version
| Some COOKIE ->
let c, rt = parse_cookie buf in
if String.length rt <> 0 then
raise_trailing_bytes "cookie"
else
`Cookie c
| _ -> `UnknownExtension (etype, buf)
in
(Some data, shift raw (4 + len))
let parse_extensions parse_ext buf =
let len = String.get_uint16_be buf 0 in
if String.length buf <> len + 2 then
raise_trailing_bytes "extensions"
else
parse_list parse_ext (String.sub buf 2 len) []
let parse_client_hello buf =
let client_version = parse_any_version_exn buf in
let client_random = String.sub buf 2 32 in
let slen = String.get_uint8 buf 34 in
let sessionid = if slen = 0 then None else Some (String.sub buf 35 slen) in
let ciphersuites, rt = parse_any_ciphersuites (shift buf (35 + slen)) in
let _, rt' = parse_compression_methods rt in
let extensions =
if String.length rt' = 0 then [] else parse_extensions parse_client_extension rt'
in
(* TLS 1.3 mandates PreSharedKeys to be the last extension *)
(if List.exists (function `PreSharedKeys _ -> true | _ -> false) extensions then
match List.rev extensions with
| `PreSharedKeys _::_ -> ()
| _ -> raise_unknown "Pre-shared key extension exists, but is not the last");
ClientHello { client_version ; client_random ; sessionid ; ciphersuites ; extensions }
let parse_server_hello buf =
let server_version = parse_version_exn buf in
let server_random = String.sub buf 2 32 in
let slen = String.get_uint8 buf 34 in
let sessionid = if slen = 0 then None else Some (String.sub buf 35 slen) in
let ciphersuite, rt = match parse_ciphersuite (shift buf (35 + slen)) with
| Some x, buf' -> (x, buf')
| None , _ -> raise_unknown "ciphersuite"
in
let rt' = match parse_compression_method rt with
| Some NULL, buf' -> buf'
| None , _ -> raise_unknown "compression method"
in
(* depending on the content of the server_random we have to diverge in behaviour *)
if String.equal server_random helloretryrequest then begin
(* hello retry request, TODO: verify compression=empty *)
match Ciphersuite.ciphersuite_to_ciphersuite13 ciphersuite with
| None -> raise_unknown "unsupported ciphersuite in hello retry request"
| Some ciphersuite ->
let extensions =
if String.length rt' = 0 then [] else parse_extensions parse_retry_extension rt'
in
let retry_version =
match Utils.map_find ~f:(function `SelectedVersion v -> Some v | _ -> None) extensions with
| None -> server_version
| Some v -> v
in
let selected_group =
match Utils.map_find ~f:(function `SelectedGroup g -> Some g | _ -> None) extensions with
| None -> raise_unknown "unknown selected group"
| Some g -> g
in
HelloRetryRequest { retry_version ; sessionid ; ciphersuite ; selected_group ; extensions }
end else begin
let extensions =
if String.length rt' = 0 then [] else parse_extensions parse_server_extension rt'
in
let server_version =
match Utils.map_find ~f:(function `SelectedVersion v -> Some v | _ -> None) extensions with
| None -> server_version
| Some v -> v
in
ServerHello { server_version ; server_random ; sessionid ; ciphersuite ; extensions }
end
let parse_certificates_exn buf =
let parsef buf =
let len = get_uint24_len ~off:0 buf in
(Some (String.sub buf 3 len), shift buf (len + 3))
in
let len = get_uint24_len ~off:0 buf in
if String.length buf <> len + 3 then
raise_trailing_bytes "certificates"
else
parse_list parsef (String.sub buf 3 len) []
let parse_certificates = catch @@ parse_certificates_exn
(* TODO finish implementation of certificate extensions *)
let parse_certificate_ext _ = None, ""
let parse_certificate_ext_1_3_exn buf =
let certlen = get_uint24_len ~off:0 buf in
let cert, extbuf, rest =
let cert, rt = split_str ~start:3 buf certlen in
let ext_len = String.get_uint16_be rt 0 in
let extbuf, rt = split_str ~start:2 rt ext_len in
cert, extbuf, rt
in
let exts = parse_list parse_certificate_ext extbuf [] in
(Some (cert, exts), rest)
let parse_certificate_ext_list_1_3_exn buf =
let len = get_uint24_len ~off:0 buf in
if String.length buf <> len + 3 then
raise_trailing_bytes "certificates"
else
parse_list parse_certificate_ext_1_3_exn (shift buf 3) []
let parse_certificates_1_3_exn buf =
let clen = String.get_uint8 buf 0 in
let context, rt = split_str ~start:1 buf clen in
let certs = parse_certificate_ext_list_1_3_exn rt in
(context, certs)
let parse_certificates_1_3 = catch @@ parse_certificates_1_3_exn
let parse_certificate_types buf =
let parsef buf =
let byte = String.get_uint8 buf 0 in
(int_to_client_certificate_type byte, shift buf 1)
in
let count = String.get_uint8 buf 0 in
parse_count_list parsef (shift buf 1) [] count
let parse_cas buf =
let parsef buf =
let length = String.get_uint16_be buf 0 in
let name = String.sub buf 2 length in
(Some name, shift buf (2 + length))
in
let calength = String.get_uint16_be buf 0 in
let cas, rt = split_str ~start:2 buf calength in
(parse_list parsef cas [], rt)
let parse_certificate_request_exn buf =
let certificate_types, buf' = parse_certificate_types buf in
let certificate_authorities, buf' = parse_cas buf' in
if String.length buf' <> 0 then
raise_trailing_bytes "certificate request"
else
(certificate_types, certificate_authorities)
let parse_certificate_request =
catch parse_certificate_request_exn
let parse_certificate_request_1_2_exn buf =
let certificate_types, buf' = parse_certificate_types buf in
let sigs, buf' = parse_signature_algorithms buf' in
let cas, buf' = parse_cas buf' in
if String.length buf' <> 0 then
raise_trailing_bytes "certificate request"
else
(certificate_types, sigs, cas)
let parse_certificate_request_1_2 =
catch parse_certificate_request_1_2_exn
let parse_certificate_request_extension raw =
let etype, len, buf = parse_ext raw in
let data = match int_to_extension_type etype with
| Some SIGNATURE_ALGORITHMS ->
let algos, rt = parse_signature_algorithms buf in
if String.length rt <> 0 then
raise_trailing_bytes "signature algorithms"
else
`SignatureAlgorithms algos
| Some CERTIFICATE_AUTHORITIES ->
let cas, rt = parse_cas buf in
if String.length rt <> 0 then
raise_trailing_bytes "certificate authorities"
else
let cas = List.fold_left (fun cas buf ->
match X509.Distinguished_name.decode_der buf with
| Ok ca -> ca :: cas
| Error _ -> cas)
[] cas
in
`CertificateAuthorities (List.rev cas)
| _ -> `UnknownExtension (etype, buf)
in
(Some data, shift raw (4 + len))
let parse_certificate_request_1_3_exn buf =
let contextlen = String.get_uint8 buf 0 in
let context, rt =
if contextlen = 0 then
None, shift buf 1
else
let ctx, rest = split_str ~start:1 buf contextlen in
Some ctx, rest
in
let exts = parse_extensions parse_certificate_request_extension rt in
(context, exts)
let parse_certificate_request_1_3 =
catch parse_certificate_request_1_3_exn
let parse_dh_parameters = catch @@ fun raw ->
let plength = String.get_uint16_be raw 0 in
let dh_p = String.sub raw 2 plength in
let buf = shift raw (2 + plength) in
let glength = String.get_uint16_be buf 0 in
let dh_g = String.sub buf 2 glength in
let buf = shift buf (2 + glength) in
let yslength = String.get_uint16_be buf 0 in
let dh_Ys = String.sub buf 2 yslength in
let buf = shift buf (2 + yslength) in
let rawparams = String.sub raw 0 (plength + glength + yslength + 6) in
({ dh_p ; dh_g ; dh_Ys }, rawparams, buf)
let parse_ec_parameters = catch @@ fun raw ->
if String.get_uint8 raw 0 <> ec_curve_type_to_int NAMED_CURVE then
raise_unknown "EC curve type"
else
match int_to_named_group (String.get_uint16_be raw 1) with
| Some g ->
begin match named_group_to_group g with
| Some ((`X25519 | `P256 | `P384 | `P521) as g) ->
let data_len = String.get_uint8 raw 3 in
let d, rest = split_str ~start:4 raw data_len in
g, d, String.sub raw 0 (data_len + 4), rest
| _ -> raise_unknown "EC group"
end
| None -> raise_unknown "EC named group"
let parse_digitally_signed_exn buf =
let siglen = String.get_uint16_be buf 0 in
if String.length buf <> siglen + 2 then
raise_trailing_bytes "digitally signed"
else
String.sub buf 2 siglen
let parse_digitally_signed =
catch parse_digitally_signed_exn
let parse_digitally_signed_1_2 = catch @@ fun buf ->
match parse_signature_algorithm buf with
| Some sig_alg ->
let signature = parse_digitally_signed_exn (shift buf 2) in
(sig_alg, signature)
| None -> raise_unknown "hash or signature algorithm"
let parse_session_ticket_extension raw =
let etype, len, buf = parse_ext raw in
let data = match int_to_extension_type etype with
| Some EARLY_DATA ->
if String.length buf <> 4 then
raise_unknown "bad early_data extension in session ticket"
else
let size = String.get_int32_be buf 0 in
`EarlyDataIndication size
| _ -> `UnknownExtension (etype, buf)
in
(Some data, shift raw (4 + len))
let parse_session_ticket buf =
let lifetime = String.get_int32_be buf 0
and age_add = String.get_int32_be buf 4
and nonce_len = String.get_uint8 buf 8
in
let nonce = String.sub buf 9 nonce_len in
let ticket_len = String.get_uint16_be buf (9 + nonce_len) in
let ticket, exts_buf = split_str ~start:(11 + nonce_len) buf ticket_len in
let extensions = parse_extensions parse_session_ticket_extension exts_buf in
{ lifetime ; age_add ; nonce ; ticket ; extensions }
let parse_client_dh_key_exchange_exn buf =
let len = String.get_uint16_be buf 0 in
if String.length buf <> len + 2 then
raise_trailing_bytes "client key exchange"
else
String.sub buf 2 len
let parse_client_dh_key_exchange = catch parse_client_dh_key_exchange_exn
let parse_client_ec_key_exchange_exn buf =
let len = String.get_uint8 buf 0 in
if String.length buf <> len + 1 then
raise_trailing_bytes "client key exchange"
else
String.sub buf 1 len
let parse_client_ec_key_exchange = catch parse_client_ec_key_exchange_exn
let parse_keyupdate buf =
if String.length buf <> 1 then
raise_trailing_bytes "key update"
else
match int_to_key_update_request_type (String.get_uint8 buf 0) with
| Some y -> y
| None -> raise_unknown "key update content"
let parse_handshake_frame buf =
if String.length buf < 4 then
(None, buf)
else
let l = get_uint24_len ~off:1 buf in
let hslen = l + 4 in
if String.length buf >= hslen then
let hs, rest = split_str buf hslen in
(Some hs, rest)
else
(None, buf)
let parse_handshake = catch @@ fun buf ->
let typ = String.get_uint8 buf 0 in
let handshake_type = int_to_handshake_type typ in
let len = get_uint24_len ~off:1 buf in
if String.length buf <> len + 4 then
raise_trailing_bytes "handshake"
else
let payload = String.sub buf 4 len in
match handshake_type with
| Some HELLO_REQUEST ->
if String.length payload = 0 then HelloRequest else raise_trailing_bytes "hello request"
| Some CLIENT_HELLO -> parse_client_hello payload
| Some SERVER_HELLO -> parse_server_hello payload
| Some CERTIFICATE -> Certificate payload
| Some CERTIFICATE_VERIFY -> CertificateVerify payload
| Some SERVER_KEY_EXCHANGE -> ServerKeyExchange payload
| Some SERVER_HELLO_DONE ->
if String.length payload = 0 then ServerHelloDone else raise_trailing_bytes "server hello done"
| Some CERTIFICATE_REQUEST -> CertificateRequest payload
| Some CLIENT_KEY_EXCHANGE -> ClientKeyExchange payload
| Some FINISHED -> Finished payload
| Some ENCRYPTED_EXTENSIONS ->
let ee = parse_extensions parse_encrypted_extension payload in
EncryptedExtensions ee
| Some KEY_UPDATE ->
let ku = parse_keyupdate payload in
KeyUpdate ku
| Some SESSION_TICKET ->
let ticket = parse_session_ticket payload in
SessionTicket ticket
| Some END_OF_EARLY_DATA ->
EndOfEarlyData
| Some _
| None -> raise_unknown @@ "handshake type" ^ string_of_int typ

31
unikernel/duniverse/ocaml-tls/lib/reader.mli Normal file
View file

@ -0,0 +1,31 @@
val parse_version : string -> (Core.tls_version, [> `Decode of string ]) result
val parse_any_version : string -> (Core.tls_any_version, [> `Decode of string ]) result
val parse_record : string ->
([ `Record of (Core.tls_hdr * string) * string
| `Fragment of string
], [> `Unexpected of [> `Content_type of int ]
| `Protocol_version of [> `Unknown_record of int * int ]
| `Record_overflow of int ]) result
val parse_handshake_frame : string -> (string option * string)
val parse_handshake : string -> (Core.tls_handshake, [> `Decode of string ]) result
val parse_alert : string -> (Core.tls_alert, [> `Decode of string ]) result
val parse_change_cipher_spec : string -> (unit, [> `Decode of string ]) result
val parse_certificate_request : string -> (Packet.client_certificate_type list * string list, [> `Decode of string ]) result
val parse_certificate_request_1_2 : string -> (Packet.client_certificate_type list * Core.signature_algorithm list * string list, [> `Decode of string ]) result
val parse_certificate_request_1_3 : string -> (string option * Core.certificate_request_extension list, [> `Decode of string ]) result
val parse_certificates : string -> (string list, [> `Decode of string ]) result
val parse_certificates_1_3 : string -> (string * (string * 'a list) list, [> `Decode of string ]) result
val parse_client_dh_key_exchange : string -> (string, [> `Decode of string ]) result
val parse_client_ec_key_exchange : string -> (string, [> `Decode of string ]) result
val parse_dh_parameters : string -> (Core.dh_parameters * string * string, [> `Decode of string ]) result
val parse_ec_parameters : string -> ([ `X25519 | `P256 | `P384 | `P521 ] * string * string * string, [> `Decode of string ]) result
val parse_digitally_signed : string -> (string, [> `Decode of string ]) result
val parse_digitally_signed_1_2 : string -> (Core.signature_algorithm * string, [> `Decode of string ]) result

352
unikernel/duniverse/ocaml-tls/lib/state.ml Normal file
View file

@ -0,0 +1,352 @@
(* 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 Core
open Mirage_crypto
type hmac_key = string
(* initialisation vector style, depending on TLS version *)
type iv_mode =
| Iv of string (* traditional CBC (reusing last cipherblock) *)
| Random_iv (* TLS 1.1 and higher explicit IV (we use random) *)
type 'k cbc_cipher = (module Block.CBC with type key = 'k)
type 'k cbc_state = {
cipher : 'k cbc_cipher ;
cipher_secret : 'k ;
iv_mode : iv_mode ;
hmac : Digestif.hash' ;
hmac_secret : hmac_key
}
type nonce = string
type 'k aead_cipher = (module AEAD with type key = 'k)
type 'k aead_state = {
cipher : 'k aead_cipher ;
cipher_secret : 'k ;
nonce : nonce ;
explicit_nonce : bool ; (* RFC 7905: no explicit nonce, instead TLS 1.3 construction is adapted *)
}
(* state of a symmetric cipher *)
type cipher_st =
| CBC : 'k cbc_state -> cipher_st
| AEAD : 'k aead_state -> cipher_st
(* 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 *)
}
(* the raw handshake log we need to carry around *)
type hs_log = string list
type dh_secret = [
| `Finite_field of Mirage_crypto_pk.Dh.secret
| `P256 of Mirage_crypto_ec.P256.Dh.secret
| `P384 of Mirage_crypto_ec.P384.Dh.secret
| `P521 of Mirage_crypto_ec.P521.Dh.secret
| `X25519 of Mirage_crypto_ec.X25519.secret
]
(* a collection of client and server verify bytes for renegotiation *)
type reneg_params = string * string
type common_session_data = {
server_random : string ; (* 32 bytes random from the server hello *)
client_random : string ; (* 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 *)
}
type session_data = {
common_session_data : common_session_data ;
client_version : tls_any_version ; (* version in client hello (needed in RSA client key exchange) *)
ciphersuite : Ciphersuite.ciphersuite ;
group : group option ;
renegotiation : reneg_params ; (* renegotiation data *)
session_id : string ;
extended_ms : bool ;
tls_unique : string ;
}
(* state machine of the server *)
type server_handshake_state =
| AwaitClientHello (* initial state *)
| AwaitClientHelloRenegotiate
| AwaitClientCertificate_RSA of session_data * hs_log
| AwaitClientCertificate_DHE of session_data * dh_secret * hs_log
| AwaitClientKeyExchange_RSA of session_data * hs_log (* server hello done is sent, and RSA key exchange used, waiting for a client key exchange message *)
| 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 * string * 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 * string * hs_log (* change cipher spec received, next should be the finished including a hmac over all handshake packets *)
| Established (* handshake successfully completed *)
(* state machine of the client *)
type client_handshake_state =
| ClientInitial (* initial state *)
| AwaitServerHello of client_hello * (group * dh_secret) list * hs_log (* client hello is sent, handshake_params are half-filled *)
| AwaitServerHelloRenegotiate of session_data * client_hello * hs_log (* client hello is sent, handshake_params are half-filled *)
| 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 * string * string * hs_log (* server hello done expected, client key exchange and premastersecret are ready *)
| AwaitServerHelloDone of session_data * signature_algorithm list option * string * string * hs_log (* server hello done expected, client key exchange and premastersecret are ready *)
| AwaitServerChangeCipherSpec of session_data * crypto_context * string * hs_log (* change cipher spec expected *)
| AwaitServerChangeCipherSpecResume of session_data * crypto_context * crypto_context * hs_log (* change cipher spec expected *)
| AwaitServerFinished of session_data * string * 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 *)
type kdf = {
secret : string ;
cipher : Ciphersuite.ciphersuite13 ;
hash : Digestif.hash' ;
}
(* TODO needs log of CH..CF for post-handshake auth *)
(* TODO drop master_secret!? *)
type session_data13 = {
common_session_data13 : common_session_data ;
ciphersuite13 : Ciphersuite.ciphersuite13 ;
master_secret : kdf ;
exporter_master_secret : string ;
resumption_secret : string ;
state : epoch_state ;
resumed : bool ;
client_app_secret : string ;
server_app_secret : string ;
}
type client13_handshake_state =
| AwaitServerHello13 of client_hello * (group * dh_secret) list * string (* this is for CH1 ~> HRR ~> CH2 <~ WAIT SH *)
| AwaitServerEncryptedExtensions13 of session_data13 * string * string * string
| AwaitServerCertificateRequestOrCertificate13 of session_data13 * string * string * string
| AwaitServerCertificate13 of session_data13 * string * string * signature_algorithm list option * string
| AwaitServerCertificateVerify13 of session_data13 * string * string * signature_algorithm list option * string
| AwaitServerFinished13 of session_data13 * string * string * signature_algorithm list option * string
| Established13
type server13_handshake_state =
| AwaitClientHelloHRR13 (* if we sent out HRR (also to-be-used for tls13-only) *)
| AwaitClientCertificate13 of session_data13 * string * crypto_context * session_ticket option * string
| AwaitClientCertificateVerify13 of session_data13 * string * crypto_context * session_ticket option * string
| AwaitClientFinished13 of string * crypto_context * session_ticket option * string
| AwaitEndOfEarlyData13 of string * crypto_context * crypto_context * session_ticket option * string
| Established13
type handshake_machina_state =
| Client of client_handshake_state
| Server of server_handshake_state
| Client13 of client13_handshake_state
| Server13 of server13_handshake_state
(* state during a handshake, used in the handlers *)
type handshake_state = {
session : [ `TLS of session_data | `TLS13 of session_data13 ] list ;
protocol_version : tls_version ;
early_data_left : int32 ;
machina : handshake_machina_state ; (* state machine state *)
config : Config.config ; (* given config *)
hs_fragment : string ; (* handshake messages can be fragmented, leftover from before *)
}
(* connection state: initially None, after handshake a crypto context *)
type crypto_state = crypto_context option
(* record consisting of a content type and a byte vector *)
type record = Packet.content_type * string
(* response returned by a handler *)
type rec_resp = [
| `Change_enc of crypto_context (* either instruction to change the encryptor to the given one *)
| `Change_dec of crypto_context (* either change the decryptor to the given one *)
| `Record of record (* or a record which should be sent out *)
]
(* return type of handshake handlers *)
type handshake_return = handshake_state * rec_resp list
(* Top level state, encapsulating the entire session. *)
type state = {
handshake : handshake_state ; (* the current handshake state *)
decryptor : crypto_state ; (* the current decryption state *)
encryptor : crypto_state ; (* the current encryption state *)
fragment : string ; (* the leftover fragment from TCP fragmentation *)
read_closed : bool ;
write_closed : bool ;
}
type error = [
| `AuthenticationFailure of X509.Validation.validation_error
| `NoConfiguredCiphersuite of Ciphersuite.ciphersuite list
| `NoConfiguredVersions of tls_version list
| `NoConfiguredSignatureAlgorithm of signature_algorithm list
| `NoMatchingCertificateFound of string
| `CouldntSelectCertificate
]
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
| `CouldntSelectCertificate -> Fmt.string ppf "couldn't select certificate"
type fatal = [
| `Protocol_version of [
| `None_supported of tls_any_version list
| `Unknown_record of int * int
| `Bad_record of tls_any_version
]
| `Unexpected of [
| `Content_type of int
| `Message of string
| `Handshake of tls_handshake
]
| `Decode of string
| `Handshake of [
| `Message of string
| `Fragments
| `BadDH of string
| `BadECDH of Mirage_crypto_ec.error
]
| `Bad_certificate of string
| `Missing_extension of string
| `Bad_mac
| `Record_overflow of int
| `Unsupported_extension
| `Inappropriate_fallback
| `No_application_protocol
]
let pp_protocol_version ppf = function
| `None_supported vs ->
Fmt.pf ppf "none supported, client provided %a"
Fmt.(list ~sep:(any ", ") pp_tls_any_version) vs
| `Unknown_record (maj, min) ->
Fmt.pf ppf "unknown record version %u.%u" maj min
| `Bad_record v ->
Fmt.pf ppf "bad record version %a" pp_tls_any_version v
let pp_unexpected ppf = function
| `Content_type c -> Fmt.pf ppf "content type %u" c
| `Message msg -> Fmt.string ppf msg
| `Handshake hs -> Fmt.pf ppf "handshake %a" pp_handshake hs
let pp_handshake_error ppf = function
| `Message msg -> Fmt.string ppf msg
| `Fragments -> Fmt.string ppf "fragments are not empty"
| `BadDH msg -> Fmt.pf ppf "bad DH %s" msg
| `BadECDH e -> Fmt.pf ppf "bad ECDH %a" Mirage_crypto_ec.pp_error e
let pp_fatal ppf = function
| `Protocol_version e -> Fmt.pf ppf "version error: %a" pp_protocol_version e
| `Unexpected p -> Fmt.pf ppf "unexpected: %a" pp_unexpected p
| `Decode msg -> Fmt.pf ppf "decode error: %s" msg
| `Handshake h -> Fmt.pf ppf "handshake error: %a" pp_handshake_error h
| `Bad_certificate msg -> Fmt.pf ppf "bad certificate: %s" msg
| `Missing_extension msg -> Fmt.pf ppf "missing extension: %s" msg
| `Bad_mac -> Fmt.string ppf "MAC mismatch"
| `Record_overflow n -> Fmt.pf ppf "record overflow %u" n
| `Unsupported_extension -> Fmt.string ppf "unsupported extension"
| `Inappropriate_fallback -> Fmt.string ppf "inappropriate fallback"
| `No_application_protocol -> Fmt.string ppf "no application protocol"
type failure = [
| `Error of error
| `Fatal of fatal
| `Alert of Packet.alert_type
]
let pp_failure ppf = function
| `Error e -> pp_error ppf e
| `Fatal f -> pp_fatal ppf f
| `Alert a -> Fmt.pf ppf "alert %s" (Packet.alert_type_to_string a)
let common_data_to_epoch common is_server peer_name =
let own_random, peer_random =
if is_server then
common.server_random, common.client_random
else
common.client_random, common.server_random
in
let epoch : epoch_data =
{ side = if is_server then `Server else `Client ;
state = `Established ;
protocol_version = `TLS_1_0 ;
ciphersuite = `DHE_RSA_WITH_AES_256_CBC_SHA ;
peer_random ;
peer_certificate = common.peer_certificate ;
peer_certificate_chain = common.peer_certificate_chain ;
peer_name ;
trust_anchor = common.trust_anchor ;
own_random ;
own_certificate = common.own_certificate ;
own_private_key = common.own_private_key ;
own_name = common.own_name ;
received_certificates = common.received_certificates ;
master_secret = common.master_secret ;
exporter_master_secret = "" ;
alpn_protocol = common.alpn_protocol ;
session_id = "" ;
extended_ms = false ;
tls_unique = None ;
} in
epoch
let epoch_of_session server peer_name protocol_version = function
| `TLS (session : session_data) ->
let epoch = common_data_to_epoch session.common_session_data server peer_name in
{
epoch with
protocol_version = protocol_version ;
ciphersuite = session.ciphersuite ;
session_id = session.session_id ;
extended_ms = session.extended_ms ;
tls_unique = Some session.tls_unique ;
}
| `TLS13 (session : session_data13) ->
let epoch : epoch_data = common_data_to_epoch session.common_session_data13 server peer_name in
{
epoch with
protocol_version = protocol_version ;
ciphersuite = (session.ciphersuite13 :> Ciphersuite.ciphersuite) ;
extended_ms = true ; (* RFC 8446, Appendix D, last paragraph *)
state = session.state ;
exporter_master_secret = session.exporter_master_secret ;
}
let epoch_of_hs hs =
let server =
match hs.machina with
| Client _ | Client13 _ -> false
| Server _ | Server13 _ -> true
and peer_name = Config.(hs.config.peer_name)
in
match hs.session with
| [] -> None
| session :: _ -> Some (epoch_of_session server peer_name hs.protocol_version session)

40
unikernel/duniverse/ocaml-tls/lib/utils.ml Normal file
View file

@ -0,0 +1,40 @@
module List_set = struct
let subset ?(compare = compare) l1 l2 =
let rec loop xs ys =
match (xs, ys) with
| ([], _) -> true
| (_, []) -> false
| (x::xss, y::yss) ->
match compare x y with
| -1 -> false
| 1 -> loop xs yss
| _ -> loop xss yss in
loop (List.sort compare l1) (List.sort compare l2)
let is_proper_set l =
let rec repeats = function
| x::(y::_ as xs) -> x = y || repeats xs
| _ -> false in
not @@ repeats (List.sort compare l)
end
let rec map_find ~f = function
| [] -> None
| x::xs ->
match f x with
| None -> map_find ~f xs
| Some _ as x' -> x'
let init_and_last list =
List.fold_right (fun x -> function
| None -> Some ([], x)
| Some (xs, y) -> Some (x::xs, y))
list None
let rec first_match l1 = function
| [] -> None
| x::_ when List.mem x l1 -> Some x
| _::xs -> first_match l1 xs
let sub_equal ~off ~len v x =
v = String.sub x off len

491
unikernel/duniverse/ocaml-tls/lib/writer.ml Normal file
View file

@ -0,0 +1,491 @@
open Packet
open Core
let assemble_protocol_version_int buf off version =
let major, minor = pair_of_tls_version version in
Bytes.set_uint8 buf off major;
Bytes.set_uint8 buf (off + 1) minor
let assemble_protocol_version ?(buf= Bytes.create 2) version =
assemble_protocol_version_int buf 0 version;
Bytes.unsafe_to_string buf
let assemble_any_protocol_version_into buf off version =
let major, minor = pair_of_tls_any_version version in
Bytes.set_uint8 buf off major;
Bytes.set_uint8 buf (off + 1) minor
let assemble_any_protocol_version version =
let buf = Bytes.create 2 in
assemble_any_protocol_version_into buf 0 version;
Bytes.unsafe_to_string buf
let assemble_hdr version (content_type, payload) =
let buf = Bytes.create 5 in
Bytes.set_uint8 buf 0 (content_type_to_int content_type);
assemble_protocol_version_int buf 1 version;
Bytes.set_uint16_be buf 3 (String.length payload);
Bytes.unsafe_to_string buf ^ payload
type len = One | Two | Three
let assemble_list ?none_if_empty lenb f elements =
let length body =
match lenb with
| One ->
let l = Bytes.create 1 in
Bytes.set_uint8 l 0 (String.length body) ;
Bytes.unsafe_to_string l
| Two ->
let l = Bytes.create 2 in
Bytes.set_uint16_be l 0 (String.length body) ;
Bytes.unsafe_to_string l
| Three ->
let l = Bytes.create 3 in
set_uint24_len ~off:0 l (String.length body) ;
Bytes.unsafe_to_string l
in
let b es = String.concat "" (List.map f es) in
let full es =
let body = b es in
length body ^ body
in
match none_if_empty with
| Some _ -> (match elements with
| [] -> ""
| eles -> full eles)
| None -> full elements
let assemble_certificate c =
let length = String.length c in
let buf = Bytes.create 3 in
set_uint24_len ~off:0 buf length;
Bytes.unsafe_to_string buf ^ c
let assemble_certificates cs =
assemble_list Three assemble_certificate cs
let assemble_compression_method m =
String.make 1 (Char.unsafe_chr (compression_method_to_int m))
let assemble_compression_methods ms =
assemble_list One assemble_compression_method ms
let assemble_any_ciphersuite c =
let buf = Bytes.create 2 in
Bytes.set_uint16_be buf 0 (any_ciphersuite_to_int c);
Bytes.unsafe_to_string buf
let assemble_any_ciphersuites cs =
assemble_list Two assemble_any_ciphersuite cs
let assemble_ciphersuite c =
let acs = Ciphersuite.ciphersuite_to_any_ciphersuite c in
assemble_any_ciphersuite acs
let assemble_hostname host =
let host = Domain_name.to_string host in
(* 8 bit hostname type; 16 bit length; value *)
let vallength = String.length host in
let buf = Bytes.create 3 in
Bytes.set_uint8 buf 0 0; (* type, only 0 registered *)
Bytes.set_uint16_be buf 1 vallength;
Bytes.unsafe_to_string buf ^ host
let assemble_hostnames hosts =
assemble_list Two assemble_hostname hosts
let assemble_hash_signature sigalg =
let buf = Bytes.create 2 in
Bytes.set_uint16_be buf 0 (signature_alg_to_int (to_signature_alg sigalg)) ;
Bytes.unsafe_to_string buf
let assemble_signature_algorithms s =
assemble_list Two assemble_hash_signature s
let assemble_certificate_types ts =
let ass x =
String.make 1 (Char.unsafe_chr (client_certificate_type_to_int x))
in
assemble_list One ass ts
let assemble_cas cas =
let ass x =
let buf = Bytes.create 2 in
Bytes.set_uint16_be buf 0 (String.length x) ;
Bytes.unsafe_to_string buf ^ x
in
assemble_list Two ass cas
let assemble_certificate_request ts cas =
assemble_certificate_types ts ^ assemble_cas cas
let assemble_certificate_request_1_2 ts sigalgs cas =
String.concat "" [
assemble_certificate_types ts;
assemble_signature_algorithms sigalgs;
assemble_cas cas
]
let assemble_named_group g =
let buf = Bytes.create 2 in
Bytes.set_uint16_be buf 0 (named_group_to_int g);
Bytes.unsafe_to_string buf
let assemble_group g =
assemble_named_group (group_to_named_group g)
let assemble_supported_groups groups =
assemble_list Two assemble_named_group groups
let assemble_keyshare_entry (ng, ks) =
let g = assemble_named_group ng in
let l = Bytes.create 2 in
Bytes.set_uint16_be l 0 (String.length ks) ;
String.concat "" [ g ; Bytes.unsafe_to_string l ; ks ]
let assemble_psk_id (id, age) =
let id_len = Bytes.create 2 in
Bytes.set_uint16_be id_len 0 (String.length id) ;
let age_buf = Bytes.create 4 in
Bytes.set_int32_be age_buf 0 age ;
String.concat "" [ Bytes.unsafe_to_string id_len ; id ; Bytes.unsafe_to_string age_buf ]
let assemble_binder b =
let b_len = String.make 1 (Char.unsafe_chr (String.length b)) in
b_len ^ b
let assemble_client_psks psks =
let ids, binders = List.split psks in
let ids_buf = assemble_list Two assemble_psk_id ids in
let binders_buf = assemble_list Two assemble_binder binders in
ids_buf ^ binders_buf
let assemble_alpn_protocol p =
let buf = String.make 1 (Char.unsafe_chr (String.length p)) in
buf ^ p
let assemble_alpn_protocols protocols =
assemble_list Two assemble_alpn_protocol protocols
let assemble_supported_versions vs =
assemble_list One assemble_any_protocol_version vs
let assemble_extension = function
| `SecureRenegotiation x ->
let buf = String.make 1 (Char.unsafe_chr (String.length x)) in
(buf ^ x, RENEGOTIATION_INFO)
| `ExtendedMasterSecret -> ("", EXTENDED_MASTER_SECRET)
| `ECPointFormats ->
(* a list of point formats, we support type 0 = uncompressed unconditionally *)
let data = Bytes.make 2 '\x00' in
Bytes.set_uint8 data 0 1;
(Bytes.unsafe_to_string data, EC_POINT_FORMATS)
| _ -> invalid_arg "unknown extension"
let assemble_cookie c =
let l = Bytes.create 2 in
Bytes.set_uint16_be l 0 (String.length c) ;
Bytes.unsafe_to_string l ^ c
let assemble_psk_key_exchange_mode mode =
String.make 1 (Char.unsafe_chr (psk_key_exchange_mode_to_int mode))
let assemble_psk_key_exchange_modes modes =
assemble_list One assemble_psk_key_exchange_mode modes
let assemble_ext (pay, typ) =
let buf = Bytes.create 4 in
Bytes.set_uint16_be buf 0 (extension_type_to_int typ);
Bytes.set_uint16_be buf 2 (String.length pay);
Bytes.unsafe_to_string buf ^ pay
let assemble_extensions ?none_if_empty assemble_e es =
assemble_list ?none_if_empty Two assemble_e es
let assemble_ca ca =
let lenbuf = Bytes.create 2 in
let data = X509.Distinguished_name.encode_der ca in
Bytes.set_uint16_be lenbuf 0 (String.length data) ;
Bytes.unsafe_to_string lenbuf ^ data
let assemble_certificate_authorities cas =
assemble_list Two assemble_ca cas
let assemble_certificate_request_extension e =
assemble_ext @@ match e with
| `SignatureAlgorithms s ->
(assemble_signature_algorithms s, SIGNATURE_ALGORITHMS)
| `CertificateAuthorities cas ->
(assemble_certificate_authorities cas, CERTIFICATE_AUTHORITIES)
| _ -> invalid_arg "unknown extension"
let assemble_certificate_request_1_3 ?(context = "") exts =
let clen = String.make 1 (Char.unsafe_chr (String.length context)) in
let exts = assemble_extensions assemble_certificate_request_extension exts in
String.concat "" [ clen ; context ; exts ]
let assemble_client_extension e =
assemble_ext @@ match e with
| `SupportedGroups groups ->
(assemble_supported_groups groups, SUPPORTED_GROUPS)
| `Hostname name -> (assemble_hostnames [name], SERVER_NAME)
| `Padding x -> (String.make x '\x00', PADDING)
| `SignatureAlgorithms s ->
(assemble_signature_algorithms s, SIGNATURE_ALGORITHMS)
| `ALPN protocols ->
(assemble_alpn_protocols protocols, APPLICATION_LAYER_PROTOCOL_NEGOTIATION)
| `KeyShare ks ->
(assemble_list Two assemble_keyshare_entry ks, KEY_SHARE)
| `PreSharedKeys ids ->
(assemble_client_psks ids, PRE_SHARED_KEY)
| `EarlyDataIndication ->
("", EARLY_DATA)
| `SupportedVersions vs ->
(assemble_supported_versions vs, SUPPORTED_VERSIONS)
| `PostHandshakeAuthentication ->
("", POST_HANDSHAKE_AUTH)
| `Cookie c ->
(assemble_cookie c, COOKIE)
| `PskKeyExchangeModes modes ->
(assemble_psk_key_exchange_modes modes, PSK_KEY_EXCHANGE_MODES)
| x -> assemble_extension x
let assemble_server_extension e =
assemble_ext @@ match e with
| `Hostname -> ("", SERVER_NAME)
| `ALPN protocol ->
(assemble_alpn_protocols [protocol], APPLICATION_LAYER_PROTOCOL_NEGOTIATION)
| `KeyShare (g, ks) ->
let ng = group_to_named_group g in
(assemble_keyshare_entry (ng, ks), KEY_SHARE)
| `PreSharedKey id ->
let data = Bytes.create 2 in
Bytes.set_uint16_be data 0 id ;
(Bytes.unsafe_to_string data, PRE_SHARED_KEY)
| `SelectedVersion v -> (assemble_protocol_version v, SUPPORTED_VERSIONS)
| x -> assemble_extension x
let assemble_encrypted_extension e =
assemble_ext @@ match e with
| `Hostname -> ("", SERVER_NAME)
| `ALPN protocol ->
(assemble_alpn_protocols [protocol], APPLICATION_LAYER_PROTOCOL_NEGOTIATION)
| `SupportedGroups groups ->
(assemble_supported_groups (List.map group_to_named_group groups), SUPPORTED_GROUPS)
| `EarlyDataIndication -> ("", EARLY_DATA)
| _ -> invalid_arg "unknown extension"
let assemble_retry_extension e =
assemble_ext @@ match e with
| `SelectedGroup g -> (assemble_group g, KEY_SHARE)
| `Cookie c -> (assemble_cookie c, COOKIE)
| `SelectedVersion v -> (assemble_protocol_version v, SUPPORTED_VERSIONS)
| `UnknownExtension _ -> invalid_arg "unknown retry extension"
let assemble_cert_ext (certificate, extensions) =
let cert = assemble_certificate certificate
and exts = assemble_list Two assemble_server_extension extensions
in
cert ^ exts
let assemble_certs_exts cs =
assemble_list Three assemble_cert_ext cs
let assemble_certificates_1_3 context certs =
let l = String.make 1 (Char.unsafe_chr (String.length context)) in
String.concat "" [ l ; context ; assemble_certs_exts (List.map (fun c -> c, []) certs) ]
let assemble_sid sid =
match sid with
| None -> String.make 1 '\x00'
| Some s -> String.make 1 (Char.unsafe_chr (String.length s)) ^ s
let assemble_client_hello (cl : client_hello) : string =
let version = match cl.client_version with
| `TLS_1_3 -> `TLS_1_2 (* keep 0x03 0x03 on wire *)
| x -> x
in
let v = assemble_any_protocol_version version in
let sid = assemble_sid cl.sessionid in
let css = assemble_any_ciphersuites cl.ciphersuites in
(* compression methods, completely useless *)
let cms = assemble_compression_methods [NULL] in
let bbuf = String.concat "" [ v ; cl.client_random ; sid ; css ; cms ] in
let extensions = assemble_extensions ~none_if_empty:true assemble_client_extension cl.extensions in
(* some widely deployed firewalls drop ClientHello messages which are
> 256 and < 511 byte, insert PADDING extension for these *)
(* from draft-ietf-tls-padding-00:
As an example, consider a client that wishes to avoid sending a
ClientHello with a record size between 256 and 511 bytes (inclusive).
This case is considered because at least one TLS implementation is
known to hang the connection when such a ClientHello record is
received.
After building a ClientHello as normal, the client can add four to
the length (to account for the "msg_type" and "length" fields of the
handshake protocol) and test whether the resulting length falls into
that range. If it does, a padding extension can be added in order to
push the length to (at least) 512 bytes. *)
let extrapadding =
(* since PreSharedKeys _must_ be the last extension, don't bother padding
when it is present. rationale from ietf-tls WG
"Padding extension and 0-RTT" thread (2016-10-30) *)
if List.exists (function `PreSharedKeys _ -> true | _ -> false) cl.extensions then
""
else
let buflen = String.length bbuf + String.length extensions + 4 (* see above, header *) in
if buflen >= 256 && buflen <= 511 then
match String.length extensions with
| 0 -> (* need to construct a 2 byte extension length as well *)
let l = 512 (* desired length *) - 2 (* extension length *) - 4 (* padding extension header *) - buflen in
let l = max l 0 in (* negative size is not good *)
let padding = assemble_client_extension (`Padding l) in
let extension_length = Bytes.create 2 in
Bytes.set_uint16_be extension_length 0 (String.length padding);
Bytes.unsafe_to_string extension_length ^ padding
| _ ->
let l = 512 - 4 (* padding extension header *) - buflen in
let l = max l 0 in
let padding = assemble_client_extension (`Padding l) in
(* extensions include the 16 bit extension length field *)
let elen = String.length extensions + String.length padding - 2 (* the 16 bit length field *) in
Bytes.set_uint16_be (Bytes.unsafe_of_string extensions) 0 elen;
padding
else
""
in
String.concat "" [ bbuf ; extensions ; extrapadding ]
let assemble_server_hello (sh : server_hello) : string =
let version, exts = match sh.server_version with
| `TLS_1_3 -> `TLS_1_2, `SelectedVersion `TLS_1_3 :: sh.extensions
| x -> x, sh.extensions
in
let v = assemble_protocol_version version in
let sid = assemble_sid sh.sessionid in
let cs = assemble_ciphersuite sh.ciphersuite in
(* useless compression method *)
let cm = assemble_compression_method NULL in
let extensions = assemble_extensions ~none_if_empty:true assemble_server_extension exts in
String.concat "" [ v ; sh.server_random ; sid ; cs ; cm ; extensions ]
let assemble_dh_parameters p =
let plen, glen, yslen = (String.length p.dh_p, String.length p.dh_g, String.length p.dh_Ys) in
let buf = Bytes.create (2 + 2 + 2 + plen + glen + yslen) in
Bytes.set_uint16_be buf 0 plen;
Bytes.blit_string p.dh_p 0 buf 2 plen;
Bytes.set_uint16_be buf (2 + plen) glen;
Bytes.blit_string p.dh_g 0 buf (4 + plen) glen;
Bytes.set_uint16_be buf (4 + plen + glen) yslen;
Bytes.blit_string p.dh_Ys 0 buf (6 + plen + glen) yslen;
Bytes.unsafe_to_string buf
let assemble_ec_parameters named_curve point =
let hdr = Bytes.create 4 in
Bytes.set_uint8 hdr 0 (ec_curve_type_to_int NAMED_CURVE);
Bytes.set_uint16_be hdr 1 (named_group_to_int (group_to_named_group named_curve));
Bytes.set_uint8 hdr 3 (String.length point);
Bytes.unsafe_to_string hdr ^ point
let assemble_digitally_signed signature =
let lenbuf = Bytes.create 2 in
Bytes.set_uint16_be lenbuf 0 (String.length signature);
Bytes.unsafe_to_string lenbuf ^ signature
let assemble_digitally_signed_1_2 sigalg signature =
(assemble_hash_signature sigalg) ^ (assemble_digitally_signed signature)
let assemble_session_ticket_extension e =
assemble_ext @@ match e with
| `EarlyDataIndication max ->
let buf = Bytes.create 4 in
Bytes.set_int32_be buf 0 max ;
(Bytes.unsafe_to_string buf, EARLY_DATA)
| _ -> invalid_arg "unknown extension"
let assemble_session_ticket (se : session_ticket) =
let buf = Bytes.create 9 in
Bytes.set_int32_be buf 0 se.lifetime ;
Bytes.set_int32_be buf 4 se.age_add ;
Bytes.set_uint8 buf 8 (String.length se.nonce) ;
let ticketlen = Bytes.create 2 in
Bytes.set_uint16_be ticketlen 0 (String.length se.ticket) ;
let exts = assemble_extensions assemble_session_ticket_extension se.extensions in
String.concat "" [ Bytes.unsafe_to_string buf ; se.nonce ; Bytes.unsafe_to_string ticketlen ; se.ticket ; exts ]
let assemble_client_dh_key_exchange kex =
let len = String.length kex in
let buf = Bytes.create (len + 2) in
Bytes.set_uint16_be buf 0 len;
Bytes.blit_string kex 0 buf 2 len;
Bytes.unsafe_to_string buf
let assemble_client_ec_key_exchange kex =
let len = String.length kex in
let buf = Bytes.create (len + 1) in
Bytes.set_uint8 buf 0 len;
Bytes.blit_string kex 0 buf 1 len;
Bytes.unsafe_to_string buf
let assemble_hello_retry_request hrr =
let exts = `SelectedGroup hrr.selected_group :: hrr.extensions in
let version, exts = match hrr.retry_version with
| `TLS_1_3 -> `TLS_1_2, `SelectedVersion `TLS_1_3 :: exts
| x -> x, exts
in
let v = assemble_protocol_version version in
let sid = assemble_sid hrr.sessionid in
let cs = assemble_ciphersuite (hrr.ciphersuite :> Ciphersuite.ciphersuite) in
(* useless compression method *)
let cm = String.make 1 '\x00' in
let extensions = assemble_extensions ~none_if_empty:true assemble_retry_extension exts in
String.concat "" [ v ; helloretryrequest ; sid ; cs ; cm ; extensions ]
let assemble_hs typ len =
let buf = Bytes.create 4 in
Bytes.set_uint8 buf 0 (handshake_type_to_int typ);
set_uint24_len ~off:1 buf len;
Bytes.unsafe_to_string buf
let assemble_message_hash len =
assemble_hs MESSAGE_HASH len
let assemble_key_update req =
String.make 1 (Char.unsafe_chr (key_update_request_type_to_int req))
let assemble_handshake hs =
let (payload, payload_type) =
match hs with
| ClientHello ch -> (assemble_client_hello ch, CLIENT_HELLO)
| ServerHello sh -> (assemble_server_hello sh, SERVER_HELLO)
| HelloRetryRequest hr -> (assemble_hello_retry_request hr, SERVER_HELLO)
| Certificate cs -> (cs, CERTIFICATE)
| CertificateRequest cr -> (cr, CERTIFICATE_REQUEST)
| CertificateVerify c -> (c, CERTIFICATE_VERIFY)
| ServerKeyExchange kex -> (kex, SERVER_KEY_EXCHANGE)
| ClientKeyExchange kex -> (kex, CLIENT_KEY_EXCHANGE)
| ServerHelloDone -> ("", SERVER_HELLO_DONE)
| HelloRequest -> ("", HELLO_REQUEST)
| Finished fs -> (fs, FINISHED)
| SessionTicket st -> (assemble_session_ticket st, SESSION_TICKET)
| EncryptedExtensions ee ->
let cs = assemble_extensions assemble_encrypted_extension ee in
(cs, ENCRYPTED_EXTENSIONS)
| KeyUpdate req ->
let cs = assemble_key_update req in
(cs, KEY_UPDATE)
| EndOfEarlyData -> ("", END_OF_EARLY_DATA)
in
let pay_len = String.length payload in
let buf = assemble_hs payload_type pay_len in
buf ^ payload
let assemble_alert ?(level = Packet.FATAL) typ =
let buf = Bytes.create 2 in
Bytes.set_uint8 buf 1 (alert_type_to_int typ);
Bytes.set_uint8 buf 0 (alert_level_to_int level) ;
Bytes.unsafe_to_string buf
let assemble_change_cipher_spec =
String.make 1 '\x01'

34
unikernel/duniverse/ocaml-tls/lib/writer.mli Normal file
View file

@ -0,0 +1,34 @@
val assemble_protocol_version : ?buf:bytes -> Core.tls_version -> string
val assemble_handshake : Core.tls_handshake -> string
val assemble_message_hash : int -> string
val assemble_hdr : Core.tls_version -> (Packet.content_type * string) -> string
val assemble_alert : ?level:Packet.alert_level -> Packet.alert_type -> string
val assemble_change_cipher_spec : string
val assemble_dh_parameters : Core.dh_parameters -> string
val assemble_ec_parameters : Core.group -> string -> string
val assemble_client_dh_key_exchange : string -> string
val assemble_client_ec_key_exchange : string -> string
val assemble_digitally_signed : string -> string
val assemble_digitally_signed_1_2 : Core.signature_algorithm -> string -> string
val assemble_certificate_request : Packet.client_certificate_type list -> string list -> string
val assemble_certificate_request_1_2 : Packet.client_certificate_type list -> Core.signature_algorithm list -> string list -> string
val assemble_certificate_request_1_3 : ?context:string -> Core.certificate_request_extension list -> string
val assemble_certificates : string list -> string
val assemble_certificates_1_3 : string -> string list -> string