tls 1.5.8 → 1.6.0
raw patch · 13 files changed
+105/−44 lines, 13 files
Files
- CHANGELOG.md +5/−0
- Network/TLS/Core.hs +9/−5
- Network/TLS/Credentials.hs +1/−1
- Network/TLS/Extension.hs +6/−2
- Network/TLS/Handshake/Client.hs +5/−2
- Network/TLS/Handshake/Common.hs +11/−7
- Network/TLS/Handshake/Common13.hs +22/−0
- Network/TLS/Handshake/Server.hs +29/−15
- Network/TLS/Packet.hs +4/−1
- Network/TLS/QUIC.hs +1/−1
- Network/TLS/Record/Disengage.hs +9/−7
- Tests/Connection.hs +1/−1
- tls.cabal +2/−2
CHANGELOG.md view
@@ -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
Network/TLS/Core.hs view
@@ -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
Network/TLS/Credentials.hs view
@@ -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)
Network/TLS/Extension.hs view
@@ -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
Network/TLS/Handshake/Client.hs view
@@ -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
Network/TLS/Handshake/Common.hs view
@@ -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.
Network/TLS/Handshake/Common13.hs view
@@ -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
Network/TLS/Handshake/Server.hs view
@@ -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.
Network/TLS/Packet.hs view
@@ -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
Network/TLS/QUIC.hs view
@@ -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
Network/TLS/Record/Disengage.hs view
@@ -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 =
Tests/Connection.hs view
@@ -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
tls.cabal view
@@ -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. .