tls 1.5.4 → 1.5.5
raw patch · 38 files changed
+1432/−565 lines, 38 filesdep ~cryptonite
Dependency ranges changed: cryptonite
Files
- CHANGELOG.md +19/−0
- Network/TLS/Context.hs +20/−1
- Network/TLS/Context/Internal.hs +35/−19
- Network/TLS/Core.hs +13/−7
- Network/TLS/Credentials.hs +1/−3
- Network/TLS/Crypto.hs +106/−25
- Network/TLS/Extension.hs +6/−1
- Network/TLS/Extra/Cipher.hs +142/−60
- Network/TLS/Handshake/Client.hs +54/−32
- Network/TLS/Handshake/Common.hs +12/−1
- Network/TLS/Handshake/Common13.hs +2/−2
- Network/TLS/Handshake/Control.hs +49/−0
- Network/TLS/Handshake/Key.hs +1/−1
- Network/TLS/Handshake/Process.hs +0/−1
- Network/TLS/Handshake/Server.hs +72/−42
- Network/TLS/Handshake/State.hs +3/−1
- Network/TLS/Handshake/State13.hs +38/−10
- Network/TLS/IO.hs +45/−127
- Network/TLS/Imports.hs +9/−20
- Network/TLS/KeySchedule.hs +4/−0
- Network/TLS/Parameters.hs +11/−0
- Network/TLS/QUIC.hs +262/−0
- Network/TLS/Receiving.hs +26/−5
- Network/TLS/Receiving13.hs +0/−51
- Network/TLS/Record/Layer.hs +63/−0
- Network/TLS/Record/Reading.hs +118/−0
- Network/TLS/Record/State.hs +19/−0
- Network/TLS/Record/Writing.hs +69/−0
- Network/TLS/Sending.hs +50/−32
- Network/TLS/Sending13.hs +0/−67
- Network/TLS/Struct.hs +4/−1
- Network/TLS/Types.hs +18/−0
- Network/TLS/Util.hs +9/−7
- Tests/Certificate.hs +19/−0
- Tests/Connection.hs +47/−38
- Tests/PubKey.hs +24/−0
- Tests/Tests.hs +46/−1
- tls.cabal +16/−10
CHANGELOG.md view
@@ -1,3 +1,22 @@+## Version 1.5.5++- QUIC support+ [#419](https://github.com/vincenthz/hs-tls/pull/419)+ [#427](https://github.com/vincenthz/hs-tls/pull/427)+ [#428](https://github.com/vincenthz/hs-tls/pull/428)+ [#430](https://github.com/vincenthz/hs-tls/pull/430)+ [#433](https://github.com/vincenthz/hs-tls/pull/433)+ [#441](https://github.com/vincenthz/hs-tls/pull/441)+- Server ECDSA for P-256+ [#436](https://github.com/vincenthz/hs-tls/pull/436)+- Sort ciphersuites based on hardware-acceleration support+ [#439](https://github.com/vincenthz/hs-tls/pull/439)+- Sending no_application_protocol+ [#440](https://github.com/vincenthz/hs-tls/pull/440)+- Internal improvements+ [#426](https://github.com/vincenthz/hs-tls/pull/426)+ [#431](https://github.com/vincenthz/hs-tls/pull/431)+ ## Version 1.5.4 - Restore interoperability with early Java 6
Network/TLS/Context.hs view
@@ -72,6 +72,9 @@ import Network.TLS.State import Network.TLS.Hooks import Network.TLS.Record.State+import Network.TLS.Record.Layer+import Network.TLS.Record.Reading+import Network.TLS.Record.Writing import Network.TLS.Parameters import Network.TLS.Measurement import Network.TLS.Types (Role(..))@@ -158,11 +161,12 @@ lockRead <- newMVar () lockState <- newMVar () - return Context+ let ctx = Context { ctxConnection = getBackend backend , ctxShared = shared , ctxSupported = supported , ctxState = stvar+ , ctxFragmentSize = Just 16384 , ctxTxState = tx , ctxRxState = rx , ctxHandshake = hs@@ -182,7 +186,22 @@ , ctxPendingActions = as , ctxCertRequests = crs , ctxKeyLogger = debugKeyLogger debug+ , ctxRecordLayer = recordLayer+ , ctxHandshakeSync = HandshakeSync syncNoOp syncNoOp+ , ctxQUICMode = False }++ syncNoOp _ _ = return ()++ recordLayer = RecordLayer+ { recordEncode = encodeRecord ctx+ , recordEncode13 = encodeRecord13 ctx+ , recordSendBytes = sendBytes ctx+ , recordRecv = recvRecord ctx+ , recordRecv13 = recvRecord13 ctx+ }++ return ctx -- | create a new context on an handle. contextNewOnHandle :: (MonadIO m, TLSParams params)
Network/TLS/Context/Internal.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} -- | -- Module : Network.TLS.Context.Internal -- License : BSD-style@@ -35,6 +37,7 @@ , contextClose , contextSend , contextRecv+ , updateRecordLayer , updateMeasure , withMeasure , withReadLock@@ -62,32 +65,36 @@ , addCertRequest13 , getCertRequest13 , decideRecordVersion++ -- * Misc+ , HandshakeSync(..) ) where import Network.TLS.Backend-import Network.TLS.Extension import Network.TLS.Cipher-import Network.TLS.Struct-import Network.TLS.Struct13 import Network.TLS.Compression (Compression)-import Network.TLS.State+import Network.TLS.Extension+import Network.TLS.Handshake.Control import Network.TLS.Handshake.State import Network.TLS.Hooks-import Network.TLS.Record.State-import Network.TLS.Parameters-import Network.TLS.Measurement import Network.TLS.Imports+import Network.TLS.Measurement+import Network.TLS.Parameters+import Network.TLS.Record.Layer+import Network.TLS.Record.State+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Util-import qualified Data.ByteString as B import Control.Concurrent.MVar+import Control.Exception (throwIO) import Control.Monad.State.Strict-import Control.Exception (throwIO, Exception())+import qualified Data.ByteString as B import Data.IORef import Data.Tuple - -- | Information related to a running context, e.g. current cipher data Information = Information { infoVersion :: Version@@ -103,7 +110,7 @@ } deriving (Show,Eq) -- | A TLS Context keep tls specific state, parameters and backend information.-data Context = Context+data Context = forall bytes . Monoid bytes => Context { ctxConnection :: Backend -- ^ return the backend object associated with this context , ctxSupported :: Supported , ctxShared :: Shared@@ -115,6 +122,7 @@ , ctxSSLv2ClientHello :: IORef Bool -- ^ enable the reception of compatibility SSLv2 client hello. -- the flag will be set to false regardless of its initial value -- after the first packet received.+ , ctxFragmentSize :: Maybe Int -- ^ maximum size of plaintext fragments , ctxTxState :: MVar RecordState -- ^ current tx state , ctxRxState :: MVar RecordState -- ^ current rx state , ctxHandshake :: MVar (Maybe HandshakeState) -- ^ optional handshake state@@ -130,8 +138,18 @@ , ctxPendingActions :: IORef [PendingAction] , ctxCertRequests :: IORef [Handshake13] -- ^ pending PHA requests , ctxKeyLogger :: String -> IO ()+ , ctxRecordLayer :: RecordLayer bytes+ , ctxHandshakeSync :: HandshakeSync+ , ctxQUICMode :: Bool } +data HandshakeSync = HandshakeSync (Context -> ClientState -> IO ())+ (Context -> ServerState -> IO ())++updateRecordLayer :: Monoid bytes => RecordLayer bytes -> Context -> Context+updateRecordLayer recordLayer Context{..} =+ Context { ctxRecordLayer = recordLayer, .. }+ data Established = NotEstablished | EarlyDataAllowed Int -- remaining 0-RTT bytes allowed | EarlyDataNotAllowed Int -- remaining 0-RTT packets allowed to skip@@ -145,9 +163,7 @@ -- ^ pending action taking transcript hash up to preceding message updateMeasure :: Context -> (Measurement -> Measurement) -> IO ()-updateMeasure ctx f = do- x <- readIORef (ctxMeasurement ctx)- writeIORef (ctxMeasurement ctx) $! f x+updateMeasure ctx = modifyIORef' (ctxMeasurement ctx) withMeasure :: Context -> (Measurement -> IO a) -> IO a withMeasure ctx f = readIORef (ctxMeasurement ctx) >>= f@@ -174,7 +190,7 @@ 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)+ (cipher,comp) <- readMVar (ctxRxState ctx) <&> \st -> (stCipher st, stCompression st) let accepted = case hstate of Just st -> hstTLS13RTT0Status st == RTT0Accepted Nothing -> False@@ -215,7 +231,7 @@ withLog :: Context -> (Logging -> IO ()) -> IO () withLog ctx f = ctxWithHooks ctx (f . hookLogging) -throwCore :: (MonadIO m, Exception e) => e -> m a+throwCore :: MonadIO m => TLSError -> m a throwCore = liftIO . throwIO failOnEitherError :: MonadIO m => m (Either TLSError a) -> m a@@ -252,9 +268,9 @@ restoreHState ctx = restoreMVar (ctxHandshake ctx) decideRecordVersion :: Context -> IO (Version, Bool)-decideRecordVersion ctx = do- ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx)- hrr <- usingState_ ctx getTLS13HRR+decideRecordVersion ctx = usingState_ ctx $ do+ ver <- getVersionWithDefault (maximum $ supportedVersions $ ctxSupported ctx)+ hrr <- getTLS13HRR -- For TLS 1.3, ver' is only used in ClientHello. -- The record version of the first ClientHello SHOULD be TLS 1.0. -- The record version of the second ClientHello MUST be TLS 1.2.
Network/TLS/Core.hs view
@@ -49,7 +49,7 @@ import Network.TLS.Handshake.State13 import Network.TLS.PostHandshake import Network.TLS.KeySchedule-import Network.TLS.Types (Role(..), HostName)+import Network.TLS.Types (Role(..), HostName, AnyTrafficSecret(..), ApplicationSecret) import Network.TLS.Util (catchException, mapChunks_) import Network.TLS.Extension import qualified Network.TLS.State as S@@ -101,7 +101,8 @@ -- All chunks are protected with the same write lock because we don't -- want to interleave writes from other threads in the middle of our -- possibly large write.- mapM_ (mapChunks_ 16384 sendP) (L.toChunks dataToSend)+ let len = ctxFragmentSize ctx+ mapM_ (mapChunks_ len sendP) (L.toChunks dataToSend) -- | Get data out of Data packet, and automatically renegotiate if a Handshake -- ClientHello is received. An empty result means EOF.@@ -194,7 +195,7 @@ -- session manager). withWriteLock ctx $ do Just resumptionMasterSecret <- usingHState ctx getTLS13ResumptionSecret- (_, usedCipher, _) <- getTxState ctx+ (_, usedCipher, _, _) <- getTxState ctx let choice = makeCipherChoice TLS13 usedCipher psk = derivePSK choice resumptionMasterSecret nonce maxSize = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTNewSessionTicket of@@ -208,6 +209,9 @@ -- putStrLn $ "NewSessionTicket received: lifetime = " ++ show life ++ " sec" loopHandshake13 hs loopHandshake13 (KeyUpdate13 mode:hs) = do+ when (ctxQUICMode ctx) $ do+ let reason = "KeyUpdate is not allowed for QUIC"+ terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason checkAlignment hs established <- ctxEstablished ctx -- Though RFC 8446 Sec 4.6.3 does not clearly says,@@ -293,13 +297,15 @@ recvData' ctx = L.fromChunks . (:[]) <$> recvData ctx keyUpdate :: Context- -> (Context -> IO (Hash,Cipher,C8.ByteString))- -> (Context -> Hash -> Cipher -> C8.ByteString -> IO ())+ -> (Context -> IO (Hash,Cipher,CryptLevel,C8.ByteString))+ -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()) -> IO () keyUpdate ctx getState setState = do- (usedHash, usedCipher, applicationSecretN) <- getState ctx+ (usedHash, usedCipher, level, applicationSecretN) <- getState ctx+ unless (level == CryptApplicationSecret) $+ throwCore $ Error_Protocol ("tried key update without application traffic secret", True, InternalError) let applicationSecretN1 = hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $ hashDigestSize usedHash- setState ctx usedHash usedCipher applicationSecretN1+ setState ctx usedHash usedCipher (AnyTrafficSecret applicationSecretN1) -- | How to update keys in TLS 1.3 data KeyUpdateRequest = OneWay -- ^ Unidirectional key update
Network/TLS/Credentials.hs view
@@ -34,10 +34,8 @@ newtype Credentials = Credentials [Credential] -#if MIN_VERSION_base(4,9,0) instance Semigroup Credentials where Credentials l1 <> Credentials l2 = Credentials (l1 ++ l2)-#endif instance Monoid Credentials where mempty = Credentials []@@ -82,7 +80,7 @@ -> [ByteString] -> ByteString -> Either String Credential-credentialLoadX509ChainFromMemory certData chainData privateData = do+credentialLoadX509ChainFromMemory certData chainData privateData = let x509 = readSignedObjectFromMemory certData chains = map readSignedObjectFromMemory chainData keys = readKeyFileFromMemory privateData
Network/TLS/Crypto.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-} module Network.TLS.Crypto ( HashContext , HashCtx@@ -35,6 +36,7 @@ , kxVerify , kxCanUseRSApkcs1 , kxCanUseRSApss+ , kxSupportedPrivKeyEC , KxError(..) , RSAEncoding(..) ) where@@ -45,18 +47,21 @@ import Crypto.Error import Crypto.Number.Basic (numBits) import Crypto.Random+import qualified Crypto.ECC as ECDSA import qualified Crypto.PubKey.DH as DH import qualified Crypto.PubKey.DSA as DSA-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA_ECC import qualified Crypto.PubKey.ECC.Types as ECC+import qualified Crypto.PubKey.ECDSA as ECDSA import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Crypto.PubKey.RSA.PSS as PSS -import Data.X509 (PrivKey(..), PubKey(..), PubKeyEC(..))-import Data.X509.EC (ecPubKeyCurveName, unserializePoint)+import Data.X509 (PrivKey(..), PubKey(..), PrivKeyEC(..), PubKeyEC(..),+ SerializedPoint(..))+import Data.X509.EC (ecPrivKeyCurveName, ecPubKeyCurveName, unserializePoint) import Network.TLS.Crypto.DH import Network.TLS.Crypto.IES import Network.TLS.Crypto.Types@@ -66,6 +71,8 @@ import Data.ASN1.Encoding import Data.ASN1.BinaryEncoding (DER(..), BER(..)) +import Data.Proxy+ {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey {-# DEPRECATED PrivateKey "use PrivKey" #-}@@ -172,6 +179,7 @@ hashName :: Hash -> String hashName = show +-- | Digest size in bytes. hashDigestSize :: Hash -> Int hashDigestSize MD5 = 16 hashDigestSize SHA1 = 20@@ -260,29 +268,34 @@ Just DSA.Signature { DSA.sign_r = r, DSA.sign_s = s } _ -> Nothing-kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = fromMaybe False $ do- -- get the curve name and the public key data- let pubBS = pubkeyEC_pub key- curveName <- ecPubKeyCurveName key- -- decode the signature- signature <- case decodeASN1' BER sigBS of- Left _ -> Nothing- Right [Start Sequence,IntVal r,IntVal s,End Sequence] -> Just $ ECDSA.Signature r s- Right _ -> Nothing-- -- decode the public key related to the curve- let curve = ECC.getCurveByName curveName- pubkey <- ECDSA.PublicKey curve <$> unserializePoint curve pubBS-- verifyF <- case alg of- MD5 -> Just (ECDSA.verify H.MD5)- SHA1 -> Just (ECDSA.verify H.SHA1)- SHA224 -> Just (ECDSA.verify H.SHA224)- SHA256 -> Just (ECDSA.verify H.SHA256)- SHA384 -> Just (ECDSA.verify H.SHA384)- SHA512 -> Just (ECDSA.verify H.SHA512)+kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS =+ fromMaybe False $ join $+ withPubKeyEC key verifyProxy verifyClassic Nothing+ where+ decodeSignatureASN1 buildRS =+ case decodeASN1' BER sigBS of+ Left _ -> Nothing+ Right [Start Sequence,IntVal r,IntVal s,End Sequence] ->+ Just (buildRS r s)+ Right _ -> Nothing+ verifyProxy prx pubkey = do+ rs <- decodeSignatureASN1 (,)+ signature <- maybeCryptoError $ ECDSA.signatureFromIntegers prx rs+ verifyF <- withAlg (ECDSA.verify prx)+ return $ verifyF pubkey signature msg+ verifyClassic pubkey = do+ signature <- decodeSignatureASN1 ECDSA_ECC.Signature+ verifyF <- withAlg ECDSA_ECC.verify+ return $ verifyF pubkey signature msg+ withAlg :: (forall hash . H.HashAlgorithm hash => hash -> a) -> Maybe a+ withAlg f = case alg of+ MD5 -> Just (f H.MD5)+ SHA1 -> Just (f H.SHA1)+ SHA224 -> Just (f H.SHA224)+ SHA256 -> Just (f H.SHA256)+ SHA384 -> Just (f H.SHA384)+ SHA512 -> Just (f H.SHA512) _ -> Nothing- return $ verifyF pubkey signature msg kxVerify (PubKeyEd25519 key) Ed25519Params msg sigBS = case Ed25519.signature sigBS of CryptoPassed sig -> Ed25519.verify key msg sig@@ -309,6 +322,18 @@ sign <- DSA.sign pk H.SHA1 msg return (Right $ encodeASN1' DER $ dsaSequence sign) where dsaSequence sign = [Start Sequence,IntVal (DSA.sign_r sign),IntVal (DSA.sign_s sign),End Sequence]+kxSign (PrivKeyEC pk) (PubKeyEC _) (ECDSAParams hashAlg) msg =+ case withPrivKeyEC pk doSign (const unsupported) unsupported of+ Nothing -> unsupported+ Just run -> fmap encode <$> run+ where encode (r, s) = encodeASN1' DER+ [ Start Sequence, IntVal r, IntVal s, End Sequence ]+ doSign prx privkey = do+ msig <- ecdsaSignHash prx hashAlg privkey msg+ return $ case msig of+ Nothing -> Left KxUnsupported+ Just sign -> Right (ECDSA.signatureToIntegers prx sign)+ unsupported = return $ Left KxUnsupported kxSign (PrivKeyEd25519 pk) (PubKeyEd25519 pub) Ed25519Params msg = return $ Right $ B.convert $ Ed25519.sign pk pub msg kxSign (PrivKeyEd448 pk) (PubKeyEd448 pub) Ed448Params msg =@@ -348,3 +373,59 @@ noHash :: Maybe H.MD5 noHash = Nothing++ecdsaSignHash :: (MonadRandom m, ECDSA.EllipticCurveECDSA curve)+ => proxy curve -> Hash -> ECDSA.Scalar curve -> ByteString -> m (Maybe (ECDSA.Signature curve))+ecdsaSignHash prx SHA1 pk msg = Just <$> ECDSA.sign prx pk H.SHA1 msg+ecdsaSignHash prx SHA224 pk msg = Just <$> ECDSA.sign prx pk H.SHA224 msg+ecdsaSignHash prx SHA256 pk msg = Just <$> ECDSA.sign prx pk H.SHA256 msg+ecdsaSignHash prx SHA384 pk msg = Just <$> ECDSA.sign prx pk H.SHA384 msg+ecdsaSignHash prx SHA512 pk msg = Just <$> ECDSA.sign prx pk H.SHA512 msg+ecdsaSignHash _ _ _ _ = return Nothing++-- Currently we generate ECDSA signatures in constant time for P256 only.+kxSupportedPrivKeyEC :: PrivKeyEC -> Bool+kxSupportedPrivKeyEC privkey =+ case ecPrivKeyCurveName privkey of+ Just ECC.SEC_p256r1 -> True+ _ -> False++-- Perform a public-key operation with a parameterized ECC implementation when+-- available, otherwise fallback to the classic ECC implementation.+withPubKeyEC :: PubKeyEC+ -> (forall curve . ECDSA.EllipticCurveECDSA curve => Proxy curve -> ECDSA.PublicKey curve -> a)+ -> (ECDSA_ECC.PublicKey -> a)+ -> a+ -> Maybe a+withPubKeyEC pubkey withProxy withClassic whenUnknown =+ case ecPubKeyCurveName pubkey of+ Nothing -> Just whenUnknown+ Just ECC.SEC_p256r1 ->+ maybeCryptoError $ withProxy p256 <$> ECDSA.decodePublic p256 bs+ Just curveName ->+ let curve = ECC.getCurveByName curveName+ pub = unserializePoint curve pt+ in withClassic . ECDSA_ECC.PublicKey curve <$> pub+ where pt@(SerializedPoint bs) = pubkeyEC_pub pubkey++-- Perform a private-key operation with a parameterized ECC implementation when+-- available. Calls for an unsupported curve can be prevented with+-- kxSupportedEcPrivKey.+withPrivKeyEC :: PrivKeyEC+ -> (forall curve . ECDSA.EllipticCurveECDSA curve => Proxy curve -> ECDSA.PrivateKey curve -> a)+ -> (ECC.CurveName -> a)+ -> a+ -> Maybe a+withPrivKeyEC privkey withProxy withUnsupported whenUnknown =+ case ecPrivKeyCurveName privkey of+ Nothing -> Just whenUnknown+ Just ECC.SEC_p256r1 ->+ -- Private key should rather be stored as bytearray and converted+ -- using ECDSA.decodePrivate, unfortunately the data type chosen in+ -- x509 was Integer.+ maybeCryptoError $ withProxy p256 <$> ECDSA.scalarFromInteger p256 d+ Just curveName -> Just $ withUnsupported curveName+ where d = privkeyEC_priv privkey++p256 :: Proxy ECDSA.Curve_P256R1+p256 = Proxy
Network/TLS/Extension.hs view
@@ -32,6 +32,7 @@ , extensionID_PostHandshakeAuth , extensionID_SignatureAlgorithmsCert , extensionID_KeyShare+ , extensionID_QuicTransportParameters -- all implemented extensions , ServerNameType(..) , ServerName(..)@@ -122,7 +123,8 @@ , extensionID_PostHandshakeAuth , extensionID_SignatureAlgorithmsCert , extensionID_KeyShare- , extensionID_SecureRenegotiation :: ExtensionID+ , extensionID_SecureRenegotiation+ , extensionID_QuicTransportParameters :: ExtensionID extensionID_ServerName = 0x0 -- RFC6066 extensionID_MaxFragmentLength = 0x1 -- RFC6066 extensionID_ClientCertificateUrl = 0x2 -- RFC6066@@ -160,6 +162,7 @@ extensionID_PostHandshakeAuth = 0x31 -- TLS 1.3 extensionID_SignatureAlgorithmsCert = 0x32 -- TLS 1.3 extensionID_KeyShare = 0x33 -- TLS 1.3+extensionID_QuicTransportParameters = 0x39 -- QUIC extensionID_SecureRenegotiation = 0xff01 -- RFC5746 ------------------------------------------------------------@@ -200,6 +203,7 @@ , extensionID_SignatureAlgorithmsCert , extensionID_CertificateAuthorities , extensionID_SecureRenegotiation+ , extensionID_QuicTransportParameters ] -- | all supported extensions by the implementation@@ -220,6 +224,7 @@ , extensionID_Cookie , extensionID_PskKeyExchangeModes , extensionID_CertificateAuthorities+ , extensionID_QuicTransportParameters ] ------------------------------------------------------------
Network/TLS/Extra/Cipher.hs view
@@ -9,9 +9,12 @@ ( -- * cipher suite ciphersuite_default+ , ciphersuite_default_det , ciphersuite_all+ , ciphersuite_all_det , ciphersuite_medium , ciphersuite_strong+ , ciphersuite_strong_det , ciphersuite_unencrypted , ciphersuite_dhe_rsa , ciphersuite_dhe_dss@@ -86,6 +89,7 @@ import Crypto.Cipher.Types hiding (Cipher, cipherName) import Crypto.Error import qualified Crypto.MAC.Poly1305 as Poly1305+import Crypto.System.CPU takelast :: Int -> B.ByteString -> B.ByteString takelast i b = B.drop (B.length b - i) b@@ -233,58 +237,111 @@ Poly1305.Auth tag = ChaChaPoly1305.finalize st3 in (output, AuthTag tag)) +data CipherSet+ = SetAead [Cipher] [Cipher] [Cipher] -- gcm, chacha, ccm+ | SetOther [Cipher]++-- Preference between AEAD ciphers having equivalent properties is based on+-- hardware-acceleration support in the cryptonite implementation.+sortOptimized :: [CipherSet] -> [Cipher]+sortOptimized = concatMap f+ where+ f (SetAead gcm chacha ccm)+ | AESNI `notElem` processorOptions = chacha ++ gcm ++ ccm+ | PCLMUL `notElem` processorOptions = ccm ++ chacha ++ gcm+ | otherwise = gcm ++ ccm ++ chacha+ f (SetOther ciphers) = ciphers++-- Order which is deterministic but not optimized for the CPU.+sortDeterministic :: [CipherSet] -> [Cipher]+sortDeterministic = concatMap f+ where+ f (SetAead gcm chacha ccm) = gcm ++ chacha ++ ccm+ f (SetOther ciphers) = ciphers+ -- | All AES and ChaCha20-Poly1305 ciphers supported ordered from strong to -- weak. This choice of ciphersuites should satisfy most normal needs. For -- otherwise strong ciphers we make little distinction between AES128 and -- AES256, and list each but the weakest of the AES128 ciphers ahead of the--- corresponding AES256 ciphers, with the ChaCha20-Poly1305 variant placed just--- after.+-- corresponding AES256 ciphers. ----- The CCM ciphers all come together after the GCM variants due to their--- relative performance cost.+-- AEAD ciphers with equivalent security properties are ordered based on CPU+-- hardware-acceleration support. If this dynamic runtime behavior is not+-- desired, use 'ciphersuite_default_det' instead. ciphersuite_default :: [Cipher]-ciphersuite_default =+ciphersuite_default = sortOptimized sets_default++-- | Same as 'ciphersuite_default', but using deterministic preference not+-- influenced by the CPU.+ciphersuite_default_det :: [Cipher]+ciphersuite_default_det = sortDeterministic sets_default++sets_default :: [CipherSet]+sets_default = [ -- First the PFS + GCM + SHA2 ciphers- cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384- , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256- , cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384- , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256- , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384- , cipher_DHE_RSA_CHACHA20POLY1305_SHA256- , -- Next the PFS + CCM + SHA2 ciphers- cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256- , cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256+ SetAead+ [ cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384 ]+ [ cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 ]+ [ cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256 ]+ , SetAead+ [ cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384 ]+ [ cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 ]+ []+ , SetAead+ [ cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384 ]+ [ cipher_DHE_RSA_CHACHA20POLY1305_SHA256 ]+ [ cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256 ] -- Next the PFS + CBC + SHA2 ciphers- , cipher_ECDHE_ECDSA_AES128CBC_SHA256, cipher_ECDHE_ECDSA_AES256CBC_SHA384- , cipher_ECDHE_RSA_AES128CBC_SHA256, cipher_ECDHE_RSA_AES256CBC_SHA384- , cipher_DHE_RSA_AES128_SHA256, cipher_DHE_RSA_AES256_SHA256+ , SetOther+ [ cipher_ECDHE_ECDSA_AES128CBC_SHA256, cipher_ECDHE_ECDSA_AES256CBC_SHA384+ , cipher_ECDHE_RSA_AES128CBC_SHA256, cipher_ECDHE_RSA_AES256CBC_SHA384+ , cipher_DHE_RSA_AES128_SHA256, cipher_DHE_RSA_AES256_SHA256+ ] -- Next the PFS + CBC + SHA1 ciphers- , cipher_ECDHE_ECDSA_AES128CBC_SHA, cipher_ECDHE_ECDSA_AES256CBC_SHA- , cipher_ECDHE_RSA_AES128CBC_SHA, cipher_ECDHE_RSA_AES256CBC_SHA- , cipher_DHE_RSA_AES128_SHA1, cipher_DHE_RSA_AES256_SHA1- -- Next the non-PFS + GCM + SHA2 ciphers- , cipher_AES128GCM_SHA256, cipher_AES256GCM_SHA384- -- Next the non-PFS + CCM + SHA2 ciphers- , cipher_AES128CCM_SHA256, cipher_AES256CCM_SHA256+ , SetOther+ [ cipher_ECDHE_ECDSA_AES128CBC_SHA, cipher_ECDHE_ECDSA_AES256CBC_SHA+ , cipher_ECDHE_RSA_AES128CBC_SHA, cipher_ECDHE_RSA_AES256CBC_SHA+ , cipher_DHE_RSA_AES128_SHA1, cipher_DHE_RSA_AES256_SHA1+ ]+ -- Next the non-PFS + AEAD + SHA2 ciphers+ , SetAead+ [ cipher_AES128GCM_SHA256, cipher_AES256GCM_SHA384 ]+ []+ [ cipher_AES128CCM_SHA256, cipher_AES256CCM_SHA256 ] -- Next the non-PFS + CBC + SHA2 ciphers- , cipher_AES256_SHA256, cipher_AES128_SHA256+ , SetOther [ cipher_AES256_SHA256, cipher_AES128_SHA256 ] -- Next the non-PFS + CBC + SHA1 ciphers- , cipher_AES256_SHA1, cipher_AES128_SHA1+ , SetOther [ cipher_AES256_SHA1, cipher_AES128_SHA1 ] -- Nobody uses or should use DSS, RC4, 3DES or MD5- -- , cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1- -- , cipher_DHE_DSS_RC4_SHA1, cipher_RC4_128_SHA1, cipher_RC4_128_MD5- -- , cipher_RSA_3DES_EDE_CBC_SHA1+-- , SetOther+-- [ cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1+-- , cipher_DHE_DSS_RC4_SHA1, cipher_RC4_128_SHA1, cipher_RC4_128_MD5+-- , cipher_RSA_3DES_EDE_CBC_SHA1+-- ] -- TLS13 (listed at the end but version is negotiated first)- , cipher_TLS13_AES128GCM_SHA256- , cipher_TLS13_AES256GCM_SHA384- , cipher_TLS13_CHACHA20POLY1305_SHA256- , cipher_TLS13_AES128CCM_SHA256+ , SetAead+ [ cipher_TLS13_AES128GCM_SHA256, cipher_TLS13_AES256GCM_SHA384 ]+ [ cipher_TLS13_CHACHA20POLY1305_SHA256 ]+ [ cipher_TLS13_AES128CCM_SHA256 ] ] {-# WARNING ciphersuite_all "This ciphersuite list contains RC4. Use ciphersuite_strong or ciphersuite_default instead." #-} -- | The default ciphersuites + some not recommended last resort ciphers.+--+-- AEAD ciphers with equivalent security properties are ordered based on CPU+-- hardware-acceleration support. If this dynamic runtime behavior is not+-- desired, use 'ciphersuite_all_det' instead. ciphersuite_all :: [Cipher]-ciphersuite_all = ciphersuite_default +++ciphersuite_all = ciphersuite_default ++ complement_all++{-# WARNING ciphersuite_all_det "This ciphersuite list contains RC4. Use ciphersuite_strong_det or ciphersuite_default_det instead." #-}+-- | Same as 'ciphersuite_all', but using deterministic preference not+-- influenced by the CPU.+ciphersuite_all_det :: [Cipher]+ciphersuite_all_det = ciphersuite_default_det ++ complement_all++complement_all :: [Cipher]+complement_all = [ cipher_ECDHE_ECDSA_AES128CCM8_SHA256, cipher_ECDHE_ECDSA_AES256CCM8_SHA256 , cipher_DHE_RSA_AES128CCM8_SHA256, cipher_DHE_RSA_AES256CCM8_SHA256 , cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1@@ -305,40 +362,65 @@ -- list each AES128 variant after the corresponding AES256 and ChaCha20-Poly1305 -- variants. For weaker constructs, we use just the AES256 form. ----- The CCM ciphers come just after the corresponding GCM ciphers despite their--- relative performance cost.+-- AEAD ciphers with equivalent security properties are ordered based on CPU+-- hardware-acceleration support. If this dynamic runtime behavior is not+-- desired, use 'ciphersuite_strong_det' instead. ciphersuite_strong :: [Cipher]-ciphersuite_strong =+ciphersuite_strong = sortOptimized sets_strong++-- | Same as 'ciphersuite_strong', but using deterministic preference not+-- influenced by the CPU.+ciphersuite_strong_det :: [Cipher]+ciphersuite_strong_det = sortDeterministic sets_strong++sets_strong :: [CipherSet]+sets_strong = [ -- If we have PFS + AEAD + SHA2, then allow AES128, else just 256- cipher_ECDHE_ECDSA_AES256GCM_SHA384, cipher_ECDHE_ECDSA_AES256CCM_SHA256- , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256- , cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES128CCM_SHA256- , cipher_ECDHE_RSA_AES256GCM_SHA384- , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256- , cipher_ECDHE_RSA_AES128GCM_SHA256- , cipher_DHE_RSA_AES256GCM_SHA384, cipher_DHE_RSA_AES256CCM_SHA256- , cipher_DHE_RSA_CHACHA20POLY1305_SHA256- , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES128CCM_SHA256+ SetAead [ cipher_ECDHE_ECDSA_AES256GCM_SHA384 ]+ [ cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 ]+ [ cipher_ECDHE_ECDSA_AES256CCM_SHA256 ]+ , SetAead [ cipher_ECDHE_ECDSA_AES128GCM_SHA256 ]+ []+ [ cipher_ECDHE_ECDSA_AES128CCM_SHA256 ]+ , SetAead [ cipher_ECDHE_RSA_AES256GCM_SHA384 ]+ [ cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 ]+ []+ , SetAead [ cipher_ECDHE_RSA_AES128GCM_SHA256 ]+ []+ []+ , SetAead [ cipher_DHE_RSA_AES256GCM_SHA384 ]+ [ cipher_DHE_RSA_CHACHA20POLY1305_SHA256 ]+ [ cipher_DHE_RSA_AES256CCM_SHA256 ]+ , SetAead [ cipher_DHE_RSA_AES128GCM_SHA256 ]+ []+ [ cipher_DHE_RSA_AES128CCM_SHA256 ] -- No AEAD- , cipher_ECDHE_ECDSA_AES256CBC_SHA384- , cipher_ECDHE_RSA_AES256CBC_SHA384- , cipher_DHE_RSA_AES256_SHA256+ , SetOther+ [ cipher_ECDHE_ECDSA_AES256CBC_SHA384+ , cipher_ECDHE_RSA_AES256CBC_SHA384+ , cipher_DHE_RSA_AES256_SHA256+ ] -- No SHA2- , cipher_ECDHE_ECDSA_AES256CBC_SHA- , cipher_ECDHE_RSA_AES256CBC_SHA- , cipher_DHE_RSA_AES256_SHA1+ , SetOther+ [ cipher_ECDHE_ECDSA_AES256CBC_SHA+ , cipher_ECDHE_RSA_AES256CBC_SHA+ , cipher_DHE_RSA_AES256_SHA1+ ] -- No PFS- , cipher_AES256GCM_SHA384- , cipher_AES256CCM_SHA256+ , SetAead [ cipher_AES256GCM_SHA384 ]+ []+ [ cipher_AES256CCM_SHA256 ] -- Neither PFS nor AEAD, just SHA2- , cipher_AES256_SHA256+ , SetOther [ cipher_AES256_SHA256 ] -- Last resort no PFS, AEAD or SHA2- , cipher_AES256_SHA1+ , SetOther [ cipher_AES256_SHA1 ] -- TLS13 (listed at the end but version is negotiated first)- , cipher_TLS13_AES256GCM_SHA384- , cipher_TLS13_CHACHA20POLY1305_SHA256- , cipher_TLS13_AES128GCM_SHA256- , cipher_TLS13_AES128CCM_SHA256+ , SetAead [ cipher_TLS13_AES256GCM_SHA384 ]+ [ cipher_TLS13_CHACHA20POLY1305_SHA256 ]+ []+ , SetAead [ cipher_TLS13_AES128GCM_SHA256 ]+ []+ [ cipher_TLS13_AES128CCM_SHA256 ] ] -- | DHE-RSA cipher suite. This only includes ciphers bound specifically to
Network/TLS/Handshake/Client.hs view
@@ -37,13 +37,14 @@ import Control.Monad.State.Strict import Control.Exception (SomeException, bracket) +import Network.TLS.Handshake.Certificate import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13-import Network.TLS.Handshake.Process-import Network.TLS.Handshake.Certificate-import Network.TLS.Handshake.Signature+import Network.TLS.Handshake.Control import Network.TLS.Handshake.Key+import Network.TLS.Handshake.Process import Network.TLS.Handshake.Random+import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.Wire@@ -102,7 +103,7 @@ | otherwise -> throwCore $ Error_Protocol ("server-selected group is not supported", True, IllegalParameter) Just _ -> error "handshakeClient': invalid KeyShare value" Nothing -> throwCore $ Error_Protocol ("key exchange not implemented in HRR, expected key_share extension", True, HandshakeFailure)- else do+ else handshakeClient13 cparams ctx groupToSend else do when rtt0 $@@ -237,8 +238,9 @@ Just cookie -> return $ Just $ toExtensionRaw cookie postHandshakeAuthExtension- | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth- | otherwise = return Nothing+ | ctxQUICMode ctx = return Nothing+ | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth+ | otherwise = return Nothing adjustExtentions pskInfo exts ch = case pskInfo of@@ -273,7 +275,7 @@ 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+ if tls13 && paramSession == Session Nothing && not (ctxQUICMode ctx) then do randomSession <- newSession ctx return (crand, randomSession)@@ -291,9 +293,13 @@ let rtt0info = pskInfo >>= get0RTTinfo rtt0 = isJust rtt0info extensions0 <- catMaybes <$> getExtensions pskInfo rtt0- extensions <- adjustExtentions pskInfo extensions0 $ mkClientHello extensions0+ let extensions1 = sharedHelloExtensions (clientShared cparams) ++ extensions0+ extensions <- adjustExtentions pskInfo extensions1 $ mkClientHello extensions1 sendPacket ctx $ Handshake [mkClientHello extensions]- mapM_ send0RTT rtt0info+ mEarlySecInfo <- case rtt0info of+ Nothing -> return Nothing+ Just info -> Just <$> send0RTT info+ unless hrr $ contextSync ctx $ SendClientHello mEarlySecInfo return (rtt0, map (\(ExtensionRaw i _) -> i) extensions) get0RTTinfo (_, sdata, choice, _) = do@@ -308,11 +314,15 @@ -- Client hello is stored in hstHandshakeDigest -- But HandshakeDigestContext is not created yet. earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) False- let ClientTrafficSecret clientEarlySecret = pairClient earlyKey- runPacketFlight ctx $ sendChangeCipherSpec13 ctx- setTxState ctx usedHash usedCipher clientEarlySecret- mapChunks_ 16384 (sendPacket13 ctx . AppData13) earlyData+ let clientEarlySecret = pairClient earlyKey+ unless (ctxQUICMode ctx) $ do+ runPacketFlight ctx $ sendChangeCipherSpec13 ctx+ setTxState ctx usedHash usedCipher clientEarlySecret+ let len = ctxFragmentSize ctx+ mapChunks_ len (sendPacket13 ctx . AppData13) earlyData+ -- We set RTT0Sent even in quicMode usingHState ctx $ setTLS13RTT0Status RTT0Sent+ return $ EarlySecretInfo usedCipher clientEarlySecret recvServerHello clientSession sentExts = runRecvState ctx recvState where recvState = RecvStateNext $ \p ->@@ -326,7 +336,7 @@ else throwAlert a _ -> throwAlert a _ -> unexpected (show p) (Just "handshake")- throwAlert a = usingState_ ctx $ throwError $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure)+ throwAlert a = throwCore $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure) -- | Store the keypair and check that it is compatible with the current protocol -- version and a list of 'CertificateType' values.@@ -852,21 +862,27 @@ handshakeClient13' cparams ctx groupSent choice = do (_, hkey, resuming) <- switchToHandshakeSecret let handshakeSecret = triBase hkey- ClientTrafficSecret clientHandshakeSecret = triClient hkey- ServerTrafficSecret serverHandshakeSecret = triServer hkey- rtt0accepted <- runRecvHandshake13 $ do- accepted <- recvHandshake13 ctx expectEncryptedExtensions+ clientHandshakeSecret = triClient hkey+ serverHandshakeSecret = triServer hkey+ handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret,serverHandshakeSecret)+ contextSync ctx $ RecvServerHello handSecInfo+ (rtt0accepted,eexts) <- runRecvHandshake13 $ do+ accext <- recvHandshake13 ctx expectEncryptedExtensions unless resuming $ recvHandshake13 ctx expectCertRequest recvHandshake13hash ctx $ expectFinished serverHandshakeSecret- return accepted+ return accext hChSf <- transcriptHash ctx- runPacketFlight ctx $ sendChangeCipherSpec13 ctx- when rtt0accepted $ sendPacket13 ctx (Handshake13 [EndOfEarlyData13])+ unless (ctxQUICMode ctx) $+ runPacketFlight ctx $ sendChangeCipherSpec13 ctx+ when (rtt0accepted && not (ctxQUICMode ctx)) $+ sendPacket13 ctx (Handshake13 [EndOfEarlyData13]) setTxState ctx usedHash usedCipher clientHandshakeSecret sendClientFlight13 cparams ctx usedHash clientHandshakeSecret appKey <- switchToApplicationSecret handshakeSecret hChSf let applicationSecret = triBase appKey setResumptionSecret applicationSecret+ let appSecInfo = ApplicationSecretInfo (triClient appKey, triServer appKey)+ contextSync ctx $ SendClientFinished eexts appSecInfo handshakeTerminate13 ctx where usedCipher = cCipher choice@@ -879,15 +895,15 @@ ecdhe <- calcSharedKey (earlySecret, resuming) <- makeEarlySecret handKey <- calculateHandshakeSecret ctx choice earlySecret ecdhe- let ServerTrafficSecret serverHandshakeSecret = triServer handKey+ let serverHandshakeSecret = triServer handKey setRxState ctx usedHash usedCipher serverHandshakeSecret return (usedCipher, handKey, resuming) switchToApplicationSecret handshakeSecret hChSf = do ensureRecvComplete ctx appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf- let ServerTrafficSecret serverApplicationSecret0 = triServer appKey- let ClientTrafficSecret clientApplicationSecret0 = triClient appKey+ let serverApplicationSecret0 = triServer appKey+ let clientApplicationSecret0 = triClient appKey setTxState ctx usedHash usedCipher clientApplicationSecret0 setRxState ctx usedHash usedCipher serverApplicationSecret0 return appKey@@ -929,13 +945,13 @@ Just _ -> do usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Accepted- return True+ return (True,eexts) Nothing -> do usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Rejected- return False+ return (False,eexts) else- return False+ return (False,eexts) expectEncryptedExtensions p = unexpected (show p) (Just "encrypted extensions") expectCertRequest (CertRequest13 token exts) = do@@ -963,7 +979,7 @@ unless ok $ decryptError "cannot verify CertificateVerify" expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify") - expectFinished baseKey hashValue (Finished13 verifyData) =+ expectFinished (ServerTrafficSecret baseKey) hashValue (Finished13 verifyData) = checkFinished usedHash baseKey hashValue verifyData expectFinished _ _ p = unexpected (show p) (Just "server finished") @@ -1020,8 +1036,8 @@ uncertsig (SignatureAlgorithmsCert a) = Just a -} -sendClientFlight13 :: ClientParams -> Context -> Hash -> ByteString -> IO ()-sendClientFlight13 cparams ctx usedHash baseKey = do+sendClientFlight13 :: ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()+sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret baseKey) = do chain <- clientChain cparams ctx runPacketFlight ctx $ do case chain of@@ -1067,8 +1083,14 @@ bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do processHandshake13 ctx h processCertRequest13 ctx certReqCtx exts- (usedHash, _, applicationSecretN) <- getTxState ctx- sendClientFlight13 cparams ctx usedHash applicationSecretN+ (usedHash, _, level, applicationSecretN) <- getTxState ctx+ unless (level == CryptApplicationSecret) $+ throwCore $ Error_Protocol ("unexpected post-handshake authentication request", True, UnexpectedMessage)+ sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret applicationSecretN) postHandshakeAuthClientWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthClientWith", True, UnexpectedMessage)++contextSync :: Context -> ClientState -> IO ()+contextSync ctx ctl = case ctxHandshakeSync ctx of+ HandshakeSync sync _ -> sync ctx ctl
Network/TLS/Handshake/Common.hs view
@@ -21,6 +21,8 @@ , storePrivInfo , isSupportedGroup , checkSupportedGroup+ , errorToAlert+ , errorToAlertMessage ) where import qualified Data.ByteString as B@@ -74,6 +76,14 @@ errorToAlert (Error_Packet_Parsing _) = [(AlertLevel_Fatal, DecodeError)] errorToAlert _ = [(AlertLevel_Fatal, InternalError)] +-- | Return the message that a TLS endpoint can add to its local log for the+-- specified library error.+errorToAlertMessage :: TLSError -> String+errorToAlertMessage (Error_Protocol (msg, _, _)) = msg+errorToAlertMessage (Error_Packet_unexpected msg _) = msg+errorToAlertMessage (Error_Packet_Parsing msg) = msg+errorToAlertMessage e = show e+ unexpected :: MonadIO m => String -> Maybe String -> m a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) @@ -215,7 +225,8 @@ -- | Store the specified keypair. Whether the public key and private key -- actually match is left for the peer to discover. We're not presently -- burning CPU to detect that misconfiguration. We verify only that the--- types of keys match.+-- types of keys match and that it does not include an algorithm that would+-- not be safe. storePrivInfo :: MonadIO m => Context -> CertificateChain
Network/TLS/Handshake/Common13.hs view
@@ -193,7 +193,7 @@ ---------------------------------------------------------------- -sendChangeCipherSpec13 :: Context -> PacketFlightM ()+sendChangeCipherSpec13 :: Monoid b => Context -> PacketFlightM b () sendChangeCipherSpec13 ctx = do sent <- usingHState ctx $ do b <- getCCS13Sent@@ -370,7 +370,7 @@ where found h hs = liftIO (processHandshake13 ctx h) >> put hs >> return h recvLoop = do- epkt <- recvPacket13 ctx+ epkt <- liftIO (recvPacket13 ctx) case epkt of Right (Handshake13 []) -> error "invalid recvPacket13 result" Right (Handshake13 (h:hs)) -> found h hs
+ Network/TLS/Handshake/Control.hs view
@@ -0,0 +1,49 @@+-- |+-- Module : Network.TLS.Handshake.Control+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS.Handshake.Control (+ ClientState(..)+ , ServerState(..)+ , EarlySecretInfo(..)+ , HandshakeSecretInfo(..)+ , ApplicationSecretInfo(..)+ , NegotiatedProtocol+ ) where++import Network.TLS.Cipher+import Network.TLS.Imports+import Network.TLS.Struct+import Network.TLS.Types++----------------------------------------------------------------++-- | ID of the application-level protocol negotiated between client and server.+-- See values listed in the <https://www.iana.org/assignments/tls-extensiontype-values/tls-extensiontype-values.xhtml#alpn-protocol-ids IANA registry>.+type NegotiatedProtocol = ByteString++-- | Handshake information generated for traffic at 0-RTT level.+data EarlySecretInfo = EarlySecretInfo Cipher (ClientTrafficSecret EarlySecret)+ deriving Show++-- | Handshake information generated for traffic at handshake level.+data HandshakeSecretInfo = HandshakeSecretInfo Cipher (TrafficSecrets HandshakeSecret)+ deriving Show++-- | Handshake information generated for traffic at application level.+newtype ApplicationSecretInfo = ApplicationSecretInfo (TrafficSecrets ApplicationSecret)+ deriving Show++----------------------------------------------------------------++data ClientState =+ SendClientHello (Maybe EarlySecretInfo)+ | RecvServerHello HandshakeSecretInfo+ | SendClientFinished [ExtensionRaw] ApplicationSecretInfo++data ServerState =+ SendServerHello [ExtensionRaw] (Maybe EarlySecretInfo) HandshakeSecretInfo+ | SendServerFinished ApplicationSecretInfo
Network/TLS/Handshake/Key.hs view
@@ -123,7 +123,7 @@ case keyPair of (PubKeyRSA _, PrivKeyRSA _) -> True (PubKeyDSA _, PrivKeyDSA _) -> True- --(PubKeyECDSA _, PrivKeyECDSA _) -> True+ (PubKeyEC _, PrivKeyEC k) -> kxSupportedPrivKeyEC k (PubKeyEd25519 _, PrivKeyEd25519 _) -> True (PubKeyEd448 _, PrivKeyEd448 _) -> True _ -> False
Network/TLS/Handshake/Process.hs view
@@ -26,7 +26,6 @@ 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
Network/TLS/Handshake/Server.hs view
@@ -28,6 +28,7 @@ import Network.TLS.IO import Network.TLS.Types import Network.TLS.State+import Network.TLS.Handshake.Control import Network.TLS.Handshake.State import Network.TLS.Handshake.Process import Network.TLS.Handshake.Key@@ -141,11 +142,6 @@ _ -> Nothing maybe (return ()) (usingState_ ctx . setClientSNI) serverName - -- ALPN (Application Layer Protocol Negotiation)- case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTClientHello of- Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos- _ -> return ()- -- TLS version dependent if chosenVersion <= TLS12 then handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession@@ -169,7 +165,7 @@ -> IO () handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession = do extraCreds <- onServerNameIndication (serverHooks sparams) serverName- let allCreds = filterCredentials (isCredentialAllowed chosenVersion) $+ let allCreds = filterCredentials (isCredentialAllowed chosenVersion exts) $ extraCreds `mappend` sharedCredentials (ctxShared ctx) -- If compression is null, commonCompressions should be [0].@@ -368,7 +364,8 @@ -- field of this extension SHALL be empty. Just _ -> return [ ExtensionRaw extensionID_ServerName ""] Nothing -> return []- let extensions = secRengExt ++ emsExt ++ protoExt ++ sniExt+ let extensions = sharedHelloExtensions (serverShared sparams)+ ++ secRengExt ++ emsExt ++ protoExt ++ sniExt usingState_ ctx (setVersion chosenVersion) usingHState ctx $ setServerHelloParameters chosenVersion srand usedCipher usedCompression return $ ServerHello chosenVersion srand session (cipherID usedCipher)@@ -601,9 +598,18 @@ 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+isCredentialAllowed :: Version -> [ExtensionRaw] -> Credential -> Bool+isCredentialAllowed ver exts cred =+ pubkey `versionCompatible` ver && satisfiesEcPredicate p pubkey+ where+ (pubkey, _) = credentialPublicPrivateKeys cred+ -- ECDSA keys are tested against supported elliptic curves until TLS12 but+ -- not after. With TLS13, the curve is linked to the signature algorithm+ -- and client support is tested with signatureCompatible13.+ p | ver < TLS13 = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of+ Nothing -> const True+ Just (NegotiatedGroups sg) -> (`elem` sg)+ | otherwise = const True -- Filters a list of candidate credentials with credentialMatchesHashSignatures. --@@ -712,13 +718,13 @@ (psk, binderInfo, is0RTTvalid) <- choosePSK earlyKey <- calculateEarlySecret ctx choice (Left psk) True let earlySecret = pairBase earlyKey- ClientTrafficSecret clientEarlySecret = pairClient earlyKey+ clientEarlySecret = pairClient earlyKey extensions <- checkBinder earlySecret binderInfo 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) $+ let allCreds = filterCredentials (isCredentialAllowed chosenVersion exts) $ extraCreds `mappend` sharedCredentials (ctxShared ctx) ---------------------------------------------------------------- established <- ctxEstablished ctx@@ -738,32 +744,43 @@ mCredInfo <- if authenticated then return Nothing else decideCredentialInfo allCreds (ecdhe,keyShare) <- makeServerKeyShare ctx clientKeyShare ensureRecvComplete ctx- (clientHandshakeSecret, handshakeSecret) <- runPacketFlight ctx $ do+ (clientHandshakeSecret, handSecret) <- runPacketFlight ctx $ do sendServerHello keyShare srand extensions sendChangeCipherSpec13 ctx ---------------------------------------------------------------- handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe- let ServerTrafficSecret serverHandshakeSecret = triServer handKey- ClientTrafficSecret clientHandshakeSecret = triClient handKey+ let serverHandshakeSecret = triServer handKey+ clientHandshakeSecret = triClient handKey+ handSecret = triBase handKey liftIO $ do- setRxState ctx usedHash usedCipher $ if rtt0OK then clientEarlySecret else clientHandshakeSecret+ if rtt0OK && not (ctxQUICMode ctx)+ then setRxState ctx usedHash usedCipher clientEarlySecret+ else setRxState ctx usedHash usedCipher clientHandshakeSecret setTxState ctx usedHash usedCipher serverHandshakeSecret+ let mEarlySecInfo+ | rtt0OK = Just $ EarlySecretInfo usedCipher clientEarlySecret+ | otherwise = Nothing+ handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret,serverHandshakeSecret)+ contextSync ctx $ SendServerHello exts mEarlySecInfo handSecInfo ---------------------------------------------------------------- sendExtensions rtt0OK protoExt case mCredInfo of Nothing -> return () Just (cred, hashSig) -> sendCertAndVerify cred hashSig- rawFinished <- makeFinished ctx usedHash serverHandshakeSecret+ let ServerTrafficSecret shs = serverHandshakeSecret+ rawFinished <- makeFinished ctx usedHash shs loadPacket13 ctx $ Handshake13 [rawFinished]- return (clientHandshakeSecret, triBase handKey)+ return (clientHandshakeSecret, handSecret) sfSentTime <- getCurrentTimeFromBase ---------------------------------------------------------------- hChSf <- transcriptHash ctx- appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf- let ClientTrafficSecret clientApplicationSecret0 = triClient appKey- ServerTrafficSecret serverApplicationSecret0 = triServer appKey+ appKey <- calculateApplicationSecret ctx choice handSecret hChSf+ let clientApplicationSecret0 = triClient appKey+ serverApplicationSecret0 = triServer appKey applicationSecret = triBase appKey setTxState ctx usedHash usedCipher serverApplicationSecret0+ let appSecInfo = ApplicationSecretInfo (clientApplicationSecret0,serverApplicationSecret0)+ contextSync ctx $ SendServerFinished appSecInfo ---------------------------------------------------------------- if rtt0OK then setEstablished ctx (EarlyDataAllowed rtt0max)@@ -771,7 +788,8 @@ setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding let expectFinished hChBeforeCf (Finished13 verifyData) = liftIO $ do- checkFinished usedHash clientHandshakeSecret hChBeforeCf verifyData+ let ClientTrafficSecret chs = clientHandshakeSecret+ checkFinished usedHash chs hChBeforeCf verifyData handshakeTerminate13 ctx setRxState ctx usedHash usedCipher clientApplicationSecret0 sendNewSessionTicket applicationSecret sfSentTime@@ -787,7 +805,7 @@ unless skip $ recvHandshake13hash ctx (expectCertVerify sparams ctx) recvHandshake13hash ctx expectFinished ensureRecvComplete ctx- else if rtt0OK then+ else if rtt0OK && not (ctxQUICMode ctx) then setPendingActions ctx [PendingAction True expectEndOfEarlyData ,PendingActionHash True expectFinished] else@@ -918,7 +936,12 @@ let earlyDataExtension | rtt0OK = Just $ ExtensionRaw extensionID_EarlyData $ extensionEncode (EarlyDataIndication Nothing) | otherwise = Nothing- let extensions = catMaybes [earlyDataExtension, groupExtension, sniExtension] ++ protoExt+ let extensions = sharedHelloExtensions (serverShared sparams)+ ++ catMaybes [earlyDataExtension+ ,groupExtension+ ,sniExtension+ ]+ ++ protoExt loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions] sendNewSessionTicket applicationSecret sfSentTime = when sendNST $ do@@ -977,8 +1000,8 @@ clientCertVerify sparams ctx certs verif expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13") -helloRetryRequest :: MonadIO m => ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> [Group] -> Session -> m ()-helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession = liftIO $ do+helloRetryRequest :: ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> [Group] -> Session -> IO ()+helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession = do twice <- usingState_ ctx getTLS13HRR when twice $ throwCore $ Error_Protocol ("Hello retry not allowed again", True, HandshakeFailure)@@ -1049,21 +1072,22 @@ cvs = sortOn Down clientVersions applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]-applicationProtocol ctx exts sparams- | clientALPNSuggest = do- suggest <- usingState_ ctx getClientALPNSuggest- case (onALPNClientSuggest $ serverHooks sparams, suggest) of- (Just io, Just protos) -> do- proto <- io protos- usingState_ ctx $ do- setExtensionALPN True- setNegotiatedProtocol proto- return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation- (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ]- (_, _) -> return []- | otherwise = return []- where- clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts+applicationProtocol ctx exts sparams = do+ -- ALPN (Application Layer Protocol Negotiation)+ case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTClientHello of+ Nothing -> return []+ Just (ApplicationLayerProtocolNegotiation protos) -> do+ case onALPNClientSuggest $ serverHooks sparams of+ Just io -> do+ proto <- io protos+ when (proto == "") $+ throwCore $ Error_Protocol ("no supported application protocols", True, NoApplicationProtocol)+ usingState_ ctx $ do+ setExtensionALPN True+ setNegotiatedProtocol proto+ return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation+ (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ]+ _ -> return [] credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm) credentialsFindForSigning13 hss0 creds = loop hss0@@ -1149,7 +1173,9 @@ processHandshake13 ctx certReq processHandshake13 ctx h - (usedHash, _, applicationSecretN) <- getRxState ctx+ (usedHash, _, level, applicationSecretN) <- getRxState ctx+ unless (level == CryptApplicationSecret) $+ throwCore $ Error_Protocol ("tried post-handshake authentication without application traffic secret", True, InternalError) let expectFinished hChBeforeCf (Finished13 verifyData) = do checkFinished usedHash applicationSecretN hChBeforeCf verifyData@@ -1167,3 +1193,7 @@ postHandshakeAuthServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthServerWith", True, UnexpectedMessage)++contextSync :: Context -> ServerState -> IO ()+contextSync ctx ctl = case ctxHandshakeSync ctx of+ HandshakeSync _ sync -> sync ctx ctl
Network/TLS/Handshake/State.hs view
@@ -284,7 +284,7 @@ data HandshakeMode13 = -- | Full handshake is used. FullHandshake- -- | Full handshake is used with hello retry reuest.+ -- | Full handshake is used with hello retry request. | HelloRetryRequest -- | Server authentication is skipped. | PreSharedKey@@ -482,12 +482,14 @@ pendingTx = RecordState { stCryptState = if cc == ClientRole then cstClient else cstServer , stMacState = if cc == ClientRole then msClient else msServer+ , stCryptLevel = CryptMasterSecret , stCipher = Just cipher , stCompression = hstPendingCompression hst } pendingRx = RecordState { stCryptState = if cc == ClientRole then cstServer else cstClient , stMacState = if cc == ClientRole then msServer else msClient+ , stCryptLevel = CryptMasterSecret , stCipher = Just cipher , stCompression = hstPendingCompression hst }
Network/TLS/Handshake/State13.hs view
@@ -8,7 +8,12 @@ -- Portability : unknown -- module Network.TLS.Handshake.State13- ( getTxState+ ( CryptLevel ( CryptEarlySecret+ , CryptHandshakeSecret+ , CryptApplicationSecret+ )+ , TrafficSecret+ , getTxState , getRxState , setTxState , setRxState@@ -35,34 +40,56 @@ import Network.TLS.Record.State import Network.TLS.Struct import Network.TLS.Imports+import Network.TLS.Types import Network.TLS.Util -getTxState :: Context -> IO (Hash, Cipher, ByteString)+getTxState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString) getTxState ctx = getXState ctx ctxTxState -getRxState :: Context -> IO (Hash, Cipher, ByteString)+getRxState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString) getRxState ctx = getXState ctx ctxRxState getXState :: Context -> (Context -> MVar RecordState)- -> IO (Hash, Cipher, ByteString)+ -> IO (Hash, Cipher, CryptLevel, ByteString) getXState ctx func = do tx <- readMVar (func ctx) let Just usedCipher = stCipher tx usedHash = cipherHash usedCipher+ level = stCryptLevel tx secret = cstMacSecret $ stCryptState tx- return (usedHash, usedCipher, secret)+ return (usedHash, usedCipher, level, secret) -setTxState :: Context -> Hash -> Cipher -> ByteString -> IO ()+class TrafficSecret ty where+ fromTrafficSecret :: ty -> (CryptLevel, ByteString)++instance HasCryptLevel a => TrafficSecret (AnyTrafficSecret a) where+ fromTrafficSecret prx@(AnyTrafficSecret s) = (getCryptLevel prx, s)++instance HasCryptLevel a => TrafficSecret (ClientTrafficSecret a) where+ fromTrafficSecret prx@(ClientTrafficSecret s) = (getCryptLevel prx, s)++instance HasCryptLevel a => TrafficSecret (ServerTrafficSecret a) where+ fromTrafficSecret prx@(ServerTrafficSecret s) = (getCryptLevel prx, s)++setTxState :: TrafficSecret ty => Context -> Hash -> Cipher -> ty -> IO () setTxState = setXState ctxTxState BulkEncrypt -setRxState :: Context -> Hash -> Cipher -> ByteString -> IO ()+setRxState :: TrafficSecret ty => Context -> Hash -> Cipher -> ty -> IO () setRxState = setXState ctxRxState BulkDecrypt -setXState :: (Context -> MVar RecordState) -> BulkDirection- -> Context -> Hash -> Cipher -> ByteString+setXState :: TrafficSecret ty+ => (Context -> MVar RecordState) -> BulkDirection+ -> Context -> Hash -> Cipher -> ty -> IO ()-setXState func encOrDec ctx h cipher secret =+setXState func encOrDec ctx h cipher ts =+ let (lvl, secret) = fromTrafficSecret ts+ in setXState' func encOrDec ctx h cipher lvl secret++setXState' :: (Context -> MVar RecordState) -> BulkDirection+ -> Context -> Hash -> Cipher -> CryptLevel -> ByteString+ -> IO ()+setXState' func encOrDec ctx h cipher lvl secret = modifyMVar_ (func ctx) (\_ -> return rt) where bulk = cipherBulk cipher@@ -78,6 +105,7 @@ rt = RecordState { stCryptState = cst , stMacState = MacState { msSequence = 0 }+ , stCryptLevel = lvl , stCipher = Just cipher , stCompression = nullCompression }
Network/TLS/IO.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-} -- | -- Module : Network.TLS.IO -- License : BSD-style@@ -29,15 +29,12 @@ import System.IO.Error (mkIOError, eofErrorType) import Network.TLS.Context.Internal-import Network.TLS.ErrT import Network.TLS.Hooks import Network.TLS.Imports-import Network.TLS.Packet import Network.TLS.Receiving-import Network.TLS.Receiving13 import Network.TLS.Record+import Network.TLS.Record.Layer import Network.TLS.Sending-import Network.TLS.Sending13 import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13@@ -45,67 +42,47 @@ ---------------------------------------------------------------- -- | Send one packet to the context-sendPacket :: MonadIO m => Context -> Packet -> m ()-sendPacket ctx pkt = do+sendPacket :: Context -> Packet -> IO ()+sendPacket ctx@Context{ctxRecordLayer = recordLayer} 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+ withEmptyPacket <- readIORef $ ctxNeedEmptyPacket ctx when withEmptyPacket $- writePacketBytes ctx (AppData B.empty) >>= sendBytes ctx+ writePacketBytes ctx recordLayer (AppData B.empty) >>=+ recordSendBytes recordLayer - writePacketBytes ctx pkt >>= sendBytes ctx+ writePacketBytes ctx recordLayer pkt >>= recordSendBytes recordLayer 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+writePacketBytes :: Monoid bytes+ => Context -> RecordLayer bytes -> Packet -> IO bytes+writePacketBytes ctx recordLayer pkt = do+ withLog ctx $ \logging -> loggingPacketSent logging (show pkt)+ edataToSend <- encodePacket ctx recordLayer pkt either throwCore return edataToSend ---------------------------------------------------------------- -sendPacket13 :: MonadIO m => Context -> Packet13 -> m ()-sendPacket13 ctx pkt = writePacketBytes13 ctx pkt >>= sendBytes ctx+sendPacket13 :: Context -> Packet13 -> IO ()+sendPacket13 ctx@Context{ctxRecordLayer = recordLayer} pkt =+ writePacketBytes13 ctx recordLayer pkt >>= recordSendBytes recordLayer -writePacketBytes13 :: MonadIO m => Context -> Packet13 -> m ByteString-writePacketBytes13 ctx pkt = do- edataToSend <- liftIO $ do- withLog ctx $ \logging -> loggingPacketSent logging (show pkt)- encodePacket13 ctx pkt+writePacketBytes13 :: Monoid bytes+ => Context -> RecordLayer bytes -> Packet13 -> IO bytes+writePacketBytes13 ctx recordLayer pkt = do+ withLog ctx $ \logging -> loggingPacketSent logging (show pkt)+ edataToSend <- encodePacket13 ctx recordLayer 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 <- 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)------------------------------------------------------------------ -- | 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-recvPacket :: MonadIO m => Context -> m (Either TLSError Packet)-recvPacket ctx = liftIO $ do+recvPacket :: Context -> IO (Either TLSError Packet)+recvPacket ctx@Context{ctxRecordLayer = recordLayer} = do compatSSLv2 <- ctxHasSSLv2ClientHello ctx hrr <- usingState_ ctx getTLS13HRR -- When a client sends 0-RTT data to a server which rejects and sends a HRR,@@ -113,7 +90,7 @@ -- AppData with maximum size 2^14 + 256. In all other scenarios and record -- types the maximum size is 2^14. let appDataOverhead = if hrr then 256 else 0- erecord <- recvRecord compatSSLv2 appDataOverhead ctx+ erecord <- recordRecv recordLayer compatSSLv2 appDataOverhead case erecord of Left err -> return $ Left err Right record ->@@ -137,44 +114,6 @@ when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx return pkt --- | 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)-- where recvLengthE = either (return . Left) recvLength-- 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)-- 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- isCCS :: Record a -> Bool isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True isCCS _ = False@@ -185,9 +124,9 @@ ---------------------------------------------------------------- -recvPacket13 :: MonadIO m => Context -> m (Either TLSError Packet13)-recvPacket13 ctx = liftIO $ do- erecord <- recvRecord13 ctx+recvPacket13 :: Context -> IO (Either TLSError Packet13)+recvPacket13 ctx@Context{ctxRecordLayer = recordLayer} = do+ erecord <- recordRecv13 recordLayer case erecord of Left err@(Error_Protocol (_, True, BadRecordMac)) -> do -- If the server decides to reject RTT0 data but accepts RTT1@@ -216,40 +155,12 @@ _ -> 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@@ -265,23 +176,30 @@ ---------------------------------------------------------------- +type Builder b = [b] -> [b]+ -- | 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 -- immediately, update the context digest and transcript, but actual sending is -- deferred. Packets are sent all at once when the monadic computation ends -- (normal termination but also if interrupted by an exception).-newtype PacketFlightM a = PacketFlightM (ReaderT (IORef [ByteString]) IO a)+newtype PacketFlightM b a = PacketFlightM (ReaderT (RecordLayer b, IORef (Builder b)) IO a) deriving (Functor, Applicative, Monad, MonadFail, MonadIO) -runPacketFlight :: Context -> PacketFlightM a -> IO a-runPacketFlight ctx (PacketFlightM f) = do- ref <- newIORef []- finally (runReaderT f ref) $ do- st <- readIORef ref- unless (null st) $ sendBytes ctx $ B.concat $ reverse st+runPacketFlight :: Context -> (forall b . Monoid b => PacketFlightM b a) -> IO a+runPacketFlight Context{ctxRecordLayer = recordLayer} (PacketFlightM f) = do+ ref <- newIORef id+ runReaderT f (recordLayer, ref) `finally` sendPendingFlight recordLayer ref -loadPacket13 :: Context -> Packet13 -> PacketFlightM ()+sendPendingFlight :: Monoid b => RecordLayer b -> IORef (Builder b) -> IO ()+sendPendingFlight recordLayer ref = do+ build <- readIORef ref+ let bss = build []+ unless (null bss) $ recordSendBytes recordLayer $ mconcat bss++loadPacket13 :: Monoid b => Context -> Packet13 -> PacketFlightM b () loadPacket13 ctx pkt = PacketFlightM $ do- bs <- writePacketBytes13 ctx pkt- ref <- ask- liftIO $ modifyIORef ref (bs :)+ (recordLayer, ref) <- ask+ liftIO $ do+ bs <- writePacketBytes13 ctx recordLayer pkt+ modifyIORef ref (. (bs :))
Network/TLS/Imports.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} -- Char8 -- | -- Module : Network.TLS.Imports@@ -13,7 +12,7 @@ ( -- generic exports ByteString- , module Data.ByteString.Char8 -- instance+ , (<&>) , module Control.Applicative , module Control.Monad #if !MIN_VERSION_base(4,13,0)@@ -22,22 +21,18 @@ , module Data.Bits , module Data.List , module Data.Maybe-#if MIN_VERSION_base(4,9,0) , module Data.Semigroup-#else- , module Data.Monoid-#endif , module Data.Ord , module Data.Word-#if !MIN_VERSION_base(4,8,0)- , sortOn-#endif -- project definition , showBytesHex ) where import Data.ByteString (ByteString)-import Data.ByteString.Char8 ()+import Data.ByteString.Char8 () -- instance+#if MIN_VERSION_base(4,11,0)+import Data.Functor+#endif import Control.Applicative import Control.Monad@@ -47,23 +42,17 @@ import Data.Bits import Data.List import Data.Maybe hiding (fromJust)-#if MIN_VERSION_base(4,9,0) import Data.Semigroup-#else-import Data.Monoid-#endif import Data.Ord import Data.Word import Data.ByteArray.Encoding as B import qualified Prelude as P -#if !MIN_VERSION_base(4,8,0)-import Prelude ((.))--sortOn :: Ord b => (a -> b) -> [a] -> [a]-sortOn f =- map P.snd . sortBy (comparing P.fst) . map (\x -> let y = f x in y `P.seq` (y, x))+#if !MIN_VERSION_base(4,11,0)+(<&>) :: Functor f => f a -> (a -> b) -> f b+(<&>) = P.flip fmap+infixl 1 <&> #endif showBytesHex :: ByteString -> P.String
Network/TLS/KeySchedule.hs view
@@ -22,6 +22,8 @@ ---------------------------------------------------------------- +-- | @HKDF-Extract@ function. Returns the pseudorandom key (PRK) from salt and+-- input keying material (IKM). hkdfExtract :: Hash -> ByteString -> ByteString -> ByteString hkdfExtract SHA1 salt ikm = convert (extract salt ikm :: PRK H.SHA1) hkdfExtract SHA256 salt ikm = convert (extract salt ikm :: PRK H.SHA256)@@ -39,6 +41,8 @@ ---------------------------------------------------------------- +-- | @HKDF-Expand-Label@ function. Returns output keying material of the+-- specified length from the PRK, customized for a TLS label and context. hkdfExpandLabel :: Hash -> ByteString -> ByteString
Network/TLS/Parameters.hs view
@@ -397,6 +397,14 @@ -- -- See the default value of 'ValidationCache'. , sharedValidationCache :: ValidationCache+ -- | Additional extensions to be sent during the Hello sequence.+ --+ -- For a client this is always included in message ClientHello. For a+ -- server, this is sent in messages ServerHello or EncryptedExtensions+ -- based on the TLS version.+ --+ -- Default: @[]@+ , sharedHelloExtensions :: [ExtensionRaw] } instance Show Shared where@@ -407,6 +415,7 @@ , sharedSessionManager = noSessionManager , sharedCAStore = mempty , sharedValidationCache = def+ , sharedHelloExtensions = [] } -- | Group usage callback possible return values.@@ -598,6 +607,8 @@ -- | Allow the server to choose an application layer protocol -- suggested from the client through the ALPN -- (Application Layer Protocol Negotiation) extensions.+ -- If the server supports no protocols that the client advertises+ -- an empty 'ByteString' should be returned. -- -- Default: 'Nothing' , onALPNClientSuggest :: Maybe ([B.ByteString] -> IO B.ByteString)
+ Network/TLS/QUIC.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Network.TLS.QUIC+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Experimental API to run the TLS handshake establishing a QUIC connection.+--+-- On the northbound API:+--+-- * QUIC starts a TLS client or server thread with 'tlsQUICClient' or+-- 'tlsQUICServer'.+--+-- TLS invokes QUIC callbacks to use the QUIC transport+--+-- * TLS uses 'quicSend' and 'quicRecv' to send and receive handshake message+-- fragments.+--+-- * TLS calls 'quicInstallKeys' to provide to QUIC the traffic secrets it+-- should use for encryption/decryption.+--+-- * TLS calls 'quicNotifyExtensions' to notify to QUIC the transport parameters+-- exchanged through the handshake protocol.+--+-- * TLS calls 'quicDone' when the handshake is done.+--+module Network.TLS.QUIC (+ -- * Handshakers+ tlsQUICClient+ , tlsQUICServer+ -- * Callback+ , QUICCallbacks(..)+ , CryptLevel(..)+ , KeyScheduleEvent(..)+ -- * Secrets+ , EarlySecretInfo(..)+ , HandshakeSecretInfo(..)+ , ApplicationSecretInfo(..)+ , EarlySecret+ , HandshakeSecret+ , ApplicationSecret+ , TrafficSecrets+ , ServerTrafficSecret(..)+ , ClientTrafficSecret(..)+ -- * Negotiated parameters+ , NegotiatedProtocol+ , HandshakeMode13(..)+ -- * Extensions+ , ExtensionRaw(..)+ , ExtensionID+ , extensionID_QuicTransportParameters+ -- * Errors+ , errorTLS+ , errorToAlertDescription+ , errorToAlertMessage+ , fromAlertDescription+ , toAlertDescription+ -- * Hash+ , hkdfExpandLabel+ , hkdfExtract+ , hashDigestSize+ -- * Constants+ , quicMaxEarlyDataSize+ -- * Supported+ , defaultSupported+ ) where++import Network.TLS.Backend+import Network.TLS.Context+import Network.TLS.Context.Internal+import Network.TLS.Core+import Network.TLS.Crypto (hashDigestSize)+import Network.TLS.Crypto.Types+import Network.TLS.Extension (extensionID_QuicTransportParameters)+import Network.TLS.Extra.Cipher+import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Control+import Network.TLS.Handshake.State+import Network.TLS.Handshake.State13+import Network.TLS.Imports+import Network.TLS.KeySchedule (hkdfExtract, hkdfExpandLabel)+import Network.TLS.Parameters+import Network.TLS.Record.Layer+import Network.TLS.Record.State+import Network.TLS.Struct+import Network.TLS.Types++import Data.Default.Class++nullBackend :: Backend+nullBackend = Backend {+ backendFlush = return ()+ , backendClose = return ()+ , backendSend = \_ -> return ()+ , backendRecv = \_ -> return ""+ }++-- | Argument given to 'quicInstallKeys' when encryption material is available.+data KeyScheduleEvent+ = InstallEarlyKeys (Maybe EarlySecretInfo)+ -- ^ Key material and parameters for traffic at 0-RTT level+ | InstallHandshakeKeys HandshakeSecretInfo+ -- ^ Key material and parameters for traffic at handshake level+ | InstallApplicationKeys ApplicationSecretInfo+ -- ^ Key material and parameters for traffic at application level++-- | Callbacks implemented by QUIC and to be called by TLS at specific points+-- during the handshake. TLS may invoke them from external threads but calls+-- are not concurrent. Only a single callback function is called at a given+-- point in time.+data QUICCallbacks = QUICCallbacks+ { quicSend :: [(CryptLevel, ByteString)] -> IO ()+ -- ^ Called by TLS so that QUIC sends one or more handshake fragments. The+ -- content transiting on this API is the plaintext of the fragments and+ -- QUIC responsability is to encrypt this payload with the key material+ -- given for the specified level and an appropriate encryption scheme.+ --+ -- The size of the fragments may exceed QUIC datagram limits so QUIC may+ -- break them into smaller fragments.+ --+ -- The handshake protocol sometimes combines content at two levels in a+ -- single flight. The TLS library does its best to provide this in the+ -- same @quicSend@ call and with a multi-valued argument. QUIC can then+ -- decide how to transmit this optimally.+ , quicRecv :: CryptLevel -> IO (Either TLSError ByteString)+ -- ^ Called by TLS to receive from QUIC the next plaintext handshake+ -- fragment. The argument specifies with which encryption level the+ -- fragment should be decrypted.+ --+ -- QUIC may return partial fragments to TLS. TLS will then call+ -- @quicRecv@ again as long as necessary. Note however that fragments+ -- must be returned in the correct sequence, i.e. the order the TLS peer+ -- emitted them.+ --+ -- The function may return an error to TLS if end of stream is reached or+ -- if a protocol error has been received, believing the handshake cannot+ -- proceed any longer. If the TLS handshake protocol cannot recover from+ -- this error, the failure condition will be reported back to QUIC through+ -- the control interface.+ , quicInstallKeys :: Context -> KeyScheduleEvent -> IO ()+ -- ^ Called by TLS when new encryption material is ready to be used in the+ -- handshake. The next 'quicSend' or 'quicRecv' may now use the+ -- associated encryption level (although the previous level is also+ -- possible: directions Send/Recv do not change at the same time).+ , quicNotifyExtensions :: Context -> [ExtensionRaw] -> IO ()+ -- ^ Called by TLS when QUIC-specific extensions have been received from+ -- the peer.+ , quicDone :: Context -> IO ()+ -- ^ Called when 'handshake' is done. 'tlsQUICServer' is+ -- finished after calling this hook. 'tlsQUICClient' calls+ -- 'recvData' after calling this hook to wait for new session+ -- tickets.+ }++getTxLevel :: Context -> IO CryptLevel+getTxLevel ctx = do+ (_, _, level, _) <- getTxState ctx+ return level++getRxLevel :: Context -> IO CryptLevel+getRxLevel ctx = do+ (_, _, level, _) <- getRxState ctx+ return level++newRecordLayer :: Context -> QUICCallbacks+ -> RecordLayer [(CryptLevel, ByteString)]+newRecordLayer ctx callbacks = newTransparentRecordLayer get send recv+ where+ get = getTxLevel ctx+ send = quicSend callbacks+ recv = getRxLevel ctx >>= quicRecv callbacks++-- | Start a TLS handshake thread for a QUIC client. The client will use the+-- specified TLS parameters and call the provided callback functions to send and+-- receive handshake data.+tlsQUICClient :: ClientParams -> QUICCallbacks -> IO ()+tlsQUICClient cparams callbacks = do+ ctx0 <- contextNew nullBackend cparams+ let ctx1 = ctx0+ { ctxHandshakeSync = HandshakeSync sync (\_ _ -> return ())+ , ctxFragmentSize = Nothing+ , ctxQUICMode = True+ }+ rl = newRecordLayer ctx2 callbacks+ ctx2 = updateRecordLayer rl ctx1+ handshake ctx2+ quicDone callbacks ctx2+ void $ recvData ctx2 -- waiting for new session tickets+ where+ sync ctx (SendClientHello mEarlySecInfo) =+ quicInstallKeys callbacks ctx (InstallEarlyKeys mEarlySecInfo)+ sync ctx (RecvServerHello handSecInfo) =+ quicInstallKeys callbacks ctx (InstallHandshakeKeys handSecInfo)+ sync ctx (SendClientFinished exts appSecInfo) = do+ let qexts = filterQTP exts+ when (null qexts) $ do+ throwCore $ Error_Protocol ("QUIC transport parameters are mssing", True, MissingExtension)+ quicNotifyExtensions callbacks ctx qexts+ quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo)++-- | Start a TLS handshake thread for a QUIC server. The server will use the+-- specified TLS parameters and call the provided callback functions to send and+-- receive handshake data.+tlsQUICServer :: ServerParams -> QUICCallbacks -> IO ()+tlsQUICServer sparams callbacks = do+ ctx0 <- contextNew nullBackend sparams+ let ctx1 = ctx0+ { ctxHandshakeSync = HandshakeSync (\_ _ -> return ()) sync+ , ctxFragmentSize = Nothing+ , ctxQUICMode = True+ }+ rl = newRecordLayer ctx2 callbacks+ ctx2 = updateRecordLayer rl ctx1+ handshake ctx2+ quicDone callbacks ctx2+ where+ sync ctx (SendServerHello exts mEarlySecInfo handSecInfo) = do+ let qexts = filterQTP exts+ when (null qexts) $ do+ throwCore $ Error_Protocol ("QUIC transport parameters are mssing", True, MissingExtension)+ quicNotifyExtensions callbacks ctx qexts+ quicInstallKeys callbacks ctx (InstallEarlyKeys mEarlySecInfo)+ quicInstallKeys callbacks ctx (InstallHandshakeKeys handSecInfo)+ sync ctx (SendServerFinished appSecInfo) =+ quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo)++filterQTP :: [ExtensionRaw] -> [ExtensionRaw]+filterQTP = filter (\(ExtensionRaw eid _) -> eid == extensionID_QuicTransportParameters || eid == 0xffa5) -- to be deleted++-- | Can be used by callbacks to signal an unexpected condition. This will then+-- generate an "internal_error" alert in the TLS stack.+errorTLS :: String -> IO a+errorTLS msg = throwCore $ Error_Protocol (msg, True, InternalError)++-- | Return the alert that a TLS endpoint would send to the peer for the+-- specified library error.+errorToAlertDescription :: TLSError -> AlertDescription+errorToAlertDescription = snd . head . errorToAlert++-- | Encode an alert to the assigned value.+fromAlertDescription :: AlertDescription -> Word8+fromAlertDescription = valOfType++-- | Decode an alert from the assigned value.+toAlertDescription :: Word8 -> Maybe AlertDescription+toAlertDescription = valToType++defaultSupported :: Supported+defaultSupported = def+ { supportedVersions = [TLS13]+ , supportedCiphers = [ cipher_TLS13_AES256GCM_SHA384+ , cipher_TLS13_AES128GCM_SHA256+ , cipher_TLS13_AES128CCM_SHA256+ ]+ , supportedGroups = [X25519,X448,P256,P384,P521]+ }++-- | Max early data size for QUIC.+quicMaxEarlyDataSize :: Int+quicMaxEarlyDataSize = 0xffffffff
Network/TLS/Receiving.hs view
@@ -12,7 +12,7 @@ module Network.TLS.Receiving ( processPacket- , decodeRecordM+ , processPacket13 ) where import Network.TLS.Cipher@@ -21,9 +21,11 @@ import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.Packet+import Network.TLS.Packet13 import Network.TLS.Record import Network.TLS.State import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.Util import Network.TLS.Wire @@ -75,7 +77,26 @@ 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)+----------------------------------------------------------------++processPacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13)+processPacket13 _ (Record ProtocolType_ChangeCipherSpec _ _) = return $ Right ChangeCipherSpec13+processPacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment+processPacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment))+processPacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do+ mCont <- gets stHandshakeRecordCont13+ modify (\st -> st { stHandshakeRecordCont13 = Nothing })+ hss <- parseMany mCont (fragmentGetBytes fragment)+ return $ Handshake13 hss+ where parseMany mCont bs =+ case fromMaybe decodeHandshakeRecord13 mCont bs of+ GotError err -> throwError err+ GotPartial cont -> modify (\st -> st { stHandshakeRecordCont13 = Just cont }) >> return []+ GotSuccess (ty,content) ->+ either throwError (return . (:[])) $ decodeHandshake13 ty content+ GotSuccessRemaining (ty,content) left ->+ case decodeHandshake13 ty content of+ Left err -> throwError err+ Right hh -> (hh:) <$> parseMany Nothing left+processPacket13 _ (Record ProtocolType_DeprecatedHandshake _ _) =+ return (Left $ Error_Packet "deprecated handshake packet 1.3")
− Network/TLS/Receiving13.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}---- |--- Module : Network.TLS.Receiving13--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ the Receiving module contains calls related to unmarshalling packets according--- to the TLS state----module Network.TLS.Receiving13- ( processPacket13- ) where--import Network.TLS.Context.Internal-import Network.TLS.ErrT-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Packet13-import Network.TLS.Record.Types-import Network.TLS.State-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Util-import Network.TLS.Wire--import Control.Monad.State--processPacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13)-processPacket13 _ (Record ProtocolType_ChangeCipherSpec _ _) = return $ Right ChangeCipherSpec13-processPacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment-processPacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment))-processPacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do- mCont <- gets stHandshakeRecordCont13- modify (\st -> st { stHandshakeRecordCont13 = Nothing })- hss <- parseMany mCont (fragmentGetBytes fragment)- return $ Handshake13 hss- where parseMany mCont bs =- case fromMaybe decodeHandshakeRecord13 mCont bs of- GotError err -> throwError err- GotPartial cont -> modify (\st -> st { stHandshakeRecordCont13 = Just cont }) >> return []- GotSuccess (ty,content) ->- either throwError (return . (:[])) $ decodeHandshake13 ty content- GotSuccessRemaining (ty,content) left ->- case decodeHandshake13 ty content of- Left err -> throwError err- Right hh -> (hh:) <$> parseMany Nothing left-processPacket13 _ (Record ProtocolType_DeprecatedHandshake _ _) =- return (Left $ Error_Packet "deprecated handshake packet 1.3")
+ Network/TLS/Record/Layer.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.TLS.Record.Layer (+ RecordLayer(..)+ , newTransparentRecordLayer+ ) where++import Network.TLS.Imports+import Network.TLS.Record+import Network.TLS.Struct++import qualified Data.ByteString as B++data RecordLayer bytes = RecordLayer {+ -- Writing.hs+ recordEncode :: Record Plaintext -> IO (Either TLSError bytes)+ , recordEncode13 :: Record Plaintext -> IO (Either TLSError bytes)+ , recordSendBytes :: bytes -> IO ()++ -- Reading.hs+ , recordRecv :: Bool -> Int -> IO (Either TLSError (Record Plaintext))+ , recordRecv13 :: IO (Either TLSError (Record Plaintext))+ }++newTransparentRecordLayer :: Eq ann+ => IO ann -> ([(ann, ByteString)] -> IO ())+ -> IO (Either TLSError ByteString)+ -> RecordLayer [(ann, ByteString)]+newTransparentRecordLayer get send recv = RecordLayer {+ recordEncode = transparentEncodeRecord get+ , recordEncode13 = transparentEncodeRecord get+ , recordSendBytes = transparentSendBytes send+ , recordRecv = \_ _ -> transparentRecvRecord recv+ , recordRecv13 = transparentRecvRecord recv+ }++transparentEncodeRecord :: IO ann -> Record Plaintext -> IO (Either TLSError [(ann, ByteString)])+transparentEncodeRecord _ (Record ProtocolType_ChangeCipherSpec _ _) =+ return $ Right []+transparentEncodeRecord _ (Record ProtocolType_Alert _ _) =+ -- all alerts are silent and must be transported externally based on+ -- TLS exceptions raised by the library+ return $ Right []+transparentEncodeRecord get (Record _ _ frag) =+ get >>= \a -> return $ Right [(a, fragmentGetBytes frag)]++transparentSendBytes :: Eq ann => ([(ann, ByteString)] -> IO ()) -> [(ann, ByteString)] -> IO ()+transparentSendBytes send input = send+ [ (a, bs) | (a, frgs) <- compress input+ , let bs = B.concat frgs+ , not (B.null bs)+ ]++transparentRecvRecord :: IO (Either TLSError ByteString)+ -> IO (Either TLSError (Record Plaintext))+transparentRecvRecord recv =+ fmap (Record ProtocolType_Handshake TLS12 . fragmentPlaintext) <$> recv++compress :: Eq ann => [(ann, val)] -> [(ann, [val])]+compress [] = []+compress ((a,v):xs) =+ let (ys, zs) = span ((== a) . fst) xs+ in (a, v : map snd ys) : compress zs
+ Network/TLS/Record/Reading.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE CPP #-}+-- |+-- Module : Network.TLS.Record.Reading+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- TLS record layer in Rx direction+--+module Network.TLS.Record.Reading+ ( recvRecord+ , recvRecord13+ ) where++import Control.Monad.Reader+import qualified Data.ByteString as B++import Network.TLS.Context.Internal+import Network.TLS.ErrT+import Network.TLS.Hooks+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record+import Network.TLS.Struct++----------------------------------------------------------------++exceeds :: Integral ty => Context -> Int -> ty -> Bool+exceeds ctx overhead actual =+ case ctxFragmentSize ctx of+ Nothing -> False+ Just sz -> fromIntegral actual > sz + overhead++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 <- decodeRecordM header content+ let Record _ _ fragment = r+ when (exceeds ctx overhead $ B.length (fragmentGetBytes fragment)) $+ throwError contentSizeExceeded+ return r+ where overhead = if pt == ProtocolType_AppData then appDataOverhead else 0++decodeRecordM :: Header -> ByteString -> RecordM (Record Plaintext)+decodeRecordM header content = disengageRecord erecord+ where+ erecord = rawToRecord header (fragmentCiphertext content)++contentSizeExceeded :: TLSError+contentSizeExceeded = Error_Protocol ("record content 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 :: Context -- ^ TLS context+ -> Bool -- ^ flag to enable SSLv2 compat ClientHello reception+ -> Int -- ^ number of AppData bytes to accept above normal maximum size+ -> IO (Either TLSError (Record Plaintext))+recvRecord ctx compatSSLv2 appDataOverhead+#ifdef SSLV2_COMPATIBLE+ | compatSSLv2 = readExactBytes ctx 2 >>= either (return . Left) sslv2Header+#endif+ | otherwise = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)++ where recvLengthE = either (return . Left) recvLength++ recvLength header@(Header _ _ readlen)+ | exceeds ctx 2048 readlen = 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)++ 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++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)+ | exceeds ctx 256 readlen = return $ Left maximumSizeExceeded+ | otherwise =+ readExactBytes ctx (fromIntegral readlen) >>=+ either (return . Left) (getRecord ctx 0 header)++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))
Network/TLS/Record/State.hs view
@@ -9,6 +9,8 @@ -- module Network.TLS.Record.State ( CryptState(..)+ , CryptLevel(..)+ , HasCryptLevel(..) , MacState(..) , RecordOptions(..) , RecordState(..)@@ -37,6 +39,7 @@ import Network.TLS.MAC import Network.TLS.Util import Network.TLS.Imports+import Network.TLS.Types import qualified Data.ByteString as B @@ -57,9 +60,24 @@ , recordTLS13 :: Bool -- TLS13 record processing } +-- | TLS encryption level.+data CryptLevel+ = CryptInitial -- ^ Unprotected traffic+ | CryptMasterSecret -- ^ Protected with master secret (TLS < 1.3)+ | CryptEarlySecret -- ^ Protected with early traffic secret (TLS 1.3)+ | CryptHandshakeSecret -- ^ Protected with handshake traffic secret (TLS 1.3)+ | CryptApplicationSecret -- ^ Protected with application traffic secret (TLS 1.3)+ deriving (Eq,Show)++class HasCryptLevel a where getCryptLevel :: proxy a -> CryptLevel+instance HasCryptLevel EarlySecret where getCryptLevel _ = CryptEarlySecret+instance HasCryptLevel HandshakeSecret where getCryptLevel _ = CryptHandshakeSecret+instance HasCryptLevel ApplicationSecret where getCryptLevel _ = CryptApplicationSecret+ data RecordState = RecordState { stCipher :: Maybe Cipher , stCompression :: Compression+ , stCryptLevel :: !CryptLevel , stCryptState :: !CryptState , stMacState :: !MacState } deriving (Show)@@ -109,6 +127,7 @@ newRecordState = RecordState { stCipher = Nothing , stCompression = nullCompression+ , stCryptLevel = CryptInitial , stCryptState = CryptState BulkStateUninitialized B.empty B.empty , stMacState = MacState 0 }
+ Network/TLS/Record/Writing.hs view
@@ -0,0 +1,69 @@+-- |+-- Module : Network.TLS.Record.Writing+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- TLS record layer in Tx direction+--+module Network.TLS.Record.Writing+ ( encodeRecord+ , encodeRecord13+ , sendBytes+ ) where++import Network.TLS.Cap+import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Hooks+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Parameters+import Network.TLS.Record+import Network.TLS.State+import Network.TLS.Struct++import Control.Concurrent.MVar+import Control.Monad.State.Strict+import qualified Data.ByteString as B++encodeRecord :: Context -> Record Plaintext -> IO (Either TLSError ByteString)+encodeRecord ctx = prepareRecord ctx . encodeRecordM++-- 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+prepareRecord :: Context -> RecordM a -> IO (Either TLSError a)+prepareRecord ctx f = do+ ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx)+ txState <- readMVar $ ctxTxState ctx+ let sz = case stCipher txState of+ Nothing -> 0+ Just cipher -> if hasRecordIV $ bulkF $ cipherBulk cipher+ then bulkIVSize $ cipherBulk cipher+ else 0 -- to not generate IV+ if hasExplicitBlockIV ver && sz > 0+ then do newIV <- getStateRNG ctx sz+ runTxState ctx (modify (setRecordIV newIV) >> f)+ else runTxState ctx f++encodeRecordM :: Record Plaintext -> RecordM ByteString+encodeRecordM record = do+ erecord <- engageRecord record+ let (hdr, content) = recordToRaw erecord+ return $ B.concat [ encodeHeader hdr, content ]++----------------------------------------------------------------++encodeRecord13 :: Context -> Record Plaintext -> IO (Either TLSError ByteString)+encodeRecord13 ctx = prepareRecord13 ctx . encodeRecordM++prepareRecord13 :: Context -> RecordM a -> IO (Either TLSError a)+prepareRecord13 = runTxState++----------------------------------------------------------------++sendBytes :: Context -> ByteString -> IO ()+sendBytes ctx dataToSend = do+ withLog ctx $ \logging -> loggingIOSent logging dataToSend+ contextSend ctx dataToSend
Network/TLS/Sending.hs view
@@ -10,20 +10,25 @@ -- module Network.TLS.Sending ( encodePacket- , encodeRecordM+ , encodePacket13 , updateHandshake+ , updateHandshake13 ) where -import Network.TLS.Cap import Network.TLS.Cipher import Network.TLS.Context.Internal+import Network.TLS.Handshake.Random import Network.TLS.Handshake.State+import Network.TLS.Handshake.State13 import Network.TLS.Imports import Network.TLS.Packet+import Network.TLS.Packet13 import Network.TLS.Parameters import Network.TLS.Record+import Network.TLS.Record.Layer import Network.TLS.State import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.Types (Role(..)) import Network.TLS.Util @@ -34,51 +39,28 @@ -- | encodePacket transform a packet into marshalled data related to current state -- and updating state on the go-encodePacket :: Context -> Packet -> IO (Either TLSError ByteString)-encodePacket ctx pkt = do+encodePacket :: Monoid bytes+ => Context -> RecordLayer bytes -> Packet -> IO (Either TLSError bytes)+encodePacket ctx recordLayer 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)+ len = ctxFragmentSize ctx+ records <- map mkRecord <$> packetToFragments ctx len pkt+ bs <- fmap mconcat <$> forEitherM records (recordEncode recordLayer) when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx return bs -- 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 :: Context -> Maybe 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-prepareRecord :: Context -> RecordM a -> IO (Either TLSError a)-prepareRecord ctx f = do- ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx)- txState <- readMVar $ ctxTxState ctx- let sz = case stCipher txState of- Nothing -> 0- Just cipher -> if hasRecordIV $ bulkF $ cipherBulk cipher- then bulkIVSize $ cipherBulk cipher- else 0 -- to not generate IV- if hasExplicitBlockIV ver && sz > 0- then do newIV <- getStateRNG ctx sz- 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)@@ -101,3 +83,39 @@ return encoded where encoded = encodeHandshake hs++----------------------------------------------------------------++encodePacket13 :: Monoid bytes+ => Context -> RecordLayer bytes -> Packet13 -> IO (Either TLSError bytes)+encodePacket13 ctx recordLayer pkt = do+ let pt = contentType pkt+ mkRecord bs = Record pt TLS12 (fragmentPlaintext bs)+ len = ctxFragmentSize ctx+ records <- map mkRecord <$> packetToFragments13 ctx len pkt+ fmap mconcat <$> forEitherM records (recordEncode13 recordLayer)++packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]+packetToFragments13 ctx len (Handshake13 hss) =+ getChunks len . B.concat <$> mapM (updateHandshake13 ctx) hss+packetToFragments13 _ _ (Alert13 a) = return [encodeAlerts a]+packetToFragments13 _ _ (AppData13 x) = return [x]+packetToFragments13 _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec]++updateHandshake13 :: Context -> Handshake13 -> IO ByteString+updateHandshake13 ctx hs+ | isIgnored hs = return encoded+ | otherwise = usingHState ctx $ do+ when (isHRR hs) wrapAsMessageHash13+ updateHandshakeDigest encoded+ addHandshakeMessage encoded+ return encoded+ where+ encoded = encodeHandshake13 hs++ isHRR (ServerHello13 srand _ _ _) = isHelloRetryRequest srand+ isHRR _ = False++ isIgnored NewSessionTicket13{} = True+ isIgnored KeyUpdate13{} = True+ isIgnored _ = False
− Network/TLS/Sending13.hs
@@ -1,67 +0,0 @@--- |--- Module : Network.TLS.Sending13--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ the Sending module contains calls related to marshalling packets according--- to the TLS state----module Network.TLS.Sending13- ( encodePacket13- , updateHandshake13- ) where--import Network.TLS.Context.Internal-import Network.TLS.Handshake.Random-import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13-import Network.TLS.Imports-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--import qualified Data.ByteString as B--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--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 encoded- | otherwise = usingHState ctx $ do- when (isHRR hs) wrapAsMessageHash13- updateHandshakeDigest encoded- addHandshakeMessage encoded- return encoded- where- encoded = encodeHandshake13 hs-- isHRR (ServerHello13 srand _ _ _) = isHelloRetryRequest srand- isHRR _ = False-- isIgnored NewSessionTicket13{} = True- isIgnored KeyUpdate13{} = True- isIgnored _ = False
Network/TLS/Struct.hs view
@@ -113,7 +113,7 @@ -- via the client certificate request callback. -- lastSupportedCertificateType :: CertificateType-lastSupportedCertificateType = CertificateType_DSS_Sign+lastSupportedCertificateType = CertificateType_ECDSA_Sign data HashAlgorithm =@@ -208,8 +208,11 @@ newtype Session = Session (Maybe SessionID) deriving (Show, Eq) type FinishedData = ByteString++-- | Identifier of a TLS extension. type ExtensionID = Word16 +-- | The raw content of a TLS extension. data ExtensionRaw = ExtensionRaw ExtensionID ByteString deriving (Eq)
Network/TLS/Types.hs view
@@ -26,8 +26,10 @@ , ApplicationSecret , ResumptionSecret , BaseSecret(..)+ , AnyTrafficSecret(..) , ClientTrafficSecret(..) , ServerTrafficSecret(..)+ , TrafficSecrets , SecretTriple(..) , SecretPair(..) , MasterSecret(..)@@ -95,13 +97,26 @@ invertRole ClientRole = ServerRole invertRole ServerRole = ClientRole +-- | Phantom type indicating early traffic secret. data EarlySecret++-- | Phantom type indicating handshake traffic secrets. data HandshakeSecret++-- | Phantom type indicating application traffic secrets. data ApplicationSecret+ data ResumptionSecret newtype BaseSecret a = BaseSecret ByteString deriving Show+newtype AnyTrafficSecret a = AnyTrafficSecret ByteString deriving Show++-- | A client traffic secret, typed with a parameter indicating a step in the+-- TLS key schedule. newtype ClientTrafficSecret a = ClientTrafficSecret ByteString deriving Show++-- | A server traffic secret, typed with a parameter indicating a step in the+-- TLS key schedule. newtype ServerTrafficSecret a = ServerTrafficSecret ByteString deriving Show data SecretTriple a = SecretTriple@@ -114,6 +129,9 @@ { pairBase :: BaseSecret a , pairClient :: ClientTrafficSecret a }++-- | Hold both client and server traffic secrets at the same step.+type TrafficSecrets a = (ClientTrafficSecret a, ServerTrafficSecret a) -- Master secret for TLS 1.2 or earlier. newtype MasterSecret = MasterSecret ByteString deriving Show
Network/TLS/Util.hs view
@@ -86,15 +86,17 @@ doTail (Left e) = return (Left e) mapChunks_ :: Monad m- => Int -> (B.ByteString -> m a) -> B.ByteString -> m ()+ => Maybe Int -> (B.ByteString -> m a) -> B.ByteString -> m () mapChunks_ len f = mapM_ f . getChunks len -getChunks :: Int -> B.ByteString -> [B.ByteString]-getChunks len bs- | B.length bs > len =- let (chunk, remain) = B.splitAt len bs- in chunk : getChunks len remain- | otherwise = [bs]+getChunks :: Maybe Int -> B.ByteString -> [B.ByteString]+getChunks Nothing = (: [])+getChunks (Just len) = go+ where+ go bs | B.length bs > len =+ let (chunk, remain) = B.splitAt len bs+ in chunk : go remain+ | otherwise = [bs] -- | An opaque newtype wrapper to prevent from poking inside content that has -- been saved.
Tests/Certificate.hs view
@@ -9,6 +9,8 @@ , arbitraryKeyUsage , simpleCertificate , simpleX509+ , toPubKeyEC+ , toPrivKeyEC ) where import Control.Applicative@@ -16,6 +18,9 @@ import Data.ASN1.OID import Data.X509 import Data.Hourglass+import Crypto.Number.Serialize (i2ospOf_)+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.Types as ECC import qualified Data.ByteString as B import PubKey@@ -125,3 +130,17 @@ getSignatureALG (PubKeyEd25519 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519 getSignatureALG (PubKeyEd448 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448 getSignatureALG pubKey = error $ "getSignatureALG: unsupported public key: " ++ show pubKey++toPubKeyEC :: ECC.CurveName -> ECDSA.PublicKey -> PubKey+toPubKeyEC curveName key =+ let ECC.Point x y = ECDSA.public_q key+ pub = SerializedPoint bs+ bs = B.cons 4 (i2ospOf_ bytes x `B.append` i2ospOf_ bytes y)+ bits = ECC.curveSizeBits (ECC.getCurveByName curveName)+ bytes = (bits + 7) `div` 8+ in PubKeyEC (PubKeyEC_Named curveName pub)++toPrivKeyEC :: ECC.CurveName -> ECDSA.PrivateKey -> PrivKey+toPrivKeyEC curveName key =+ let priv = ECDSA.private_d key+ in PrivKeyEC (PrivKeyEC_Named curveName priv)
Tests/Connection.hs view
@@ -63,14 +63,6 @@ , 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 @@ -80,16 +72,14 @@ arbitraryVersions :: Gen [Version] arbitraryVersions = sublistOf knownVersions +-- for performance reason ecdsa_secp521r1_sha512 is not tested knownHashSignatures :: [HashAndSignatureAlgorithm]-knownHashSignatures = filter nonECDSA availableHashSignatures- where- availableHashSignatures = [(TLS.HashIntrinsic, SignatureRSApssRSAeSHA512)+knownHashSignatures = [(TLS.HashIntrinsic, SignatureRSApssRSAeSHA512) ,(TLS.HashIntrinsic, SignatureRSApssRSAeSHA384) ,(TLS.HashIntrinsic, SignatureRSApssRSAeSHA256) ,(TLS.HashIntrinsic, SignatureEd25519) ,(TLS.HashIntrinsic, SignatureEd448) ,(TLS.HashSHA512, SignatureRSA)- ,(TLS.HashSHA512, SignatureECDSA) ,(TLS.HashSHA384, SignatureRSA) ,(TLS.HashSHA384, SignatureECDSA) ,(TLS.HashSHA256, SignatureRSA)@@ -97,8 +87,6 @@ ,(TLS.HashSHA1, SignatureRSA) ,(TLS.HashSHA1, SignatureDSS) ]- -- arbitraryCredentialsOfEachType cannot generate ECDSA- nonECDSA (_,s) = s /= SignatureECDSA knownHashSignatures13 :: [HashAndSignatureAlgorithm] knownHashSignatures13 = filter compat knownHashSignatures@@ -115,6 +103,12 @@ knownFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096] knownGroups = knownECGroups ++ knownFFGroups +defaultECGroup :: Group+defaultECGroup = P256 -- same as defaultECCurve++otherKnownECGroups :: [Group]+otherKnownECGroups = filter (/= defaultECGroup) knownECGroups+ arbitraryGroups :: Gen [Group] arbitraryGroups = scale (min 5) $ listOf1 $ elements knownGroups @@ -123,9 +117,14 @@ isCredentialDSA _ = False arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)]-arbitraryCredentialsOfEachType = do+arbitraryCredentialsOfEachType = arbitraryCredentialsOfEachType' >>= shuffle++arbitraryCredentialsOfEachType' :: Gen [(CertificateChain, PrivKey)]+arbitraryCredentialsOfEachType' = do let (pubKey, privKey) = getGlobalRSAPair+ curveName = defaultECCurve (dsaPub, dsaPriv) <- arbitraryDSAPair+ (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair (ed448Pub, ed448Priv) <- arbitraryEd448Pair mapM (\(pub, priv) -> do@@ -133,20 +132,29 @@ return (CertificateChain [cert], priv) ) [ (PubKeyRSA pubKey, PrivKeyRSA privKey) , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv)+ , (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv) , (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) ] arbitraryCredentialsOfEachCurve :: Gen [(CertificateChain, PrivKey)]-arbitraryCredentialsOfEachCurve = do+arbitraryCredentialsOfEachCurve = arbitraryCredentialsOfEachCurve' >>= shuffle++arbitraryCredentialsOfEachCurve' :: Gen [(CertificateChain, PrivKey)]+arbitraryCredentialsOfEachCurve' = do+ ecdsaPairs <-+ mapM (\curveName -> do+ (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName+ return (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv)+ ) knownECCurves (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair (ed448Pub, ed448Priv) <- arbitraryEd448Pair mapM (\(pub, priv) -> do cert <- arbitraryX509WithKey (pub, priv) return (CertificateChain [cert], priv)- ) [ (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv)- , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv)- ]+ ) $ [ (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv)+ , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv)+ ] ++ ecdsaPairs dhParamsGroup :: DHParams -> Maybe Group dhParamsGroup params@@ -169,29 +177,32 @@ 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 = elements knownVersions >>= arbitraryPairParamsAt --- pair of groups so that at least one EC and one FF group are in common+-- Pair of groups so that at least the default EC group P256 and one FF group+-- are in common. This makes DHE and ECDHE ciphers always compatible with+-- extension "Supported Elliptic Curves" / "Supported Groups". arbitraryGroupPair :: Gen ([Group], [Group]) arbitraryGroupPair = do- (serverECGroups, clientECGroups) <- arbitraryGroupPairFrom knownECGroups+ (serverECGroups, clientECGroups) <- arbitraryGroupPairWith defaultECGroup otherKnownECGroups (serverFFGroups, clientFFGroups) <- arbitraryGroupPairFrom knownFFGroups serverGroups <- shuffle (serverECGroups ++ serverFFGroups) clientGroups <- shuffle (clientECGroups ++ clientFFGroups) return (clientGroups, serverGroups) where- arbitraryGroupPairFrom list = do- s <- arbitraryGroupsFrom list- c <- arbitraryGroupsFrom list `suchThat` any (`elem` s)- return (c, s)- arbitraryGroupsFrom list = listOf1 $ elements list+ arbitraryGroupPairFrom list = elements list >>= \e ->+ arbitraryGroupPairWith e (filter (/= e) list)+ arbitraryGroupPairWith e es = do+ s <- sublistOf es+ c <- sublistOf es+ return (e : s, e : c) arbitraryPairParams13 :: Gen (ClientParams, ServerParams) arbitraryPairParams13 = arbitraryPairParamsAt TLS13@@ -204,7 +215,7 @@ -- ensure we can test version downgrade. let allowedVersions = [ v | v <- knownVersions, or [ x `elem` serverCiphers &&- cipherAllowedForVersion' v x | x <- clientCiphers ]]+ cipherAllowedForVersion v x | x <- clientCiphers ]] allowedVersionsFiltered = filter (<= connectVersion) allowedVersions -- Server or client is allowed to have versions > connectVersion, but not -- both simultaneously.@@ -283,13 +294,13 @@ arbitraryClientCredential :: Version -> Gen Credential arbitraryClientCredential SSL3 = do -- for SSL3 there is no EC but only RSA/DSA- creds <- arbitraryCredentialsOfEachType- elements (take 2 creds) -- RSA and DSA, but not Ed25519 and Ed448+ creds <- arbitraryCredentialsOfEachType'+ elements (take 2 creds) -- RSA and DSA, but not ECDSA, 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+ creds <- arbitraryCredentialsOfEachType'+ elements (take 3 creds) -- RSA, DSA and ECDSA, but not EdDSA+arbitraryClientCredential _ = arbitraryCredentialsOfEachType' >>= elements arbitraryRSACredentialWithUsage :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey) arbitraryRSACredentialWithUsage usageFlags = do@@ -377,10 +388,8 @@ (cCtx, sCtx) <- newPairContext pipe params withAsync (E.catch (tlsServer sCtx resultQueue)- (printAndRaise "server" (serverSupported $ snd params))) $ \sAsync -> do- withAsync (E.catch (tlsClient startQueue cCtx)- (printAndRaise "client" (clientSupported $ fst params))) $ \cAsync -> do-+ (printAndRaise "server" (serverSupported $ snd params))) $ \sAsync -> withAsync (E.catch (tlsClient startQueue cCtx)+ (printAndRaise "client" (clientSupported $ fst params))) $ \cAsync -> do let readResult = waitBoth cAsync sAsync >> readChan resultQueue cont (writeChan startQueue, readResult)
Tests/PubKey.hs view
@@ -1,10 +1,13 @@ module PubKey ( arbitraryRSAPair , arbitraryDSAPair+ , arbitraryECDSAPair , arbitraryEd25519Pair , arbitraryEd448Pair , globalRSAPair , getGlobalRSAPair+ , knownECCurves+ , defaultECCurve , dhParams512 , dhParams768 , dhParams1024@@ -20,6 +23,9 @@ import Crypto.Random import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.DSA as DSA+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.Prim as ECC+import qualified Crypto.PubKey.ECC.Types as ECC import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 @@ -95,6 +101,24 @@ priv <- choose (1, DSA.params_q dsaParams) let pub = DSA.calculatePublic dsaParams priv return (DSA.PublicKey dsaParams pub, DSA.PrivateKey dsaParams priv)++-- for performance reason P521 is not tested+knownECCurves :: [ECC.CurveName]+knownECCurves = [ ECC.SEC_p256r1+ , ECC.SEC_p384r1+ ]++defaultECCurve :: ECC.CurveName+defaultECCurve = ECC.SEC_p256r1++arbitraryECDSAPair :: ECC.CurveName -> Gen (ECDSA.PublicKey, ECDSA.PrivateKey)+arbitraryECDSAPair curveName = do+ d <- choose (1, n - 1)+ let p = ECC.pointBaseMul curve d+ return (ECDSA.PublicKey curve p, ECDSA.PrivateKey curve d)+ where+ curve = ECC.getCurveByName curveName+ n = ECC.ecc_n . ECC.common_curve $ curve arbitraryEd25519Pair :: Gen (Ed25519.PublicKey, Ed25519.SecretKey) arbitraryEd25519Pair = do
Tests/Tests.hs view
@@ -489,10 +489,16 @@ serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedHashSignatures = serverHashSigs } }- shouldFail = null (clientHashSigs `intersect` serverHashSigs)+ commonHashSigs = clientHashSigs `intersect` serverHashSigs+ shouldFail+ | tls13 = all incompatibleWithDefaultCurve commonHashSigs+ | otherwise = null commonHashSigs if shouldFail then runTLSInitFailure (clientParam',serverParam') else runTLSPipeSimple (clientParam',serverParam')+ where+ incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256+ incompatibleWithDefaultCurve _ = False -- Tests ability to use or ignore client "signature_algorithms" extension when -- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but@@ -653,6 +659,44 @@ then runTLSPipeSimple (clientParam,serverParam') else runTLSInitFailure (clientParam,serverParam') +prop_handshake_ec :: PropertyM IO ()+prop_handshake_ec = do+ let versions = [TLS10, TLS11, TLS12, TLS13]+ ciphers = [ cipher_ECDHE_ECDSA_AES256GCM_SHA384+ , cipher_ECDHE_ECDSA_AES128CBC_SHA+ , cipher_TLS13_AES128GCM_SHA256+ ]+ sigGroups = [P256]+ ecdhGroups = [X25519, X448] -- always enabled, so no ECDHE failure+ hashSignatures = [ (HashSHA256, SignatureECDSA)+ ]+ clientVersion <- pick $ elements versions+ (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers+ ([clientVersion], versions)+ (ciphers, ciphers)+ clientGroups <- pick $ sublistOf sigGroups+ clientHashSignatures <- pick $ sublistOf hashSignatures+ serverHashSignatures <- pick $ sublistOf hashSignatures+ credentials <- pick arbitraryCredentialsOfEachCurve+ let clientParam' = clientParam { clientSupported = (clientSupported clientParam)+ { supportedGroups = clientGroups ++ ecdhGroups+ , supportedHashSignatures = clientHashSignatures+ }+ }+ serverParam' = serverParam { serverSupported = (serverSupported serverParam)+ { supportedGroups = sigGroups ++ ecdhGroups+ , supportedHashSignatures = serverHashSignatures+ }+ , serverShared = (serverShared serverParam)+ { sharedCredentials = Credentials credentials }+ }+ sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures)+ ecdsaDenied = (clientVersion < TLS13 && null clientGroups) ||+ (clientVersion >= TLS12 && SignatureECDSA `notElem` sigAlgs)+ if ecdsaDenied+ then runTLSInitFailure (clientParam',serverParam')+ else runTLSPipeSimple (clientParam',serverParam')+ prop_handshake_client_auth :: PropertyM IO () prop_handshake_client_auth = do (clientParam,serverParam) <- pick arbitraryPairParams@@ -952,6 +996,7 @@ , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures) , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites) , testProperty "Groups" (monadicIO prop_handshake_groups)+ , testProperty "Elliptic curves" (monadicIO prop_handshake_ec) , testProperty "Certificate fallback (ciphers)" (monadicIO prop_handshake_cert_fallback) , testProperty "Certificate fallback (hash and signatures)" (monadicIO prop_handshake_cert_fallback_hs) , testProperty "Server key usage" (monadicIO prop_handshake_srv_key_usage)
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 1.5.4+Version: 1.5.5 Description: Native Haskell TLS and SSL protocol implementation for server and client. .@@ -22,7 +22,7 @@ Build-Type: Simple Category: Network stability: experimental-Cabal-Version: >=1.8+Cabal-Version: >=1.10 Homepage: http://github.com/vincenthz/hs-tls extra-source-files: Tests/*.hs CHANGELOG.md@@ -40,6 +40,7 @@ Default: False Library+ Default-Language: Haskell2010 Build-Depends: base >= 4.9 && < 5 , mtl >= 2 , transformers@@ -48,7 +49,7 @@ , data-default-class -- crypto related , memory >= 0.14.6- , cryptonite >= 0.25+ , cryptonite >= 0.27 -- certificate related , asn1-types >= 0.2.0 , asn1-encoding@@ -70,6 +71,7 @@ Network.TLS.Extra Network.TLS.Extra.Cipher Network.TLS.Extra.FFDHE+ Network.TLS.QUIC other-modules: Network.TLS.Cap Network.TLS.Struct Network.TLS.Struct13@@ -85,14 +87,15 @@ Network.TLS.ErrT Network.TLS.Extension Network.TLS.Handshake+ Network.TLS.Handshake.Certificate+ Network.TLS.Handshake.Client Network.TLS.Handshake.Common Network.TLS.Handshake.Common13- Network.TLS.Handshake.Certificate+ Network.TLS.Handshake.Control Network.TLS.Handshake.Key- Network.TLS.Handshake.Client- Network.TLS.Handshake.Server Network.TLS.Handshake.Process Network.TLS.Handshake.Random+ Network.TLS.Handshake.Server Network.TLS.Handshake.Signature Network.TLS.Handshake.State Network.TLS.Handshake.State13@@ -107,17 +110,18 @@ Network.TLS.Parameters Network.TLS.PostHandshake Network.TLS.Record- Network.TLS.Record.Types- Network.TLS.Record.Engage Network.TLS.Record.Disengage+ Network.TLS.Record.Engage+ Network.TLS.Record.Layer+ Network.TLS.Record.Reading+ Network.TLS.Record.Writing Network.TLS.Record.State+ Network.TLS.Record.Types Network.TLS.RNG Network.TLS.State Network.TLS.Session Network.TLS.Sending- Network.TLS.Sending13 Network.TLS.Receiving- Network.TLS.Receiving13 Network.TLS.Util Network.TLS.Util.ASN1 Network.TLS.Util.Serialization@@ -129,6 +133,7 @@ cpp-options: -DSSLV2_COMPATIBLE Test-Suite test-tls+ Default-Language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: Tests Main-is: Tests.hs@@ -154,6 +159,7 @@ ghc-options: -Wall -fno-warn-unused-imports Benchmark bench-tls+ Default-Language: Haskell2010 hs-source-dirs: Benchmarks Tests Main-Is: Benchmarks.hs type: exitcode-stdio-1.0