diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## Version 1.6.0 + +- Major version up because of disabling SSL3 +- Some fixes against tlsfuzzer + ## Version 1.5.8 - Require mtl-2.2.1 or newer diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -176,7 +176,13 @@ terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason Established -> return x NotEstablished -> throwCore $ Error_Protocol ("data at not-established", True, UnexpectedMessage) - process ChangeCipherSpec13 = recvData13 ctx + process ChangeCipherSpec13 = do + established <- ctxEstablished ctx + if established /= Established then + recvData13 ctx + else do + let reason = "CSS after Finished" + terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason process p = let reason = "unexpected message " ++ show p in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason @@ -272,10 +278,8 @@ -> TLSError -> m B.ByteString onError _ Error_EOF = -- Not really an error. return B.empty -onError terminate err@(Error_Protocol (reason,fatal,desc)) = - terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason -onError terminate err = - terminate err AlertLevel_Fatal InternalError (show err) +onError terminate err = let (lvl,ad) = errorToAlert err + in terminate err lvl ad (errorToAlertMessage err) terminateWithWriteLock :: Context -> ([(AlertLevel, AlertDescription)] -> IO ()) -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a diff --git a/Network/TLS/Credentials.hs b/Network/TLS/Credentials.hs --- a/Network/TLS/Credentials.hs +++ b/Network/TLS/Credentials.hs @@ -32,7 +32,7 @@ type Credential = (CertificateChain, PrivKey) -newtype Credentials = Credentials [Credential] +newtype Credentials = Credentials [Credential] deriving (Show) instance Semigroup Credentials where Credentials l1 <> Credentials l2 = Credentials (l1 ++ l2) diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -483,7 +483,10 @@ decodeSignatureAlgorithms :: ByteString -> Maybe SignatureAlgorithms decodeSignatureAlgorithms = runGetMaybe $ do len <- getWord16 - SignatureAlgorithms <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) + sas <- getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) + leftoverLen <- remaining + when (leftoverLen /= 0) $ fail "decodeSignatureAlgorithms: broken length" + return $ SignatureAlgorithms sas ------------------------------------------------------------ @@ -544,7 +547,7 @@ data KeyShareEntry = KeyShareEntry { keyShareEntryGroup :: Group - , keySHareEntryKeyExchange:: ByteString + , keyShareEntryKeyExchange :: ByteString } deriving (Show,Eq) getKeyShareEntry :: Get (Int, Maybe KeyShareEntry) @@ -584,6 +587,7 @@ Just ent -> return $ KeyShareServerHello ent extensionDecode MsgTClientHello = runGetMaybe $ do len <- fromIntegral <$> getWord16 +-- len == 0 allows for HRR grps <- getList len getKeyShareEntry return $ KeyShareClientHello $ catMaybes grps extensionDecode MsgTHelloRetryRequest = runGetMaybe $ do diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -648,7 +648,8 @@ -- onServerHello :: Context -> ClientParams -> Session -> [ExtensionID] -> Handshake -> IO (RecvState IO) onServerHello ctx cparams clientSession sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do - when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) + when (rver == SSL2) $ throwCore $ Error_Protocol ("SSL2 is not supported", True, ProtocolVersion) + when (rver == SSL3) $ throwCore $ Error_Protocol ("SSL3 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 Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, IllegalParameter) @@ -913,9 +914,11 @@ mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareServerHello ks) -> return ks - Just _ -> error "calcSharedKey: invalid KeyShare value" + Just _ -> throwCore $ Error_Protocol ("invalid key_share value", True, IllegalParameter) Nothing -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure) let grp = keyShareEntryGroup serverKeyShare + unless (checkKeyShareKeyLength serverKeyShare) $ + throwCore $ Error_Protocol ("broken key_share", True, IllegalParameter) unless (groupSent == Just grp) $ throwCore $ Error_Protocol ("received incompatible group for (EC)DHE", True, IllegalParameter) usingHState ctx $ setNegotiatedGroup grp diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -63,19 +63,23 @@ handle ignoreIOErr $ do tls13 <- tls13orLater ctx if tls13 then - sendPacket13 ctx $ Alert13 $ errorToAlert tlserror + sendPacket13 ctx $ Alert13 [errorToAlert tlserror] else - sendPacket ctx $ Alert $ errorToAlert tlserror + sendPacket ctx $ Alert [errorToAlert tlserror] handshakeFailed tlserror where ignoreIOErr :: IOException -> IO () ignoreIOErr _ = return () -errorToAlert :: TLSError -> [(AlertLevel, AlertDescription)] -errorToAlert (Error_Protocol (_, _, ad)) = [(AlertLevel_Fatal, ad)] -errorToAlert (Error_Packet_unexpected _ _) = [(AlertLevel_Fatal, UnexpectedMessage)] -errorToAlert (Error_Packet_Parsing _) = [(AlertLevel_Fatal, DecodeError)] -errorToAlert _ = [(AlertLevel_Fatal, InternalError)] +errorToAlert :: TLSError -> (AlertLevel, AlertDescription) +errorToAlert (Error_Protocol (_, b, ad)) = let lvl = if b then AlertLevel_Fatal else AlertLevel_Warning + in (lvl, ad) +errorToAlert (Error_Packet_unexpected _ _) = (AlertLevel_Fatal, UnexpectedMessage) +errorToAlert (Error_Packet_Parsing msg) + | "invalid version" `isInfixOf` msg = (AlertLevel_Fatal, ProtocolVersion) + | "request_update" `isInfixOf` msg = (AlertLevel_Fatal, IllegalParameter) + | otherwise = (AlertLevel_Fatal, DecodeError) +errorToAlert _ = (AlertLevel_Fatal, InternalError) -- | Return the message that a TLS endpoint can add to its local log for the -- specified library error. diff --git a/Network/TLS/Handshake/Common13.hs b/Network/TLS/Handshake/Common13.hs --- a/Network/TLS/Handshake/Common13.hs +++ b/Network/TLS/Handshake/Common13.hs @@ -42,6 +42,7 @@ , calculateApplicationSecret , calculateResumptionSecret , derivePSK + , checkKeyShareKeyLength ) where import qualified Data.ByteArray as BA @@ -87,6 +88,7 @@ checkFinished :: MonadIO m => Context -> Hash -> ByteString -> ByteString -> ByteString -> m () checkFinished ctx usedHash baseKey hashValue verifyData = do let verifyData' = makeVerifyData usedHash baseKey hashValue + when (B.length verifyData /= B.length verifyData') $ throwCore $ Error_Protocol ("broken Finished", True, DecodeError) unless (verifyData' == verifyData) $ decryptError "cannot verify finished" liftIO $ writeIORef (ctxPeerFinished ctx) (Just verifyData) @@ -505,3 +507,23 @@ where usedHash = cHash choice hashSize = hashDigestSize usedHash + +---------------------------------------------------------------- + +checkKeyShareKeyLength :: KeyShareEntry -> Bool +checkKeyShareKeyLength ks = keyShareKeyLength grp == B.length key + where + grp = keyShareEntryGroup ks + key = keyShareEntryKeyExchange ks + +keyShareKeyLength :: Group -> Int +keyShareKeyLength P256 = 65 -- 32 * 2 + 1 +keyShareKeyLength P384 = 97 -- 48 * 2 + 1 +keyShareKeyLength P521 = 133 -- 66 * 2 + 1 +keyShareKeyLength X25519 = 32 +keyShareKeyLength X448 = 56 +keyShareKeyLength FFDHE2048 = 256 +keyShareKeyLength FFDHE3072 = 384 +keyShareKeyLength FFDHE4096 = 512 +keyShareKeyLength FFDHE6144 = 768 +keyShareKeyLength FFDHE8192 = 1024 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 @@ -107,7 +107,7 @@ -- rejecting SSL2. RFC 6176 when (legacyVersion == SSL2) $ throwCore $ Error_Protocol ("SSL 2.0 is not supported", True, ProtocolVersion) -- rejecting SSL3. RFC 7568 - -- when (legacyVersion == SSL3) $ throwCore $ Error_Protocol ("SSL 3.0 is not supported", True, ProtocolVersion) + when (legacyVersion == SSL3) $ throwCore $ Error_Protocol ("SSL 3.0 is not supported", True, ProtocolVersion) -- Fallback SCSV: RFC7507 -- TLS_FALLBACK_SCSV: {0x56, 0x00} @@ -117,7 +117,7 @@ throwCore $ Error_Protocol ("fallback is not allowed", True, InappropriateFallback) -- choosing TLS version let clientVersions = case extensionLookup extensionID_SupportedVersions exts >>= extensionDecode MsgTClientHello of - Just (SupportedVersionsClientHello vers) -> vers + Just (SupportedVersionsClientHello vers) -> vers -- fixme: vers == [] _ -> [] clientVersion = min TLS12 legacyVersion serverVersions @@ -686,22 +686,34 @@ -- status again if 0-RTT successful setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding -- Deciding key exchange from key shares - keyShares <- case extensionLookup extensionID_KeyShare exts >>= extensionDecode MsgTClientHello of - Just (KeyShareClientHello kses) -> return kses - Just _ -> error "handshakeServerWithTLS13: invalid KeyShare value" - _ -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure) - case findKeyShare keyShares serverGroups of + keyShares <- case extensionLookup extensionID_KeyShare exts of + Nothing -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, MissingExtension) + Just kss -> case extensionDecode MsgTClientHello kss of + Just (KeyShareClientHello kses) -> return kses + Just _ -> error "handshakeServerWithTLS13: invalid KeyShare value" + _ -> throwCore $ Error_Protocol ("broken key_share", True, DecodeError) + mshare <- findKeyShare keyShares serverGroups + case mshare of Nothing -> helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession Just keyShare -> doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash keyShare clientSession rtt0 where ciphersFilteredVersion = filter ((`elem` clientCiphers) . cipherID) serverCiphers serverCiphers = filter (cipherAllowedForVersion chosenVersion) (supportedCiphers $ serverSupported sparams) serverGroups = supportedGroups (ctxSupported ctx) - findKeyShare _ [] = Nothing - findKeyShare ks (g:gs) = case find (\ent -> keyShareEntryGroup ent == g) ks of - Just k -> Just k - Nothing -> findKeyShare ks gs +findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry) +findKeyShare ks ggs = go ggs + where + go [] = return Nothing + go (g:gs) = case filter (grpEq g) ks of + [] -> go gs + [k] -> do + unless (checkKeyShareKeyLength k) $ + throwCore $ Error_Protocol ("broken key_share", True, IllegalParameter) + return $ Just k + _ -> throwCore $ Error_Protocol ("duplicated key_share", True, IllegalParameter) + grpEq g ent = g == keyShareEntryGroup ent + doHandshake13 :: ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> Hash -> KeyShareEntry @@ -876,9 +888,11 @@ return [ExtensionRaw extensionID_PreSharedKey selectedIdentity] decideCredentialInfo allCreds = do - cHashSigs <- case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode MsgTClientHello of + cHashSigs <- case extensionLookup extensionID_SignatureAlgorithms exts of Nothing -> throwCore $ Error_Protocol ("no signature_algorithms extension", True, MissingExtension) - Just (SignatureAlgorithms sas) -> return sas + Just sa -> case extensionDecode MsgTClientHello sa of + Nothing -> throwCore $ Error_Protocol ("broken signature_algorithms extension", True, DecodeError) + Just (SignatureAlgorithms sas) -> return sas -- When deciding signature algorithm and certificate, we try to keep -- certificates supported by the client, but fallback to all credentials -- if this produces no suitable result (see RFC 5246 section 7.4.2 and @@ -1070,7 +1084,7 @@ v:_ -> Just v where svs = sortOn Down serverVersions - cvs = sortOn Down clientVersions + cvs = sortOn Down $ filter (> SSL3) clientVersions applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw] applicationProtocol ctx exts sparams = do @@ -1095,7 +1109,7 @@ where loop [] = Nothing loop (hs:hss) = case credentialsFindForSigning13' hs creds of - Nothing -> credentialsFindForSigning13 hss creds + Nothing -> loop hss Just cred -> Just (cred, hs) -- See credentialsFindForSigning. diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -229,7 +229,10 @@ r <- remaining exts <- if hasHelloExtensions ver && r > 0 then fromIntegral <$> getWord16 >>= getExtensions - else return [] + else do + rest <- remaining + _ <- getBytes rest + return [] return $ ClientHello ver random session ciphers compressions exts Nothing decodeServerHello :: Get Handshake diff --git a/Network/TLS/QUIC.hs b/Network/TLS/QUIC.hs --- a/Network/TLS/QUIC.hs +++ b/Network/TLS/QUIC.hs @@ -237,7 +237,7 @@ -- | Return the alert that a TLS endpoint would send to the peer for the -- specified library error. errorToAlertDescription :: TLSError -> AlertDescription -errorToAlertDescription = snd . head . errorToAlert +errorToAlertDescription = snd . errorToAlert -- | Encode an alert to the assigned value. fromAlertDescription :: AlertDescription -> Word8 diff --git a/Network/TLS/Record/Disengage.hs b/Network/TLS/Record/Disengage.hs --- a/Network/TLS/Record/Disengage.hs +++ b/Network/TLS/Record/Disengage.hs @@ -57,13 +57,15 @@ decryptData mver record e st where noDecryption = onRecordFragment record $ fragmentUncipher return - decryptData13 mver e st - | ct == ProtocolType_AppData = do - inner <- decryptData mver record e st - case unInnerPlaintext inner of - Left message -> throwError $ Error_Protocol (message, True, UnexpectedMessage) - Right (ct', d) -> return $ Record ct' ver (fragmentCompressed d) - | otherwise = noDecryption + decryptData13 mver e st = case ct of + ProtocolType_AppData -> do + inner <- decryptData mver record e st + case unInnerPlaintext inner of + Left message -> throwError $ Error_Protocol (message, True, UnexpectedMessage) + Right (ct', d) -> return $ Record ct' ver (fragmentCompressed d) + ProtocolType_ChangeCipherSpec -> noDecryption + ProtocolType_Alert -> noDecryption + _ -> throwError $ Error_Protocol ("illegal plain text", True, UnexpectedMessage) unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString) unInnerPlaintext inner = diff --git a/Tests/Connection.hs b/Tests/Connection.hs --- a/Tests/Connection.hs +++ b/Tests/Connection.hs @@ -67,7 +67,7 @@ arbitraryCiphers = listOf1 $ elements knownCiphers knownVersions :: [Version] -knownVersions = [TLS13,TLS12,TLS11,TLS10,SSL3] +knownVersions = [TLS13,TLS12,TLS11,TLS10] arbitraryVersions :: Gen [Version] arbitraryVersions = sublistOf knownVersions diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,5 +1,5 @@ Name: tls -Version: 1.5.8 +Version: 1.6.0 Description: Native Haskell TLS and SSL protocol implementation for server and client. . @@ -7,7 +7,7 @@ eliminating a common set of security issues through the use of the advanced type system, high level constructions and common Haskell features. . - Currently implement the SSL3.0, TLS1.0, TLS1.1, TLS1.2 and TLS 1.3 protocol, + Currently implement the TLS1.0, TLS1.1, TLS1.2 and TLS 1.3 protocol, and support RSA and Ephemeral (Elliptic curve and regular) Diffie Hellman key exchanges, and many extensions. .