diff --git a/Benchmarks/Benchmarks.hs b/Benchmarks/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/Benchmarks/Benchmarks.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE BangPatterns #-} + +module Main where + +import Certificate +import Control.Concurrent.Chan +import Data.Default (def) +import Data.IORef +import Data.X509 +import Data.X509.Validation +import Test.Tasty.Bench +import Network.TLS +import Network.TLS.Extra.Cipher +import Session +import Run +import PubKey + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +blockCipher :: Cipher +blockCipher = + Cipher + { cipherID = 0xff12 + , cipherName = "rsa-id-const" + , cipherBulk = + Bulk + { bulkName = "id" + , bulkKeySize = 16 + , bulkIVSize = 16 + , bulkExplicitIV = 0 + , bulkAuthTagLen = 0 + , bulkBlockSize = 16 + , bulkF = BulkBlockF $ \_ _ _ m -> (m, B.empty) + } + , cipherHash = MD5 + , cipherPRFHash = Nothing + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } + +getParams :: Version -> Cipher -> (ClientParams, ServerParams) +getParams connectVer cipher = (cParams, sParams) + where + sParams = + def + { serverSupported = supported + , serverShared = + def + { sharedCredentials = + Credentials + [(CertificateChain [simpleX509 $ PubKeyRSA pubKey], PrivKeyRSA privKey)] + } + } + cParams = + (defaultParamsClient "" B.empty) + { clientSupported = supported + , clientShared = + def + { sharedValidationCache = + ValidationCache + { cacheAdd = \_ _ _ -> return () + , cacheQuery = \_ _ _ -> return ValidationCachePass + } + } + } + supported = + def + { supportedCiphers = [cipher] + , supportedVersions = [connectVer] + , supportedGroups = [X25519, FFDHE2048] + } + (pubKey, privKey) = getGlobalRSAPair + +runTLSPipe + :: (ClientParams, ServerParams) + -> (Context -> Chan b -> IO ()) + -> (Chan a -> Context -> IO ()) + -> a + -> IO b +runTLSPipe params tlsServer tlsClient d = do + withDataPipe params tlsServer tlsClient $ \(writeStart, readResult) -> do + writeStart d + readResult + +runTLSPipeSimple + :: (ClientParams, ServerParams) -> B.ByteString -> IO B.ByteString +runTLSPipeSimple params = runTLSPipe params tlsServer tlsClient + where + tlsServer ctx queue = do + handshake ctx + d <- recvData ctx + writeChan queue d + bye ctx + tlsClient queue ctx = do + handshake ctx + d <- readChan queue + sendData ctx (L.fromChunks [d]) + byeBye ctx + +benchConnection + :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark +benchConnection params !d name = bench name . nfIO $ runTLSPipeSimple params d + +benchResumption + :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark +benchResumption params !d name = env initializeSession runResumption + where + initializeSession = do + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + params1 = setPairParamsSessionManagers sessionManagers params + _ <- runTLSPipeSimple params1 d + + Just sessionParams <- readClientSessionRef sessionRefs + let params2 = setPairParamsSessionResuming sessionParams params1 + newIORef params2 + + runResumption paramsRef = bench name . nfIO $ do + params2 <- readIORef paramsRef + runTLSPipeSimple params2 d + +benchResumption13 + :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark +benchResumption13 params !d name = env initializeSession runResumption + where + initializeSession = do + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + params1 = setPairParamsSessionManagers sessionManagers params + _ <- runTLSPipeSimple params1 d + newIORef (params1, sessionRefs) + + -- with TLS13 the sessionId is constantly changing so we must update + -- our parameters at each iteration unfortunately + runResumption paramsRef = bench name . nfIO $ do + (params1, sessionRefs) <- readIORef paramsRef + Just sessionParams <- readClientSessionRef sessionRefs + let params2 = setPairParamsSessionResuming sessionParams params1 + runTLSPipeSimple params2 d + +benchCiphers :: String -> Version -> B.ByteString -> [Cipher] -> Benchmark +benchCiphers name connectVer d = bgroup name . map doBench + where + doBench cipher = + benchResumption13 (getParams connectVer cipher) d (cipherName cipher) + +main :: IO () +main = + defaultMain + [ bgroup + "connection" + -- not sure the number actually make sense for anything. improve .. + [ benchConnection (getParams TLS12 blockCipher) small "TLS12-256 bytes" + ] + , bgroup + "resumption" + [ benchResumption (getParams TLS12 blockCipher) small "TLS12-256 bytes" + ] + , -- Here we try to measure TLS12 and TLS13 performance with AEAD ciphers. + -- Resumption and a larger message can be a demonstration of the symmetric + -- crypto but for TLS13 this does not work so well because of dhe_psk. + benchCiphers + "TLS12" + TLS12 + large + [ cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 + , cipher_DHE_RSA_WITH_AES_256_GCM_SHA384 + , cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 + , cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + , cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 + , cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 + ] + , benchCiphers + "TLS13" + TLS13 + large + [ cipher13_AES_128_GCM_SHA256 + , cipher13_AES_256_GCM_SHA384 + , cipher13_CHACHA20_POLY1305_SHA256 + , cipher13_AES_128_CCM_SHA256 + , cipher13_AES_128_CCM_8_SHA256 + ] + ] + where + small = B.replicate 256 0 + large = B.replicate 102400 0 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,18 @@ # Change log for "tls" +## Version 2.1.12 + +* Restore benchmarks. + [#509](https://github.com/haskell-tls/hs-tls/pull/509) +* Supporting random 1.2. + [#508](https://github.com/haskell-tls/hs-tls/pull/508) +* Add --trusted-anchor cli option to tls-client. + [#505](https://github.com/haskell-tls/hs-tls/pull/505) + +## Version 2.1.11 + +* Removing OVERLAPS instances. + ## Version 2.1.10 * Supporting the SSLKEYLOGFILE environment variable. diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -85,7 +85,6 @@ onCertificateRequest, OnServerCertificate, onServerCertificate, - validateClientCertificate, onSuggestALPN, onCustomFFDHEGroup, onServerFinished, @@ -94,6 +93,7 @@ ServerHooks, defaultServerHooks, onClientCertificate, + validateClientCertificate, onUnverifiedClientCert, onCipherChoosing, onServerNameIndication, diff --git a/Network/TLS/Backend.hs b/Network/TLS/Backend.hs --- a/Network/TLS/Backend.hs +++ b/Network/TLS/Backend.hs @@ -44,7 +44,13 @@ instance HasBackend Network.Socket where initializeBackend _ = return () - getBackend sock = Backend (return ()) (Network.close sock) (Network.sendAll sock) recvAll + getBackend sock = + Backend + { backendFlush = return () + , backendClose = Network.close sock + , backendSend = Network.sendAll sock + , backendRecv = recvAll + } where recvAll n = B.concat <$> loop n where @@ -57,4 +63,10 @@ instance HasBackend Handle where initializeBackend handle = hSetBuffering handle NoBuffering - getBackend handle = Backend (hFlush handle) (hClose handle) (B.hPut handle) (B.hGet handle) + getBackend handle = + Backend + { backendFlush = hFlush handle + , backendClose = hClose handle + , backendSend = B.hPut handle + , backendRecv = B.hGet handle + } diff --git a/Network/TLS/Handshake/Client/ClientHello.hs b/Network/TLS/Handshake/Client/ClientHello.hs --- a/Network/TLS/Handshake/Client/ClientHello.hs +++ b/Network/TLS/Handshake/Client/ClientHello.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -12,6 +13,12 @@ import Network.TLS.ECH.Config import System.Random +#if !MIN_VERSION_random(1,3,0) +import Data.ByteString.Internal (unsafeCreate) +import Foreign.Ptr +import Foreign.Storable +#endif + import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Crypto @@ -571,3 +578,17 @@ , echPayload = payload } return $ toExtensionRaw outer + +#if !MIN_VERSION_random(1,3,0) +uniformByteString :: RandomGen g => Int -> g -> (ByteString, g) +uniformByteString l g0 = (bs, g2) + where + (g1, g2) = split g0 + bs = unsafeCreate l $ go 0 g1 + go n g ptr + | n == l = return () + | otherwise = do + let (w, g') = genWord8 g + poke ptr w + go (n + 1) g' (plusPtr ptr 1) +#endif 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 @@ -56,8 +56,14 @@ expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime if not authenticated && serverWantClientCert sparams then runRecvHandshake13 $ do - recvHandshake13 ctx $ expectCertificate sparams ctx - recvHandshake13hash ctx "CertVerify" (expectCertVerify sparams ctx) + -- RFC 8446 Sec 4.4.3: Clients MUST send this message + -- whenever authenticating via a certificate (i.e., when the + -- Certificate message is non-empty). When sent, this message MUST + -- appear immediately after the Certificate message and immediately + -- prior to the Finished message. + skip <- recvHandshake13 ctx $ expectCertificate sparams ctx + unless skip $ + recvHandshake13hash ctx "CertVerify" (expectCertVerify sparams ctx) recvHandshake13hash ctx "Finished" expectFinished' ensureRecvComplete ctx else @@ -105,19 +111,21 @@ expectEndOfEarlyData _ _ hs = unexpected (show hs) (Just "end of early data") expectCertificate - :: MonadIO m => ServerParams -> Context -> Handshake13 -> m () + :: MonadIO m => ServerParams -> Context -> Handshake13 -> m Bool expectCertificate sparams ctx (Certificate13 certCtx (CertificateChain_ certs) _ext) = liftIO $ do when (certCtx /= "") $ throwCore $ Error_Protocol "certificate request context MUST be empty" IllegalParameter -- fixme checking _ext clientCertificate sparams ctx certs + return $ isNullCertificateChain certs expectCertificate sparams ctx (CompressedCertificate13 certCtx (CertificateChain_ certs) _ext) = liftIO $ do when (certCtx /= "") $ throwCore $ Error_Protocol "certificate request context MUST be empty" IllegalParameter -- fixme checking _ext clientCertificate sparams ctx certs + return $ isNullCertificateChain certs expectCertificate _ _ hs = unexpected (show hs) (Just "certificate 13") sendNewSessionTicket diff --git a/test/Certificate.hs b/test/Certificate.hs --- a/test/Certificate.hs +++ b/test/Certificate.hs @@ -9,6 +9,7 @@ arbitraryDN, simpleCertificate, simpleX509, + getSignatureALG, toPubKeyEC, toPrivKeyEC, ) where diff --git a/test/Run.hs b/test/Run.hs --- a/test/Run.hs +++ b/test/Run.hs @@ -15,6 +15,9 @@ runTLSSuccess, runTLSFailure, expectMaybe, + newPairContext, + withDataPipe, + byeBye, ) where import Control.Concurrent @@ -356,3 +359,36 @@ , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) } else defaultLogging + + +withDataPipe :: (ClientParams, ServerParams) -> (Context -> Chan result -> IO ()) -> (Chan start -> Context -> IO ()) -> ((start -> IO (), IO result) -> IO a) -> IO a +withDataPipe params tlsServer tlsClient cont = do + -- initial setup + startQueue <- newChan + resultQueue <- newChan + + (cCtx, sCtx) <- snd <$> newPairContext params + + withAsync (E.catch (tlsServer sCtx resultQueue) + (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) + + where + printAndRaise :: String -> Supported -> E.SomeException -> IO () + printAndRaise s supported e = do + putStrLn $ s ++ " exception: " ++ show e ++ + ", supported: " ++ show supported + E.throwIO e + +-- Terminate the write direction and wait to receive the peer EOF. This is +-- necessary in situations where we want to confirm the peer status, or to make +-- sure to receive late messages like session tickets. In the test suite this +-- is used each time application code ends the connection without prior call to +-- 'recvData'. +byeBye :: Context -> IO () +byeBye ctx = do + bye ctx + bs <- recvData ctx + unless (B.null bs) $ fail "byeBye: unexpected application data" diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tls -version: 2.1.11 +version: 2.1.12 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez @@ -133,7 +133,7 @@ memory >= 0.18 && < 0.19, mtl >= 2.2 && < 2.4, network >= 3.1, - random >= 1.3 && < 1.4, + random >= 1.2 && < 1.4, serialise >= 0.2 && < 0.3, transformers >= 0.5 && < 0.7, unix-time >= 0.4.11 && < 0.5, @@ -233,3 +233,46 @@ else buildable: False + +benchmark tls-bench + main-is: Benchmarks.hs + type: exitcode-stdio-1.0 + other-modules: + API + Arbitrary + Certificate + CiphersSpec + ECHSpec + EncodeSpec + HandshakeSpec + PipeChan + PubKey + Run + Session + ThreadSpec + hs-source-dirs: + Benchmarks + test + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.9 && <5, + bytestring, + base64-bytestring, + containers, + async, + data-default, + hourglass, + crypton, + crypton-x509, + crypton-x509-store, + crypton-x509-validation, + ech-config, + network, + network-run, + tls, + asn1-types, + tasty-bench, + QuickCheck, + serialise, + hspec diff --git a/util/tls-client.hs b/util/tls-client.hs --- a/util/tls-client.hs +++ b/util/tls-client.hs @@ -46,6 +46,7 @@ , optTraceKey :: Bool , optIPv4Only :: Bool , optIPv6Only :: Bool + , optTrustedAnchor :: Maybe FilePath } deriving (Show) @@ -69,6 +70,7 @@ , optTraceKey = False , optIPv4Only = False , optIPv6Only = False + , optTrustedAnchor = Nothing } usage :: String @@ -161,6 +163,11 @@ [] (NoArg (\o -> o{optIPv6Only = True, optIPv4Only = False})) "IPv6 only" + , Option + ['t'] + ["trusted-anchor"] + (ReqArg (\fl o -> o{optTrustedAnchor = Just fl}) "") + "trusted anchor file" ] showUsageAndExit :: String -> IO a @@ -213,8 +220,13 @@ , auxShow = showContent , auxReadResumptionData = readIORef ref } - mstore <- - if optValidate then Just <$> getSystemCertificateStore else return Nothing + mstore <- do + mstore' <- case optTrustedAnchor of + Nothing -> + if optValidate then Just <$> getSystemCertificateStore else return Nothing + Just file -> readCertificateStore file + when (isNothing mstore') $ showUsageAndExit "cannot set trusted anchor" + return mstore' echConfList <- case optECHConfigFile of Nothing -> return [] Just ecnff ->