upstream: github.com/mirleft/ocaml-tls
Cleanups
+354
-335
+354
-335
lib/handshake_server13.ml
+354
-335
lib/handshake_server13.ml
···
6
6
open Handshake_crypto13
7
7
open Result.Syntax
8
8
9
-
let answer_client_hello ~hrr state ch raw =
10
-
let* () = client_hello_valid `TLS_1_3 ch in
11
-
let* () =
12
-
guard (not (hrr && List.mem `EarlyDataIndication ch.extensions))
13
-
(`Fatal (`Handshake (`Message "has 0RTT after hello retry request")))
9
+
let extract_supported_groups exts =
10
+
let* gs =
11
+
Option.to_result
12
+
~none:(`Fatal (`Missing_extension "supported group"))
13
+
(Utils.map_find ~f:(function `SupportedGroups gs -> Some gs | _ -> None) exts)
14
14
in
15
-
Tracing.debug (fun m -> m "version %a" pp_tls_version `TLS_1_3) ;
15
+
Ok (List.filter_map Core.named_group_to_group gs)
16
16
17
-
let ciphers =
18
-
List.filter_map Ciphersuite.any_ciphersuite_to_ciphersuite13 ch.ciphersuites
17
+
let extract_keyshares exts =
18
+
let* ks =
19
+
Option.to_result
20
+
~none:(`Fatal (`Missing_extension "key share"))
21
+
(Utils.map_find ~f:(function `KeyShare ks -> Some ks | _ -> None) exts)
19
22
in
23
+
List.fold_left (fun acc (g, ks) ->
24
+
let* acc = acc in
25
+
match Core.named_group_to_group g with
26
+
| None -> Ok acc
27
+
| Some g -> Ok ((g, ks) :: acc))
28
+
(Ok []) ks
20
29
21
-
let* groups =
22
-
let* gs =
23
-
Option.to_result
24
-
~none:(`Fatal (`Missing_extension "supported group"))
25
-
(Utils.map_find ~f:(function `SupportedGroups gs -> Some gs | _ -> None) ch.extensions)
26
-
in
27
-
Ok (List.filter_map Core.named_group_to_group gs)
30
+
let make_server_hello13 (ch : client_hello) cipher epoch extensions =
31
+
let ciphersuite = (cipher :> Ciphersuite.ciphersuite) in
32
+
let sh =
33
+
{ server_version = `TLS_1_3 ;
34
+
server_random = Crypto_rng.generate 32 ;
35
+
sessionid = ch.sessionid ;
36
+
ciphersuite ;
37
+
extensions }
38
+
in
39
+
let session : session_data13 =
40
+
let base = match epoch with None -> empty_session13 cipher | Some e -> session13_of_epoch cipher e in
41
+
let common_session_data13 = {
42
+
base.common_session_data13 with
43
+
server_random = sh.server_random ;
44
+
client_random = ch.client_random ;
45
+
} in
46
+
let resumed = match epoch with None -> false | Some _ -> true in
47
+
{ base with common_session_data13 ; ciphersuite13 = cipher ; resumed }
28
48
in
49
+
(sh, session)
29
50
30
-
let* keyshares =
31
-
let* ks =
32
-
Option.to_result
33
-
~none:(`Fatal (`Missing_extension "key share"))
34
-
(Utils.map_find ~f:(function `KeyShare ks -> Some ks | _ -> None) ch.extensions)
35
-
in
36
-
List.fold_left (fun acc (g, ks) ->
37
-
let* acc = acc in
38
-
match Core.named_group_to_group g with
39
-
| None -> Ok acc
40
-
| Some g -> Ok ((g, ks) :: acc))
41
-
(Ok []) ks
51
+
let send_hello_retry state config (ch : client_hello) raw cipher group =
52
+
let cookie =
53
+
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
54
+
H.(to_raw_string (digest_string raw))
42
55
in
56
+
let hrr = { retry_version = `TLS_1_3 ; ciphersuite = cipher ; sessionid = ch.sessionid ; selected_group = group ; extensions = [ `Cookie cookie ] } in
57
+
let hrr_raw = Writer.assemble_handshake (HelloRetryRequest hrr) in
58
+
Tracing.hs ~tag:"handshake-out" (HelloRetryRequest hrr) ;
59
+
(* there is no early data anymore if HRR was sent (see 4.1.2) *)
60
+
(* but the client wouldn't know until it received the HRR *)
61
+
let early_data_left = if List.mem `EarlyDataIndication ch.extensions then config.Config.zero_rtt else 0l in
62
+
let machina = Server13 AwaitClientHelloHRR13 in
63
+
Ok ({ state with early_data_left ; machina },
64
+
`Record (Packet.HANDSHAKE, hrr_raw) ::
65
+
(match ch.sessionid with
66
+
| None -> []
67
+
| Some _ -> [`Record change_cipher_spec]))
43
68
44
-
let base_server_hello ?epoch cipher extensions =
45
-
let ciphersuite = (cipher :> Ciphersuite.ciphersuite) in
46
-
let sh =
47
-
{ server_version = `TLS_1_3 ;
48
-
server_random = Crypto_rng.generate 32 ;
49
-
sessionid = ch.sessionid ;
50
-
ciphersuite ;
51
-
extensions }
52
-
in
53
-
let session : session_data13 =
54
-
let base = match epoch with None -> empty_session13 cipher | Some e -> session13_of_epoch cipher e in
55
-
let common_session_data13 = {
56
-
base.common_session_data13 with
57
-
server_random = sh.server_random ;
58
-
client_random = ch.client_random ;
59
-
} in
60
-
let resumed = match epoch with None -> false | Some _ -> true in
61
-
{ base with common_session_data13 ; ciphersuite13 = cipher ; resumed }
62
-
in
63
-
(sh, session)
64
-
in
65
-
let config = state.config in
69
+
let resolve_psk config hrr cipher hostname (ch : client_hello) raw log hlen =
70
+
let secret ?(psk = String.make hlen '\x00') () = Handshake_crypto13.(derive (empty cipher) psk) in
71
+
let no_resume = secret (), None, [], false in
66
72
match
67
-
Utils.first_match (List.map fst keyshares) config.Config.groups,
68
-
Utils.first_match ciphers (Config.ciphers13 config)
73
+
config.Config.ticket_cache,
74
+
Utils.map_find ~f:(function `PreSharedKeys ids -> Some ids | _ -> None) ch.extensions,
75
+
Utils.map_find ~f:(function `PskKeyExchangeModes ms -> Some ms | _ -> None) ch.extensions
69
76
with
70
-
| _, None -> Error (`Error (`NoConfiguredCiphersuite ciphers))
71
-
| None, Some cipher ->
72
-
if hrr then
73
-
(* avoid loops CH -> HRR -> CH -> HRR -> ... *)
74
-
Error (`Fatal (`Handshake (`Message "hello retry request already sent, still no supported group")))
77
+
| None, _, _ | _, None, _ -> no_resume
78
+
| Some _, Some _, None -> no_resume (* should this lead to an error instead? *)
79
+
| Some cache, Some ids, Some ms ->
80
+
if not (List.mem Packet.PSK_KE_DHE ms) then
81
+
no_resume
75
82
else
76
-
(* no keyshare, looks whether there's a supported group ++ send back HRR *)
77
-
begin match Utils.first_match groups config.Config.groups with
78
-
| None -> Error (`Fatal (`Handshake (`Message "no supported group found")))
79
-
| Some group ->
80
-
let cookie =
81
-
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
82
-
H.(to_raw_string (digest_string raw))
83
+
let idx_ids = List.mapi (fun i id -> (i, id)) ids in
84
+
match
85
+
List.filter (fun (_, ((id, _), _)) ->
86
+
match cache.Config.lookup id with None -> false | Some _ -> true)
87
+
idx_ids
88
+
with
89
+
| [] ->
90
+
Log.info (fun m -> m "found no id in psk cache") ;
91
+
no_resume
92
+
| (idx, ((id, obf_age), binder))::_ ->
93
+
(* need to verify binder, do the obf_age computations + checking,
94
+
figure out whether the id is in our psk cache, and use the resumption secret as input
95
+
and Ok the idx *)
96
+
let psk, old_epoch =
97
+
match cache.Config.lookup id with
98
+
| None -> assert false (* see above *)
99
+
| Some x -> x
100
+
in
101
+
match Ciphersuite.(any_ciphersuite_to_ciphersuite13 (ciphersuite_to_any_ciphersuite old_epoch.ciphersuite)) with
102
+
| None -> no_resume
103
+
| Some c' ->
104
+
if c' = cipher &&
105
+
match hostname, old_epoch.own_name with
106
+
| None, None -> true
107
+
| Some x, Some y -> Domain_name.equal x y
108
+
| _ -> false
109
+
then
110
+
let now = cache.Config.timestamp () in
111
+
let server_delta_t = Ptime.diff now psk.issued_at in
112
+
let client_delta_t =
113
+
match Ptime.Span.of_float_s Int32.(to_float (sub obf_age psk.obfuscation) /. 1000.) with
114
+
| None ->
115
+
Logs.debug (fun m -> m "client_delta is not computable, using 0") ;
116
+
Ptime.Span.zero
117
+
| Some x -> x
118
+
in
119
+
(* ensure server&client_delta_t are not too far off! *)
120
+
match Ptime.Span.(to_int_s (abs (sub server_delta_t client_delta_t))) with
121
+
| None ->
122
+
Logs.debug (fun m -> m "s_c_delta computation lead nowhere") ;
123
+
no_resume
124
+
| Some s_c_delta ->
125
+
if s_c_delta > 10 then begin
126
+
Logs.debug (fun m -> m "delta between client and server is %d seconds, ignoring this ticket!" s_c_delta);
127
+
no_resume
128
+
end else
129
+
(* if ticket_creation ts + lifetime > now, continue *)
130
+
let until = match Ptime.add_span psk.issued_at (Ptime.Span.of_int_s (Int32.to_int cache.Config.lifetime)) with
131
+
| None -> Ptime.epoch
132
+
| Some ts -> ts
133
+
in
134
+
if Ptime.is_earlier now ~than:until then
135
+
let early_secret = secret ~psk:psk.secret () in
136
+
let binder_key = Handshake_crypto13.derive_secret early_secret "res binder" "" in
137
+
let binders_len = binders_len ids in
138
+
let ch_part = String.(sub raw 0 (length raw - binders_len)) in
139
+
let log = log ^ ch_part in
140
+
let binder' = Handshake_crypto13.finished early_secret.hash binder_key log in
141
+
if String.equal binder binder' then begin
142
+
(* from 4.1.2 - earlydata is not allowed after hrr *)
143
+
let zero = idx = 0 && not hrr && List.mem `EarlyDataIndication ch.extensions in
144
+
early_secret, Some old_epoch, [ `PreSharedKey idx ], zero
145
+
end else
146
+
no_resume
147
+
else
148
+
no_resume
149
+
else
150
+
no_resume
151
+
152
+
let send_server_cert_messages config session cipher sigalgs chain priv log =
153
+
if session.resumed then
154
+
Ok ([], log, session)
155
+
else
156
+
let out, log, session = match config.Config.authenticator with
157
+
| None -> [], log, session
158
+
| Some _ ->
159
+
let certreq =
160
+
let exts =
161
+
`SignatureAlgorithms config.Config.signature_algorithms ::
162
+
(match config.Config.acceptable_cas with
163
+
| [] -> []
164
+
| cas -> [ `CertificateAuthorities cas ])
83
165
in
84
-
let hrr = { retry_version = `TLS_1_3 ; ciphersuite = cipher ; sessionid = ch.sessionid ; selected_group = group ; extensions = [ `Cookie cookie ] } in
85
-
let hrr_raw = Writer.assemble_handshake (HelloRetryRequest hrr) in
86
-
Tracing.hs ~tag:"handshake-out" (HelloRetryRequest hrr) ;
87
-
(* there is no early data anymore if HRR was sent (see 4.1.2) *)
88
-
(* but the client wouldn't know until it received the HRR *)
89
-
let early_data_left = if List.mem `EarlyDataIndication ch.extensions then config.Config.zero_rtt else 0l in
90
-
let machina = Server13 AwaitClientHelloHRR13 in
91
-
Ok ({ state with early_data_left ; machina },
92
-
`Record (Packet.HANDSHAKE, hrr_raw) ::
93
-
(match ch.sessionid with
94
-
| None -> []
95
-
| Some _ -> [`Record change_cipher_spec]))
96
-
end
97
-
| Some group, Some cipher ->
98
-
Log.debug (fun m -> m "cipher %a" Ciphersuite.pp_ciphersuite cipher) ;
99
-
Log.debug (fun m -> m "group %a" pp_group group) ;
166
+
CertificateRequest (Writer.assemble_certificate_request_1_3 exts)
167
+
in
168
+
Tracing.hs ~tag:"handshake-out" certreq ;
169
+
let raw_cert_req = Writer.assemble_handshake certreq in
170
+
let common_session_data13 = { session.common_session_data13 with client_auth = true } in
171
+
[raw_cert_req], log ^ raw_cert_req, { session with common_session_data13 }
172
+
in
100
173
101
-
if not (List.mem group groups) then
102
-
Error (`Fatal (`Handshake (`Message "keyshare group not in group list")))
103
-
else
104
-
(* we already checked above in keyshares that group is present there *)
105
-
let keyshare =
106
-
snd (List.find (fun (g, _) -> g = group) keyshares)
107
-
in
108
-
(* DHE - full handshake *)
174
+
let certs = List.map X509.Certificate.encode_der chain in
175
+
let cert = Certificate (Writer.assemble_certificates_1_3 "" certs) in
176
+
let cert_raw = Writer.assemble_handshake cert in
177
+
Tracing.hs ~tag:"handshake-out" cert ;
178
+
let log = log ^ cert_raw in
109
179
110
-
let* log =
111
-
if hrr then
112
-
let* c =
113
-
Option.to_result
114
-
~none:(`Fatal (`Missing_extension "cookie"))
115
-
(Utils.map_find ~f:(function `Cookie c -> Some c | _ -> None) ch.extensions)
116
-
in
117
-
(* log is: 254 00 00 length c :: HRR *)
118
-
let hash_hdr = Writer.assemble_message_hash (String.length c) in
119
-
let hrr = { retry_version = `TLS_1_3 ; ciphersuite = cipher ; sessionid = ch.sessionid ; selected_group = group ; extensions = [ `Cookie c ]} in
120
-
let hs_buf = Writer.assemble_handshake (HelloRetryRequest hrr) in
121
-
Ok (String.concat "" [ hash_hdr ; c ; hs_buf ])
122
-
else
123
-
Ok ""
124
-
in
180
+
let tbs =
181
+
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
182
+
H.(to_raw_string (digest_string log))
183
+
in
184
+
let* signed =
185
+
signature `TLS_1_3
186
+
~context_string:"TLS 1.3, server CertificateVerify"
187
+
tbs (Some sigalgs) config.Config.signature_algorithms priv
188
+
in
189
+
let cv = CertificateVerify signed in
190
+
let cv_raw = Writer.assemble_handshake cv in
191
+
Tracing.hs ~tag:"handshake-out" cv ;
192
+
let log = log ^ cv_raw in
193
+
Ok (out @ [cert_raw; cv_raw], log, session)
125
194
126
-
let hostname = hostname ch in
127
-
let hlen =
128
-
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
129
-
H.digest_size
130
-
in
195
+
let make_session_ticket config session =
196
+
match session.resumed, config.Config.ticket_cache with
197
+
| true, _ | _, None -> None, []
198
+
| false, Some cache ->
199
+
let age_add =
200
+
let cs = Crypto_rng.generate 4 in
201
+
String.get_int32_be cs 0
202
+
in
203
+
let psk_id = Crypto_rng.generate 32 in
204
+
let nonce = Crypto_rng.generate 4 in
205
+
let extensions = match config.Config.zero_rtt with
206
+
| 0l -> []
207
+
| x -> [ `EarlyDataIndication x ]
208
+
in
209
+
let st = { lifetime = cache.Config.lifetime ; age_add ; nonce ; ticket = psk_id ; extensions } in
210
+
Tracing.hs ~tag:"handshake-out" (SessionTicket st) ;
211
+
let st_raw = Writer.assemble_handshake (SessionTicket st) in
212
+
(Some st, [st_raw])
131
213
132
-
let early_secret, epoch, exts, can_use_early_data =
133
-
let secret ?(psk = String.make hlen '\x00') () = Handshake_crypto13.(derive (empty cipher) psk) in
134
-
let no_resume = secret (), None, [], false in
135
-
match
136
-
config.Config.ticket_cache,
137
-
Utils.map_find ~f:(function `PreSharedKeys ids -> Some ids | _ -> None) ch.extensions,
138
-
Utils.map_find ~f:(function `PskKeyExchangeModes ms -> Some ms | _ -> None) ch.extensions
139
-
with
140
-
| None, _, _ | _, None, _ -> no_resume
141
-
| Some _, Some _, None -> no_resume (* should this lead to an error instead? *)
142
-
| Some cache, Some ids, Some ms ->
143
-
if not (List.mem Packet.PSK_KE_DHE ms) then
144
-
no_resume
145
-
else
146
-
let idx_ids = List.mapi (fun i id -> (i, id)) ids in
147
-
match
148
-
List.filter (fun (_, ((id, _), _)) ->
149
-
match cache.Config.lookup id with None -> false | Some _ -> true)
150
-
idx_ids
151
-
with
152
-
| [] ->
153
-
Log.info (fun m -> m "found no id in psk cache") ;
154
-
no_resume
155
-
| (idx, ((id, obf_age), binder))::_ ->
156
-
(* need to verify binder, do the obf_age computations + checking,
157
-
figure out whether the id is in our psk cache, and use the resumption secret as input
158
-
and Ok the idx *)
159
-
let psk, old_epoch =
160
-
match cache.Config.lookup id with
161
-
| None -> assert false (* see above *)
162
-
| Some x -> x
163
-
in
164
-
match Ciphersuite.(any_ciphersuite_to_ciphersuite13 (ciphersuite_to_any_ciphersuite old_epoch.ciphersuite)) with
165
-
| None -> no_resume
166
-
| Some c' ->
167
-
if c' = cipher &&
168
-
match hostname, old_epoch.own_name with
169
-
| None, None -> true
170
-
| Some x, Some y -> Domain_name.equal x y
171
-
| _ -> false
172
-
then
173
-
let now = cache.Config.timestamp () in
174
-
let server_delta_t = Ptime.diff now psk.issued_at in
175
-
let client_delta_t =
176
-
match Ptime.Span.of_float_s Int32.(to_float (sub obf_age psk.obfuscation) /. 1000.) with
177
-
| None ->
178
-
Logs.debug (fun m -> m "client_delta is not computable, using 0") ;
179
-
Ptime.Span.zero
180
-
| Some x -> x
181
-
in
182
-
(* ensure server&client_delta_t are not too far off! *)
183
-
match Ptime.Span.(to_int_s (abs (sub server_delta_t client_delta_t))) with
184
-
| None ->
185
-
Logs.debug (fun m -> m "s_c_delta computation lead nowhere") ;
186
-
no_resume
187
-
| Some s_c_delta ->
188
-
if s_c_delta > 10 then begin
189
-
Logs.debug (fun m -> m "delta between client and server is %d seconds, ignoring this ticket!" s_c_delta);
190
-
no_resume
191
-
end else
192
-
(* if ticket_creation ts + lifetime > now, continue *)
193
-
let until = match Ptime.add_span psk.issued_at (Ptime.Span.of_int_s (Int32.to_int cache.Config.lifetime)) with
194
-
| None -> Ptime.epoch
195
-
| Some ts -> ts
196
-
in
197
-
if Ptime.is_earlier now ~than:until then
198
-
let early_secret = secret ~psk:psk.secret () in
199
-
let binder_key = Handshake_crypto13.derive_secret early_secret "res binder" "" in
200
-
let binders_len = binders_len ids in
201
-
let ch_part = String.(sub raw 0 (length raw - binders_len)) in
202
-
let log = log ^ ch_part in
203
-
let binder' = Handshake_crypto13.finished early_secret.hash binder_key log in
204
-
if String.equal binder binder' then begin
205
-
(* from 4.1.2 - earlydata is not allowed after hrr *)
206
-
let zero = idx = 0 && not hrr && List.mem `EarlyDataIndication ch.extensions in
207
-
early_secret, Some old_epoch, [ `PreSharedKey idx ], zero
208
-
end else
209
-
no_resume
210
-
else
211
-
no_resume
212
-
else
213
-
no_resume
214
-
in
214
+
let complete_server_handshake ~hrr state config (ch : client_hello) hlen hs_secret
215
+
server_hs_secret server_ctx client_hs_secret client_ctx early_traffic_ctx
216
+
can_use_early_data sh_raw ee_raw c_out session' log =
217
+
let master_secret = Handshake_crypto13.derive hs_secret (String.make hlen '\x00') in
218
+
Tracing.cs ~tag:"master-secret" master_secret.secret ;
219
+
220
+
let f_data = finished hs_secret.hash server_hs_secret log in
221
+
let fin = Finished f_data in
222
+
let fin_raw = Writer.assemble_handshake fin in
223
+
224
+
Tracing.hs ~tag:"handshake-out" fin ;
225
+
226
+
let log = log ^ fin_raw in
227
+
let server_app_secret, server_app_ctx, client_app_secret, client_app_ctx =
228
+
app_ctx master_secret log
229
+
in
230
+
let exporter_master_secret = Handshake_crypto13.exporter master_secret log in
231
+
let session' = { session' with server_app_secret ; client_app_secret ; exporter_master_secret } in
215
232
216
-
let _, early_traffic_ctx = Handshake_crypto13.early_traffic early_secret raw in
233
+
let* () =
234
+
guard (String.length state.hs_fragment = 0)
235
+
(`Fatal (`Handshake `Fragments))
236
+
in
217
237
218
-
let secret, public = Handshake_crypto13.dh_gen_key group in
219
-
let* es = Handshake_crypto13.dh_shared secret keyshare in
220
-
let hs_secret = Handshake_crypto13.derive early_secret es in
221
-
Tracing.cs ~tag:"hs secret" hs_secret.secret ;
238
+
(* send sessionticket early *)
239
+
(* TODO track the nonce across handshakes / newsessionticket messages (i.e. after post-handshake auth) - needs to be unique! *)
240
+
let st, st_raw = make_session_ticket config session' in
222
241
223
-
let sh, session = base_server_hello ?epoch cipher (`KeyShare (group, public) :: exts) in
224
-
let sh_raw = Writer.assemble_handshake (ServerHello sh) in
225
-
Tracing.hs ~tag:"handshake-out" (ServerHello sh) ;
242
+
let session =
243
+
let common_session_data13 = { session'.common_session_data13 with master_secret = master_secret.secret } in
244
+
{ session' with common_session_data13 ; master_secret }
245
+
in
246
+
let st, session =
247
+
if can_use_early_data then
248
+
(AwaitEndOfEarlyData13 (client_hs_secret, client_ctx, client_app_ctx, st, log),
249
+
`TLS13 { session with state = `ZeroRTT } :: state.session)
250
+
else if session.common_session_data13.client_auth then
251
+
(AwaitClientCertificate13 (session, client_hs_secret, client_app_ctx, st, log),
252
+
state.session)
253
+
else
254
+
(AwaitClientFinished13 (client_hs_secret, client_app_ctx, st, log),
255
+
`TLS13 session :: state.session)
256
+
in
257
+
let early_data_left = if List.mem `EarlyDataIndication ch.extensions then config.Config.zero_rtt else 0l in
258
+
Ok ({ state with machina = Server13 st ; session ; early_data_left },
259
+
`Record (Packet.HANDSHAKE, sh_raw) ::
260
+
(match ch.sessionid with
261
+
| Some _ when not hrr -> [`Record change_cipher_spec]
262
+
| _ -> []) @
263
+
[ `Change_enc server_ctx ;
264
+
`Change_dec (if can_use_early_data then early_traffic_ctx else client_ctx) ;
265
+
`Record (Packet.HANDSHAKE, ee_raw) ] @
266
+
List.map (fun data -> `Record (Packet.HANDSHAKE, data)) c_out @
267
+
[ `Record (Packet.HANDSHAKE, fin_raw) ;
268
+
`Change_enc server_app_ctx ] @
269
+
List.map (fun data -> `Record (Packet.HANDSHAKE, data)) st_raw)
226
270
227
-
let log = log ^ raw ^ sh_raw in
228
-
let server_hs_secret, server_ctx, client_hs_secret, client_ctx = hs_ctx hs_secret log in
271
+
let handle_dhe_handshake ~hrr state config (ch : client_hello) raw cipher group keyshares groups =
272
+
Log.debug (fun m -> m "cipher %a" Ciphersuite.pp_ciphersuite cipher) ;
273
+
Log.debug (fun m -> m "group %a" pp_group group) ;
229
274
230
-
let* sigalgs =
231
-
Option.to_result
232
-
~none:(`Fatal (`Missing_extension "signature algorithms"))
233
-
(Utils.map_find ~f:(function `SignatureAlgorithms sa -> Some sa | _ -> None) ch.extensions)
234
-
in
235
-
(* TODO respect certificate_signature_algs if present *)
275
+
if not (List.mem group groups) then
276
+
Error (`Fatal (`Handshake (`Message "keyshare group not in group list")))
277
+
else
278
+
(* we already checked above in keyshares that group is present there *)
279
+
let keyshare =
280
+
snd (List.find (fun (g, _) -> g = group) keyshares)
281
+
in
282
+
(* DHE - full handshake *)
236
283
237
-
let f = supports_key_usage ~not_present:true `Digital_signature in
238
-
let* chain, priv =
239
-
let* r = agreed_cert ~f ~signature_algorithms:sigalgs config.Config.own_certificates hostname in
240
-
match r with
241
-
| c::cs, priv -> Ok (c::cs, priv)
242
-
| _ -> Error (`Fatal (`Handshake (`Message "couldn't find certificate chain")))
243
-
in
244
-
let* alpn_protocol = alpn_protocol config ch in
245
-
let session =
246
-
let common_session_data13 = { session.common_session_data13 with
247
-
own_name = hostname ; own_certificate = chain ;
248
-
own_private_key = Some priv ; alpn_protocol }
284
+
let* log =
285
+
if hrr then
286
+
let* c =
287
+
Option.to_result
288
+
~none:(`Fatal (`Missing_extension "cookie"))
289
+
(Utils.map_find ~f:(function `Cookie c -> Some c | _ -> None) ch.extensions)
249
290
in
250
-
{ session with common_session_data13 }
251
-
in
291
+
(* log is: 254 00 00 length c :: HRR *)
292
+
let hash_hdr = Writer.assemble_message_hash (String.length c) in
293
+
let hrr = { retry_version = `TLS_1_3 ; ciphersuite = cipher ; sessionid = ch.sessionid ; selected_group = group ; extensions = [ `Cookie c ]} in
294
+
let hs_buf = Writer.assemble_handshake (HelloRetryRequest hrr) in
295
+
Ok (String.concat "" [ hash_hdr ; c ; hs_buf ])
296
+
else
297
+
Ok ""
298
+
in
252
299
253
-
let ee =
254
-
let hostname_ext = Option.fold ~none:[] ~some:(fun _ -> [`Hostname]) hostname
255
-
and alpn = Option.fold ~none:[] ~some:(fun proto -> [`ALPN proto]) alpn_protocol
256
-
and early_data = if can_use_early_data && config.Config.zero_rtt <> 0l then [ `EarlyDataIndication ] else []
257
-
in
258
-
EncryptedExtensions (hostname_ext @ alpn @ early_data)
259
-
in
260
-
(* 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 *)
261
-
let ee_raw = Writer.assemble_handshake ee in
262
-
Tracing.hs ~tag:"handshake-out" ee ;
263
-
let log = log ^ ee_raw in
300
+
let hostname = hostname ch in
301
+
let hlen =
302
+
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
303
+
H.digest_size
304
+
in
264
305
265
-
let* c_out, log, session' =
266
-
if session.resumed then
267
-
Ok ([], log, session)
268
-
else
269
-
let out, log, session = match config.Config.authenticator with
270
-
| None -> [], log, session
271
-
| Some _ ->
272
-
let certreq =
273
-
let exts =
274
-
`SignatureAlgorithms config.Config.signature_algorithms ::
275
-
(match config.Config.acceptable_cas with
276
-
| [] -> []
277
-
| cas -> [ `CertificateAuthorities cas ])
278
-
in
279
-
CertificateRequest (Writer.assemble_certificate_request_1_3 exts)
280
-
in
281
-
Tracing.hs ~tag:"handshake-out" certreq ;
282
-
let raw_cert_req = Writer.assemble_handshake certreq in
283
-
let common_session_data13 = { session.common_session_data13 with client_auth = true } in
284
-
[raw_cert_req], log ^ raw_cert_req, { session with common_session_data13 }
285
-
in
306
+
let early_secret, epoch, exts, can_use_early_data =
307
+
resolve_psk config hrr cipher hostname ch raw log hlen
308
+
in
286
309
287
-
let certs = List.map X509.Certificate.encode_der chain in
288
-
let cert = Certificate (Writer.assemble_certificates_1_3 "" certs) in
289
-
let cert_raw = Writer.assemble_handshake cert in
290
-
Tracing.hs ~tag:"handshake-out" cert ;
291
-
let log = log ^ cert_raw in
310
+
let _, early_traffic_ctx = Handshake_crypto13.early_traffic early_secret raw in
292
311
293
-
let tbs =
294
-
let module H = (val Digestif.module_of_hash' (Ciphersuite.hash13 cipher)) in
295
-
H.(to_raw_string (digest_string log))
296
-
in
297
-
let* signed =
298
-
signature `TLS_1_3
299
-
~context_string:"TLS 1.3, server CertificateVerify"
300
-
tbs (Some sigalgs) config.Config.signature_algorithms priv
301
-
in
302
-
let cv = CertificateVerify signed in
303
-
let cv_raw = Writer.assemble_handshake cv in
304
-
Tracing.hs ~tag:"handshake-out" cv ;
305
-
let log = log ^ cv_raw in
306
-
Ok (out @ [cert_raw; cv_raw], log, session)
307
-
in
312
+
let secret, public = Handshake_crypto13.dh_gen_key group in
313
+
let* es = Handshake_crypto13.dh_shared secret keyshare in
314
+
let hs_secret = Handshake_crypto13.derive early_secret es in
315
+
Tracing.cs ~tag:"hs secret" hs_secret.secret ;
308
316
309
-
let master_secret = Handshake_crypto13.derive hs_secret (String.make hlen '\x00') in
310
-
Tracing.cs ~tag:"master-secret" master_secret.secret ;
317
+
let sh, session = make_server_hello13 ch cipher epoch (`KeyShare (group, public) :: exts) in
318
+
let sh_raw = Writer.assemble_handshake (ServerHello sh) in
319
+
Tracing.hs ~tag:"handshake-out" (ServerHello sh) ;
311
320
312
-
let f_data = finished hs_secret.hash server_hs_secret log in
313
-
let fin = Finished f_data in
314
-
let fin_raw = Writer.assemble_handshake fin in
321
+
let log = log ^ raw ^ sh_raw in
322
+
let server_hs_secret, server_ctx, client_hs_secret, client_ctx = hs_ctx hs_secret log in
315
323
316
-
Tracing.hs ~tag:"handshake-out" fin ;
324
+
let* sigalgs =
325
+
Option.to_result
326
+
~none:(`Fatal (`Missing_extension "signature algorithms"))
327
+
(Utils.map_find ~f:(function `SignatureAlgorithms sa -> Some sa | _ -> None) ch.extensions)
328
+
in
329
+
(* TODO respect certificate_signature_algs if present *)
317
330
318
-
let log = log ^ fin_raw in
319
-
let server_app_secret, server_app_ctx, client_app_secret, client_app_ctx =
320
-
app_ctx master_secret log
331
+
let f = supports_key_usage ~not_present:true `Digital_signature in
332
+
let* chain, priv =
333
+
let* r = agreed_cert ~f ~signature_algorithms:sigalgs config.Config.own_certificates hostname in
334
+
match r with
335
+
| c::cs, priv -> Ok (c::cs, priv)
336
+
| _ -> Error (`Fatal (`Handshake (`Message "couldn't find certificate chain")))
337
+
in
338
+
let* alpn_protocol = alpn_protocol config ch in
339
+
let session =
340
+
let common_session_data13 = { session.common_session_data13 with
341
+
own_name = hostname ; own_certificate = chain ;
342
+
own_private_key = Some priv ; alpn_protocol }
321
343
in
322
-
let exporter_master_secret = Handshake_crypto13.exporter master_secret log in
323
-
let session' = { session' with server_app_secret ; client_app_secret ; exporter_master_secret } in
344
+
{ session with common_session_data13 }
345
+
in
324
346
325
-
let* () =
326
-
guard (String.length state.hs_fragment = 0)
327
-
(`Fatal (`Handshake `Fragments))
347
+
let ee =
348
+
let hostname_ext = Option.fold ~none:[] ~some:(fun _ -> [`Hostname]) hostname
349
+
and alpn = Option.fold ~none:[] ~some:(fun proto -> [`ALPN proto]) alpn_protocol
350
+
and early_data = if can_use_early_data && config.Config.zero_rtt <> 0l then [ `EarlyDataIndication ] else []
328
351
in
352
+
EncryptedExtensions (hostname_ext @ alpn @ early_data)
353
+
in
354
+
(* 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 *)
355
+
let ee_raw = Writer.assemble_handshake ee in
356
+
Tracing.hs ~tag:"handshake-out" ee ;
357
+
let log = log ^ ee_raw in
329
358
330
-
(* send sessionticket early *)
331
-
(* TODO track the nonce across handshakes / newsessionticket messages (i.e. after post-handshake auth) - needs to be unique! *)
332
-
let st, st_raw =
333
-
match session.resumed, config.Config.ticket_cache with
334
-
| true, _ | _, None -> None, []
335
-
| false, Some cache ->
336
-
let age_add =
337
-
let cs = Crypto_rng.generate 4 in
338
-
String.get_int32_be cs 0
339
-
in
340
-
let psk_id = Crypto_rng.generate 32 in
341
-
let nonce = Crypto_rng.generate 4 in
342
-
let extensions = match config.Config.zero_rtt with
343
-
| 0l -> []
344
-
| x -> [ `EarlyDataIndication x ]
345
-
in
346
-
let st = { lifetime = cache.Config.lifetime ; age_add ; nonce ; ticket = psk_id ; extensions } in
347
-
Tracing.hs ~tag:"handshake-out" (SessionTicket st) ;
348
-
let st_raw = Writer.assemble_handshake (SessionTicket st) in
349
-
(Some st, [st_raw])
350
-
in
359
+
let* c_out, log, session' =
360
+
send_server_cert_messages config session cipher sigalgs chain priv log
361
+
in
351
362
352
-
let session =
353
-
let common_session_data13 = { session'.common_session_data13 with master_secret = master_secret.secret } in
354
-
{ session' with common_session_data13 ; master_secret }
355
-
in
356
-
let st, session =
357
-
if can_use_early_data then
358
-
(AwaitEndOfEarlyData13 (client_hs_secret, client_ctx, client_app_ctx, st, log),
359
-
`TLS13 { session with state = `ZeroRTT } :: state.session)
360
-
else if session.common_session_data13.client_auth then
361
-
(AwaitClientCertificate13 (session, client_hs_secret, client_app_ctx, st, log),
362
-
state.session)
363
-
else
364
-
(AwaitClientFinished13 (client_hs_secret, client_app_ctx, st, log),
365
-
`TLS13 session :: state.session)
366
-
in
367
-
let early_data_left = if List.mem `EarlyDataIndication ch.extensions then config.Config.zero_rtt else 0l in
368
-
Ok ({ state with machina = Server13 st ; session ; early_data_left },
369
-
`Record (Packet.HANDSHAKE, sh_raw) ::
370
-
(match ch.sessionid with
371
-
| Some _ when not hrr -> [`Record change_cipher_spec]
372
-
| _ -> []) @
373
-
[ `Change_enc server_ctx ;
374
-
`Change_dec (if can_use_early_data then early_traffic_ctx else client_ctx) ;
375
-
`Record (Packet.HANDSHAKE, ee_raw) ] @
376
-
List.map (fun data -> `Record (Packet.HANDSHAKE, data)) c_out @
377
-
[ `Record (Packet.HANDSHAKE, fin_raw) ;
378
-
`Change_enc server_app_ctx ] @
379
-
List.map (fun data -> `Record (Packet.HANDSHAKE, data)) st_raw)
363
+
complete_server_handshake ~hrr state config ch hlen hs_secret
364
+
server_hs_secret server_ctx client_hs_secret client_ctx early_traffic_ctx
365
+
can_use_early_data sh_raw ee_raw c_out session' log
366
+
367
+
let answer_client_hello ~hrr state ch raw =
368
+
let* () = client_hello_valid `TLS_1_3 ch in
369
+
let* () =
370
+
guard (not (hrr && List.mem `EarlyDataIndication ch.extensions))
371
+
(`Fatal (`Handshake (`Message "has 0RTT after hello retry request")))
372
+
in
373
+
Tracing.debug (fun m -> m "version %a" pp_tls_version `TLS_1_3) ;
374
+
375
+
let ciphers =
376
+
List.filter_map Ciphersuite.any_ciphersuite_to_ciphersuite13 ch.ciphersuites
377
+
in
378
+
379
+
let* groups = extract_supported_groups ch.extensions in
380
+
let* keyshares = extract_keyshares ch.extensions in
381
+
let config = state.config in
382
+
match
383
+
Utils.first_match (List.map fst keyshares) config.Config.groups,
384
+
Utils.first_match ciphers (Config.ciphers13 config)
385
+
with
386
+
| _, None -> Error (`Error (`NoConfiguredCiphersuite ciphers))
387
+
| None, Some cipher ->
388
+
if hrr then
389
+
(* avoid loops CH -> HRR -> CH -> HRR -> ... *)
390
+
Error (`Fatal (`Handshake (`Message "hello retry request already sent, still no supported group")))
391
+
else
392
+
(* no keyshare, looks whether there's a supported group ++ send back HRR *)
393
+
begin match Utils.first_match groups config.Config.groups with
394
+
| None -> Error (`Fatal (`Handshake (`Message "no supported group found")))
395
+
| Some group -> send_hello_retry state config ch raw cipher group
396
+
end
397
+
| Some group, Some cipher ->
398
+
handle_dhe_handshake ~hrr state config ch raw cipher group keyshares groups
380
399
381
400
let answer_client_certificate state cert (sd : session_data13) client_fini dec_ctx st raw log =
382
401
let* c = map_reader_error (Reader.parse_certificates_1_3 cert) in