tls-1.3.6: Network/TLS/Handshake/Server.hs
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
-- |
-- Module : Network.TLS.Handshake.Server
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
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.ECDH
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 Data.Maybe (isJust, listToMaybe, mapMaybe)
import Data.List (intersect, sortBy)
import qualified Data.ByteString as B
import Data.ByteString.Char8 ()
import Control.Monad.State
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Certificate
import Network.TLS.X509
-- Put the server context in handshake mode.
--
-- Expect to receive as first packet a client hello handshake message
--
-- This is just a helper to pop the next message from the recv layer,
-- and call handshakeServerWith.
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)
-- | Put the server context in handshake mode.
--
-- Expect a client hello message as parameter.
-- This is useful when the client hello has been already poped from the recv layer to inspect the packet.
--
-- When the function returns, a new handshake has been succesfully negociated.
-- On any error, a HandshakeFailed exception is raised.
--
-- handshake protocol (<- receiving, -> sending, [] optional):
-- (no session) (session resumption)
-- <- client hello <- client hello
-- -> server hello -> server hello
-- -> [certificate]
-- -> [server key xchg]
-- -> [cert request]
-- -> hello done
-- <- [certificate]
-- <- client key xchg
-- <- [cert verify]
-- <- change cipher -> change cipher
-- <- [NPN]
-- <- finish -> finish
-- -> change cipher <- change cipher
-- -> finish <- finish
--
handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()
handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientSession ciphers compressions exts _) = do
-- rejecting client initiated renegotiation to prevent DOS.
unless (supportedClientInitiatedRenegotiation (ctxSupported ctx)) $ do
established <- ctxEstablished ctx
eof <- ctxEOF ctx
when (established && not eof) $
throwCore $ Error_Protocol ("renegotiation is not allowed", False, NoRenegotiation)
-- check if policy allow this new handshake to happens
handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams)
unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")
updateMeasure ctx incrementNbHandshakes
-- Handle Client hello
processHandshake ctx clientHello
when (clientVersion == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)
-- Fallback SCSV: RFC7507
-- TLS_FALLBACK_SCSV: {0x56, 0x00}
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 (commonCipherIDs == []) $ throwCore $
Error_Protocol ("no cipher in common with the client", True, HandshakeFailure)
when (null commonCompressions) $ throwCore $
Error_Protocol ("no compression in common with the client", True, HandshakeFailure)
let serverName = case extensionDecode False `fmap` (extensionLookup extensionID_ServerName exts) of
Just (Just (ServerName ns)) -> listToMaybe (mapMaybe toHostName ns)
where toHostName (ServerNameHostName hostName) = Just hostName
toHostName (ServerNameOther _) = Nothing
_ -> Nothing
let ciphersFilteredVersion = filter (cipherAllowedForVersion chosenVersion) commonCiphers
usedCipher = (onCipherChoosing $ serverHooks sparams) chosenVersion ciphersFilteredVersion
extraCreds <- (onServerNameIndication $ serverHooks sparams) serverName
let creds = extraCreds `mappend` (sharedCredentials $ ctxShared ctx)
cred <- case cipherKeyExchange usedCipher of
CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds
CipherKeyExchange_DH_Anon -> return $ Nothing
CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning SignatureRSA creds
CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning SignatureDSS creds
CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning SignatureRSA creds
_ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure)
resumeSessionData <- case clientSession of
(Session (Just clientSessionId)) -> liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId
(Session Nothing) -> return Nothing
maybe (return ()) (usingState_ ctx . setClientSNI) serverName
case extensionDecode False `fmap` (extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts) of
Just (Just (ApplicationLayerProtocolNegotiation protos)) -> usingState_ ctx $ setClientALPNSuggest protos
_ -> return ()
case extensionDecode False `fmap` (extensionLookup extensionID_EllipticCurves exts) of
Just (Just (EllipticCurvesSupported es)) -> usingState_ ctx $ setClientEllipticCurveSuggest es
_ -> return ()
-- Currently, we don't send back EcPointFormats. In this case,
-- the client chooses EcPointFormat_Uncompressed.
case extensionDecode False `fmap` (extensionLookup extensionID_EcPointFormats exts) of
Just (Just (EcPointFormatsSupported fs)) -> usingState_ ctx $ setClientEcPointFormatSuggest fs
_ -> return ()
doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts
where
commonCipherIDs = intersect ciphers (map cipherID $ ctxCiphers ctx)
commonCiphers = filter (flip elem commonCipherIDs . cipherID) (ctxCiphers ctx)
commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions
usedCompression = head commonCompressions
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
-- Receive client info until client Finished.
recvClientData sparams ctx
sendChangeCipherAndFinish (return ()) 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 (return ()) ctx ServerRole
recvChangeCipherAndFinish ctx
handshakeTerminate ctx
where
clientRequestedNPN = isJust $ extensionLookup extensionID_NextProtocolNegotiation exts
clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts
applicationProtocol = do
protos <- alpn
if null protos then npn else return protos
alpn | 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 []
npn = do
nextProtocols <-
if clientRequestedNPN
then liftIO $ onSuggestNextProtocols $ serverHooks sparams
else return Nothing
case nextProtocols of
Just protos -> do
usingState_ ctx $ do
setExtensionNPN True
setServerNextProtocolSuggest protos
return [ ExtensionRaw extensionID_NextProtocolNegotiation
(extensionEncode $ NextProtocolNegotiation protos) ]
Nothing -> return []
---
-- When the client sends a certificate, check whether
-- it is acceptable for the application.
--
---
makeServerHello session = do
srand <- getStateRNG ctx 32 >>= return . ServerRandom
case mcred of
Just (_, privkey) -> usingHState ctx $ setPrivateKey privkey
_ -> return () -- return a sensible error
-- in TLS12, we need to check as well the certificates we are sending if they have in the extension
-- the necessary bits set.
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 0xff01 vf ]
else return []
protoExt <- applicationProtocol
let extensions = secRengExt ++ protoExt
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
-- send ServerHello & Certificate & ServerKeyXchg & CertReq
let certMsg = case mcred of
Just (srvCerts, _) -> Certificates srvCerts
_ -> Certificates $ CertificateChain []
sendPacket ctx $ Handshake [ serverhello, certMsg ]
-- send server key exchange if needed
skx <- case cipherKeyExchange usedCipher of
CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon
CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE SignatureRSA
CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE SignatureDSS
CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE SignatureRSA
_ -> return Nothing
maybe (return ()) (sendPacket ctx . Handshake . (:[]) . ServerKeyXchg) skx
-- FIXME we don't do this on a Anonymous server
-- When configured, send a certificate request
-- with the DNs of all confgure CA
-- certificates.
--
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])
-- Send HelloDone
sendPacket ctx (Handshake [ServerHelloDone])
extractCAname :: SignedCertificate -> DistinguishedName
extractCAname cert = certSubjectDN $ getCertificate cert
setup_DHE = do
let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams
(priv, pub) <- generateDHE ctx dhparams
let serverParams = serverDHParamsFrom dhparams pub
usingHState ctx $ setServerDHParams serverParams
usingHState ctx $ modify $ \hst -> hst { hstDHPrivate = Just priv }
return (serverParams)
generateSKX_DHE sigAlg = do
serverParams <- setup_DHE
signed <- digitallySignDHParams ctx serverParams sigAlg
case sigAlg of
SignatureRSA -> return $ SKX_DHE_RSA serverParams signed
SignatureDSS -> 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 curvename = do
let ecdhparams = ecdhParams curvename
(priv, pub) <- generateECDHE ctx ecdhparams
let serverParams = ServerECDHParams ecdhparams pub
usingHState ctx $ setServerECDHParams serverParams
usingHState ctx $ modify $ \hst -> hst { hstECDHPrivate = Just priv }
return (serverParams)
generateSKX_ECDHE sigAlg = do
ncs <- usingState_ ctx $ getClientEllipticCurveSuggest
let common = availableEllipticCurves `intersect` fromJust "ClientEllipticCurveSuggest" ncs
-- FIXME: Currently maximum strength is chosen.
-- There may be a better way to choose EC.
nc = if null common then error "No common EllipticCurves"
else maximum $ map fromEnumSafe16 common
serverParams <- setup_ECDHE nc
signed <- digitallySignECDHParams ctx serverParams sigAlg
case sigAlg of
SignatureRSA -> return $ SKX_ECDHE_RSA serverParams signed
_ -> error ("generate skx_ecdhe unsupported signature type: " ++ show sigAlg)
-- create a DigitallySigned objects for DHParams or ECDHParams.
-- | receive Client data in handshake until the Finished handshake.
--
-- <- [certificate]
-- <- client key xchg
-- <- [cert verify]
-- <- change cipher
-- <- [NPN]
-- <- finish
--
recvClientData :: ServerParams -> Context -> IO ()
recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate)
where processClientCertificate (Certificates certs) = do
-- run certificate recv hook
ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks $ certs)
-- Call application callback to see whether the
-- certificate chain is acceptable.
--
usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs) rejectOnException
case usage of
CertificateUsageAccept -> return ()
CertificateUsageReject reason -> certificateRejected reason
-- Remember cert chain for later use.
--
usingHState ctx $ setClientCertChain certs
-- FIXME: We should check whether the certificate
-- matches our request and that we support
-- verifying with that certificate.
return $ RecvStateHandshake processClientKeyExchange
processClientCertificate p = processClientKeyExchange p
-- cannot use RecvStateHandshake, as the next message could be a ChangeCipher,
-- so we must process any packet, and in case of handshake call processHandshake manually.
processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify
processClientKeyExchange p = unexpected (show p) (Just "client key exchange")
-- Check whether the client correctly signed the handshake.
-- If not, ask the application on how to proceed.
--
processCertificateVerify (Handshake [hs@(CertVerify dsig@(DigitallySigned mbHashSig _))]) = do
processHandshake ctx hs
checkValidClientCertChain "change cipher message expected"
usedVersion <- usingState_ ctx getVersion
-- Fetch all handshake messages up to now.
msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages
verif <- certificateVerifyCheck ctx usedVersion mbHashSig msgs dsig
case verif of
True -> do
-- When verification succeeds, commit the
-- client certificate chain to the context.
--
Just certs <- usingHState ctx $ getClientCertChain
usingState_ ctx $ setClientCertificateChain certs
return ()
False -> do
-- Either verification failed because of an
-- invalid format (with an error message), or
-- the signature is wrong. In either case,
-- ask the application if it wants to
-- proceed, we will do that.
res <- liftIO $ onUnverifiedClientCert (serverHooks sparams)
if res
then do
-- When verification fails, but the
-- application callbacks accepts, we
-- also commit the client certificate
-- chain to the context.
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
expectChangeCipher ChangeCipherSpec = do
npn <- usingState_ ctx getExtensionNPN
return $ RecvStateHandshake $ if npn then expectNPN else expectFinish
expectChangeCipher p = unexpected (show p) (Just "change cipher")
expectNPN (HsNextProtocolNegotiation _) = return $ RecvStateHandshake expectFinish
expectNPN p = unexpected (show p) (Just "Handshake NextProtocolNegotiation")
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 ()
findHighestVersionFrom :: Version -> [Version] -> Maybe Version
findHighestVersionFrom clientVersion allowedVersions =
case filter (clientVersion >=) $ reverse $ sortBy compare allowedVersions of
[] -> Nothing
v:_ -> Just v