tls 1.8.0 → 1.9.0
raw patch · 17 files changed
+145/−161 lines, 17 files
Files
- CHANGELOG.md +6/−0
- Network/TLS/Core.hs +4/−4
- Network/TLS/Handshake/Certificate.hs +6/−6
- Network/TLS/Handshake/Client.hs +47/−74
- Network/TLS/Handshake/Common.hs +11/−13
- Network/TLS/Handshake/Common13.hs +7/−7
- Network/TLS/Handshake/Key.hs +2/−2
- Network/TLS/Handshake/Process.hs +5/−5
- Network/TLS/Handshake/Server.hs +33/−33
- Network/TLS/Handshake/Signature.hs +2/−2
- Network/TLS/Handshake/State13.hs +1/−1
- Network/TLS/IO.hs +1/−1
- Network/TLS/QUIC.hs +3/−3
- Network/TLS/Record/Disengage.hs +6/−6
- Network/TLS/Record/Reading.hs +2/−2
- Network/TLS/Struct.hs +8/−1
- tls.cabal +1/−1
CHANGELOG.md view
@@ -1,3 +1,9 @@+## Version 1.9.0++* BREAKING CHANGE: The type of the `Error_Protocol` constructor of `TLSError` has changed.+ The "warning" case has been split off into a new `Error_Protocol_Warning` constructor.+ [#460](https://github.com/haskell-tls/hs-tls/pull/460)+ ## Version 1.8.0 * BREAKING CHANGE: Remove `Exception` instance for `TLSError`.
Network/TLS/Core.hs view
@@ -133,7 +133,7 @@ process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty process (Alert [(AlertLevel_Fatal, desc)]) = do setEOF ctx- E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc)))+ E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol "remote side fatal error" desc)) -- when receiving empty appdata, we just retry to get some data. process (AppData "") = recvData1 ctx@@ -151,7 +151,7 @@ process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty process (Alert13 [(AlertLevel_Fatal, desc)]) = do setEOF ctx- E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc)))+ E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol "remote side fatal error" desc)) process (Handshake13 hs) = do loopHandshake13 hs recvData13 ctx@@ -176,7 +176,7 @@ let reason = "early data deprotect overflow" in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason Established -> return x- NotEstablished -> throwCore $ Error_Protocol ("data at not-established", True, UnexpectedMessage)+ NotEstablished -> throwCore $ Error_Protocol "data at not-established" UnexpectedMessage process ChangeCipherSpec13 = do established <- ctxEstablished ctx if established /= Established then@@ -309,7 +309,7 @@ keyUpdate ctx getState setState = do (usedHash, usedCipher, level, applicationSecretN) <- getState ctx unless (level == CryptApplicationSecret) $- throwCore $ Error_Protocol ("tried key update without application traffic secret", True, InternalError)+ throwCore $ Error_Protocol "tried key update without application traffic secret" InternalError let applicationSecretN1 = hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $ hashDigestSize usedHash setState ctx usedHash usedCipher (AnyTrafficSecret applicationSecretN1)
Network/TLS/Handshake/Certificate.hs view
@@ -24,18 +24,18 @@ -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected :: MonadIO m => CertificateRejectReason -> m a certificateRejected CertificateRejectRevoked =- throwCore $ Error_Protocol ("certificate is revoked", True, CertificateRevoked)+ throwCore $ Error_Protocol "certificate is revoked" CertificateRevoked certificateRejected CertificateRejectExpired =- throwCore $ Error_Protocol ("certificate has expired", True, CertificateExpired)+ throwCore $ Error_Protocol "certificate has expired" CertificateExpired certificateRejected CertificateRejectUnknownCA =- throwCore $ Error_Protocol ("certificate has unknown CA", True, UnknownCa)+ throwCore $ Error_Protocol "certificate has unknown CA" UnknownCa certificateRejected CertificateRejectAbsent =- throwCore $ Error_Protocol ("certificate is missing", True, CertificateRequired)+ throwCore $ Error_Protocol "certificate is missing" CertificateRequired certificateRejected (CertificateRejectOther s) =- throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown)+ throwCore $ Error_Protocol ("certificate rejected: " ++ s) CertificateUnknown badCertificate :: MonadIO m => String -> m a-badCertificate msg = throwCore $ Error_Protocol (msg, True, BadCertificate)+badCertificate msg = throwCore $ Error_Protocol msg BadCertificate rejectOnException :: SomeException -> IO CertificateUsage rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e
Network/TLS/Handshake/Client.hs view
@@ -51,7 +51,7 @@ handshakeClientWith :: ClientParams -> Context -> Handshake -> IO () handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx-handshakeClientWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeClientWith", True, HandshakeFailure)+handshakeClientWith _ _ _ = throwCore $ Error_Protocol "unexpected handshake message received in handshakeClientWith" HandshakeFailure -- client part of handshake. send a bunch of handshake of client -- values intertwined with response from the server.@@ -80,17 +80,17 @@ recvServerHello clientSession sentExtensions ver <- usingState_ ctx getVersion unless (maybe True (\(_, _, v) -> v == ver) mparams) $- throwCore $ Error_Protocol ("version changed after hello retry", True, IllegalParameter)+ throwCore $ Error_Protocol "version changed after hello retry" IllegalParameter -- recvServerHello sets TLS13HRR according to the server random. -- For 1st server hello, getTLS13HR returns True if it is HRR and False otherwise. -- For 2nd server hello, getTLS13HR returns False since it is NOT HRR. hrr <- usingState_ ctx getTLS13HRR if ver == TLS13 then if hrr then case drop 1 groups of- [] -> throwCore $ Error_Protocol ("group is exhausted in the client side", True, IllegalParameter)+ [] -> throwCore $ Error_Protocol "group is exhausted in the client side" IllegalParameter groups' -> do when (isJust mparams) $- throwCore $ Error_Protocol ("server sent too many hello retries", True, UnexpectedMessage)+ throwCore $ Error_Protocol "server sent too many hello retries" UnexpectedMessage mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareHRR selectedGroup)@@ -100,14 +100,14 @@ let cparams' = cparams { clientEarlyData = Nothing } runPacketFlight ctx $ sendChangeCipherSpec13 ctx handshakeClient' cparams' ctx [selectedGroup] (Just (crand, clientSession, ver))- | otherwise -> throwCore $ Error_Protocol ("server-selected group is not supported", True, IllegalParameter)+ | otherwise -> throwCore $ Error_Protocol "server-selected group is not supported" IllegalParameter Just _ -> error "handshakeClient': invalid KeyShare value"- Nothing -> throwCore $ Error_Protocol ("key exchange not implemented in HRR, expected key_share extension", True, HandshakeFailure)+ Nothing -> throwCore $ Error_Protocol "key exchange not implemented in HRR, expected key_share extension" HandshakeFailure else handshakeClient13 cparams ctx groupToSend else do when rtt0 $- throwCore $ Error_Protocol ("server denied TLS 1.3 when connecting with early data", True, HandshakeFailure)+ throwCore $ Error_Protocol "server denied TLS 1.3 when connecting with early data" HandshakeFailure sessionResuming <- usingState_ ctx isSessionResuming if sessionResuming then sendChangeCipherAndFinish ctx ClientRole@@ -336,7 +336,7 @@ else throwAlert a _ -> throwAlert a _ -> unexpected (show p) (Just "handshake")- throwAlert a = throwCore $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure)+ throwAlert a = throwCore $ Error_Protocol ("expecting server hello, got alert : " ++ show a) HandshakeFailure -- | Store the keypair and check that it is compatible with the current protocol -- version and a list of 'CertificateType' values.@@ -347,16 +347,10 @@ storePrivInfoClient ctx cTypes (cc, privkey) = do pubkey <- storePrivInfo ctx cc privkey unless (certificateCompatible pubkey cTypes) $- throwCore $ Error_Protocol- ( pubkeyType pubkey ++ " credential does not match allowed certificate types"- , True- , InternalError )+ throwCore $ Error_Protocol (pubkeyType pubkey ++ " credential does not match allowed certificate types") InternalError ver <- usingState_ ctx getVersion unless (pubkey `versionCompatible` ver) $- throwCore $ Error_Protocol- ( pubkeyType pubkey ++ " credential is not supported at version " ++ show ver- , True- , InternalError )+ throwCore $ Error_Protocol (pubkeyType pubkey ++ " credential is not supported at version " ++ show ver) InternalError -- | When the server requests a client certificate, we try to -- obtain a suitable certificate chain and private key via the@@ -456,11 +450,7 @@ <*> flip elem hashSigs case find want cHashSigs of Just best -> return best- Nothing -> throwCore $ Error_Protocol- ( keyerr pubKey- , True- , HandshakeFailure- )+ Nothing -> throwCore $ Error_Protocol (keyerr pubKey) HandshakeFailure where keyerr k = "no " ++ pubkeyType k ++ " hash algorithm in common with the server" @@ -535,7 +525,7 @@ CipherKeyExchange_DHE_DSS -> getCKX_DHE CipherKeyExchange_ECDHE_RSA -> getCKX_ECDHE CipherKeyExchange_ECDHE_ECDSA -> getCKX_ECDHE- _ -> throwCore $ Error_Protocol ("client key exchange unsupported type", True, HandshakeFailure)+ _ -> throwCore $ Error_Protocol "client key exchange unsupported type" HandshakeFailure sendPacket ctx $ Handshake [ClientKeyXchg ckx] masterSecret <- usingHState ctx setMasterSec logKey ctx (MasterSecret masterSecret)@@ -551,9 +541,9 @@ groupUsage <- onCustomFFDHEGroup (clientHooks cparams) params srvpub `catchException` throwMiscErrorOnException "custom group callback failed" case groupUsage of- GroupUsageInsecure -> throwCore $ Error_Protocol ("FFDHE group is not secure enough", True, InsufficientSecurity)- GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason, True, HandshakeFailure)- GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, IllegalParameter)+ GroupUsageInsecure -> throwCore $ Error_Protocol "FFDHE group is not secure enough" InsufficientSecurity+ GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason) HandshakeFailure+ GroupUsageInvalidPublic -> throwCore $ Error_Protocol "invalid server public key" IllegalParameter GroupUsageValid -> return () -- When grp is known but not in the supported list we use it@@ -569,7 +559,7 @@ usingHState ctx $ setNegotiatedGroup grp dhePair <- generateFFDHEShared ctx grp srvpub case dhePair of- Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter)+ Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key") IllegalParameter Just pair -> return pair let setMasterSec = setMasterSecretFromPre xver ClientRole premaster@@ -581,7 +571,7 @@ usingHState ctx $ setNegotiatedGroup grp ecdhePair <- generateECDHEShared ctx srvpub case ecdhePair of- Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter)+ Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key") IllegalParameter Just (clipub, premaster) -> do xver <- usingState_ ctx getVersion let setMasterSec = setMasterSecretFromPre xver ClientRole premaster@@ -622,7 +612,7 @@ cv <- getVerifiedData ClientRole sv <- getVerifiedData ServerRole let bs = extensionEncode (SecureRenegotiation cv $ Just sv)- unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure)+ unless (bs `bytesEq` content) $ throwError $ Error_Protocol "server secure renegotiation data not matching" HandshakeFailure | extID == extensionID_SupportedVersions = case extensionDecode MsgTServerHello content of Just (SupportedVersionsServerHello ver) -> setVersion ver _ -> return ()@@ -648,14 +638,14 @@ -- 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 == SSL3) $ throwCore $ Error_Protocol ("SSL3 is not supported", True, ProtocolVersion)+ when (rver == SSL2) $ throwCore $ Error_Protocol "SSL2 is not supported" ProtocolVersion+ when (rver == SSL3) $ throwCore $ Error_Protocol "SSL3 is not supported" 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)+ Nothing -> throwCore $ Error_Protocol "server choose unknown cipher" IllegalParameter Just alg -> return alg compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of- Nothing -> throwCore $ Error_Protocol ("server choose unknown compression", True, IllegalParameter)+ Nothing -> throwCore $ Error_Protocol "server choose unknown compression" IllegalParameter Just alg -> return alg -- intersect sent extensions in client and the received extensions from server.@@ -664,7 +654,7 @@ | i == extensionID_Cookie = False -- for HRR | otherwise = i `notElem` sentExts when (any checkExt exts) $- throwCore $ Error_Protocol ("spurious extensions received", True, UnsupportedExtension)+ throwCore $ Error_Protocol "spurious extensions received" UnsupportedExtension let resumingSession = case clientWantSessionResume cparams of@@ -691,18 +681,18 @@ -- client-side enabled protocol versions. -- when (isDowngraded ver (supportedVersions $ clientSupported cparams) serverRan) $- throwCore $ Error_Protocol ("version downgrade detected", True, IllegalParameter)+ throwCore $ Error_Protocol "version downgrade detected" IllegalParameter case find (== ver) (supportedVersions $ ctxSupported ctx) of- Nothing -> throwCore $ Error_Protocol ("server version " ++ show ver ++ " is not supported", True, ProtocolVersion)+ Nothing -> throwCore $ Error_Protocol ("server version " ++ show ver ++ " is not supported") ProtocolVersion Just _ -> return () if ver > TLS12 then do when (serverSession /= clientSession) $- throwCore $ Error_Protocol ("received mismatched legacy session", True, IllegalParameter)+ throwCore $ Error_Protocol "received mismatched legacy session" IllegalParameter established <- ctxEstablished ctx eof <- ctxEOF ctx when (established == Established && not eof) $- throwCore $ Error_Protocol ("renegotiation to TLS 1.3 or later is not allowed", True, ProtocolVersion)+ throwCore $ Error_Protocol "renegotiation to TLS 1.3 or later is not allowed" ProtocolVersion ensureNullCompression compression failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg return RecvStateDone@@ -715,7 +705,7 @@ let emsSession = SessionEMS `elem` sessionFlags sessionData when (ems /= emsSession) $ let err = "server resumes a session which is not EMS consistent"- in throwCore $ Error_Protocol (err, True, HandshakeFailure)+ in throwCore $ Error_Protocol err HandshakeFailure let masterSecret = sessionSecret sessionData usingHState ctx $ setMasterSecret rver ClientRole masterSecret logKey ctx (MasterSecret masterSecret)@@ -725,7 +715,7 @@ processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) processCertificate cparams ctx (Certificates certs) = do when (isNullCertificateChain certs) $- throwCore $ Error_Protocol ("server certificate missing", True, DecodeError)+ throwCore $ Error_Protocol "server certificate missing" DecodeError -- run certificate recv hook ctxWithHooks ctx (`hookRecvCertificates` certs) -- then run certificate validation@@ -780,10 +770,10 @@ (cke, SKX_Unparsed bytes) -> do ver <- usingState_ ctx getVersion case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of- Left _ -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show cke, True, HandshakeFailure)+ Left _ -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show cke) HandshakeFailure Right realSkx -> processWithCipher cipher realSkx -- we need to resolve the result. and recall processWithCipher ..- (c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c, True, HandshakeFailure)+ (c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c) HandshakeFailure doDHESignature dhparams signature kxsAlg = do -- FF group selected by the server is verified when generating CKX publicKey <- getSignaturePublicKey kxsAlg@@ -801,13 +791,13 @@ getSignaturePublicKey kxsAlg = do publicKey <- usingHState ctx getRemotePublicKey unless (isKeyExchangeSignatureKey kxsAlg publicKey) $- throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg, True, HandshakeFailure)+ throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg) HandshakeFailure ver <- usingState_ ctx getVersion unless (publicKey `versionCompatible` ver) $- throwCore $ Error_Protocol (show ver ++ " has no support for " ++ pubkeyType publicKey, True, IllegalParameter)+ throwCore $ Error_Protocol (show ver ++ " has no support for " ++ pubkeyType publicKey) IllegalParameter let groups = supportedGroups (ctxSupported ctx) unless (satisfiesEcPredicate (`elem` groups) publicKey) $- throwCore $ Error_Protocol ("server public key has unsupported elliptic curve", True, IllegalParameter)+ throwCore $ Error_Protocol "server public key has unsupported elliptic curve" IllegalParameter return publicKey processServerKeyExchange ctx p = processCertificateRequest ctx p@@ -816,11 +806,7 @@ processCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do ver <- usingState_ ctx getVersion when (ver == TLS12 && isNothing sigAlgs) $- throwCore $ Error_Protocol- ( "missing TLS 1.2 certificate request signature algorithms"- , True- , InternalError- )+ throwCore $ Error_Protocol "missing TLS 1.2 certificate request signature algorithms" InternalError let cTypes = filter (<= lastSupportedCertificateType) cTypesSent usingHState ctx $ setCertReqCBdata $ Just (cTypes, sigAlgs, dNames) return $ RecvStateHandshake (processServerHelloDone ctx)@@ -914,13 +900,13 @@ mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareServerHello ks) -> return ks- Just _ -> throwCore $ Error_Protocol ("invalid key_share value", True, IllegalParameter)- Nothing -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure)+ Just _ -> throwCore $ Error_Protocol "invalid key_share value" IllegalParameter+ Nothing -> throwCore $ Error_Protocol "key exchange not implemented, expected key_share extension" HandshakeFailure let grp = keyShareEntryGroup serverKeyShare unless (checkKeyShareKeyLength serverKeyShare) $- throwCore $ Error_Protocol ("broken key_share", True, IllegalParameter)+ throwCore $ Error_Protocol "broken key_share" IllegalParameter unless (groupSent == Just grp) $- throwCore $ Error_Protocol ("received incompatible group for (EC)DHE", True, IllegalParameter)+ throwCore $ Error_Protocol "received incompatible group for (EC)DHE" IllegalParameter usingHState ctx $ setNegotiatedGroup grp usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare @@ -935,10 +921,10 @@ return (initEarlySecret choice Nothing, False) Just (PreSharedKeyServerHello 0) -> do unless (B.length sec == hashSize) $- throwCore $ Error_Protocol ("selected cipher is incompatible with selected PSK", True, IllegalParameter)+ throwCore $ Error_Protocol "selected cipher is incompatible with selected PSK" IllegalParameter usingHState ctx $ setTLS13HandshakeMode PreSharedKey return (earlySecretPSK, True)- Just _ -> throwCore $ Error_Protocol ("selected identity out of range", True, IllegalParameter)+ Just _ -> throwCore $ Error_Protocol "selected identity out of range" IllegalParameter expectEncryptedExtensions (EncryptedExtensions13 eexts) = do liftIO $ setALPN ctx MsgTEncryptedExtensions eexts@@ -1001,10 +987,7 @@ Just as -> let validAs = filter isHashSignatureValid13 as in return $ sigAlgsToCertTypes ctx validAs- Nothing -> throwCore $ Error_Protocol- ( "invalid certificate request"- , True- , HandshakeFailure )+ Nothing -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure -- Unused: -- caAlgs <- extalgs caextID uncertsig usingHState ctx $ do@@ -1017,19 +1000,13 @@ Nothing -> return [] Just ext -> case extensionDecode MsgTCertificateRequest ext of Just (CertificateAuthorities names) -> return names- _ -> throwCore $ Error_Protocol- ( "invalid certificate request"- , True- , HandshakeFailure )+ _ -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure extalgs extID decons = case extensionLookup extID exts of Nothing -> return Nothing Just ext -> case extensionDecode MsgTCertificateRequest ext of Just e -> return $ decons e- _ -> throwCore $ Error_Protocol- ( "invalid certificate request"- , True- , HandshakeFailure )+ _ -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure unsighash :: SignatureAlgorithms -> Maybe [HashAndSignatureAlgorithm] unsighash (SignatureAlgorithms a) = Just a@@ -1064,11 +1041,7 @@ loadPacket13 ctx $ Handshake13 [vfy] -- sendClientData13 _ _ =- throwCore $ Error_Protocol- ( "missing TLS 1.3 certificate request context token"- , True- , InternalError- )+ throwCore $ Error_Protocol "missing TLS 1.3 certificate request context token" InternalError setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO () setALPN ctx msgt exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode msgt of@@ -1088,11 +1061,11 @@ processCertRequest13 ctx certReqCtx exts (usedHash, _, level, applicationSecretN) <- getTxState ctx unless (level == CryptApplicationSecret) $- throwCore $ Error_Protocol ("unexpected post-handshake authentication request", True, UnexpectedMessage)+ throwCore $ Error_Protocol "unexpected post-handshake authentication request" UnexpectedMessage sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret applicationSecretN) postHandshakeAuthClientWith _ _ _ =- throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthClientWith", True, UnexpectedMessage)+ throwCore $ Error_Protocol "unexpected handshake message received in postHandshakeAuthClientWith" UnexpectedMessage contextSync :: Context -> ClientState -> IO () contextSync ctx ctl = case ctxHandshakeSync ctx of
Network/TLS/Handshake/Common.hs view
@@ -77,8 +77,8 @@ ignoreIOErr _ = return () errorToAlert :: TLSError -> (AlertLevel, AlertDescription)-errorToAlert (Error_Protocol (_, b, ad)) = let lvl = if b then AlertLevel_Fatal else AlertLevel_Warning- in (lvl, ad)+errorToAlert (Error_Protocol _ ad) = (AlertLevel_Fatal, ad)+errorToAlert (Error_Protocol_Warning _ ad) = (AlertLevel_Warning, ad) errorToAlert (Error_Packet_unexpected _ _) = (AlertLevel_Fatal, UnexpectedMessage) errorToAlert (Error_Packet_Parsing msg) | "invalid version" `isInfixOf` msg = (AlertLevel_Fatal, ProtocolVersion)@@ -89,10 +89,11 @@ -- | Return the message that a TLS endpoint can add to its local log for the -- specified library error. errorToAlertMessage :: TLSError -> String-errorToAlertMessage (Error_Protocol (msg, _, _)) = msg-errorToAlertMessage (Error_Packet_unexpected msg _) = msg-errorToAlertMessage (Error_Packet_Parsing msg) = msg-errorToAlertMessage e = show e+errorToAlertMessage (Error_Protocol msg _) = msg+errorToAlertMessage (Error_Protocol_Warning msg _) = msg+errorToAlertMessage (Error_Packet_unexpected msg _) = msg+errorToAlertMessage (Error_Packet_Parsing msg) = msg+errorToAlertMessage e = show e unexpected :: MonadIO m => String -> Maybe String -> m a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected)@@ -188,7 +189,7 @@ ensureRecvComplete ctx = do complete <- liftIO $ isRecvComplete ctx unless complete $- throwCore $ Error_Protocol ("received incomplete message at key change", True, UnexpectedMessage)+ throwCore $ Error_Protocol "received incomplete message at key change" UnexpectedMessage processExtendedMasterSec :: MonadIO m => Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool processExtendedMasterSec ctx ver msgt exts@@ -198,7 +199,7 @@ | otherwise = case extensionLookup extensionID_ExtendedMasterSecret exts >>= extensionDecode msgt of Just ExtendedMasterSecret -> usingHState ctx (setExtendedMasterSec True) >> return True- Nothing | ems == RequireEMS -> throwCore $ Error_Protocol (err, True, HandshakeFailure)+ Nothing | ems == RequireEMS -> throwCore $ Error_Protocol err HandshakeFailure | otherwise -> return False where ems = supportedExtendedMasterSec (ctxSupported ctx) err = "peer does not support Extended Master Secret"@@ -247,10 +248,7 @@ let CertificateChain (c:_) = cc pubkey = certPubKey $ getCertificate c unless (isDigitalSignaturePair (pubkey, privkey)) $- throwCore $ Error_Protocol- ( "mismatched or unsupported private key pair"- , True- , InternalError )+ throwCore $ Error_Protocol "mismatched or unsupported private key pair" InternalError usingHState ctx $ setPublicPrivateKeys (pubkey, privkey) return pubkey @@ -260,7 +258,7 @@ checkSupportedGroup ctx grp = unless (isSupportedGroup ctx grp) $ let msg = "unsupported (EC)DHE group: " ++ show grp- in throwCore $ Error_Protocol (msg, True, IllegalParameter)+ in throwCore $ Error_Protocol msg IllegalParameter isSupportedGroup :: Context -> Group -> Bool isSupportedGroup ctx grp = grp `elem` supportedGroups (ctxSupported ctx)
Network/TLS/Handshake/Common13.hs view
@@ -88,7 +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)+ when (B.length verifyData /= B.length verifyData') $ throwCore $ Error_Protocol "broken Finished" DecodeError unless (verifyData' == verifyData) $ decryptError "cannot verify finished" liftIO $ writeIORef (ctxPeerFinished ctx) (Just verifyData) @@ -102,11 +102,11 @@ makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry) makeServerKeyShare ctx (KeyShareEntry grp wcpub) = case ecpub of- Left e -> throwCore $ Error_Protocol (show e, True, IllegalParameter)+ Left e -> throwCore $ Error_Protocol (show e) IllegalParameter Right cpub -> do ecdhePair <- generateECDHEShared ctx cpub case ecdhePair of- Nothing -> throwCore $ Error_Protocol (msgInvalidPublic, True, IllegalParameter)+ Nothing -> throwCore $ Error_Protocol msgInvalidPublic IllegalParameter Just (spub, share) -> let wspub = IES.encodeGroupPublic spub serverKeyShare = KeyShareEntry grp wspub@@ -124,10 +124,10 @@ fromServerKeyShare :: KeyShareEntry -> IES.GroupPrivate -> IO ByteString fromServerKeyShare (KeyShareEntry grp wspub) cpri = case espub of- Left e -> throwCore $ Error_Protocol (show e, True, IllegalParameter)+ Left e -> throwCore $ Error_Protocol (show e) IllegalParameter Right spub -> case IES.groupGetShared spub cpri of Just shared -> return $ BA.convert shared- Nothing -> throwCore $ Error_Protocol ("cannot generate a shared secret on (EC)DH", True, IllegalParameter)+ Nothing -> throwCore $ Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter where espub = IES.decodeGroupPublic grp wspub @@ -337,7 +337,7 @@ ensureNullCompression :: MonadIO m => CompressionID -> m () ensureNullCompression compression = when (compression /= compressionID nullCompression) $- throwCore $ Error_Protocol ("compression is not allowed in TLS 1.3", True, IllegalParameter)+ throwCore $ Error_Protocol "compression is not allowed in TLS 1.3" IllegalParameter -- Word32 is used in TLS 1.3 protocol. -- Int is used for API for Haskell TLS because it is natural.@@ -398,7 +398,7 @@ checkHashSignatureValid13 hs = unless (isHashSignatureValid13 hs) $ let msg = "invalid TLS13 hash and signature algorithm: " ++ show hs- in throwCore $ Error_Protocol (msg, True, IllegalParameter)+ in throwCore $ Error_Protocol msg IllegalParameter isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool isHashSignatureValid13 (HashIntrinsic, s) =
Network/TLS/Handshake/Key.hs view
@@ -111,9 +111,9 @@ checkDigitalSignatureKey :: MonadIO m => Version -> PubKey -> m () checkDigitalSignatureKey usedVersion key = do unless (isDigitalSignatureKey key) $- throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure)+ throwCore $ Error_Protocol "unsupported remote public key type" HandshakeFailure unless (key `versionCompatible` usedVersion) $- throwCore $ Error_Protocol (show usedVersion ++ " has no support for " ++ pubkeyType key, True, IllegalParameter)+ throwCore $ Error_Protocol (show usedVersion ++ " has no support for " ++ pubkeyType key) IllegalParameter -- | Test whether the argument is matching key pair supported for signature. -- This also accepts material for RSA encryption. This test is performed by
Network/TLS/Handshake/Process.hs view
@@ -65,7 +65,7 @@ processClientExtension (ExtensionRaw 0xff01 content) | secureRenegotiation = do v <- getVerifiedData ClientRole let bs = extensionEncode (SecureRenegotiation v Nothing)- unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("client verified data not matching: " ++ show v ++ ":" ++ show content, True, HandshakeFailure)+ unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("client verified data not matching: " ++ show v ++ ":" ++ show content) HandshakeFailure setSecureRenegotiation True -- unknown extensions@@ -74,7 +74,7 @@ processCertificates :: Role -> CertificateChain -> IO () processCertificates ServerRole (CertificateChain []) = return () processCertificates ClientRole (CertificateChain []) =- throwCore $ Error_Protocol ("server certificate missing", True, HandshakeFailure)+ throwCore $ Error_Protocol "server certificate missing" HandshakeFailure processCertificates _ (CertificateChain (c:_)) = usingHState ctx $ setPublicKey pubkey where pubkey = certPubKey $ getCertificate c@@ -111,7 +111,7 @@ serverParams <- usingHState ctx getServerDHParams let params = serverDHParamsToParams serverParams unless (dhValid params $ dhUnwrapPublic clientDHValue) $- throwCore $ Error_Protocol ("invalid client public key", True, IllegalParameter)+ throwCore $ Error_Protocol "invalid client public key" IllegalParameter dhpriv <- usingHState ctx getDHPrivate let premaster = dhGetShared params dhpriv clientDHValue@@ -121,7 +121,7 @@ processClientKeyXchg ctx (CKX_ECDH bytes) = do ServerECDHParams grp _ <- usingHState ctx getServerECDHParams case decodeGroupPublic grp bytes of- Left _ -> throwCore $ Error_Protocol ("client public key cannot be decoded", True, IllegalParameter)+ Left _ -> throwCore $ Error_Protocol "client public key cannot be decoded" IllegalParameter Right clipub -> do srvpri <- usingHState ctx getGroupPrivate case groupGetShared clipub srvpri of@@ -130,7 +130,7 @@ role <- usingState_ ctx isClientContext masterSecret <- usingHState ctx $ setMasterSecretFromPre rver role premaster liftIO $ logKey ctx (MasterSecret masterSecret)- Nothing -> throwCore $ Error_Protocol ("cannot generate a shared secret on ECDH", True, IllegalParameter)+ Nothing -> throwCore $ Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter processClientFinished :: Context -> FinishedData -> IO () processClientFinished ctx fdata = do
Network/TLS/Handshake/Server.hs view
@@ -90,12 +90,12 @@ -- renego is not allowed in TLS 1.3 when (established /= NotEstablished) $ do ver <- usingState_ ctx (getVersionWithDefault TLS10)- when (ver == TLS13) $ throwCore $ Error_Protocol ("renegotiation is not allowed in TLS 1.3", True, UnexpectedMessage)+ when (ver == TLS13) $ throwCore $ Error_Protocol "renegotiation is not allowed in TLS 1.3" UnexpectedMessage -- rejecting client initiated renegotiation to prevent DOS. eof <- ctxEOF ctx let renegotiation = established == Established && not eof when (renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx)) $- throwCore $ Error_Protocol ("renegotiation is not allowed", False, NoRenegotiation)+ throwCore $ Error_Protocol_Warning "renegotiation is not allowed" NoRenegotiation -- check if policy allow this new handshake to happens handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams) unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")@@ -105,16 +105,16 @@ processHandshake ctx clientHello -- rejecting SSL2. RFC 6176- when (legacyVersion == SSL2) $ throwCore $ Error_Protocol ("SSL 2.0 is not supported", True, ProtocolVersion)+ when (legacyVersion == SSL2) $ throwCore $ Error_Protocol "SSL 2.0 is not supported" 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" ProtocolVersion -- Fallback SCSV: RFC7507 -- TLS_FALLBACK_SCSV: {0x56, 0x00} when (supportedFallbackScsv (ctxSupported ctx) && (0x5600 `elem` ciphers) && legacyVersion < TLS12) $- throwCore $ Error_Protocol ("fallback is not allowed", True, InappropriateFallback)+ throwCore $ Error_Protocol "fallback is not allowed" InappropriateFallback -- choosing TLS version let clientVersions = case extensionLookup extensionID_SupportedVersions exts >>= extensionDecode MsgTClientHello of Just (SupportedVersionsClientHello vers) -> vers -- fixme: vers == []@@ -128,10 +128,10 @@ Just cver -> return cver Nothing -> if (TLS13 `elem` serverVersions) && clientVersions /= [] then case findHighestVersionFrom13 clientVersions serverVersions of- Nothing -> throwCore $ Error_Protocol ("client versions " ++ show clientVersions ++ " is not supported", True, ProtocolVersion)+ Nothing -> throwCore $ Error_Protocol ("client versions " ++ show clientVersions ++ " is not supported") ProtocolVersion Just v -> return v else case findHighestVersionFrom clientVersion serverVersions of- Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported", True, ProtocolVersion)+ Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported") ProtocolVersion Just v -> return v -- SNI (Server Name Indication)@@ -150,7 +150,7 @@ -- 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 exts ciphers serverName clientSession-handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure)+handshakeServerWith _ _ _ = throwCore $ Error_Protocol "unexpected handshake message received in handshakeServerWith" HandshakeFailure -- TLS 1.2 or earlier handshakeServerWithTLS12 :: ServerParams@@ -170,7 +170,7 @@ -- If compression is null, commonCompressions should be [0]. when (null commonCompressions) $ throwCore $- Error_Protocol ("no compression in common with the client", True, HandshakeFailure)+ Error_Protocol "no compression in common with the client" HandshakeFailure -- When selecting a cipher we must ensure that it is allowed for the -- TLS version but also that all its key-exchange requirements@@ -252,7 +252,7 @@ -- creds, check now before calling onCipherChoosing, which does not handle -- empty lists. when (null ciphersFilteredVersion) $ throwCore $- Error_Protocol ("no cipher in common with the client", True, HandshakeFailure)+ Error_Protocol "no cipher in common with the client" HandshakeFailure let usedCipher = onCipherChoosing (serverHooks sparams) chosenVersion ciphersFilteredVersion @@ -263,7 +263,7 @@ CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning KX_DSS signatureCreds CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds CipherKeyExchange_ECDHE_ECDSA -> return $ credentialsFindForSigning KX_ECDSA signatureCreds- _ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure)+ _ -> throwCore $ Error_Protocol "key exchange algorithm not implemented" HandshakeFailure ems <- processExtendedMasterSec ctx chosenVersion MsgTClientHello exts resumeSessionData <- case clientSession of@@ -298,7 +298,7 @@ | ems && not emsSession = return Nothing | not ems && emsSession = let err = "client resumes an EMS session without EMS"- in throwCore $ Error_Protocol (err, True, HandshakeFailure)+ in throwCore $ Error_Protocol err HandshakeFailure | otherwise = return m where emsSession = SessionEMS `elem` sessionFlags sd @@ -479,7 +479,7 @@ generateSKX_ECDHE kxsAlg = do let possibleECGroups = negotiatedGroupsInCommon ctx exts `intersect` availableECGroups grp <- case possibleECGroups of- [] -> throwCore $ Error_Protocol ("no common group", True, HandshakeFailure)+ [] -> throwCore $ Error_Protocol "no common group" HandshakeFailure g:_ -> return g serverParams <- setup_ECDHE grp pubKey <- getLocalPublicKey ctx@@ -541,7 +541,7 @@ chain <- usingHState ctx getClientCertChain case chain of Just cc | isNullCertificateChain cc -> return ()- | otherwise -> throwCore $ Error_Protocol ("cert verify message missing", True, UnexpectedMessage)+ | otherwise -> throwCore $ Error_Protocol "cert verify message missing" UnexpectedMessage Nothing -> return () expectChangeCipher p @@ -556,7 +556,7 @@ checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain checkValidClientCertChain ctx errmsg = do chain <- usingHState ctx getClientCertChain- let throwerror = Error_Protocol (errmsg , True, UnexpectedMessage)+ let throwerror = Error_Protocol errmsg UnexpectedMessage case chain of Nothing -> throwCore throwerror Just cc | isNullCertificateChain cc -> throwCore throwerror@@ -669,13 +669,13 @@ -> IO () handshakeServerWithTLS13 sparams ctx chosenVersion exts clientCiphers _serverName clientSession = do when (any (\(ExtensionRaw eid _) -> eid == extensionID_PreSharedKey) $ init exts) $- throwCore $ Error_Protocol ("extension pre_shared_key must be last", True, IllegalParameter)+ throwCore $ Error_Protocol "extension pre_shared_key must be last" IllegalParameter -- Deciding cipher. -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle -- empty lists. when (null ciphersFilteredVersion) $ throwCore $- Error_Protocol ("no cipher in common with the client", True, HandshakeFailure)+ Error_Protocol "no cipher in common with the client" HandshakeFailure let usedCipher = onCipherChoosing (serverHooks sparams) chosenVersion ciphersFilteredVersion usedHash = cipherHash usedCipher rtt0 = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTClientHello of@@ -687,11 +687,11 @@ setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding -- Deciding key exchange from key shares keyShares <- case extensionLookup extensionID_KeyShare exts of- Nothing -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, MissingExtension)+ Nothing -> throwCore $ Error_Protocol "key exchange not implemented, expected key_share extension" 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)+ _ -> throwCore $ Error_Protocol "broken key_share" DecodeError mshare <- findKeyShare keyShares serverGroups case mshare of Nothing -> helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession@@ -709,9 +709,9 @@ [] -> go gs [k] -> do unless (checkKeyShareKeyLength k) $- throwCore $ Error_Protocol ("broken key_share", True, IllegalParameter)+ throwCore $ Error_Protocol "broken key_share" IllegalParameter return $ Just k- _ -> throwCore $ Error_Protocol ("duplicated key_share", True, IllegalParameter)+ _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter grpEq g ent = g == keyShareEntryGroup ent doHandshake13 :: ServerParams -> Context -> Version@@ -840,7 +840,7 @@ choosePSK = case extensionLookup extensionID_PreSharedKey exts >>= extensionDecode MsgTClientHello of Just (PreSharedKeyClientHello (PskIdentity sessionId obfAge:_) bnds@(bnd:_)) -> do when (null dhModes) $- throwCore $ Error_Protocol ("no psk_key_exchange_modes extension", True, MissingExtension)+ throwCore $ Error_Protocol "no psk_key_exchange_modes extension" MissingExtension if PSK_DHE_KE `elem` dhModes then do let len = sum (map (\x -> B.length x + 1) bnds) + 2 mgr = sharedSessionManager $ serverShared sparams@@ -889,9 +889,9 @@ decideCredentialInfo allCreds = do cHashSigs <- case extensionLookup extensionID_SignatureAlgorithms exts of- Nothing -> throwCore $ Error_Protocol ("no signature_algorithms extension", True, MissingExtension)+ Nothing -> throwCore $ Error_Protocol "no signature_algorithms extension" MissingExtension Just sa -> case extensionDecode MsgTClientHello sa of- Nothing -> throwCore $ Error_Protocol ("broken signature_algorithms extension", True, DecodeError)+ Nothing -> throwCore $ Error_Protocol "broken signature_algorithms extension" 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@@ -903,7 +903,7 @@ case credentialsFindForSigning13 hashSigs cltCreds of Nothing -> case credentialsFindForSigning13 hashSigs allCreds of- Nothing -> throwCore $ Error_Protocol ("credential not found", True, HandshakeFailure)+ Nothing -> throwCore $ Error_Protocol "credential not found" HandshakeFailure mcs -> return mcs mcs -> return mcs @@ -993,7 +993,7 @@ expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool expectCertificate (Certificate13 certCtx certs _ext) = liftIO $ do- when (certCtx /= "") $ throwCore $ Error_Protocol ("certificate request context MUST be empty", True, IllegalParameter)+ when (certCtx /= "") $ throwCore $ Error_Protocol "certificate request context MUST be empty" IllegalParameter -- fixme checking _ext clientCertificate sparams ctx certs return $ isNullCertificateChain certs@@ -1006,7 +1006,7 @@ expectCertVerify sparams ctx hChCc (CertVerify13 sigAlg sig) = liftIO $ do certs@(CertificateChain cc) <- checkValidClientCertChain ctx "finished 13 message expected" pubkey <- case cc of- [] -> throwCore $ Error_Protocol ("client certificate missing", True, HandshakeFailure)+ [] -> throwCore $ Error_Protocol "client certificate missing" HandshakeFailure c:_ -> return $ certPubKey $ getCertificate c ver <- usingState_ ctx getVersion checkDigitalSignatureKey ver pubkey@@ -1019,7 +1019,7 @@ helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession = do twice <- usingState_ ctx getTLS13HRR when twice $- throwCore $ Error_Protocol ("Hello retry not allowed again", True, HandshakeFailure)+ throwCore $ Error_Protocol "Hello retry not allowed again" HandshakeFailure usingState_ ctx $ setTLS13HRR True failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher let clientGroups = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of@@ -1027,7 +1027,7 @@ Nothing -> [] possibleGroups = serverGroups `intersect` clientGroups case possibleGroups of- [] -> throwCore $ Error_Protocol ("no group in common with the client for HRR", True, HandshakeFailure)+ [] -> throwCore $ Error_Protocol "no group in common with the client for HRR" HandshakeFailure g:_ -> do let serverKeyShare = extensionEncode $ KeyShareHRR g selectedVersion = extensionEncode $ SupportedVersionsServerHello chosenVersion@@ -1096,7 +1096,7 @@ Just io -> do proto <- io protos when (proto == "") $- throwCore $ Error_Protocol ("no supported application protocols", True, NoApplicationProtocol)+ throwCore $ Error_Protocol "no supported application protocols" NoApplicationProtocol usingState_ ctx $ do setExtensionALPN True setNegotiatedProtocol proto@@ -1178,7 +1178,7 @@ postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO () postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx certs _ext) = do mCertReq <- getCertRequest13 ctx certCtx- when (isNothing mCertReq) $ throwCore $ Error_Protocol ("unknown certificate request context", True, DecodeError)+ when (isNothing mCertReq) $ throwCore $ Error_Protocol "unknown certificate request context" DecodeError let certReq = fromJust "certReq" mCertReq -- fixme checking _ext@@ -1190,7 +1190,7 @@ (usedHash, _, level, applicationSecretN) <- getRxState ctx unless (level == CryptApplicationSecret) $- throwCore $ Error_Protocol ("tried post-handshake authentication without application traffic secret", True, InternalError)+ throwCore $ Error_Protocol "tried post-handshake authentication without application traffic secret" InternalError let expectFinished hChBeforeCf (Finished13 verifyData) = do checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData@@ -1207,7 +1207,7 @@ ] postHandshakeAuthServerWith _ _ _ =- throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthServerWith", True, UnexpectedMessage)+ throwCore $ Error_Protocol "unexpected handshake message received in postHandshakeAuthServerWith" UnexpectedMessage contextSync :: Context -> ServerState -> IO () contextSync ctx ctl = case ctxHandshakeSync ctx of
Network/TLS/Handshake/Signature.hs view
@@ -39,7 +39,7 @@ import Control.Monad.State.Strict decryptError :: MonadIO m => String -> m a-decryptError msg = throwCore $ Error_Protocol (msg, True, DecryptError)+decryptError msg = throwCore $ Error_Protocol msg DecryptError -- | Check that the key is compatible with a list of 'CertificateType' values. -- Ed25519 and Ed448 have no assigned code point and are checked with extension@@ -297,4 +297,4 @@ checkSupportedHashSignature ctx (Just hs) = unless (hs `elem` supportedHashSignatures (ctxSupported ctx)) $ let msg = "unsupported hash and signature algorithm: " ++ show hs- in throwCore $ Error_Protocol (msg, True, IllegalParameter)+ in throwCore $ Error_Protocol msg IllegalParameter
Network/TLS/Handshake/State13.hs view
@@ -133,7 +133,7 @@ return $ Right () Just oldcipher | cipher == oldcipher -> return $ Right ()- | otherwise -> return $ Left $ Error_Protocol ("TLS 1.3 cipher changed after hello retry", True, IllegalParameter)+ | otherwise -> return $ Left $ Error_Protocol "TLS 1.3 cipher changed after hello retry" IllegalParameter where hashAlg = cipherHash cipher updateDigest (HandshakeMessages bytes) = HandshakeDigestContext $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes
Network/TLS/IO.hs view
@@ -127,7 +127,7 @@ recvPacket13 ctx@Context{ctxRecordLayer = recordLayer} = do erecord <- recordRecv13 recordLayer case erecord of- Left err@(Error_Protocol (_, True, BadRecordMac)) -> do+ Left err@(Error_Protocol _ BadRecordMac) -> do -- If the server decides to reject RTT0 data but accepts RTT1 -- data, the server should skip all records for RTT0 data. established <- ctxEstablished ctx
Network/TLS/QUIC.hs view
@@ -196,7 +196,7 @@ sync ctx (SendClientFinished exts appSecInfo) = do let qexts = filterQTP exts when (null qexts) $ do- throwCore $ Error_Protocol ("QUIC transport parameters are mssing", True, MissingExtension)+ throwCore $ Error_Protocol "QUIC transport parameters are mssing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo) @@ -219,7 +219,7 @@ sync ctx (SendServerHello exts mEarlySecInfo handSecInfo) = do let qexts = filterQTP exts when (null qexts) $ do- throwCore $ Error_Protocol ("QUIC transport parameters are mssing", True, MissingExtension)+ throwCore $ Error_Protocol "QUIC transport parameters are mssing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallEarlyKeys mEarlySecInfo) quicInstallKeys callbacks ctx (InstallHandshakeKeys handSecInfo)@@ -232,7 +232,7 @@ -- | Can be used by callbacks to signal an unexpected condition. This will then -- generate an "internal_error" alert in the TLS stack. errorTLS :: String -> IO a-errorTLS msg = throwCore $ Error_Protocol (msg, True, InternalError)+errorTLS msg = throwCore $ Error_Protocol msg InternalError -- | Return the alert that a TLS endpoint would send to the peer for the -- specified library error.
Network/TLS/Record/Disengage.hs view
@@ -61,11 +61,11 @@ ProtocolType_AppData -> do inner <- decryptData mver record e st case unInnerPlaintext inner of- Left message -> throwError $ Error_Protocol (message, True, UnexpectedMessage)+ Left message -> throwError $ Error_Protocol message UnexpectedMessage Right (ct', d) -> return $ Record ct' ver (fragmentCompressed d) ProtocolType_ChangeCipherSpec -> noDecryption ProtocolType_Alert -> noDecryption- _ -> throwError $ Error_Protocol ("illegal plain text", True, UnexpectedMessage)+ _ -> throwError $ Error_Protocol "illegal plain text" UnexpectedMessage unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString) unInnerPlaintext inner =@@ -105,7 +105,7 @@ else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad unless (macValid &&! paddingValid) $- throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)+ throwError $ Error_Protocol "bad record mac" BadRecordMac return $ cipherDataContent cdata @@ -183,13 +183,13 @@ (content, authTag2) = decryptF nonce econtent' ad when (AuthTag (B.convert authTag) /= authTag2) $- throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)+ throwError $ Error_Protocol "bad record mac" BadRecordMac modify incrRecordState return content decryptOf BulkStateUninitialized =- throwError $ Error_Protocol ("decrypt state uninitialized", True, InternalError)+ throwError $ Error_Protocol "decrypt state uninitialized" InternalError -- handling of outer format can report errors with Error_Packet get3o s ls = maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls@@ -197,5 +197,5 @@ -- all format errors related to decrypted content are reported -- externally as integrity failures, i.e. BadRecordMac- get3i s ls = maybe (throwError $ Error_Protocol ("record bad format", True, BadRecordMac)) return $ partition3 s ls+ get3i s ls = maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $ partition3 s ls get2i s (d1,d2) = get3i s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2)
Network/TLS/Record/Reading.hs view
@@ -49,7 +49,7 @@ erecord = rawToRecord header (fragmentCiphertext content) contentSizeExceeded :: TLSError-contentSizeExceeded = Error_Protocol ("record content exceeding maximum size", True, RecordOverflow)+contentSizeExceeded = Error_Protocol "record content exceeding maximum size" RecordOverflow ---------------------------------------------------------------- @@ -101,7 +101,7 @@ either (return . Left) (getRecord ctx 0 header) maximumSizeExceeded :: TLSError-maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow)+maximumSizeExceeded = Error_Protocol "record exceeding maximum size" RecordOverflow ----------------------------------------------------------------
Network/TLS/Struct.hs view
@@ -163,7 +163,14 @@ -- this library now only throw 'TLSException'. data TLSError = Error_Misc String -- ^ mainly for instance of Error- | Error_Protocol (String, Bool, AlertDescription)+ | Error_Protocol String AlertDescription+ -- ^ A fatal error condition was encountered at a low level. The+ -- elements of the tuple give (freeform text description, structured+ -- error description).+ | Error_Protocol_Warning String AlertDescription+ -- ^ A non-fatal error condition was encountered at a low level at a low+ -- level. The elements of the tuple give (freeform text description,+ -- structured error description). | Error_Certificate String | Error_HandshakePolicy String -- ^ handshake policy failed. | Error_EOF
tls.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tls-version: 1.8.0+version: 1.9.0 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>