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 Data.Maybe (isJust, listToMaybe, mapMaybe)
import Data.List (intersect)
import qualified Data.ByteString as B
import Data.ByteString.Char8 ()
import Data.Ord (Down(..))
#if MIN_VERSION_base(4,8,0)
import Data.List (sortOn)
#else
import Data.List (sortBy)
import Data.Ord (comparing)
#endif
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 ("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 cipherAllowed cipher = case chosenVersion of
TLS12 -> let
possibleSigAlgs = map snd (hashAndSignaturesInCommon ctx exts)
hasSigningRequirements =
case cipherKeyExchange cipher of
CipherKeyExchange_DHE_RSA -> SignatureRSA `elem` possibleSigAlgs
CipherKeyExchange_DHE_DSS -> SignatureDSS `elem` possibleSigAlgs
CipherKeyExchange_ECDHE_RSA -> SignatureRSA `elem` possibleSigAlgs
CipherKeyExchange_ECDHE_ECDSA -> SignatureECDSA `elem` possibleSigAlgs
_ -> True
in cipherAllowedForVersion chosenVersion cipher && hasSigningRequirements
_ -> cipherAllowedForVersion chosenVersion cipher
let ciphersFilteredVersion = filter cipherAllowed (commonCiphers extraCreds)
when (null ciphersFilteredVersion) $ throwCore $
Error_Protocol ("no cipher in common with the client", True, HandshakeFailure)
let usedCipher = (onCipherChoosing $ serverHooks sparams) chosenVersion ciphersFilteredVersion
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 extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode False of
Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos
_ -> return ()
case extensionLookup extensionID_EllipticCurves exts >>= extensionDecode False of
Just (EllipticCurvesSupported es) -> usingState_ ctx $ setClientEllipticCurveSuggest es
_ -> 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
commonCipherIDs extra = ciphers `intersect` map cipherID (ctxCiphers ctx extra)
commonCiphers extra = filter (flip elem (commonCipherIDs extra) . cipherID) (ctxCiphers ctx extra)
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 <- 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 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 $ setDHPrivate priv
return serverParams
decideHash sigAlg = do
usedVersion <- usingState_ ctx getVersion
case usedVersion of
TLS12 -> do
let hashSigs = hashAndSignaturesInCommon ctx exts
case filter ((==) sigAlg . snd) hashSigs of
[] -> error ("no hash signature for " ++ show sigAlg)
x:_ -> return $ Just (fst x)
_ -> return Nothing
generateSKX_DHE sigAlg = do
serverParams <- setup_DHE
mhash <- decideHash sigAlg
signed <- digitallySignDHParams ctx serverParams sigAlg mhash
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 $ setECDHPrivate 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
mhash <- decideHash sigAlg
signed <- digitallySignECDHParams ctx serverParams sigAlg mhash
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)]) = do
processHandshake ctx hs
checkValidClientCertChain "change cipher message expected"
usedVersion <- usingState_ ctx getVersion
msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages
sigAlgExpected <- getRemoteSignatureAlg
verif <- certificateVerifyCheck ctx usedVersion sigAlgExpected 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
getRemoteSignatureAlg = do
pk <- usingHState ctx getRemotePublicKey
case pk of
PubKeyRSA _ -> return SignatureRSA
PubKeyDSA _ -> return SignatureDSS
PubKeyEC _ -> return SignatureECDSA
_ -> throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure)
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 ()
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
findHighestVersionFrom :: Version -> [Version] -> Maybe Version
findHighestVersionFrom clientVersion allowedVersions =
case filter (clientVersion >=) $ sortOn Down allowedVersions of
[] -> Nothing
v:_ -> Just v
#if !MIN_VERSION_base(4,8,0)
sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn f =
map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
#endif