diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,28 @@ +## Version 1.5.3 + +- Additional verification regarding EC signatures + [#412](https://github.com/vincenthz/hs-tls/pull/412) +- Fixing ALPN + [#411](https://github.com/vincenthz/hs-tls/pull/411) +- Check SSLv3 padding length + [#410](https://github.com/vincenthz/hs-tls/pull/410) +- Exposing getClientCertificateChain + [#407](https://github.com/vincenthz/hs-tls/pull/407) +- Extended Master Secret + [#406](https://github.com/vincenthz/hs-tls/pull/406) +- Brushing up the documentation + [#404](https://github.com/vincenthz/hs-tls/pull/404) + [#408](https://github.com/vincenthz/hs-tls/pull/408) +- Improving tests + [#403](https://github.com/vincenthz/hs-tls/pull/403) +- Avoid calling onServerNameIndication twice with HRR + [#402](https://github.com/vincenthz/hs-tls/pull/402) +- Enable X448 and FFDHE groups + [#401](https://github.com/vincenthz/hs-tls/pull/401) +- Refactoring + [#400](https://github.com/vincenthz/hs-tls/pull/400) + [#399](https://github.com/vincenthz/hs-tls/pull/399) + ## Version 1.5.2 - Enabled TLS 1.3 by default [#398](https://github.com/vincenthz/hs-tls/pull/398) diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -6,6 +6,21 @@ -- Stability : experimental -- Portability : unknown -- +-- Native Haskell TLS and SSL protocol implementation for server and +-- client. +-- +-- This provides a high-level implementation of a sensitive security +-- protocol, eliminating a common set of security issues through the +-- use of the advanced type system, high level constructions and +-- common Haskell features. +-- +-- Currently implement the SSL3.0, TLS1.0, TLS1.1, TLS1.2 and TLS 1.3 +-- protocol, and support RSA and Ephemeral (Elliptic curve and +-- regular) Diffie Hellman key exchanges, and many extensions. +-- +-- Some debug tools linked with tls, are available through the +-- http://hackage.haskell.org/package/tls-debug/. + module Network.TLS ( -- * Basic APIs @@ -20,24 +35,26 @@ , HasBackend(..) , Backend(..) - -- * Context configuration - -- ** Parameters + -- * Parameters -- intentionally hide the internal methods even haddock warns. , TLSParams , ClientParams(..) , defaultParamsClient , ServerParams(..) - -- ** Supported - , Supported(..) -- ** Shared , Shared(..) - -- ** Debug parameters - , DebugParams(..) - -- ** Client Server Hooks + -- ** Hooks , ClientHooks(..) , OnCertificateRequest , OnServerCertificate , ServerHooks(..) + , Measurement(..) + -- ** Supported + , Supported(..) + -- ** Debug parameters + , DebugParams(..) + + -- * Shared parameters -- ** Credentials , Credentials(..) , Credential @@ -45,46 +62,41 @@ , credentialLoadX509FromMemory , credentialLoadX509Chain , credentialLoadX509ChainFromMemory - -- ** Session - , SessionID - , SessionData(..) + -- ** Session manager , SessionManager(..) , noSessionManager + , SessionID + , SessionData(..) + , SessionFlag(..) , TLS13TicketInfo - -- ** Hooks - , Hooks(..) - , Handshake - , Logging(..) - , contextHookSetHandshakeRecv - , contextHookSetHandshake13Recv - , contextHookSetCertificateRecv - , contextHookSetLogging - , contextModifyHooks - -- ** Misc - , HostName + -- ** Validation Cache + , ValidationCache(..) + , ValidationCacheQueryCallback + , ValidationCacheAddCallback + , ValidationCacheResult(..) + , exceptionValidationCache + + -- * Types + -- ** For 'Supported' + , Version(..) + , Compression(..) + , nullCompression + , HashAndSignatureAlgorithm + , HashAlgorithm(..) + , SignatureAlgorithm(..) + , Group(..) + , EMSMode(..) + -- ** For parameters and hooks , DHParams , DHPublic - , Measurement(..) , GroupUsage(..) , CertificateUsage(..) , CertificateRejectReason(..) - , MaxFragmentEnum(..) - , HashAndSignatureAlgorithm - , HashAlgorithm(..) - , SignatureAlgorithm(..) , CertificateType(..) - - -- * X509 - -- ** X509 Validation - , ValidationChecks(..) - , ValidationHooks(..) - - -- ** X509 Validation Cache - , ValidationCache(..) - , ValidationCacheResult(..) - , exceptionValidationCache + , HostName + , MaxFragmentEnum(..) - -- * APIs + -- * Advanced APIs -- ** Backend , ctxConnection , contextFlush @@ -96,6 +108,8 @@ , ServerRandom , unClientRandom , unServerRandom + , HandshakeMode13(..) + , getClientCertificateChain -- ** Negotiated , getNegotiatedProtocol , getClientSNI @@ -103,32 +117,37 @@ , updateKey , KeyUpdateRequest(..) , requestCertificate - - -- * Raw types - , ProtocolType(..) + -- ** Modifying hooks in context + , Hooks(..) + , contextModifyHooks + , Handshake + , contextHookSetHandshakeRecv + , Handshake13 + , contextHookSetHandshake13Recv + , contextHookSetCertificateRecv + , Logging(..) , Header(..) - , Version(..) - -- ** Compressions & Predefined compressions - , module Network.TLS.Compression - , CompressionID - -- ** Ciphers & Predefined ciphers - , module Network.TLS.Cipher - -- ** Crypto Key - , PubKey(..) - , PrivKey(..) - -- ** TLS 1.3 - , Group(..) - , HandshakeMode13(..) + , ProtocolType(..) + , contextHookSetLogging -- * Errors and exceptions -- ** Errors , TLSError(..) , KxError(..) , AlertDescription(..) - -- ** Exceptions , TLSException(..) + -- * Raw types + -- ** Compressions class + , CompressionC(..) + , CompressionID + -- ** Crypto Key + , PubKey(..) + , PrivKey(..) + -- ** Ciphers & Predefined ciphers + , module Network.TLS.Cipher + -- * Deprecated , recvData' , contextNewOnHandle @@ -136,31 +155,44 @@ , contextNewOnSocket #endif , Bytes + , ValidationChecks(..) + , ValidationHooks(..) ) where import Network.TLS.Backend (Backend(..), HasBackend(..)) +import Network.TLS.Cipher +import Network.TLS.Compression (CompressionC(..), Compression(..), nullCompression) +import Network.TLS.Context +import Network.TLS.Core +import Network.TLS.Credentials +import Network.TLS.Crypto (KxError(..), DHParams, DHPublic, Group(..)) +import Network.TLS.Handshake.State (HandshakeMode13(..)) +import Network.TLS.Hooks +import Network.TLS.Measurement +import Network.TLS.Parameters +import Network.TLS.Session +import qualified Network.TLS.State as S import Network.TLS.Struct ( TLSError(..), TLSException(..) , HashAndSignatureAlgorithm, HashAlgorithm(..), SignatureAlgorithm(..) , Header(..), ProtocolType(..), CertificateType(..) , AlertDescription(..) , ClientRandom(..), ServerRandom(..) , Handshake) -import Network.TLS.Crypto (KxError(..), DHParams, DHPublic, Group(..)) -import Network.TLS.Cipher -import Network.TLS.Hooks -import Network.TLS.Measurement -import Network.TLS.Credentials -import Network.TLS.Compression (CompressionC(..), Compression(..), nullCompression) -import Network.TLS.Context -import Network.TLS.Parameters -import Network.TLS.Core -import Network.TLS.Session -import Network.TLS.X509 +import Network.TLS.Struct13 ( Handshake13 ) import Network.TLS.Types -import Network.TLS.Handshake.State (HandshakeMode13(..)) +import Network.TLS.X509 + +import Data.ByteString as B import Data.X509 (PubKey(..), PrivKey(..)) import Data.X509.Validation hiding (HostName) -import Data.ByteString as B {-# DEPRECATED Bytes "Use Data.ByteString.Bytestring instead of Bytes." #-} type Bytes = B.ByteString + +-- | Getting certificates from a client, if any. +-- Note that the certificates are not sent by a client +-- on resumption even if client authentication is required. +-- So, this API would be replaced by the one which can treat +-- both cases of full-negotiation and resumption. +getClientCertificateChain :: Context -> IO (Maybe CertificateChain) +getClientCertificateChain ctx = usingState_ ctx S.getClientCertificateChain diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs --- a/Network/TLS/Context/Internal.hs +++ b/Network/TLS/Context/Internal.hs @@ -61,6 +61,7 @@ , tls13orLater , addCertRequest13 , getCertRequest13 + , decideRecordVersion ) where import Network.TLS.Backend @@ -93,6 +94,7 @@ , infoCipher :: Cipher , infoCompression :: Compression , infoMasterSecret :: Maybe ByteString + , infoExtendedMasterSec :: Bool , infoClientRandom :: Maybe ClientRandom , infoServerRandom :: Maybe ServerRandom , infoNegotiatedGroup :: Maybe Group @@ -163,19 +165,21 @@ contextGetInformation ctx = do ver <- usingState_ ctx $ gets stVersion hstate <- getHState ctx - let (ms, cr, sr, hm13, grp) = case hstate of - Just st -> (hstMasterSecret st, - Just (hstClientRandom st), - hstServerRandom st, - if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing, - hstNegotiatedGroup st) - Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing) + let (ms, ems, cr, sr, hm13, grp) = + case hstate of + Just st -> (hstMasterSecret st, + hstExtendedMasterSec st, + Just (hstClientRandom st), + hstServerRandom st, + if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing, + hstNegotiatedGroup st) + Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing) (cipher,comp) <- failOnEitherError $ runRxState ctx $ gets $ \st -> (stCipher st, stCompression st) let accepted = case hstate of Just st -> hstTLS13RTT0Status st == RTT0Accepted Nothing -> False case (ver, cipher) of - (Just v, Just c) -> return $ Just $ Information v c comp ms cr sr grp hm13 accepted + (Just v, Just c) -> return $ Just $ Information v c comp ms ems cr sr grp hm13 accepted _ -> return Nothing contextSend :: Context -> ByteString -> IO () @@ -247,8 +251,8 @@ -> IO (Saved (Maybe HandshakeState)) restoreHState ctx = restoreMVar (ctxHandshake ctx) -runTxState :: Context -> RecordM a -> IO (Either TLSError a) -runTxState ctx f = do +decideRecordVersion :: Context -> IO (Version, Bool) +decideRecordVersion ctx = do ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) hrr <- usingState_ ctx getTLS13HRR -- For TLS 1.3, ver' is only used in ClientHello. @@ -257,8 +261,13 @@ let ver' | ver >= TLS13 = if hrr then TLS12 else TLS10 | otherwise = ver - opt = RecordOptions { recordVersion = ver' - , recordTLS13 = ver >= TLS13 + return (ver', ver >= TLS13) + +runTxState :: Context -> RecordM a -> IO (Either TLSError a) +runTxState ctx f = do + (ver, tls13) <- decideRecordVersion ctx + let opt = RecordOptions { recordVersion = ver + , recordTLS13 = tls13 } modifyMVar (ctxTxState ctx) $ \st -> case runRecordM f opt st of diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -28,6 +28,7 @@ , isKeyExchangeSignatureKey , findKeyExchangeSignatureAlg , findFiniteFieldGroup + , findEllipticCurveGroup , kxEncrypt , kxDecrypt , kxSign @@ -103,6 +104,14 @@ table = [ (pg prms, grp) | grp <- availableFFGroups , let Just prms = dhParamsForGroup grp ] + +findEllipticCurveGroup :: PubKeyEC -> Maybe Group +findEllipticCurveGroup ecPub = + case ecPubKeyCurveName ecPub of + Just ECC.SEC_p256r1 -> Just P256 + Just ECC.SEC_p384r1 -> Just P384 + Just ECC.SEC_p521r1 -> Just P521 + _ -> Nothing -- functions to use the hidden class. hashInit :: Hash -> HashContext diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -17,6 +17,7 @@ , extensionID_MaxFragmentLength , extensionID_SecureRenegotiation , extensionID_ApplicationLayerProtocolNegotiation + , extensionID_ExtendedMasterSecret , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_Heartbeat @@ -38,6 +39,7 @@ , MaxFragmentEnum(..) , SecureRenegotiation(..) , ApplicationLayerProtocolNegotiation(..) + , ExtendedMasterSecret(..) , NegotiatedGroups(..) , Group(..) , EcPointFormatsSupported(..) @@ -144,7 +146,7 @@ extensionID_ServerCertificateType = 0x14 -- RFC7250 extensionID_Padding = 0x15 -- draft-agl-tls-padding. expires 2015-03-12 extensionID_EncryptThenMAC = 0x16 -- RFC7366 -extensionID_ExtendedMasterSecret = 0x17 -- draft-ietf-tls-session-hash. expires 2015-09-26 +extensionID_ExtendedMasterSecret = 0x17 -- REF7627 extensionID_SessionTicket = 0x23 -- RFC4507 -- Reserved 0x28 -- TLS 1.3 extensionID_PreSharedKey = 0x29 -- TLS 1.3 @@ -205,6 +207,7 @@ supportedExtensions = [ extensionID_ServerName , extensionID_MaxFragmentLength , extensionID_ApplicationLayerProtocolNegotiation + , extensionID_ExtendedMasterSecret , extensionID_SecureRenegotiation , extensionID_NegotiatedGroups , extensionID_EcPointFormats @@ -354,6 +357,18 @@ alpnParsed <- getOpaque8 let !alpn = B.copy alpnParsed return (B.length alpn + 1, alpn) + +------------------------------------------------------------ + +-- | Extended Master Secret +data ExtendedMasterSecret = ExtendedMasterSecret deriving (Show,Eq) + +instance Extension ExtendedMasterSecret where + extensionID _ = extensionID_ExtendedMasterSecret + extensionEncode ExtendedMasterSecret = B.empty + extensionDecode MsgTClientHello _ = Just ExtendedMasterSecret + extensionDecode MsgTServerHello _ = Just ExtendedMasterSecret + extensionDecode _ _ = error "extensionDecode: ExtendedMasterSecret" ------------------------------------------------------------ diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -118,11 +118,13 @@ compressions = supportedCompressions $ ctxSupported ctx highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13 + ems = supportedExtendedMasterSec $ ctxSupported ctx groupToSend = listToMaybe groups getExtensions pskInfo rtt0 = sequence [ sniExtension , secureReneg , alpnExtension + , emsExtension , groupExtension , ecPointExtension --, sessionTicketExtension @@ -151,6 +153,10 @@ Just protos -> do usingState_ ctx $ setClientALPNSuggest protos return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos + emsExtension = return $ + if ems == NoEMS || all (>= TLS13) (supportedVersions $ ctxSupported ctx) + then Nothing + else Just $ toExtensionRaw ExtendedMasterSecret sniExtension = if clientUseServerNameIndication cparams then do let sni = fst $ clientServerIdentification cparams usingState_ ctx $ setClientSNI sni @@ -252,8 +258,10 @@ let paramSession = case clientWantSessionResume cparams of Nothing -> Session Nothing Just (sid, sdata) - | sessionVersion sdata >= TLS13 -> Session Nothing - | otherwise -> Session (Just sid) + | sessionVersion sdata >= TLS13 -> Session Nothing + | ems == RequireEMS && noSessionEMS -> Session Nothing + | otherwise -> Session (Just sid) + where noSessionEMS = SessionEMS `notElem` sessionFlags sdata -- In compatibility mode a client not offering a pre-TLS 1.3 -- session MUST generate a new 32-byte value if tls13 && paramSession == Session Nothing @@ -311,8 +319,8 @@ _ -> unexpected (show p) (Just "handshake") throwAlert a = usingState_ ctx $ throwError $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure) --- | Store the keypair and check that it is compatible with a list of --- 'CertificateType' values. +-- | Store the keypair and check that it is compatible with the current protocol +-- version and a list of 'CertificateType' values. storePrivInfoClient :: Context -> [CertificateType] -> Credential @@ -324,6 +332,12 @@ ( pubkeyType pubkey ++ " credential does not match allowed certificate types" , True , InternalError ) + ver <- usingState_ ctx getVersion + unless (pubkey `versionCompatible` ver) $ + throwCore $ Error_Protocol + ( pubkeyType pubkey ++ " credential is not supported at version " ++ show ver + , True + , InternalError ) -- | When the server requests a client certificate, we try to -- obtain a suitable certificate chain and private key via the @@ -402,23 +416,24 @@ storePrivInfoClient ctx cTypes cred return $ Just cc --- | Return a most preferred 'HandAndSignatureAlgorithm' that is --- compatible with the local key and server's signature --- algorithms (both already saved). Must only be called for TLS --- versions 1.2 and up. +-- | Return a most preferred 'HandAndSignatureAlgorithm' that is compatible with +-- the local key and server's signature algorithms (both already saved). Must +-- only be called for TLS versions 1.2 and up, with compatibility function +-- 'signatureCompatible' or 'signatureCompatible13' based on version. -- -- The values in the server's @signature_algorithms@ extension are -- in descending order of preference. However here the algorithms -- are selected by client preference in @cHashSigs@. -- getLocalHashSigAlg :: Context + -> (PubKey -> HashAndSignatureAlgorithm -> Bool) -> [HashAndSignatureAlgorithm] -> PubKey -> IO HashAndSignatureAlgorithm -getLocalHashSigAlg ctx cHashSigs pubKey = do +getLocalHashSigAlg ctx isCompatible cHashSigs pubKey = do -- Must be present with TLS 1.2 and up. (Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata - let want = (&&) <$> signatureCompatible pubKey + let want = (&&) <$> isCompatible pubKey <*> flip elem hashSigs case find want cHashSigs of Just best -> return best @@ -481,14 +496,13 @@ sendClientKeyXchg = do cipher <- usingHState ctx getPendingCipher - ckx <- case cipherKeyExchange cipher of + (ckx, setMasterSec) <- case cipherKeyExchange cipher of CipherKeyExchange_RSA -> do clientVersion <- usingHState ctx $ gets hstClientVersion (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 let premaster = encodePreMasterSecret clientVersion prerand - masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster - logKey ctx (MasterSecret masterSecret) + setMasterSec = setMasterSecretFromPre xver ClientRole premaster encryptedPreMaster <- do -- SSL3 implementation generally forget this length field since it's redundant, -- however TLS10 make it clear that the length field need to be present. @@ -497,13 +511,15 @@ then B.empty else encodeWord16 $ fromIntegral $ B.length e return $ extra `B.append` e - return $ CKX_RSA encryptedPreMaster + return (CKX_RSA encryptedPreMaster, setMasterSec) CipherKeyExchange_DHE_RSA -> getCKX_DHE CipherKeyExchange_DHE_DSS -> getCKX_DHE CipherKeyExchange_ECDHE_RSA -> getCKX_ECDHE CipherKeyExchange_ECDHE_ECDSA -> getCKX_ECDHE _ -> throwCore $ Error_Protocol ("client key exchange unsupported type", True, HandshakeFailure) sendPacket ctx $ Handshake [ClientKeyXchg ckx] + masterSecret <- usingHState ctx setMasterSec + logKey ctx (MasterSecret masterSecret) where getCKX_DHE = do xver <- usingState_ ctx getVersion serverParams <- usingHState ctx getServerDHParams @@ -537,9 +553,8 @@ Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter) Just pair -> return pair - masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster - logKey ctx (MasterSecret masterSecret) - return $ CKX_DH clientDHPub + let setMasterSec = setMasterSecretFromPre xver ClientRole premaster + return (CKX_DH clientDHPub, setMasterSec) getCKX_ECDHE = do ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams @@ -550,9 +565,8 @@ Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter) Just (clipub, premaster) -> do xver <- usingState_ ctx getVersion - masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster - logKey ctx (MasterSecret masterSecret) - return $ CKX_ECDH $ encodeGroupPublic clipub + let setMasterSec = setMasterSecretFromPre xver ClientRole premaster + return (CKX_ECDH $ encodeGroupPublic clipub, setMasterSec) -- In order to send a proper certificate verify message, -- we have to do the following: @@ -575,7 +589,7 @@ mhashSig <- case ver of TLS12 -> let cHashSigs = supportedHashSignatures $ ctxSupported ctx - in Just <$> getLocalHashSigAlg ctx cHashSigs pubKey + in Just <$> getLocalHashSigAlg ctx signatureCompatible cHashSigs pubKey _ -> return Nothing -- Fetch all handshake messages up to now. @@ -644,7 +658,7 @@ setVersion rver -- must be before processing supportedVersions ext mapM_ processServerExtension exts - setALPN ctx exts + setALPN ctx MsgTServerHello exts ver <- usingState_ ctx getVersion @@ -673,10 +687,15 @@ failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg return RecvStateDone else do + ems <- processExtendedMasterSec ctx ver MsgTServerHello exts usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg case resumingSession of Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx) Just sessionData -> do + let emsSession = SessionEMS `elem` sessionFlags sessionData + when (ems /= emsSession) $ + let err = "server resumes a session which is not EMS consistent" + in throwCore $ Error_Protocol (err, True, HandshakeFailure) let masterSecret = sessionSecret sessionData usingHState ctx $ setMasterSecret rver ClientRole masterSecret logKey ctx (MasterSecret masterSecret) @@ -763,6 +782,12 @@ publicKey <- usingHState ctx getRemotePublicKey unless (isKeyExchangeSignatureKey kxsAlg publicKey) $ throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg, True, HandshakeFailure) + ver <- usingState_ ctx getVersion + unless (publicKey `versionCompatible` ver) $ + throwCore $ Error_Protocol (show ver ++ " has no support for " ++ pubkeyType publicKey, True, IllegalParameter) + let groups = supportedGroups (ctxSupported ctx) + unless (satisfiesEcPredicate (`elem` groups) publicKey) $ + throwCore $ Error_Protocol ("server public key has unsupported elliptic curve", True, IllegalParameter) return publicKey processServerKeyExchange ctx p = processCertificateRequest ctx p @@ -888,7 +913,7 @@ Just _ -> throwCore $ Error_Protocol ("selected identity out of range", True, IllegalParameter) expectEncryptedExtensions (EncryptedExtensions13 eexts) = do - liftIO $ setALPN ctx eexts + liftIO $ setALPN ctx MsgTEncryptedExtensions eexts st <- usingHState ctx getTLS13RTT0Status if st == RTT0Sent then case extensionLookup extensionID_EarlyData eexts of @@ -918,7 +943,8 @@ expectCertAndVerify (Certificate13 _ cc _) = do _ <- liftIO $ processCertificate cparams ctx (Certificates cc) let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc - checkDigitalSignatureKey pubkey + ver <- liftIO $ usingState_ ctx getVersion + checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey recvHandshake13hash ctx $ expectCertVerify pubkey expectCertAndVerify p = unexpected (show p) (Just "server certificate") @@ -1005,7 +1031,7 @@ _ -> do hChSc <- transcriptHash ctx pubKey <- getLocalPublicKey ctx - sigAlg <- liftIO $ getLocalHashSigAlg ctx cHashSigs pubKey + sigAlg <- liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey vfy <- makeCertVerify ctx pubKey sigAlg hChSc loadPacket13 ctx $ Handshake13 [vfy] -- @@ -1016,8 +1042,8 @@ , InternalError ) -setALPN :: Context -> [ExtensionRaw] -> IO () -setALPN ctx exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTServerHello of +setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO () +setALPN ctx msgt exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode msgt of Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do mprotos <- getClientALPNSuggest case mprotos of diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -15,6 +15,7 @@ , recvPacketHandshake , onRecvStateHandshake , ensureRecvComplete + , processExtendedMasterSec , extensionLookup , getSessionData , storePrivInfo @@ -28,6 +29,7 @@ import Network.TLS.Parameters import Network.TLS.Compression import Network.TLS.Context.Internal +import Network.TLS.Extension import Network.TLS.Session import Network.TLS.Struct import Network.TLS.Struct13 @@ -99,6 +101,7 @@ return $ Just (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake)) { hstServerRandom = hstServerRandom hshake , hstMasterSecret = hstMasterSecret hshake + , hstExtendedMasterSec = hstExtendedMasterSec hshake , hstNegotiatedGroup = hstNegotiatedGroup hshake } updateMeasure ctx resetBytesCounters @@ -166,15 +169,30 @@ unless complete $ throwCore $ Error_Protocol ("received incomplete message at key change", True, UnexpectedMessage) +processExtendedMasterSec :: MonadIO m => Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool +processExtendedMasterSec ctx ver msgt exts + | ver < TLS10 = return False + | ver > TLS12 = error "EMS processing is not compatible with TLS 1.3" + | ems == NoEMS = return False + | otherwise = + case extensionLookup extensionID_ExtendedMasterSecret exts >>= extensionDecode msgt of + Just ExtendedMasterSecret -> usingHState ctx (setExtendedMasterSec True) >> return True + Nothing | ems == RequireEMS -> throwCore $ Error_Protocol (err, True, HandshakeFailure) + | otherwise -> return False + where ems = supportedExtendedMasterSec (ctxSupported ctx) + err = "peer does not support Extended Master Secret" + getSessionData :: Context -> IO (Maybe SessionData) getSessionData ctx = do ver <- usingState_ ctx getVersion sni <- usingState_ ctx getClientSNI mms <- usingHState ctx (gets hstMasterSecret) + !ems <- usingHState ctx getExtendedMasterSec tx <- liftIO $ readMVar (ctxTxState ctx) alpn <- usingState_ ctx getNegotiatedProtocol let !cipher = cipherID $ fromJust "cipher" $ stCipher tx !compression = compressionID $ stCompression tx + flags = [SessionEMS | ems] case mms of Nothing -> return Nothing Just ms -> return $ Just SessionData @@ -187,6 +205,7 @@ , sessionTicketInfo = Nothing , sessionALPN = alpn , sessionMaxEarlyDataSize = 0 + , sessionFlags = flags } extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString diff --git a/Network/TLS/Handshake/Common13.hs b/Network/TLS/Handshake/Common13.hs --- a/Network/TLS/Handshake/Common13.hs +++ b/Network/TLS/Handshake/Common13.hs @@ -143,7 +143,7 @@ checkCertVerify :: MonadIO m => Context -> PubKey -> HashAndSignatureAlgorithm -> Signature -> ByteString -> m Bool checkCertVerify ctx pub hs signature hashValue - | pub `signatureCompatible` hs = liftIO $ do + | pub `signatureCompatible13` hs = liftIO $ do cc <- usingState_ ctx isClientContext let ctxStr | cc == ClientRole = serverContextString -- opposite context | otherwise = clientContextString @@ -323,6 +323,7 @@ , sessionTicketInfo = Just tinfo , sessionALPN = malpn , sessionMaxEarlyDataSize = maxSize + , sessionFlags = [] } ---------------------------------------------------------------- diff --git a/Network/TLS/Handshake/Key.hs b/Network/TLS/Handshake/Key.hs --- a/Network/TLS/Handshake/Key.hs +++ b/Network/TLS/Handshake/Key.hs @@ -18,9 +18,11 @@ , generateECDHEShared , generateFFDHE , generateFFDHEShared + , versionCompatible , isDigitalSignaturePair , checkDigitalSignatureKey , getLocalPublicKey + , satisfiesEcPredicate , logKey ) where @@ -35,6 +37,7 @@ import Network.TLS.Context.Internal import Network.TLS.Imports import Network.TLS.Struct +import Network.TLS.X509 {- if the RSA encryption fails we just return an empty bytestring, and let the protocol - fail by itself; however it would be probably better to just report it since it's an internal problem. @@ -93,13 +96,24 @@ isDigitalSignatureKey (PubKeyEd448 _) = True isDigitalSignatureKey _ = False --- | Test whether the argument is a public key supported for signature. This --- also accepts a key for RSA encryption. This test is performed by clients or --- servers before verifying a remote Certificate Verify. -checkDigitalSignatureKey :: MonadIO m => PubKey -> m () -checkDigitalSignatureKey key = +versionCompatible :: PubKey -> Version -> Bool +versionCompatible (PubKeyRSA _) _ = True +versionCompatible (PubKeyDSA _) v = v <= TLS12 +versionCompatible (PubKeyEC _) v = v >= TLS10 +versionCompatible (PubKeyEd25519 _) v = v >= TLS12 +versionCompatible (PubKeyEd448 _) v = v >= TLS12 +versionCompatible _ _ = False + +-- | Test whether the argument is a public key supported for signature at the +-- specified TLS version. This also accepts a key for RSA encryption. This +-- test is performed by clients or servers before verifying a remote +-- Certificate Verify. +checkDigitalSignatureKey :: MonadIO m => Version -> PubKey -> m () +checkDigitalSignatureKey usedVersion key = do unless (isDigitalSignatureKey key) $ throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure) + unless (key `versionCompatible` usedVersion) $ + throwCore $ Error_Protocol (show usedVersion ++ " has no support for " ++ pubkeyType key, True, IllegalParameter) -- | Test whether the argument is matching key pair supported for signature. -- This also accepts material for RSA encryption. This test is performed by @@ -117,6 +131,14 @@ getLocalPublicKey :: MonadIO m => Context -> m PubKey getLocalPublicKey ctx = usingHState ctx (fst <$> getLocalPublicPrivateKeys) + +-- | Test whether the public key satisfies a predicate about the elliptic curve. +-- When the public key is not suitable for ECDSA, like RSA for instance, the +-- predicate is not used and the result is 'True'. +satisfiesEcPredicate :: (Group -> Bool) -> PubKey -> Bool +satisfiesEcPredicate p (PubKeyEC ecPub) = + maybe False p $ findEllipticCurveGroup ecPub +satisfiesEcPredicate _ _ = True ---------------------------------------------------------------- diff --git a/Network/TLS/Handshake/Process.hs b/Network/TLS/Handshake/Process.hs --- a/Network/TLS/Handshake/Process.hs +++ b/Network/TLS/Handshake/Process.hs @@ -11,31 +11,31 @@ ( processHandshake , processHandshake13 , startHandshake - , getHandshakeDigest ) where -import Control.Concurrent.MVar -import Control.Monad.State.Strict (gets) -import Control.Monad.IO.Class (liftIO) - -import Network.TLS.Types (Role(..), invertRole, MasterSecret(..)) -import Network.TLS.Util -import Network.TLS.Packet -import Network.TLS.ErrT -import Network.TLS.Struct -import Network.TLS.Struct13 -import Network.TLS.State import Network.TLS.Context.Internal import Network.TLS.Crypto -import Network.TLS.Imports +import Network.TLS.ErrT +import Network.TLS.Extension +import Network.TLS.Handshake.Key import Network.TLS.Handshake.Random import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 -import Network.TLS.Handshake.Key -import Network.TLS.Extension +import Network.TLS.Imports +import Network.TLS.Packet import Network.TLS.Parameters +import Network.TLS.Sending import Network.TLS.Sending13 +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.Types (Role(..), invertRole, MasterSecret(..)) +import Network.TLS.Util + +import Control.Concurrent.MVar +import Control.Monad.IO.Class (liftIO) +import Control.Monad.State.Strict (gets) import Data.X509 (CertificateChain(..), Certificate(..), getCertificate) processHandshake :: Context -> Handshake -> IO () @@ -51,14 +51,14 @@ hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx cver ran Certificates certs -> processCertificates role certs - ClientKeyXchg content -> when (role == ServerRole) $ do - processClientKeyXchg ctx content Finished fdata -> processClientFinished ctx fdata _ -> return () - let encoded = encodeHandshake hs when (isHRR hs) $ usingHState ctx wrapAsMessageHash13 - when (certVerifyHandshakeMaterial hs) $ usingHState ctx $ addHandshakeMessage encoded - when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ usingHState ctx $ updateHandshakeDigest encoded + void $ updateHandshake ctx ServerRole hs + case hs of + ClientKeyXchg content -> when (role == ServerRole) $ + processClientKeyXchg ctx content + _ -> return () where secureRenegotiation = supportedSecureRenegotiation $ ctxSupported ctx -- RFC5746: secure renegotiation -- the renegotiation_info extension: 0xff01 @@ -83,7 +83,7 @@ isHRR _ = False processHandshake13 :: Context -> Handshake13 -> IO () -processHandshake13 = updateHandshake13 +processHandshake13 ctx = void . updateHandshake13 ctx -- process the client key exchange message. the protocol expects the initial -- client version received in ClientHello, not the negotiated version. @@ -137,8 +137,6 @@ (cc,ver) <- usingState_ ctx $ (,) <$> isClientContext <*> getVersion expected <- usingHState ctx $ getHandshakeDigest ver $ invertRole cc when (expected /= fdata) $ decryptError "cannot verify finished" - usingState_ ctx $ updateVerifiedData ServerRole fdata - return () -- initialize a new Handshake context (initial handshake or renegotiations) startHandshake :: Context -> Version -> ClientRandom -> IO () diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -146,24 +146,20 @@ Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos _ -> return () - extraCreds <- onServerNameIndication (serverHooks sparams) serverName - let allCreds = extraCreds `mappend` sharedCredentials (ctxShared ctx) - -- TLS version dependent if chosenVersion <= TLS12 then - handshakeServerWithTLS12 sparams ctx chosenVersion allCreds exts ciphers serverName clientVersion compressions clientSession + handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession else do mapM_ ensureNullCompression compressions -- fixme: we should check if the client random is the same as -- that in the first client hello in the case of hello retry. - handshakeServerWithTLS13 sparams ctx chosenVersion allCreds exts ciphers serverName clientSession + handshakeServerWithTLS13 sparams ctx chosenVersion exts ciphers serverName clientSession handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure) -- TLS 1.2 or earlier handshakeServerWithTLS12 :: ServerParams -> Context -> Version - -> Credentials -> [ExtensionRaw] -> [CipherID] -> Maybe String @@ -171,7 +167,11 @@ -> [CompressionID] -> Session -> IO () -handshakeServerWithTLS12 sparams ctx chosenVersion allCreds exts ciphers serverName clientVersion compressions clientSession = do +handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession = do + extraCreds <- onServerNameIndication (serverHooks sparams) serverName + let allCreds = filterCredentials (isCredentialAllowed chosenVersion) $ + extraCreds `mappend` sharedCredentials (ctxShared ctx) + -- If compression is null, commonCompressions should be [0]. when (null commonCompressions) $ throwCore $ Error_Protocol ("no compression in common with the client", True, HandshakeFailure) @@ -247,7 +247,10 @@ then (allCreds, sigAllCreds, allCiphers) else (cltCreds, sigCltCreds, cltCiphers) in resultTuple - _ -> (allCreds, allCreds, selectCipher allCreds allCreds) + _ -> + let sigAllCreds = filterCredentials (isJust . credentialDigitalSignatureKey) allCreds + allCiphers = selectCipher allCreds sigAllCreds + in (allCreds, sigAllCreds, allCiphers) -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle @@ -266,10 +269,11 @@ CipherKeyExchange_ECDHE_ECDSA -> return $ credentialsFindForSigning KX_ECDSA signatureCreds _ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure) + ems <- processExtendedMasterSec ctx chosenVersion MsgTClientHello exts resumeSessionData <- case clientSession of - (Session (Just clientSessionId)) -> + (Session (Just clientSessionId)) -> do let resume = liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId - in validateSession serverName <$> resume + resume >>= validateSession serverName ems (Session Nothing) -> return Nothing -- Currently, we don't send back EcPointFormats. In this case, @@ -285,17 +289,22 @@ commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions usedCompression = head commonCompressions - validateSession _ Nothing = Nothing - validateSession sni m@(Just sd) + validateSession _ _ Nothing = return Nothing + validateSession 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. - | clientVersion < sessionVersion sd = Nothing - | sessionCipher sd `notElem` ciphers = Nothing - | sessionCompression sd `notElem` compressions = Nothing - | isJust sni && sessionClientSNI sd /= sni = Nothing - | otherwise = m + | clientVersion < sessionVersion sd = return Nothing + | sessionCipher sd `notElem` ciphers = return Nothing + | sessionCompression sd `notElem` compressions = 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, True, HandshakeFailure) + | otherwise = return m + where emsSession = SessionEMS `elem` sessionFlags sd doHandshake :: ServerParams -> Maybe Credential -> Context -> Version -> Cipher -> Compression -> Session -> Maybe SessionData @@ -341,7 +350,10 @@ return $ extensionEncode (SecureRenegotiation cvf $ Just svf) return [ ExtensionRaw extensionID_SecureRenegotiation vf ] else return [] - + ems <- usingHState ctx getExtendedMasterSec + let emsExt | ems = let raw = extensionEncode ExtendedMasterSecret + in [ ExtensionRaw extensionID_ExtendedMasterSecret raw ] + | otherwise = [] protoExt <- applicationProtocol ctx exts sparams sniExt <- do resuming <- usingState_ ctx isSessionResuming @@ -356,7 +368,7 @@ -- field of this extension SHALL be empty. Just _ -> return [ ExtensionRaw extensionID_ServerName ""] Nothing -> return [] - let extensions = secRengExt ++ protoExt ++ sniExt + let extensions = secRengExt ++ emsExt ++ protoExt ++ sniExt usingState_ ctx (setVersion chosenVersion) usingHState ctx $ setServerHelloParameters chosenVersion srand usedCipher usedCompression return $ ServerHello chosenVersion srand session (cipherID usedCipher) @@ -522,7 +534,7 @@ msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages pubKey <- usingHState ctx getRemotePublicKey - checkDigitalSignatureKey pubKey + checkDigitalSignatureKey usedVersion pubKey verif <- checkCertificateVerify ctx usedVersion pubKey msgs dsig clientCertVerify sparams ctx certs verif @@ -581,11 +593,18 @@ | otherwise = Nothing where keys@(pubkey, _) = credentialPublicPrivateKeys cred +filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials +filterCredentials p (Credentials l) = Credentials (filter p l) + 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 ] +isCredentialAllowed :: Version -> Credential -> Bool +isCredentialAllowed ver cred = pubkey `versionCompatible` ver + where (pubkey, _) = credentialPublicPrivateKeys cred + -- Filters a list of candidate credentials with credentialMatchesHashSignatures. -- -- Algorithms to filter with are taken from "signature_algorithms_cert" @@ -615,7 +634,6 @@ where withExt extId = extensionLookup extId exts >>= extensionDecode MsgTClientHello withAlgs sas = filterCredentials (credentialMatchesHashSignatures sas) - filterCredentials p (Credentials l) = Credentials (filter p l) -- returns True if certificate filtering with "signature_algorithms_cert" / -- "signature_algorithms" produced no ephemeral D-H nor TLS13 cipher (so @@ -638,13 +656,12 @@ handshakeServerWithTLS13 :: ServerParams -> Context -> Version - -> Credentials -> [ExtensionRaw] -> [CipherID] -> Maybe String -> Session -> IO () -handshakeServerWithTLS13 sparams ctx chosenVersion allCreds exts clientCiphers _serverName clientSession = do +handshakeServerWithTLS13 sparams ctx chosenVersion exts clientCiphers _serverName clientSession = do when (any (\(ExtensionRaw eid _) -> eid == extensionID_PreSharedKey) $ init exts) $ throwCore $ Error_Protocol ("extension pre_shared_key must be last", True, IllegalParameter) -- Deciding cipher. @@ -669,7 +686,7 @@ _ -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure) case findKeyShare keyShares serverGroups of Nothing -> helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession - Just keyShare -> doHandshake13 sparams ctx allCreds chosenVersion usedCipher exts usedHash keyShare clientSession rtt0 + Just keyShare -> doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash keyShare clientSession rtt0 where ciphersFilteredVersion = filter ((`elem` clientCiphers) . cipherID) serverCiphers serverCiphers = filter (cipherAllowedForVersion chosenVersion) (supportedCiphers $ serverSupported sparams) @@ -679,17 +696,19 @@ Just k -> Just k Nothing -> findKeyShare ks gs -doHandshake13 :: ServerParams -> Context -> Credentials -> Version +doHandshake13 :: ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> Hash -> KeyShareEntry -> Session -> Bool -> IO () -doHandshake13 sparams ctx allCreds chosenVersion usedCipher exts usedHash clientKeyShare clientSession rtt0 = do +doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare clientSession rtt0 = do newSession ctx >>= \ss -> usingState_ ctx $ do setSession ss False setClientSupportsPHA supportsPHA usingHState ctx $ setNegotiatedGroup $ keyShareEntryGroup clientKeyShare srand <- setServerParameter + -- ALPN is used in choosePSK + protoExt <- applicationProtocol ctx exts sparams (psk, binderInfo, is0RTTvalid) <- choosePSK earlyKey <- calculateEarlySecret ctx choice (Left psk) True let earlySecret = pairBase earlyKey @@ -698,6 +717,9 @@ hrr <- usingState_ ctx getTLS13HRR let authenticated = isJust binderInfo rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid + extraCreds <- usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams) + let allCreds = filterCredentials (isCredentialAllowed chosenVersion) $ + extraCreds `mappend` sharedCredentials (ctxShared ctx) ---------------------------------------------------------------- established <- ctxEstablished ctx if established /= NotEstablished then @@ -713,7 +735,7 @@ else -- FullHandshake or HelloRetryRequest return () - mCredInfo <- if authenticated then return Nothing else decideCredentialInfo + mCredInfo <- if authenticated then return Nothing else decideCredentialInfo allCreds (ecdhe,keyShare) <- makeServerKeyShare ctx clientKeyShare ensureRecvComplete ctx (clientHandshakeSecret, handshakeSecret) <- runPacketFlight ctx $ do @@ -727,7 +749,7 @@ setRxState ctx usedHash usedCipher $ if rtt0OK then clientEarlySecret else clientHandshakeSecret setTxState ctx usedHash usedCipher serverHandshakeSecret ---------------------------------------------------------------- - sendExtensions rtt0OK + sendExtensions rtt0OK protoExt case mCredInfo of Nothing -> return () Just (cred, hashSig) -> sendCertAndVerify cred hashSig @@ -835,7 +857,7 @@ let selectedIdentity = extensionEncode $ PreSharedKeyServerHello $ fromIntegral n return [ExtensionRaw extensionID_PreSharedKey selectedIdentity] - decideCredentialInfo = do + decideCredentialInfo allCreds = do cHashSigs <- case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode MsgTClientHello of Nothing -> throwCore $ Error_Protocol ("no signature_algorithms extension", True, MissingExtension) Just (SignatureAlgorithms sas) -> return sas @@ -878,8 +900,7 @@ vrfy <- makeCertVerify ctx pubkey hashSig hChSc loadPacket13 ctx $ Handshake13 [vrfy] - sendExtensions rtt0OK = do - protoExt <- liftIO $ applicationProtocol ctx exts sparams + sendExtensions rtt0OK protoExt = do msni <- liftIO $ usingState_ ctx getClientSNI let sniExtension = case msni of -- RFC6066: In this event, the server SHALL include @@ -949,7 +970,8 @@ pubkey <- case cc of [] -> throwCore $ Error_Protocol ("client certificate missing", True, HandshakeFailure) c:_ -> return $ certPubKey $ getCertificate c - checkDigitalSignatureKey pubkey + ver <- usingState_ ctx getVersion + checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey verif <- checkCertVerify ctx pubkey sigAlg sig hChCc clientCertVerify sparams ctx certs verif @@ -1057,7 +1079,7 @@ where forSigning cred = case credentialDigitalSignatureKey cred of Nothing -> False - Just pub -> pub `signatureCompatible` sigAlg + Just pub -> pub `signatureCompatible13` sigAlg clientCertificate :: ServerParams -> Context -> CertificateChain -> IO () clientCertificate sparams ctx certs = do diff --git a/Network/TLS/Handshake/Signature.hs b/Network/TLS/Handshake/Signature.hs --- a/Network/TLS/Handshake/Signature.hs +++ b/Network/TLS/Handshake/Signature.hs @@ -17,6 +17,7 @@ , checkSupportedHashSignature , certificateCompatible , signatureCompatible + , signatureCompatible13 , hashSigToCertType , signatureParams , decryptError @@ -64,6 +65,18 @@ signatureCompatible (PubKeyEd25519 _) (_, SignatureEd25519) = True signatureCompatible (PubKeyEd448 _) (_, SignatureEd448) = True signatureCompatible _ (_, _) = False + +-- Same as 'signatureCompatible' but for TLS13: for ECDSA this also checks the +-- relation between hash in the HashAndSignatureAlgorithm and elliptic curve +signatureCompatible13 :: PubKey -> HashAndSignatureAlgorithm -> Bool +signatureCompatible13 (PubKeyEC ecPub) (h, SignatureECDSA) = + maybe False (\g -> findEllipticCurveGroup ecPub == Just g) (hashCurve h) + where + hashCurve HashSHA256 = Just P256 + hashCurve HashSHA384 = Just P384 + hashCurve HashSHA512 = Just P521 + hashCurve _ = Nothing +signatureCompatible13 pub hs = signatureCompatible pub hs -- | Translate a 'HashAndSignatureAlgorithm' to an acceptable 'CertificateType'. -- Perhaps this needs to take supported groups into account, so that, for diff --git a/Network/TLS/Handshake/State.hs b/Network/TLS/Handshake/State.hs --- a/Network/TLS/Handshake/State.hs +++ b/Network/TLS/Handshake/State.hs @@ -58,6 +58,8 @@ -- * misc accessor , getPendingCipher , setServerHelloParameters + , setExtendedMasterSec + , getExtendedMasterSec , setNegotiatedGroup , getNegotiatedGroup , setTLS13HandshakeMode @@ -125,6 +127,7 @@ , hstPendingRxState :: Maybe RecordState , hstPendingCipher :: Maybe Cipher , hstPendingCompression :: Compression + , hstExtendedMasterSec :: Bool , hstNegotiatedGroup :: Maybe Group , hstTLS13HandshakeMode :: HandshakeMode13 , hstTLS13RTT0Status :: !RTT0Status @@ -215,6 +218,7 @@ , hstPendingRxState = Nothing , hstPendingCipher = Nothing , hstPendingCompression = nullCompression + , hstExtendedMasterSec = False , hstNegotiatedGroup = Nothing , hstTLS13HandshakeMode = FullHandshake , hstTLS13RTT0Status = RTT0None @@ -264,6 +268,12 @@ setGroupPrivate :: GroupPrivate -> HandshakeM () setGroupPrivate shp = modify (\hst -> hst { hstGroupPrivate = Just shp }) +setExtendedMasterSec :: Bool -> HandshakeM () +setExtendedMasterSec b = modify (\hst -> hst { hstExtendedMasterSec = b }) + +getExtendedMasterSec :: HandshakeM Bool +getExtendedMasterSec = gets hstExtendedMasterSec + setNegotiatedGroup :: Group -> HandshakeM () setNegotiatedGroup g = modify (\hst -> hst { hstNegotiatedGroup = Just g }) @@ -395,6 +405,12 @@ , hstHandshakeMessages = [folded] } +getSessionHash :: HandshakeM ByteString +getSessionHash = gets $ \hst -> + case hstHandshakeDigest hst of + HandshakeDigestContext hashCtx -> hashFinal hashCtx + HandshakeMessages _ -> error "un-initialized session hash" + getHandshakeDigest :: Version -> Role -> HandshakeM ByteString getHandshakeDigest ver role = gets gen where gen hst = case hstHandshakeDigest hst of @@ -414,7 +430,8 @@ -> preMaster -- ^ the pre master secret -> HandshakeM ByteString setMasterSecretFromPre ver role premasterSecret = do - secret <- genSecret <$> get + ems <- getExtendedMasterSec + secret <- if ems then get >>= genExtendedSecret else genSecret <$> get setMasterSecret ver role secret return secret where genSecret hst = @@ -422,6 +439,10 @@ premasterSecret (hstClientRandom hst) (fromJust "server random" $ hstServerRandom hst) + genExtendedSecret hst = + generateExtendedMasterSec ver (fromJust "cipher" $ hstPendingCipher hst) + premasterSecret + <$> getSessionHash -- | Set master secret and as a side effect generate the key block -- with all the right parameters, and setup the pending tx/rx state. diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -8,117 +8,99 @@ -- Portability : unknown -- module Network.TLS.IO - ( checkValid - , sendPacket + ( sendPacket , sendPacket13 , recvPacket , recvPacket13 + -- , isRecvComplete + , checkValid -- * Grouping multiple packets in the same flight , PacketFlightM , runPacketFlight , loadPacket13 ) where +import Control.Exception (finally, throwIO) +import Control.Monad.Reader +import Control.Monad.State.Strict +import qualified Data.ByteString as B +import Data.IORef +import System.IO.Error (mkIOError, eofErrorType) + import Network.TLS.Context.Internal import Network.TLS.ErrT -import Network.TLS.Struct -import Network.TLS.Struct13 -import Network.TLS.Record -import Network.TLS.Packet import Network.TLS.Hooks -import Network.TLS.Sending -import Network.TLS.Sending13 -import Network.TLS.Receiving import Network.TLS.Imports +import Network.TLS.Packet +import Network.TLS.Receiving import Network.TLS.Receiving13 +import Network.TLS.Record +import Network.TLS.Sending +import Network.TLS.Sending13 import Network.TLS.State -import qualified Data.ByteString as B +import Network.TLS.Struct +import Network.TLS.Struct13 -import Data.IORef -import Control.Monad.Reader -import Control.Monad.State.Strict -import Control.Exception (finally, throwIO) -import System.IO.Error (mkIOError, eofErrorType) +---------------------------------------------------------------- -checkValid :: Context -> IO () -checkValid ctx = do - established <- ctxEstablished ctx - when (established == NotEstablished) $ throwIO ConnectionNotEstablished - eofed <- ctxEOF ctx - when eofed $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing +-- | Send one packet to the context +sendPacket :: MonadIO m => Context -> Packet -> m () +sendPacket ctx pkt = do + -- in ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed + -- by an attacker. Hence, an empty packet is sent before a normal data packet, to + -- prevent guessability. + when (isNonNullAppData pkt) $ do + withEmptyPacket <- liftIO $ readIORef $ ctxNeedEmptyPacket ctx + when withEmptyPacket $ + writePacketBytes ctx (AppData B.empty) >>= sendBytes ctx -readExact :: Context -> Int -> IO (Either TLSError ByteString) -readExact ctx sz = do - hdrbs <- contextRecv ctx sz - if B.length hdrbs == sz - then return $ Right hdrbs - else do - setEOF ctx - return . Left $ - if B.null hdrbs - then Error_EOF - else Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ show (B.length hdrbs)) + writePacketBytes ctx pkt >>= sendBytes ctx + where isNonNullAppData (AppData b) = not $ B.null b + isNonNullAppData _ = False +writePacketBytes :: MonadIO m => Context -> Packet -> m ByteString +writePacketBytes ctx pkt = do + edataToSend <- liftIO $ do + withLog ctx $ \logging -> loggingPacketSent logging (show pkt) + encodePacket ctx pkt + either throwCore return edataToSend + +---------------------------------------------------------------- + +sendPacket13 :: MonadIO m => Context -> Packet13 -> m () +sendPacket13 ctx pkt = writePacketBytes13 ctx pkt >>= sendBytes ctx + +writePacketBytes13 :: MonadIO m => Context -> Packet13 -> m ByteString +writePacketBytes13 ctx pkt = do + edataToSend <- liftIO $ do + withLog ctx $ \logging -> loggingPacketSent logging (show pkt) + encodePacket13 ctx pkt + either throwCore return edataToSend + +sendBytes :: MonadIO m => Context -> ByteString -> m () +sendBytes ctx dataToSend = liftIO $ do + withLog ctx $ \logging -> loggingIOSent logging dataToSend + contextSend ctx dataToSend + +---------------------------------------------------------------- + getRecord :: Context -> Int -> Header -> ByteString -> IO (Either TLSError (Record Plaintext)) getRecord ctx appDataOverhead header@(Header pt _ _) content = do withLog ctx $ \logging -> loggingIORecv logging header content runRxState ctx $ do - r <- disengageRecord $ rawToRecord header (fragmentCiphertext content) + r <- decodeRecordM header content let Record _ _ fragment = r when (B.length (fragmentGetBytes fragment) > 16384 + overhead) $ throwError contentSizeExceeded return r where overhead = if pt == ProtocolType_AppData then appDataOverhead else 0 + contentSizeExceeded :: TLSError contentSizeExceeded = Error_Protocol ("record content exceeding maximum size", True, RecordOverflow) -maximumSizeExceeded :: TLSError -maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow) - --- | recvRecord receive a full TLS record (header + data), from the other side. --- --- The record is disengaged from the record layer -recvRecord :: Bool -- ^ flag to enable SSLv2 compat ClientHello reception - -> Int -- ^ number of AppData bytes to accept above normal maximum size - -> Context -- ^ TLS context - -> IO (Either TLSError (Record Plaintext)) -recvRecord compatSSLv2 appDataOverhead ctx -#ifdef SSLV2_COMPATIBLE - | compatSSLv2 = readExact ctx 2 >>= either (return . Left) sslv2Header -#endif - | otherwise = readExact ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) - - where recvLengthE = either (return . Left) recvLength - - recvLength header@(Header _ _ readlen) - | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded - | otherwise = - readExact ctx (fromIntegral readlen) >>= - either (return . Left) (getRecord ctx appDataOverhead header) -#ifdef SSLV2_COMPATIBLE - sslv2Header header = - if B.head header >= 0x80 - then either (return . Left) recvDeprecatedLength $ decodeDeprecatedHeaderLength header - else readExact ctx 3 >>= - either (return . Left) (recvLengthE . decodeHeader . B.append header) - - recvDeprecatedLength readlen - | readlen > 1024 * 4 = return $ Left maximumSizeExceeded - | otherwise = do - res <- readExact ctx (fromIntegral readlen) - case res of - Left e -> return $ Left e - Right content -> - let hdr = decodeDeprecatedHeader readlen (B.take 3 content) - in either (return . Left) (\h -> getRecord ctx appDataOverhead h content) hdr -#endif - -isCCS :: Record a -> Bool -isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True -isCCS _ = False - +---------------------------------------------------------------- -- | receive one packet from the context that contains 1 or -- many messages (many only in case of handshake). if will returns a -- TLSError if the packet is unexpected or malformed @@ -155,56 +137,53 @@ when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx return pkt -isEmptyHandshake :: Either TLSError Packet -> Bool -isEmptyHandshake (Right (Handshake [])) = True -isEmptyHandshake _ = False - --- | Send one packet to the context -sendPacket :: MonadIO m => Context -> Packet -> m () -sendPacket ctx pkt = do - -- in ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed - -- by an attacker. Hence, an empty packet is sent before a normal data packet, to - -- prevent guessability. - when (isNonNullAppData pkt) $ do - withEmptyPacket <- liftIO $ readIORef $ ctxNeedEmptyPacket ctx - when withEmptyPacket $ - writePacketBytes ctx (AppData B.empty) >>= sendBytes ctx +-- | recvRecord receive a full TLS record (header + data), from the other side. +-- +-- The record is disengaged from the record layer +recvRecord :: Bool -- ^ flag to enable SSLv2 compat ClientHello reception + -> Int -- ^ number of AppData bytes to accept above normal maximum size + -> Context -- ^ TLS context + -> IO (Either TLSError (Record Plaintext)) +recvRecord compatSSLv2 appDataOverhead ctx +#ifdef SSLV2_COMPATIBLE + | compatSSLv2 = readExactBytes ctx 2 >>= either (return . Left) sslv2Header +#endif + | otherwise = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) - writePacketBytes ctx pkt >>= sendBytes ctx - where isNonNullAppData (AppData b) = not $ B.null b - isNonNullAppData _ = False + where recvLengthE = either (return . Left) recvLength -writePacketBytes :: MonadIO m => Context -> Packet -> m ByteString -writePacketBytes ctx pkt = do - edataToSend <- liftIO $ do - withLog ctx $ \logging -> loggingPacketSent logging (show pkt) - writePacket ctx pkt - either throwCore return edataToSend + recvLength header@(Header _ _ readlen) + | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded + | otherwise = + readExactBytes ctx (fromIntegral readlen) >>= + either (return . Left) (getRecord ctx appDataOverhead header) +#ifdef SSLV2_COMPATIBLE + sslv2Header header = + if B.head header >= 0x80 + then either (return . Left) recvDeprecatedLength $ decodeDeprecatedHeaderLength header + else readExactBytes ctx 3 >>= + either (return . Left) (recvLengthE . decodeHeader . B.append header) -sendPacket13 :: MonadIO m => Context -> Packet13 -> m () -sendPacket13 ctx pkt = writePacketBytes13 ctx pkt >>= sendBytes ctx + recvDeprecatedLength readlen + | readlen > 1024 * 4 = return $ Left maximumSizeExceeded + | otherwise = do + res <- readExactBytes ctx (fromIntegral readlen) + case res of + Left e -> return $ Left e + Right content -> + let hdr = decodeDeprecatedHeader readlen (B.take 3 content) + in either (return . Left) (\h -> getRecord ctx appDataOverhead h content) hdr +#endif -writePacketBytes13 :: MonadIO m => Context -> Packet13 -> m ByteString -writePacketBytes13 ctx pkt = do - edataToSend <- liftIO $ do - withLog ctx $ \logging -> loggingPacketSent logging (show pkt) - writePacket13 ctx pkt - either throwCore return edataToSend +isCCS :: Record a -> Bool +isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True +isCCS _ = False -sendBytes :: MonadIO m => Context -> ByteString -> m () -sendBytes ctx dataToSend = liftIO $ do - withLog ctx $ \logging -> loggingIOSent logging dataToSend - contextSend ctx dataToSend +isEmptyHandshake :: Either TLSError Packet -> Bool +isEmptyHandshake (Right (Handshake [])) = True +isEmptyHandshake _ = False -recvRecord13 :: Context - -> IO (Either TLSError (Record Plaintext)) -recvRecord13 ctx = readExact ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) - where recvLengthE = either (return . Left) recvLength - recvLength header@(Header _ _ readlen) - | readlen > 16384 + 256 = return $ Left maximumSizeExceeded - | otherwise = - readExact ctx (fromIntegral readlen) >>= - either (return . Left) (getRecord ctx 0 header) +---------------------------------------------------------------- recvPacket13 :: MonadIO m => Context -> m (Either TLSError Packet13) recvPacket13 ctx = liftIO $ do @@ -237,15 +216,54 @@ _ -> return () return pkt +recvRecord13 :: Context + -> IO (Either TLSError (Record Plaintext)) +recvRecord13 ctx = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) + where recvLengthE = either (return . Left) recvLength + recvLength header@(Header _ _ readlen) + | readlen > 16384 + 256 = return $ Left maximumSizeExceeded + | otherwise = + readExactBytes ctx (fromIntegral readlen) >>= + either (return . Left) (getRecord ctx 0 header) + isEmptyHandshake13 :: Either TLSError Packet13 -> Bool isEmptyHandshake13 (Right (Handshake13 [])) = True isEmptyHandshake13 _ = False +---------------------------------------------------------------- +-- Common for receiving + +maximumSizeExceeded :: TLSError +maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow) + +readExactBytes :: Context -> Int -> IO (Either TLSError ByteString) +readExactBytes ctx sz = do + hdrbs <- contextRecv ctx sz + if B.length hdrbs == sz + then return $ Right hdrbs + else do + setEOF ctx + return . Left $ + if B.null hdrbs + then Error_EOF + else Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ show (B.length hdrbs)) + +---------------------------------------------------------------- + isRecvComplete :: Context -> IO Bool isRecvComplete ctx = usingState_ ctx $ do cont <- gets stHandshakeRecordCont cont13 <- gets stHandshakeRecordCont13 return $! isNothing cont && isNothing cont13 + +checkValid :: Context -> IO () +checkValid ctx = do + established <- ctxEstablished ctx + when (established == NotEstablished) $ throwIO ConnectionNotEstablished + eofed <- ctxEOF ctx + when eofed $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing + +---------------------------------------------------------------- -- | State monad used to group several packets together and send them on wire as -- single flight. When packets are loaded in the monad, they are logged diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -30,7 +30,6 @@ , decodeHandshake , decodeDeprecatedHandshake , encodeHandshake - , encodeHandshakes , encodeHandshakeHeader , encodeHandshakeContent @@ -47,6 +46,7 @@ -- * generate things for packet content , generateMasterSecret + , generateExtendedMasterSec , generateKeyBlock , generateClientFinished , generateServerFinished @@ -75,13 +75,11 @@ import Network.TLS.Struct import Network.TLS.Wire import Network.TLS.Cap -import Data.ASN1.Types (fromASN1, toASN1) -import Data.ASN1.Encoding (decodeASN1', encodeASN1') -import Data.ASN1.BinaryEncoding (DER(..)) import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) import Network.TLS.Crypto import Network.TLS.MAC import Network.TLS.Cipher (CipherKeyExchangeType(..), Cipher(..)) +import Network.TLS.Util.ASN1 import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.ByteArray (ByteArrayAccess) @@ -282,11 +280,7 @@ getDName = do dName <- getOpaque16 when (B.length dName == 0) $ fail "certrequest: invalid DN length" - dn <- case decodeASN1' DER dName of - Left e -> fail ("cert request decoding DistinguishedName ASN1 failed: " ++ show e) - Right asn1s -> case fromASN1 asn1s of - Left e -> fail ("cert request parsing DistinguishedName ASN1 failed: " ++ show e) - Right (d,_) -> return d + dn <- either fail return $ decodeASN1Object "cert request DistinguishedName" dName return (2 + B.length dName, dn) decodeCertVerify :: CurrentParams -> Get Handshake @@ -359,9 +353,6 @@ _ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in B.concat [ header, content ] -encodeHandshakes :: [Handshake] -> ByteString -encodeHandshakes hss = B.concat $ map encodeHandshake hss - encodeHandshakeHeader :: HandshakeType -> Int -> Put encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len @@ -432,7 +423,7 @@ mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc where -- Convert a distinguished name to its DER encoding. - encodeCA dn = return $ encodeASN1' DER (toASN1 dn []) + encodeCA dn = return $ encodeASN1Object dn {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get ByteString @@ -596,6 +587,16 @@ generateMasterSecret SSL2 _ = generateMasterSecret_SSL generateMasterSecret SSL3 _ = generateMasterSecret_SSL generateMasterSecret v c = generateMasterSecret_TLS $ getPRF v c + +generateExtendedMasterSec :: ByteArrayAccess preMaster + => Version + -> Cipher + -> preMaster + -> ByteString + -> ByteString +generateExtendedMasterSec v c premasterSecret sessionHash = + getPRF v c (B.convert premasterSecret) seed 48 + where seed = B.append "extended master secret" sessionHash generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mastersecret kbsize = diff --git a/Network/TLS/Packet13.hs b/Network/TLS/Packet13.hs --- a/Network/TLS/Packet13.hs +++ b/Network/TLS/Packet13.hs @@ -10,8 +10,7 @@ -- Portability : unknown -- module Network.TLS.Packet13 - ( encodeHandshakes13 - , encodeHandshake13 + ( encodeHandshake13 , getHandshakeType13 , decodeHandshakeRecord13 , decodeHandshake13 @@ -26,9 +25,6 @@ import Network.TLS.Imports import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) import Network.TLS.ErrT - -encodeHandshakes13 :: [Handshake13] -> ByteString -encodeHandshakes13 hss = B.concat $ map encodeHandshake13 hss encodeHandshake13 :: Handshake13 -> ByteString encodeHandshake13 hdsk = pkt diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -21,6 +21,7 @@ , defaultParamsClient -- * Parameters , MaxFragmentEnum(..) + , EMSMode(..) , GroupUsage(..) , CertificateUsage(..) , CertificateRejectReason(..) @@ -51,13 +52,21 @@ -- | Disable the true randomness in favor of deterministic seed that will produce -- a deterministic random from. This is useful for tests and debugging purpose. -- Do not use in production + -- + -- Default: 'Nothing' debugSeed :: Maybe Seed -- | Add a way to print the seed that was randomly generated. re-using the same seed -- will reproduce the same randomness with 'debugSeed' + -- + -- Default: no printing , debugPrintSeed :: Seed -> IO () -- | Force to choose this version in the server side. + -- + -- Default: 'Nothing' , debugVersionForced :: Maybe Version - -- | Printing master keys. The default is no printing. + -- | Printing master keys. + -- + -- Default: no printing , debugKeyLogger :: String -> IO () } @@ -75,7 +84,10 @@ def = defaultDebugParams data ClientParams = ClientParams - { clientUseMaxFragmentLength :: Maybe MaxFragmentEnum + { -- | + -- + -- Default: 'Nothing' + clientUseMaxFragmentLength :: Maybe MaxFragmentEnum -- | Define the name of the server, along with an extra service identification blob. -- this is important that the hostname part is properly filled for security reason, -- as it allow to properly associate the remote side with the given certificate @@ -84,45 +96,62 @@ -- The extra blob is useful to differentiate services running on the same host, but that -- might have different certificates given. It's only used as part of the X509 validation -- infrastructure. + -- + -- This value is typically set by 'defaultParamsClient'. , clientServerIdentification :: (HostName, ByteString) -- | Allow the use of the Server Name Indication TLS extension during handshake, which allow -- the client to specify which host name, it's trying to access. This is useful to distinguish -- CNAME aliasing (e.g. web virtual host). + -- + -- Default: 'True' , clientUseServerNameIndication :: Bool -- | try to establish a connection using this session. + -- + -- Default: 'Nothing' , clientWantSessionResume :: Maybe (SessionID, SessionData) + -- | See the default value of 'Shared'. , clientShared :: Shared + -- | See the default value of 'ClientHooks'. , clientHooks :: ClientHooks -- | In this element, you'll need to override the default empty value of -- of 'supportedCiphers' with a suitable cipherlist. + -- + -- See the default value of 'Supported'. , clientSupported :: Supported + -- | See the default value of 'DebugParams'. , clientDebug :: DebugParams -- | Client tries to send this early data in TLS 1.3 if possible. -- If not accepted by the server, it is application's responsibility -- to re-sent it. + -- + -- Default: 'Nothing' , clientEarlyData :: Maybe ByteString } deriving (Show) defaultParamsClient :: HostName -> ByteString -> ClientParams defaultParamsClient serverName serverId = ClientParams - { clientWantSessionResume = Nothing - , clientUseMaxFragmentLength = Nothing - , clientServerIdentification = (serverName, serverId) + { clientUseMaxFragmentLength = Nothing + , clientServerIdentification = (serverName, serverId) , clientUseServerNameIndication = True - , clientShared = def - , clientHooks = def - , clientSupported = def - , clientDebug = defaultDebugParams - , clientEarlyData = Nothing + , clientWantSessionResume = Nothing + , clientShared = def + , clientHooks = def + , clientSupported = def + , clientDebug = defaultDebugParams + , clientEarlyData = Nothing } data ServerParams = ServerParams - { -- | request a certificate from client. + { -- | Request a certificate from client. + -- + -- Default: 'False' serverWantClientCert :: Bool -- | This is a list of certificates from which the -- disinguished names are sent in certificate request -- messages. For TLS1.0, it should not be empty. + -- + -- Default: '[]' , serverCACertificates :: [SignedCertificate] -- | Server Optional Diffie Hellman parameters. Setting parameters is @@ -132,18 +161,27 @@ -- Value can be one of the standardized groups from module -- "Network.TLS.Extra.FFDHE" or custom parameters generated with -- 'Crypto.PubKey.DH.generateParams'. + -- + -- Default: 'Nothing' , serverDHEParams :: Maybe DHParams - - , serverShared :: Shared + -- | See the default value of 'ServerHooks'. , serverHooks :: ServerHooks + -- | See the default value of 'Shared'. + , serverShared :: Shared + -- | See the default value of 'Supported'. , serverSupported :: Supported + -- | See the default value of 'DebugParams'. , serverDebug :: DebugParams -- | Server accepts this size of early data in TLS 1.3. -- 0 (or lower) means that the server does not accept early data. + -- + -- Default: 0 , serverEarlyDataSize :: Int -- | Lifetime in seconds for session tickets generated by the server. -- Acceptable value range is 0 to 604800 (7 days). The default lifetime -- is 86400 seconds (1 day). + -- + -- Default: 86400 (one day) , serverTicketLifetime :: Int } deriving (Show) @@ -173,15 +211,21 @@ -- -- Versions should be listed in preference order, i.e. higher versions -- first. + -- + -- Default: @[TLS13,TLS12,TLS11,TLS10]@ supportedVersions :: [Version] -- | Supported cipher methods. The default is empty, specify a suitable -- cipher list. 'Network.TLS.Extra.Cipher.ciphersuite_default' is often -- a good choice. + -- + -- Default: @[]@ , supportedCiphers :: [Cipher] -- | Supported compressions methods. By default only the "null" -- compression is supported, which means no compression will be performed. -- Allowing other compression method is not advised as it causes a -- connection failure when TLS 1.3 is negotiated. + -- + -- Default: @[nullCompression]@ , supportedCompressions :: [Compression] -- | All supported hash/signature algorithms pair for client -- certificate verification and server signature in (EC)DHE, @@ -199,22 +243,60 @@ -- Note: with TLS 1.3 some algorithms have been deprecated and will not be -- used even when listed in the parameter: MD5, SHA-1, SHA-224, RSA -- PKCS#1, DSS. + -- + -- Default: + -- + -- @ + -- [ (HashIntrinsic, SignatureEd448) + -- , (HashIntrinsic, SignatureEd25519) + -- , (Struct.HashSHA256, SignatureECDSA) + -- , (Struct.HashSHA384, SignatureECDSA) + -- , (Struct.HashSHA512, SignatureECDSA) + -- , (HashIntrinsic, SignatureRSApssRSAeSHA512) + -- , (HashIntrinsic, SignatureRSApssRSAeSHA384) + -- , (HashIntrinsic, SignatureRSApssRSAeSHA256) + -- , (Struct.HashSHA512, SignatureRSA) + -- , (Struct.HashSHA384, SignatureRSA) + -- , (Struct.HashSHA256, SignatureRSA) + -- , (Struct.HashSHA1, SignatureRSA) + -- , (Struct.HashSHA1, SignatureDSS) + -- ] + -- @ , supportedHashSignatures :: [HashAndSignatureAlgorithm] -- | Secure renegotiation defined in RFC5746. -- If 'True', clients send the renegotiation_info extension. -- If 'True', servers handle the extension or the renegotiation SCSV -- then send the renegotiation_info extension. + -- + -- Default: 'True' , supportedSecureRenegotiation :: Bool -- | If 'True', renegotiation is allowed from the client side. -- This is vulnerable to DOS attacks. -- If 'False', renegotiation is allowed only from the server side -- via HelloRequest. + -- + -- Default: 'False' , supportedClientInitiatedRenegotiation :: Bool + -- | The mode regarding extended master secret. Enabling this extension + -- provides better security for TLS versions 1.0 to 1.2. TLS 1.3 provides + -- the security properties natively and does not need the extension. + -- + -- By default the extension is enabled but not required. If mode is set + -- to 'RequireEMS', the handshake will fail when the peer does not support + -- the extension. It is also advised to disable SSLv3 which does not have + -- this mechanism. + -- + -- Default: 'AllowEMS' + , supportedExtendedMasterSec :: EMSMode -- | Set if we support session. + -- + -- Default: 'True' , supportedSession :: Bool -- | Support for fallback SCSV defined in RFC7507. -- If 'True', servers reject handshakes which suggest -- a lower protocol than the highest protocol supported. + -- + -- Default: 'True' , supportedFallbackScsv :: Bool -- | In ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed -- by an attacker. Hence, an empty packet is normally sent before a normal data packet, to @@ -222,21 +304,32 @@ -- consider these empty packets as a protocol violation and disconnect. If this parameter is -- 'False', empty packets will never be added, which is less secure, but might help in rare -- cases. + -- + -- Default: 'True' , supportedEmptyPacket :: Bool -- | A list of supported elliptic curves and finite-field groups in the -- preferred order. -- -- The list is sent to the server as part of the "supported_groups" -- extension. It is used in both clients and servers to restrict - -- accepted groups in DH key exchange. + -- accepted groups in DH key exchange. Up until TLS v1.2, it is also + -- used by a client to restrict accepted elliptic curves in ECDSA + -- signatures. -- - -- The default value is ['X25519','P256','P384','P521']. - -- 'X25519' and 'P256' provide 128-bit security which is strong - -- enough until 2030. Both curves are fast because their - -- backends are written in C. + -- The default value includes all groups with security strength of 128 + -- bits or more. + -- + -- Default: @[X25519,X448,P256,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@ , supportedGroups :: [Group] } deriving (Show,Eq) +-- | Client or server policy regarding Extended Master Secret +data EMSMode + = NoEMS -- ^ Extended Master Secret is not used + | AllowEMS -- ^ Extended Master Secret is allowed + | RequireEMS -- ^ Extended Master Secret is required + deriving (Show,Eq) + defaultSupported :: Supported defaultSupported = Supported { supportedVersions = [TLS13,TLS12,TLS11,TLS10] @@ -258,10 +351,11 @@ ] , supportedSecureRenegotiation = True , supportedClientInitiatedRenegotiation = False + , supportedExtendedMasterSec = AllowEMS , supportedSession = True , supportedFallbackScsv = True , supportedEmptyPacket = True - , supportedGroups = [X25519,P256,P384,P521] + , supportedGroups = [X25519,X448,P256,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521] } instance Default Supported where @@ -277,11 +371,15 @@ -- -- When credential list is left empty (the default value), no key -- exchange can take place. + -- + -- Default: 'mempty' sharedCredentials :: Credentials -- | Callbacks used by clients and servers in order to resume TLS -- sessions. The default implementation never resumes sessions. Package -- -- provides an in-memory implementation. + -- + -- Default: 'noSessionManager' , sharedSessionManager :: SessionManager -- | A collection of trust anchors to be used by a client as -- part of validation of server certificates. This is set as @@ -289,11 +387,15 @@ -- -- gives access to a default certificate store configured in the -- system. + -- + -- Default: 'mempty' , sharedCAStore :: CertificateStore -- | Callbacks that may be used by a client to cache certificate -- validation results (positive or negative) and avoid expensive -- signature check. The default implementation does not have -- any caching. + -- + -- See the default value of 'ValidationCache'. , sharedValidationCache :: ValidationCache } @@ -301,9 +403,9 @@ show _ = "Shared" instance Default Shared where def = Shared - { sharedCAStore = mempty - , sharedCredentials = mempty + { sharedCredentials = mempty , sharedSessionManager = noSessionManager + , sharedCAStore = mempty , sharedValidationCache = def } @@ -386,6 +488,8 @@ -- select a certificate matching one of the requested -- certificate types (public key algorithms). Returning -- a non-matching one will lead to handshake failure later. + -- + -- Default: returns 'Nothing' anyway. onCertificateRequest :: OnCertificateRequest -- | Used by the client to validate the server certificate. The default -- implementation calls 'validateDefault' which validates according to the @@ -396,9 +500,13 @@ -- end-entity certificate, as this depends on the dynamically-selected -- cipher and this part should not be cached. Key-usage verification -- is performed by the library internally. + -- + -- Default: 'validateDefault' , onServerCertificate :: OnServerCertificate -- | This action is called when the client sends ClientHello -- to determine ALPN values such as '["h2", "http/1.1"]'. + -- + -- Default: returns 'Nothing' , onSuggestALPN :: IO (Maybe [B.ByteString]) -- | This action is called to validate DHE parameters when the server -- selected a finite-field group not part of the "Supported Groups @@ -442,11 +550,19 @@ -- The function is not expected to verify the key-usage -- extension of the certificate. This verification is -- performed by the library internally. + -- + -- Default: returns the followings: + -- + -- @ + -- CertificateUsageReject (CertificateRejectOther "no client certificates expected") + -- @ onClientCertificate :: CertificateChain -> IO CertificateUsage -- | This action is called when the client certificate -- cannot be verified. Return 'True' to accept the certificate -- anyway, or 'False' to fail verification. + -- + -- Default: returns 'False' , onUnverifiedClientCert :: IO Bool -- | Allow the server to choose the cipher relative to the @@ -456,6 +572,8 @@ -- to the BEAST (where RC4 is sometimes prefered with TLS < 1.1) -- -- The client cipher list cannot be empty. + -- + -- Default: taking the head of ciphers. , onCipherChoosing :: Version -> [Cipher] -> Cipher -- | Allow the server to indicate additional credentials @@ -468,22 +586,28 @@ -- -- Returned credentials may be ignored if a client does not support -- the signature algorithms used in the certificate chain. + -- + -- Default: returns 'mempty' , onServerNameIndication :: Maybe HostName -> IO Credentials - -- | at each new handshake, we call this hook to see if we allow handshake to happens. + -- | At each new handshake, we call this hook to see if we allow handshake to happens. + -- + -- Default: returns 'True' , onNewHandshake :: Measurement -> IO Bool -- | Allow the server to choose an application layer protocol -- suggested from the client through the ALPN -- (Application Layer Protocol Negotiation) extensions. + -- + -- Default: 'Nothing' , onALPNClientSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) } defaultServerHooks :: ServerHooks defaultServerHooks = ServerHooks - { onCipherChoosing = \_ -> head - , onClientCertificate = \_ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected" + { onClientCertificate = \_ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected" , onUnverifiedClientCert = return False + , onCipherChoosing = \_ -> head , onServerNameIndication = \_ -> return mempty , onNewHandshake = \_ -> return True , onALPNClientSuggest = Nothing diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -12,23 +12,24 @@ module Network.TLS.Receiving ( processPacket + , decodeRecordM ) where -import Control.Monad.State.Strict -import Control.Concurrent.MVar - +import Network.TLS.Cipher import Network.TLS.Context.Internal -import Network.TLS.Struct import Network.TLS.ErrT -import Network.TLS.Record +import Network.TLS.Handshake.State +import Network.TLS.Imports import Network.TLS.Packet -import Network.TLS.Wire +import Network.TLS.Record import Network.TLS.State -import Network.TLS.Handshake.State -import Network.TLS.Cipher +import Network.TLS.Struct import Network.TLS.Util -import Network.TLS.Imports +import Network.TLS.Wire +import Control.Concurrent.MVar +import Control.Monad.State.Strict + processPacket :: Context -> Record Plaintext -> IO (Either TLSError Packet) processPacket _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment @@ -73,3 +74,8 @@ switchRxEncryption ctx = usingHState ctx (gets hstPendingRxState) >>= \rx -> liftIO $ modifyMVar_ (ctxRxState ctx) (\_ -> return $ fromJust "rx-state" rx) + +decodeRecordM :: Header -> ByteString -> RecordM (Record Plaintext) +decodeRecordM header content = disengageRecord erecord + where + erecord = rawToRecord header (fragmentCiphertext content) diff --git a/Network/TLS/Receiving13.hs b/Network/TLS/Receiving13.hs --- a/Network/TLS/Receiving13.hs +++ b/Network/TLS/Receiving13.hs @@ -14,19 +14,19 @@ ( processPacket13 ) where -import Control.Monad.State - import Network.TLS.Context.Internal -import Network.TLS.Struct -import Network.TLS.Struct13 import Network.TLS.ErrT -import Network.TLS.Record.Types +import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Packet13 -import Network.TLS.Wire +import Network.TLS.Record.Types import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Struct13 import Network.TLS.Util -import Network.TLS.Imports +import Network.TLS.Wire + +import Control.Monad.State processPacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13) processPacket13 _ (Record ProtocolType_ChangeCipherSpec _ _) = return $ Right ChangeCipherSpec13 diff --git a/Network/TLS/Record/Disengage.hs b/Network/TLS/Record/Disengage.hs --- a/Network/TLS/Record/Disengage.hs +++ b/Network/TLS/Record/Disengage.hs @@ -92,14 +92,17 @@ return (expected_digest `bytesEq` digest) -- check if the padding is filled with the correct pattern if it exists + -- (before TLS10 this checks instead that the padding length is minimal) paddingValid <- case cipherDataPadding cdata of - Nothing -> return True - Just pad -> do + Nothing -> return True + Just (pad, blksz) -> do cver <- getRecordVersion let b = B.length pad - 1 - return (cver < TLS10 || B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad) + return $ if cver < TLS10 + then b < blksz + else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad - unless (macValid &&! paddingValid) $ do + unless (macValid &&! paddingValid) $ throwError $ Error_Protocol ("bad record mac", True, BadRecordMac) return $ cipherDataContent cdata @@ -137,7 +140,7 @@ getCipherData record CipherData { cipherDataContent = content , cipherDataMAC = Just mac - , cipherDataPadding = Just padding + , cipherDataPadding = Just (padding, blockSize) } decryptOf (BulkStateStream (BulkStream decryptF)) = do diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs --- a/Network/TLS/Sending.hs +++ b/Network/TLS/Sending.hs @@ -8,71 +8,51 @@ -- the Sending module contains calls related to marshalling packets according -- to the TLS state -- -module Network.TLS.Sending (writePacket) where - -import Control.Monad.State.Strict -import Control.Concurrent.MVar -import Data.IORef - -import qualified Data.ByteString as B +module Network.TLS.Sending ( + encodePacket + , encodeRecordM + , updateHandshake + ) where -import Network.TLS.Types (Role(..)) import Network.TLS.Cap -import Network.TLS.Struct -import Network.TLS.Record -import Network.TLS.Packet +import Network.TLS.Cipher import Network.TLS.Context.Internal +import Network.TLS.Handshake.State +import Network.TLS.Imports +import Network.TLS.Packet import Network.TLS.Parameters +import Network.TLS.Record import Network.TLS.State -import Network.TLS.Handshake.State -import Network.TLS.Cipher +import Network.TLS.Struct +import Network.TLS.Types (Role(..)) import Network.TLS.Util -import Network.TLS.Imports -makeRecord :: ProtocolType -> Fragment Plaintext -> RecordM (Record Plaintext) -makeRecord pt fragment = do - ver <- getRecordVersion - return $ Record pt ver fragment - --- Decompose handshake packets into fragments of the specified length. AppData --- packets are not fragmented here but by callers of sendPacket, so that the --- empty-packet countermeasure may be applied to each fragment independently. -getPacketFragments :: Int -> Packet -> [Fragment Plaintext] -getPacketFragments len pkt = map fragmentPlaintext (writePacketContent pkt) - where writePacketContent (Handshake hss) = getChunks len (encodeHandshakes hss) - writePacketContent (Alert a) = [encodeAlerts a] - writePacketContent ChangeCipherSpec = [encodeChangeCipherSpec] - writePacketContent (AppData x) = [x] - --- | marshall packet data -encodeRecord :: Record Ciphertext -> RecordM ByteString -encodeRecord record = return $ B.concat [ encodeHeader hdr, content ] - where (hdr, content) = recordToRaw record +import Control.Concurrent.MVar +import Control.Monad.State.Strict +import qualified Data.ByteString as B +import Data.IORef --- | writePacket transform a packet into marshalled data related to current state +-- | encodePacket transform a packet into marshalled data related to current state -- and updating state on the go -writePacket :: Context -> Packet -> IO (Either TLSError ByteString) -writePacket ctx pkt@(Handshake hss) = do - forM_ hss $ \hs -> do - case hs of - Finished fdata -> usingState_ ctx $ updateVerifiedData ClientRole fdata - _ -> return () - let encoded = encodeHandshake hs - usingHState ctx $ do - when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded - when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ updateHandshakeDigest encoded - writeFragments ctx pkt -writePacket ctx pkt = do - d <- writeFragments ctx pkt +encodePacket :: Context -> Packet -> IO (Either TLSError ByteString) +encodePacket ctx pkt = do + (ver, _) <- decideRecordVersion ctx + let pt = packetType pkt + mkRecord bs = Record pt ver (fragmentPlaintext bs) + records <- map mkRecord <$> packetToFragments ctx 16384 pkt + bs <- fmap B.concat <$> forEitherM records (encodeRecord ctx) when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx - return d + return bs -writeFragments :: Context-> Packet -> IO (Either TLSError ByteString) -writeFragments ctx pkt = - let fragments = getPacketFragments 16384 pkt - pt = packetType pkt - in fmap B.concat <$> forEitherM fragments (\frg -> - prepareRecord ctx (makeRecord pt frg >>= engageRecord >>= encodeRecord)) +-- Decompose handshake packets into fragments of the specified length. AppData +-- packets are not fragmented here but by callers of sendPacket, so that the +-- empty-packet countermeasure may be applied to each fragment independently. +packetToFragments :: Context -> Int -> Packet -> IO [ByteString] +packetToFragments ctx len (Handshake hss) = + getChunks len . B.concat <$> mapM (updateHandshake ctx ClientRole) hss +packetToFragments _ _ (Alert a) = return [encodeAlerts a] +packetToFragments _ _ ChangeCipherSpec = return [encodeChangeCipherSpec] +packetToFragments _ _ (AppData x) = return [x] -- before TLS 1.1, the block cipher IV is made of the residual of the previous block, -- so we use cstIV as is, however in other case we generate an explicit IV @@ -90,6 +70,15 @@ runTxState ctx (modify (setRecordIV newIV) >> f) else runTxState ctx f +encodeRecord :: Context -> Record Plaintext -> IO (Either TLSError ByteString) +encodeRecord ctx = prepareRecord ctx . encodeRecordM + +encodeRecordM :: Record Plaintext -> RecordM ByteString +encodeRecordM record = do + erecord <- engageRecord record + let (hdr, content) = recordToRaw erecord + return $ B.concat [ encodeHeader hdr, content ] + switchTxEncryption :: Context -> IO () switchTxEncryption ctx = do tx <- usingHState ctx (fromJust "tx-state" <$> gets hstPendingTxState) @@ -100,3 +89,15 @@ -- set empty packet counter measure if condition are met when (ver <= TLS10 && cc == ClientRole && isCBC tx && supportedEmptyPacket (ctxSupported ctx)) $ liftIO $ writeIORef (ctxNeedEmptyPacket ctx) True where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx) + +updateHandshake :: Context -> Role -> Handshake -> IO ByteString +updateHandshake ctx role hs = do + case hs of + Finished fdata -> usingState_ ctx $ updateVerifiedData role fdata + _ -> return () + usingHState ctx $ do + when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded + when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ updateHandshakeDigest encoded + return encoded + where + encoded = encodeHandshake hs diff --git a/Network/TLS/Sending13.hs b/Network/TLS/Sending13.hs --- a/Network/TLS/Sending13.hs +++ b/Network/TLS/Sending13.hs @@ -9,65 +9,53 @@ -- to the TLS state -- module Network.TLS.Sending13 - ( writePacket13 + ( encodePacket13 , updateHandshake13 ) where -import Control.Monad.State -import qualified Data.ByteString as B - -import Network.TLS.Struct -import Network.TLS.Struct13 -import Network.TLS.Record (RecordM) -import Network.TLS.Record.Types -import Network.TLS.Record.Engage -import Network.TLS.Packet -import Network.TLS.Packet13 import Network.TLS.Context.Internal import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 -import Network.TLS.Util import Network.TLS.Imports - -makeRecord :: ProtocolType -> Fragment Plaintext -> RecordM (Record Plaintext) -makeRecord pt fragment = - return $ Record pt TLS12 fragment - -getPacketFragments :: Int -> Packet13 -> [Fragment Plaintext] -getPacketFragments len pkt = map fragmentPlaintext (writePacketContent pkt) - where writePacketContent (Handshake13 hss) = getChunks len (encodeHandshakes13 hss) - writePacketContent (Alert13 a) = [encodeAlerts a] - writePacketContent (AppData13 x) = [x] - writePacketContent ChangeCipherSpec13 = [encodeChangeCipherSpec] - -encodeRecord :: Record Ciphertext -> RecordM ByteString -encodeRecord record = return $ B.concat [ encodeHeader hdr, content ] - where (hdr, content) = recordToRaw record +import Network.TLS.Packet +import Network.TLS.Packet13 +import Network.TLS.Record +import Network.TLS.Sending +import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.Util -writePacket13 :: Context -> Packet13 -> IO (Either TLSError ByteString) -writePacket13 ctx pkt@(Handshake13 hss) = do - forM_ hss $ updateHandshake13 ctx - writeFragments ctx pkt -writePacket13 ctx pkt = writeFragments ctx pkt +import qualified Data.ByteString as B -writeFragments :: Context -> Packet13 -> IO (Either TLSError ByteString) -writeFragments ctx pkt = - let fragments = getPacketFragments 16384 pkt - pt = contentType pkt - in fmap B.concat <$> forEitherM fragments (\frg -> - prepareRecord ctx (makeRecord pt frg >>= engageRecord >>= encodeRecord)) +encodePacket13 :: Context -> Packet13 -> IO (Either TLSError ByteString) +encodePacket13 ctx pkt = do + let pt = contentType pkt + mkRecord bs = Record pt TLS12 (fragmentPlaintext bs) + records <- map mkRecord <$> packetToFragments ctx 16384 pkt + fmap B.concat <$> forEitherM records (encodeRecord ctx) prepareRecord :: Context -> RecordM a -> IO (Either TLSError a) prepareRecord = runTxState -updateHandshake13 :: Context -> Handshake13 -> IO () +encodeRecord :: Context -> Record Plaintext -> IO (Either TLSError ByteString) +encodeRecord ctx = prepareRecord ctx . encodeRecordM + +packetToFragments :: Context -> Int -> Packet13 -> IO [ByteString] +packetToFragments ctx len (Handshake13 hss) = + getChunks len . B.concat <$> mapM (updateHandshake13 ctx) hss +packetToFragments _ _ (Alert13 a) = return [encodeAlerts a] +packetToFragments _ _ (AppData13 x) = return [x] +packetToFragments _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec] + +updateHandshake13 :: Context -> Handshake13 -> IO ByteString updateHandshake13 ctx hs - | isIgnored hs = return () + | isIgnored hs = return encoded | otherwise = usingHState ctx $ do when (isHRR hs) wrapAsMessageHash13 updateHandshakeDigest encoded addHandshakeMessage encoded + return encoded where encoded = encodeHandshake13 hs diff --git a/Network/TLS/Session.hs b/Network/TLS/Session.hs --- a/Network/TLS/Session.hs +++ b/Network/TLS/Session.hs @@ -24,6 +24,7 @@ , sessionInvalidate :: SessionID -> IO () } +-- | The session manager to do nothing. noSessionManager :: SessionManager noSessionManager = SessionManager { sessionResume = \_ -> return Nothing diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -78,7 +78,7 @@ data CipherData = CipherData { cipherDataContent :: ByteString , cipherDataMAC :: Maybe ByteString - , cipherDataPadding :: Maybe ByteString + , cipherDataPadding :: Maybe (ByteString, Int) } deriving (Show,Eq) -- | Some of the IANA registered code points for 'CertificateType' are not diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -10,6 +10,7 @@ ( Version(..) , SessionID , SessionData(..) + , SessionFlag(..) , CertReqContext , TLS13TicketInfo(..) , CipherID @@ -58,7 +59,13 @@ , sessionTicketInfo :: Maybe TLS13TicketInfo , sessionALPN :: Maybe ByteString , sessionMaxEarlyDataSize :: Int + , sessionFlags :: [SessionFlag] } deriving (Show,Eq) + +-- | Some session flags +data SessionFlag + = SessionEMS -- ^ Session created with Extended Master Secret + deriving (Show,Eq,Enum) -- | Certificate request context for TLS 1.3. type CertReqContext = ByteString diff --git a/Network/TLS/Util/Serialization.hs b/Network/TLS/Util/Serialization.hs --- a/Network/TLS/Util/Serialization.hs +++ b/Network/TLS/Util/Serialization.hs @@ -2,11 +2,6 @@ ( os2ip , i2osp , i2ospOf_ - , lengthBytes ) where -import Crypto.Number.Basic (numBytes) import Crypto.Number.Serialize (os2ip, i2osp, i2ospOf_) - -lengthBytes :: Integer -> Int -lengthBytes = numBytes diff --git a/Tests/Connection.hs b/Tests/Connection.hs --- a/Tests/Connection.hs +++ b/Tests/Connection.hs @@ -14,10 +14,13 @@ , arbitraryCredentialsOfEachCurve , arbitraryRSACredentialWithUsage , dhParamsGroup + , getConnectVersion , isVersionEnabled , isCustomDHParams , isLeafRSA , isCredentialDSA + , arbitraryEMSMode + , setEMSMode , readClientSessionRef , twoSessionRefs , twoSessionManagers @@ -43,7 +46,7 @@ import Control.Concurrent import qualified Control.Exception as E import Control.Monad (unless, when) -import Data.List (isInfixOf) +import Data.List (intersect, isInfixOf) import qualified Data.ByteString as B @@ -60,6 +63,14 @@ , cipher_null_SHA1 ] +-- local restriction: EdDSA credentials are not usable before TLS12 so without +-- ECDSA support it is not possible for ECDHE_ECDSA to be successful with TLS10 +-- and TLS11 +cipherAllowedForVersion' :: Version -> Cipher -> Bool +cipherAllowedForVersion' connectVersion x = + cipherAllowedForVersion connectVersion x && + (connectVersion >= TLS12 || cipherKeyExchange x /= CipherKeyExchange_ECDHE_ECDSA) + arbitraryCiphers :: Gen [Cipher] arbitraryCiphers = listOf1 $ elements knownCiphers @@ -105,7 +116,7 @@ knownGroups = knownECGroups ++ knownFFGroups arbitraryGroups :: Gen [Group] -arbitraryGroups = listOf1 $ elements knownGroups +arbitraryGroups = scale (min 5) $ listOf1 $ elements knownGroups isCredentialDSA :: (CertificateChain, PrivKey) -> Bool isCredentialDSA (_, PrivKeyDSA _) = True @@ -158,22 +169,14 @@ arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher]) arbitraryCipherPair connectVersion = do serverCiphers <- arbitraryCiphers `suchThat` - (\cs -> or [cipherAllowedForVersion connectVersion x | x <- cs]) + (\cs -> or [cipherAllowedForVersion' connectVersion x | x <- cs]) clientCiphers <- arbitraryCiphers `suchThat` (\cs -> or [x `elem` serverCiphers && - cipherAllowedForVersion connectVersion x | x <- cs]) + cipherAllowedForVersion' connectVersion x | x <- cs]) return (clientCiphers, serverCiphers) arbitraryPairParams :: Gen (ClientParams, ServerParams) -arbitraryPairParams = do - connectVersion <- elements knownVersions - (clientCiphers, serverCiphers) <- arbitraryCipherPair connectVersion - -- The shared ciphers may add constraints on the compatible protocol versions - let allowedVersions = [ v | v <- knownVersions, - or [ x `elem` serverCiphers && - cipherAllowedForVersion v x | x <- clientCiphers ]] - serAllowedVersions <- (:[]) `fmap` elements allowedVersions - arbitraryPairParamsWithVersionsAndCiphers (allowedVersions, serAllowedVersions) (clientCiphers, serverCiphers) +arbitraryPairParams = elements knownVersions >>= arbitraryPairParamsAt -- pair of groups so that at least one EC and one FF group are in common arbitraryGroupPair :: Gen ([Group], [Group]) @@ -195,11 +198,42 @@ arbitraryPairParamsAt :: Version -> Gen (ClientParams, ServerParams) arbitraryPairParamsAt connectVersion = do - let allowedVersions = [connectVersion] - serAllowedVersions = [connectVersion] (clientCiphers, serverCiphers) <- arbitraryCipherPair connectVersion - arbitraryPairParamsWithVersionsAndCiphers (allowedVersions, serAllowedVersions) (clientCiphers, serverCiphers) + -- Select version lists containing connectVersion, as well as some other + -- versions for which we have compatible ciphers. Criteria about cipher + -- ensure we can test version downgrade. + let allowedVersions = [ v | v <- knownVersions, + or [ x `elem` serverCiphers && + cipherAllowedForVersion' v x | x <- clientCiphers ]] + allowedVersionsFiltered = filter (<= connectVersion) allowedVersions + -- Server or client is allowed to have versions > connectVersion, but not + -- both simultaneously. + filterSrv <- arbitrary + let (clientAllowedVersions, serverAllowedVersions) + | filterSrv = (allowedVersions, allowedVersionsFiltered) + | otherwise = (allowedVersionsFiltered, allowedVersions) + -- Generate version lists containing less than 127 elements, otherwise the + -- "supported_versions" extension cannot be correctly serialized + clientVersions <- listWithOthers connectVersion 126 clientAllowedVersions + serverVersions <- listWithOthers connectVersion 126 serverAllowedVersions + arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) + where + listWithOthers :: a -> Int -> [a] -> Gen [a] + listWithOthers fixedElement maxOthers others + | maxOthers < 1 = return [fixedElement] + | otherwise = sized $ \n -> do + num <- choose (0, min n maxOthers) + pos <- choose (0, num) + prefix <- vectorOf pos $ elements others + suffix <- vectorOf (num - pos) $ elements others + return $ prefix ++ (fixedElement : suffix) +getConnectVersion :: (ClientParams, ServerParams) -> Version +getConnectVersion (cparams, sparams) = maximum (cver `intersect` sver) + where + sver = supportedVersions (serverSupported sparams) + cver = supportedVersions (clientSupported cparams) + isVersionEnabled :: Version -> (ClientParams, ServerParams) -> Bool isVersionEnabled ver (cparams, sparams) = (ver `elem` supportedVersions (serverSupported sparams)) && @@ -251,6 +285,10 @@ -- for SSL3 there is no EC but only RSA/DSA creds <- arbitraryCredentialsOfEachType elements (take 2 creds) -- RSA and DSA, but not Ed25519 and Ed448 +arbitraryClientCredential v | v < TLS12 = do + -- for TLS10 and TLS11 there is no EdDSA but only RSA/DSA/ECDSA + creds <- arbitraryCredentialsOfEachType + elements (take 2 creds) -- RSA and DSA (ECDSA later), but not EdDSA arbitraryClientCredential _ = arbitraryCredentialsOfEachType >>= elements arbitraryRSACredentialWithUsage :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey) @@ -258,6 +296,20 @@ let (pubKey, privKey) = getGlobalRSAPair cert <- arbitraryX509WithKeyAndUsage usageFlags (PubKeyRSA pubKey, ()) return (CertificateChain [cert], PrivKeyRSA privKey) + +arbitraryEMSMode :: Gen (EMSMode, EMSMode) +arbitraryEMSMode = (,) <$> gen <*> gen + where gen = elements [ NoEMS, AllowEMS, RequireEMS ] + +setEMSMode :: (EMSMode, EMSMode) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) +setEMSMode (cems, sems) (clientParam, serverParam) = (clientParam', serverParam') + where + clientParam' = clientParam { clientSupported = (clientSupported clientParam) + { supportedExtendedMasterSec = cems } + } + serverParam' = serverParam { serverSupported = (serverSupported serverParam) + { supportedExtendedMasterSec = sems } + } readClientSessionRef :: (IORef mclient, IORef mserver) -> IO mclient readClientSessionRef refs = readIORef (fst refs) diff --git a/Tests/Tests.hs b/Tests/Tests.hs --- a/Tests/Tests.hs +++ b/Tests/Tests.hs @@ -217,14 +217,12 @@ prop_handshake13_full :: PropertyM IO () prop_handshake13_full = do (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = def { - supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + let cliSupported = def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } - svrSupported = def { - supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + svrSupported = def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } params = (cli { clientSupported = cliSupported } @@ -235,14 +233,12 @@ prop_handshake13_hrr :: PropertyM IO () prop_handshake13_hrr = do (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = def { - supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + let cliSupported = def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [P256,X25519] } - svrSupported = def { - supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + svrSupported = def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } params = (cli { clientSupported = cliSupported } @@ -253,14 +249,12 @@ prop_handshake13_psk :: PropertyM IO () prop_handshake13_psk = do (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = def { - supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + let cliSupported = def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [P256,X25519] } - svrSupported = def { - supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + svrSupported = def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } params0 = (cli { clientSupported = cliSupported } @@ -285,15 +279,13 @@ prop_handshake13_psk_fallback = do (cli, srv) <- pick arbitraryPairParams13 let cliSupported = def - { supportedVersions = [TLS13] - , supportedCiphers = [ cipher_TLS13_AES128GCM_SHA256 + { supportedCiphers = [ cipher_TLS13_AES128GCM_SHA256 , cipher_TLS13_AES128CCM_SHA256 ] , supportedGroups = [P256,X25519] } svrSupported = def - { supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } params0 = (cli { clientSupported = cliSupported } @@ -315,8 +307,7 @@ let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params srv2' = srv2 { serverSupported = svrSupported' } svrSupported' = def - { supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128CCM_SHA256] + { supportedCiphers = [cipher_TLS13_AES128CCM_SHA256] , supportedGroups = [P256] } @@ -325,18 +316,25 @@ prop_handshake13_rtt0 :: PropertyM IO () prop_handshake13_rtt0 = do (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = def { - supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + let cliSupported = def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [P256,X25519] } - svrSupported = def { - supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + svrSupported = def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } - params0 = (cli { clientSupported = cliSupported } + cliHooks = def { + onSuggestALPN = return $ Just ["h2"] + } + svrHooks = def { + onALPNClientSuggest = Just (\protos -> return $ head protos) + } + params0 = (cli { clientSupported = cliSupported + , clientHooks = cliHooks + } ,srv { serverSupported = svrSupported + , serverHooks = svrHooks , serverEarlyDataSize = 2048 } ) @@ -361,14 +359,12 @@ ticketSize <- pick $ choose (0, 512) (cli, srv) <- pick arbitraryPairParams13 group0 <- pick $ elements [P256,X25519] - let cliSupported = def { - supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + let cliSupported = def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [P256,X25519] } - svrSupported = def { - supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + svrSupported = def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [group0] } params0 = (cli { clientSupported = cliSupported } @@ -390,9 +386,8 @@ earlyData <- B.pack <$> pick (someWords8 256) group2 <- pick $ elements [P256,X25519] let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params - svrSupported2 = def { - supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + svrSupported2 = def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [group2] } params2 = (pc { clientEarlyData = Just earlyData } @@ -409,13 +404,11 @@ serverMax <- pick $ choose (0, 33792) (cli, srv) <- pick arbitraryPairParams13 let cliSupported = def - { supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } svrSupported = def - { supportedVersions = [TLS13] - , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } params0 = (cli { clientSupported = cliSupported } @@ -659,7 +652,9 @@ prop_handshake_client_auth :: PropertyM IO () prop_handshake_client_auth = do (clientParam,serverParam) <- pick arbitraryPairParams - let version = maximum (supportedVersions $ serverSupported serverParam) + let clientVersions = supportedVersions $ clientSupported clientParam + serverVersions = supportedVersions $ serverSupported serverParam + version = maximum (clientVersions `intersect` serverVersions) cred <- pick (arbitraryClientCredential version) let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onCertificateRequest = \_ -> return $ Just cred } @@ -735,6 +730,59 @@ then runTLSPipeSimple (clientParam',serverParam') else runTLSInitFailure (clientParam',serverParam') +prop_handshake_ems :: PropertyM IO () +prop_handshake_ems = do + (cems, sems) <- pick arbitraryEMSMode + params <- pick arbitraryPairParams + let params' = setEMSMode (cems, sems) params + version = getConnectVersion params' + emsVersion = version >= TLS10 && version <= TLS12 + use = cems /= NoEMS && sems /= NoEMS + require = cems == RequireEMS || sems == RequireEMS + p info = infoExtendedMasterSec info == (emsVersion && use) + if emsVersion && require && not use + then runTLSInitFailure params' + else runTLSPipePredicate params' (maybe False p) + +prop_handshake_session_resumption_ems :: PropertyM IO () +prop_handshake_session_resumption_ems = do + sessionRefs <- run twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + plainParams <- pick arbitraryPairParams + ems <- pick (arbitraryEMSMode `suchThat` compatible) + let params = setEMSMode ems $ + setPairParamsSessionManagers sessionManagers plainParams + + runTLSPipeSimple params + + -- and resume + sessionParams <- run $ readClientSessionRef sessionRefs + assert (isJust sessionParams) + ems2 <- pick (arbitraryEMSMode `suchThat` compatible) + let params2 = setEMSMode ems2 $ + setPairParamsSessionResuming (fromJust sessionParams) params + + let version = getConnectVersion params2 + emsVersion = version >= TLS10 && version <= TLS12 + + if emsVersion && use ems && not (use ems2) + then runTLSInitFailure params2 + else do + runTLSPipeSimple params2 + sessionParams2 <- run $ readClientSessionRef sessionRefs + let sameSession = sessionParams == sessionParams2 + sameUse = use ems == use ems2 + when emsVersion $ assert (sameSession == sameUse) + where + compatible (NoEMS, RequireEMS) = False + compatible (RequireEMS, NoEMS) = False + compatible _ = True + + use (NoEMS, _) = False + use (_, NoEMS) = False + use _ = True + prop_handshake_alpn :: PropertyM IO () prop_handshake_alpn = do (clientParam,serverParam) <- pick arbitraryPairParams @@ -766,12 +814,17 @@ prop_handshake_sni :: PropertyM IO () prop_handshake_sni = do + ref <- run $ newIORef Nothing (clientParam,serverParam) <- pick arbitraryPairParams let clientParam' = clientParam { clientServerIdentification = (serverName, "") - , clientUseServerNameIndication = True - } - params' = (clientParam',serverParam) + } + serverParam' = serverParam { serverHooks = (serverHooks serverParam) + { onServerNameIndication = onSNI ref } + } + params' = (clientParam',serverParam') runTLSPipe params' tlsServer tlsClient + receivedName <- run $ readIORef ref + Just (Just serverName) `assertEq` receivedName where tlsServer ctx queue = do handshake ctx sni <- getClientSNI ctx @@ -781,9 +834,13 @@ bye ctx tlsClient queue ctx = do handshake ctx + sni <- getClientSNI ctx + Just serverName `assertEq` sni d <- readChan queue sendData ctx (L.fromChunks [d]) byeBye ctx + onSNI ref name = assertEmptyRef ref >> writeIORef ref (Just name) >> + return (Credentials []) serverName = "haskell.org" prop_handshake_renegotiation :: PropertyM IO () @@ -856,6 +913,10 @@ assertIsLeft (Left _) = return () assertIsLeft (Right b) = error ("got " ++ show b ++ " but was expecting a failure") +assertEmptyRef :: Show a => IORef (Maybe a) -> IO () +assertEmptyRef ref = readIORef ref >>= maybe (return ()) (\a -> + error ("got " ++ show a ++ " but was expecting empty reference")) + recvDataAssert :: Context -> C8.ByteString -> IO () recvDataAssert ctx expected = do got <- recvData ctx @@ -892,6 +953,8 @@ , testProperty "Server key usage" (monadicIO prop_handshake_srv_key_usage) , testProperty "Client authentication" (monadicIO prop_handshake_client_auth) , testProperty "Client key usage" (monadicIO prop_handshake_clt_key_usage) + , testProperty "Extended Master Secret" (monadicIO prop_handshake_ems) + , testProperty "Extended Master Secret (resumption)" (monadicIO prop_handshake_session_resumption_ems) , testProperty "ALPN" (monadicIO prop_handshake_alpn) , testProperty "SNI" (monadicIO prop_handshake_sni) , testProperty "Renegotiation" (monadicIO prop_handshake_renegotiation) diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,5 +1,5 @@ Name: tls -Version: 1.5.2 +Version: 1.5.3 Description: Native Haskell TLS and SSL protocol implementation for server and client. .