diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -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) diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs --- a/Network/TLS/Context/Internal.hs +++ b/Network/TLS/Context/Internal.hs @@ -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. diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -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 diff --git a/Network/TLS/Credentials.hs b/Network/TLS/Credentials.hs --- a/Network/TLS/Credentials.hs +++ b/Network/TLS/Credentials.hs @@ -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 diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -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 diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -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 ] ------------------------------------------------------------ diff --git a/Network/TLS/Extra/Cipher.hs b/Network/TLS/Extra/Cipher.hs --- a/Network/TLS/Extra/Cipher.hs +++ b/Network/TLS/Extra/Cipher.hs @@ -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 diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -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 diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -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 diff --git a/Network/TLS/Handshake/Common13.hs b/Network/TLS/Handshake/Common13.hs --- a/Network/TLS/Handshake/Common13.hs +++ b/Network/TLS/Handshake/Common13.hs @@ -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 diff --git a/Network/TLS/Handshake/Control.hs b/Network/TLS/Handshake/Control.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Control.hs @@ -0,0 +1,49 @@ +-- | +-- Module : Network.TLS.Handshake.Control +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 . +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 diff --git a/Network/TLS/Handshake/Key.hs b/Network/TLS/Handshake/Key.hs --- a/Network/TLS/Handshake/Key.hs +++ b/Network/TLS/Handshake/Key.hs @@ -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 diff --git a/Network/TLS/Handshake/Process.hs b/Network/TLS/Handshake/Process.hs --- a/Network/TLS/Handshake/Process.hs +++ b/Network/TLS/Handshake/Process.hs @@ -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 diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -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 diff --git a/Network/TLS/Handshake/State.hs b/Network/TLS/Handshake/State.hs --- a/Network/TLS/Handshake/State.hs +++ b/Network/TLS/Handshake/State.hs @@ -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 } diff --git a/Network/TLS/Handshake/State13.hs b/Network/TLS/Handshake/State13.hs --- a/Network/TLS/Handshake/State13.hs +++ b/Network/TLS/Handshake/State13.hs @@ -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 } diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -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 :)) diff --git a/Network/TLS/Imports.hs b/Network/TLS/Imports.hs --- a/Network/TLS/Imports.hs +++ b/Network/TLS/Imports.hs @@ -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 diff --git a/Network/TLS/KeySchedule.hs b/Network/TLS/KeySchedule.hs --- a/Network/TLS/KeySchedule.hs +++ b/Network/TLS/KeySchedule.hs @@ -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 diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -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) diff --git a/Network/TLS/QUIC.hs b/Network/TLS/QUIC.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/QUIC.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Network.TLS.QUIC +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -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") diff --git a/Network/TLS/Receiving13.hs b/Network/TLS/Receiving13.hs deleted file mode 100644 --- a/Network/TLS/Receiving13.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - --- | --- Module : Network.TLS.Receiving13 --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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") diff --git a/Network/TLS/Record/Layer.hs b/Network/TLS/Record/Layer.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Layer.hs @@ -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 diff --git a/Network/TLS/Record/Reading.hs b/Network/TLS/Record/Reading.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Reading.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Network.TLS.Record.Reading +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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)) diff --git a/Network/TLS/Record/State.hs b/Network/TLS/Record/State.hs --- a/Network/TLS/Record/State.hs +++ b/Network/TLS/Record/State.hs @@ -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 } diff --git a/Network/TLS/Record/Writing.hs b/Network/TLS/Record/Writing.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Writing.hs @@ -0,0 +1,69 @@ +-- | +-- Module : Network.TLS.Record.Writing +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs --- a/Network/TLS/Sending.hs +++ b/Network/TLS/Sending.hs @@ -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 diff --git a/Network/TLS/Sending13.hs b/Network/TLS/Sending13.hs deleted file mode 100644 --- a/Network/TLS/Sending13.hs +++ /dev/null @@ -1,67 +0,0 @@ --- | --- Module : Network.TLS.Sending13 --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -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) diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -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 diff --git a/Network/TLS/Util.hs b/Network/TLS/Util.hs --- a/Network/TLS/Util.hs +++ b/Network/TLS/Util.hs @@ -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. diff --git a/Tests/Certificate.hs b/Tests/Certificate.hs --- a/Tests/Certificate.hs +++ b/Tests/Certificate.hs @@ -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) diff --git a/Tests/Connection.hs b/Tests/Connection.hs --- a/Tests/Connection.hs +++ b/Tests/Connection.hs @@ -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) diff --git a/Tests/PubKey.hs b/Tests/PubKey.hs --- a/Tests/PubKey.hs +++ b/Tests/PubKey.hs @@ -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 diff --git a/Tests/Tests.hs b/Tests/Tests.hs --- a/Tests/Tests.hs +++ b/Tests/Tests.hs @@ -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) diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -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