tls 2.4.3 → 2.4.4
raw patch · 21 files changed
+439/−83 lines, 21 filesdep ~network-rundep ~ramdep ~zlib
Dependency ranges changed: network-run, ram, zlib
Files
- CHANGELOG.md +13/−0
- Network/TLS/Context.hs +2/−0
- Network/TLS/Context/Internal.hs +36/−5
- Network/TLS/Core.hs +67/−12
- Network/TLS/Error.hs +4/−5
- Network/TLS/Handshake/Certificate.hs +2/−2
- Network/TLS/Handshake/Client/Common.hs +6/−4
- Network/TLS/Handshake/Client/TLS13.hs +2/−2
- Network/TLS/Handshake/Common.hs +5/−5
- Network/TLS/Handshake/Server/ClientHello13.hs +19/−15
- Network/TLS/Handshake/Server/ServerHello13.hs +11/−3
- Network/TLS/Handshake/Server/TLS13.hs +5/−5
- Network/TLS/IO.hs +5/−4
- Network/TLS/Packet13.hs +8/−5
- Network/TLS/Parameters.hs +5/−4
- Network/TLS/Util.hs +1/−2
- test/Certificate.hs +20/−0
- test/EncodeSpec.hs +41/−0
- test/HandshakeSpec.hs +158/−1
- test/Run.hs +23/−5
- tls.cabal +6/−4
CHANGELOG.md view
@@ -1,5 +1,18 @@ # Change log for "tls" +## Version 2.4.4++* Enforce server certificate purpose+ [#534](https://github.com/haskell-tls/hs-tls/pull/534)+* Use dedicated doctest REPL+ [#533](https://github.com/haskell-tls/hs-tls/pull/533)+* Bind early data to ALPN+ [#532](https://github.com/haskell-tls/hs-tls/pull/532)+* Bound certificate decompression+ [#531](https://github.com/haskell-tls/hs-tls/pull/531)+* Fix RecordOverflow race after TLS 1.3 client authentication+ [#530](https://github.com/haskell-tls/hs-tls/pull/530)+ ## Version 2.4.3 * A server checks clientAuth of ExtendedKeyUsage in a client
Network/TLS/Context.hs view
@@ -8,6 +8,7 @@ Context (..), Hooks (..), Established (..),+ PendingRecv (..), RecordLayer (..), ctxEOF, ctxEstablished,@@ -23,6 +24,7 @@ updateMeasure, withMeasure, withReadLock,+ tryWithReadLock, withWriteLock, withStateLock, withRWLock,
Network/TLS/Context/Internal.hs view
@@ -17,6 +17,7 @@ Hooks (..), Limit (..), Established (..),+ PendingRecv (..), PendingRecvAction (..), RecordLayer (..), Locks (..),@@ -36,6 +37,7 @@ updateMeasure, withMeasure, withReadLock,+ tryWithReadLock, withWriteLock, withStateLock, withRWLock,@@ -86,7 +88,7 @@ ) where import Control.Concurrent.MVar-import Control.Exception (throwIO)+import qualified Control.Exception as E import Control.Monad.State.Strict import Data.ByteArray (convert) import qualified Data.ByteArray as BA@@ -203,7 +205,7 @@ , tls13stRecvSF :: Bool -- client , tls13stSentCF :: Bool -- client , tls13stRecvCF :: Bool -- server- , tls13stPendingRecvData :: Maybe ByteString -- client+ , tls13stPendingRecv :: PendingRecv -- client , tls13stPendingSentData :: [ByteString] -> [ByteString] -- client , tls13stRTT :: Millisecond , tls13st0RTT :: Bool -- client@@ -224,7 +226,7 @@ , tls13stRecvSF = False , tls13stSentCF = False , tls13stRecvCF = False- , tls13stPendingRecvData = Nothing+ , tls13stPendingRecv = NoPendingRecv , tls13stPendingSentData = id , tls13stRTT = 0 , tls13st0RTT = False@@ -271,6 +273,15 @@ | Established deriving (Eq, Show) +-- | Outcome of a read that was started on behalf of a caller who is no longer+-- waiting for it, held until the next receive hands it over. Reads cannot be+-- abandoned once started -- see 'Network.TLS.Core.handshake' -- so a reader that+-- outlives its caller leaves its result here instead.+data PendingRecv+ = NoPendingRecv+ | PendingRecvData ByteString+ | PendingRecvError E.SomeException+ data PendingRecvAction = -- | simple pending action. The first 'Bool' is necessity of alignment. PendingRecvAction Bool (Handshake13 -> IO ())@@ -367,7 +378,7 @@ withLog ctx f = ctxWithHooks ctx (f . hookLogging) throwCore :: MonadIO m => TLSError -> m a-throwCore = liftIO . throwIO . Uncontextualized+throwCore = liftIO . E.throwIO . Uncontextualized failOnEitherError :: MonadIO m => m (Either TLSError a) -> m a failOnEitherError f = do@@ -387,7 +398,7 @@ usingHState :: MonadIO m => Context -> HandshakeM a -> m a usingHState ctx f = liftIO $ modifyMVar (ctxHandshakeState ctx) $ \case- Nothing -> liftIO $ throwIO MissingHandshake+ Nothing -> liftIO $ E.throwIO MissingHandshake Just st -> return $ swap (Just <$> runHandshake st f) getHState :: MonadIO m => Context -> m (Maybe HandshakeState)@@ -449,6 +460,26 @@ withReadLock :: Context -> IO a -> IO a withReadLock ctx f = withMVar (lockRead $ ctxLocks ctx) (const f)++-- | Like 'withReadLock', but returns 'Nothing' immediately instead of waiting+-- when another thread already holds the read lock.+--+-- The read lock is what keeps a single thread reading the connection at a time.+-- Records arrive length-prefixed, so two threads reading in parallel would each+-- take a piece of whatever record the other was in the middle of, and neither+-- would end up with a usable message.+--+-- Use this instead of 'withReadLock' when the read is optional and skipping it+-- is better than waiting for the current reader, which may hold the lock for+-- arbitrarily long. 'bye' is the only such caller; see the note there.+tryWithReadLock :: Context -> IO a -> IO (Maybe a)+tryWithReadLock ctx f = E.bracket acquire release $ \mlock -> case mlock of+ Nothing -> return Nothing+ Just _ -> Just <$> f+ where+ lock = lockRead $ ctxLocks ctx+ acquire = tryTakeMVar lock+ release = mapM_ (putMVar lock) withWriteLock :: Context -> IO a -> IO a withWriteLock ctx f = withMVar (lockWrite $ ctxLocks ctx) (const f)
Network/TLS/Core.hs view
@@ -27,6 +27,8 @@ requestCertificate, ) where +import Control.Concurrent (forkIO)+import Control.Concurrent.MVar import qualified Control.Exception as E import Control.Monad.State.Strict import qualified Data.ByteString as B@@ -72,11 +74,39 @@ sentClientCert <- tls13stSentClientCert <$> getTLS13State ctx when (role == ClientRole && tls13 && sentClientCert) $ do rtt <- getRTT ctx- -- This 'timeout' should work.- mdat <- timeout rtt $ recvData13 ctx- case mdat of- Nothing -> return ()- Just dat -> modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Just dat}+ -- We are only willing to wait 'rtt' for the alert, but a receive+ -- must not be abandoned once it has started. Records are read+ -- length-prefixed and the record layer keeps no receive buffer, so+ -- an aborted receive loses the bytes it has already taken off the+ -- transport and leaves the stream positioned inside a record.+ -- Every later read is then misframed, and the connection is dead+ -- with a spurious protocol error.+ --+ -- So the receive runs in its own thread and we stop waiting for it+ -- rather than interrupting it. It holds the read lock, which keeps+ -- it the only reader and makes the next receive wait for it to+ -- finish; its outcome is left in 'tls13stPendingRecv' for that+ -- receive to pick up.+ done <- newEmptyMVar+ void $ forkIO $ withReadLock ctx $ do+ r <- E.try $ recvData13 ctx+ modifyTLS13State ctx $ \st ->+ st+ { tls13stPendingRecv = case r of+ Right dat -> PendingRecvData dat+ Left err -> PendingRecvError err+ }+ putMVar done ()+ arrived <- timeout rtt $ takeMVar done+ -- Still report the authentication failure from 'handshake' itself+ -- whenever it did arrive in time.+ when (isJust arrived) $ do+ pending <- tls13stPendingRecv <$> getTLS13State ctx+ case pending of+ PendingRecvError err -> do+ modifyTLS13State ctx $ \st -> st{tls13stPendingRecv = NoPendingRecv}+ E.throwIO err+ _ -> return () rttFactor :: Int rttFactor = 3@@ -118,7 +148,7 @@ recvNST <- chk unless recvNST $ do rtt <- getRTT ctx- void $ timeout rtt $ recvHS13 ctx chk+ tryRecvHS13 rtt chk else do -- receiving Client Finished let chk = tls13stRecvCF <$> getTLS13State ctx@@ -127,8 +157,28 @@ -- no chance to measure RTT before receiving CF -- fixme: 1sec is good enough? let rtt = 1000000- void $ timeout rtt $ recvHS13 ctx chk+ tryRecvHS13 rtt chk bye_ ctx+ where+ -- Receiving these messages only improves the chances of a later session+ -- resumption, so giving up on them costs nothing important. We give up in+ -- two different situations, for two different reasons.+ --+ -- First, we need the read lock, because only one thread at a time may read+ -- the connection, but we take it only if it happens to be free. Another+ -- thread can be sitting in 'recvData' waiting for data that never arrives,+ -- or the receive that 'handshake' starts can still be running, and either+ -- holds the read lock for as long as it lasts. Waiting for the lock would+ -- therefore hang 'bye', and closing a connection that a reader is stuck on+ -- is exactly what 'bye' is for, so we skip the receive in that case.+ --+ -- Second, if we do get the lock, we wait 'rtt' for the message and then+ -- abandon the receive. Abandoning it can stop the connection part way+ -- through a record, after which nothing can be read from it again -- which+ -- is acceptable only because we are closing the connection here anyway.+ tryRecvHS13 :: Int -> IO Bool -> IO ()+ tryRecvHS13 rtt chk =+ void $ tryWithReadLock ctx $ timeout rtt $ recvHS13 ctx chk bye_ :: MonadIO m => Context -> m () bye_ ctx = liftIO $ do@@ -240,15 +290,20 @@ recvData13 :: Context -> IO ByteString recvData13 ctx = do- mdat <- tls13stPendingRecvData <$> getTLS13State ctx- case mdat of- Nothing -> do+ pending <- tls13stPendingRecv <$> getTLS13State ctx+ case pending of+ NoPendingRecv -> do pkt <- recvPacket13 ctx either (onError (terminate13 ctx)) process pkt- Just dat -> do- modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Nothing}+ PendingRecvData dat -> do+ clearPending return dat+ PendingRecvError err -> do+ clearPending+ E.throwIO err where+ clearPending = modifyTLS13State ctx $ \st -> st{tls13stPendingRecv = NoPendingRecv}+ -- UserCanceled MUST be followed by a CloseNotify. process (Alert13 [(AlertLevel_Warning, UserCanceled)]) = return B.empty process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty
Network/TLS/Error.hs view
@@ -3,8 +3,7 @@ module Network.TLS.Error where -import Control.Exception (Exception (..))-import Data.Typeable+import qualified Control.Exception as E import Network.TLS.Imports @@ -34,7 +33,7 @@ | Error_Packet_unexpected String String | Error_Packet_Parsing String | Error_TCP_Terminate- deriving (Eq, Show, Typeable)+ deriving (Eq, Show) ---------------------------------------------------------------- @@ -61,9 +60,9 @@ -- handshake had occurred. -- Indicates that this library has been used incorrectly. MissingHandshake- deriving (Show, Eq, Typeable)+ deriving (Show, Eq) -instance Exception TLSException+instance E.Exception TLSException ----------------------------------------------------------------
Network/TLS/Handshake/Certificate.hs view
@@ -7,7 +7,7 @@ extractCAname, ) where -import Control.Exception (SomeException)+import qualified Control.Exception as E import Control.Monad (unless) import Control.Monad.State.Strict import Data.X509 (@@ -38,7 +38,7 @@ badCertificate :: MonadIO m => String -> m a badCertificate msg = throwCore $ Error_Protocol msg BadCertificate -rejectOnException :: SomeException -> IO CertificateUsage+rejectOnException :: E.SomeException -> IO CertificateUsage rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e verifyLeafKeyUsage :: MonadIO m => [ExtKeyUsageFlag] -> CertificateChain -> m ()
Network/TLS/Handshake/Client/Common.hs view
@@ -13,9 +13,9 @@ clientSessions, ) where -import Control.Exception (SomeException)+import qualified Control.Exception as E import Control.Monad.State.Strict-import Data.X509 (ExtKeyUsageFlag (..))+import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) import Network.TLS.Cipher import Network.TLS.Context.Internal@@ -38,7 +38,7 @@ ---------------------------------------------------------------- -throwMiscErrorOnException :: String -> SomeException -> IO a+throwMiscErrorOnException :: String -> E.SomeException -> IO a throwMiscErrorOnException msg e = throwCore $ Error_Misc $ msg ++ ": " ++ show e @@ -124,7 +124,9 @@ -- then run certificate validation usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException case usage of- CertificateUsageAccept -> checkLeafCertificateKeyUsage+ CertificateUsageAccept -> do+ verifyLeafKeyUsagePurpose KeyUsagePurpose_ServerAuth certs+ checkLeafCertificateKeyUsage CertificateUsageReject reason -> certificateRejected reason where shared = clientShared cparams
Network/TLS/Handshake/Client/TLS13.hs view
@@ -7,7 +7,7 @@ postHandshakeAuthClientWith, ) where -import Control.Exception (bracket)+import qualified Control.Exception as E import Control.Monad.State.Strict import qualified Data.ByteArray as BA import Data.IORef@@ -379,7 +379,7 @@ postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO () postHandshakeAuthClientWith cparams ctx (CertRequest13 certReqCtx exts) =- bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do+ E.bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do -- updateTranscriptHash13 ctx h b processCertRequest13 ctx certReqCtx exts (usedHash, _, level, applicationSecretN) <- getTxRecordState ctx
Network/TLS/Handshake/Common.hs view
@@ -40,7 +40,7 @@ ) where import Control.Concurrent.MVar-import Control.Exception (IOException, fromException, handle, throwIO)+import qualified Control.Exception as E import Control.Monad.State.Strict import Data.ByteArray (convert) import qualified Data.ByteString as B@@ -69,7 +69,7 @@ import Network.TLS.X509 handshakeFailed :: TLSError -> IO ()-handshakeFailed err = throwIO $ HandshakeFailed err+handshakeFailed err = E.throwIO $ HandshakeFailed err handleException :: Context -> IO () -> IO () handleException ctx f = catchException f $ \exception -> do@@ -77,12 +77,12 @@ -- If the error was an Uncontextualized TLSException, we replace the -- context with HandshakeFailed. If it's anything else, we convert -- it to a string and wrap it with Error_Misc and HandshakeFailed.- let tlserror = case fromException exception of+ let tlserror = case E.fromException exception of Just e | Uncontextualized e' <- e -> e' _ -> Error_Misc (show exception) established <- ctxEstablished ctx setEstablished ctx NotEstablished- handle ignoreIOErr $ do+ E.handle ignoreIOErr $ do tls13 <- tls13orLater ctx if tls13 then do@@ -93,7 +93,7 @@ else sendPacket12 ctx $ Alert [errorToAlert tlserror] handshakeFailed tlserror where- ignoreIOErr :: IOException -> IO ()+ ignoreIOErr :: E.IOException -> IO () ignoreIOErr _ = return () errorToAlert :: TLSError -> (AlertLevel, AlertDescription)
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -34,7 +34,8 @@ -> IO ( SelectKeyShareResult , (Cipher, Hash, Bool) -- rtt0- , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid+ , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString)+ -- authenticated, is0RTTvalid, ticket ALPN ) processClientHello13 sparams ctx ch@CH{..} = do when@@ -126,14 +127,15 @@ -> Context -> (Cipher, Hash, Bool) -- rtt0 -> ClientHello- -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid+ -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString)+ -- authenticated, is0RTTvalid, ticket ALPN pskAndEarlySecret sparams ctx (usedCipher, usedHash, rtt0) CH{..} = do- (psk, binderInfo, is0RTTvalid) <- choosePSK+ (psk, binderInfo, is0RTTvalid, ticketALPN) <- choosePSK earlyKey <- calculateEarlySecret ctx choice (Left psk) let earlySecret = pairBase earlyKey authenticated = isJust binderInfo preSharedKeyExt <- checkBinder earlySecret binderInfo- return (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid)+ return (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid, ticketALPN) where choice = makeCipherChoice TLS13 usedCipher @@ -142,7 +144,7 @@ EID_PreSharedKey MsgTClientHello chExtensions- (return (zero, Nothing, False))+ (return (zero, Nothing, False, Nothing)) selectPSK selectPSK (PreSharedKeyClientHello (PskIdentity identity obfAge : _) bnds@(bnd : _)) = do@@ -167,12 +169,18 @@ isFresh <- checkFreshness tinfo obfAge (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata if isPSKvalid && isFresh- then return (psk, Just (bnd, 0 :: Int, len), is0RTTvalid)+ then+ return+ ( psk+ , Just (bnd, 0 :: Int, len)+ , is0RTTvalid+ , sessionALPN sdata+ ) else -- fall back to full handshake- return (zero, Nothing, False)- _ -> return (zero, Nothing, False)- else return (zero, Nothing, False)- selectPSK _ = return (zero, Nothing, False)+ return (zero, Nothing, False, Nothing)+ _ -> return (zero, Nothing, False, Nothing)+ else return (zero, Nothing, False, Nothing)+ selectPSK _ = return (zero, Nothing, False, Nothing) checkBinder _ Nothing = return [] checkBinder earlySecret (Just (binder, n, tlen)) = do@@ -184,9 +192,6 @@ checkSessionEquality sdata = do msni <- usingState_ ctx getClientSNI- -- ALPN should be checked.- -- But it's an extension in EE, sigh.- -- malpn <- usingState_ ctx getNegotiatedProtocol let isSameSNI = sessionClientSNI sdata == msni isSameCipher = sessionCipher sdata == cipherID usedCipher ciphers = supportedCiphers $ serverSupported sparams@@ -195,9 +200,8 @@ Nothing -> False Just c -> cipherHash c == cipherHash usedCipher isSameVersion = TLS13 == sessionVersion sdata- -- isSameALPN = sessionALPN sdata == malpn isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required- is0RTTvalid = isSameVersion && isSameCipher -- && isSameALPN+ is0RTTvalid = isSameVersion && isSameCipher return (isPSKvalid, is0RTTvalid) dhModes =
Network/TLS/Handshake/Server/ServerHello13.hs view
@@ -37,7 +37,8 @@ -> Context -> KeyShareEntry -> (Cipher, Hash, Bool) -- rtt0- -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid+ -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString)+ -- authenticated, is0RTTvalid, ticket ALPN -> ClientHello -> Maybe ClientRandom -> IO@@ -46,7 +47,7 @@ , Bool -- authenticated , Bool -- rtt0OK )-sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid) CH{..} mOuterClientRandom = do+sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid, ticketALPN) CH{..} mOuterClientRandom = do let clientEarlySecret = pairClient earlyKey earlySecret = pairBase earlyKey -- parse CompressCertificate to check if it is broken here@@ -69,8 +70,15 @@ setOuterClientRandom mOuterClientRandom hrr <- usingState_ ctx getTLS13HRR alpnExt <- applicationProtocol ctx chExtensions sparams+ negotiatedALPN <- usingState_ ctx getNegotiatedProtocol setServerParameter- let rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid+ let rtt0OK =+ authenticated+ && not hrr+ && rtt0+ && rtt0accept+ && is0RTTvalid+ && ticketALPN == negotiatedALPN extraCreds <- usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams) let p = makeCredentialPredicate TLS13 chExtensions
Network/TLS/Handshake/Server/TLS13.hs view
@@ -9,7 +9,7 @@ KeyUpdateRequest (..), ) where -import Control.Exception+import qualified Control.Exception as E import Control.Monad.State.Strict import Data.IORef @@ -239,7 +239,7 @@ origCertReqCtx <- newCertReqContext ctx let certReq13 = makeCertRequest sparams ctx origCertReqCtx False _ <- withWriteLock ctx $ do- bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do+ E.bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do sendPacket13 ctx $ Handshake13 [certReq13] [] withReadLock ctx $ do (clientCert13, bClientCert13) <- getHandshake ctx ref@@ -328,18 +328,18 @@ send = sendPacket13 ctx . Alert13 catchException (send [(level, desc)]) (\_ -> return ()) setEOF ctx- throwIO $ Terminated False reason err+ E.throwIO $ Terminated False reason err handleEx :: Context -> IO Bool -> IO Bool handleEx ctx f = catchException f $ \exception -> do -- If the error was an Uncontextualized TLSException, we replace the -- context with HandshakeFailed. If it's anything else, we convert -- it to a string and wrap it with Error_Misc and HandshakeFailed.- let tlserror = case fromException exception of+ let tlserror = case E.fromException exception of Just e | Uncontextualized e' <- e -> e' _ -> Error_Misc (show exception) sendPacket13 ctx $ Alert13 [errorToAlert tlserror]- void $ throwIO $ PostHandshake tlserror+ void $ E.throwIO $ PostHandshake tlserror return False ----------------------------------------------------------------
Network/TLS/IO.hs view
@@ -16,7 +16,7 @@ loadPacket13, ) where -import Control.Exception (finally, throwIO)+import qualified Control.Exception as E import Control.Monad.Reader import Control.Monad.State.Strict import qualified Data.ByteString as B@@ -203,9 +203,9 @@ checkValid :: Context -> IO () checkValid ctx = do established <- ctxEstablished ctx- when (established == NotEstablished) $ throwIO ConnectionNotEstablished+ when (established == NotEstablished) $ E.throwIO ConnectionNotEstablished eofed <- ctxEOF ctx- when eofed $ throwIO $ PostHandshake Error_EOF+ when eofed $ E.throwIO $ PostHandshake Error_EOF ---------------------------------------------------------------- @@ -223,7 +223,8 @@ runPacketFlight :: Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a runPacketFlight ctx@Context{ctxRecordLayer = recordLayer} (PacketFlightM f) = do ref <- newIORef id- runReaderT f (recordLayer, ref) `finally` sendPendingFlight ctx recordLayer ref+ runReaderT f (recordLayer, ref)+ `E.finally` sendPendingFlight ctx recordLayer ref sendPendingFlight :: Monoid b => Context -> RecordLayer b -> IORef (Builder b) -> IO ()
Network/TLS/Packet13.hs view
@@ -217,7 +217,7 @@ bs <- getOpaque24 if bs == "" then fail "empty compressed certificate"- else case decompressIt bs of+ else case decompressIt len bs of Left e -> fail (show e) Right bs' -> do when (B.length bs' /= len) $ fail "plain length is wrong"@@ -226,8 +226,11 @@ -- _ -> fail "compressed certificate cannot be parsed" _ -> fail $ "invalid compressed certificate: len = " ++ show len -decompressIt :: ByteString -> Either DecompressError ByteString-decompressIt inp = unsafePerformIO $ E.handle handler $ do- Right . BL.toStrict <$> E.evaluate (decompress (BL.fromStrict inp))+decompressIt :: Int -> ByteString -> Either DecompressError ByteString+decompressIt limit inp = unsafePerformIO $ E.handle handler $ do+ -- One extra byte distinguishes exact-length output from oversized output.+ let output = BL.take (fromIntegral limit + 1) $ decompress $ BL.fromStrict inp+ Right <$> E.evaluate (BL.toStrict output) where- handler e = return $ Left (e :: DecompressError)+ handler :: DecompressError -> IO (Either DecompressError ByteString)+ handler e = return $ Left e
Network/TLS/Parameters.hs view
@@ -640,10 +640,11 @@ -- "Data.X509.Validation". This can be replaced with a custom -- validation function using different settings. --- -- The function is not expected to verify the key-usage extension- -- of the end-entity certificate, as this depends on the- -- dynamically-selected cipher and this part should not be cached.- -- Key-usage verification is performed by the library internally.+ -- The function is not expected to verify the key-usage or+ -- extended-key-usage extensions of the end-entity certificate.+ -- Key usage depends on the dynamically-selected cipher and this+ -- part should not be cached. Both checks are performed by the+ -- library internally after this function accepts the chain. -- -- Default: 'validateDefault' , onSuggestALPN :: IO (Maybe [ByteString])
Network/TLS/Util.hs view
@@ -18,7 +18,6 @@ ) where import Control.Concurrent.MVar-import Control.Exception (SomeAsyncException (..)) import qualified Control.Exception as E import Data.ByteArray (ScrubbedBytes) import qualified Data.ByteArray as BA@@ -83,7 +82,7 @@ where filterExn :: E.SomeException -> Maybe E.SomeException filterExn e = case E.fromException (E.toException e) of- Just (SomeAsyncException _) -> Nothing+ Just (E.SomeAsyncException _) -> Nothing Nothing -> Just e forEitherM :: Monad m => [a] -> (a -> m (Either l b)) -> m (Either l [b])
test/Certificate.hs view
@@ -6,6 +6,7 @@ arbitraryX509, arbitraryX509WithKey, arbitraryX509WithKeyAndUsage,+ arbitraryRSACredentialWithPurpose, arbitraryDN, simpleCertificate, simpleX509,@@ -117,6 +118,25 @@ let sigalg = getSignatureALG pubKey let (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert return signedExact++arbitraryRSACredentialWithPurpose+ :: ExtKeyUsagePurpose -> Gen (CertificateChain, PrivKey)+arbitraryRSACredentialWithPurpose purpose = do+ let (pubKey, privKey) = getGlobalRSAPair+ cert <- arbitraryCertificate knownKeyUsage $ PubKeyRSA pubKey+ sig <- resize 40 $ listOf1 arbitrary+ let cert' =+ cert+ { certExtensions =+ Extensions $+ Just+ [ extensionEncode True $ ExtKeyUsage knownKeyUsage+ , extensionEncode False $ ExtExtendedKeyUsage [purpose]+ ]+ }+ sigalg = getSignatureALG $ PubKeyRSA pubKey+ (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert'+ return (CertificateChain [signedExact], PrivKeyRSA privKey) arbitraryX509 :: Gen SignedCertificate arbitraryX509 = do
test/EncodeSpec.hs view
@@ -1,6 +1,13 @@ module EncodeSpec where +import Codec.Compression.Zlib (compress)+import Control.Exception (bracket_, evaluate) import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Either (isLeft)+import Data.Int (Int64)+import GHC.Conc (disableAllocationLimit, enableAllocationLimit, setAllocationCounter) import Network.TLS import Network.TLS.Internal import Test.Hspec@@ -17,6 +24,34 @@ decodeHs (encodeHandshake x) `shouldBe` Right x prop "can encode/decode Handshake13" $ \x -> do decodeHs13 (encodeHandshake13 x) `shouldBe` Right x+ it "round trips a valid TLS 1.3 compressed certificate" $ do+ let certificate =+ CompressedCertificate13+ B.empty+ (CertificateChain_ $ CertificateChain [])+ []+ decodeHs13 (encodeHandshake13 certificate) `shouldBe` Right certificate+ it "rejects decompressed output shorter than its declared size" $ do+ let plain = encodeCertificate13 B.empty (CertificateChain []) []+ compressed = BL.toStrict $ compress $ BL.fromStrict plain+ encoded = runPut $ do+ putWord16 1+ putWord24 (B.length plain + 1)+ putOpaque24 compressed+ decodeHandshake13 HandshakeType_CompressedCertificate encoded+ `shouldSatisfy` isLeft+ it "bounds TLS 1.3 certificate decompression by the declared size" $ do+ let compressed = BL.toStrict $ compress $ BL.replicate (32 * 1024 * 1024) 0+ encoded = runPut $ do+ putWord16 1+ putWord24 1+ putOpaque24 compressed+ _ <- evaluate $ B.length encoded+ decoded <-+ withinAllocationLimit (8 * 1024 * 1024) $+ evaluate $+ decodeHandshake13 HandshakeType_CompressedCertificate encoded+ decoded `shouldSatisfy` isLeft decodeHs :: ByteString -> Either TLSError Handshake decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b@@ -37,3 +72,9 @@ GotError e -> error ("got error: " ++ show e) GotSuccessRemaining _ _ -> error "got remaining byte left" GotSuccess (ty, content) -> fn ty content++withinAllocationLimit :: Int64 -> IO a -> IO a+withinAllocationLimit limit =+ bracket_+ (setAllocationCounter limit >> enableAllocationLimit)+ disableAllocationLimit
test/HandshakeSpec.hs view
@@ -2,13 +2,15 @@ module HandshakeSpec where +import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (concurrently_) import Control.Monad import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.IORef import Data.List import Data.Maybe-import Data.X509 (ExtKeyUsageFlag (..))+import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) import Network.TLS import Network.TLS.Extra.Cipher import Network.TLS.Extra.CipherCBC@@ -19,6 +21,7 @@ import API import Arbitrary+import Certificate (arbitraryRSACredentialWithPurpose) import PipeChan import Run import Session@@ -41,6 +44,14 @@ "can fallback for certificate with hash and signature" handshake_cert_fallback_hs prop "can handle server key usage" handshake_server_key_usage+ it "accepts a TLS 1.2 server certificate permitting server auth" $+ handshake_server_key_purpose TLS12 KeyUsagePurpose_ServerAuth True+ it "accepts a TLS 1.3 server certificate permitting server auth" $+ handshake_server_key_purpose TLS13 KeyUsagePurpose_ServerAuth True+ it "rejects a TLS 1.2 server certificate restricted to client auth" $+ handshake_server_key_purpose TLS12 KeyUsagePurpose_ClientAuth False+ it "rejects a TLS 1.3 server certificate restricted to client auth" $+ handshake_server_key_purpose TLS13 KeyUsagePurpose_ClientAuth False prop "can handle client key usage" handshake_client_key_usage prop "can authenticate client" handshake_client_auth prop "can receive client authentication failure" handshake_client_auth_fail@@ -58,11 +69,16 @@ prop "can handshake with TLS 1.3 PSK ticket" handshake13_psk_ticket prop "can handshake with TLS 1.3 PSK -> HRR" handshake13_psk_fallback prop "can handshake with TLS 1.3 0RTT" handshake13_0rtt+ it "rejects TLS 1.3 early data when ALPN changes" $+ handshake13_0rtt_alpn prop "can handshake with TLS 1.3 0RTT -> PSK" handshake13_0rtt_fallback prop "can handshake with TLS 1.3 EE" handshake13_ee_groups prop "can handshake with TLS 1.3 EC groups" handshake13_ec prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe prop "can handshake with TLS 1.3 Post-handshake auth" post_handshake_auth+ it+ "keeps record alignment when a slow record follows client auth"+ handshake13_client_auth_slow_record -------------------------------------------------------------- @@ -451,6 +467,35 @@ then runTLSSimple (clientParam, serverParam') else runTLSFailure (clientParam, serverParam') handshake handshake +handshake_server_key_purpose :: Version -> ExtKeyUsagePurpose -> Bool -> IO ()+handshake_server_key_purpose version purpose shouldSucceed = do+ let cipher+ | version == TLS13 = cipher13_AES_128_GCM_SHA256+ | otherwise = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+ (clientParam, serverParam) <-+ generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([version], [version])+ ([cipher], [cipher])+ cred <- generate $ arbitraryRSACredentialWithPurpose purpose+ let clientParam' =+ clientParam+ { clientHooks =+ (clientHooks clientParam)+ { onServerCertificate = \_ _ _ _ -> return []+ }+ }+ serverParam' =+ serverParam+ { serverShared =+ (serverShared serverParam)+ { sharedCredentials = Credentials [cred]+ }+ }+ if shouldSucceed+ then runTLSSimple (clientParam', serverParam')+ else runTLSFailure (clientParam', serverParam') handshake handshake+ handshake_client_key_usage :: [ExtKeyUsageFlag] -> IO () handshake_client_key_usage usageFlags = do (clientParam, serverParam) <- generate arbitrary@@ -916,6 +961,67 @@ runTLS0RTT params2 RTT0 earlyData +handshake13_0rtt_alpn :: IO ()+handshake13_0rtt_alpn = do+ (cli, srv) <- generate arbitraryPairParams13+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ cliHooks =+ defaultClientHooks+ { onSuggestALPN = return $ Just ["h2"]+ }+ svrHooks =+ defaultServerHooks+ { onALPNClientSuggest = Just (return . unsafeHead)+ }+ params0 =+ ( cli+ { clientSupported = cliSupported+ , clientHooks = cliHooks+ }+ , srv+ { serverSupported = svrSupported+ , serverHooks = svrHooks+ , serverEarlyDataSize = 2048+ }+ )+ sessionRefs <- twoSessionRefs+ let params =+ setPairParamsSessionManagers+ (twoSessionManagers sessionRefs)+ params0+ runTLSSimple13 params FullHandshake++ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ sessionALPN (snd $ fromJust sessionParams) `shouldBe` Just "h2"+ let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params+ pc' =+ pc+ { clientUseEarlyData = True+ , clientHooks =+ (clientHooks pc)+ { onSuggestALPN = return $ Just ["http/1.1"]+ }+ }+ ps' =+ ps+ { serverHooks =+ (serverHooks ps)+ { onALPNClientSuggest = Just (return . unsafeHead)+ }+ }+ runTLS0RTT (pc', ps') PreSharedKey "GET /admin HTTP/1.1\r\n\r\n"+ handshake13_0rtt_fallback :: CSP13 -> IO () handshake13_0rtt_fallback (CSP13 (cli, srv)) = do group0 <- generate $ elements [P256, X25519]@@ -1081,6 +1187,57 @@ _ <- requestCertificate ctx _ <- requestCertificate ctx -- two simultaneously sendData ctx "response 2"++-- | After sending a Certificate message, a TLS 1.3 client peeks for a+-- client-authentication alert with a deadline of a few RTTs. That peek must+-- not abandon a record it has already started reading: the record layer has no+-- receive buffer, so the bytes consumed for the record header would be lost and+-- the caller's next 'recvData' would decode part of a record body as a header.+--+-- Here the server's first write is one full-size record whose body is made to+-- arrive late, so the peek does hit its deadline with the header already+-- consumed. Before the fix this failed with+-- @Error_Protocol "record exceeding maximum size" RecordOverflow@.+handshake13_client_auth_slow_record :: IO ()+handshake13_client_auth_slow_record = do+ (clientParam, serverParam) <- generate arbitraryPairParams13+ cred <- generate (arbitraryClientCredential TLS13)+ let clientParam' =+ clientParam+ { clientHooks =+ (clientHooks clientParam)+ { onCertificateRequest = \_ -> return $ Just cred+ }+ }+ serverParam' =+ serverParam+ { serverWantClientCert = True+ , serverHooks =+ (serverHooks serverParam)+ { onClientCertificate = \_ -> return CertificateUsageAccept+ }+ }+ payload = B.replicate 16384 65+ withPairContextWith (delayBigReads, id) (clientParam', serverParam') $+ \(cCtx, sCtx) ->+ concurrently_+ ( do+ handshake sCtx+ sendData sCtx $ L.fromStrict payload+ )+ ( do+ handshake cCtx+ recvData cCtx `shouldReturn` payload+ )+ where+ -- Only the body of the big record is held back; every handshake record is+ -- far smaller than this threshold and so arrives immediately.+ delayBigReads be =+ be+ { backendRecv = \n -> do+ when (n > 4096) $ threadDelay 300000+ backendRecv be n+ } expectJust :: String -> Maybe a -> Expectation expectJust tag mx = case mx of
test/Run.hs view
@@ -16,6 +16,8 @@ runTLSFailure, expectMaybe, newPairContext,+ newPairContextWith,+ withPairContextWith, withDataPipe, byeBye, ) where@@ -326,16 +328,32 @@ withPairContext :: (ClientParams, ServerParams) -> ((Context, Context) -> IO ()) -> IO ()-withPairContext params body =+withPairContext = withPairContextWith (id, id)++withPairContextWith+ :: (Backend -> Backend, Backend -> Backend)+ -> (ClientParams, ServerParams)+ -> ((Context, Context) -> IO ())+ -> IO ()+withPairContextWith wrapBackends params body = E.bracket- (newPairContext params)+ (newPairContextWith wrapBackends params) (\((t1, t2), _) -> killThread t1 >> killThread t2) (\(_, ctxs) -> body ctxs) newPairContext :: (ClientParams, ServerParams) -> IO ((ThreadId, ThreadId), (Context, Context))-newPairContext (cParams, sParams) = do+newPairContext = newPairContextWith (id, id)++-- | 'newPairContext' with a hook on each side's 'Backend' -- client first, as+-- with the parameters -- so that a test can control how bytes arrive (delay+-- them, split them). Pass 'id' for a side to leave it alone.+newPairContextWith+ :: (Backend -> Backend, Backend -> Backend)+ -> (ClientParams, ServerParams)+ -> IO ((ThreadId, ThreadId), (Context, Context))+newPairContextWith (wrapCBackend, wrapSBackend) (cParams, sParams) = do pipe <- newPipe tids <- runPipe pipe let noFlush = return ()@@ -343,8 +361,8 @@ let cBackend = Backend noFlush noClose (writePipeC pipe) (readPipeC pipe) let sBackend = Backend noFlush noClose (writePipeS pipe) (readPipeS pipe)- cCtx' <- contextNew cBackend cParams- sCtx' <- contextNew sBackend sParams+ cCtx' <- contextNew (wrapCBackend cBackend) cParams+ sCtx' <- contextNew (wrapSBackend sBackend) sParams contextHookSetLogging cCtx' (logging "client: ") contextHookSetLogging sCtx' (logging "server: ")
tls.cabal view
@@ -1,6 +1,6 @@-cabal-version: >=1.10+cabal-version: 2.0 name: tls-version: 2.4.3+version: 2.4.4 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>@@ -190,7 +190,7 @@ crypton-x509-system, ech-config, network,- network-run >=0.5,+ network-run >=0.6.0 && < 0.7, tls if flag(devel)@@ -235,7 +235,8 @@ ram, serialise, time-hourglass,- tls+ tls,+ zlib benchmark tls-bench type: exitcode-stdio-1.0@@ -274,6 +275,7 @@ hspec, network, network-run,+ ram, serialise, tasty-bench, time-hourglass,