diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -80,6 +80,9 @@ -- * Next Protocol Negotiation , getNegotiatedProtocol + -- * Server Name Indication + , getClientSNI + -- * High level API , sendData , recvData diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -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 diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -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 diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -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 diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs --- a/Network/TLS/Sending.hs +++ b/Network/TLS/Sending.hs @@ -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) diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -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) diff --git a/Tests/Certificate.hs b/Tests/Certificate.hs --- a/Tests/Certificate.hs +++ b/Tests/Certificate.hs @@ -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 diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -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. .