tls 1.5.6 → 1.5.7
raw patch · 11 files changed
+71/−10 lines, 11 files
Files
- CHANGELOG.md +7/−1
- Network/TLS.hs +2/−0
- Network/TLS/Context.hs +14/−0
- Network/TLS/Context/Internal.hs +2/−0
- Network/TLS/Handshake/Client.hs +1/−1
- Network/TLS/Handshake/Common.hs +2/−0
- Network/TLS/Handshake/Common13.hs +8/−4
- Network/TLS/Handshake/Process.hs +2/−0
- Network/TLS/Handshake/Server.hs +2/−2
- Tests/Tests.hs +29/−0
- tls.cabal +2/−2
CHANGELOG.md view
@@ -1,6 +1,12 @@+## Version 1.5.7++- New APIs: getFinished and getPeerFinished+ [#445](https://github.com/vincenthz/hs-tls/pull/445)+ ## Version 1.5.6 -- Dynamically setting enctypted extensions [#444](https://github.com/vincenthz/hs-tls/pull/444)+- Dynamically setting enctypted extensions+ [#444](https://github.com/vincenthz/hs-tls/pull/444) ## Version 1.5.5
Network/TLS.hs view
@@ -117,6 +117,8 @@ , updateKey , KeyUpdateRequest(..) , requestCertificate+ , getFinished+ , getPeerFinished -- ** Modifying hooks in context , Hooks(..) , contextModifyHooks
Network/TLS/Context.hs view
@@ -63,6 +63,8 @@ , getHState , getStateRNG , tls13orLater+ , getFinished+ , getPeerFinished ) where import Network.TLS.Backend@@ -160,6 +162,8 @@ lockWrite <- newMVar () lockRead <- newMVar () lockState <- newMVar ()+ finished <- newIORef Nothing+ peerFinished <- newIORef Nothing let ctx = Context { ctxConnection = getBackend backend@@ -189,6 +193,8 @@ , ctxRecordLayer = recordLayer , ctxHandshakeSync = HandshakeSync syncNoOp syncNoOp , ctxQUICMode = False+ , ctxFinished = finished+ , ctxPeerFinished = peerFinished } syncNoOp _ _ = return ()@@ -236,3 +242,11 @@ contextHookSetLogging :: Context -> Logging -> IO () contextHookSetLogging context loggingCallbacks = contextModifyHooks context (\hooks -> hooks { hookLogging = loggingCallbacks })++-- | Get TLS Finished sent to peer+getFinished :: Context -> IO (Maybe FinishedData)+getFinished = readIORef . ctxFinished++-- | Get TLS Finished received from peer+getPeerFinished :: Context -> IO (Maybe FinishedData)+getPeerFinished = readIORef . ctxPeerFinished
Network/TLS/Context/Internal.hs view
@@ -141,6 +141,8 @@ , ctxRecordLayer :: RecordLayer bytes , ctxHandshakeSync :: HandshakeSync , ctxQUICMode :: Bool+ , ctxFinished :: IORef (Maybe FinishedData)+ , ctxPeerFinished :: IORef (Maybe FinishedData) } data HandshakeSync = HandshakeSync (Context -> ClientState -> IO ())
Network/TLS/Handshake/Client.hs view
@@ -980,7 +980,7 @@ expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify") expectFinished (ServerTrafficSecret baseKey) hashValue (Finished13 verifyData) =- checkFinished usedHash baseKey hashValue verifyData+ checkFinished ctx usedHash baseKey hashValue verifyData expectFinished _ _ p = unexpected (show p) (Just "server finished") setResumptionSecret applicationSecret = do
Network/TLS/Handshake/Common.hs view
@@ -51,6 +51,7 @@ import Control.Monad.State.Strict import Control.Exception (IOException, handle, fromException, throwIO)+import Data.IORef (writeIORef) handshakeFailed :: TLSError -> IO () handshakeFailed err = throwIO $ HandshakeFailed err@@ -127,6 +128,7 @@ liftIO $ contextFlush ctx cf <- usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role sendPacket ctx (Handshake [Finished cf])+ writeIORef (ctxFinished ctx) $ Just cf liftIO $ contextFlush ctx recvChangeCipherAndFinish :: Context -> IO ()
Network/TLS/Handshake/Common13.hs view
@@ -74,17 +74,21 @@ import Control.Concurrent.MVar import Control.Monad.State.Strict+import Data.IORef (writeIORef) ---------------------------------------------------------------- makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13-makeFinished ctx usedHash baseKey =- Finished13 . makeVerifyData usedHash baseKey <$> transcriptHash ctx+makeFinished ctx usedHash baseKey = do+ finished <- makeVerifyData usedHash baseKey <$> transcriptHash ctx+ liftIO $ writeIORef (ctxFinished ctx) (Just finished)+ pure $ Finished13 finished -checkFinished :: MonadIO m => Hash -> ByteString -> ByteString -> ByteString -> m ()-checkFinished usedHash baseKey hashValue verifyData = do+checkFinished :: MonadIO m => Context -> Hash -> ByteString -> ByteString -> ByteString -> m ()+checkFinished ctx usedHash baseKey hashValue verifyData = do let verifyData' = makeVerifyData usedHash baseKey hashValue unless (verifyData' == verifyData) $ decryptError "cannot verify finished"+ liftIO $ writeIORef (ctxPeerFinished ctx) (Just verifyData) makeVerifyData :: Hash -> ByteString -> ByteString -> ByteString makeVerifyData usedHash baseKey = hmac usedHash finishedKey
Network/TLS/Handshake/Process.hs view
@@ -36,6 +36,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.State.Strict (gets) import Data.X509 (CertificateChain(..), Certificate(..), getCertificate)+import Data.IORef (writeIORef) processHandshake :: Context -> Handshake -> IO () processHandshake ctx hs = do@@ -136,6 +137,7 @@ (cc,ver) <- usingState_ ctx $ (,) <$> isClientContext <*> getVersion expected <- usingHState ctx $ getHandshakeDigest ver $ invertRole cc when (expected /= fdata) $ decryptError "cannot verify finished"+ writeIORef (ctxPeerFinished ctx) $ Just fdata -- initialize a new Handshake context (initial handshake or renegotiations) startHandshake :: Context -> Version -> ClientRandom -> IO ()
Network/TLS/Handshake/Server.hs view
@@ -789,7 +789,7 @@ let expectFinished hChBeforeCf (Finished13 verifyData) = liftIO $ do let ClientTrafficSecret chs = clientHandshakeSecret- checkFinished usedHash chs hChBeforeCf verifyData+ checkFinished ctx usedHash chs hChBeforeCf verifyData handshakeTerminate13 ctx setRxState ctx usedHash usedCipher clientApplicationSecret0 sendNewSessionTicket applicationSecret sfSentTime@@ -1179,7 +1179,7 @@ throwCore $ Error_Protocol ("tried post-handshake authentication without application traffic secret", True, InternalError) let expectFinished hChBeforeCf (Finished13 verifyData) = do- checkFinished usedHash applicationSecretN hChBeforeCf verifyData+ checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData void $ restoreHState ctx baseHState expectFinished _ hs = unexpected (show hs) (Just "finished 13")
Tests/Tests.hs view
@@ -80,12 +80,14 @@ runTLSPipePredicate params p = runTLSPipe params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx+ checkCtxFinished ctx checkInfoPredicate ctx d <- recvData ctx writeChan queue [d] bye ctx tlsClient queue ctx = do handshake ctx+ checkCtxFinished ctx checkInfoPredicate ctx d <- readChan queue sendData ctx (L.fromChunks [d])@@ -109,12 +111,14 @@ chunks <- replicateM (length ls) $ recvData ctx (ls, ed) `assertEq` (map B.length chunks, B.concat chunks) d <- recvData ctx+ checkCtxFinished ctx writeChan queue [d] minfo <- contextGetInformation ctx Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode) bye ctx tlsClient queue ctx = do handshake ctx+ checkCtxFinished ctx d <- readChan queue sendData ctx (L.fromChunks [d]) minfo <- contextGetInformation ctx@@ -132,12 +136,14 @@ where tlsServer ref ctx queue = do installHook ctx ref handshake ctx+ checkCtxFinished ctx d <- recvData ctx writeChan queue [d] bye ctx tlsClient ref queue ctx = do installHook ctx ref handshake ctx+ checkCtxFinished ctx d <- readChan queue sendData ctx (L.fromChunks [d]) byeBye ctx@@ -149,6 +155,7 @@ runTLSPipeSimpleKeyUpdate params = runTLSPipeN 3 params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx+ checkCtxFinished ctx d0 <- recvData ctx req <- generate $ elements [OneWay, TwoWay] _ <- updateKey ctx req@@ -158,6 +165,7 @@ bye ctx tlsClient queue ctx = do handshake ctx+ checkCtxFinished ctx d0 <- readChan queue sendData ctx (L.fromChunks [d0]) d1 <- readChan queue@@ -175,11 +183,13 @@ assertIsLeft sRes where tlsServer ctx = do _ <- hsServer ctx+ checkCtxFinished ctx minfo <- contextGetInformation ctx byeBye ctx return $ "server success: " ++ show minfo tlsClient ctx = do _ <- hsClient ctx+ checkCtxFinished ctx minfo <- contextGetInformation ctx byeBye ctx return $ "client success: " ++ show minfo@@ -747,6 +757,7 @@ byeBye ctx hsServer ctx = do handshake ctx+ checkCtxFinished ctx recvDataAssert ctx "request 1" _ <- requestCertificate ctx -- single request sendData ctx "response 1"@@ -756,6 +767,7 @@ sendData ctx "response 2" hsClient ctx = do handshake ctx+ checkCtxFinished ctx sendData ctx "request 1" recvDataAssert ctx "response 1" sendData ctx "request 2"@@ -844,6 +856,7 @@ runTLSPipe params' tlsServer tlsClient where tlsServer ctx queue = do handshake ctx+ checkCtxFinished ctx proto <- getNegotiatedProtocol ctx Just "h2" `assertEq` proto d <- recvData ctx@@ -851,6 +864,7 @@ bye ctx tlsClient queue ctx = do handshake ctx+ checkCtxFinished ctx proto <- getNegotiatedProtocol ctx Just "h2" `assertEq` proto d <- readChan queue@@ -875,6 +889,7 @@ Just (Just serverName) `assertEq` receivedName where tlsServer ctx queue = do handshake ctx+ checkCtxFinished ctx sni <- getClientSNI ctx Just serverName `assertEq` sni d <- recvData ctx@@ -882,6 +897,7 @@ bye ctx tlsClient queue ctx = do handshake ctx+ checkCtxFinished ctx sni <- getClientSNI ctx Just serverName `assertEq` sni d <- readChan queue@@ -905,11 +921,13 @@ else runTLSPipe (cparams, sparams') tlsServer tlsClient where tlsServer ctx queue = do hsServer ctx+ checkCtxFinished ctx d <- recvData ctx writeChan queue [d] bye ctx tlsClient queue ctx = do hsClient ctx+ checkCtxFinished ctx d <- readChan queue sendData ctx (L.fromChunks [d]) byeBye ctx@@ -939,12 +957,14 @@ runTLSPipe params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx+ checkCtxFinished ctx runReaderWriters ctx "client-value" "server-value" d <- recvData ctx writeChan queue [d] bye ctx tlsClient queue ctx = do handshake ctx+ checkCtxFinished ctx runReaderWriters ctx "server-value" "client-value" d <- readChan queue sendData ctx (L.fromChunks [d])@@ -969,6 +989,15 @@ recvDataAssert ctx expected = do got <- recvData ctx assertEq expected got++checkCtxFinished :: Context -> IO ()+checkCtxFinished ctx = do+ ctxFinished <- getFinished ctx+ unless (isJust ctxFinished) $+ fail "unexpected ctxFinished"+ ctxPeerFinished <- getPeerFinished ctx+ unless (isJust ctxPeerFinished) $+ fail "unexpected ctxPeerFinished" main :: IO () main = defaultMain $ testGroup "tls"
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 1.5.6+Version: 1.5.7 Description: Native Haskell TLS and SSL protocol implementation for server and client. .@@ -17,7 +17,7 @@ License-file: LICENSE Copyright: Vincent Hanquez <vincent@snarc.org> Author: Vincent Hanquez <vincent@snarc.org>-Maintainer: Vincent Hanquez <vincent@snarc.org>+Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> Synopsis: TLS/SSL protocol native implementation (Server and Client) Build-Type: Simple Category: Network