{-# LANGUAGE OverloadedStrings #-}
module Network.TLS.Handshake.Server
( handshakeServer
, handshakeServerWith
) where
import Network.TLS.Parameters
import Network.TLS.Imports
import Network.TLS.Context.Internal
import Network.TLS.Session
import Network.TLS.Struct
import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Credentials
import Network.TLS.Crypto
import Network.TLS.Extension
import Network.TLS.Util (catchException, fromJust)
import Network.TLS.IO
import Network.TLS.Types
import Network.TLS.State hiding (getNegotiatedProtocol)
import Network.TLS.Handshake.State
import Network.TLS.Handshake.Process
import Network.TLS.Handshake.Key
import Network.TLS.Measurement
import qualified Data.ByteString as B
import Control.Monad.State.Strict
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Certificate
import Network.TLS.X509
handshakeServer :: MonadIO m => ServerParams -> Context -> m ()
handshakeServer sparams ctx = liftIO $ do
hss <- recvPacketHandshake ctx
case hss of
[ch] -> handshakeServerWith sparams ctx ch
_ -> fail ("unexpected handshake received, excepting client hello and received " ++ show hss)
handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()
handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientSession ciphers compressions exts _) = do
unless (supportedClientInitiatedRenegotiation (ctxSupported ctx)) $ do
established <- ctxEstablished ctx
eof <- ctxEOF ctx
when (established && not eof) $
throwCore $ Error_Protocol ("renegotiation is not allowed", False, NoRenegotiation)
handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams)
unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")
updateMeasure ctx incrementNbHandshakes
processHandshake ctx clientHello
when (clientVersion == SSL2) $ throwCore $ Error_Protocol ("SSL 2.0 is not supported", True, ProtocolVersion)
when (supportedFallbackScsv (ctxSupported ctx) &&
(0x5600 `elem` ciphers) &&
clientVersion /= maxBound) $
throwCore $ Error_Protocol ("fallback is not allowed", True, InappropriateFallback)
chosenVersion <- case findHighestVersionFrom clientVersion (supportedVersions $ ctxSupported ctx) of
Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported", True, ProtocolVersion)
Just v -> return v
when (null commonCompressions) $ throwCore $
Error_Protocol ("no compression in common with the client", True, HandshakeFailure)
let serverName = case extensionLookup extensionID_ServerName exts >>= extensionDecode False of
Just (ServerName ns) -> listToMaybe (mapMaybe toHostName ns)
where toHostName (ServerNameHostName hostName) = Just hostName
toHostName (ServerNameOther _) = Nothing
_ -> Nothing
extraCreds <- (onServerNameIndication $ serverHooks sparams) serverName
let possibleGroups = negotiatedGroupsInCommon ctx exts
possibleECGroups = possibleGroups `intersect` availableECGroups
possibleFFGroups = possibleGroups `intersect` availableFFGroups
hasCommonGroupForECDHE = not (null possibleECGroups)
hasCommonGroupForFFDHE = not (null possibleFFGroups)
hasCustomGroupForFFDHE = isJust (serverDHEParams sparams)
canFFDHE = hasCustomGroupForFFDHE || hasCommonGroupForFFDHE
hasCommonGroup cipher =
case cipherKeyExchange cipher of
CipherKeyExchange_DH_Anon -> canFFDHE
CipherKeyExchange_DHE_RSA -> canFFDHE
CipherKeyExchange_DHE_DSS -> canFFDHE
CipherKeyExchange_ECDHE_RSA -> hasCommonGroupForECDHE
CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE
_ -> True
cipherAllowed cipher = cipherAllowedForVersion chosenVersion cipher && hasCommonGroup cipher
selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials)
allCreds = extraCreds `mappend` sharedCredentials (ctxShared ctx)
(creds, signatureCreds, ciphersFilteredVersion)
= case chosenVersion of
TLS12 -> let
possibleHashSigAlgs = hashAndSignaturesInCommon ctx exts
signingRank cred =
case credentialDigitalSignatureAlg cred of
Just sig -> findIndex (sig `signatureCompatible`) possibleHashSigAlgs
Nothing -> Nothing
cltCreds = filterCredentialsWithHashSignatures exts allCreds
sigCltCreds = filterSortCredentials signingRank cltCreds
sigAllCreds = filterSortCredentials signingRank allCreds
cltCiphers = selectCipher cltCreds sigCltCreds
allCiphers = selectCipher allCreds sigAllCreds
resultTuple = if cipherListCredentialFallback cltCiphers
then (allCreds, sigAllCreds, allCiphers)
else (cltCreds, sigCltCreds, cltCiphers)
in resultTuple
_ -> (allCreds, allCreds, selectCipher allCreds allCreds)
when (null ciphersFilteredVersion) $ throwCore $
Error_Protocol ("no cipher in common with the client", True, HandshakeFailure)
let usedCipher = (onCipherChoosing $ serverHooks sparams) chosenVersion ciphersFilteredVersion
cred <- case cipherKeyExchange usedCipher of
CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds
CipherKeyExchange_DH_Anon -> return Nothing
CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning RSA signatureCreds
CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning DSS signatureCreds
CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning RSA signatureCreds
_ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure)
resumeSessionData <- case clientSession of
(Session (Just clientSessionId)) ->
let resume = liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId
in validateSession serverName <$> resume
(Session Nothing) -> return Nothing
maybe (return ()) (usingState_ ctx . setClientSNI) serverName
case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode False of
Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos
_ -> return ()
case extensionLookup extensionID_EcPointFormats exts >>= extensionDecode False of
Just (EcPointFormatsSupported fs) -> usingState_ ctx $ setClientEcPointFormatSuggest fs
_ -> return ()
doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts
where
commonCiphers creds sigCreds = filter ((`elem` ciphers) . cipherID) (getCiphers sparams creds sigCreds)
commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions
usedCompression = head commonCompressions
validateSession _ Nothing = Nothing
validateSession sni m@(Just sd)
| clientVersion < sessionVersion sd = Nothing
| sessionCipher sd `notElem` ciphers = Nothing
| sessionCompression sd `notElem` compressions = Nothing
| isJust sni && sessionClientSNI sd /= sni = Nothing
| otherwise = m
handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure)
doHandshake :: ServerParams -> Maybe Credential -> Context -> Version -> Cipher
-> Compression -> Session -> Maybe SessionData
-> [ExtensionRaw] -> IO ()
doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts = do
case resumeSessionData of
Nothing -> do
handshakeSendServerData
liftIO $ contextFlush ctx
recvClientData sparams ctx
sendChangeCipherAndFinish ctx ServerRole
Just sessionData -> do
usingState_ ctx (setSession clientSession True)
serverhello <- makeServerHello clientSession
sendPacket ctx $ Handshake [serverhello]
usingHState ctx $ setMasterSecret chosenVersion ServerRole $ sessionSecret sessionData
sendChangeCipherAndFinish ctx ServerRole
recvChangeCipherAndFinish ctx
handshakeTerminate ctx
where
clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts
applicationProtocol | clientALPNSuggest = do
suggest <- usingState_ ctx getClientALPNSuggest
case (onALPNClientSuggest $ serverHooks sparams, suggest) of
(Just io, Just protos) -> do
proto <- liftIO $ io protos
usingState_ ctx $ do
setExtensionALPN True
setNegotiatedProtocol proto
return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation
(extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ]
(_, _) -> return []
| otherwise = return []
makeServerHello session = do
srand <- ServerRandom <$> getStateRNG ctx 32
case mcred of
Just (_, privkey) -> usingHState ctx $ setPrivateKey privkey
_ -> return ()
secReneg <- usingState_ ctx getSecureRenegotiation
secRengExt <- if secReneg
then do
vf <- usingState_ ctx $ do
cvf <- getVerifiedData ClientRole
svf <- getVerifiedData ServerRole
return $ extensionEncode (SecureRenegotiation cvf $ Just svf)
return [ ExtensionRaw extensionID_SecureRenegotiation vf ]
else return []
protoExt <- applicationProtocol
sniExt <- do
resuming <- usingState_ ctx isSessionResuming
if resuming
then return []
else do
msni <- usingState_ ctx getClientSNI
case msni of
Just _ -> return [ ExtensionRaw extensionID_ServerName ""]
Nothing -> return []
let extensions = secRengExt ++ protoExt ++ sniExt
usingState_ ctx (setVersion chosenVersion)
usingHState ctx $ setServerHelloParameters chosenVersion srand usedCipher usedCompression
return $ ServerHello chosenVersion srand session (cipherID usedCipher)
(compressionID usedCompression) extensions
handshakeSendServerData = do
serverSession <- newSession ctx
usingState_ ctx (setSession serverSession False)
serverhello <- makeServerHello serverSession
let certMsg = case mcred of
Just (srvCerts, _) -> Certificates srvCerts
_ -> Certificates $ CertificateChain []
sendPacket ctx $ Handshake [ serverhello, certMsg ]
skx <- case cipherKeyExchange usedCipher of
CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon
CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE RSA
CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE DSS
CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE RSA
_ -> return Nothing
maybe (return ()) (sendPacket ctx . Handshake . (:[]) . ServerKeyXchg) skx
when (serverWantClientCert sparams) $ do
usedVersion <- usingState_ ctx getVersion
let certTypes = [ CertificateType_RSA_Sign ]
hashSigs = if usedVersion < TLS12
then Nothing
else Just (supportedHashSignatures $ ctxSupported ctx)
creq = CertRequest certTypes hashSigs
(map extractCAname $ serverCACertificates sparams)
usingHState ctx $ setCertReqSent True
sendPacket ctx (Handshake [creq])
sendPacket ctx (Handshake [ServerHelloDone])
extractCAname :: SignedCertificate -> DistinguishedName
extractCAname cert = certSubjectDN $ getCertificate cert
setup_DHE = do
let possibleFFGroups = negotiatedGroupsInCommon ctx exts `intersect` availableFFGroups
(dhparams, priv, pub) <-
case possibleFFGroups of
[] ->
let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams
in case findFiniteFieldGroup dhparams of
Just g -> generateFFDHE ctx g
Nothing -> do
(priv, pub) <- generateDHE ctx dhparams
return (dhparams, priv, pub)
g:_ -> generateFFDHE ctx g
let serverParams = serverDHParamsFrom dhparams pub
usingHState ctx $ setServerDHParams serverParams
usingHState ctx $ setDHPrivate priv
return serverParams
decideHashSig sigAlg = do
usedVersion <- usingState_ ctx getVersion
case usedVersion of
TLS12 -> do
let hashSigs = hashAndSignaturesInCommon ctx exts
case filter (sigAlg `signatureCompatible`) hashSigs of
[] -> error ("no hash signature for " ++ show sigAlg)
x:_ -> return $ Just x
_ -> return Nothing
generateSKX_DHE sigAlg = do
serverParams <- setup_DHE
mhashSig <- decideHashSig sigAlg
signed <- digitallySignDHParams ctx serverParams sigAlg mhashSig
case sigAlg of
RSA -> return $ SKX_DHE_RSA serverParams signed
DSS -> return $ SKX_DHE_DSS serverParams signed
_ -> error ("generate skx_dhe unsupported signature type: " ++ show sigAlg)
generateSKX_DH_Anon = SKX_DH_Anon <$> setup_DHE
setup_ECDHE grp = do
(srvpri, srvpub) <- generateECDHE ctx grp
let serverParams = ServerECDHParams grp srvpub
usingHState ctx $ setServerECDHParams serverParams
usingHState ctx $ setECDHPrivate srvpri
return serverParams
generateSKX_ECDHE sigAlg = do
let possibleECGroups = negotiatedGroupsInCommon ctx exts `intersect` availableECGroups
grp <- case possibleECGroups of
[] -> throwCore $ Error_Protocol ("no common group", True, HandshakeFailure)
g:_ -> return g
serverParams <- setup_ECDHE grp
mhashSig <- decideHashSig sigAlg
signed <- digitallySignECDHParams ctx serverParams sigAlg mhashSig
case sigAlg of
RSA -> return $ SKX_ECDHE_RSA serverParams signed
_ -> error ("generate skx_ecdhe unsupported signature type: " ++ show sigAlg)
recvClientData :: ServerParams -> Context -> IO ()
recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate)
where processClientCertificate (Certificates certs) = do
ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks certs)
usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs) rejectOnException
case usage of
CertificateUsageAccept -> return ()
CertificateUsageReject reason -> certificateRejected reason
usingHState ctx $ setClientCertChain certs
return $ RecvStateHandshake processClientKeyExchange
processClientCertificate p = processClientKeyExchange p
processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify
processClientKeyExchange p = unexpected (show p) (Just "client key exchange")
processCertificateVerify (Handshake [hs@(CertVerify dsig)]) = do
processHandshake ctx hs
checkValidClientCertChain "change cipher message expected"
usedVersion <- usingState_ ctx getVersion
msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages
sigAlgExpected <- getRemoteSignatureAlg
verif <- checkCertificateVerify ctx usedVersion sigAlgExpected msgs dsig
if verif then do
Just certs <- usingHState ctx getClientCertChain
usingState_ ctx $ setClientCertificateChain certs
return ()
else do
res <- liftIO $ onUnverifiedClientCert (serverHooks sparams)
if res then do
Just certs <- usingHState ctx getClientCertChain
usingState_ ctx $ setClientCertificateChain certs
else throwCore $ Error_Protocol ("verification failed", True, BadCertificate)
return $ RecvStateNext expectChangeCipher
processCertificateVerify p = do
chain <- usingHState ctx getClientCertChain
case chain of
Just cc | isNullCertificateChain cc -> return ()
| otherwise -> throwCore $ Error_Protocol ("cert verify message missing", True, UnexpectedMessage)
Nothing -> return ()
expectChangeCipher p
getRemoteSignatureAlg = do
pk <- usingHState ctx getRemotePublicKey
case pk of
PubKeyRSA _ -> return RSA
PubKeyDSA _ -> return DSS
PubKeyEC _ -> return ECDSA
_ -> throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure)
expectChangeCipher ChangeCipherSpec = do
return $ RecvStateHandshake expectFinish
expectChangeCipher p = unexpected (show p) (Just "change cipher")
expectFinish (Finished _) = return RecvStateDone
expectFinish p = unexpected (show p) (Just "Handshake Finished")
checkValidClientCertChain msg = do
chain <- usingHState ctx getClientCertChain
let throwerror = Error_Protocol (msg , True, UnexpectedMessage)
case chain of
Nothing -> throwCore throwerror
Just cc | isNullCertificateChain cc -> throwCore throwerror
| otherwise -> return ()
hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon ctx exts =
let cHashSigs = case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode False of
Nothing -> [(HashSHA1, SignatureECDSA)
,(HashSHA1, SignatureRSA)
,(HashSHA1, SignatureDSS)]
Just (SignatureAlgorithms sas) -> sas
sHashSigs = supportedHashSignatures $ ctxSupported ctx
in sHashSigs `intersect` cHashSigs
negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode False of
Just (NegotiatedGroups clientGroups) ->
let serverGroups = supportedGroups (ctxSupported ctx)
in serverGroups `intersect` clientGroups
_ -> []
credentialDigitalSignatureAlg :: Credential -> Maybe DigitalSignatureAlg
credentialDigitalSignatureAlg cred =
findDigitalSignatureAlg (credentialPublicPrivateKeys cred)
filterSortCredentials :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials rankFun (Credentials creds) =
let orderedPairs = sortOn fst [ (rankFun cred, cred) | cred <- creds ]
in Credentials [ cred | (Just _, cred) <- orderedPairs ]
filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials
filterCredentialsWithHashSignatures exts =
case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode False of
Nothing -> id
Just (SignatureAlgorithms sas) ->
let filterCredentials p (Credentials l) = Credentials (filter p l)
in filterCredentials (credentialMatchesHashSignatures sas)
cipherListCredentialFallback :: [Cipher] -> Bool
cipherListCredentialFallback xs = all nonDH xs
where
nonDH x = case cipherKeyExchange x of
CipherKeyExchange_DHE_RSA -> False
CipherKeyExchange_DHE_DSS -> False
CipherKeyExchange_ECDHE_RSA -> False
CipherKeyExchange_ECDHE_ECDSA -> False
_ -> True
findHighestVersionFrom :: Version -> [Version] -> Maybe Version
findHighestVersionFrom clientVersion allowedVersions =
case filter (clientVersion >=) $ sortOn Down allowedVersions of
[] -> Nothing
v:_ -> Just v
getCiphers :: ServerParams -> Credentials -> Credentials -> [Cipher]
getCiphers sparams creds sigCreds = filter authorizedCKE (supportedCiphers $ serverSupported sparams)
where authorizedCKE cipher =
case cipherKeyExchange cipher of
CipherKeyExchange_RSA -> canEncryptRSA
CipherKeyExchange_DH_Anon -> True
CipherKeyExchange_DHE_RSA -> canSignRSA
CipherKeyExchange_DHE_DSS -> canSignDSS
CipherKeyExchange_ECDHE_RSA -> canSignRSA
CipherKeyExchange_ECDHE_ECDSA -> False
CipherKeyExchange_DH_DSS -> False
CipherKeyExchange_DH_RSA -> False
CipherKeyExchange_ECDH_ECDSA -> False
CipherKeyExchange_ECDH_RSA -> False
canSignDSS = DSS `elem` signingAlgs
canSignRSA = RSA `elem` signingAlgs
canEncryptRSA = isJust $ credentialsFindForDecrypting creds
signingAlgs = credentialsListSigningAlgorithms sigCreds