diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -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) diff --git a/Network/TLS/Handshake/Certificate.hs b/Network/TLS/Handshake/Certificate.hs --- a/Network/TLS/Handshake/Certificate.hs +++ b/Network/TLS/Handshake/Certificate.hs @@ -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 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 @@ -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 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 @@ -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) 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 @@ -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) = diff --git a/Network/TLS/Handshake/Key.hs b/Network/TLS/Handshake/Key.hs --- a/Network/TLS/Handshake/Key.hs +++ b/Network/TLS/Handshake/Key.hs @@ -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 diff --git a/Network/TLS/Handshake/Process.hs b/Network/TLS/Handshake/Process.hs --- a/Network/TLS/Handshake/Process.hs +++ b/Network/TLS/Handshake/Process.hs @@ -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 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 @@ -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 diff --git a/Network/TLS/Handshake/Signature.hs b/Network/TLS/Handshake/Signature.hs --- a/Network/TLS/Handshake/Signature.hs +++ b/Network/TLS/Handshake/Signature.hs @@ -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 diff --git a/Network/TLS/Handshake/State13.hs b/Network/TLS/Handshake/State13.hs --- a/Network/TLS/Handshake/State13.hs +++ b/Network/TLS/Handshake/State13.hs @@ -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 diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -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 diff --git a/Network/TLS/QUIC.hs b/Network/TLS/QUIC.hs --- a/Network/TLS/QUIC.hs +++ b/Network/TLS/QUIC.hs @@ -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. 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 @@ -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) diff --git a/Network/TLS/Record/Reading.hs b/Network/TLS/Record/Reading.hs --- a/Network/TLS/Record/Reading.hs +++ b/Network/TLS/Record/Reading.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -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 diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -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