diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,26 @@ +## Version 1.5.2 + +- Enabled TLS 1.3 by default [#398](https://github.com/vincenthz/hs-tls/pull/398) +- Avoid handshake failure with small RSA keys [#394](https://github.com/vincenthz/hs-tls/pull/394) + +NOTES: + +- Starting with tls-1.5.0, the parameter `supportedVersions` contains values + ordered by decreasing preference, so typically the higher versions first. + This departs from code samples previously available. For maximum + interoperability, users overriding the default value should verify and adapt + their code. + ## Version 1.5.1 - Post-handshake authentication [#363](https://github.com/vincenthz/hs-tls/pull/363) +- Middlebox compatibility [#386](https://github.com/vincenthz/hs-tls/pull/386) +- Verification and configuration of session-ticket lifetime [#373](https://github.com/vincenthz/hs-tls/pull/373) - Fixing memory leak [#366](https://github.com/vincenthz/hs-tls/pull/366) -- Improve version negotiation [#368](https://github.com/vincenthz/hs-tls/pull/368) - Don't send 0-RTT data when ticket is expired [#370](https://github.com/vincenthz/hs-tls/pull/370) - Handshake packet fragmentation [#371](https://github.com/vincenthz/hs-tls/pull/371) +- Fix SSLv2 deprecated header [#383](https://github.com/vincenthz/hs-tls/pull/383) +- Other improvements to TLS 1.3 and RFC conformance [#368](https://github.com/vincenthz/hs-tls/pull/368) [#372](https://github.com/vincenthz/hs-tls/pull/372) [#375](https://github.com/vincenthz/hs-tls/pull/375) [#376](https://github.com/vincenthz/hs-tls/pull/376) [#377](https://github.com/vincenthz/hs-tls/pull/377) [#378](https://github.com/vincenthz/hs-tls/pull/378) [#380](https://github.com/vincenthz/hs-tls/pull/380) [#382](https://github.com/vincenthz/hs-tls/pull/382) [#385](https://github.com/vincenthz/hs-tls/pull/385) [#387](https://github.com/vincenthz/hs-tls/pull/387) [#388](https://github.com/vincenthz/hs-tls/pull/388) ## Version 1.5.0 diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -193,10 +193,10 @@ -- read+write locks (which is also what we use for all calls to the -- session manager). withWriteLock ctx $ do - ResuptionSecret resumptionMasterSecret <- usingHState ctx getTLS13Secret - (usedHash, usedCipher, _) <- getTxState ctx - let hashSize = hashDigestSize usedHash - psk = hkdfExpandLabel usedHash resumptionMasterSecret "resumption" nonce hashSize + Just resumptionMasterSecret <- usingHState ctx getTLS13ResumptionSecret + (_, usedCipher, _) <- getTxState ctx + let choice = makeCipherChoice TLS13 usedCipher + psk = derivePSK choice resumptionMasterSecret nonce maxSize = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTNewSessionTicket of Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms _ -> 0 @@ -297,9 +297,9 @@ -> (Context -> Hash -> Cipher -> C8.ByteString -> IO ()) -> IO () keyUpdate ctx getState setState = do - (usedHash, usedCipher, applicationTrafficSecretN) <- getState ctx - let applicationTrafficSecretN1 = hkdfExpandLabel usedHash applicationTrafficSecretN "traffic upd" "" $ hashDigestSize usedHash - setState ctx usedHash usedCipher applicationTrafficSecretN1 + (usedHash, usedCipher, applicationSecretN) <- getState ctx + let applicationSecretN1 = hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $ hashDigestSize usedHash + setState ctx usedHash usedCipher applicationSecretN1 -- | How to update keys in TLS 1.3 data KeyUpdateRequest = OneWay -- ^ Unidirectional key update diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -25,13 +25,15 @@ , PublicKey , PrivateKey , SignatureParams(..) - , findDigitalSignatureAlg + , isKeyExchangeSignatureKey , findKeyExchangeSignatureAlg , findFiniteFieldGroup , kxEncrypt , kxDecrypt , kxSign , kxVerify + , kxCanUseRSApkcs1 + , kxCanUseRSApss , KxError(..) , RSAEncoding(..) ) where @@ -40,6 +42,7 @@ import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert) import Crypto.Error +import Crypto.Number.Basic (numBits) import Crypto.Random import qualified Crypto.PubKey.DH as DH import qualified Crypto.PubKey.DSA as DSA @@ -72,15 +75,15 @@ | KxUnsupported deriving (Show) -findDigitalSignatureAlg :: (PubKey, PrivKey) -> Maybe DigitalSignatureAlg -findDigitalSignatureAlg keyPair = - case keyPair of - (PubKeyRSA _, PrivKeyRSA _) -> Just DS_RSA - (PubKeyDSA _, PrivKeyDSA _) -> Just DS_DSS - --(PubKeyECDSA _, PrivKeyECDSA _) -> Just DS_ECDSA - (PubKeyEd25519 _, PrivKeyEd25519 _) -> Just DS_Ed25519 - (PubKeyEd448 _, PrivKeyEd448 _) -> Just DS_Ed448 - _ -> Nothing +isKeyExchangeSignatureKey :: KeyExchangeSignatureAlg -> PubKey -> Bool +isKeyExchangeSignatureKey = f + where + f KX_RSA (PubKeyRSA _) = True + f KX_DSS (PubKeyDSA _) = True + f KX_ECDSA (PubKeyEC _) = True + f KX_ECDSA (PubKeyEd25519 _) = True + f KX_ECDSA (PubKeyEd448 _) = True + f _ _ = False findKeyExchangeSignatureAlg :: (PubKey, PrivKey) -> Maybe KeyExchangeSignatureAlg findKeyExchangeSignatureAlg keyPair = @@ -193,6 +196,26 @@ kxDecrypt _ _ = return (Left KxUnsupported) data RSAEncoding = RSApkcs1 | RSApss deriving (Show,Eq) + +-- | Test the RSASSA-PKCS1 length condition described in RFC 8017 section 9.2, +-- i.e. @emLen >= tLen + 11@. Lengths are in bytes. +kxCanUseRSApkcs1 :: RSA.PublicKey -> Hash -> Bool +kxCanUseRSApkcs1 pk h = RSA.public_size pk >= tLen + 11 + where + tLen = prefixSize h + hashDigestSize h + + prefixSize MD5 = 18 + prefixSize SHA1 = 15 + prefixSize SHA224 = 19 + prefixSize SHA256 = 19 + prefixSize SHA384 = 19 + prefixSize SHA512 = 19 + prefixSize _ = error (show h ++ " is not supported for RSASSA-PKCS1") + +-- | Test the RSASSA-PSS length condition described in RFC 8017 section 9.1.1, +-- i.e. @emBits >= 8hLen + 8sLen + 9@. Lengths are in bits. +kxCanUseRSApss :: RSA.PublicKey -> Hash -> Bool +kxCanUseRSApss pk h = numBits (RSA.public_n pk) >= 16 * hashDigestSize h + 10 -- Signature algorithm and associated parameters. -- diff --git a/Network/TLS/Crypto/Types.hs b/Network/TLS/Crypto/Types.hs --- a/Network/TLS/Crypto/Types.hs +++ b/Network/TLS/Crypto/Types.hs @@ -17,10 +17,6 @@ availableECGroups :: [Group] availableECGroups = [P256,P384,P521,X25519,X448] --- Digital signature algorithm, in close relation to public/private key types. -data DigitalSignatureAlg = DS_RSA | DS_DSS | DS_ECDSA | DS_Ed25519 | DS_Ed448 - deriving (Show, Eq) - -- Key-exchange signature algorithm, in close relation to ciphers -- (before TLS 1.3). data KeyExchangeSignatureAlg = KX_RSA | KX_DSS | KX_ECDSA 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 @@ -46,7 +46,6 @@ import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 -import Network.TLS.KeySchedule import Network.TLS.Wire handshakeClientWith :: ClientParams -> Context -> Handshake -> IO () @@ -196,16 +195,14 @@ let tinfo = fromJust "sessionTicketInfo" $ sessionTicketInfo sdata age <- getAge tinfo return $ if isAgeValid age tinfo - then Just (sid, sdata, sCipher, ageToObfuscatedAge age tinfo) + then Just (sid, sdata, makeCipherChoice TLS13 sCipher, ageToObfuscatedAge age tinfo) else Nothing preSharedKeyExtension pskInfo = case pskInfo of Nothing -> return Nothing - Just (sid, _, sCipher, obfAge) -> - let usedHash = cipherHash sCipher - siz = hashDigestSize usedHash - zero = B.replicate siz 0 + Just (sid, _, choice, obfAge) -> + let zero = cZero choice identity = PskIdentity sid obfAge offeredPsks = PreSharedKeyClientHello [identity] [zero] in return $ Just $ toExtensionRaw offeredPsks @@ -231,15 +228,14 @@ adjustExtentions pskInfo exts ch = case pskInfo of Nothing -> return exts - Just (_, sdata, sCipher, _) -> do - let usedHash = cipherHash sCipher - siz = hashDigestSize usedHash - zero = B.replicate siz 0 - psk = sessionSecret sdata - earlySecret = hkdfExtract usedHash zero psk - usingHState ctx $ setTLS13Secret (EarlySecret earlySecret) + Just (_, sdata, choice, _) -> do + let psk = sessionSecret sdata + earlySecret = initEarlySecret choice (Just psk) + usingHState ctx $ setTLS13EarlySecret earlySecret let ech = encodeHandshake ch - binder <- makePSKBinder ctx earlySecret usedHash (siz + 3) (Just ech) + h = cHash choice + siz = hashDigestSize h + binder <- makePSKBinder ctx earlySecret h (siz + 3) (Just ech) let exts' = init exts ++ [adjust (last exts)] adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders where @@ -283,22 +279,21 @@ mapM_ send0RTT rtt0info return (rtt0, map (\(ExtensionRaw i _) -> i) extensions) - get0RTTinfo (_, sdata, sCipher, _) = do + get0RTTinfo (_, sdata, choice, _) = do earlyData <- clientEarlyData cparams guard (B.length earlyData <= sessionMaxEarlyDataSize sdata) - return (sCipher, earlyData) + return (choice, earlyData) - send0RTT (usedCipher, earlyData) = do - let usedHash = cipherHash usedCipher - -- fixme: not initialized yet - -- hCh <- transcriptHash ctx - hmsgs <- usingHState ctx getHandshakeMessages - let hCh = hash usedHash $ B.concat hmsgs -- fixme - EarlySecret earlySecret <- usingHState ctx getTLS13Secret -- fixme - let clientEarlyTrafficSecret = deriveSecret usedHash earlySecret "c e traffic" hCh - logKey ctx (ClientEarlyTrafficSecret clientEarlyTrafficSecret) + send0RTT (choice, earlyData) = do + let usedCipher = cCipher choice + usedHash = cHash choice + Just earlySecret <- usingHState ctx getTLS13EarlySecret + -- Client hello is stored in hstHandshakeDigest + -- But HandshakeDigestContext is not created yet. + earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) False + let ClientTrafficSecret clientEarlySecret = pairClient earlyKey runPacketFlight ctx $ sendChangeCipherSpec13 ctx - setTxState ctx usedHash usedCipher clientEarlyTrafficSecret + setTxState ctx usedHash usedCipher clientEarlySecret mapChunks_ 16384 (sendPacket13 ctx . AppData13) earlyData usingHState ctx $ setTLS13RTT0Status RTT0Sent @@ -323,10 +318,10 @@ -> Credential -> IO () storePrivInfoClient ctx cTypes (cc, privkey) = do - privalg <- storePrivInfo ctx cc privkey - unless (certificateCompatible privalg cTypes) $ + pubkey <- storePrivInfo ctx cc privkey + unless (certificateCompatible pubkey cTypes) $ throwCore $ Error_Protocol - ( show privalg ++ " credential does not match allowed certificate types" + ( pubkeyType pubkey ++ " credential does not match allowed certificate types" , True , InternalError ) @@ -408,7 +403,7 @@ return $ Just cc -- | Return a most preferred 'HandAndSignatureAlgorithm' that is --- compatible with the private key and server's signature +-- compatible with the local key and server's signature -- algorithms (both already saved). Must only be called for TLS -- versions 1.2 and up. -- @@ -418,22 +413,22 @@ -- getLocalHashSigAlg :: Context -> [HashAndSignatureAlgorithm] - -> DigitalSignatureAlg + -> PubKey -> IO HashAndSignatureAlgorithm -getLocalHashSigAlg ctx cHashSigs keyAlg = do +getLocalHashSigAlg ctx cHashSigs pubKey = do -- Must be present with TLS 1.2 and up. (Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata - let want = (&&) <$> signatureCompatible keyAlg + let want = (&&) <$> signatureCompatible pubKey <*> flip elem hashSigs case find want cHashSigs of Just best -> return best Nothing -> throwCore $ Error_Protocol - ( keyerr keyAlg + ( keyerr pubKey , True , HandshakeFailure ) where - keyerr alg = "no " ++ show alg ++ " hash algorithm in common with the server" + keyerr k = "no " ++ pubkeyType k ++ " hash algorithm in common with the server" -- | Return the supported 'CertificateType' values that are -- compatible with at least one supported signature algorithm. @@ -576,16 +571,16 @@ -- certSent <- usingHState ctx getClientCertSent when certSent $ do - keyAlg <- getLocalDigitalSignatureAlg ctx + pubKey <- getLocalPublicKey ctx mhashSig <- case ver of TLS12 -> let cHashSigs = supportedHashSignatures $ ctxSupported ctx - in Just <$> getLocalHashSigAlg ctx cHashSigs keyAlg + in Just <$> getLocalHashSigAlg ctx cHashSigs pubKey _ -> return Nothing -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages - sigDig <- createCertificateVerify ctx ver keyAlg mhashSig msgs + sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs sendPacket ctx $ Handshake [CertVerify sigDig] processServerExtension :: ExtensionRaw -> TLSSt () @@ -752,27 +747,23 @@ (c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c, True, HandshakeFailure) doDHESignature dhparams signature kxsAlg = do -- FF group selected by the server is verified when generating CKX - signatureType <- getSignatureType kxsAlg - verified <- digitallySignDHParamsVerify ctx dhparams signatureType signature - unless verified $ decryptError ("bad " ++ show signatureType ++ " signature for dhparams " ++ show dhparams) + publicKey <- getSignaturePublicKey kxsAlg + verified <- digitallySignDHParamsVerify ctx dhparams publicKey signature + unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for dhparams " ++ show dhparams) usingHState ctx $ setServerDHParams dhparams doECDHESignature ecdhparams signature kxsAlg = do -- EC group selected by the server is verified when generating CKX - signatureType <- getSignatureType kxsAlg - verified <- digitallySignECDHParamsVerify ctx ecdhparams signatureType signature - unless verified $ decryptError ("bad " ++ show signatureType ++ " signature for ecdhparams") + publicKey <- getSignaturePublicKey kxsAlg + verified <- digitallySignECDHParamsVerify ctx ecdhparams publicKey signature + unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for ecdhparams") usingHState ctx $ setServerECDHParams ecdhparams - getSignatureType kxsAlg = do + getSignaturePublicKey kxsAlg = do publicKey <- usingHState ctx getRemotePublicKey - case (kxsAlg, publicKey) of - (KX_RSA, PubKeyRSA _) -> return DS_RSA - (KX_DSS, PubKeyDSA _) -> return DS_DSS - (KX_ECDSA, PubKeyEC _) -> return DS_ECDSA - (KX_ECDSA, PubKeyEd25519 _) -> return DS_Ed25519 - (KX_ECDSA, PubKeyEd448 _) -> return DS_Ed448 - _ -> throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg, True, HandshakeFailure) + unless (isKeyExchangeSignatureKey kxsAlg publicKey) $ + throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg, True, HandshakeFailure) + return publicKey processServerKeyExchange ctx p = processCertificateRequest ctx p @@ -820,55 +811,52 @@ handshakeClient13 :: ClientParams -> Context -> Maybe Group -> IO () handshakeClient13 cparams ctx groupSent = do - usedCipher <- usingHState ctx getPendingCipher - let usedHash = cipherHash usedCipher - handshakeClient13' cparams ctx groupSent usedCipher usedHash + choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher + handshakeClient13' cparams ctx groupSent choice -handshakeClient13' :: ClientParams -> Context -> Maybe Group -> Cipher -> Hash -> IO () -handshakeClient13' cparams ctx groupSent usedCipher usedHash = do - (resuming, handshakeSecret, clientHandshakeTrafficSecret, serverHandshakeTrafficSecret) <- switchToHandshakeSecret +handshakeClient13' :: ClientParams -> Context -> Maybe Group -> CipherChoice -> IO () +handshakeClient13' cparams ctx groupSent choice = do + (_, hkey, resuming) <- switchToHandshakeSecret + let handshakeSecret = triBase hkey + ClientTrafficSecret clientHandshakeSecret = triClient hkey + ServerTrafficSecret serverHandshakeSecret = triServer hkey rtt0accepted <- runRecvHandshake13 $ do accepted <- recvHandshake13 ctx expectEncryptedExtensions unless resuming $ recvHandshake13 ctx expectCertRequest - recvHandshake13hash ctx $ expectFinished serverHandshakeTrafficSecret + recvHandshake13hash ctx $ expectFinished serverHandshakeSecret return accepted hChSf <- transcriptHash ctx runPacketFlight ctx $ sendChangeCipherSpec13 ctx when rtt0accepted $ sendPacket13 ctx (Handshake13 [EndOfEarlyData13]) - setTxState ctx usedHash usedCipher clientHandshakeTrafficSecret - sendClientFlight13 cparams ctx usedHash clientHandshakeTrafficSecret - masterSecret <- switchToTrafficSecret handshakeSecret hChSf - setResumptionSecret masterSecret + setTxState ctx usedHash usedCipher clientHandshakeSecret + sendClientFlight13 cparams ctx usedHash clientHandshakeSecret + appKey <- switchToApplicationSecret handshakeSecret hChSf + let applicationSecret = triBase appKey + setResumptionSecret applicationSecret handshakeTerminate13 ctx where + usedCipher = cCipher choice + usedHash = cHash choice + hashSize = hashDigestSize usedHash - zero = B.replicate hashSize 0 switchToHandshakeSecret = do ensureRecvComplete ctx ecdhe <- calcSharedKey (earlySecret, resuming) <- makeEarlySecret - let handshakeSecret = hkdfExtract usedHash (deriveSecret usedHash earlySecret "derived" (hash usedHash "")) ecdhe - hChSh <- transcriptHash ctx - let clientHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh - serverHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh - logKey ctx (ServerHandshakeTrafficSecret serverHandshakeTrafficSecret) - logKey ctx (ClientHandshakeTrafficSecret clientHandshakeTrafficSecret) - setRxState ctx usedHash usedCipher serverHandshakeTrafficSecret - return (resuming, handshakeSecret, clientHandshakeTrafficSecret, serverHandshakeTrafficSecret) + handKey <- calculateHandshakeSecret ctx choice earlySecret ecdhe + let ServerTrafficSecret serverHandshakeSecret = triServer handKey + setRxState ctx usedHash usedCipher serverHandshakeSecret + return (usedCipher, handKey, resuming) - switchToTrafficSecret handshakeSecret hChSf = do + switchToApplicationSecret handshakeSecret hChSf = do ensureRecvComplete ctx - let masterSecret = hkdfExtract usedHash (deriveSecret usedHash handshakeSecret "derived" (hash usedHash "")) zero - let clientApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "c ap traffic" hChSf - serverApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "s ap traffic" hChSf - exporterMasterSecret = deriveSecret usedHash masterSecret "exp master" hChSf - usingState_ ctx $ setExporterMasterSecret exporterMasterSecret - logKey ctx (ServerTrafficSecret0 serverApplicationTrafficSecret0) - logKey ctx (ClientTrafficSecret0 clientApplicationTrafficSecret0) - setTxState ctx usedHash usedCipher clientApplicationTrafficSecret0 - setRxState ctx usedHash usedCipher serverApplicationTrafficSecret0 - return masterSecret + appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf + let ServerTrafficSecret serverApplicationSecret0 = triServer appKey + let ClientTrafficSecret clientApplicationSecret0 = triClient appKey + setTxState ctx usedHash usedCipher clientApplicationSecret0 + setRxState ctx usedHash usedCipher serverApplicationSecret0 + return appKey calcSharedKey = do serverKeyShare <- do @@ -884,20 +872,20 @@ usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare makeEarlySecret = do - secret <- usingHState ctx getTLS13Secret - case secret of - EarlySecret sec -> do - mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey - case mSelectedIdentity of - Nothing -> - return (hkdfExtract usedHash zero zero, False) - Just (PreSharedKeyServerHello 0) -> do - unless (B.length sec == hashSize) $ - throwCore $ Error_Protocol ("selected cipher is incompatible with selected PSK", True, IllegalParameter) - usingHState ctx $ setTLS13HandshakeMode PreSharedKey - return (sec, True) - Just _ -> throwCore $ Error_Protocol ("selected identity out of range", True, IllegalParameter) - _ -> return (hkdfExtract usedHash zero zero, False) + mEarlySecretPSK <- usingHState ctx getTLS13EarlySecret + case mEarlySecretPSK of + Nothing -> return (initEarlySecret choice Nothing, False) + Just earlySecretPSK@(BaseSecret sec) -> do + mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey + case mSelectedIdentity of + Nothing -> + 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) + usingHState ctx $ setTLS13HandshakeMode PreSharedKey + return (earlySecretPSK, True) + Just _ -> throwCore $ Error_Protocol ("selected identity out of range", True, IllegalParameter) expectEncryptedExtensions (EncryptedExtensions13 eexts) = do liftIO $ setALPN ctx eexts @@ -930,13 +918,13 @@ expectCertAndVerify (Certificate13 _ cc _) = do _ <- liftIO $ processCertificate cparams ctx (Certificates cc) let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc + checkDigitalSignatureKey pubkey usingHState ctx $ setPublicKey pubkey recvHandshake13hash ctx $ expectCertVerify pubkey expectCertAndVerify p = unexpected (show p) (Just "server certificate") expectCertVerify pubkey hChSc (CertVerify13 sigAlg sig) = do - let keyAlg = fromJust "fromPubKey" (fromPubKey pubkey) - ok <- checkCertVerify ctx keyAlg sigAlg sig hChSc + ok <- checkCertVerify ctx pubkey sigAlg sig hChSc unless ok $ decryptError "cannot verify CertificateVerify" expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify") @@ -944,10 +932,9 @@ checkFinished usedHash baseKey hashValue verifyData expectFinished _ _ p = unexpected (show p) (Just "server finished") - setResumptionSecret masterSecret = do - hChCf <- transcriptHash ctx - let resumptionMasterSecret = deriveSecret usedHash masterSecret "res master" hChCf - usingHState ctx $ setTLS13Secret $ ResuptionSecret resumptionMasterSecret + setResumptionSecret applicationSecret = do + resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret + usingHState ctx $ setTLS13ResumptionSecret resumptionSecret processCertRequest13 :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m () processCertRequest13 ctx token exts = do @@ -1017,9 +1004,9 @@ [] -> return () _ -> do hChSc <- transcriptHash ctx - keyAlg <- getLocalDigitalSignatureAlg ctx - sigAlg <- liftIO $ getLocalHashSigAlg ctx cHashSigs keyAlg - vfy <- makeCertVerify ctx keyAlg sigAlg hChSc + pubKey <- getLocalPublicKey ctx + sigAlg <- liftIO $ getLocalHashSigAlg ctx cHashSigs pubKey + vfy <- makeCertVerify ctx pubKey sigAlg hChSc loadPacket13 ctx $ Handshake13 [vfy] -- sendClientData13 _ _ = @@ -1045,8 +1032,8 @@ bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do processHandshake13 ctx h processCertRequest13 ctx certReqCtx exts - (usedHash, _, applicationTrafficSecretN) <- getTxState ctx - sendClientFlight13 cparams ctx usedHash applicationTrafficSecretN + (usedHash, _, applicationSecretN) <- getTxState ctx + sendClientFlight13 cparams ctx usedHash applicationSecretN postHandshakeAuthClientWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthClientWith", True, UnexpectedMessage) 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 @@ -33,6 +33,7 @@ import Network.TLS.Struct13 import Network.TLS.IO import Network.TLS.State +import Network.TLS.Handshake.Key import Network.TLS.Handshake.Process import Network.TLS.Handshake.State import Network.TLS.Record.State @@ -200,18 +201,17 @@ => Context -> CertificateChain -> PrivKey - -> m DigitalSignatureAlg + -> m PubKey storePrivInfo ctx cc privkey = do let CertificateChain (c:_) = cc pubkey = certPubKey $ getCertificate c - privalg <- case findDigitalSignatureAlg (pubkey, privkey) of - Just alg -> return alg - Nothing -> throwCore $ Error_Protocol - ( "mismatched or unsupported private key pair" - , True - , InternalError ) + unless (isDigitalSignaturePair (pubkey, privkey)) $ + throwCore $ Error_Protocol + ( "mismatched or unsupported private key pair" + , True + , InternalError ) usingHState ctx $ setPublicPrivateKeys (pubkey, privkey) - return privalg + return pubkey -- verify that the group selected by the peer is supported in the local -- configuration 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 @@ -34,6 +34,14 @@ , runRecvHandshake13 , recvHandshake13 , recvHandshake13hash + , CipherChoice(..) + , makeCipherChoice + , initEarlySecret + , calculateEarlySecret + , calculateHandshakeSecret + , calculateApplicationSecret + , calculateResumptionSecret + , derivePSK ) where import qualified Data.ByteArray as BA @@ -125,24 +133,26 @@ clientContextString :: ByteString clientContextString = "TLS 1.3, client CertificateVerify" -makeCertVerify :: MonadIO m => Context -> DigitalSignatureAlg -> HashAndSignatureAlgorithm -> ByteString -> m Handshake13 -makeCertVerify ctx sig hs hashValue = do +makeCertVerify :: MonadIO m => Context -> PubKey -> HashAndSignatureAlgorithm -> ByteString -> m Handshake13 +makeCertVerify ctx pub hs hashValue = do cc <- liftIO $ usingState_ ctx isClientContext let ctxStr | cc == ClientRole = clientContextString | otherwise = serverContextString target = makeTarget ctxStr hashValue - CertVerify13 hs <$> sign ctx sig hs target + CertVerify13 hs <$> sign ctx pub hs target -checkCertVerify :: MonadIO m => Context -> DigitalSignatureAlg -> HashAndSignatureAlgorithm -> Signature -> ByteString -> m Bool -checkCertVerify ctx sig hs signature hashValue = liftIO $ do - cc <- usingState_ ctx isClientContext - let ctxStr | cc == ClientRole = serverContextString -- opposite context - | otherwise = clientContextString - target = makeTarget ctxStr hashValue - sigParams = signatureParams sig (Just hs) - checkHashSignatureValid13 hs - checkSupportedHashSignature ctx (Just hs) - verifyPublic ctx sigParams target signature +checkCertVerify :: MonadIO m => Context -> PubKey -> HashAndSignatureAlgorithm -> Signature -> ByteString -> m Bool +checkCertVerify ctx pub hs signature hashValue + | pub `signatureCompatible` hs = liftIO $ do + cc <- usingState_ ctx isClientContext + let ctxStr | cc == ClientRole = serverContextString -- opposite context + | otherwise = clientContextString + target = makeTarget ctxStr hashValue + sigParams = signatureParams pub (Just hs) + checkHashSignatureValid13 hs + checkSupportedHashSignature ctx (Just hs) + verifyPublic ctx sigParams target signature + | otherwise = return False makeTarget :: ByteString -> ByteString -> ByteString makeTarget contextString hashValue = runPut $ do @@ -151,22 +161,22 @@ putWord8 0 putBytes hashValue -sign :: MonadIO m => Context -> DigitalSignatureAlg -> HashAndSignatureAlgorithm -> ByteString -> m Signature -sign ctx sig hs target = liftIO $ do +sign :: MonadIO m => Context -> PubKey -> HashAndSignatureAlgorithm -> ByteString -> m Signature +sign ctx pub hs target = liftIO $ do cc <- usingState_ ctx isClientContext - let sigParams = signatureParams sig (Just hs) + let sigParams = signatureParams pub (Just hs) signPrivate ctx cc sigParams target ---------------------------------------------------------------- -makePSKBinder :: Context -> ByteString -> Hash -> Int -> Maybe ByteString -> IO ByteString -makePSKBinder ctx earlySecret usedHash truncLen mch = do +makePSKBinder :: Context -> BaseSecret EarlySecret -> Hash -> Int -> Maybe ByteString -> IO ByteString +makePSKBinder ctx (BaseSecret sec) usedHash truncLen mch = do rmsgs0 <- usingHState ctx getHandshakeMessagesRev -- fixme let rmsgs = case mch of Just ch -> trunc ch : rmsgs0 Nothing -> trunc (head rmsgs0) : tail rmsgs0 hChTruncated = hash usedHash $ B.concat $ reverse rmsgs - binderKey = deriveSecret usedHash earlySecret "res binder" (hash usedHash "") + binderKey = deriveSecret usedHash sec "res binder" (hash usedHash "") return $ makeVerifyData usedHash binderKey hChTruncated where trunc x = B.take takeLen x @@ -212,7 +222,7 @@ , hstHandshakeDigest = hstHandshakeDigest hshake , hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake , hstTLS13RTT0Status = hstTLS13RTT0Status hshake - , hstTLS13Secret = hstTLS13Secret hshake + , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake } -- forget handshake data stored in TLS state usingState_ ctx $ do @@ -397,3 +407,96 @@ isHashSignatureValid13 (h, SignatureECDSA) = h `elem` [ HashSHA256, HashSHA384, HashSHA512 ] isHashSignatureValid13 _ = False + +data CipherChoice = CipherChoice { + cVersion :: Version + , cCipher :: Cipher + , cHash :: Hash + , cZero :: !ByteString + } + +makeCipherChoice :: Version -> Cipher -> CipherChoice +makeCipherChoice ver cipher = CipherChoice ver cipher h zero + where + h = cipherHash cipher + zero = B.replicate (hashDigestSize h) 0 + +---------------------------------------------------------------- + +calculateEarlySecret :: Context -> CipherChoice + -> Either ByteString (BaseSecret EarlySecret) + -> Bool -> IO (SecretPair EarlySecret) +calculateEarlySecret ctx choice maux initialized = do + hCh <- if initialized then + transcriptHash ctx + else do + hmsgs <- usingHState ctx getHandshakeMessages + return $ hash usedHash $ B.concat hmsgs + let earlySecret = case maux of + Right (BaseSecret sec) -> sec + Left psk -> hkdfExtract usedHash zero psk + clientEarlySecret = deriveSecret usedHash earlySecret "c e traffic" hCh + cets = ClientTrafficSecret clientEarlySecret :: ClientTrafficSecret EarlySecret + logKey ctx cets + return $ SecretPair (BaseSecret earlySecret) cets + where + usedHash = cHash choice + zero = cZero choice + +initEarlySecret :: CipherChoice -> Maybe ByteString -> BaseSecret EarlySecret +initEarlySecret choice mpsk = BaseSecret sec + where + sec = hkdfExtract usedHash zero zeroOrPSK + usedHash = cHash choice + zero = cZero choice + zeroOrPSK = case mpsk of + Just psk -> psk + Nothing -> zero + +calculateHandshakeSecret :: Context -> CipherChoice -> BaseSecret EarlySecret -> ByteString + -> IO (SecretTriple HandshakeSecret) +calculateHandshakeSecret ctx choice (BaseSecret sec) ecdhe = do + hChSh <- transcriptHash ctx + let handshakeSecret = hkdfExtract usedHash (deriveSecret usedHash sec "derived" (hash usedHash "")) ecdhe + let clientHandshakeSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh + serverHandshakeSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh + let shts = ServerTrafficSecret serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret + chts = ClientTrafficSecret clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret + logKey ctx shts + logKey ctx chts + return $ SecretTriple (BaseSecret handshakeSecret) chts shts + where + usedHash = cHash choice + +calculateApplicationSecret :: Context -> CipherChoice -> BaseSecret HandshakeSecret -> ByteString + -> IO (SecretTriple ApplicationSecret) +calculateApplicationSecret ctx choice (BaseSecret sec) hChSf = do + let applicationSecret = hkdfExtract usedHash (deriveSecret usedHash sec "derived" (hash usedHash "")) zero + let clientApplicationSecret0 = deriveSecret usedHash applicationSecret "c ap traffic" hChSf + serverApplicationSecret0 = deriveSecret usedHash applicationSecret "s ap traffic" hChSf + exporterMasterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf + usingState_ ctx $ setExporterMasterSecret exporterMasterSecret + let sts0 = ServerTrafficSecret serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret + let cts0 = ClientTrafficSecret clientApplicationSecret0 :: ClientTrafficSecret ApplicationSecret + logKey ctx sts0 + logKey ctx cts0 + return $ SecretTriple (BaseSecret applicationSecret) cts0 sts0 + where + usedHash = cHash choice + zero = cZero choice + +calculateResumptionSecret :: Context -> CipherChoice -> BaseSecret ApplicationSecret + -> IO (BaseSecret ResumptionSecret) +calculateResumptionSecret ctx choice (BaseSecret sec) = do + hChCf <- transcriptHash ctx + let resumptionMasterSecret = deriveSecret usedHash sec "res master" hChCf + return $ BaseSecret resumptionMasterSecret + where + usedHash = cHash choice + +derivePSK :: CipherChoice -> BaseSecret ResumptionSecret -> ByteString -> ByteString +derivePSK choice (BaseSecret sec) nonce = + hkdfExpandLabel usedHash sec "resumption" nonce hashSize + where + usedHash = cHash choice + hashSize = hashDigestSize usedHash 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} -- | -- Module : Network.TLS.Handshake.Key -- License : BSD-style @@ -17,9 +18,10 @@ , generateECDHEShared , generateFFDHE , generateFFDHEShared - , getLocalDigitalSignatureAlg + , isDigitalSignaturePair + , checkDigitalSignatureKey + , getLocalPublicKey , logKey - , LogKey(..) ) where import Control.Monad.State.Strict @@ -83,39 +85,65 @@ generateFFDHEShared :: Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey)) generateFFDHEShared ctx grp pub = usingState_ ctx $ withRNG $ dhGroupGetPubShared grp pub -getLocalDigitalSignatureAlg :: (MonadFail m, MonadIO m) => Context -> m DigitalSignatureAlg -getLocalDigitalSignatureAlg ctx = do - keys <- usingHState ctx getLocalPublicPrivateKeys - case findDigitalSignatureAlg keys of - Just sigAlg -> return sigAlg - Nothing -> fail "selected credential does not support signing" +isDigitalSignatureKey :: PubKey -> Bool +isDigitalSignatureKey (PubKeyRSA _) = True +isDigitalSignatureKey (PubKeyDSA _) = True +isDigitalSignatureKey (PubKeyEC _) = True +isDigitalSignatureKey (PubKeyEd25519 _) = True +isDigitalSignatureKey (PubKeyEd448 _) = True +isDigitalSignatureKey _ = False +-- | Test whether the argument is a public key supported for signature. This +-- also accepts a key for RSA encryption. This test is performed by clients or +-- servers before verifying a remote Certificate Verify. +checkDigitalSignatureKey :: MonadIO m => PubKey -> m () +checkDigitalSignatureKey key = + unless (isDigitalSignatureKey key) $ + throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure) + +-- | Test whether the argument is matching key pair supported for signature. +-- This also accepts material for RSA encryption. This test is performed by +-- servers or clients before using a credential from the local configuration. +isDigitalSignaturePair :: (PubKey, PrivKey) -> Bool +isDigitalSignaturePair keyPair = + case keyPair of + (PubKeyRSA _, PrivKeyRSA _) -> True + (PubKeyDSA _, PrivKeyDSA _) -> True + --(PubKeyECDSA _, PrivKeyECDSA _) -> True + (PubKeyEd25519 _, PrivKeyEd25519 _) -> True + (PubKeyEd448 _, PrivKeyEd448 _) -> True + _ -> False + +getLocalPublicKey :: MonadIO m => Context -> m PubKey +getLocalPublicKey ctx = + usingHState ctx (fst <$> getLocalPublicPrivateKeys) + ---------------------------------------------------------------- -data LogKey = MasterSecret ByteString - | ClientEarlyTrafficSecret ByteString - | ServerHandshakeTrafficSecret ByteString - | ClientHandshakeTrafficSecret ByteString - | ServerTrafficSecret0 ByteString - | ClientTrafficSecret0 ByteString +class LogLabel a where + labelAndKey :: a -> (String, ByteString) -labelAndKey :: LogKey -> (String, ByteString) -labelAndKey (MasterSecret key) = - ("CLIENT_RANDOM", key) -labelAndKey (ClientEarlyTrafficSecret key) = - ("CLIENT_EARLY_TRAFFIC_SECRET", key) -labelAndKey (ServerHandshakeTrafficSecret key) = - ("SERVER_HANDSHAKE_TRAFFIC_SECRET", key) -labelAndKey (ClientHandshakeTrafficSecret key) = - ("CLIENT_HANDSHAKE_TRAFFIC_SECRET", key) -labelAndKey (ServerTrafficSecret0 key) = - ("SERVER_TRAFFIC_SECRET_0", key) -labelAndKey (ClientTrafficSecret0 key) = - ("CLIENT_TRAFFIC_SECRET_0", key) +instance LogLabel MasterSecret where + labelAndKey (MasterSecret key) = ("CLIENT_RANDOM", key) +instance LogLabel (ClientTrafficSecret EarlySecret) where + labelAndKey (ClientTrafficSecret key) = ("CLIENT_EARLY_TRAFFIC_SECRET", key) + +instance LogLabel (ServerTrafficSecret HandshakeSecret) where + labelAndKey (ServerTrafficSecret key) = ("SERVER_HANDSHAKE_TRAFFIC_SECRET", key) + +instance LogLabel (ClientTrafficSecret HandshakeSecret) where + labelAndKey (ClientTrafficSecret key) = ("CLIENT_HANDSHAKE_TRAFFIC_SECRET", key) + +instance LogLabel (ServerTrafficSecret ApplicationSecret) where + labelAndKey (ServerTrafficSecret key) = ("SERVER_TRAFFIC_SECRET_0", key) + +instance LogLabel (ClientTrafficSecret ApplicationSecret) where + labelAndKey (ClientTrafficSecret key) = ("CLIENT_TRAFFIC_SECRET_0", key) + -- NSS Key Log Format -- See https://developer.mozilla.org/en-US/docs/Mozilla/Projects/NSS/Key_Log_Format -logKey :: Context -> LogKey -> IO () +logKey :: LogLabel a => Context -> a -> IO () logKey ctx logkey = do mhst <- getHState ctx case mhst of 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 @@ -18,7 +18,7 @@ import Control.Monad.State.Strict (gets) import Control.Monad.IO.Class (liftIO) -import Network.TLS.Types (Role(..), invertRole) +import Network.TLS.Types (Role(..), invertRole, MasterSecret(..)) import Network.TLS.Util import Network.TLS.Packet import Network.TLS.ErrT 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 @@ -44,7 +44,6 @@ import Network.TLS.Handshake.Certificate import Network.TLS.X509 import Network.TLS.Handshake.State13 -import Network.TLS.KeySchedule import Network.TLS.Handshake.Common13 -- Put the server context in handshake mode. @@ -226,8 +225,8 @@ -- 'possibleHashSigAlgs' the result is Nothing, and the credential will -- not be used to sign. This avoids a failure later in 'decideHashSig'. signingRank cred = - case credentialDigitalSignatureAlg cred of - Just sig -> findIndex (sig `signatureCompatible`) possibleHashSigAlgs + case credentialDigitalSignatureKey cred of + Just pub -> findIndex (pub `signatureCompatible`) possibleHashSigAlgs Nothing -> Nothing -- Finally compute credential lists and resulting cipher list. @@ -438,21 +437,21 @@ -- the "signature_algorithms" extension in a client hello. -- If RSA is also used for key exchange, this function is -- not called. - decideHashSig sigAlg = do + decideHashSig pubKey = do usedVersion <- usingState_ ctx getVersion case usedVersion of TLS12 -> do let hashSigs = hashAndSignaturesInCommon ctx exts - case filter (sigAlg `signatureCompatible`) hashSigs of - [] -> error ("no hash signature for " ++ show sigAlg) + case filter (pubKey `signatureCompatible`) hashSigs of + [] -> error ("no hash signature for " ++ pubkeyType pubKey) x:_ -> return $ Just x _ -> return Nothing generateSKX_DHE kxsAlg = do serverParams <- setup_DHE - sigAlg <- getLocalDigitalSignatureAlg ctx - mhashSig <- decideHashSig sigAlg - signed <- digitallySignDHParams ctx serverParams sigAlg mhashSig + pubKey <- getLocalPublicKey ctx + mhashSig <- decideHashSig pubKey + signed <- digitallySignDHParams ctx serverParams pubKey mhashSig case kxsAlg of KX_RSA -> return $ SKX_DHE_RSA serverParams signed KX_DSS -> return $ SKX_DHE_DSS serverParams signed @@ -474,9 +473,9 @@ [] -> throwCore $ Error_Protocol ("no common group", True, HandshakeFailure) g:_ -> return g serverParams <- setup_ECDHE grp - sigAlg <- getLocalDigitalSignatureAlg ctx - mhashSig <- decideHashSig sigAlg - signed <- digitallySignECDHParams ctx serverParams sigAlg mhashSig + pubKey <- getLocalPublicKey ctx + mhashSig <- decideHashSig pubKey + signed <- digitallySignECDHParams ctx serverParams pubKey mhashSig case kxsAlg of KX_RSA -> return $ SKX_ECDHE_RSA serverParams signed KX_ECDSA -> return $ SKX_ECDHE_ECDSA serverParams signed @@ -522,9 +521,10 @@ -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages - sigAlgExpected <- getRemoteSignatureAlg + pubKey <- usingHState ctx getRemotePublicKey + checkDigitalSignatureKey pubKey - verif <- checkCertificateVerify ctx usedVersion sigAlgExpected msgs dsig + verif <- checkCertificateVerify ctx usedVersion pubKey msgs dsig clientCertVerify sparams ctx certs verif return $ RecvStateNext expectChangeCipher @@ -536,12 +536,6 @@ Nothing -> return () expectChangeCipher p - getRemoteSignatureAlg = do - pk <- usingHState ctx getRemotePublicKey - case fromPubKey pk of - Nothing -> throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure) - Just sig -> return sig - expectChangeCipher ChangeCipherSpec = do return $ RecvStateHandshake expectFinish @@ -581,9 +575,11 @@ in serverGroups `intersect` clientGroups _ -> [] -credentialDigitalSignatureAlg :: Credential -> Maybe DigitalSignatureAlg -credentialDigitalSignatureAlg cred = - findDigitalSignatureAlg (credentialPublicPrivateKeys cred) +credentialDigitalSignatureKey :: Credential -> Maybe PubKey +credentialDigitalSignatureKey cred + | isDigitalSignaturePair keys = Just pubkey + | otherwise = Nothing + where keys@(pubkey, _) = credentialPublicPrivateKeys cred filterSortCredentials :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials filterSortCredentials rankFun (Credentials creds) = @@ -695,10 +691,9 @@ usingHState ctx $ setNegotiatedGroup $ keyShareEntryGroup clientKeyShare srand <- setServerParameter (psk, binderInfo, is0RTTvalid) <- choosePSK - hCh <- transcriptHash ctx - let earlySecret = hkdfExtract usedHash zero psk - clientEarlyTrafficSecret = deriveSecret usedHash earlySecret "c e traffic" hCh - logKey ctx (ClientEarlyTrafficSecret clientEarlyTrafficSecret) + earlyKey <- calculateEarlySecret ctx choice (Left psk) True + let earlySecret = pairBase earlyKey + ClientTrafficSecret clientEarlySecret = pairClient earlyKey extensions <- checkBinder earlySecret binderInfo hrr <- usingState_ ctx getTLS13HRR let authenticated = isJust binderInfo @@ -721,39 +716,32 @@ mCredInfo <- if authenticated then return Nothing else decideCredentialInfo (ecdhe,keyShare) <- makeServerKeyShare ctx clientKeyShare ensureRecvComplete ctx - let handshakeSecret = hkdfExtract usedHash (deriveSecret usedHash earlySecret "derived" (hash usedHash "")) ecdhe - clientHandshakeTrafficSecret <- runPacketFlight ctx $ do + (clientHandshakeSecret, handshakeSecret) <- runPacketFlight ctx $ do sendServerHello keyShare srand extensions sendChangeCipherSpec13 ctx ---------------------------------------------------------------- - hChSh <- transcriptHash ctx - let clientHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh - serverHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh + handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe + let ServerTrafficSecret serverHandshakeSecret = triServer handKey + ClientTrafficSecret clientHandshakeSecret = triClient handKey liftIO $ do - logKey ctx (ServerHandshakeTrafficSecret serverHandshakeTrafficSecret) - logKey ctx (ClientHandshakeTrafficSecret clientHandshakeTrafficSecret) - setRxState ctx usedHash usedCipher $ if rtt0OK then clientEarlyTrafficSecret else clientHandshakeTrafficSecret - setTxState ctx usedHash usedCipher serverHandshakeTrafficSecret + setRxState ctx usedHash usedCipher $ if rtt0OK then clientEarlySecret else clientHandshakeSecret + setTxState ctx usedHash usedCipher serverHandshakeSecret ---------------------------------------------------------------- sendExtensions rtt0OK case mCredInfo of Nothing -> return () Just (cred, hashSig) -> sendCertAndVerify cred hashSig - rawFinished <- makeFinished ctx usedHash serverHandshakeTrafficSecret + rawFinished <- makeFinished ctx usedHash serverHandshakeSecret loadPacket13 ctx $ Handshake13 [rawFinished] - return clientHandshakeTrafficSecret + return (clientHandshakeSecret, triBase handKey) sfSentTime <- getCurrentTimeFromBase ---------------------------------------------------------------- - let masterSecret = hkdfExtract usedHash (deriveSecret usedHash handshakeSecret "derived" (hash usedHash "")) zero hChSf <- transcriptHash ctx - let clientApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "c ap traffic" hChSf - serverApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "s ap traffic" hChSf - exporterMasterSecret = deriveSecret usedHash masterSecret "exp master" hChSf - usingState_ ctx $ setExporterMasterSecret exporterMasterSecret - ---------------------------------------------------------------- - logKey ctx (ServerTrafficSecret0 serverApplicationTrafficSecret0) - logKey ctx (ClientTrafficSecret0 clientApplicationTrafficSecret0) - setTxState ctx usedHash usedCipher serverApplicationTrafficSecret0 + appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf + let ClientTrafficSecret clientApplicationSecret0 = triClient appKey + ServerTrafficSecret serverApplicationSecret0 = triServer appKey + applicationSecret = triBase appKey + setTxState ctx usedHash usedCipher serverApplicationSecret0 ---------------------------------------------------------------- if rtt0OK then setEstablished ctx (EarlyDataAllowed rtt0max) @@ -761,14 +749,14 @@ setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding let expectFinished hChBeforeCf (Finished13 verifyData) = liftIO $ do - checkFinished usedHash clientHandshakeTrafficSecret hChBeforeCf verifyData + checkFinished usedHash clientHandshakeSecret hChBeforeCf verifyData handshakeTerminate13 ctx - setRxState ctx usedHash usedCipher clientApplicationTrafficSecret0 - sendNewSessionTicket masterSecret sfSentTime + setRxState ctx usedHash usedCipher clientApplicationSecret0 + sendNewSessionTicket applicationSecret sfSentTime expectFinished _ hs = unexpected (show hs) (Just "finished 13") let expectEndOfEarlyData EndOfEarlyData13 = - setRxState ctx usedHash usedCipher clientHandshakeTrafficSecret + setRxState ctx usedHash usedCipher clientHandshakeSecret expectEndOfEarlyData hs = unexpected (show hs) (Just "end of early data") if not authenticated && serverWantClientCert sparams then @@ -785,6 +773,8 @@ recvHandshake13hash ctx expectFinished ensureRecvComplete ctx where + choice = makeCipherChoice chosenVersion usedCipher + setServerParameter = do srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams usingState_ ctx $ setVersion chosenVersion @@ -884,8 +874,8 @@ ess = replicate (length cs) [] loadPacket13 ctx $ Handshake13 [Certificate13 "" certChain ess] hChSc <- transcriptHash ctx - sigAlg <- getLocalDigitalSignatureAlg ctx - vrfy <- makeCertVerify ctx sigAlg hashSig hChSc + pubkey <- getLocalPublicKey ctx + vrfy <- makeCertVerify ctx pubkey hashSig hChSc loadPacket13 ctx $ Handshake13 [vrfy] sendExtensions rtt0OK = do @@ -910,14 +900,13 @@ let extensions = catMaybes [earlyDataExtension, groupExtension, sniExtension] ++ protoExt loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions] - sendNewSessionTicket masterSecret sfSentTime = when sendNST $ do + sendNewSessionTicket applicationSecret sfSentTime = when sendNST $ do cfRecvTime <- getCurrentTimeFromBase let rtt = cfRecvTime - sfSentTime - hChCf <- transcriptHash ctx nonce <- getStateRNG ctx 32 - let resumptionMasterSecret = deriveSecret usedHash masterSecret "res master" hChCf - life = toSeconds $ serverTicketLifetime sparams - psk = hkdfExpandLabel usedHash resumptionMasterSecret "resumption" nonce hashSize + resumptionMasterSecret <- calculateResumptionSecret ctx choice applicationSecret + let life = toSeconds $ serverTicketLifetime sparams + psk = derivePSK choice resumptionMasterSecret nonce (label, add) <- generateSession life psk rtt0max rtt let nst = createNewSessionTicket life add nonce label rtt0max sendPacket13 ctx $ Handshake13 [nst] @@ -960,9 +949,9 @@ pubkey <- case cc of [] -> throwCore $ Error_Protocol ("client certificate missing", True, HandshakeFailure) c:_ -> return $ certPubKey $ getCertificate c + checkDigitalSignatureKey pubkey usingHState ctx $ setPublicKey pubkey - let keyAlg = fromJust "fromPubKey" (fromPubKey pubkey) - verif <- checkCertVerify ctx keyAlg sigAlg sig hChCc + verif <- checkCertVerify ctx pubkey sigAlg sig hChCc clientCertVerify sparams ctx certs verif expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13") @@ -1066,9 +1055,9 @@ credentialsFindForSigning13' :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential credentialsFindForSigning13' sigAlg (Credentials l) = find forSigning l where - forSigning cred = case credentialDigitalSignatureAlg cred of + forSigning cred = case credentialDigitalSignatureKey cred of Nothing -> False - Just sig -> sig `signatureCompatible` sigAlg + Just pub -> pub `signatureCompatible` sigAlg clientCertificate :: ServerParams -> Context -> CertificateChain -> IO () clientCertificate sparams ctx certs = do @@ -1138,10 +1127,10 @@ processHandshake13 ctx certReq processHandshake13 ctx h - (usedHash, _, applicationTrafficSecretN) <- getRxState ctx + (usedHash, _, applicationSecretN) <- getRxState ctx let expectFinished hChBeforeCf (Finished13 verifyData) = do - checkFinished usedHash applicationTrafficSecretN hChBeforeCf verifyData + checkFinished usedHash applicationSecretN hChBeforeCf verifyData void $ restoreHState ctx baseHState expectFinished _ hs = unexpected (show hs) (Just "finished 13") 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 @@ -19,7 +19,6 @@ , signatureCompatible , hashSigToCertType , signatureParams - , fromPubKey , decryptError ) where @@ -34,40 +33,37 @@ import Network.TLS.Handshake.State import Network.TLS.Handshake.Key import Network.TLS.Util +import Network.TLS.X509 import Control.Monad.State.Strict -fromPubKey :: PubKey -> Maybe DigitalSignatureAlg -fromPubKey (PubKeyRSA _) = Just DS_RSA -fromPubKey (PubKeyDSA _) = Just DS_DSS -fromPubKey (PubKeyEC _) = Just DS_ECDSA -fromPubKey (PubKeyEd25519 _) = Just DS_Ed25519 -fromPubKey (PubKeyEd448 _) = Just DS_Ed448 -fromPubKey _ = Nothing - decryptError :: MonadIO m => String -> m a decryptError msg = throwCore $ Error_Protocol (msg, True, DecryptError) --- | Check that the signature algorithm is compatible with a list of --- 'CertificateType' values. Ed25519 and Ed448 have no assigned code point --- and are checked with extension "signature_algorithms" only. -certificateCompatible :: DigitalSignatureAlg -> [CertificateType] -> Bool -certificateCompatible DS_RSA cTypes = CertificateType_RSA_Sign `elem` cTypes -certificateCompatible DS_DSS cTypes = CertificateType_DSS_Sign `elem` cTypes -certificateCompatible DS_ECDSA cTypes = CertificateType_ECDSA_Sign `elem` cTypes -certificateCompatible DS_Ed25519 _ = True -certificateCompatible DS_Ed448 _ = True +-- | 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 +-- "signature_algorithms" only. +certificateCompatible :: PubKey -> [CertificateType] -> Bool +certificateCompatible (PubKeyRSA _) cTypes = CertificateType_RSA_Sign `elem` cTypes +certificateCompatible (PubKeyDSA _) cTypes = CertificateType_DSS_Sign `elem` cTypes +certificateCompatible (PubKeyEC _) cTypes = CertificateType_ECDSA_Sign `elem` cTypes +certificateCompatible (PubKeyEd25519 _) _ = True +certificateCompatible (PubKeyEd448 _) _ = True +certificateCompatible _ _ = False -signatureCompatible :: DigitalSignatureAlg -> HashAndSignatureAlgorithm -> Bool -signatureCompatible DS_RSA (_, SignatureRSA) = True -signatureCompatible DS_RSA (_, SignatureRSApssRSAeSHA256) = True -signatureCompatible DS_RSA (_, SignatureRSApssRSAeSHA384) = True -signatureCompatible DS_RSA (_, SignatureRSApssRSAeSHA512) = True -signatureCompatible DS_DSS (_, SignatureDSS) = True -signatureCompatible DS_ECDSA (_, SignatureECDSA) = True -signatureCompatible DS_Ed25519 (_, SignatureEd25519) = True -signatureCompatible DS_Ed448 (_, SignatureEd448) = True -signatureCompatible _ (_, _) = False +signatureCompatible :: PubKey -> HashAndSignatureAlgorithm -> Bool +signatureCompatible (PubKeyRSA pk) (HashSHA1, SignatureRSA) = kxCanUseRSApkcs1 pk SHA1 +signatureCompatible (PubKeyRSA pk) (HashSHA256, SignatureRSA) = kxCanUseRSApkcs1 pk SHA256 +signatureCompatible (PubKeyRSA pk) (HashSHA384, SignatureRSA) = kxCanUseRSApkcs1 pk SHA384 +signatureCompatible (PubKeyRSA pk) (HashSHA512, SignatureRSA) = kxCanUseRSApkcs1 pk SHA512 +signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA256) = kxCanUseRSApss pk SHA256 +signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA384) = kxCanUseRSApss pk SHA384 +signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA512) = kxCanUseRSApss pk SHA512 +signatureCompatible (PubKeyDSA _) (_, SignatureDSS) = True +signatureCompatible (PubKeyEC _) (_, SignatureECDSA) = True +signatureCompatible (PubKeyEd25519 _) (_, SignatureEd25519) = True +signatureCompatible (PubKeyEd448 _) (_, SignatureEd448) = True +signatureCompatible _ (_, _) = False -- | Translate a 'HashAndSignatureAlgorithm' to an acceptable 'CertificateType'. -- Perhaps this needs to take supported groups into account, so that, for @@ -111,30 +107,30 @@ checkCertificateVerify :: Context -> Version - -> DigitalSignatureAlg + -> PubKey -> ByteString -> DigitallySigned -> IO Bool -checkCertificateVerify ctx usedVersion sigAlgExpected msgs digSig@(DigitallySigned hashSigAlg _) = +checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg _) = case (usedVersion, hashSigAlg) of (TLS12, Nothing) -> return False - (TLS12, Just hs) | sigAlgExpected `signatureCompatible` hs -> doVerify - | otherwise -> return False + (TLS12, Just hs) | pubKey `signatureCompatible` hs -> doVerify + | otherwise -> return False (_, Nothing) -> doVerify (_, Just _) -> return False where doVerify = - prepareCertificateVerifySignatureData ctx usedVersion sigAlgExpected hashSigAlg msgs >>= + prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs >>= signatureVerifyWithCertVerifyData ctx digSig createCertificateVerify :: Context -> Version - -> DigitalSignatureAlg + -> PubKey -> Maybe HashAndSignatureAlgorithm -- TLS12 only -> ByteString -> IO DigitallySigned -createCertificateVerify ctx usedVersion sigAlg hashSigAlg msgs = - prepareCertificateVerifySignatureData ctx usedVersion sigAlg hashSigAlg msgs >>= +createCertificateVerify ctx usedVersion pubKey hashSigAlg msgs = + prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs >>= signatureCreateWithCertVerifyData ctx hashSigAlg type CertVerifyData = (SignatureParams, ByteString) @@ -147,25 +143,25 @@ prepareCertificateVerifySignatureData :: Context -> Version - -> DigitalSignatureAlg + -> PubKey -> Maybe HashAndSignatureAlgorithm -- TLS12 only -> ByteString -> IO CertVerifyData -prepareCertificateVerifySignatureData ctx usedVersion sigAlg hashSigAlg msgs +prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs | usedVersion == SSL3 = do (hashCtx, params, generateCV_SSL) <- - case sigAlg of - DS_RSA -> return (hashInit SHA1_MD5, RSAParams SHA1_MD5 RSApkcs1, generateCertificateVerify_SSL) - DS_DSS -> return (hashInit SHA1, DSSParams, generateCertificateVerify_SSL_DSS) - _ -> throwCore $ Error_Misc ("unsupported CertificateVerify signature for SSL3: " ++ show sigAlg) + case pubKey of + PubKeyRSA _ -> return (hashInit SHA1_MD5, RSAParams SHA1_MD5 RSApkcs1, generateCertificateVerify_SSL) + PubKeyDSA _ -> return (hashInit SHA1, DSSParams, generateCertificateVerify_SSL_DSS) + _ -> throwCore $ Error_Misc ("unsupported CertificateVerify signature for SSL3: " ++ pubkeyType pubKey) Just masterSecret <- usingHState ctx $ gets hstMasterSecret return (params, generateCV_SSL masterSecret $ hashUpdate hashCtx msgs) | usedVersion == TLS10 || usedVersion == TLS11 = - return $ buildVerifyData (signatureParams sigAlg Nothing) msgs - | otherwise = return (signatureParams sigAlg hashSigAlg, msgs) + return $ buildVerifyData (signatureParams pubKey Nothing) msgs + | otherwise = return (signatureParams pubKey hashSigAlg, msgs) -signatureParams :: DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -> SignatureParams -signatureParams DS_RSA hashSigAlg = +signatureParams :: PubKey -> Maybe HashAndSignatureAlgorithm -> SignatureParams +signatureParams (PubKeyRSA _) hashSigAlg = case hashSigAlg of Just (HashSHA512, SignatureRSA) -> RSAParams SHA512 RSApkcs1 Just (HashSHA384, SignatureRSA) -> RSAParams SHA384 RSApkcs1 @@ -177,13 +173,13 @@ Nothing -> RSAParams SHA1_MD5 RSApkcs1 Just (hsh , SignatureRSA) -> error ("unimplemented RSA signature hash type: " ++ show hsh) Just (_ , sigAlg) -> error ("signature algorithm is incompatible with RSA: " ++ show sigAlg) -signatureParams DS_DSS hashSigAlg = +signatureParams (PubKeyDSA _) hashSigAlg = case hashSigAlg of Nothing -> DSSParams Just (HashSHA1, SignatureDSS) -> DSSParams Just (_ , SignatureDSS) -> error "invalid DSA hash choice, only SHA1 allowed" Just (_ , sigAlg) -> error ("signature algorithm is incompatible with DSS: " ++ show sigAlg) -signatureParams DS_ECDSA hashSigAlg = +signatureParams (PubKeyEC _) hashSigAlg = case hashSigAlg of Just (HashSHA512, SignatureECDSA) -> ECDSAParams SHA512 Just (HashSHA384, SignatureECDSA) -> ECDSAParams SHA384 @@ -192,18 +188,19 @@ Nothing -> ECDSAParams SHA1 Just (hsh , SignatureECDSA) -> error ("unimplemented ECDSA signature hash type: " ++ show hsh) Just (_ , sigAlg) -> error ("signature algorithm is incompatible with ECDSA: " ++ show sigAlg) -signatureParams DS_Ed25519 hashSigAlg = +signatureParams (PubKeyEd25519 _) hashSigAlg = case hashSigAlg of Nothing -> Ed25519Params Just (HashIntrinsic , SignatureEd25519) -> Ed25519Params Just (hsh , SignatureEd25519) -> error ("unimplemented Ed25519 signature hash type: " ++ show hsh) Just (_ , sigAlg) -> error ("signature algorithm is incompatible with Ed25519: " ++ show sigAlg) -signatureParams DS_Ed448 hashSigAlg = +signatureParams (PubKeyEd448 _) hashSigAlg = case hashSigAlg of Nothing -> Ed448Params Just (HashIntrinsic , SignatureEd448) -> Ed448Params Just (hsh , SignatureEd448) -> error ("unimplemented Ed448 signature hash type: " ++ show hsh) Just (_ , sigAlg) -> error ("signature algorithm is incompatible with Ed448: " ++ show sigAlg) +signatureParams pk _ = error ("signatureParams: " ++ pubkeyType pk ++ " is not supported") signatureCreateWithCertVerifyData :: Context -> Maybe HashAndSignatureAlgorithm @@ -213,15 +210,15 @@ cc <- usingState_ ctx isClientContext DigitallySigned malg <$> signPrivate ctx cc sigParam toSign -signatureVerify :: Context -> DigitallySigned -> DigitalSignatureAlg -> ByteString -> IO Bool -signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) sigAlgExpected toVerifyData = do +signatureVerify :: Context -> DigitallySigned -> PubKey -> ByteString -> IO Bool +signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) pubKey toVerifyData = do usedVersion <- usingState_ ctx getVersion let (sigParam, toVerify) = case (usedVersion, hashSigAlg) of (TLS12, Nothing) -> error "expecting hash and signature algorithm in a TLS12 digitally signed structure" - (TLS12, Just hs) | sigAlgExpected `signatureCompatible` hs -> (signatureParams sigAlgExpected hashSigAlg, toVerifyData) - | otherwise -> error "expecting different signature algorithm" - (_, Nothing) -> buildVerifyData (signatureParams sigAlgExpected Nothing) toVerifyData + (TLS12, Just hs) | pubKey `signatureCompatible` hs -> (signatureParams pubKey hashSigAlg, toVerifyData) + | otherwise -> error "expecting different signature algorithm" + (_, Nothing) -> buildVerifyData (signatureParams pubKey Nothing) toVerifyData (_, Just _) -> error "not expecting hash and signature algorithm in a < TLS12 digitially signed structure" signatureVerifyWithCertVerifyData ctx digSig (sigParam, toVerify) @@ -233,46 +230,46 @@ checkSupportedHashSignature ctx hs verifyPublic ctx sigParam toVerify bs -digitallySignParams :: Context -> ByteString -> DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -> IO DigitallySigned -digitallySignParams ctx signatureData sigAlg hashSigAlg = - let sigParam = signatureParams sigAlg hashSigAlg +digitallySignParams :: Context -> ByteString -> PubKey -> Maybe HashAndSignatureAlgorithm -> IO DigitallySigned +digitallySignParams ctx signatureData pubKey hashSigAlg = + let sigParam = signatureParams pubKey hashSigAlg in signatureCreateWithCertVerifyData ctx hashSigAlg (buildVerifyData sigParam signatureData) digitallySignDHParams :: Context -> ServerDHParams - -> DigitalSignatureAlg + -> PubKey -> Maybe HashAndSignatureAlgorithm -- TLS12 only -> IO DigitallySigned -digitallySignDHParams ctx serverParams sigAlg mhash = do +digitallySignDHParams ctx serverParams pubKey mhash = do dhParamsData <- withClientAndServerRandom ctx $ encodeSignedDHParams serverParams - digitallySignParams ctx dhParamsData sigAlg mhash + digitallySignParams ctx dhParamsData pubKey mhash digitallySignECDHParams :: Context -> ServerECDHParams - -> DigitalSignatureAlg + -> PubKey -> Maybe HashAndSignatureAlgorithm -- TLS12 only -> IO DigitallySigned -digitallySignECDHParams ctx serverParams sigAlg mhash = do +digitallySignECDHParams ctx serverParams pubKey mhash = do ecdhParamsData <- withClientAndServerRandom ctx $ encodeSignedECDHParams serverParams - digitallySignParams ctx ecdhParamsData sigAlg mhash + digitallySignParams ctx ecdhParamsData pubKey mhash digitallySignDHParamsVerify :: Context -> ServerDHParams - -> DigitalSignatureAlg + -> PubKey -> DigitallySigned -> IO Bool -digitallySignDHParamsVerify ctx dhparams sigAlg signature = do +digitallySignDHParamsVerify ctx dhparams pubKey signature = do expectedData <- withClientAndServerRandom ctx $ encodeSignedDHParams dhparams - signatureVerify ctx signature sigAlg expectedData + signatureVerify ctx signature pubKey expectedData digitallySignECDHParamsVerify :: Context -> ServerECDHParams - -> DigitalSignatureAlg + -> PubKey -> DigitallySigned -> IO Bool -digitallySignECDHParamsVerify ctx dhparams sigAlg signature = do +digitallySignECDHParamsVerify ctx dhparams pubKey signature = do expectedData <- withClientAndServerRandom ctx $ encodeSignedECDHParams dhparams - signatureVerify ctx signature sigAlg expectedData + signatureVerify ctx signature pubKey expectedData withClientAndServerRandom :: Context -> (ClientRandom -> ServerRandom -> b) -> IO b withClientAndServerRandom ctx f = do diff --git a/Network/TLS/Handshake/State.hs b/Network/TLS/Handshake/State.hs --- a/Network/TLS/Handshake/State.hs +++ b/Network/TLS/Handshake/State.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Handshake.State @@ -14,7 +15,6 @@ , HandshakeDigest(..) , HandshakeMode13(..) , RTT0Status(..) - , Secret13(..) , CertReqCBdata , HandshakeM , newEmptyHandshake @@ -64,8 +64,10 @@ , getTLS13HandshakeMode , setTLS13RTT0Status , getTLS13RTT0Status - , setTLS13Secret - , getTLS13Secret + , setTLS13EarlySecret + , getTLS13EarlySecret + , setTLS13ResumptionSecret + , getTLS13ResumptionSecret , setCCS13Sent , getCCS13Sent ) where @@ -83,11 +85,6 @@ import Data.X509 (CertificateChain) import Data.ByteArray (ByteArrayAccess) -data Secret13 = NoSecret - | EarlySecret ByteString - | ResuptionSecret ByteString - deriving (Eq, Show) - data HandshakeKeyState = HandshakeKeyState { hksRemotePublicKey :: !(Maybe PubKey) , hksLocalPublicPrivateKeys :: !(Maybe (PubKey, PrivKey)) @@ -131,7 +128,8 @@ , hstNegotiatedGroup :: Maybe Group , hstTLS13HandshakeMode :: HandshakeMode13 , hstTLS13RTT0Status :: !RTT0Status - , hstTLS13Secret :: Secret13 + , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) + , hstTLS13ResumptionSecret :: Maybe (BaseSecret ResumptionSecret) , hstCCS13Sent :: !Bool } deriving (Show) @@ -220,7 +218,8 @@ , hstNegotiatedGroup = Nothing , hstTLS13HandshakeMode = FullHandshake , hstTLS13RTT0Status = RTT0None - , hstTLS13Secret = NoSecret + , hstTLS13EarlySecret = Nothing + , hstTLS13ResumptionSecret = Nothing , hstCCS13Sent = False } @@ -301,11 +300,17 @@ getTLS13RTT0Status :: HandshakeM RTT0Status getTLS13RTT0Status = gets hstTLS13RTT0Status -setTLS13Secret :: Secret13 -> HandshakeM () -setTLS13Secret secret = modify (\hst -> hst { hstTLS13Secret = secret }) +setTLS13EarlySecret :: BaseSecret EarlySecret -> HandshakeM () +setTLS13EarlySecret secret = modify (\hst -> hst { hstTLS13EarlySecret = Just secret }) -getTLS13Secret :: HandshakeM Secret13 -getTLS13Secret = gets hstTLS13Secret +getTLS13EarlySecret :: HandshakeM (Maybe (BaseSecret EarlySecret)) +getTLS13EarlySecret = gets hstTLS13EarlySecret + +setTLS13ResumptionSecret :: BaseSecret ResumptionSecret -> HandshakeM () +setTLS13ResumptionSecret secret = modify (\hst -> hst { hstTLS13ResumptionSecret = Just secret }) + +getTLS13ResumptionSecret :: HandshakeM (Maybe (BaseSecret ResumptionSecret)) +getTLS13ResumptionSecret = gets hstTLS13ResumptionSecret setCCS13Sent :: Bool -> HandshakeM () setCCS13Sent sent = modify (\hst -> hst { hstCCS13Sent = sent }) diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -59,9 +59,13 @@ , putSignatureHashAlgorithm , getBinaryVersion , putBinaryVersion + , getClientRandom32 + , putClientRandom32 + , getServerRandom32 , putServerRandom32 - , putExtension , getExtensions + , putExtension + , getSession , putSession , putDNames , getDNames diff --git a/Network/TLS/Packet13.hs b/Network/TLS/Packet13.hs --- a/Network/TLS/Packet13.hs +++ b/Network/TLS/Packet13.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Network.TLS.Packet13 @@ -14,6 +15,7 @@ , getHandshakeType13 , decodeHandshakeRecord13 , decodeHandshake13 + , decodeHandshakes13 ) where import qualified Data.ByteString as B @@ -23,6 +25,7 @@ import Network.TLS.Wire import Network.TLS.Imports import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) +import Network.TLS.ErrT encodeHandshakes13 :: [Handshake13] -> ByteString encodeHandshakes13 hss = B.concat $ map encodeHandshake13 hss @@ -41,6 +44,13 @@ putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) encodeHandshake13' :: Handshake13 -> ByteString +encodeHandshake13' (ClientHello13 version random session cipherIDs exts) = runPut $ do + putBinaryVersion version + putClientRandom32 random + putSession session + putWords16 cipherIDs + putWords8 [0] + putExtensions exts encodeHandshake13' (ServerHello13 random session cipherId exts) = runPut $ do putBinaryVersion TLS12 putServerRandom32 random @@ -74,13 +84,21 @@ encodeHandshake13' (KeyUpdate13 UpdateNotRequested) = runPut $ putWord8 0 encodeHandshake13' (KeyUpdate13 UpdateRequested) = runPut $ putWord8 1 -encodeHandshake13' _ = error "encodeHandshake13'" - encodeHandshakeHeader13 :: HandshakeType13 -> Int -> ByteString encodeHandshakeHeader13 ty len = runPut $ do putWord8 (valOfType ty) putWord24 len +decodeHandshakes13 :: MonadError TLSError m => ByteString -> m [Handshake13] +decodeHandshakes13 bs = case decodeHandshakeRecord13 bs of + GotError err -> throwError err + GotPartial _cont -> error "decodeHandshakes13" + GotSuccess (ty,content) -> case decodeHandshake13 ty content of + Left e -> throwError e + Right h -> return [h] + GotSuccessRemaining (ty,content) left -> case decodeHandshake13 ty content of + Left e -> throwError e + Right h -> (h:) <$> decodeHandshakes13 left {- decode and encode HANDSHAKE -} getHandshakeType13 :: Get HandshakeType13 @@ -98,6 +116,8 @@ decodeHandshake13 :: HandshakeType13 -> ByteString -> Either TLSError Handshake13 decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of + HandshakeType_ClientHello13 -> decodeClientHello13 + HandshakeType_ServerHello13 -> decodeServerHello13 HandshakeType_Finished13 -> decodeFinished13 HandshakeType_EncryptedExtensions13 -> decodeEncryptedExtensions13 HandshakeType_CertRequest13 -> decodeCertRequest13 @@ -106,7 +126,26 @@ HandshakeType_NewSessionTicket13 -> decodeNewSessionTicket13 HandshakeType_EndOfEarlyData13 -> return EndOfEarlyData13 HandshakeType_KeyUpdate13 -> decodeKeyUpdate13 - _fixme -> error $ "decodeHandshake13 " ++ show _fixme + +decodeClientHello13 :: Get Handshake13 +decodeClientHello13 = do + Just ver <- getBinaryVersion + random <- getClientRandom32 + session <- getSession + ciphers <- getWords16 + _comp <- getWords8 + exts <- fromIntegral <$> getWord16 >>= getExtensions + return $ ClientHello13 ver random session ciphers exts + +decodeServerHello13 :: Get Handshake13 +decodeServerHello13 = do + Just _ver <- getBinaryVersion + random <- getServerRandom32 + session <- getSession + cipherid <- getWord16 + _comp <- getWord8 + exts <- fromIntegral <$> getWord16 >>= getExtensions + return $ ServerHello13 random session cipherid exts decodeFinished13 :: Get Handshake13 decodeFinished13 = Finished13 <$> (remaining >>= getBytes) diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -239,7 +239,7 @@ defaultSupported :: Supported defaultSupported = Supported - { supportedVersions = [TLS12,TLS11,TLS10] + { supportedVersions = [TLS13,TLS12,TLS11,TLS10] , supportedCiphers = [] , supportedCompressions = [nullCompression] , supportedHashSignatures = [ (HashIntrinsic, SignatureEd448) diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -214,7 +214,47 @@ deriving (Eq) instance Show ExtensionRaw where - show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs ++ "" + show (ExtensionRaw eid bs) = "ExtensionRaw " ++ showEID eid ++ " " ++ showBytesHex bs + +showEID :: ExtensionID -> String +showEID 0x0 = "ServerName" +showEID 0x1 = "MaxFragmentLength" +showEID 0x2 = "ClientCertificateUrl" +showEID 0x3 = "TrustedCAKeys" +showEID 0x4 = "TruncatedHMAC" +showEID 0x5 = "StatusRequest" +showEID 0x6 = "UserMapping" +showEID 0x7 = "ClientAuthz" +showEID 0x8 = "ServerAuthz" +showEID 0x9 = "CertType" +showEID 0xa = "NegotiatedGroups" +showEID 0xb = "EcPointFormats" +showEID 0xc = "SRP" +showEID 0xd = "SignatureAlgorithm" +showEID 0xe = "SRTP" +showEID 0xf = "Heartbeat" +showEID 0x10 = "ApplicationLayerProtocolNegotiation" +showEID 0x11 = "StatusRequestv2" +showEID 0x12 = "SignedCertificateTimestamp" +showEID 0x13 = "ClientCertificateType" +showEID 0x14 = "ServerCertificateType" +showEID 0x15 = "Padding" +showEID 0x16 = "EncryptThenMAC" +showEID 0x17 = "ExtendedMasterSecret" +showEID 0x23 = "SessionTicket" +showEID 0x29 = "PreShardeKey" +showEID 0x2a = "EarlyData" +showEID 0x2b = "SupportedVersions" +showEID 0x2c = "Cookie" +showEID 0x2d = "PskKeyExchangeModes" +showEID 0x2f = "CertificateAuthorities" +showEID 0x30 = "OidFilters" +showEID 0x31 = "PostHandshakeAuth" +showEID 0x32 = "SignatureAlgorithmsCert" +showEID 0x33 = "KeyShare" +showEID 0xff01 = "SecureRenegotiation" +showEID 0xffa5 = "QuicTransportParameters" +showEID x = show x data AlertLevel = AlertLevel_Warning diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE EmptyDataDecls #-} -- | -- Module : Network.TLS.Types -- License : BSD-style @@ -19,6 +20,16 @@ , HostName , Second , Millisecond + , EarlySecret + , HandshakeSecret + , ApplicationSecret + , ResumptionSecret + , BaseSecret(..) + , ClientTrafficSecret(..) + , ServerTrafficSecret(..) + , SecretTriple(..) + , SecretPair(..) + , MasterSecret(..) ) where import Network.TLS.Imports @@ -76,3 +87,26 @@ invertRole :: Role -> Role invertRole ClientRole = ServerRole invertRole ServerRole = ClientRole + +data EarlySecret +data HandshakeSecret +data ApplicationSecret +data ResumptionSecret + +newtype BaseSecret a = BaseSecret ByteString deriving Show +newtype ClientTrafficSecret a = ClientTrafficSecret ByteString deriving Show +newtype ServerTrafficSecret a = ServerTrafficSecret ByteString deriving Show + +data SecretTriple a = SecretTriple + { triBase :: BaseSecret a + , triClient :: ClientTrafficSecret a + , triServer :: ServerTrafficSecret a + } + +data SecretPair a = SecretPair + { pairBase :: BaseSecret a + , pairClient :: ClientTrafficSecret a + } + +-- Master secret for TLS 1.2 or earlier. +newtype MasterSecret = MasterSecret ByteString deriving Show diff --git a/Network/TLS/X509.hs b/Network/TLS/X509.hs --- a/Network/TLS/X509.hs +++ b/Network/TLS/X509.hs @@ -23,6 +23,7 @@ , FailedReason , ServiceID , wrapCertificateChecks + , pubkeyType ) where import Data.X509 @@ -60,3 +61,6 @@ | SelfSigned `elem` l = CertificateUsageReject CertificateRejectUnknownCA | EmptyChain `elem` l = CertificateUsageReject CertificateRejectAbsent | otherwise = CertificateUsageReject $ CertificateRejectOther (show l) + +pubkeyType :: PubKey -> String +pubkeyType = show . pubkeyToAlg diff --git a/Tests/Marshalling.hs b/Tests/Marshalling.hs --- a/Tests/Marshalling.hs +++ b/Tests/Marshalling.hs @@ -133,7 +133,17 @@ instance Arbitrary Handshake13 where arbitrary = oneof - [ NewSessionTicket13 + [ arbitrary >>= \ver -> ClientHello13 ver + <$> arbitrary + <*> arbitrary + <*> arbitraryCiphersIDs + <*> arbitraryHelloExtensions ver + , arbitrary >>= \ver -> ServerHello13 + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryHelloExtensions ver + , NewSessionTicket13 <$> arbitrary <*> arbitrary <*> genByteString 32 -- nonce diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,5 +1,5 @@ Name: tls -Version: 1.5.1 +Version: 1.5.2 Description: Native Haskell TLS and SSL protocol implementation for server and client. .