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
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 ("ssl2 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 (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 ()
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
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 []
makeServerHello session = do
srand <- getStateRNG ctx 32 >>= return . ServerRandom
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 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
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 SignatureRSA
CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE SignatureDSS
CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE SignatureRSA
_ -> 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 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
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)
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@(DigitallySigned mbHashSig _))]) = do
processHandshake ctx hs
checkValidClientCertChain "change cipher message expected"
usedVersion <- usingState_ ctx getVersion
msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages
verif <- certificateVerifyCheck ctx usedVersion mbHashSig msgs dsig
case verif of
True -> do
Just certs <- usingHState ctx $ getClientCertChain
usingState_ ctx $ setClientCertificateChain certs
return ()
False -> 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
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