761 lines
30 KiB
OCaml
761 lines
30 KiB
OCaml
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
|