662 lines
26 KiB
OCaml
662 lines
26 KiB
OCaml
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)))
|