diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -8,6 +8,7 @@ Context (..), Hooks (..), Established (..), + PendingRecv (..), RecordLayer (..), ctxEOF, ctxEstablished, @@ -23,6 +24,7 @@ updateMeasure, withMeasure, withReadLock, + tryWithReadLock, withWriteLock, withStateLock, withRWLock, 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 @@ -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) diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -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 diff --git a/Network/TLS/Error.hs b/Network/TLS/Error.hs --- a/Network/TLS/Error.hs +++ b/Network/TLS/Error.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/TLS/Handshake/Certificate.hs b/Network/TLS/Handshake/Certificate.hs --- a/Network/TLS/Handshake/Certificate.hs +++ b/Network/TLS/Handshake/Certificate.hs @@ -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 () diff --git a/Network/TLS/Handshake/Client/Common.hs b/Network/TLS/Handshake/Client/Common.hs --- a/Network/TLS/Handshake/Client/Common.hs +++ b/Network/TLS/Handshake/Client/Common.hs @@ -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 diff --git a/Network/TLS/Handshake/Client/TLS13.hs b/Network/TLS/Handshake/Client/TLS13.hs --- a/Network/TLS/Handshake/Client/TLS13.hs +++ b/Network/TLS/Handshake/Client/TLS13.hs @@ -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 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 @@ -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) diff --git a/Network/TLS/Handshake/Server/ClientHello13.hs b/Network/TLS/Handshake/Server/ClientHello13.hs --- a/Network/TLS/Handshake/Server/ClientHello13.hs +++ b/Network/TLS/Handshake/Server/ClientHello13.hs @@ -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 = diff --git a/Network/TLS/Handshake/Server/ServerHello13.hs b/Network/TLS/Handshake/Server/ServerHello13.hs --- a/Network/TLS/Handshake/Server/ServerHello13.hs +++ b/Network/TLS/Handshake/Server/ServerHello13.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/TLS13.hs b/Network/TLS/Handshake/Server/TLS13.hs --- a/Network/TLS/Handshake/Server/TLS13.hs +++ b/Network/TLS/Handshake/Server/TLS13.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -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 () diff --git a/Network/TLS/Packet13.hs b/Network/TLS/Packet13.hs --- a/Network/TLS/Packet13.hs +++ b/Network/TLS/Packet13.hs @@ -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 diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -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]) diff --git a/Network/TLS/Util.hs b/Network/TLS/Util.hs --- a/Network/TLS/Util.hs +++ b/Network/TLS/Util.hs @@ -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]) diff --git a/test/Certificate.hs b/test/Certificate.hs --- a/test/Certificate.hs +++ b/test/Certificate.hs @@ -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 diff --git a/test/EncodeSpec.hs b/test/EncodeSpec.hs --- a/test/EncodeSpec.hs +++ b/test/EncodeSpec.hs @@ -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 diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -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 diff --git a/test/Run.hs b/test/Run.hs --- a/test/Run.hs +++ b/test/Run.hs @@ -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: ") diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -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 @@ -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,