tls 1.5.2 → 1.5.3
raw patch · 29 files changed
+986/−519 lines, 29 files
Files
- CHANGELOG.md +25/−0
- Network/TLS.hs +98/−66
- Network/TLS/Context/Internal.hs +21/−12
- Network/TLS/Crypto.hs +9/−0
- Network/TLS/Extension.hs +16/−1
- Network/TLS/Handshake/Client.hs +53/−27
- Network/TLS/Handshake/Common.hs +19/−0
- Network/TLS/Handshake/Common13.hs +2/−1
- Network/TLS/Handshake/Key.hs +27/−5
- Network/TLS/Handshake/Process.hs +21/−23
- Network/TLS/Handshake/Server.hs +55/−33
- Network/TLS/Handshake/Signature.hs +13/−0
- Network/TLS/Handshake/State.hs +22/−1
- Network/TLS/IO.hs +140/−122
- Network/TLS/Packet.hs +14/−13
- Network/TLS/Packet13.hs +1/−5
- Network/TLS/Parameters.hs +148/−24
- Network/TLS/Receiving.hs +15/−9
- Network/TLS/Receiving13.hs +7/−7
- Network/TLS/Record/Disengage.hs +8/−5
- Network/TLS/Sending.hs +55/−54
- Network/TLS/Sending13.hs +28/−40
- Network/TLS/Session.hs +1/−0
- Network/TLS/Struct.hs +1/−1
- Network/TLS/Types.hs +7/−0
- Network/TLS/Util/Serialization.hs +0/−5
- Tests/Connection.hs +68/−16
- Tests/Tests.hs +111/−48
- tls.cabal +1/−1
CHANGELOG.md view
@@ -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)
Network/TLS.hs view
@@ -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
Network/TLS/Context/Internal.hs view
@@ -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
Network/TLS/Crypto.hs view
@@ -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
Network/TLS/Extension.hs view
@@ -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" ------------------------------------------------------------
Network/TLS/Handshake/Client.hs view
@@ -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
Network/TLS/Handshake/Common.hs view
@@ -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
Network/TLS/Handshake/Common13.hs view
@@ -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 = [] } ----------------------------------------------------------------
Network/TLS/Handshake/Key.hs view
@@ -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 ----------------------------------------------------------------
Network/TLS/Handshake/Process.hs view
@@ -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 ()
Network/TLS/Handshake/Server.hs view
@@ -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
Network/TLS/Handshake/Signature.hs view
@@ -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
Network/TLS/Handshake/State.hs view
@@ -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.
Network/TLS/IO.hs view
@@ -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
Network/TLS/Packet.hs view
@@ -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 =
Network/TLS/Packet13.hs view
@@ -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
Network/TLS/Parameters.hs view
@@ -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 -- <https://hackage.haskell.org/package/tls-session-manager tls-session-manager> -- 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 @@ -- <https://hackage.haskell.org/package/x509-system x509-system> -- 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
Network/TLS/Receiving.hs view
@@ -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)
Network/TLS/Receiving13.hs view
@@ -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
Network/TLS/Record/Disengage.hs view
@@ -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
Network/TLS/Sending.hs view
@@ -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
Network/TLS/Sending13.hs view
@@ -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
Network/TLS/Session.hs view
@@ -24,6 +24,7 @@ , sessionInvalidate :: SessionID -> IO () } +-- | The session manager to do nothing. noSessionManager :: SessionManager noSessionManager = SessionManager { sessionResume = \_ -> return Nothing
Network/TLS/Struct.hs view
@@ -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
Network/TLS/Types.hs view
@@ -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
Network/TLS/Util/Serialization.hs view
@@ -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
Tests/Connection.hs view
@@ -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)
Tests/Tests.hs view
@@ -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)
tls.cabal view
@@ -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. .