tls 1.3.3 → 1.3.4

raw patch · 8 files changed

+59/−6 lines, 8 filesdep ~memory

Dependency ranges changed: memory

Files

• Network/TLS.hs +3/−0
• Network/TLS/Core.hs +10/−0
• Network/TLS/Handshake/Server.hs +12/−2
• Network/TLS/Parameters.hs +18/−0
• Network/TLS/Sending.hs +2/−2
• Network/TLS/State.hs +12/−0
• Tests/Certificate.hs +1/−1
• tls.cabal +1/−1

@@ -80,6 +80,9 @@     -- * Next Protocol Negotiation     , getNegotiatedProtocol +    -- * Server Name Indication+    , getClientSNI+     -- * High level API     , sendData     , recvData

@@ -20,6 +20,9 @@     -- * Next Protocol Negotiation     , getNegotiatedProtocol +    -- * Server Name Indication+    , getClientSNI+     -- * High level API     , sendData     , recvData@@ -55,6 +58,13 @@ -- return get the protocol agreed upon. getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString) getNegotiatedProtocol ctx = liftIO $ usingState_ ctx S.getNegotiatedProtocol++type HostName = String++-- | If the Server Name Indication extension has been used, return the+-- hostname specified by the client.+getClientSNI :: MonadIO m => Context -> m (Maybe HostName)+getClientSNI ctx = liftIO $ usingState_ ctx S.getClientSNI  -- | sendData sends a bunch of data. -- It will automatically chunk data to acceptable packet size

@@ -28,7 +28,8 @@ import Network.TLS.Handshake.Process import Network.TLS.Handshake.Key import Network.TLS.Measurement-import Data.Maybe (isJust)+import Data.Monoid+import Data.Maybe (isJust, listToMaybe, mapMaybe) import Data.List (intersect, sortBy) import qualified Data.ByteString as B import Data.ByteString.Char8 ()@@ -111,9 +112,16 @@     when (null commonCompressions) $ throwCore $         Error_Protocol ("no compression in common with the client", True, HandshakeFailure) +    let serverName = case extensionDecode False `fmap` (lookup extensionID_ServerName exts) of+            Just (Just (ServerName ns)) -> listToMaybe (mapMaybe toHostName ns)+                where toHostName (ServerNameHostName hostName) = Just hostName+                      toHostName (ServerNameOther _)           = Nothing+            _                           -> Nothing+     let ciphersFilteredVersion = filter (cipherAllowedForVersion chosenVersion) commonCiphers         usedCipher = (onCipherChoosing $ serverHooks sparams) chosenVersion ciphersFilteredVersion-        creds = sharedCredentials $ ctxShared ctx+    extraCreds <- (onServerNameIndication $ serverHooks sparams) serverName+    let creds = extraCreds `mappend` (sharedCredentials $ ctxShared ctx)     cred <- case cipherKeyExchange usedCipher of                 CipherKeyExchange_RSA     -> return $ credentialsFindForDecrypting creds                 CipherKeyExchange_DH_Anon -> return $ Nothing@@ -125,6 +133,8 @@     resumeSessionData <- case clientSession of             (Session (Just clientSessionId)) -> liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId             (Session Nothing)                -> return Nothing++    maybe (return ()) (usingState_ ctx . setClientSNI) serverName      case extensionDecode False `fmap` (lookup extensionID_ApplicationLayerProtocolNegotiation exts) of         Just (Just (ApplicationLayerProtocolNegotiation protos)) -> usingState_ ctx $ setClientALPNSuggest protos

@@ -134,6 +134,13 @@       --   If 'True', servers reject handshakes which suggest       --   a lower protocol than the highest protocol supported.     , supportedFallbackScsv        :: Bool+      -- | In ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed+      -- by an attacker. Hence, an empty packet is normally sent before a normal data packet, to+      -- prevent guessability. Some Microsoft TLS-based protocol implementations, however,+      -- consider these empty packets as a protocol violation and disconnect. If this parameter is+      -- 'False', empty packets will never be added, which is less secure, but might help in rare+      -- cases.+    , supportedEmptyPacket         :: Bool     } deriving (Show,Eq)  defaultSupported :: Supported@@ -152,6 +159,7 @@     , supportedClientInitiatedRenegotiation = False     , supportedSession             = True     , supportedFallbackScsv        = True+    , supportedEmptyPacket         = True     }  instance Default Supported where@@ -239,6 +247,15 @@       -- The client cipher list cannot be empty.     , onCipherChoosing        :: Version -> [Cipher] -> Cipher +      -- | Allow the server to indicate additional credentials+      -- to be used depending on the host name indicated by the+      -- client.+      --+      -- This is most useful for transparent proxies where+      -- credentials must be generated on the fly according to+      -- the host the client is trying to connect to.+    , onServerNameIndication  :: Maybe HostName -> IO Credentials+       -- | suggested next protocols accoring to the next protocol negotiation extension.     , onSuggestNextProtocols  :: IO (Maybe [B.ByteString])       -- | at each new handshake, we call this hook to see if we allow handshake to happens.@@ -251,6 +268,7 @@     { onCipherChoosing       = \_ -> head     , onClientCertificate    = \_ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected"     , onUnverifiedClientCert = return False+    , onServerNameIndication = \_ -> return mempty     , onSuggestNextProtocols = return Nothing     , onNewHandshake         = \_ -> return True     , onALPNClientSuggest    = Nothing

@@ -6,7 +6,7 @@ -- Portability : unknown -- -- the Sending module contains calls related to marshalling packets according--- to the TLS state +-- to the TLS state -- module Network.TLS.Sending (writePacket) where @@ -88,5 +88,5 @@                                       return (v, c)     liftIO $ modifyMVar_ (ctxTxState ctx) (\_ -> return tx)     -- set empty packet counter measure if condition are met-    when (ver <= TLS10 && cc == ClientRole && isCBC tx) $ liftIO $ writeIORef (ctxNeedEmptyPacket ctx) True+    when (ver <= TLS10 && cc == ClientRole && isCBC tx && supportedEmptyPacket (ctxSupported ctx)) $ liftIO $ writeIORef (ctxNeedEmptyPacket ctx) True   where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx)

@@ -45,6 +45,8 @@     , getClientEcPointFormatSuggest     , getClientCertificateChain     , setClientCertificateChain+    , setClientSNI+    , getClientSNI     , getVerifiedData     , setSession     , getSession@@ -67,6 +69,8 @@ import Crypto.Random import Data.X509 (CertificateChain) +type HostName = String+ data TLSState = TLSState     { stSession             :: Session     , stSessionResuming     :: Bool@@ -82,6 +86,7 @@     , stClientEllipticCurveSuggest :: Maybe [NamedCurve]     , stClientEcPointFormatSuggest :: Maybe [EcPointFormat]     , stClientCertificateChain :: Maybe CertificateChain+    , stClientSNI           :: Maybe HostName     , stRandomGen           :: StateRNG     , stVersion             :: Maybe Version     , stClientContext       :: Role@@ -116,6 +121,7 @@     , stClientEllipticCurveSuggest = Nothing     , stClientEcPointFormatSuggest = Nothing     , stClientCertificateChain = Nothing+    , stClientSNI           = Nothing     , stRandomGen           = rng     , stVersion             = Nothing     , stClientContext       = clientContext@@ -237,6 +243,12 @@  getClientCertificateChain :: TLSSt (Maybe CertificateChain) getClientCertificateChain = gets stClientCertificateChain++setClientSNI :: HostName -> TLSSt ()+setClientSNI hn = modify (\st -> st { stClientSNI = Just hn })++getClientSNI :: TLSSt (Maybe HostName)+getClientSNI = gets stClientSNI  getVerifiedData :: Role -> TLSSt Bytes getVerifiedData client = gets (if client == ClientRole then stClientVerifiedData else stServerVerifiedData)

@@ -20,7 +20,7 @@  instance Arbitrary Date where     arbitrary = do-        y <- choose (1951, 2050)+        y <- choose (1971, 2035)         m <- elements [ January .. December]         d <- choose (1, 30)         return $ normalizeDate $ Date y m d

@@ -1,5 +1,5 @@ Name:                tls-Version:             1.3.3+Version:             1.3.4 Description:    Native Haskell TLS and SSL protocol implementation for server and client.    .