{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Server.ServerHello12 ( sendServerHello12, ) where import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Credentials import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Certificate import Network.TLS.Handshake.Common import Network.TLS.Handshake.Key import Network.TLS.Handshake.Random import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Parameters import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct import Network.TLS.Types import Network.TLS.X509 hiding (Certificate) sendServerHello12 :: ServerParams -> Context -> (Cipher, Maybe Credential) -> CH -> IO (Maybe SessionData) sendServerHello12 sparams ctx (usedCipher, mcred) ch@CH{..} = do resumeSessionData <- recoverSessionData ctx ch case resumeSessionData of Nothing -> do serverSession <- newSession ctx usingState_ ctx $ setSession serverSession False serverhello <- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions let ff = serverhello : build [ServerHelloDone] sendPacket12 ctx $ Handshake ff contextFlush ctx Just sessionData -> do usingState_ ctx $ setSession chSession True serverhello <- makeServerHello sparams ctx usedCipher mcred chExtensions chSession sendPacket12 ctx $ Handshake [serverhello] let mainSecret = sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ServerRole mainSecret logKey ctx $ MainSecret mainSecret sendCCSandFinished ctx ServerRole return resumeSessionData recoverSessionData :: Context -> CH -> IO (Maybe SessionData) recoverSessionData ctx CH{..} = do serverName <- usingState_ ctx getClientSNI ems <- processExtendedMainSecret ctx TLS12 MsgTClientHello chExtensions let mticket = extensionLookup EID_SessionTicket chExtensions >>= extensionDecode MsgTClientHello case mticket of Just (SessionTicket ticket) | ticket /= "" -> do sd <- sessionResume (sharedSessionManager $ ctxShared ctx) ticket validateSession chCiphers serverName ems sd _ -> case chSession of (Session (Just clientSessionId)) -> do sd <- sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId validateSession chCiphers serverName ems sd (Session Nothing) -> return Nothing validateSession :: [CipherID] -> Maybe HostName -> Bool -> Maybe SessionData -> IO (Maybe SessionData) validateSession _ _ _ Nothing = return Nothing validateSession ciphers sni ems m@(Just sd) -- SessionData parameters are assumed to match the local server configuration -- so we need to compare only to ClientHello inputs. Abbreviated handshake -- uses the same server_name than full handshake so the same -- credentials (and thus ciphers) are available. | TLS12 < sessionVersion sd = return Nothing -- fixme | sessionCipher sd `notElem` ciphers = return Nothing | isJust sni && sessionClientSNI sd /= sni = return Nothing | ems && not emsSession = return Nothing | not ems && emsSession = let err = "client resumes an EMS session without EMS" in throwCore $ Error_Protocol err HandshakeFailure | otherwise = return m where emsSession = SessionEMS `elem` sessionFlags sd sendServerFirstFlight :: ServerParams -> Context -> Cipher -> Maybe Credential -> [ExtensionRaw] -> IO ([Handshake] -> [Handshake]) sendServerFirstFlight sparams ctx usedCipher mcred chExts = do let b0 = id let cc = case mcred of Just (srvCerts, _) -> srvCerts _ -> CertificateChain [] let b1 = b0 . (Certificate cc :) usingState_ ctx $ setServerCertificateChain cc -- send server key exchange if needed skx <- case cipherKeyExchange usedCipher of CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE KX_RSA CipherKeyExchange_DHE_DSA -> Just <$> generateSKX_DHE KX_DSA CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE KX_RSA CipherKeyExchange_ECDHE_ECDSA -> Just <$> generateSKX_ECDHE KX_ECDSA _ -> return Nothing let b2 = case skx of Nothing -> b1 Just kx -> b1 . (ServerKeyXchg kx :) -- FIXME we don't do this on a Anonymous server -- When configured, send a certificate request with the DNs of all -- configured CA certificates. -- -- Client certificates MUST NOT be accepted if not requested. -- if serverWantClientCert sparams then do let (certTypes, hashSigs) = let as = supportedHashSignatures $ ctxSupported ctx in (nub $ mapMaybe hashSigToCertType as, as) creq = CertRequest certTypes hashSigs (map extractCAname $ serverCACertificates sparams) usingHState ctx $ setCertReqSent True return $ b2 . (creq :) else return b2 where setup_DHE = do let possibleFFGroups = negotiatedGroupsInCommon ctx chExts `intersect` availableFFGroups (dhparams, priv, pub) <- case possibleFFGroups of [] -> let dhparams = fromJust $ serverDHEParams sparams in case findFiniteFieldGroup dhparams of Just g -> do usingHState ctx $ setSupportedGroup g generateFFDHE ctx g Nothing -> do (priv, pub) <- generateDHE ctx dhparams return (dhparams, priv, pub) g : _ -> do usingHState ctx $ setSupportedGroup g generateFFDHE ctx g let serverParams = serverDHParamsFrom dhparams pub usingHState ctx $ setServerDHParams serverParams usingHState ctx $ setDHPrivate priv return serverParams -- Choosing a hash algorithm to sign (EC)DHE parameters -- in ServerKeyExchange. Hash algorithm is not suggested by -- the chosen cipher suite. So, it should be selected based on -- the "signature_algorithms" extension in a client hello. -- If RSA is also used for key exchange, this function is -- not called. decideHashSig pubKey = do let hashSigs = hashAndSignaturesInCommon ctx chExts case filter (pubKey `signatureCompatible`) hashSigs of [] -> error ("no hash signature for " ++ pubkeyType pubKey) x : _ -> return x generateSKX_DHE kxsAlg = do serverParams <- setup_DHE pubKey <- getLocalPublicKey ctx mhashSig <- decideHashSig pubKey signed <- digitallySignDHParams ctx serverParams pubKey mhashSig case kxsAlg of KX_RSA -> return $ SKX_DHE_RSA serverParams signed KX_DSA -> return $ SKX_DHE_DSA serverParams signed _ -> error ("generate skx_dhe unsupported key exchange signature: " ++ show kxsAlg) generateSKX_DH_Anon = SKX_DH_Anon <$> setup_DHE setup_ECDHE grp = do usingHState ctx $ setSupportedGroup grp (srvpri, srvpub) <- generateECDHE ctx grp let serverParams = ServerECDHParams grp srvpub usingHState ctx $ setServerECDHParams serverParams usingHState ctx $ setGroupPrivate srvpri return serverParams generateSKX_ECDHE kxsAlg = do let possibleECGroups = negotiatedGroupsInCommon ctx chExts `intersect` availableECGroups grp <- case possibleECGroups of [] -> throwCore $ Error_Protocol "no common group" HandshakeFailure g : _ -> return g serverParams <- setup_ECDHE grp pubKey <- getLocalPublicKey ctx mhashSig <- decideHashSig pubKey signed <- digitallySignECDHParams ctx serverParams pubKey mhashSig case kxsAlg of KX_RSA -> return $ SKX_ECDHE_RSA serverParams signed KX_ECDSA -> return $ SKX_ECDHE_ECDSA serverParams signed _ -> error ("generate skx_ecdhe unsupported key exchange signature: " ++ show kxsAlg) --- -- When the client sends a certificate, check whether -- it is acceptable for the application. -- --- makeServerHello :: ServerParams -> Context -> Cipher -> Maybe Credential -> [ExtensionRaw] -> Session -> IO Handshake makeServerHello sparams ctx usedCipher mcred chExts session = do resuming <- usingState_ ctx isSessionResuming srand <- serverRandom ctx TLS12 $ supportedVersions $ serverSupported sparams case mcred of Just cred -> storePrivInfoServer ctx cred _ -> 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 vd <- usingState_ ctx $ do cvd <- getVerifyData ClientRole svd <- getVerifyData ServerRole return $ extensionEncode $ SecureRenegotiation cvd svd return [ExtensionRaw EID_SecureRenegotiation vd] else return [] ems <- usingHState ctx getExtendedMainSecret let emsExt | ems = let raw = extensionEncode ExtendedMainSecret in [ExtensionRaw EID_ExtendedMainSecret raw] | otherwise = [] protoExt <- applicationProtocol ctx chExts sparams sniExt <- do if resuming then return [] else do msni <- usingState_ ctx getClientSNI case msni of -- RFC6066: In this event, the server SHALL include -- an extension of type "server_name" in the -- (extended) server hello. The "extension_data" -- field of this extension SHALL be empty. Just _ -> return [ExtensionRaw EID_ServerName ""] Nothing -> return [] let useTicket = sessionUseTicket $ sharedSessionManager $ serverShared sparams ticktExt | not resuming && useTicket = let raw = extensionEncode $ SessionTicket "" in [ExtensionRaw EID_SessionTicket raw] | otherwise = [] let shExts = sharedHelloExtensions (serverShared sparams) ++ secRengExt ++ emsExt ++ protoExt ++ sniExt ++ ticktExt usingState_ ctx $ setVersion TLS12 usingHState ctx $ setServerHelloParameters TLS12 srand usedCipher nullCompression return $ ServerHello TLS12 srand session (cipherID usedCipher) (compressionID nullCompression) shExts hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] hashAndSignaturesInCommon ctx chExts = let cHashSigs = case extensionLookup EID_SignatureAlgorithms chExts >>= extensionDecode MsgTClientHello of -- See Section 7.4.1.4.1 of RFC 5246. Nothing -> [ (HashSHA1, SignatureECDSA) , (HashSHA1, SignatureRSA) , (HashSHA1, SignatureDSA) ] Just (SignatureAlgorithms sas) -> sas sHashSigs = supportedHashSignatures $ ctxSupported ctx in -- The values in the "signature_algorithms" extension -- are in descending order of preference. -- However here the algorithms are selected according -- to server preference in 'supportedHashSignatures'. sHashSigs `intersect` cHashSigs negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group] negotiatedGroupsInCommon ctx chExts = case extensionLookup EID_SupportedGroups chExts >>= extensionDecode MsgTClientHello of Just (SupportedGroups clientGroups) -> let serverGroups = supportedGroups (ctxSupported ctx) in serverGroups `intersect` clientGroups _ -> []