1{-# LANGUAGE OverloadedStrings #-} 2-- | 3-- Module : Network.TLS.Handshake.Server 4-- License : BSD-style 5-- Maintainer : Vincent Hanquez <vincent@snarc.org> 6-- Stability : experimental 7-- Portability : unknown 8-- 9module Network.TLS.Handshake.Server 10 ( handshakeServer 11 , handshakeServerWith 12 , requestCertificateServer 13 , postHandshakeAuthServerWith 14 ) where 15 16import Network.TLS.Parameters 17import Network.TLS.Imports 18import Network.TLS.Context.Internal 19import Network.TLS.Session 20import Network.TLS.Struct 21import Network.TLS.Struct13 22import Network.TLS.Cipher 23import Network.TLS.Compression 24import Network.TLS.Credentials 25import Network.TLS.Crypto 26import Network.TLS.Extension 27import Network.TLS.Util (bytesEq, catchException, fromJust) 28import Network.TLS.IO 29import Network.TLS.Types 30import Network.TLS.State 31import Network.TLS.Handshake.State 32import Network.TLS.Handshake.Process 33import Network.TLS.Handshake.Key 34import Network.TLS.Handshake.Random 35import Network.TLS.Measurement 36import qualified Data.ByteString as B 37import Data.X509 (ExtKeyUsageFlag(..)) 38 39import Control.Monad.State.Strict 40import Control.Exception (bracket) 41 42import Network.TLS.Handshake.Signature 43import Network.TLS.Handshake.Common 44import Network.TLS.Handshake.Certificate 45import Network.TLS.X509 46import Network.TLS.Handshake.State13 47import Network.TLS.Handshake.Common13 48 49-- Put the server context in handshake mode. 50-- 51-- Expect to receive as first packet a client hello handshake message 52-- 53-- This is just a helper to pop the next message from the recv layer, 54-- and call handshakeServerWith. 55handshakeServer :: ServerParams -> Context -> IO () 56handshakeServer sparams ctx = liftIO $ do 57 hss <- recvPacketHandshake ctx 58 case hss of 59 [ch] -> handshakeServerWith sparams ctx ch 60 _ -> unexpected (show hss) (Just "client hello") 61 62-- | Put the server context in handshake mode. 63-- 64-- Expect a client hello message as parameter. 65-- This is useful when the client hello has been already poped from the recv layer to inspect the packet. 66-- 67-- When the function returns, a new handshake has been succesfully negociated. 68-- On any error, a HandshakeFailed exception is raised. 69-- 70-- handshake protocol (<- receiving, -> sending, [] optional): 71-- (no session) (session resumption) 72-- <- client hello <- client hello 73-- -> server hello -> server hello 74-- -> [certificate] 75-- -> [server key xchg] 76-- -> [cert request] 77-- -> hello done 78-- <- [certificate] 79-- <- client key xchg 80-- <- [cert verify] 81-- <- change cipher -> change cipher 82-- <- finish -> finish 83-- -> change cipher <- change cipher 84-- -> finish <- finish 85-- 86handshakeServerWith :: ServerParams -> Context -> Handshake -> IO () 87handshakeServerWith sparams ctx clientHello@(ClientHello legacyVersion _ clientSession ciphers compressions exts _) = do 88 established <- ctxEstablished ctx 89 -- renego is not allowed in TLS 1.3 90 when (established /= NotEstablished) $ do 91 ver <- usingState_ ctx (getVersionWithDefault TLS10) 92 when (ver == TLS13) $ throwCore $ Error_Protocol ("renegotiation is not allowed in TLS 1.3", True, UnexpectedMessage) 93 -- rejecting client initiated renegotiation to prevent DOS. 94 eof <- ctxEOF ctx 95 let renegotiation = established == Established && not eof 96 when (renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx)) $ 97 throwCore $ Error_Protocol ("renegotiation is not allowed", False, NoRenegotiation) 98 -- check if policy allow this new handshake to happens 99 handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams) 100 unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied") 101 updateMeasure ctx incrementNbHandshakes 102 103 -- Handle Client hello 104 processHandshake ctx clientHello 105 106 -- rejecting SSL2. RFC 6176 107 when (legacyVersion == SSL2) $ throwCore $ Error_Protocol ("SSL 2.0 is not supported", True, ProtocolVersion) 108 -- rejecting SSL3. RFC 7568 109 -- when (legacyVersion == SSL3) $ throwCore $ Error_Protocol ("SSL 3.0 is not supported", True, ProtocolVersion) 110 111 -- Fallback SCSV: RFC7507 112 -- TLS_FALLBACK_SCSV: {0x56, 0x00} 113 when (supportedFallbackScsv (ctxSupported ctx) && 114 (0x5600 `elem` ciphers) && 115 legacyVersion < TLS12) $ 116 throwCore $ Error_Protocol ("fallback is not allowed", True, InappropriateFallback) 117 -- choosing TLS version 118 let clientVersions = case extensionLookup extensionID_SupportedVersions exts >>= extensionDecode MsgTClientHello of 119 Just (SupportedVersionsClientHello vers) -> vers 120 _ -> [] 121 clientVersion = min TLS12 legacyVersion 122 serverVersions 123 | renegotiation = filter (< TLS13) (supportedVersions $ ctxSupported ctx) 124 | otherwise = supportedVersions $ ctxSupported ctx 125 mVersion = debugVersionForced $ serverDebug sparams 126 chosenVersion <- case mVersion of 127 Just cver -> return cver 128 Nothing -> 129 if (TLS13 `elem` serverVersions) && clientVersions /= [] then case findHighestVersionFrom13 clientVersions serverVersions of 130 Nothing -> throwCore $ Error_Protocol ("client versions " ++ show clientVersions ++ " is not supported", True, ProtocolVersion) 131 Just v -> return v 132 else case findHighestVersionFrom clientVersion serverVersions of 133 Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported", True, ProtocolVersion) 134 Just v -> return v 135 136 -- SNI (Server Name Indication) 137 let serverName = case extensionLookup extensionID_ServerName exts >>= extensionDecode MsgTClientHello of 138 Just (ServerName ns) -> listToMaybe (mapMaybe toHostName ns) 139 where toHostName (ServerNameHostName hostName) = Just hostName 140 toHostName (ServerNameOther _) = Nothing 141 _ -> Nothing 142 maybe (return ()) (usingState_ ctx . setClientSNI) serverName 143 144 -- ALPN (Application Layer Protocol Negotiation) 145 case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTClientHello of 146 Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos 147 _ -> return () 148 149 -- TLS version dependent 150 if chosenVersion <= TLS12 then 151 handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession 152 else do 153 mapM_ ensureNullCompression compressions 154 -- fixme: we should check if the client random is the same as 155 -- that in the first client hello in the case of hello retry. 156 handshakeServerWithTLS13 sparams ctx chosenVersion exts ciphers serverName clientSession 157handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure) 158 159-- TLS 1.2 or earlier 160handshakeServerWithTLS12 :: ServerParams 161 -> Context 162 -> Version 163 -> [ExtensionRaw] 164 -> [CipherID] 165 -> Maybe String 166 -> Version 167 -> [CompressionID] 168 -> Session 169 -> IO () 170handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession = do 171 extraCreds <- onServerNameIndication (serverHooks sparams) serverName 172 let allCreds = filterCredentials (isCredentialAllowed chosenVersion) $ 173 extraCreds `mappend` sharedCredentials (ctxShared ctx) 174 175 -- If compression is null, commonCompressions should be [0]. 176 when (null commonCompressions) $ throwCore $ 177 Error_Protocol ("no compression in common with the client", True, HandshakeFailure) 178 179 -- When selecting a cipher we must ensure that it is allowed for the 180 -- TLS version but also that all its key-exchange requirements 181 -- will be met. 182 183 -- Some ciphers require a signature and a hash. With TLS 1.2 the hash 184 -- algorithm is selected from a combination of server configuration and 185 -- the client "supported_signatures" extension. So we cannot pick 186 -- such a cipher if no hash is available for it. It's best to skip this 187 -- cipher and pick another one (with another key exchange). 188 189 -- Cipher selection is performed in two steps: first server credentials 190 -- are flagged as not suitable for signature if not compatible with 191 -- negotiated signature parameters. Then ciphers are evalutated from 192 -- the resulting credentials. 193 194 let possibleGroups = negotiatedGroupsInCommon ctx exts 195 possibleECGroups = possibleGroups `intersect` availableECGroups 196 possibleFFGroups = possibleGroups `intersect` availableFFGroups 197 hasCommonGroupForECDHE = not (null possibleECGroups) 198 hasCommonGroupForFFDHE = not (null possibleFFGroups) 199 hasCustomGroupForFFDHE = isJust (serverDHEParams sparams) 200 canFFDHE = hasCustomGroupForFFDHE || hasCommonGroupForFFDHE 201 hasCommonGroup cipher = 202 case cipherKeyExchange cipher of 203 CipherKeyExchange_DH_Anon -> canFFDHE 204 CipherKeyExchange_DHE_RSA -> canFFDHE 205 CipherKeyExchange_DHE_DSS -> canFFDHE 206 CipherKeyExchange_ECDHE_RSA -> hasCommonGroupForECDHE 207 CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE 208 _ -> True -- group not used 209 210 -- Ciphers are selected according to TLS version, availability of 211 -- (EC)DHE group and credential depending on key exchange. 212 cipherAllowed cipher = cipherAllowedForVersion chosenVersion cipher && hasCommonGroup cipher 213 selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials) 214 215 (creds, signatureCreds, ciphersFilteredVersion) 216 = case chosenVersion of 217 TLS12 -> let -- Build a list of all hash/signature algorithms in common between 218 -- client and server. 219 possibleHashSigAlgs = hashAndSignaturesInCommon ctx exts 220 221 -- Check that a candidate signature credential will be compatible with 222 -- client & server hash/signature algorithms. This returns Just Int 223 -- in order to sort credentials according to server hash/signature 224 -- preference. When the certificate has no matching hash/signature in 225 -- 'possibleHashSigAlgs' the result is Nothing, and the credential will 226 -- not be used to sign. This avoids a failure later in 'decideHashSig'. 227 signingRank cred = 228 case credentialDigitalSignatureKey cred of 229 Just pub -> findIndex (pub `signatureCompatible`) possibleHashSigAlgs 230 Nothing -> Nothing 231 232 -- Finally compute credential lists and resulting cipher list. 233 -- 234 -- We try to keep certificates supported by the client, but 235 -- fallback to all credentials if this produces no suitable result 236 -- (see RFC 5246 section 7.4.2 and RFC 8446 section 4.4.2.2). 237 -- The condition is based on resulting (EC)DHE ciphers so that 238 -- filtering credentials does not give advantage to a less secure 239 -- key exchange like CipherKeyExchange_RSA or CipherKeyExchange_DH_Anon. 240 cltCreds = filterCredentialsWithHashSignatures exts allCreds 241 sigCltCreds = filterSortCredentials signingRank cltCreds 242 sigAllCreds = filterSortCredentials signingRank allCreds 243 cltCiphers = selectCipher cltCreds sigCltCreds 244 allCiphers = selectCipher allCreds sigAllCreds 245 246 resultTuple = if cipherListCredentialFallback cltCiphers 247 then (allCreds, sigAllCreds, allCiphers) 248 else (cltCreds, sigCltCreds, cltCiphers) 249 in resultTuple 250 _ -> 251 let sigAllCreds = filterCredentials (isJust . credentialDigitalSignatureKey) allCreds 252 allCiphers = selectCipher allCreds sigAllCreds 253 in (allCreds, sigAllCreds, allCiphers) 254 255 -- The shared cipherlist can become empty after filtering for compatible 256 -- creds, check now before calling onCipherChoosing, which does not handle 257 -- empty lists. 258 when (null ciphersFilteredVersion) $ throwCore $ 259 Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) 260 261 let usedCipher = onCipherChoosing (serverHooks sparams) chosenVersion ciphersFilteredVersion 262 263 cred <- case cipherKeyExchange usedCipher of 264 CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds 265 CipherKeyExchange_DH_Anon -> return Nothing 266 CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds 267 CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning KX_DSS signatureCreds 268 CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds 269 CipherKeyExchange_ECDHE_ECDSA -> return $ credentialsFindForSigning KX_ECDSA signatureCreds 270 _ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure) 271 272 ems <- processExtendedMasterSec ctx chosenVersion MsgTClientHello exts 273 resumeSessionData <- case clientSession of 274 (Session (Just clientSessionId)) -> do 275 let resume = liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId 276 resume >>= validateSession serverName ems 277 (Session Nothing) -> return Nothing 278 279 -- Currently, we don't send back EcPointFormats. In this case, 280 -- the client chooses EcPointFormat_Uncompressed. 281 case extensionLookup extensionID_EcPointFormats exts >>= extensionDecode MsgTClientHello of 282 Just (EcPointFormatsSupported fs) -> usingState_ ctx $ setClientEcPointFormatSuggest fs 283 _ -> return () 284 285 doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts 286 287 where 288 commonCiphers creds sigCreds = filter ((`elem` ciphers) . cipherID) (getCiphers sparams creds sigCreds) 289 commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions 290 usedCompression = head commonCompressions 291 292 validateSession _ _ Nothing = return Nothing 293 validateSession sni ems m@(Just sd) 294 -- SessionData parameters are assumed to match the local server configuration 295 -- so we need to compare only to ClientHello inputs. Abbreviated handshake 296 -- uses the same server_name than full handshake so the same 297 -- credentials (and thus ciphers) are available. 298 | clientVersion < sessionVersion sd = return Nothing 299 | sessionCipher sd `notElem` ciphers = return Nothing 300 | sessionCompression sd `notElem` compressions = return Nothing 301 | isJust sni && sessionClientSNI sd /= sni = return Nothing 302 | ems && not emsSession = return Nothing 303 | not ems && emsSession = 304 let err = "client resumes an EMS session without EMS" 305 in throwCore $ Error_Protocol (err, True, HandshakeFailure) 306 | otherwise = return m 307 where emsSession = SessionEMS `elem` sessionFlags sd 308 309doHandshake :: ServerParams -> Maybe Credential -> Context -> Version -> Cipher 310 -> Compression -> Session -> Maybe SessionData 311 -> [ExtensionRaw] -> IO () 312doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts = do 313 case resumeSessionData of 314 Nothing -> do 315 handshakeSendServerData 316 liftIO $ contextFlush ctx 317 -- Receive client info until client Finished. 318 recvClientData sparams ctx 319 sendChangeCipherAndFinish ctx ServerRole 320 Just sessionData -> do 321 usingState_ ctx (setSession clientSession True) 322 serverhello <- makeServerHello clientSession 323 sendPacket ctx $ Handshake [serverhello] 324 let masterSecret = sessionSecret sessionData 325 usingHState ctx $ setMasterSecret chosenVersion ServerRole masterSecret 326 logKey ctx (MasterSecret masterSecret) 327 sendChangeCipherAndFinish ctx ServerRole 328 recvChangeCipherAndFinish ctx 329 handshakeTerminate ctx 330 where 331 --- 332 -- When the client sends a certificate, check whether 333 -- it is acceptable for the application. 334 -- 335 --- 336 makeServerHello session = do 337 srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams 338 case mcred of 339 Just cred -> storePrivInfoServer ctx cred 340 _ -> return () -- return a sensible error 341 342 -- in TLS12, we need to check as well the certificates we are sending if they have in the extension 343 -- the necessary bits set. 344 secReneg <- usingState_ ctx getSecureRenegotiation 345 secRengExt <- if secReneg 346 then do 347 vf <- usingState_ ctx $ do 348 cvf <- getVerifiedData ClientRole 349 svf <- getVerifiedData ServerRole 350 return $ extensionEncode (SecureRenegotiation cvf $ Just svf) 351 return [ ExtensionRaw extensionID_SecureRenegotiation vf ] 352 else return [] 353 ems <- usingHState ctx getExtendedMasterSec 354 let emsExt | ems = let raw = extensionEncode ExtendedMasterSecret 355 in [ ExtensionRaw extensionID_ExtendedMasterSecret raw ] 356 | otherwise = [] 357 protoExt <- applicationProtocol ctx exts sparams 358 sniExt <- do 359 resuming <- usingState_ ctx isSessionResuming 360 if resuming 361 then return [] 362 else do 363 msni <- usingState_ ctx getClientSNI 364 case msni of 365 -- RFC6066: In this event, the server SHALL include 366 -- an extension of type "server_name" in the 367 -- (extended) server hello. The "extension_data" 368 -- field of this extension SHALL be empty. 369 Just _ -> return [ ExtensionRaw extensionID_ServerName ""] 370 Nothing -> return [] 371 let extensions = secRengExt ++ emsExt ++ protoExt ++ sniExt 372 usingState_ ctx (setVersion chosenVersion) 373 usingHState ctx $ setServerHelloParameters chosenVersion srand usedCipher usedCompression 374 return $ ServerHello chosenVersion srand session (cipherID usedCipher) 375 (compressionID usedCompression) extensions 376 377 handshakeSendServerData = do 378 serverSession <- newSession ctx 379 usingState_ ctx (setSession serverSession False) 380 serverhello <- makeServerHello serverSession 381 -- send ServerHello & Certificate & ServerKeyXchg & CertReq 382 let certMsg = case mcred of 383 Just (srvCerts, _) -> Certificates srvCerts 384 _ -> Certificates $ CertificateChain [] 385 sendPacket ctx $ Handshake [ serverhello, certMsg ] 386 387 -- send server key exchange if needed 388 skx <- case cipherKeyExchange usedCipher of 389 CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon 390 CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE KX_RSA 391 CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE KX_DSS 392 CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE KX_RSA 393 CipherKeyExchange_ECDHE_ECDSA -> Just <$> generateSKX_ECDHE KX_ECDSA 394 _ -> return Nothing 395 maybe (return ()) (sendPacket ctx . Handshake . (:[]) . ServerKeyXchg) skx 396 397 -- FIXME we don't do this on a Anonymous server 398 399 -- When configured, send a certificate request with the DNs of all 400 -- configured CA certificates. 401 -- 402 -- Client certificates MUST NOT be accepted if not requested. 403 -- 404 when (serverWantClientCert sparams) $ do 405 usedVersion <- usingState_ ctx getVersion 406 let defaultCertTypes = [ CertificateType_RSA_Sign 407 , CertificateType_DSS_Sign 408 , CertificateType_ECDSA_Sign 409 ] 410 (certTypes, hashSigs) 411 | usedVersion < TLS12 = (defaultCertTypes, Nothing) 412 | otherwise = 413 let as = supportedHashSignatures $ ctxSupported ctx 414 in (nub $ mapMaybe hashSigToCertType as, Just as) 415 creq = CertRequest certTypes hashSigs 416 (map extractCAname $ serverCACertificates sparams) 417 usingHState ctx $ setCertReqSent True 418 sendPacket ctx (Handshake [creq]) 419 420 -- Send HelloDone 421 sendPacket ctx (Handshake [ServerHelloDone]) 422 423 setup_DHE = do 424 let possibleFFGroups = negotiatedGroupsInCommon ctx exts `intersect` availableFFGroups 425 (dhparams, priv, pub) <- 426 case possibleFFGroups of 427 [] -> 428 let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams 429 in case findFiniteFieldGroup dhparams of 430 Just g -> do 431 usingHState ctx $ setNegotiatedGroup g 432 generateFFDHE ctx g 433 Nothing -> do 434 (priv, pub) <- generateDHE ctx dhparams 435 return (dhparams, priv, pub) 436 g:_ -> do 437 usingHState ctx $ setNegotiatedGroup g 438 generateFFDHE ctx g 439 440 let serverParams = serverDHParamsFrom dhparams pub 441 442 usingHState ctx $ setServerDHParams serverParams 443 usingHState ctx $ setDHPrivate priv 444 return serverParams 445 446 -- Choosing a hash algorithm to sign (EC)DHE parameters 447 -- in ServerKeyExchange. Hash algorithm is not suggested by 448 -- the chosen cipher suite. So, it should be selected based on 449 -- the "signature_algorithms" extension in a client hello. 450 -- If RSA is also used for key exchange, this function is 451 -- not called. 452 decideHashSig pubKey = do 453 usedVersion <- usingState_ ctx getVersion 454 case usedVersion of 455 TLS12 -> do 456 let hashSigs = hashAndSignaturesInCommon ctx exts 457 case filter (pubKey `signatureCompatible`) hashSigs of 458 [] -> error ("no hash signature for " ++ pubkeyType pubKey) 459 x:_ -> return $ Just x 460 _ -> return Nothing 461 462 generateSKX_DHE kxsAlg = do 463 serverParams <- setup_DHE 464 pubKey <- getLocalPublicKey ctx 465 mhashSig <- decideHashSig pubKey 466 signed <- digitallySignDHParams ctx serverParams pubKey mhashSig 467 case kxsAlg of 468 KX_RSA -> return $ SKX_DHE_RSA serverParams signed 469 KX_DSS -> return $ SKX_DHE_DSS serverParams signed 470 _ -> error ("generate skx_dhe unsupported key exchange signature: " ++ show kxsAlg) 471 472 generateSKX_DH_Anon = SKX_DH_Anon <$> setup_DHE 473 474 setup_ECDHE grp = do 475 usingHState ctx $ setNegotiatedGroup grp 476 (srvpri, srvpub) <- generateECDHE ctx grp 477 let serverParams = ServerECDHParams grp srvpub 478 usingHState ctx $ setServerECDHParams serverParams 479 usingHState ctx $ setGroupPrivate srvpri 480 return serverParams 481 482 generateSKX_ECDHE kxsAlg = do 483 let possibleECGroups = negotiatedGroupsInCommon ctx exts `intersect` availableECGroups 484 grp <- case possibleECGroups of 485 [] -> throwCore $ Error_Protocol ("no common group", True, HandshakeFailure) 486 g:_ -> return g 487 serverParams <- setup_ECDHE grp 488 pubKey <- getLocalPublicKey ctx 489 mhashSig <- decideHashSig pubKey 490 signed <- digitallySignECDHParams ctx serverParams pubKey mhashSig 491 case kxsAlg of 492 KX_RSA -> return $ SKX_ECDHE_RSA serverParams signed 493 KX_ECDSA -> return $ SKX_ECDHE_ECDSA serverParams signed 494 _ -> error ("generate skx_ecdhe unsupported key exchange signature: " ++ show kxsAlg) 495 496 -- create a DigitallySigned objects for DHParams or ECDHParams. 497 498-- | receive Client data in handshake until the Finished handshake. 499-- 500-- <- [certificate] 501-- <- client key xchg 502-- <- [cert verify] 503-- <- change cipher 504-- <- finish 505-- 506recvClientData :: ServerParams -> Context -> IO () 507recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate) 508 where processClientCertificate (Certificates certs) = do 509 clientCertificate sparams ctx certs 510 511 -- FIXME: We should check whether the certificate 512 -- matches our request and that we support 513 -- verifying with that certificate. 514 515 return $ RecvStateHandshake processClientKeyExchange 516 517 processClientCertificate p = processClientKeyExchange p 518 519 -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher, 520 -- so we must process any packet, and in case of handshake call processHandshake manually. 521 processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify 522 processClientKeyExchange p = unexpected (show p) (Just "client key exchange") 523 524 -- Check whether the client correctly signed the handshake. 525 -- If not, ask the application on how to proceed. 526 -- 527 processCertificateVerify (Handshake [hs@(CertVerify dsig)]) = do 528 processHandshake ctx hs 529 530 certs <- checkValidClientCertChain ctx "change cipher message expected" 531 532 usedVersion <- usingState_ ctx getVersion 533 -- Fetch all handshake messages up to now. 534 msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages 535 536 pubKey <- usingHState ctx getRemotePublicKey 537 checkDigitalSignatureKey usedVersion pubKey 538 539 verif <- checkCertificateVerify ctx usedVersion pubKey msgs dsig 540 clientCertVerify sparams ctx certs verif 541 return $ RecvStateNext expectChangeCipher 542 543 processCertificateVerify p = do 544 chain <- usingHState ctx getClientCertChain 545 case chain of 546 Just cc | isNullCertificateChain cc -> return () 547 | otherwise -> throwCore $ Error_Protocol ("cert verify message missing", True, UnexpectedMessage) 548 Nothing -> return () 549 expectChangeCipher p 550 551 expectChangeCipher ChangeCipherSpec = do 552 return $ RecvStateHandshake expectFinish 553 554 expectChangeCipher p = unexpected (show p) (Just "change cipher") 555 556 expectFinish (Finished _) = return RecvStateDone 557 expectFinish p = unexpected (show p) (Just "Handshake Finished") 558 559checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain 560checkValidClientCertChain ctx errmsg = do 561 chain <- usingHState ctx getClientCertChain 562 let throwerror = Error_Protocol (errmsg , True, UnexpectedMessage) 563 case chain of 564 Nothing -> throwCore throwerror 565 Just cc | isNullCertificateChain cc -> throwCore throwerror 566 | otherwise -> return cc 567 568hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] 569hashAndSignaturesInCommon ctx exts = 570 let cHashSigs = case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode MsgTClientHello of 571 -- See Section 7.4.1.4.1 of RFC 5246. 572 Nothing -> [(HashSHA1, SignatureECDSA) 573 ,(HashSHA1, SignatureRSA) 574 ,(HashSHA1, SignatureDSS)] 575 Just (SignatureAlgorithms sas) -> sas 576 sHashSigs = supportedHashSignatures $ ctxSupported ctx 577 -- The values in the "signature_algorithms" extension 578 -- are in descending order of preference. 579 -- However here the algorithms are selected according 580 -- to server preference in 'supportedHashSignatures'. 581 in sHashSigs `intersect` cHashSigs 582 583negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group] 584negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of 585 Just (NegotiatedGroups clientGroups) -> 586 let serverGroups = supportedGroups (ctxSupported ctx) 587 in serverGroups `intersect` clientGroups 588 _ -> [] 589 590credentialDigitalSignatureKey :: Credential -> Maybe PubKey 591credentialDigitalSignatureKey cred 592 | isDigitalSignaturePair keys = Just pubkey 593 | otherwise = Nothing 594 where keys@(pubkey, _) = credentialPublicPrivateKeys cred 595 596filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials 597filterCredentials p (Credentials l) = Credentials (filter p l) 598 599filterSortCredentials :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials 600filterSortCredentials rankFun (Credentials creds) = 601 let orderedPairs = sortOn fst [ (rankFun cred, cred) | cred <- creds ] 602 in Credentials [ cred | (Just _, cred) <- orderedPairs ] 603 604isCredentialAllowed :: Version -> Credential -> Bool 605isCredentialAllowed ver cred = pubkey `versionCompatible` ver 606 where (pubkey, _) = credentialPublicPrivateKeys cred 607 608-- Filters a list of candidate credentials with credentialMatchesHashSignatures. 609-- 610-- Algorithms to filter with are taken from "signature_algorithms_cert" 611-- extension when it exists, else from "signature_algorithms" when clients do 612-- not implement the new extension (see RFC 8446 section 4.2.3). 613-- 614-- Resulting credential list can be used as input to the hybrid cipher-and- 615-- certificate selection for TLS12, or to the direct certificate selection 616-- simplified with TLS13. As filtering credential signatures with client- 617-- advertised algorithms is not supposed to cause negotiation failure, in case 618-- of dead end with the subsequent selection process, this process should always 619-- be restarted with the unfiltered credential list as input (see fallback 620-- certificate chains, described in same RFC section). 621-- 622-- Calling code should not forget to apply constraints of extension 623-- "signature_algorithms" to any signature-based key exchange derived from the 624-- output credentials. Respecting client constraints on KX signatures is 625-- mandatory but not implemented by this function. 626filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials 627filterCredentialsWithHashSignatures exts = 628 case withExt extensionID_SignatureAlgorithmsCert of 629 Just (SignatureAlgorithmsCert sas) -> withAlgs sas 630 Nothing -> 631 case withExt extensionID_SignatureAlgorithms of 632 Nothing -> id 633 Just (SignatureAlgorithms sas) -> withAlgs sas 634 where 635 withExt extId = extensionLookup extId exts >>= extensionDecode MsgTClientHello 636 withAlgs sas = filterCredentials (credentialMatchesHashSignatures sas) 637 638-- returns True if certificate filtering with "signature_algorithms_cert" / 639-- "signature_algorithms" produced no ephemeral D-H nor TLS13 cipher (so 640-- handshake with lower security) 641cipherListCredentialFallback :: [Cipher] -> Bool 642cipherListCredentialFallback = all nonDH 643 where 644 nonDH x = case cipherKeyExchange x of 645 CipherKeyExchange_DHE_RSA -> False 646 CipherKeyExchange_DHE_DSS -> False 647 CipherKeyExchange_ECDHE_RSA -> False 648 CipherKeyExchange_ECDHE_ECDSA -> False 649 CipherKeyExchange_TLS13 -> False 650 _ -> True 651 652storePrivInfoServer :: MonadIO m => Context -> Credential -> m () 653storePrivInfoServer ctx (cc, privkey) = void (storePrivInfo ctx cc privkey) 654 655-- TLS 1.3 or later 656handshakeServerWithTLS13 :: ServerParams 657 -> Context 658 -> Version 659 -> [ExtensionRaw] 660 -> [CipherID] 661 -> Maybe String 662 -> Session 663 -> IO () 664handshakeServerWithTLS13 sparams ctx chosenVersion exts clientCiphers _serverName clientSession = do 665 when (any (\(ExtensionRaw eid _) -> eid == extensionID_PreSharedKey) $ init exts) $ 666 throwCore $ Error_Protocol ("extension pre_shared_key must be last", True, IllegalParameter) 667 -- Deciding cipher. 668 -- The shared cipherlist can become empty after filtering for compatible 669 -- creds, check now before calling onCipherChoosing, which does not handle 670 -- empty lists. 671 when (null ciphersFilteredVersion) $ throwCore $ 672 Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) 673 let usedCipher = onCipherChoosing (serverHooks sparams) chosenVersion ciphersFilteredVersion 674 usedHash = cipherHash usedCipher 675 rtt0 = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTClientHello of 676 Just (EarlyDataIndication _) -> True 677 Nothing -> False 678 when rtt0 $ 679 -- mark a 0-RTT attempt before a possible HRR, and before updating the 680 -- status again if 0-RTT successful 681 setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding 682 -- Deciding key exchange from key shares 683 keyShares <- case extensionLookup extensionID_KeyShare exts >>= extensionDecode MsgTClientHello of 684 Just (KeyShareClientHello kses) -> return kses 685 Just _ -> error "handshakeServerWithTLS13: invalid KeyShare value" 686 _ -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure) 687 case findKeyShare keyShares serverGroups of 688 Nothing -> helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession 689 Just keyShare -> doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash keyShare clientSession rtt0 690 where 691 ciphersFilteredVersion = filter ((`elem` clientCiphers) . cipherID) serverCiphers 692 serverCiphers = filter (cipherAllowedForVersion chosenVersion) (supportedCiphers $ serverSupported sparams) 693 serverGroups = supportedGroups (ctxSupported ctx) 694 findKeyShare _ [] = Nothing 695 findKeyShare ks (g:gs) = case find (\ent -> keyShareEntryGroup ent == g) ks of 696 Just k -> Just k 697 Nothing -> findKeyShare ks gs 698 699doHandshake13 :: ServerParams -> Context -> Version 700 -> Cipher -> [ExtensionRaw] 701 -> Hash -> KeyShareEntry 702 -> Session -> Bool 703 -> IO () 704doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare clientSession rtt0 = do 705 newSession ctx >>= \ss -> usingState_ ctx $ do 706 setSession ss False 707 setClientSupportsPHA supportsPHA 708 usingHState ctx $ setNegotiatedGroup $ keyShareEntryGroup clientKeyShare 709 srand <- setServerParameter 710 -- ALPN is used in choosePSK 711 protoExt <- applicationProtocol ctx exts sparams 712 (psk, binderInfo, is0RTTvalid) <- choosePSK 713 earlyKey <- calculateEarlySecret ctx choice (Left psk) True 714 let earlySecret = pairBase earlyKey 715 ClientTrafficSecret clientEarlySecret = pairClient earlyKey 716 extensions <- checkBinder earlySecret binderInfo 717 hrr <- usingState_ ctx getTLS13HRR 718 let authenticated = isJust binderInfo 719 rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid 720 extraCreds <- usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams) 721 let allCreds = filterCredentials (isCredentialAllowed chosenVersion) $ 722 extraCreds `mappend` sharedCredentials (ctxShared ctx) 723 ---------------------------------------------------------------- 724 established <- ctxEstablished ctx 725 if established /= NotEstablished then 726 if rtt0OK then do 727 usingHState ctx $ setTLS13HandshakeMode RTT0 728 usingHState ctx $ setTLS13RTT0Status RTT0Accepted 729 else do 730 usingHState ctx $ setTLS13HandshakeMode RTT0 731 usingHState ctx $ setTLS13RTT0Status RTT0Rejected 732 else 733 if authenticated then 734 usingHState ctx $ setTLS13HandshakeMode PreSharedKey 735 else 736 -- FullHandshake or HelloRetryRequest 737 return () 738 mCredInfo <- if authenticated then return Nothing else decideCredentialInfo allCreds 739 (ecdhe,keyShare) <- makeServerKeyShare ctx clientKeyShare 740 ensureRecvComplete ctx 741 (clientHandshakeSecret, handshakeSecret) <- runPacketFlight ctx $ do 742 sendServerHello keyShare srand extensions 743 sendChangeCipherSpec13 ctx 744 ---------------------------------------------------------------- 745 handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe 746 let ServerTrafficSecret serverHandshakeSecret = triServer handKey 747 ClientTrafficSecret clientHandshakeSecret = triClient handKey 748 liftIO $ do 749 setRxState ctx usedHash usedCipher $ if rtt0OK then clientEarlySecret else clientHandshakeSecret 750 setTxState ctx usedHash usedCipher serverHandshakeSecret 751 ---------------------------------------------------------------- 752 sendExtensions rtt0OK protoExt 753 case mCredInfo of 754 Nothing -> return () 755 Just (cred, hashSig) -> sendCertAndVerify cred hashSig 756 rawFinished <- makeFinished ctx usedHash serverHandshakeSecret 757 loadPacket13 ctx $ Handshake13 [rawFinished] 758 return (clientHandshakeSecret, triBase handKey) 759 sfSentTime <- getCurrentTimeFromBase 760 ---------------------------------------------------------------- 761 hChSf <- transcriptHash ctx 762 appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf 763 let ClientTrafficSecret clientApplicationSecret0 = triClient appKey 764 ServerTrafficSecret serverApplicationSecret0 = triServer appKey 765 applicationSecret = triBase appKey 766 setTxState ctx usedHash usedCipher serverApplicationSecret0 767 ---------------------------------------------------------------- 768 if rtt0OK then 769 setEstablished ctx (EarlyDataAllowed rtt0max) 770 else when (established == NotEstablished) $ 771 setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding 772 773 let expectFinished hChBeforeCf (Finished13 verifyData) = liftIO $ do 774 checkFinished usedHash clientHandshakeSecret hChBeforeCf verifyData 775 handshakeTerminate13 ctx 776 setRxState ctx usedHash usedCipher clientApplicationSecret0 777 sendNewSessionTicket applicationSecret sfSentTime 778 expectFinished _ hs = unexpected (show hs) (Just "finished 13") 779 780 let expectEndOfEarlyData EndOfEarlyData13 = 781 setRxState ctx usedHash usedCipher clientHandshakeSecret 782 expectEndOfEarlyData hs = unexpected (show hs) (Just "end of early data") 783 784 if not authenticated && serverWantClientCert sparams then 785 runRecvHandshake13 $ do 786 skip <- recvHandshake13 ctx expectCertificate 787 unless skip $ recvHandshake13hash ctx (expectCertVerify sparams ctx) 788 recvHandshake13hash ctx expectFinished 789 ensureRecvComplete ctx 790 else if rtt0OK then 791 setPendingActions ctx [PendingAction True expectEndOfEarlyData 792 ,PendingActionHash True expectFinished] 793 else 794 runRecvHandshake13 $ do 795 recvHandshake13hash ctx expectFinished 796 ensureRecvComplete ctx 797 where 798 choice = makeCipherChoice chosenVersion usedCipher 799 800 setServerParameter = do 801 srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams 802 usingState_ ctx $ setVersion chosenVersion 803 failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher 804 return srand 805 806 supportsPHA = case extensionLookup extensionID_PostHandshakeAuth exts >>= extensionDecode MsgTClientHello of 807 Just PostHandshakeAuth -> True 808 Nothing -> False 809 810 choosePSK = case extensionLookup extensionID_PreSharedKey exts >>= extensionDecode MsgTClientHello of 811 Just (PreSharedKeyClientHello (PskIdentity sessionId obfAge:_) bnds@(bnd:_)) -> do 812 when (null dhModes) $ 813 throwCore $ Error_Protocol ("no psk_key_exchange_modes extension", True, MissingExtension) 814 if PSK_DHE_KE `elem` dhModes then do 815 let len = sum (map (\x -> B.length x + 1) bnds) + 2 816 mgr = sharedSessionManager $ serverShared sparams 817 msdata <- if rtt0 then sessionResumeOnlyOnce mgr sessionId 818 else sessionResume mgr sessionId 819 case msdata of 820 Just sdata -> do 821 let Just tinfo = sessionTicketInfo sdata 822 psk = sessionSecret sdata 823 isFresh <- checkFreshness tinfo obfAge 824 (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata 825 if isPSKvalid && isFresh then 826 return (psk, Just (bnd,0::Int,len),is0RTTvalid) 827 else 828 -- fall back to full handshake 829 return (zero, Nothing, False) 830 _ -> return (zero, Nothing, False) 831 else return (zero, Nothing, False) 832 _ -> return (zero, Nothing, False) 833 834 checkSessionEquality sdata = do 835 msni <- usingState_ ctx getClientSNI 836 malpn <- usingState_ ctx getNegotiatedProtocol 837 let isSameSNI = sessionClientSNI sdata == msni 838 isSameCipher = sessionCipher sdata == cipherID usedCipher 839 ciphers = supportedCiphers $ serverSupported sparams 840 isSameKDF = case find (\c -> cipherID c == sessionCipher sdata) ciphers of 841 Nothing -> False 842 Just c -> cipherHash c == cipherHash usedCipher 843 isSameVersion = chosenVersion == sessionVersion sdata 844 isSameALPN = sessionALPN sdata == malpn 845 isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required 846 is0RTTvalid = isSameVersion && isSameCipher && isSameALPN 847 return (isPSKvalid, is0RTTvalid) 848 849 rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams 850 rtt0accept = serverEarlyDataSize sparams > 0 851 852 checkBinder _ Nothing = return [] 853 checkBinder earlySecret (Just (binder,n,tlen)) = do 854 binder' <- makePSKBinder ctx earlySecret usedHash tlen Nothing 855 unless (binder `bytesEq` binder') $ 856 decryptError "PSK binder validation failed" 857 let selectedIdentity = extensionEncode $ PreSharedKeyServerHello $ fromIntegral n 858 return [ExtensionRaw extensionID_PreSharedKey selectedIdentity] 859 860 decideCredentialInfo allCreds = do 861 cHashSigs <- case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode MsgTClientHello of 862 Nothing -> throwCore $ Error_Protocol ("no signature_algorithms extension", True, MissingExtension) 863 Just (SignatureAlgorithms sas) -> return sas 864 -- When deciding signature algorithm and certificate, we try to keep 865 -- certificates supported by the client, but fallback to all credentials 866 -- if this produces no suitable result (see RFC 5246 section 7.4.2 and 867 -- RFC 8446 section 4.4.2.2). 868 let sHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx 869 hashSigs = sHashSigs `intersect` cHashSigs 870 cltCreds = filterCredentialsWithHashSignatures exts allCreds 871 case credentialsFindForSigning13 hashSigs cltCreds of 872 Nothing -> 873 case credentialsFindForSigning13 hashSigs allCreds of 874 Nothing -> throwCore $ Error_Protocol ("credential not found", True, HandshakeFailure) 875 mcs -> return mcs 876 mcs -> return mcs 877 878 sendServerHello keyShare srand extensions = do 879 let serverKeyShare = extensionEncode $ KeyShareServerHello keyShare 880 selectedVersion = extensionEncode $ SupportedVersionsServerHello chosenVersion 881 extensions' = ExtensionRaw extensionID_KeyShare serverKeyShare 882 : ExtensionRaw extensionID_SupportedVersions selectedVersion 883 : extensions 884 helo = ServerHello13 srand clientSession (cipherID usedCipher) extensions' 885 loadPacket13 ctx $ Handshake13 [helo] 886 887 sendCertAndVerify cred@(certChain, _) hashSig = do 888 storePrivInfoServer ctx cred 889 when (serverWantClientCert sparams) $ do 890 let certReqCtx = "" -- this must be zero length here. 891 certReq = makeCertRequest sparams ctx certReqCtx 892 loadPacket13 ctx $ Handshake13 [certReq] 893 usingHState ctx $ setCertReqSent True 894 895 let CertificateChain cs = certChain 896 ess = replicate (length cs) [] 897 loadPacket13 ctx $ Handshake13 [Certificate13 "" certChain ess] 898 hChSc <- transcriptHash ctx 899 pubkey <- getLocalPublicKey ctx 900 vrfy <- makeCertVerify ctx pubkey hashSig hChSc 901 loadPacket13 ctx $ Handshake13 [vrfy] 902 903 sendExtensions rtt0OK protoExt = do 904 msni <- liftIO $ usingState_ ctx getClientSNI 905 let sniExtension = case msni of 906 -- RFC6066: In this event, the server SHALL include 907 -- an extension of type "server_name" in the 908 -- (extended) server hello. The "extension_data" 909 -- field of this extension SHALL be empty. 910 Just _ -> Just $ ExtensionRaw extensionID_ServerName "" 911 Nothing -> Nothing 912 mgroup <- usingHState ctx getNegotiatedGroup 913 let serverGroups = supportedGroups (ctxSupported ctx) 914 groupExtension 915 | null serverGroups = Nothing 916 | maybe True (== head serverGroups) mgroup = Nothing 917 | otherwise = Just $ ExtensionRaw extensionID_NegotiatedGroups $ extensionEncode (NegotiatedGroups serverGroups) 918 let earlyDataExtension 919 | rtt0OK = Just $ ExtensionRaw extensionID_EarlyData $ extensionEncode (EarlyDataIndication Nothing) 920 | otherwise = Nothing 921 let extensions = catMaybes [earlyDataExtension, groupExtension, sniExtension] ++ protoExt 922 loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions] 923 924 sendNewSessionTicket applicationSecret sfSentTime = when sendNST $ do 925 cfRecvTime <- getCurrentTimeFromBase 926 let rtt = cfRecvTime - sfSentTime 927 nonce <- getStateRNG ctx 32 928 resumptionMasterSecret <- calculateResumptionSecret ctx choice applicationSecret 929 let life = toSeconds $ serverTicketLifetime sparams 930 psk = derivePSK choice resumptionMasterSecret nonce 931 (label, add) <- generateSession life psk rtt0max rtt 932 let nst = createNewSessionTicket life add nonce label rtt0max 933 sendPacket13 ctx $ Handshake13 [nst] 934 where 935 sendNST = PSK_DHE_KE `elem` dhModes 936 generateSession life psk maxSize rtt = do 937 Session (Just sessionId) <- newSession ctx 938 tinfo <- createTLS13TicketInfo life (Left ctx) (Just rtt) 939 sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk 940 let mgr = sharedSessionManager $ serverShared sparams 941 sessionEstablish mgr sessionId sdata 942 return (sessionId, ageAdd tinfo) 943 createNewSessionTicket life add nonce label maxSize = 944 NewSessionTicket13 life add nonce label extensions 945 where 946 tedi = extensionEncode $ EarlyDataIndication $ Just $ fromIntegral maxSize 947 extensions = [ExtensionRaw extensionID_EarlyData tedi] 948 toSeconds i | i < 0 = 0 949 | i > 604800 = 604800 950 | otherwise = fromIntegral i 951 952 dhModes = case extensionLookup extensionID_PskKeyExchangeModes exts >>= extensionDecode MsgTClientHello of 953 Just (PskKeyExchangeModes ms) -> ms 954 Nothing -> [] 955 956 expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool 957 expectCertificate (Certificate13 certCtx certs _ext) = liftIO $ do 958 when (certCtx /= "") $ throwCore $ Error_Protocol ("certificate request context MUST be empty", True, IllegalParameter) 959 -- fixme checking _ext 960 clientCertificate sparams ctx certs 961 return $ isNullCertificateChain certs 962 expectCertificate hs = unexpected (show hs) (Just "certificate 13") 963 964 hashSize = hashDigestSize usedHash 965 zero = B.replicate hashSize 0 966 967expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m () 968expectCertVerify sparams ctx hChCc (CertVerify13 sigAlg sig) = liftIO $ do 969 certs@(CertificateChain cc) <- checkValidClientCertChain ctx "finished 13 message expected" 970 pubkey <- case cc of 971 [] -> throwCore $ Error_Protocol ("client certificate missing", True, HandshakeFailure) 972 c:_ -> return $ certPubKey $ getCertificate c 973 ver <- usingState_ ctx getVersion 974 checkDigitalSignatureKey ver pubkey 975 usingHState ctx $ setPublicKey pubkey 976 verif <- checkCertVerify ctx pubkey sigAlg sig hChCc 977 clientCertVerify sparams ctx certs verif 978expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13") 979 980helloRetryRequest :: MonadIO m => ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> [Group] -> Session -> m () 981helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession = liftIO $ do 982 twice <- usingState_ ctx getTLS13HRR 983 when twice $ 984 throwCore $ Error_Protocol ("Hello retry not allowed again", True, HandshakeFailure) 985 usingState_ ctx $ setTLS13HRR True 986 failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher 987 let clientGroups = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of 988 Just (NegotiatedGroups gs) -> gs 989 Nothing -> [] 990 possibleGroups = serverGroups `intersect` clientGroups 991 case possibleGroups of 992 [] -> throwCore $ Error_Protocol ("no group in common with the client for HRR", True, HandshakeFailure) 993 g:_ -> do 994 let serverKeyShare = extensionEncode $ KeyShareHRR g 995 selectedVersion = extensionEncode $ SupportedVersionsServerHello chosenVersion 996 extensions = [ExtensionRaw extensionID_KeyShare serverKeyShare 997 ,ExtensionRaw extensionID_SupportedVersions selectedVersion] 998 hrr = ServerHello13 hrrRandom clientSession (cipherID usedCipher) extensions 999 usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest 1000 runPacketFlight ctx $ do 1001 loadPacket13 ctx $ Handshake13 [hrr] 1002 sendChangeCipherSpec13 ctx 1003 handshakeServer sparams ctx 1004 1005findHighestVersionFrom :: Version -> [Version] -> Maybe Version 1006findHighestVersionFrom clientVersion allowedVersions = 1007 case filter (clientVersion >=) $ sortOn Down allowedVersions of 1008 [] -> Nothing 1009 v:_ -> Just v 1010 1011-- We filter our allowed ciphers here according to dynamic credential lists. 1012-- Credentials 'creds' come from server parameters but also SNI callback. 1013-- When the key exchange requires a signature, we use a 1014-- subset of this list named 'sigCreds'. This list has been filtered in order 1015-- to remove certificates that are not compatible with hash/signature 1016-- restrictions (TLS 1.2). 1017getCiphers :: ServerParams -> Credentials -> Credentials -> [Cipher] 1018getCiphers sparams creds sigCreds = filter authorizedCKE (supportedCiphers $ serverSupported sparams) 1019 where authorizedCKE cipher = 1020 case cipherKeyExchange cipher of 1021 CipherKeyExchange_RSA -> canEncryptRSA 1022 CipherKeyExchange_DH_Anon -> True 1023 CipherKeyExchange_DHE_RSA -> canSignRSA 1024 CipherKeyExchange_DHE_DSS -> canSignDSS 1025 CipherKeyExchange_ECDHE_RSA -> canSignRSA 1026 CipherKeyExchange_ECDHE_ECDSA -> canSignECDSA 1027 -- unimplemented: non ephemeral DH & ECDH. 1028 -- Note, these *should not* be implemented, and have 1029 -- (for example) been removed in OpenSSL 1.1.0 1030 -- 1031 CipherKeyExchange_DH_DSS -> False 1032 CipherKeyExchange_DH_RSA -> False 1033 CipherKeyExchange_ECDH_ECDSA -> False 1034 CipherKeyExchange_ECDH_RSA -> False 1035 CipherKeyExchange_TLS13 -> False -- not reached 1036 1037 canSignDSS = KX_DSS `elem` signingAlgs 1038 canSignRSA = KX_RSA `elem` signingAlgs 1039 canSignECDSA = KX_ECDSA `elem` signingAlgs 1040 canEncryptRSA = isJust $ credentialsFindForDecrypting creds 1041 signingAlgs = credentialsListSigningAlgorithms sigCreds 1042 1043findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version 1044findHighestVersionFrom13 clientVersions serverVersions = case svs `intersect` cvs of 1045 [] -> Nothing 1046 v:_ -> Just v 1047 where 1048 svs = sortOn Down serverVersions 1049 cvs = sortOn Down clientVersions 1050 1051applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw] 1052applicationProtocol ctx exts sparams 1053 | clientALPNSuggest = do 1054 suggest <- usingState_ ctx getClientALPNSuggest 1055 case (onALPNClientSuggest $ serverHooks sparams, suggest) of 1056 (Just io, Just protos) -> do 1057 proto <- io protos 1058 usingState_ ctx $ do 1059 setExtensionALPN True 1060 setNegotiatedProtocol proto 1061 return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation 1062 (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ] 1063 (_, _) -> return [] 1064 | otherwise = return [] 1065 where 1066 clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts 1067 1068credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm) 1069credentialsFindForSigning13 hss0 creds = loop hss0 1070 where 1071 loop [] = Nothing 1072 loop (hs:hss) = case credentialsFindForSigning13' hs creds of 1073 Nothing -> credentialsFindForSigning13 hss creds 1074 Just cred -> Just (cred, hs) 1075 1076-- See credentialsFindForSigning. 1077credentialsFindForSigning13' :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential 1078credentialsFindForSigning13' sigAlg (Credentials l) = find forSigning l 1079 where 1080 forSigning cred = case credentialDigitalSignatureKey cred of 1081 Nothing -> False 1082 Just pub -> pub `signatureCompatible13` sigAlg 1083 1084clientCertificate :: ServerParams -> Context -> CertificateChain -> IO () 1085clientCertificate sparams ctx certs = do 1086 -- run certificate recv hook 1087 ctxWithHooks ctx (`hookRecvCertificates` certs) 1088 -- Call application callback to see whether the 1089 -- certificate chain is acceptable. 1090 -- 1091 usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs) rejectOnException 1092 case usage of 1093 CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs 1094 CertificateUsageReject reason -> certificateRejected reason 1095 1096 -- Remember cert chain for later use. 1097 -- 1098 usingHState ctx $ setClientCertChain certs 1099 1100clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO () 1101clientCertVerify sparams ctx certs verif = do 1102 if verif then do 1103 -- When verification succeeds, commit the 1104 -- client certificate chain to the context. 1105 -- 1106 usingState_ ctx $ setClientCertificateChain certs 1107 return () 1108 else do 1109 -- Either verification failed because of an 1110 -- invalid format (with an error message), or 1111 -- the signature is wrong. In either case, 1112 -- ask the application if it wants to 1113 -- proceed, we will do that. 1114 res <- liftIO $ onUnverifiedClientCert (serverHooks sparams) 1115 if res then do 1116 -- When verification fails, but the 1117 -- application callbacks accepts, we 1118 -- also commit the client certificate 1119 -- chain to the context. 1120 usingState_ ctx $ setClientCertificateChain certs 1121 else decryptError "verification failed" 1122 1123newCertReqContext :: Context -> IO CertReqContext 1124newCertReqContext ctx = getStateRNG ctx 32 1125 1126requestCertificateServer :: ServerParams -> Context -> IO Bool 1127requestCertificateServer sparams ctx = do 1128 tls13 <- tls13orLater ctx 1129 supportsPHA <- usingState_ ctx getClientSupportsPHA 1130 let ok = tls13 && supportsPHA 1131 when ok $ do 1132 certReqCtx <- newCertReqContext ctx 1133 let certReq = makeCertRequest sparams ctx certReqCtx 1134 bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do 1135 addCertRequest13 ctx certReq 1136 sendPacket13 ctx $ Handshake13 [certReq] 1137 return ok 1138 1139postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO () 1140postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx certs _ext) = do 1141 mCertReq <- getCertRequest13 ctx certCtx 1142 when (isNothing mCertReq) $ throwCore $ Error_Protocol ("unknown certificate request context", True, DecodeError) 1143 let certReq = fromJust "certReq" mCertReq 1144 1145 -- fixme checking _ext 1146 clientCertificate sparams ctx certs 1147 1148 baseHState <- saveHState ctx 1149 processHandshake13 ctx certReq 1150 processHandshake13 ctx h 1151 1152 (usedHash, _, applicationSecretN) <- getRxState ctx 1153 1154 let expectFinished hChBeforeCf (Finished13 verifyData) = do 1155 checkFinished usedHash applicationSecretN hChBeforeCf verifyData 1156 void $ restoreHState ctx baseHState 1157 expectFinished _ hs = unexpected (show hs) (Just "finished 13") 1158 1159 -- Note: here the server could send updated NST too, however the library 1160 -- currently has no API to handle resumption and client authentication 1161 -- together, see discussion in #133 1162 if isNullCertificateChain certs 1163 then setPendingActions ctx [ PendingActionHash False expectFinished ] 1164 else setPendingActions ctx [ PendingActionHash False (expectCertVerify sparams ctx) 1165 , PendingActionHash False expectFinished 1166 ] 1167 1168postHandshakeAuthServerWith _ _ _ = 1169 throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthServerWith", True, UnexpectedMessage) 1170