unikernel/duniverse/ocaml-tls/lib/handshake_server.ml

@@ -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)))