Downgrade protection

core/Network/TLS/Handshake/Client.hs

@@ -19,7 +19,6 @@ import Network.TLS.Struct13
 import Network.TLS.Cipher
 import Network.TLS.Compression
 import Network.TLS.Packet hiding (getExtensions)
-import Network.TLS.Packet13
 import Network.TLS.ErrT
 import Network.TLS.Extension
 import Network.TLS.IO
@@ -42,6 +41,7 @@ import Network.TLS.Handshake.Process
 import Network.TLS.Handshake.Certificate
 import Network.TLS.Handshake.Signature
 import Network.TLS.Handshake.Key
+import Network.TLS.Handshake.Random
 import Network.TLS.Handshake.State
 import Network.TLS.Handshake.State13
 import Network.TLS.KeySchedule
@@ -62,6 +62,13 @@ handshakeClient cparams ctx = do
                   Just grp -> [grp]
     handshakeClient' cparams ctx groups Nothing
 
+-- https://tools.ietf.org/html/rfc8446#section-4.1.2 says:
+-- "The client will also send a
+--  ClientHello when the server has responded to its ClientHello with a
+--  HelloRetryRequest.  In that case, the client MUST send the same
+--  ClientHello without modification, except as follows:"
+--
+-- So, the ClientRandom in the first client hello is necessary.
 handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe ClientRandom -> IO ()
 handshakeClient' cparams ctx groups mcrand = do
     -- putStr $ "groups = " ++ show groups ++ ", keyshare = ["
@@ -225,10 +232,7 @@ handshakeClient' cparams ctx groups mcrand = do
                       return exts'
 
         sendClientHello mcr = do
-            -- fixme -- "44 4F 57 4E 47 52 44 01"
-            crand <- case mcr of
-              Nothing -> ClientRandom <$> getStateRNG ctx 32
-              Just cr -> return cr
+            crand <- clientRandom ctx mcr
             let ver = if tls13 then TLS12 else highestVer
             hrr <- usingState_ ctx getTLS13HRR
             unless hrr $ startHandshake ctx ver crand
@@ -465,6 +469,8 @@ throwMiscErrorOnException msg e =
 --
 onServerHello :: Context -> ClientParams -> [ExtensionID] -> Handshake -> IO (RecvState IO)
 onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do
+    when (isDowngraded (supportedVersions $ clientSupported cparams) serverRan) $
+        throwCore $ Error_Protocol ("verion downgrade detected", True, IllegalParameter)
     when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)
     -- find the compression and cipher methods that the server want to use.
     cipherAlg <- case find ((==) cipher . cipherID) (supportedCiphers $ ctxSupported ctx) of
@@ -486,7 +492,7 @@ onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cip
             case clientWantSessionResume cparams of
                 Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing
                 Nothing                       -> Nothing
-        isHRR = serverRan == hrrRandom
+        isHRR = isHelloRetryRequest serverRan
     usingState_ ctx $ do
         setTLS13HRR isHRR
         case extensionLookup extensionID_Cookie exts >>= extensionDecode MsgTServerHello of

core/Network/TLS/Handshake/Random.hs

@@ -0,0 +1,63 @@
+-- |
+-- Module      : Network.TLS.Handshake.Random
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+module Network.TLS.Handshake.Random (
+      serverRandom
+    , clientRandom
+    , hrrRandom
+    , isHelloRetryRequest
+    , isDowngraded
+    ) where
+
+import qualified Data.ByteString as B
+import Network.TLS.Context.Internal
+import Network.TLS.Struct
+
+serverRandom :: Context -> Version -> [Version] -> IO ServerRandom
+serverRandom ctx chosenVer suppVers
+  | TLS13 `elem` suppVers = case chosenVer of
+      TLS13  -> ServerRandom <$> getStateRNG ctx 32
+      TLS12  -> ServerRandom <$> genServRand suffix12
+      _      -> ServerRandom <$> genServRand suffix11
+  | TLS12 `elem` suppVers = case chosenVer of
+      TLS12  -> ServerRandom <$> getStateRNG ctx 32
+      _      -> ServerRandom <$> genServRand suffix11
+  | otherwise = ServerRandom <$> getStateRNG ctx 32
+  where
+    genServRand suff = do
+        pref <- getStateRNG ctx 24
+        return $ (pref `B.append` suff)
+
+isDowngraded :: [Version] -> ServerRandom -> Bool
+isDowngraded suppVers (ServerRandom sr)
+  | TLS13 `elem` suppVers = suffix12 `B.isSuffixOf` sr
+                         || suffix11 `B.isSuffixOf` sr
+  | TLS12 `elem` suppVers = suffix11 `B.isSuffixOf` sr
+  | otherwise             = False
+
+suffix12 :: B.ByteString
+suffix12 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x01]
+
+suffix11 :: B.ByteString
+suffix11 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x00]
+
+-- ClientRandom in the second client hello for retry must be
+-- the same as the first one.
+clientRandom :: Context -> Maybe ClientRandom -> IO ClientRandom
+clientRandom ctx Nothing   = ClientRandom <$> getStateRNG ctx 32
+clientRandom _   (Just cr) = return cr
+
+hrrRandom :: ServerRandom
+hrrRandom = ServerRandom $ B.pack [
+    0xCF, 0x21, 0xAD, 0x74, 0xE5, 0x9A, 0x61, 0x11
+  , 0xBE, 0x1D, 0x8C, 0x02, 0x1E, 0x65, 0xB8, 0x91
+  , 0xC2, 0xA2, 0x11, 0x16, 0x7A, 0xBB, 0x8C, 0x5E
+  , 0x07, 0x9E, 0x09, 0xE2, 0xC8, 0xA8, 0x33, 0x9C
+  ]
+
+isHelloRetryRequest :: ServerRandom -> Bool
+isHelloRetryRequest = (== hrrRandom)

core/Network/TLS/Handshake/Server.hs

@@ -17,7 +17,6 @@ import Network.TLS.Context.Internal
 import Network.TLS.Session
 import Network.TLS.Struct
 import Network.TLS.Struct13
-import Network.TLS.Packet13
 import Network.TLS.Cipher
 import Network.TLS.Compression
 import Network.TLS.Credentials
@@ -31,6 +30,7 @@ import Network.TLS.State
 import Network.TLS.Handshake.State
 import Network.TLS.Handshake.Process
 import Network.TLS.Handshake.Key
+import Network.TLS.Handshake.Random
 import Network.TLS.Measurement
 import qualified Data.ByteString as B
 import Data.IORef (writeIORef)
@@ -119,7 +119,10 @@ handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientS
             Just (SupportedVersionsClientHello vers) -> vers
             _                                        -> []
         serverVersions = supportedVersions $ ctxSupported ctx
-    chosenVersion <-
+        mVersion = debugVersionForced $ serverDebug sparams
+    chosenVersion <- case mVersion of
+      Just cver -> return cver
+      Nothing   ->
         if (TLS13 `elem` serverVersions) && clientVersion == TLS12 && clientVersions /= [] then case findHighestVersionFrom13 clientVersions serverVersions of
                   Nothing -> throwCore $ Error_Protocol ("client versions " ++ show clientVersions ++ " is not supported", True, ProtocolVersion)
                   Just v  -> return v
@@ -147,6 +150,8 @@ handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientS
     if chosenVersion <= TLS12 then
         handshakeServerWithTLS12 sparams ctx chosenVersion allCreds exts ciphers serverName clientVersion compressions clientSession
       else
+        -- fixme: we should check if the client random is the same as
+        -- that in the first client hello in the case of hello retry.
         handshakeServerWithTLS13 sparams ctx chosenVersion allCreds exts ciphers serverName clientSession
 handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure)
 
@@ -313,7 +318,7 @@ doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSes
         --
         ---
         makeServerHello session = do
-            srand <- ServerRandom <$> getStateRNG ctx 32
+            srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams
             case mcred of
                 Just (_, privkey) -> usingHState ctx $ setPrivateKey privkey
                 _                 -> return () -- return a sensible error
@@ -819,7 +824,7 @@ doHandshake13 sparams (certChain, privKey) ctx chosenVersion usedCipher exts use
         setPendingActions ctx [finishedAction]
   where
     setServerParameter = do
-        srand <- ServerRandom <$> getStateRNG ctx 32
+        srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams
         usingHState ctx $ setPrivateKey privKey
         usingState_ ctx $ setVersion chosenVersion
         usingHState ctx $ setHelloParameters13 usedCipher False

core/Network/TLS/Packet13.hs

@@ -14,7 +14,6 @@ module Network.TLS.Packet13
        , getHandshakeType13
        , decodeHandshakeRecord13
        , decodeHandshake13
-       , hrrRandom
        ) where
 
 import qualified Data.ByteString as B
@@ -151,11 +150,3 @@ decodeKeyUpdate13 = do
         0 -> return $ KeyUpdate13 UpdateNotRequested
         1 -> return $ KeyUpdate13 UpdateRequested
         x -> fail $ "Unknown request_update: " ++ show x
-
-hrrRandom :: ServerRandom
-hrrRandom = ServerRandom $ B.pack [
-    0xCF, 0x21, 0xAD, 0x74, 0xE5, 0x9A, 0x61, 0x11
-  , 0xBE, 0x1D, 0x8C, 0x02, 0x1E, 0x65, 0xB8, 0x91
-  , 0xC2, 0xA2, 0x11, 0x16, 0x7A, 0xBB, 0x8C, 0x5E
-  , 0x07, 0x9E, 0x09, 0xE2, 0xC8, 0xA8, 0x33, 0x9C
-  ]

core/Network/TLS/Parameters.hs

@@ -53,12 +53,15 @@ data DebugParams = DebugParams
       -- | Add a way to print the seed that was randomly generated. re-using the same seed
       -- will reproduce the same randomness with 'debugSeed'
     , debugPrintSeed :: Seed -> IO ()
+      -- | Force to choose this version in the server side.
+    , debugVersionForced :: Maybe Version
     }
 
 defaultDebugParams :: DebugParams
 defaultDebugParams = DebugParams
     { debugSeed = Nothing
     , debugPrintSeed = const (return ())
+    , debugVersionForced = Nothing
     }
 
 instance Show DebugParams where

core/Network/TLS/Struct.hs

@@ -41,8 +41,6 @@ module Network.TLS.Struct
     , Header(..)
     , ServerRandom(..)
     , ClientRandom(..)
-    , serverRandom
-    , clientRandom
     , FinishedData
     , SessionID
     , Session(..)
@@ -60,7 +58,6 @@ module Network.TLS.Struct
     , typeOfHandshake
     ) where
 
-import qualified Data.ByteString as B (length)
 import Data.X509 (CertificateChain, DistinguishedName)
 import Data.Typeable
 import Control.Exception (Exception(..))
@@ -191,15 +188,6 @@ data ExtensionRaw = ExtensionRaw ExtensionID ByteString
 instance Show ExtensionRaw where
     show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs ++ ""
 
-constrRandom32 :: (ByteString -> a) -> ByteString -> Maybe a
-constrRandom32 constr l = if B.length l == 32 then Just (constr l) else Nothing
-
-serverRandom :: ByteString -> Maybe ServerRandom
-serverRandom l = constrRandom32 ServerRandom l
-
-clientRandom :: ByteString -> Maybe ClientRandom
-clientRandom l = constrRandom32 ClientRandom l
-
 data AlertLevel =
       AlertLevel_Warning
     | AlertLevel_Fatal

core/Tests/Tests.hs

@@ -180,6 +180,14 @@ prop_handshake_keyupdate = do
     params <- pick arbitraryPairParams
     runTLSPipeSimpleKeyUpdate params
 
+prop_handshake13_downgrade :: PropertyM IO ()
+prop_handshake13_downgrade = do
+    (cparam,sparam) <- pick arbitraryPairParams13
+    versionForced <- pick $ elements [TLS11,TLS12]
+    let debug' = (serverDebug sparam) { debugVersionForced = Just versionForced }
+        sparam' = sparam { serverDebug = debug' }
+    runTLSInitFailure (cparam,sparam')
+
 prop_handshake13_full :: PropertyM IO ()
 prop_handshake13_full = do
     (cli, srv) <- pick arbitraryPairParams13
@@ -674,6 +682,7 @@ main = defaultMain $ testGroup "tls"
             , testProperty "Initiation" (monadicIO prop_handshake_initiate)
             , testProperty "Initiation 1.3" (monadicIO prop_handshake13_initiate)
             , testProperty "Key update 1.3" (monadicIO prop_handshake_keyupdate)
+            , testProperty "Downgrade protection" (monadicIO prop_handshake13_downgrade)
             , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures)
             , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites)
             , testProperty "Groups" (monadicIO prop_handshake_groups)

core/tls.cabal

@@ -92,6 +92,7 @@ Library
                      Network.TLS.Handshake.Client
                      Network.TLS.Handshake.Server
                      Network.TLS.Handshake.Process
+                     Network.TLS.Handshake.Random
                      Network.TLS.Handshake.Signature
                      Network.TLS.Handshake.State
                      Network.TLS.Handshake.State13