diff --git a/Benchmarks/Benchmarks.hs b/Benchmarks/Benchmarks.hs --- a/Benchmarks/Benchmarks.hs +++ b/Benchmarks/Benchmarks.hs @@ -10,12 +10,34 @@ import Data.X509 import Data.X509.Validation import Data.Default.Class +import Data.IORef import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +blockCipher :: Cipher +blockCipher = Cipher + { cipherID = 0xff12 + , cipherName = "rsa-id-const" + , cipherBulk = Bulk + { bulkName = "id" + , bulkKeySize = 16 + , bulkIVSize = 16 + , bulkExplicitIV= 0 + , bulkAuthTagLen= 0 + , bulkBlockSize = 16 + , bulkF = BulkBlockF $ \_ _ _ -> (\m -> (m, B.empty)) + } + , cipherHash = MD5 + , cipherPRFHash = Nothing + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } + +recvDataNonNull :: Context -> IO B.ByteString recvDataNonNull ctx = recvData ctx >>= \l -> if B.null l then recvDataNonNull ctx else return l +getParams :: Version -> Cipher -> (ClientParams, ServerParams) getParams connectVer cipher = (cParams, sParams) where sParams = def { serverSupported = supported , serverShared = def { @@ -35,12 +57,18 @@ } (pubKey, privKey) = getGlobalRSAPair -runTLSPipe params tlsServer tlsClient d name = bench name . nfIO $ do +runTLSPipe :: (ClientParams, ServerParams) + -> (Context -> Chan b -> IO ()) + -> (Chan a -> Context -> IO ()) + -> a + -> IO b +runTLSPipe params tlsServer tlsClient d = do (startQueue, resultQueue) <- establishDataPipe params tlsServer tlsClient writeChan startQueue d readChan resultQueue -bench1 params !d name = runTLSPipe params tlsServer tlsClient d name +runTLSPipeSimple :: (ClientParams, ServerParams) -> B.ByteString -> IO B.ByteString +runTLSPipeSimple params bs = runTLSPipe params tlsServer tlsClient bs where tlsServer ctx queue = do handshake ctx d <- recvDataNonNull ctx @@ -53,12 +81,39 @@ bye ctx return () +benchConnection :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark +benchConnection params !d name = bench name . nfIO $ runTLSPipeSimple params d + +benchResumption :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark +benchResumption params !d name = env initializeSession runResumption + where + initializeSession = do + sessionRef <- newIORef Nothing + let sessionManager = oneSessionManager sessionRef + params1 = setPairParamsSessionManager sessionManager params + _ <- runTLSPipeSimple params1 d + + Just sessionParams <- readIORef sessionRef + let params2 = setPairParamsSessionResuming sessionParams params1 + newIORef params2 + + runResumption paramsRef = bench name . nfIO $ do + params2 <- readIORef paramsRef + runTLSPipeSimple params2 d + +main :: IO () main = defaultMain [ bgroup "connection" -- not sure the number actually make sense for anything. improve .. - [ bench1 (getParams SSL3 blockCipher) (B.replicate 256 0) "SSL3-256 bytes" - , bench1 (getParams TLS10 blockCipher) (B.replicate 256 0) "TLS10-256 bytes" - , bench1 (getParams TLS11 blockCipher) (B.replicate 256 0) "TLS11-256 bytes" - , bench1 (getParams TLS12 blockCipher) (B.replicate 256 0) "TLS12-256 bytes" + [ benchConnection (getParams SSL3 blockCipher) (B.replicate 256 0) "SSL3-256 bytes" + , benchConnection (getParams TLS10 blockCipher) (B.replicate 256 0) "TLS10-256 bytes" + , benchConnection (getParams TLS11 blockCipher) (B.replicate 256 0) "TLS11-256 bytes" + , benchConnection (getParams TLS12 blockCipher) (B.replicate 256 0) "TLS12-256 bytes" + ] + , bgroup "resumption" + [ benchResumption (getParams SSL3 blockCipher) (B.replicate 256 0) "SSL3-256 bytes" + , benchResumption (getParams TLS10 blockCipher) (B.replicate 256 0) "TLS10-256 bytes" + , benchResumption (getParams TLS11 blockCipher) (B.replicate 256 0) "TLS11-256 bytes" + , benchResumption (getParams TLS12 blockCipher) (B.replicate 256 0) "TLS12-256 bytes" ] ] diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,59 @@ +## Version 1.4.0 + +- Wrap renegotiation failures with HandshakeFailed [#237](https://github.com/vincenthz/hs-tls/pull/237) +- Improve selection of server certificate and use "signature_algorithms" extension [#236](https://github.com/vincenthz/hs-tls/pull/236) +- Change Bytes to ByteString and deprecate the Bytes type alias [#230](https://github.com/vincenthz/hs-tls/pull/230) +- Session compression and SNI [#223](https://github.com/vincenthz/hs-tls/pull/223) +- Deprecating ciphersuite_medium. Putting WARNING to ciphersuite_all since this includes RC4 [#153](https://github.com/vincenthz/hs-tls/pull/153) [#222](https://github.com/vincenthz/hs-tls/pull/222) +- Removing NPN [#214](https://github.com/vincenthz/hs-tls/pull/214) +- Supporting RSAPSS defined in TLS 1.3 [#207](https://github.com/vincenthz/hs-tls/pull/207) +- Supporting X25519 and X448 in the IES style. [#205](https://github.com/vincenthz/hs-tls/pull/205) +- Strip leading zeros in DHE premaster secret [#201](https://github.com/vincenthz/hs-tls/pull/201) + +FEATURES: + +- RSASSA-PSS signatures can be enabled with `supportedHashSignatures`. This + uses assignments from TLS 1.3, for example `(HashIntrinsic, SignatureRSApssSHA256)`. +- Diffie-Hellman with elliptic curves X25519 and X448: This can be enabled with + `supportedGroups`, which also gives control over curve preference. +- ECDH with curve P-256 now uses optimized C implementation from package `cryptonite`. + +API CHANGES: + +- Cipher list `ciphersuite_medium` is now deprecated, users are advised to use + `ciphersuite_default` or `ciphersuite_strong`. List `ciphersuite_all` is kept + for compatibility with old servers but this is discouraged and generates a + warning (this includes RC4 ciphers, see [#153](https://github.com/vincenthz/hs-tls/pull/153) + for reference). +- Support for NPN (Next Protocol Negotiation) has been removed. The replacement + is ALPN (Application-Layer Protocol Negotiation). +- Data type `SessionData` now contains fields for compression algorithm and + client SNI. A `SessionManager` implementation that serializes/deserializes + `SessionData` values must deal with the new fields. +- Module `Network.TLS` exports a type alias named `Bytes` which is now deprecated. + The replacement is to use strict `ByteString` directly. + +## Version 1.3.11 + +- Using reliable versions of dependent libraries. + +## Version 1.3.10 + +- Selecting a cipher based on "signature_algorithms" [#193](https://github.com/vincenthz/hs-tls/pull/193) +- Respecting the "signature_algorithms" extension [#137](https://github.com/vincenthz/hs-tls/pull/137) +- Fix RSA signature in CertificateVerify with TLS < 1.2 [#189](https://github.com/vincenthz/hs-tls/pull/189) +- Fix ECDSA with TLS 1.0 / TLS 1.1 [#187](https://github.com/vincenthz/hs-tls/pull/187) +- Sending an empty server name from a server if necessary. [#175](https://github.com/vincenthz/hs-tls/pull/175) +- `Network.TLS.Extra` provides Finite Field Diffie-Hellman Ephemeral Parameters in RFC 7919 [#174](https://github.com/vincenthz/hs-tls/pull/174) +- Restore ability to renegotiate[#164](https://github.com/vincenthz/hs-tls/pull/164) + +## Version 1.3.9 + +- Drop support for old GHC. +- Enable sha384 ciphers and provide `ciphersuite_default` as default set of ciphers for common needs [#168](https://github.com/vincenthz/hs-tls/pull/168) +- SNI late checks [#147](https://github.com/vincenthz/hs-tls/pull/147) +- Expose the HasBackend(..) class fully, so that developers can use TLS over their own channels [#149](https://github.com/vincenthz/hs-tls/pull/149) + ## Version 1.3.8 - Fix older GHC builds diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -85,7 +85,7 @@ , bye , handshake - -- * Next Protocol Negotiation + -- * Application Layer Protocol Negotiation , getNegotiatedProtocol -- * Server Name Indication @@ -125,6 +125,9 @@ , ValidationCache(..) , ValidationCacheResult(..) , exceptionValidationCache + + -- * Key exchange group + , Group(..) ) where import Network.TLS.Backend (Backend(..), HasBackend(..)) @@ -133,9 +136,8 @@ , Header(..), ProtocolType(..), CertificateType(..) , AlertDescription(..) , ClientRandom(..), ServerRandom(..) - , Bytes , Handshake) -import Network.TLS.Crypto (KxError(..), DHParams) +import Network.TLS.Crypto (KxError(..), DHParams, Group(..)) import Network.TLS.Cipher import Network.TLS.Hooks import Network.TLS.Measurement @@ -149,3 +151,7 @@ import Network.TLS.Types import Data.X509 (PubKey(..), PrivKey(..)) import Data.X509.Validation +import Data.ByteString as B + +{-# DEPRECATED Bytes "Use Data.ByteString.Bytestring instead of Bytes." #-} +type Bytes = B.ByteString diff --git a/Network/TLS/Cap.hs b/Network/TLS/Cap.hs --- a/Network/TLS/Cap.hs +++ b/Network/TLS/Cap.hs @@ -11,7 +11,7 @@ , hasExplicitBlockIV ) where -import Network.TLS.Struct +import Network.TLS.Types hasHelloExtensions, hasExplicitBlockIV :: Version -> Bool diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -65,8 +65,6 @@ import Network.TLS.Backend import Network.TLS.Context.Internal import Network.TLS.Struct -import Network.TLS.Cipher (Cipher(..), CipherKeyExchangeType(..)) -import Network.TLS.Credentials import Network.TLS.State import Network.TLS.Hooks import Network.TLS.Record.State @@ -76,12 +74,10 @@ import Network.TLS.Handshake (handshakeClient, handshakeClientWith, handshakeServer, handshakeServerWith) import Network.TLS.X509 import Network.TLS.RNG -import Data.Maybe (isJust) import Control.Concurrent.MVar -import Control.Monad.State +import Control.Monad.State.Strict import Data.IORef -import Data.Monoid (mappend) -- deprecated imports #ifdef INCLUDE_NETWORK @@ -92,7 +88,6 @@ class TLSParams a where getTLSCommonParams :: a -> CommonParams getTLSRole :: a -> Role - getCiphers :: a -> Credentials -> [Cipher] doHandshake :: a -> Context -> IO () doHandshakeWith :: a -> Context -> Handshake -> IO () @@ -102,7 +97,6 @@ , clientDebug cparams ) getTLSRole _ = ClientRole - getCiphers cparams _ = supportedCiphers $ clientSupported cparams doHandshake = handshakeClient doHandshakeWith = handshakeClientWith @@ -112,34 +106,6 @@ , serverDebug sparams ) getTLSRole _ = ServerRole - -- on the server we filter our allowed ciphers here according - -- to the credentials and DHE parameters loaded - getCiphers sparams extraCreds = filter authorizedCKE (supportedCiphers $ serverSupported sparams) - where authorizedCKE cipher = - case cipherKeyExchange cipher of - CipherKeyExchange_RSA -> canEncryptRSA - CipherKeyExchange_DH_Anon -> canDHE - CipherKeyExchange_DHE_RSA -> canSignRSA && canDHE - CipherKeyExchange_DHE_DSS -> canSignDSS && canDHE - CipherKeyExchange_ECDHE_RSA -> canSignRSA - -- unimplemented: EC - CipherKeyExchange_ECDHE_ECDSA -> False - -- unimplemented: non ephemeral DH & ECDH. - -- Note, these *should not* be implemented, and have - -- (for example) been removed in OpenSSL 1.1.0 - -- - CipherKeyExchange_DH_DSS -> False - CipherKeyExchange_DH_RSA -> False - CipherKeyExchange_ECDH_ECDSA -> False - CipherKeyExchange_ECDH_RSA -> False - - canDHE = isJust $ serverDHEParams sparams - canSignDSS = SignatureDSS `elem` signingAlgs - canSignRSA = SignatureRSA `elem` signingAlgs - canEncryptRSA = isJust $ credentialsFindForDecrypting creds - signingAlgs = credentialsListSigningAlgorithms creds - serverCreds = sharedCredentials $ serverShared sparams - creds = extraCreds `mappend` serverCreds doHandshake = handshakeServer doHandshakeWith = handshakeServerWith @@ -162,12 +128,7 @@ let role = getTLSRole params st = newTLSState rng role - ciphers = getCiphers params --- we still might get some ciphers from SNI callback --- If we could bail only on protocols which require the main cert?? --- when (null (ciphers mempty)) $ error "no ciphers available with those parameters" - stvar <- newMVar st eof <- newIORef False established <- newIORef False @@ -188,7 +149,6 @@ { ctxConnection = getBackend backend , ctxShared = shared , ctxSupported = supported - , ctxCiphers = ciphers , ctxState = stvar , ctxTxState = tx , ctxRxState = rx diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs --- a/Network/TLS/Context/Internal.hs +++ b/Network/TLS/Context/Internal.hs @@ -57,7 +57,6 @@ import Network.TLS.Backend import Network.TLS.Extension import Network.TLS.Cipher -import Network.TLS.Credentials (Credentials) import Network.TLS.Struct import Network.TLS.Compression (Compression) import Network.TLS.State @@ -66,10 +65,11 @@ import Network.TLS.Record.State import Network.TLS.Parameters import Network.TLS.Measurement +import Data.ByteString (ByteString) import qualified Data.ByteString as B import Control.Concurrent.MVar -import Control.Monad.State +import Control.Monad.State.Strict import Control.Exception (throwIO, Exception()) import Data.IORef import Data.Tuple @@ -80,7 +80,7 @@ { infoVersion :: Version , infoCipher :: Cipher , infoCompression :: Compression - , infoMasterSecret :: Maybe Bytes + , infoMasterSecret :: Maybe ByteString , infoClientRandom :: Maybe ClientRandom , infoServerRandom :: Maybe ServerRandom } deriving (Show,Eq) @@ -90,8 +90,6 @@ { ctxConnection :: Backend -- ^ return the backend object associated with this context , ctxSupported :: Supported , ctxShared :: Shared - , ctxCiphers :: Credentials -> [Cipher] -- ^ list of allowed ciphers according to parameters - -- and additional credentials , ctxState :: MVar TLSState , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not. @@ -141,10 +139,10 @@ (Just v, Just c) -> return $ Just $ Information v c comp ms cr sr _ -> return Nothing -contextSend :: Context -> Bytes -> IO () +contextSend :: Context -> ByteString -> IO () contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b -contextRecv :: Context -> Int -> IO Bytes +contextRecv :: Context -> Int -> IO ByteString contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz ctxEOF :: Context -> IO Bool @@ -218,7 +216,7 @@ Left err -> return (st, Left err) Right (a, newSt) -> return (newSt, Right a) -getStateRNG :: Context -> Int -> IO Bytes +getStateRNG :: Context -> Int -> IO ByteString getStateRNG ctx n = usingState_ ctx $ genRandom n withReadLock :: Context -> IO a -> IO a diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -17,7 +17,7 @@ , bye , handshake - -- * Next Protocol Negotiation + -- * Application Layer Protocol Negotiation , getNegotiatedProtocol -- * Server Name Indication @@ -43,7 +43,7 @@ import qualified Data.ByteString.Lazy as L import qualified Control.Exception as E -import Control.Monad.State +import Control.Monad.State.Strict -- | notify the context that this side wants to close connection. @@ -54,7 +54,7 @@ bye :: MonadIO m => Context -> m () bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] --- | If the Next Protocol Negotiation or ALPN extensions have been used, this will +-- | If the ALPN extensions have been used, this will -- return get the protocol agreed upon. getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString) getNegotiatedProtocol ctx = liftIO $ usingState_ ctx S.getNegotiatedProtocol @@ -82,15 +82,10 @@ recvData :: MonadIO m => Context -> m B.ByteString recvData ctx = liftIO $ do checkValid ctx - E.catchJust safeHandleError_EOF - doRecv - (\() -> return B.empty) - where doRecv = do - pkt <- withReadLock ctx $ recvPacket ctx - either onError process pkt - - safeHandleError_EOF Error_EOF = Just () - safeHandleError_EOF _ = Nothing + pkt <- withReadLock ctx $ recvPacket ctx + either onError process pkt + where onError Error_EOF = -- Not really an error. + return B.empty onError err@(Error_Protocol (reason,fatal,desc)) = terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason @@ -98,9 +93,9 @@ terminate err AlertLevel_Fatal InternalError (show err) process (Handshake [ch@(ClientHello {})]) = - withRWLock ctx ((ctxDoHandshakeWith ctx) ctx ch) >> recvData ctx + handshakeWith ctx ch >> recvData ctx process (Handshake [hr@HelloRequest]) = - withRWLock ctx ((ctxDoHandshakeWith ctx) ctx hr) >> recvData ctx + handshakeWith ctx hr >> recvData ctx process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye >> setEOF ctx >> return B.empty process (Alert [(AlertLevel_Fatal, desc)]) = do diff --git a/Network/TLS/Credentials.hs b/Network/TLS/Credentials.hs --- a/Network/TLS/Credentials.hs +++ b/Network/TLS/Credentials.hs @@ -15,17 +15,23 @@ , credentialsFindForSigning , credentialsFindForDecrypting , credentialsListSigningAlgorithms + , credentialPublicPrivateKeys + , credentialMatchesHashSignatures ) where +import Data.ByteString (ByteString) import Data.Monoid import Data.Maybe (catMaybes) import Data.List (find) -import Network.TLS.Struct +import Network.TLS.Crypto import Network.TLS.X509 import Data.X509.File import Data.X509.Memory import Data.X509 +import qualified Data.X509 as X509 +import qualified Network.TLS.Struct as TLS + type Credential = (CertificateChain, PrivKey) newtype Credentials = Credentials [Credential] @@ -44,8 +50,8 @@ -- | similar to 'credentialLoadX509' but take the certificate -- and private key from memory instead of from the filesystem. -credentialLoadX509FromMemory :: Bytes - -> Bytes +credentialLoadX509FromMemory :: ByteString + -> ByteString -> Either String Credential credentialLoadX509FromMemory certData = credentialLoadX509ChainFromMemory certData [] @@ -67,9 +73,9 @@ -- | similar to 'credentialLoadX509FromMemory' but also allow -- specifying chain certificates. -credentialLoadX509ChainFromMemory :: Bytes - -> [Bytes] - -> Bytes +credentialLoadX509ChainFromMemory :: ByteString + -> [ByteString] + -> ByteString -> Either String Credential credentialLoadX509ChainFromMemory certData chainData privateData = do let x509 = readSignedObjectFromMemory certData @@ -79,14 +85,16 @@ [] -> Left "no keys found" (k:_) -> Right (CertificateChain . concat $ x509 : chains, k) -credentialsListSigningAlgorithms :: Credentials -> [SignatureAlgorithm] +credentialsListSigningAlgorithms :: Credentials -> [DigitalSignatureAlg] credentialsListSigningAlgorithms (Credentials l) = catMaybes $ map credentialCanSign l -credentialsFindForSigning :: SignatureAlgorithm -> Credentials -> Maybe (CertificateChain, PrivKey) +credentialsFindForSigning :: DigitalSignatureAlg -> Credentials -> Maybe Credential credentialsFindForSigning sigAlg (Credentials l) = find forSigning l - where forSigning cred = Just sigAlg == credentialCanSign cred + where forSigning cred = case credentialCanSign cred of + Nothing -> False + Just sig -> sig == sigAlg -credentialsFindForDecrypting :: Credentials -> Maybe (CertificateChain, PrivKey) +credentialsFindForDecrypting :: Credentials -> Maybe Credential credentialsFindForDecrypting (Credentials l) = find forEncrypting l where forEncrypting cred = Just () == credentialCanDecrypt cred @@ -107,21 +115,58 @@ pub = certPubKey cert signed = getCertificateChainLeaf chain -credentialCanSign :: Credential -> Maybe SignatureAlgorithm +credentialCanSign :: Credential -> Maybe DigitalSignatureAlg credentialCanSign (chain, priv) = case extensionGet (certExtensions cert) of - Nothing -> getSignatureAlg pub priv + Nothing -> findDigitalSignatureAlg (pub, priv) Just (ExtKeyUsage flags) - | KeyUsage_digitalSignature `elem` flags -> getSignatureAlg pub priv + | KeyUsage_digitalSignature `elem` flags -> findDigitalSignatureAlg (pub, priv) | otherwise -> Nothing where cert = signedObject $ getSigned signed pub = certPubKey cert signed = getCertificateChainLeaf chain -getSignatureAlg :: PubKey -> PrivKey -> Maybe SignatureAlgorithm -getSignatureAlg pub priv = - case (pub, priv) of - (PubKeyRSA _, PrivKeyRSA _) -> Just SignatureRSA - (PubKeyDSA _, PrivKeyDSA _) -> Just SignatureDSS - --(PubKeyECDSA _, PrivKeyECDSA _) -> Just SignatureECDSA - _ -> Nothing +credentialPublicPrivateKeys :: Credential -> (PubKey, PrivKey) +credentialPublicPrivateKeys (chain, priv) = pub `seq` (pub, priv) + where cert = signedObject $ getSigned signed + pub = certPubKey cert + signed = getCertificateChainLeaf chain + +getHashSignature :: SignedCertificate -> Maybe TLS.HashAndSignatureAlgorithm +getHashSignature signed = + case signedAlg $ getSigned signed of + SignatureALG hashAlg PubKeyALG_RSA -> convertHash TLS.SignatureRSA hashAlg + SignatureALG hashAlg PubKeyALG_DSA -> convertHash TLS.SignatureDSS hashAlg + SignatureALG hashAlg PubKeyALG_EC -> convertHash TLS.SignatureECDSA hashAlg + + SignatureALG X509.HashSHA256 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssSHA256) + SignatureALG X509.HashSHA384 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssSHA384) + SignatureALG X509.HashSHA512 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssSHA512) + + _ -> Nothing + where + convertHash sig X509.HashMD5 = Just (TLS.HashMD5 , sig) + convertHash sig X509.HashSHA1 = Just (TLS.HashSHA1 , sig) + convertHash sig X509.HashSHA224 = Just (TLS.HashSHA224, sig) + convertHash sig X509.HashSHA256 = Just (TLS.HashSHA256, sig) + convertHash sig X509.HashSHA384 = Just (TLS.HashSHA384, sig) + convertHash sig X509.HashSHA512 = Just (TLS.HashSHA512, sig) + convertHash _ _ = Nothing + +-- | Checks whether certificates in the chain comply with a list of +-- hash/signature algorithm pairs. Currently the verification applies only +-- to the leaf certificate, if it is not self-signed. This may be extended +-- to additional chain elements in the future. +credentialMatchesHashSignatures :: [TLS.HashAndSignatureAlgorithm] -> Credential -> Bool +credentialMatchesHashSignatures hashSigs (chain, _) = + case chain of + CertificateChain [] -> True + CertificateChain (leaf:_) -> isSelfSigned leaf || matchHashSig leaf + where + matchHashSig signed = case getHashSignature signed of + Nothing -> False + Just hs -> hs `elem` hashSigs + + isSelfSigned signed = + let cert = signedObject $ getSigned signed + in certSubjectDN cert == certIssuerDN cert diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -9,7 +9,8 @@ , hashFinal , module Network.TLS.Crypto.DH - , module Network.TLS.Crypto.ECDH + , module Network.TLS.Crypto.IES + , module Network.TLS.Crypto.Types -- * Hash , hash @@ -23,11 +24,14 @@ , PrivKey(..) , PublicKey , PrivateKey + , SignatureParams(..) + , findDigitalSignatureAlg , kxEncrypt , kxDecrypt , kxSign , kxVerify , KxError(..) + , RSAEncoding(..) ) where import qualified Crypto.Hash as H @@ -41,11 +45,13 @@ import qualified Crypto.PubKey.ECC.Types as ECC import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA +import qualified Crypto.PubKey.RSA.PSS as PSS import Crypto.Number.Serialize (os2ip) import Data.X509 (PrivKey(..), PubKey(..), PubKeyEC(..), SerializedPoint(..)) import Network.TLS.Crypto.DH -import Network.TLS.Crypto.ECDH +import Network.TLS.Crypto.IES +import Network.TLS.Crypto.Types import Data.ASN1.Types import Data.ASN1.Encoding @@ -62,6 +68,14 @@ | KxUnsupported deriving (Show) +findDigitalSignatureAlg :: (PubKey, PrivKey) -> Maybe DigitalSignatureAlg +findDigitalSignatureAlg keyPair = + case keyPair of + (PubKeyRSA _, PrivKeyRSA _) -> Just RSA + (PubKeyDSA _, PrivKeyDSA _) -> Just DSS + --(PubKeyECDSA _, PrivKeyECDSA _) -> Just ECDSA + _ -> Nothing + -- functions to use the hidden class. hashInit :: Hash -> HashContext hashInit MD5 = HashContext $ ContextSimple (H.hashInit :: H.Context H.MD5) @@ -153,12 +167,26 @@ kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError `fmap` RSA.decryptSafer pk b kxDecrypt _ _ = return (Left KxUnsupported) +data RSAEncoding = RSApkcs1 | RSApss deriving (Show,Eq) + +-- Signature algorithm and associated parameters. +-- +-- FIXME add RSAPSSParams, Ed25519Params, Ed448Params +data SignatureParams = + RSAParams Hash RSAEncoding + | DSSParams + | ECDSAParams Hash + deriving (Show,Eq) + -- Verify that the signature matches the given message, using the -- public key. -- -kxVerify :: PublicKey -> Hash -> ByteString -> ByteString -> Bool -kxVerify (PubKeyRSA pk) alg msg sign = rsaVerifyHash alg pk msg sign -kxVerify (PubKeyDSA pk) _ msg signBS = + +kxVerify :: PublicKey -> SignatureParams -> ByteString -> ByteString -> Bool +kxVerify (PubKeyRSA pk) (RSAParams alg RSApkcs1) msg sign = rsaVerifyHash alg pk msg sign +kxVerify (PubKeyRSA pk) (RSAParams alg RSApss) msg sign = rsapssVerifyHash alg pk msg sign +kxVerify (PubKeyDSA pk) DSSParams msg signBS = + case dsaToSignature signBS of Just sig -> DSA.verify H.SHA1 pk sig msg _ -> False @@ -173,7 +201,7 @@ Just $ DSA.Signature { DSA.sign_r = r, DSA.sign_s = s } _ -> Nothing -kxVerify (PubKeyEC key) alg msg sigBS = maybe False id $ do +kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = maybe False id $ do -- get the curve name and the public key data (curveName, pubBS) <- case key of PubKeyEC_Named curveName' pub -> Just (curveName',pub) @@ -232,17 +260,19 @@ -- kxSign :: MonadRandom r => PrivateKey - -> Hash + -> SignatureParams -> ByteString -> r (Either KxError ByteString) -kxSign (PrivKeyRSA pk) hashAlg msg = +kxSign (PrivKeyRSA pk) (RSAParams hashAlg RSApkcs1) msg = generalizeRSAError `fmap` rsaSignHash hashAlg pk msg -kxSign (PrivKeyDSA pk) _ msg = do +kxSign (PrivKeyRSA pk) (RSAParams hashAlg RSApss) msg = + generalizeRSAError `fmap` rsapssSignHash hashAlg pk msg +kxSign (PrivKeyDSA pk) DSSParams msg = do sign <- DSA.sign pk H.SHA1 msg return (Right $ encodeASN1' DER $ dsaSequence sign) where dsaSequence sign = [Start Sequence,IntVal (DSA.sign_r sign),IntVal (DSA.sign_s sign),End Sequence] ---kxSign _ _ _ = --- return (Left KxUnsupported) +kxSign _ _ _ = + return (Left KxUnsupported) rsaSignHash :: MonadRandom m => Hash -> RSA.PrivateKey -> ByteString -> m (Either RSA.Error ByteString) rsaSignHash SHA1_MD5 pk msg = RSA.signSafer noHash pk msg @@ -253,6 +283,12 @@ rsaSignHash SHA384 pk msg = RSA.signSafer (Just H.SHA384) pk msg rsaSignHash SHA512 pk msg = RSA.signSafer (Just H.SHA512) pk msg +rsapssSignHash :: MonadRandom m => Hash -> RSA.PrivateKey -> ByteString -> m (Either RSA.Error ByteString) +rsapssSignHash SHA256 pk msg = PSS.signSafer (PSS.defaultPSSParams H.SHA256) pk msg +rsapssSignHash SHA384 pk msg = PSS.signSafer (PSS.defaultPSSParams H.SHA384) pk msg +rsapssSignHash SHA512 pk msg = PSS.signSafer (PSS.defaultPSSParams H.SHA512) pk msg +rsapssSignHash _ _ _ = error "rsapssSignHash: unsupported hash" + rsaVerifyHash :: Hash -> RSA.PublicKey -> ByteString -> ByteString -> Bool rsaVerifyHash SHA1_MD5 = RSA.verify noHash rsaVerifyHash MD5 = RSA.verify (Just H.MD5) @@ -261,6 +297,12 @@ rsaVerifyHash SHA256 = RSA.verify (Just H.SHA256) rsaVerifyHash SHA384 = RSA.verify (Just H.SHA384) rsaVerifyHash SHA512 = RSA.verify (Just H.SHA512) + +rsapssVerifyHash :: Hash -> RSA.PublicKey -> ByteString -> ByteString -> Bool +rsapssVerifyHash SHA256 = PSS.verify (PSS.defaultPSSParams H.SHA256) +rsapssVerifyHash SHA384 = PSS.verify (PSS.defaultPSSParams H.SHA384) +rsapssVerifyHash SHA512 = PSS.verify (PSS.defaultPSSParams H.SHA512) +rsapssVerifyHash _ = error "rsapssVerifyHash: unsupported hash" noHash :: Maybe H.MD5 noHash = Nothing diff --git a/Network/TLS/Crypto/DH.hs b/Network/TLS/Crypto/DH.hs --- a/Network/TLS/Crypto/DH.hs +++ b/Network/TLS/Crypto/DH.hs @@ -19,6 +19,7 @@ import qualified Crypto.PubKey.DH as DH import Crypto.Number.Basic (numBits) +import qualified Data.ByteArray as B import Network.TLS.RNG type DHPublic = DH.PublicNumber @@ -42,7 +43,12 @@ return (priv, pub) dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey -dhGetShared params priv pub = DH.getShared params priv pub +dhGetShared params priv pub = + stripLeadingZeros (DH.getShared params priv pub) + where + -- strips leading zeros from the result of DH.getShared, as required + -- for DH(E) premaster secret in SSL/TLS before version 1.3. + stripLeadingZeros (DH.SharedKey sb) = DH.SharedKey (snd $ B.span (== 0) sb) dhUnwrap :: DHParams -> DHPublic -> [Integer] dhUnwrap (DH.Params p g _) (DH.PublicNumber y) = [p,g,y] diff --git a/Network/TLS/Crypto/ECDH.hs b/Network/TLS/Crypto/ECDH.hs deleted file mode 100644 --- a/Network/TLS/Crypto/ECDH.hs +++ /dev/null @@ -1,76 +0,0 @@ -module Network.TLS.Crypto.ECDH - ( - -- * ECDH types - ECDHParams(..) - , ECDHPublic - , ECDHPrivate(..) - - -- * ECDH methods - , ecdhPublic - , ecdhPrivate - , ecdhParams - , ecdhGenerateKeyPair - , ecdhGetShared - , ecdhUnwrap - , ecdhUnwrapPublic - ) where - -import Network.TLS.Extension.EC -import qualified Crypto.PubKey.ECC.DH as ECDH -import qualified Crypto.PubKey.ECC.Types as ECDH -import qualified Crypto.PubKey.ECC.Prim as ECC (isPointValid) -import Network.TLS.RNG -import Data.Word (Word16) - -data ECDHPublic = ECDHPublic ECDH.PublicPoint Int {- byte size -} - deriving (Show,Eq) - -newtype ECDHPrivate = ECDHPrivate ECDH.PrivateNumber deriving (Show,Eq) - -data ECDHParams = ECDHParams ECDH.Curve ECDH.CurveName deriving (Show,Eq) - -type ECDHKey = ECDH.SharedKey - -ecdhPublic :: Integer -> Integer -> Int -> ECDHPublic -ecdhPublic x y siz = ECDHPublic (ECDH.Point x y) siz - -ecdhPrivate :: Integer -> ECDHPrivate -ecdhPrivate = ECDHPrivate - -ecdhParams :: Word16 -> ECDHParams -ecdhParams w16 = ECDHParams curve name - where - Just name = toCurveName w16 -- FIXME - curve = ECDH.getCurveByName name - -ecdhGenerateKeyPair :: MonadRandom r => ECDHParams -> r (ECDHPrivate, ECDHPublic) -ecdhGenerateKeyPair (ECDHParams curve _) = do - priv <- ECDH.generatePrivate curve - let siz = pointSize curve - point = ECDH.calculatePublic curve priv - pub = ECDHPublic point siz - return (ECDHPrivate priv, pub) - -ecdhGetShared :: ECDHParams -> ECDHPrivate -> ECDHPublic -> Maybe ECDHKey -ecdhGetShared (ECDHParams curve _) (ECDHPrivate priv) (ECDHPublic point _) - | ECC.isPointValid curve point = Just $ ECDH.getShared curve priv point - | otherwise = Nothing - --- for server key exchange -ecdhUnwrap :: ECDHParams -> ECDHPublic -> (Word16,Integer,Integer,Int) -ecdhUnwrap (ECDHParams _ name) point = (w16,x,y,siz) - where - w16 = case fromCurveName name of - Just w -> w - Nothing -> error "ecdhUnwrap" - (x,y,siz) = ecdhUnwrapPublic point - --- for client key exchange -ecdhUnwrapPublic :: ECDHPublic -> (Integer,Integer,Int) -ecdhUnwrapPublic (ECDHPublic (ECDH.Point x y) siz) = (x,y,siz) -ecdhUnwrapPublic _ = error "ecdhUnwrapPublic" - -pointSize :: ECDH.Curve -> Int -pointSize = toBytes . ECDH.curveSizeBits - where - toBytes bits = (bits + 7) `div` 8 diff --git a/Network/TLS/Crypto/IES.hs b/Network/TLS/Crypto/IES.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Crypto/IES.hs @@ -0,0 +1,182 @@ +-- | +-- Module : Network.TLS.Crypto.IES +-- License : BSD-style +-- Maintainer : Kazu Yamamoto +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Crypto.IES + ( + GroupPublic + , GroupPrivate + , GroupKey + -- * Group methods + , groupGenerateKeyPair + , groupGetPubShared + , groupGetShared + , encodeGroupPublic + , decodeGroupPublic + ) where + +import Control.Arrow +import Crypto.ECC +import Crypto.Error +import Crypto.PubKey.DH +import Crypto.PubKey.ECIES +import Data.Proxy +import Network.TLS.Crypto.Types +import Network.TLS.Extra.FFDHE +import Network.TLS.Imports +import Network.TLS.RNG +import Network.TLS.Util.Serialization (os2ip,i2ospOf_) + +data GroupPrivate = GroupPri_P256 (Scalar Curve_P256R1) + | GroupPri_P384 (Scalar Curve_P384R1) + | GroupPri_P521 (Scalar Curve_P521R1) + | GroupPri_X255 (Scalar Curve_X25519) + | GroupPri_X448 (Scalar Curve_X448) + | GroupPri_FFDHE2048 PrivateNumber + | GroupPri_FFDHE3072 PrivateNumber + | GroupPri_FFDHE4096 PrivateNumber + | GroupPri_FFDHE6144 PrivateNumber + | GroupPri_FFDHE8192 PrivateNumber + deriving (Eq, Show) + +data GroupPublic = GroupPub_P256 (Point Curve_P256R1) + | GroupPub_P384 (Point Curve_P384R1) + | GroupPub_P521 (Point Curve_P521R1) + | GroupPub_X255 (Point Curve_X25519) + | GroupPub_X448 (Point Curve_X448) + | GroupPub_FFDHE2048 PublicNumber + | GroupPub_FFDHE3072 PublicNumber + | GroupPub_FFDHE4096 PublicNumber + | GroupPub_FFDHE6144 PublicNumber + | GroupPub_FFDHE8192 PublicNumber + deriving (Eq, Show) + +type GroupKey = SharedSecret + +p256 :: Proxy Curve_P256R1 +p256 = Proxy + +p384 :: Proxy Curve_P384R1 +p384 = Proxy + +p521 :: Proxy Curve_P521R1 +p521 = Proxy + +x25519 :: Proxy Curve_X25519 +x25519 = Proxy + +x448 :: Proxy Curve_X448 +x448 = Proxy + +groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublic) +groupGenerateKeyPair P256 = + (GroupPri_P256,GroupPub_P256) `fs` curveGenerateKeyPair p256 +groupGenerateKeyPair P384 = + (GroupPri_P384,GroupPub_P384) `fs` curveGenerateKeyPair p384 +groupGenerateKeyPair P521 = + (GroupPri_P521,GroupPub_P521) `fs` curveGenerateKeyPair p521 +groupGenerateKeyPair X25519 = + (GroupPri_X255,GroupPub_X255) `fs` curveGenerateKeyPair x25519 +groupGenerateKeyPair X448 = + (GroupPri_X448,GroupPub_X448) `fs` curveGenerateKeyPair x448 +groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 GroupPri_FFDHE2048 GroupPub_FFDHE2048 +groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 GroupPri_FFDHE3072 GroupPub_FFDHE3072 +groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 GroupPri_FFDHE4096 GroupPub_FFDHE4096 +groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 GroupPri_FFDHE6144 GroupPub_FFDHE6144 +groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 GroupPri_FFDHE8192 GroupPub_FFDHE8192 + +fs :: MonadRandom r + => (Scalar a -> GroupPrivate, Point a -> GroupPublic) + -> r (KeyPair a) + -> r (GroupPrivate, GroupPublic) +(t1, t2) `fs` action = do + keypair <- action + let pub = keypairGetPublic keypair + pri = keypairGetPrivate keypair + return (t1 pri, t2 pub) + +gen :: MonadRandom r + => Params + -> (PrivateNumber -> GroupPrivate) + -> (PublicNumber -> GroupPublic) + -> r (GroupPrivate, GroupPublic) +gen params priTag pubTag = do + pri <- generatePrivate params + let pub = calculatePublic params pri + return (priTag pri, pubTag pub) + +groupGetPubShared :: MonadRandom r => GroupPublic -> r (Maybe (GroupPublic, GroupKey)) +groupGetPubShared (GroupPub_P256 pub) = + fmap (first GroupPub_P256) . maybeCryptoError <$> deriveEncrypt p256 pub +groupGetPubShared (GroupPub_P384 pub) = + fmap (first GroupPub_P384) . maybeCryptoError <$> deriveEncrypt p384 pub +groupGetPubShared (GroupPub_P521 pub) = + fmap (first GroupPub_P521) . maybeCryptoError <$> deriveEncrypt p521 pub +groupGetPubShared (GroupPub_X255 pub) = + fmap (first GroupPub_X255) . maybeCryptoError <$> deriveEncrypt x25519 pub +groupGetPubShared (GroupPub_X448 pub) = + fmap (first GroupPub_X448) . maybeCryptoError <$> deriveEncrypt x448 pub +groupGetPubShared (GroupPub_FFDHE2048 pub) = getPubShared ffdhe2048 pub GroupPub_FFDHE2048 +groupGetPubShared (GroupPub_FFDHE3072 pub) = getPubShared ffdhe3072 pub GroupPub_FFDHE3072 +groupGetPubShared (GroupPub_FFDHE4096 pub) = getPubShared ffdhe4096 pub GroupPub_FFDHE4096 +groupGetPubShared (GroupPub_FFDHE6144 pub) = getPubShared ffdhe6144 pub GroupPub_FFDHE6144 +groupGetPubShared (GroupPub_FFDHE8192 pub) = getPubShared ffdhe8192 pub GroupPub_FFDHE8192 + +getPubShared :: MonadRandom r + => Params + -> PublicNumber + -> (PublicNumber -> GroupPublic) + -> r (Maybe (GroupPublic, GroupKey)) +getPubShared params pub pubTag = do + mypri <- generatePrivate params + let mypub = calculatePublic params mypri + let SharedKey share = getShared params mypri pub + return $ Just (pubTag mypub, SharedSecret share) + +groupGetShared :: GroupPublic -> GroupPrivate -> Maybe GroupKey +groupGetShared (GroupPub_P256 pub) (GroupPri_P256 pri) = maybeCryptoError $ deriveDecrypt p256 pub pri +groupGetShared (GroupPub_P384 pub) (GroupPri_P384 pri) = maybeCryptoError $ deriveDecrypt p384 pub pri +groupGetShared (GroupPub_P521 pub) (GroupPri_P521 pri) = maybeCryptoError $ deriveDecrypt p521 pub pri +groupGetShared (GroupPub_X255 pub) (GroupPri_X255 pri) = maybeCryptoError $ deriveDecrypt x25519 pub pri +groupGetShared (GroupPub_X448 pub) (GroupPri_X448 pri) = maybeCryptoError $ deriveDecrypt x448 pub pri +groupGetShared (GroupPub_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = Just $ calcShared ffdhe2048 pub pri +groupGetShared (GroupPub_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = Just $ calcShared ffdhe3072 pub pri +groupGetShared (GroupPub_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = Just $ calcShared ffdhe4096 pub pri +groupGetShared (GroupPub_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = Just $ calcShared ffdhe6144 pub pri +groupGetShared (GroupPub_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = Just $ calcShared ffdhe8192 pub pri +groupGetShared _ _ = Nothing + +calcShared :: Params -> PublicNumber -> PrivateNumber -> SharedSecret +calcShared params pub pri = SharedSecret share + where + SharedKey share = getShared params pri pub + +encodeGroupPublic :: GroupPublic -> ByteString +encodeGroupPublic (GroupPub_P256 p) = encodePoint p256 p +encodeGroupPublic (GroupPub_P384 p) = encodePoint p384 p +encodeGroupPublic (GroupPub_P521 p) = encodePoint p521 p +encodeGroupPublic (GroupPub_X255 p) = encodePoint x25519 p +encodeGroupPublic (GroupPub_X448 p) = encodePoint x448 p +encodeGroupPublic (GroupPub_FFDHE2048 p) = enc ffdhe2048 p +encodeGroupPublic (GroupPub_FFDHE3072 p) = enc ffdhe3072 p +encodeGroupPublic (GroupPub_FFDHE4096 p) = enc ffdhe4096 p +encodeGroupPublic (GroupPub_FFDHE6144 p) = enc ffdhe6144 p +encodeGroupPublic (GroupPub_FFDHE8192 p) = enc ffdhe8192 p + +enc :: Params -> PublicNumber -> ByteString +enc params (PublicNumber p) = i2ospOf_ ((params_bits params + 7) `div` 8) p + +decodeGroupPublic :: Group -> ByteString -> Either CryptoError GroupPublic +decodeGroupPublic P256 bs = eitherCryptoError $ GroupPub_P256 <$> decodePoint p256 bs +decodeGroupPublic P384 bs = eitherCryptoError $ GroupPub_P384 <$> decodePoint p384 bs +decodeGroupPublic P521 bs = eitherCryptoError $ GroupPub_P521 <$> decodePoint p521 bs +decodeGroupPublic X25519 bs = eitherCryptoError $ GroupPub_X255 <$> decodePoint x25519 bs +decodeGroupPublic X448 bs = eitherCryptoError $ GroupPub_X448 <$> decodePoint x448 bs +decodeGroupPublic FFDHE2048 bs = Right . GroupPub_FFDHE2048 . PublicNumber $ os2ip bs +decodeGroupPublic FFDHE3072 bs = Right . GroupPub_FFDHE3072 . PublicNumber $ os2ip bs +decodeGroupPublic FFDHE4096 bs = Right . GroupPub_FFDHE4096 . PublicNumber $ os2ip bs +decodeGroupPublic FFDHE6144 bs = Right . GroupPub_FFDHE6144 . PublicNumber $ os2ip bs +decodeGroupPublic FFDHE8192 bs = Right . GroupPub_FFDHE8192 . PublicNumber $ os2ip bs diff --git a/Network/TLS/Crypto/Types.hs b/Network/TLS/Crypto/Types.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Crypto/Types.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Network.TLS.Crypto.Types +-- License : BSD-style +-- Maintainer : Kazu Yamamoto +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Crypto.Types where + +data Group = P256 | P384 | P521 | X25519 | X448 + | FFDHE2048 | FFDHE3072 | FFDHE4096 | FFDHE6144 | FFDHE8192 + deriving (Eq, Show) + +availableGroups :: [Group] +availableGroups = [P256,P384,P521,X25519,X448] + +-- Digital signature algorithm, in close relation to public/private key types +-- and cipher key exchange. +data DigitalSignatureAlg = RSA | DSS | ECDSA | Ed25519 | Ed448 + deriving (Show, Eq) diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -15,9 +15,8 @@ , extensionID_ServerName , extensionID_MaxFragmentLength , extensionID_SecureRenegotiation - , extensionID_NextProtocolNegotiation , extensionID_ApplicationLayerProtocolNegotiation - , extensionID_EllipticCurves + , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_Heartbeat , extensionID_SignatureAlgorithms @@ -27,18 +26,15 @@ , MaxFragmentLength(..) , MaxFragmentEnum(..) , SecureRenegotiation(..) - , NextProtocolNegotiation(..) , ApplicationLayerProtocolNegotiation(..) - , EllipticCurvesSupported(..) - , NamedCurve(..) - , CurveName(..) + , NegotiatedGroups(..) + , Group(..) , EcPointFormatsSupported(..) , EcPointFormat(..) , SessionTicket(..) , HeartBeat(..) , HeartBeatMode(..) , SignatureAlgorithms(..) - , availableEllipticCurves ) where import Control.Monad @@ -49,8 +45,8 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import Network.TLS.Extension.EC import Network.TLS.Struct (ExtensionID, EnumSafe8(..), EnumSafe16(..), HashAndSignatureAlgorithm) +import Network.TLS.Crypto.Types import Network.TLS.Wire import Network.TLS.Imports import Network.TLS.Packet (putSignatureHashAlgorithm, getSignatureHashAlgorithm) @@ -68,7 +64,7 @@ , extensionID_ClientAuthz , extensionID_ServerAuthz , extensionID_CertType - , extensionID_EllipticCurves + , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_SRP , extensionID_SignatureAlgorithms @@ -83,7 +79,6 @@ , extensionID_EncryptThenMAC , extensionID_ExtendedMasterSecret , extensionID_SessionTicket - , extensionID_NextProtocolNegotiation , extensionID_SecureRenegotiation :: ExtensionID extensionID_ServerName = 0x0 -- RFC6066 extensionID_MaxFragmentLength = 0x1 -- RFC6066 @@ -95,7 +90,7 @@ extensionID_ClientAuthz = 0x7 -- RFC5878 extensionID_ServerAuthz = 0x8 -- RFC5878 extensionID_CertType = 0x9 -- RFC6091 -extensionID_EllipticCurves = 0xa -- RFC4492 +extensionID_NegotiatedGroups = 0xa -- RFC4492bis and TLS 1.3 extensionID_EcPointFormats = 0xb -- RFC4492 extensionID_SRP = 0xc -- RFC5054 extensionID_SignatureAlgorithms = 0xd -- RFC5246 @@ -110,7 +105,6 @@ extensionID_EncryptThenMAC = 0x16 -- RFC7366 extensionID_ExtendedMasterSecret = 0x17 -- draft-ietf-tls-session-hash. expires 2015-09-26 extensionID_SessionTicket = 0x23 -- RFC4507 -extensionID_NextProtocolNegotiation = 0x3374 -- obsolete extensionID_SecureRenegotiation = 0xff01 -- RFC5746 definedExtensions :: [ExtensionID] @@ -125,7 +119,7 @@ , extensionID_ClientAuthz , extensionID_ServerAuthz , extensionID_CertType - , extensionID_EllipticCurves + , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_SRP , extensionID_SignatureAlgorithms @@ -140,7 +134,6 @@ , extensionID_EncryptThenMAC , extensionID_ExtendedMasterSecret , extensionID_SessionTicket - , extensionID_NextProtocolNegotiation , extensionID_SecureRenegotiation ] @@ -150,8 +143,7 @@ , extensionID_MaxFragmentLength , extensionID_ApplicationLayerProtocolNegotiation , extensionID_SecureRenegotiation - , extensionID_NextProtocolNegotiation - , extensionID_EllipticCurves + , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_SignatureAlgorithms ] @@ -220,21 +212,6 @@ in return $ SecureRenegotiation cvd (Just svd) else return $ SecureRenegotiation opaque Nothing --- | Next Protocol Negotiation -data NextProtocolNegotiation = NextProtocolNegotiation [ByteString] - deriving (Show,Eq) - -instance Extension NextProtocolNegotiation where - extensionID _ = extensionID_NextProtocolNegotiation - extensionEncode (NextProtocolNegotiation bytes) = - runPut $ mapM_ putOpaque8 bytes - extensionDecode _ = runGetMaybe (NextProtocolNegotiation <$> getNPN) - where getNPN = do - avail <- remaining - case avail of - 0 -> return [] - _ -> do liftM2 (:) getOpaque8 getNPN - -- | Application Layer Protocol Negotiation (ALPN) data ApplicationLayerProtocolNegotiation = ApplicationLayerProtocolNegotiation [ByteString] deriving (Show,Eq) @@ -253,44 +230,15 @@ 0 -> return [] _ -> (:) <$> getOpaque8 <*> getALPN' -data EllipticCurvesSupported = EllipticCurvesSupported [NamedCurve] - deriving (Show,Eq) -data NamedCurve = - SEC CurveName - | BrainPool BrainPoolCurve - | NamedCurve_arbitrary_explicit_prime_curves - | NamedCurve_arbitrary_explicit_char2_curves - deriving (Show,Eq) - -data BrainPoolCurve = - BrainPoolP512R1 -- 28 - | BrainPoolP384R1 -- 27 - | BrainPoolP256R1 -- 26 +data NegotiatedGroups = NegotiatedGroups [Group] deriving (Show,Eq) -availableEllipticCurves :: [NamedCurve] -availableEllipticCurves = [SEC SEC_p256r1, SEC SEC_p384r1, SEC SEC_p521r1] - -instance EnumSafe16 NamedCurve where - fromEnumSafe16 NamedCurve_arbitrary_explicit_prime_curves = 0xFF01 - fromEnumSafe16 NamedCurve_arbitrary_explicit_char2_curves = 0xFF02 - fromEnumSafe16 (SEC nc) = maybe (error "named curve: internal error") id $ fromCurveName nc - fromEnumSafe16 (BrainPool BrainPoolP512R1) = 28 - fromEnumSafe16 (BrainPool BrainPoolP384R1) = 27 - fromEnumSafe16 (BrainPool BrainPoolP256R1) = 26 - toEnumSafe16 0xFF01 = Just NamedCurve_arbitrary_explicit_prime_curves - toEnumSafe16 0xFF02 = Just NamedCurve_arbitrary_explicit_char2_curves - toEnumSafe16 26 = Just (BrainPool BrainPoolP256R1) - toEnumSafe16 27 = Just (BrainPool BrainPoolP384R1) - toEnumSafe16 28 = Just (BrainPool BrainPoolP512R1) - toEnumSafe16 n = SEC <$> toCurveName n - -- on decode, filter all unknown curves -instance Extension EllipticCurvesSupported where - extensionID _ = extensionID_EllipticCurves - extensionEncode (EllipticCurvesSupported curves) = runPut $ putWords16 $ map fromEnumSafe16 curves - extensionDecode _ = runGetMaybe (EllipticCurvesSupported . catMaybes . map toEnumSafe16 <$> getWords16) +instance Extension NegotiatedGroups where + extensionID _ = extensionID_NegotiatedGroups + extensionEncode (NegotiatedGroups groups) = runPut $ putWords16 $ map fromEnumSafe16 groups + extensionDecode _ = runGetMaybe (NegotiatedGroups . catMaybes . map toEnumSafe16 <$> getWords16) data EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat] deriving (Show,Eq) diff --git a/Network/TLS/Extension/EC.hs b/Network/TLS/Extension/EC.hs deleted file mode 100644 --- a/Network/TLS/Extension/EC.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Network.TLS.Extension.EC ( - CurveName(..) - , toCurveName - , fromCurveName - ) where - -import Crypto.PubKey.ECC.Types (CurveName(..)) -import Data.Word (Word16) - -toCurveName :: Word16 -> Maybe CurveName -toCurveName 1 = Just SEC_t163k1 -toCurveName 2 = Just SEC_t163r1 -toCurveName 3 = Just SEC_t163r2 -toCurveName 4 = Just SEC_t193r1 -toCurveName 5 = Just SEC_t193r2 -toCurveName 6 = Just SEC_t233k1 -toCurveName 7 = Just SEC_t233r1 -toCurveName 8 = Just SEC_t239k1 -toCurveName 9 = Just SEC_t283k1 -toCurveName 10 = Just SEC_t283r1 -toCurveName 11 = Just SEC_t409k1 -toCurveName 12 = Just SEC_t409r1 -toCurveName 13 = Just SEC_t571k1 -toCurveName 14 = Just SEC_t571r1 -toCurveName 15 = Just SEC_p160k1 -toCurveName 16 = Just SEC_p160r1 -toCurveName 17 = Just SEC_p160r2 -toCurveName 18 = Just SEC_p192k1 -toCurveName 19 = Just SEC_p192r1 -toCurveName 20 = Just SEC_p224k1 -toCurveName 21 = Just SEC_p224r1 -toCurveName 22 = Just SEC_p256k1 -toCurveName 23 = Just SEC_p256r1 -toCurveName 24 = Just SEC_p384r1 -toCurveName 25 = Just SEC_p521r1 ---toCurveName 26 = Just Brainpool_P256r1 ---toCurveName 27 = Just Brainpool_P384r1 ---toCurveName 28 = Just Brainpool_P512r1 -toCurveName _ = Nothing - -fromCurveName :: CurveName -> Maybe Word16 -fromCurveName SEC_t163k1 = Just 1 -fromCurveName SEC_t163r1 = Just 2 -fromCurveName SEC_t163r2 = Just 3 -fromCurveName SEC_t193r1 = Just 4 -fromCurveName SEC_t193r2 = Just 5 -fromCurveName SEC_t233k1 = Just 6 -fromCurveName SEC_t233r1 = Just 7 -fromCurveName SEC_t239k1 = Just 8 -fromCurveName SEC_t283k1 = Just 9 -fromCurveName SEC_t283r1 = Just 10 -fromCurveName SEC_t409k1 = Just 11 -fromCurveName SEC_t409r1 = Just 12 -fromCurveName SEC_t571k1 = Just 13 -fromCurveName SEC_t571r1 = Just 14 -fromCurveName SEC_p160k1 = Just 15 -fromCurveName SEC_p160r1 = Just 16 -fromCurveName SEC_p160r2 = Just 17 -fromCurveName SEC_p192k1 = Just 18 -fromCurveName SEC_p192r1 = Just 19 -fromCurveName SEC_p224k1 = Just 20 -fromCurveName SEC_p224r1 = Just 21 -fromCurveName SEC_p256k1 = Just 22 -fromCurveName SEC_p256r1 = Just 23 -fromCurveName SEC_p384r1 = Just 24 -fromCurveName SEC_p521r1 = Just 25 -fromCurveName _ = Nothing diff --git a/Network/TLS/Extra/Cipher.hs b/Network/TLS/Extra/Cipher.hs --- a/Network/TLS/Extra/Cipher.hs +++ b/Network/TLS/Extra/Cipher.hs @@ -174,6 +174,7 @@ -- , cipher_RSA_3DES_EDE_CBC_SHA1 ] +{-# WARNING ciphersuite_all "This ciphersuite list contains RC4. Use ciphersuite_strong or ciphersuite_default instead." #-} -- | The default ciphersuites + some not recommended last resort ciphers. ciphersuite_all :: [Cipher] ciphersuite_all = ciphersuite_default ++ @@ -182,6 +183,7 @@ , cipher_RC4_128_SHA1 ] +{-# DEPRECATED ciphersuite_medium "Use ciphersuite_strong or ciphersuite_default instead." #-} -- | list of medium ciphers. ciphersuite_medium :: [Cipher] ciphersuite_medium = [ cipher_RC4_128_SHA1 @@ -303,7 +305,7 @@ -- | unencrypted cipher using RSA for key exchange and MD5 for digest cipher_null_MD5 :: Cipher cipher_null_MD5 = Cipher - { cipherID = 0x1 + { cipherID = 0x0001 , cipherName = "RSA-null-MD5" , cipherBulk = bulk_null , cipherHash = MD5 @@ -315,7 +317,7 @@ -- | unencrypted cipher using RSA for key exchange and SHA1 for digest cipher_null_SHA1 :: Cipher cipher_null_SHA1 = Cipher - { cipherID = 0x2 + { cipherID = 0x0002 , cipherName = "RSA-null-SHA1" , cipherBulk = bulk_null , cipherHash = SHA1 @@ -327,7 +329,7 @@ -- | RC4 cipher, RSA key exchange and MD5 for digest cipher_RC4_128_MD5 :: Cipher cipher_RC4_128_MD5 = Cipher - { cipherID = 0x04 + { cipherID = 0x0004 , cipherName = "RSA-rc4-128-md5" , cipherBulk = bulk_rc4 , cipherHash = MD5 @@ -339,7 +341,7 @@ -- | RC4 cipher, RSA key exchange and SHA1 for digest cipher_RC4_128_SHA1 :: Cipher cipher_RC4_128_SHA1 = Cipher - { cipherID = 0x05 + { cipherID = 0x0005 , cipherName = "RSA-rc4-128-sha1" , cipherBulk = bulk_rc4 , cipherHash = SHA1 @@ -348,10 +350,22 @@ , cipherMinVer = Nothing } +-- | 3DES cipher (168 bit key), RSA key exchange and SHA1 for digest +cipher_RSA_3DES_EDE_CBC_SHA1 :: Cipher +cipher_RSA_3DES_EDE_CBC_SHA1 = Cipher + { cipherID = 0x000A + , cipherName = "RSA-3DES-EDE-CBC-SHA1" + , cipherBulk = bulk_tripledes_ede + , cipherHash = SHA1 + , cipherPRFHash = Nothing + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } + -- | AES cipher (128 bit key), RSA key exchange and SHA1 for digest cipher_AES128_SHA1 :: Cipher cipher_AES128_SHA1 = Cipher - { cipherID = 0x2f + { cipherID = 0x002F , cipherName = "RSA-AES128-SHA1" , cipherBulk = bulk_aes128 , cipherHash = SHA1 @@ -363,7 +377,7 @@ -- | AES cipher (128 bit key), DHE key exchanged signed by DSA and SHA1 for digest cipher_DHE_DSS_AES128_SHA1 :: Cipher cipher_DHE_DSS_AES128_SHA1 = Cipher - { cipherID = 0x32 + { cipherID = 0x0032 , cipherName = "DHE-DSA-AES128-SHA1" , cipherBulk = bulk_aes128 , cipherHash = SHA1 @@ -375,7 +389,7 @@ -- | AES cipher (128 bit key), DHE key exchanged signed by RSA and SHA1 for digest cipher_DHE_RSA_AES128_SHA1 :: Cipher cipher_DHE_RSA_AES128_SHA1 = Cipher - { cipherID = 0x33 + { cipherID = 0x0033 , cipherName = "DHE-RSA-AES128-SHA1" , cipherBulk = bulk_aes128 , cipherHash = SHA1 @@ -387,7 +401,7 @@ -- | AES cipher (256 bit key), RSA key exchange and SHA1 for digest cipher_AES256_SHA1 :: Cipher cipher_AES256_SHA1 = Cipher - { cipherID = 0x35 + { cipherID = 0x0035 , cipherName = "RSA-AES256-SHA1" , cipherBulk = bulk_aes256 , cipherHash = SHA1 @@ -399,7 +413,7 @@ -- | AES cipher (256 bit key), DHE key exchanged signed by DSA and SHA1 for digest cipher_DHE_DSS_AES256_SHA1 :: Cipher cipher_DHE_DSS_AES256_SHA1 = cipher_DHE_DSS_AES128_SHA1 - { cipherID = 0x38 + { cipherID = 0x0038 , cipherName = "DHE-DSA-AES256-SHA1" , cipherBulk = bulk_aes256 } @@ -407,7 +421,7 @@ -- | AES cipher (256 bit key), DHE key exchanged signed by RSA and SHA1 for digest cipher_DHE_RSA_AES256_SHA1 :: Cipher cipher_DHE_RSA_AES256_SHA1 = cipher_DHE_RSA_AES128_SHA1 - { cipherID = 0x39 + { cipherID = 0x0039 , cipherName = "DHE-RSA-AES256-SHA1" , cipherBulk = bulk_aes256 } @@ -415,7 +429,7 @@ -- | AES cipher (128 bit key), RSA key exchange and SHA256 for digest cipher_AES128_SHA256 :: Cipher cipher_AES128_SHA256 = Cipher - { cipherID = 0x3c + { cipherID = 0x003C , cipherName = "RSA-AES128-SHA256" , cipherBulk = bulk_aes128 , cipherHash = SHA256 @@ -427,7 +441,7 @@ -- | AES cipher (256 bit key), RSA key exchange and SHA256 for digest cipher_AES256_SHA256 :: Cipher cipher_AES256_SHA256 = Cipher - { cipherID = 0x3d + { cipherID = 0x003D , cipherName = "RSA-AES256-SHA256" , cipherBulk = bulk_aes256 , cipherHash = SHA256 @@ -436,11 +450,36 @@ , cipherMinVer = Just TLS12 } +-- This is not registered in IANA. +-- So, this will be removed in the next major release. +cipher_DHE_DSS_RC4_SHA1 :: Cipher +cipher_DHE_DSS_RC4_SHA1 = cipher_DHE_DSS_AES128_SHA1 + { cipherID = 0x0066 + , cipherName = "DHE-DSA-RC4-SHA1" + , cipherBulk = bulk_rc4 + } + +cipher_DHE_RSA_AES128_SHA256 :: Cipher +cipher_DHE_RSA_AES128_SHA256 = cipher_DHE_RSA_AES128_SHA1 + { cipherID = 0x0067 + , cipherName = "DHE-RSA-AES128-SHA256" + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherMinVer = Just TLS12 + } + +cipher_DHE_RSA_AES256_SHA256 :: Cipher +cipher_DHE_RSA_AES256_SHA256 = cipher_DHE_RSA_AES128_SHA256 + { cipherID = 0x006B + , cipherName = "DHE-RSA-AES256-SHA256" + , cipherBulk = bulk_aes256 + } + -- | AESGCM cipher (128 bit key), RSA key exchange. -- The SHA256 digest is used as a PRF, not as a MAC. cipher_AES128GCM_SHA256 :: Cipher cipher_AES128GCM_SHA256 = Cipher - { cipherID = 0x9c + { cipherID = 0x009C , cipherName = "RSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 @@ -453,7 +492,7 @@ -- The SHA384 digest is used as a PRF, not as a MAC. cipher_AES256GCM_SHA384 :: Cipher cipher_AES256GCM_SHA384 = Cipher - { cipherID = 0x9d + { cipherID = 0x009D , cipherName = "RSA-AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 @@ -462,44 +501,9 @@ , cipherMinVer = Just TLS12 } -cipher_DHE_DSS_RC4_SHA1 :: Cipher -cipher_DHE_DSS_RC4_SHA1 = cipher_DHE_DSS_AES128_SHA1 - { cipherID = 0x66 - , cipherName = "DHE-DSA-RC4-SHA1" - , cipherBulk = bulk_rc4 - } - -cipher_DHE_RSA_AES128_SHA256 :: Cipher -cipher_DHE_RSA_AES128_SHA256 = cipher_DHE_RSA_AES128_SHA1 - { cipherID = 0x67 - , cipherName = "DHE-RSA-AES128-SHA256" - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherMinVer = Just TLS12 - } - -cipher_DHE_RSA_AES256_SHA256 :: Cipher -cipher_DHE_RSA_AES256_SHA256 = cipher_DHE_RSA_AES128_SHA256 - { cipherID = 0x6b - , cipherName = "DHE-RSA-AES256-SHA256" - , cipherBulk = bulk_aes256 - } - --- | 3DES cipher (168 bit key), RSA key exchange and SHA1 for digest -cipher_RSA_3DES_EDE_CBC_SHA1 :: Cipher -cipher_RSA_3DES_EDE_CBC_SHA1 = Cipher - { cipherID = 0x0a - , cipherName = "RSA-3DES-EDE-CBC-SHA1" - , cipherBulk = bulk_tripledes_ede - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } - cipher_DHE_RSA_AES128GCM_SHA256 :: Cipher cipher_DHE_RSA_AES128GCM_SHA256 = Cipher - { cipherID = 0x9e + { cipherID = 0x009E , cipherName = "DHE-RSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 @@ -510,7 +514,7 @@ cipher_DHE_RSA_AES256GCM_SHA384 :: Cipher cipher_DHE_RSA_AES256GCM_SHA384 = Cipher - { cipherID = 0x9f + { cipherID = 0x009F , cipherName = "DHE-RSA-AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 @@ -521,7 +525,7 @@ cipher_ECDHE_ECDSA_AES128CBC_SHA :: Cipher cipher_ECDHE_ECDSA_AES128CBC_SHA = Cipher - { cipherID = 0xc009 + { cipherID = 0xC009 , cipherName = "ECDHE-ECDSA-AES128CBC-SHA" , cipherBulk = bulk_aes128 , cipherHash = SHA1 @@ -532,7 +536,7 @@ cipher_ECDHE_ECDSA_AES256CBC_SHA :: Cipher cipher_ECDHE_ECDSA_AES256CBC_SHA = Cipher - { cipherID = 0xc00A + { cipherID = 0xC00A , cipherName = "ECDHE-ECDSA-AES256CBC-SHA" , cipherBulk = bulk_aes256 , cipherHash = SHA1 @@ -543,7 +547,7 @@ cipher_ECDHE_RSA_AES128CBC_SHA :: Cipher cipher_ECDHE_RSA_AES128CBC_SHA = Cipher - { cipherID = 0xc013 + { cipherID = 0xC013 , cipherName = "ECDHE-RSA-AES128CBC-SHA" , cipherBulk = bulk_aes128 , cipherHash = SHA1 @@ -554,7 +558,7 @@ cipher_ECDHE_RSA_AES256CBC_SHA :: Cipher cipher_ECDHE_RSA_AES256CBC_SHA = Cipher - { cipherID = 0xc014 + { cipherID = 0xC014 , cipherName = "ECDHE-RSA-AES256CBC-SHA" , cipherBulk = bulk_aes256 , cipherHash = SHA1 @@ -565,7 +569,7 @@ cipher_ECDHE_RSA_AES128CBC_SHA256 :: Cipher cipher_ECDHE_RSA_AES128CBC_SHA256 = Cipher - { cipherID = 0xc027 + { cipherID = 0xC027 , cipherName = "ECDHE-RSA-AES128CBC-SHA256" , cipherBulk = bulk_aes128 , cipherHash = SHA256 @@ -576,7 +580,7 @@ cipher_ECDHE_RSA_AES256CBC_SHA384 :: Cipher cipher_ECDHE_RSA_AES256CBC_SHA384 = Cipher - { cipherID = 0xc028 + { cipherID = 0xC028 , cipherName = "ECDHE-RSA-AES256CBC-SHA384" , cipherBulk = bulk_aes256 , cipherHash = SHA384 @@ -598,7 +602,7 @@ cipher_ECDHE_ECDSA_AES256CBC_SHA384 :: Cipher cipher_ECDHE_ECDSA_AES256CBC_SHA384 = Cipher - { cipherID = 0xc024 + { cipherID = 0xC024 , cipherName = "ECDHE-ECDSA-AES256CBC-SHA384" , cipherBulk = bulk_aes256 , cipherHash = SHA384 @@ -609,7 +613,7 @@ cipher_ECDHE_ECDSA_AES128GCM_SHA256 :: Cipher cipher_ECDHE_ECDSA_AES128GCM_SHA256 = Cipher - { cipherID = 0xc02b + { cipherID = 0xC02B , cipherName = "ECDHE-ECDSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 @@ -620,7 +624,7 @@ cipher_ECDHE_ECDSA_AES256GCM_SHA384 :: Cipher cipher_ECDHE_ECDSA_AES256GCM_SHA384 = Cipher - { cipherID = 0xc02c + { cipherID = 0xC02C , cipherName = "ECDHE-ECDSA-AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 @@ -631,7 +635,7 @@ cipher_ECDHE_RSA_AES128GCM_SHA256 :: Cipher cipher_ECDHE_RSA_AES128GCM_SHA256 = Cipher - { cipherID = 0xc02f + { cipherID = 0xC02F , cipherName = "ECDHE-RSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 @@ -642,7 +646,7 @@ cipher_ECDHE_RSA_AES256GCM_SHA384 :: Cipher cipher_ECDHE_RSA_AES256GCM_SHA384 = Cipher - { cipherID = 0xc030 + { cipherID = 0xC030 , cipherName = "ECDHE-RSA-AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 @@ -651,94 +655,5 @@ , cipherMinVer = Just TLS12 -- RFC 5289 } -{- -TLS 1.0 ciphers definition - -CipherSuite TLS_NULL_WITH_NULL_NULL = { 0x00,0x00 }; -CipherSuite TLS_RSA_WITH_NULL_MD5 = { 0x00,0x01 }; -CipherSuite TLS_RSA_WITH_NULL_SHA = { 0x00,0x02 }; -CipherSuite TLS_RSA_EXPORT_WITH_RC4_40_MD5 = { 0x00,0x03 }; -CipherSuite TLS_RSA_WITH_RC4_128_MD5 = { 0x00,0x04 }; -CipherSuite TLS_RSA_WITH_RC4_128_SHA = { 0x00,0x05 }; -CipherSuite TLS_RSA_EXPORT_WITH_RC2_CBC_40_MD5 = { 0x00,0x06 }; -CipherSuite TLS_RSA_WITH_IDEA_CBC_SHA = { 0x00,0x07 }; -CipherSuite TLS_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x08 }; -CipherSuite TLS_RSA_WITH_DES_CBC_SHA = { 0x00,0x09 }; -CipherSuite TLS_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x0A }; -CipherSuite TLS_DH_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x0B }; -CipherSuite TLS_DH_DSS_WITH_DES_CBC_SHA = { 0x00,0x0C }; -CipherSuite TLS_DH_DSS_WITH_3DES_EDE_CBC_SHA = { 0x00,0x0D }; -CipherSuite TLS_DH_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x0E }; -CipherSuite TLS_DH_RSA_WITH_DES_CBC_SHA = { 0x00,0x0F }; -CipherSuite TLS_DH_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x10 }; -CipherSuite TLS_DHE_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x11 }; -CipherSuite TLS_DHE_DSS_WITH_DES_CBC_SHA = { 0x00,0x12 }; -CipherSuite TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA = { 0x00,0x13 }; -CipherSuite TLS_DHE_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x14 }; -CipherSuite TLS_DHE_RSA_WITH_DES_CBC_SHA = { 0x00,0x15 }; -CipherSuite TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x16 }; -CipherSuite TLS_DH_anon_EXPORT_WITH_RC4_40_MD5 = { 0x00,0x17 }; -CipherSuite TLS_DH_anon_WITH_RC4_128_MD5 = { 0x00,0x18 }; -CipherSuite TLS_DH_anon_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x19 }; -CipherSuite TLS_DH_anon_WITH_DES_CBC_SHA = { 0x00,0x1A }; -CipherSuite TLS_DH_anon_WITH_3DES_EDE_CBC_SHA = { 0x00,0x1B }; - -TLS-RSA-WITH-AES-128-GCM-SHA256 {0x00,0x9C} -TLS-RSA-WITH-AES-256-GCM-SHA384 {0x00,0x9D} - -TLS-DHE-RSA-WITH-AES-128-CBC-SHA {0x00,0x33} -TLS-DHE-RSA-WITH-AES-256-CBC-SHA {0x00,0x39} -TLS-DHE-RSA-WITH-AES-128-CBC-SHA256 {0x00,0x67} -TLS-DHE-RSA-WITH-AES-256-CBC-SHA256 {0x00,0x6B} -TLS-DHE-RSA-WITH-AES-128-GCM-SHA256 {0x00,0x9E} -TLS-DHE-RSA-WITH-AES-256-GCM-SHA384 {0x00,0x9F} -TLS-DHE-RSA-WITH-CAMELLIA-128-CBC-SHA {0x00,0x45} -TLS-DHE-RSA-WITH-CAMELLIA-256-CBC-SHA {0x00,0x88} -TLS-DHE-RSA-WITH-CAMELLIA-128-CBC-SHA256 {0x00,0xBE} -TLS-DHE-RSA-WITH-CAMELLIA-256-CBC-SHA256 {0x00,0xC4} -TLS-DHE-RSA-WITH-CAMELLIA-128-GCM-SHA256 {0x00,0x7C} -TLS-DHE-RSA-WITH-CAMELLIA-256-GCM-SHA256 {0x00,0x7D} -TLS-DHE-RSA-WITH-3DES-EDE-CBC-SHA {0x00,0x16} -TLS-DHE-RSA-WITH-DES-CBC-SHA {0x00,0x15} - -TLS-ECDHE-RSA-WITH-AES-128-CBC-SHA {0xC0,0x13} -TLS-ECDHE-RSA-WITH-AES-256-CBC-SHA {0xC0,0x14} -TLS-ECDHE-RSA-WITH-AES-128-CBC-SHA256 {0xC0,0x27} -TLS-ECDHE-RSA-WITH-AES-256-CBC-SHA384 {0xC0,0x28} -TLS-ECDHE-RSA-WITH-AES-128-GCM-SHA256 {0xC0,0x2F} -TLS-ECDHE-RSA-WITH-AES-256-GCM-SHA384 {0xC0,0x30} -TLS-ECDHE-RSA-WITH-CAMELLIA-128-CBC-SHA256 {0xC0,0x76} -TLS-ECDHE-RSA-WITH-CAMELLIA-256-CBC-SHA384 {0xC0,0x77} -TLS-ECDHE-RSA-WITH-CAMELLIA-128-GCM-SHA256 {0xC0,0x8A} -TLS-ECDHE-RSA-WITH-CAMELLIA-256-GCM-SHA384 {0xC0,0x8B} -TLS-ECDHE-RSA-WITH-3DES-EDE-CBC-SHA {0xC0,0x12} -TLS-ECDHE-RSA-WITH-RC4-128-SHA {0xC0,0x11} -TLS-ECDHE-RSA-WITH-NULL-SHA {0xC0,0x10} - -TLS-ECDHE-ECDSA-WITH-AES-128-CBC-SHA {0xC0,0x09} -TLS-ECDHE-ECDSA-WITH-AES-256-CBC-SHA {0xC0,0x0A} -TLS-ECDHE-ECDSA-WITH-AES-128-CBC-SHA256 {0xC0,0x23} -TLS-ECDHE-ECDSA-WITH-AES-256-CBC-SHA384 {0xC0,0x24} -TLS-ECDHE-ECDSA-WITH-AES-128-GCM-SHA256 {0xC0,0x2B} -TLS-ECDHE-ECDSA-WITH-AES-256-GCM-SHA384 {0xC0,0x2C} - -TLS-PSK-WITH-RC4-128-SHA {0x00,0x8A} -TLS-PSK-WITH-3DES-EDE-CBC-SHA {0x00,0x8B} -TLS-PSK-WITH-AES-128-CBC-SHA {0x00,0x8C} -TLS-PSK-WITH-AES-256-CBC-SHA {0x00,0x8D} -TLS-PSK-WITH-AES-128-CBC-SHA256 {0x00,0xAE} -TLS-PSK-WITH-AES-256-CBC-SHA384 {0x00,0xAF} -TLS-PSK-WITH-AES-128-GCM-SHA256 {0x00,0xA8} -TLS-PSK-WITH-AES-256-GCM-SHA384 {0x00,0xA9} -TLS-PSK-WITH-CAMELLIA-128-CBC-SHA256 {0xC0,0x94} -TLS-PSK-WITH-CAMELLIA-256-CBC-SHA384 {0xC0,0x95} -TLS-PSK-WITH-CAMELLIA-128-GCM-SHA256 {0xC0,0x8D} -TLS-PSK-WITH-CAMELLIA-256-GCM-SHA384 {0xC0,0x8F} -TLS-PSK-WITH-NULL-SHA {0x00,0x2C} -TLS-PSK-WITH-NULL-SHA256 {0x00,0xB4} -TLS-PSK-WITH-NULL-SHA384 {0x00,0xB5} - -best ciphers suite description: - - --} +-- A list of cipher suite is found from: +-- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4 diff --git a/Network/TLS/Handshake.hs b/Network/TLS/Handshake.hs --- a/Network/TLS/Handshake.hs +++ b/Network/TLS/Handshake.hs @@ -7,6 +7,7 @@ -- module Network.TLS.Handshake ( handshake + , handshakeWith , handshakeClientWith , handshakeServerWith , handshakeClient @@ -22,16 +23,24 @@ import Network.TLS.Handshake.Client import Network.TLS.Handshake.Server -import Control.Monad.State +import Control.Monad.State.Strict import Control.Exception (fromException) -- | Handshake for a new TLS connection -- This is to be called at the beginning of a connection, and during renegotiation handshake :: MonadIO m => Context -> m () handshake ctx = - liftIO $ handleException $ withRWLock ctx (ctxDoHandshake ctx $ ctx) - where handleException f = catchException f $ \exception -> do - let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception - setEstablished ctx False - sendPacket ctx (errorToAlert tlserror) - handshakeFailed tlserror + liftIO $ handleException ctx $ withRWLock ctx (ctxDoHandshake ctx $ ctx) + +-- Handshake when requested by the remote end +-- This is called automatically by 'recvData' +handshakeWith :: MonadIO m => Context -> Handshake -> m () +handshakeWith ctx hs = + liftIO $ handleException ctx $ withRWLock ctx ((ctxDoHandshakeWith ctx) ctx hs) + +handleException :: Context -> IO () -> IO () +handleException ctx f = catchException f $ \exception -> do + let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception + setEstablished ctx False + sendPacket ctx (errorToAlert tlserror) + handshakeFailed tlserror 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 @@ -13,7 +13,7 @@ import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.X509 -import Control.Monad.State +import Control.Monad.State.Strict import Control.Exception (SomeException) -- on certificate reject, throw an exception with the proper protocol alert error. 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 @@ -29,11 +29,11 @@ import Network.TLS.Types import Network.TLS.X509 import Data.Maybe -import Data.List (find) +import Data.List (find, intersect) import qualified Data.ByteString as B import Data.ByteString.Char8 () -import Control.Monad.State +import Control.Monad.State.Strict import Control.Exception (SomeException) import Network.TLS.Handshake.Common @@ -56,16 +56,15 @@ recvServerHello sentExtensions sessionResuming <- usingState_ ctx isSessionResuming if sessionResuming - then sendChangeCipherAndFinish sendMaybeNPN ctx ClientRole + then sendChangeCipherAndFinish ctx ClientRole else do sendClientData cparams ctx - sendChangeCipherAndFinish sendMaybeNPN ctx ClientRole + sendChangeCipherAndFinish ctx ClientRole recvChangeCipherAndFinish ctx handshakeTerminate ctx - where ciphers = ctxCiphers ctx + where ciphers = supportedCiphers $ ctxSupported ctx compressions = supportedCompressions $ ctxSupported ctx getExtensions = sequence [sniExtension ,secureReneg - ,npnExtention ,alpnExtension ,curveExtension ,ecPointExtension @@ -81,9 +80,6 @@ if supportedSecureRenegotiation $ ctxSupported ctx then usingState_ ctx (getVerifiedData ClientRole) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing else return Nothing - npnExtention = if isJust $ onNPNServerSuggest $ clientHooks cparams - then return $ Just $ toExtensionRaw $ NextProtocolNegotiation [] - else return Nothing alpnExtension = do mprotos <- onSuggestALPN $ clientHooks cparams case mprotos of @@ -92,10 +88,12 @@ usingState_ ctx $ setClientALPNSuggest protos return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos sniExtension = if clientUseServerNameIndication cparams - then return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName $ fst $ clientServerIdentification cparams] + then do let sni = fst $ clientServerIdentification cparams + usingState_ ctx $ setClientSNI sni + return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] else return Nothing - curveExtension = return $ Just $ toExtensionRaw $ EllipticCurvesSupported availableEllipticCurves + curveExtension = return $ Just $ toExtensionRaw $ NegotiatedGroups ((supportedGroups $ ctxSupported ctx) `intersect` availableGroups) ecPointExtension = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed] --[EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2] --heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend @@ -111,23 +109,11 @@ startHandshake ctx highestVer crand usingState_ ctx $ setVersionIfUnset highestVer sendPacket ctx $ Handshake - [ ClientHello highestVer crand clientSession (map cipherID (ciphers mempty)) + [ ClientHello highestVer crand clientSession (map cipherID ciphers) (map compressionID compressions) extensions Nothing ] return $ map (\(ExtensionRaw i _) -> i) extensions - sendMaybeNPN = do - suggest <- usingState_ ctx $ getServerNextProtocolSuggest - case (onNPNServerSuggest $ clientHooks cparams, suggest) of - -- client offered, server picked up. send NPN handshake. - (Just io, Just protos) -> do proto <- liftIO $ io protos - sendPacket ctx (Handshake [HsNextProtocolNegotiation proto]) - usingState_ ctx $ setNegotiatedProtocol proto - -- client offered, server didn't pick up. do nothing. - (Just _, Nothing) -> return () - -- client didn't offer. do nothing. - (Nothing, _) -> return () - recvServerHello sentExts = runRecvState ctx recvState where recvState = RecvStateNext $ \p -> case p of @@ -217,15 +203,14 @@ return $ CKX_DH clientDHPub getCKX_ECDHE = do - xver <- usingState_ ctx getVersion - (ServerECDHParams ecdhparams serverECDHPub) <- usingHState ctx getServerECDHParams - (clientECDHPriv, clientECDHPub) <- generateECDHE ctx ecdhparams - - case ecdhGetShared ecdhparams clientECDHPriv serverECDHPub of - Nothing -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure) - Just premaster -> do + ServerECDHParams _grp srvpub <- usingHState ctx getServerECDHParams + ecdhePair <- generateECDHEShared ctx srvpub + case ecdhePair of + Nothing -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure) + Just (clipub, premaster) -> do + xver <- usingState_ ctx getVersion usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster - return $ CKX_ECDH clientECDHPub + return $ CKX_ECDH $ encodeGroupPublic clipub -- In order to send a proper certificate verify message, -- we have to do the following: @@ -247,7 +232,7 @@ True -> do sigAlg <- getLocalSignatureAlg - mhash <- case usedVersion of + mhashSig <- case usedVersion of TLS12 -> do Just (_, Just hashSigs, _) <- usingHState ctx $ getClientCertRequest -- The values in the "signature_algorithms" extension @@ -255,17 +240,17 @@ -- However here the algorithms are selected according -- to client preference in 'supportedHashSignatures'. let suppHashSigs = supportedHashSignatures $ ctxSupported ctx - matchHashSigs = filter (\ a -> snd a == sigAlg) suppHashSigs + matchHashSigs = filter (sigAlg `signatureCompatible`) suppHashSigs hashSigs' = filter (\ a -> a `elem` hashSigs) matchHashSigs when (null hashSigs') $ throwCore $ Error_Protocol ("no " ++ show sigAlg ++ " hash algorithm in common with the server", True, HandshakeFailure) - return $ Just $ fst $ head hashSigs' + return $ Just $ head hashSigs' _ -> return Nothing -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages - sigDig <- certificateVerifyCreate ctx usedVersion sigAlg mhash msgs + sigDig <- createCertificateVerify ctx usedVersion sigAlg mhashSig msgs sendPacket ctx $ Handshake [CertVerify sigDig] _ -> return () @@ -273,9 +258,8 @@ getLocalSignatureAlg = do pk <- usingHState ctx getLocalPrivateKey case pk of - PrivKeyRSA _ -> return SignatureRSA - PrivKeyDSA _ -> return SignatureDSS - _ -> throwCore $ Error_Protocol ("unsupported local private key type", True, HandshakeFailure) + PrivKeyRSA _ -> return RSA + PrivKeyDSA _ -> return DSS processServerExtension :: ExtensionRaw -> TLSSt () processServerExtension (ExtensionRaw 0xff01 content) = do @@ -296,8 +280,7 @@ -- 2) check that our compression and cipher algorithms are part of the list we sent -- 3) check extensions received are part of the one we sent -- 4) process the session parameter to see if the server want to start a new session or can resume --- 5) process NPN extension --- 6) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher +-- 5) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher -- onServerHello :: Context -> ClientParams -> [ExtensionID] -> Handshake -> IO (RecvState IO) onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do @@ -306,7 +289,7 @@ Nothing -> throwCore $ Error_Protocol ("server version " ++ show rver ++ " is not supported", True, ProtocolVersion) Just _ -> return () -- find the compression and cipher methods that the server want to use. - cipherAlg <- case find ((==) cipher . cipherID) (ctxCiphers ctx mempty) of + cipherAlg <- case find ((==) cipher . cipherID) (supportedCiphers $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, HandshakeFailure) Just alg -> return alg compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of @@ -338,14 +321,6 @@ _ -> return () _ -> return () - case extensionDecode False `fmap` (extensionLookup extensionID_NextProtocolNegotiation exts) of - Just (Just (NextProtocolNegotiation protos)) -> usingState_ ctx $ do - alpnDone <- getExtensionALPN - unless alpnDone $ do - setExtensionNPN True - setServerNextProtocolSuggest protos - _ -> return () - case resumingSession of Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx) Just sessionData -> do @@ -386,13 +361,13 @@ where processWithCipher cipher skx = case (cipherKeyExchange cipher, skx) of (CipherKeyExchange_DHE_RSA, SKX_DHE_RSA dhparams signature) -> do - doDHESignature dhparams signature SignatureRSA + doDHESignature dhparams signature RSA (CipherKeyExchange_DHE_DSS, SKX_DHE_DSS dhparams signature) -> do - doDHESignature dhparams signature SignatureDSS + doDHESignature dhparams signature DSS (CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) -> do - doECDHESignature ecdhparams signature SignatureRSA + doECDHESignature ecdhparams signature RSA (CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ecdhparams signature) -> do - doECDHESignature ecdhparams signature SignatureECDSA + doECDHESignature ecdhparams signature ECDSA (cke, SKX_Unparsed bytes) -> do ver <- usingState_ ctx getVersion case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of @@ -403,13 +378,13 @@ doDHESignature dhparams signature signatureType = do -- TODO verify DHParams verified <- digitallySignDHParamsVerify ctx dhparams signatureType signature - when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " for dhparams " ++ show dhparams, True, HandshakeFailure) + when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature for dhparams " ++ show dhparams, True, HandshakeFailure) usingHState ctx $ setServerDHParams dhparams doECDHESignature ecdhparams signature signatureType = do -- TODO verify DHParams verified <- digitallySignECDHParamsVerify ctx ecdhparams signatureType signature - when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " for ecdhparams", True, HandshakeFailure) + when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature for ecdhparams", True, HandshakeFailure) usingHState ctx $ setServerECDHParams ecdhparams processServerKeyExchange ctx p = processCertificateRequest ctx p 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 @@ -19,6 +19,7 @@ import Control.Concurrent.MVar import Network.TLS.Parameters +import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Session import Network.TLS.Struct @@ -32,9 +33,9 @@ import Network.TLS.Cipher import Network.TLS.Util import Data.List (find) -import Data.ByteString.Char8 () +import Data.ByteString.Char8 (ByteString) -import Control.Monad.State +import Control.Monad.State.Strict import Control.Exception (throwIO) handshakeFailed :: TLSError -> IO () @@ -76,13 +77,11 @@ setEstablished ctx True return () -sendChangeCipherAndFinish :: IO () -- ^ message possibly sent between ChangeCipherSpec and Finished. - -> Context +sendChangeCipherAndFinish :: Context -> Role -> IO () -sendChangeCipherAndFinish betweenCall ctx role = do +sendChangeCipherAndFinish ctx role = do sendPacket ctx ChangeCipherSpec - betweenCall liftIO $ contextFlush ctx cf <- usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role sendPacket ctx (Handshake [Finished cf]) @@ -125,16 +124,19 @@ getSessionData :: Context -> IO (Maybe SessionData) getSessionData ctx = do ver <- usingState_ ctx getVersion + sni <- usingState_ ctx getClientSNI mms <- usingHState ctx (gets hstMasterSecret) tx <- liftIO $ readMVar (ctxTxState ctx) case mms of Nothing -> return Nothing Just ms -> return $ Just $ SessionData - { sessionVersion = ver - , sessionCipher = cipherID $ fromJust "cipher" $ stCipher tx - , sessionSecret = ms + { sessionVersion = ver + , sessionCipher = cipherID $ fromJust "cipher" $ stCipher tx + , sessionCompression = compressionID $ stCompression tx + , sessionClientSNI = sni + , sessionSecret = ms } -extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe Bytes +extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString extensionLookup toFind = fmap (\(ExtensionRaw _ content) -> content) . find (\(ExtensionRaw eid _) -> eid == toFind) 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 @@ -14,6 +14,7 @@ , verifyPublic , generateDHE , generateECDHE + , generateECDHEShared ) where import Data.ByteString (ByteString) @@ -37,13 +38,13 @@ Left err -> fail ("rsa encrypt failed: " ++ show err) Right econtent -> return econtent -signPrivate :: Context -> Role -> Hash -> ByteString -> IO ByteString -signPrivate ctx _ hsh content = do +signPrivate :: Context -> Role -> SignatureParams -> ByteString -> IO ByteString +signPrivate ctx _ params content = do privateKey <- usingHState ctx getLocalPrivateKey usingState_ ctx $ do - r <- withRNG $ kxSign privateKey hsh content + r <- withRNG $ kxSign privateKey params content case r of - Left err -> fail ("rsa sign failed: " ++ show err) + Left err -> fail ("sign failed: " ++ show err) Right econtent -> return econtent decryptRSA :: Context -> ByteString -> IO (Either KxError ByteString) @@ -54,13 +55,16 @@ let cipher = if ver < TLS10 then econtent else B.drop 2 econtent withRNG $ kxDecrypt privateKey cipher -verifyPublic :: Context -> Role -> Hash -> ByteString -> ByteString -> IO Bool -verifyPublic ctx _ hsh econtent sign = do +verifyPublic :: Context -> Role -> SignatureParams -> ByteString -> ByteString -> IO Bool +verifyPublic ctx _ params econtent sign = do publicKey <- usingHState ctx getRemotePublicKey - return $ kxVerify publicKey hsh econtent sign + return $ kxVerify publicKey params econtent sign generateDHE :: Context -> DHParams -> IO (DHPrivate, DHPublic) generateDHE ctx dhp = usingState_ ctx $ withRNG $ dhGenerateKeyPair dhp -generateECDHE :: Context -> ECDHParams -> IO (ECDHPrivate, ECDHPublic) -generateECDHE ctx dhp = usingState_ ctx $ withRNG $ ecdhGenerateKeyPair dhp +generateECDHE :: Context -> Group -> IO (GroupPrivate, GroupPublic) +generateECDHE ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp + +generateECDHEShared :: Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey)) +generateECDHEShared ctx pub = usingState_ ctx $ withRNG $ groupGetPubShared pub 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 @@ -14,7 +14,7 @@ ) where import Control.Concurrent.MVar -import Control.Monad.State (gets) +import Control.Monad.State.Strict (gets) import Control.Monad import Control.Monad.IO.Class (liftIO) @@ -47,8 +47,6 @@ Certificates certs -> processCertificates role certs ClientKeyXchg content -> when (role == ServerRole) $ do processClientKeyXchg ctx content - HsNextProtocolNegotiation selected_protocol -> - when (role == ServerRole) $ usingState_ ctx $ setNegotiatedProtocol selected_protocol Finished fdata -> processClientFinished ctx fdata _ -> return () let encoded = encodeHandshake hs @@ -100,16 +98,18 @@ let premaster = dhGetShared (serverDHParamsToParams serverParams) dhpriv clientDHValue usingHState ctx $ setMasterSecretFromPre rver role premaster -processClientKeyXchg ctx (CKX_ECDH clientECDHValue) = do - rver <- usingState_ ctx getVersion - role <- usingState_ ctx isClientContext - - (ServerECDHParams ecdhparams _) <- usingHState ctx getServerECDHParams - ecdhpriv <- usingHState ctx getECDHPrivate - case ecdhGetShared ecdhparams ecdhpriv clientECDHValue of - Nothing -> throwCore $ Error_Protocol("invalid client public key", True, HandshakeFailure) - Just premaster -> - usingHState ctx $ setMasterSecretFromPre rver role premaster +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, HandshakeFailure) + Right clipub -> do + srvpri <- usingHState ctx getECDHPrivate + case groupGetShared clipub srvpri of + Just premaster -> do + rver <- usingState_ ctx getVersion + role <- usingState_ ctx isClientContext + usingHState ctx $ setMasterSecretFromPre rver role premaster + Nothing -> throwCore $ Error_Protocol ("cannote generate a shared secret on ECDH", True, HandshakeFailure) 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 @@ -31,7 +31,7 @@ import Network.TLS.Handshake.Key import Network.TLS.Measurement import Data.Maybe (isJust, listToMaybe, mapMaybe) -import Data.List (intersect) +import Data.List (findIndex, intersect) import qualified Data.ByteString as B import Data.ByteString.Char8 () import Data.Ord (Down(..)) @@ -42,7 +42,7 @@ import Data.Ord (comparing) #endif -import Control.Monad.State +import Control.Monad.State.Strict import Network.TLS.Handshake.Signature import Network.TLS.Handshake.Common @@ -82,7 +82,6 @@ -- <- client key xchg -- <- [cert verify] -- <- change cipher -> change cipher --- <- [NPN] -- <- finish -> finish -- -> change cipher <- change cipher -- -> finish <- finish @@ -141,48 +140,82 @@ -- such a cipher if no hash is available for it. It's best to skip this -- cipher and pick another one (with another key exchange). - -- FIXME ciphers should also be checked for other requirements - -- (i.e. elliptic curves and D-H groups) - let cipherAllowed cipher = case chosenVersion of - TLS12 -> let -- Build a list of all signature algorithms with at least - -- one hash algorithm in common between client and server. - -- May contain duplicates, as it is only used for `elem`. - possibleSigAlgs = map snd (hashAndSignaturesInCommon ctx exts) + -- Cipher selection is performed in two steps: first server credentials + -- are flagged as not suitable for signature if not compatible with + -- negotiated signature parameters. Then ciphers are evalutated from + -- the resulting credentials. - -- Check that a candidate cipher with a signature requiring - -- a hash will have at least one hash available. This avoids - -- a failure later in 'decideHash'. - hasSigningRequirements = - case cipherKeyExchange cipher of - CipherKeyExchange_DHE_RSA -> SignatureRSA `elem` possibleSigAlgs - CipherKeyExchange_DHE_DSS -> SignatureDSS `elem` possibleSigAlgs - CipherKeyExchange_ECDHE_RSA -> SignatureRSA `elem` possibleSigAlgs - CipherKeyExchange_ECDHE_ECDSA -> SignatureECDSA `elem` possibleSigAlgs - _ -> True -- signature not used + let possibleGroups = negotiatedGroupsInCommon ctx exts + hasCommonGroupForECDHE = not (null possibleGroups) + hasCommonGroup cipher = + case cipherKeyExchange cipher of + CipherKeyExchange_ECDHE_RSA -> hasCommonGroupForECDHE + CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE + _ -> True -- group not used - in cipherAllowedForVersion chosenVersion cipher && hasSigningRequirements - _ -> cipherAllowedForVersion chosenVersion cipher + -- Ciphers are selected according to TLS version, availability of ECDHE + -- group and credential depending on key exchange. + cipherAllowed cipher = cipherAllowedForVersion chosenVersion cipher && hasCommonGroup cipher + selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials) + allCreds = extraCreds `mappend` sharedCredentials (ctxShared ctx) + (creds, signatureCreds, ciphersFilteredVersion) + = case chosenVersion of + TLS12 -> let -- Build a list of all hash/signature algorithms in common between + -- client and server. + possibleHashSigAlgs = hashAndSignaturesInCommon ctx exts + + -- Check that a candidate signature credential will be compatible with + -- client & server hash/signature algorithms. This returns Just Int + -- in order to sort credentials according to server hash/signature + -- preference. When the certificate has no matching hash/signature in + -- '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 + Nothing -> Nothing + + -- Finally compute credential lists and resulting cipher list. + -- + -- We try to keep certificates supported by the client, but + -- fallback to all credentials if this produces no suitable result + -- (see RFC 5246 section 7.4.2 and TLS 1.3 section 4.4.2.2). + -- The condition is based on resulting (EC)DHE ciphers so that + -- filtering credentials does not give advantage to a less secure + -- key exchange like CipherKeyExchange_RSA or CipherKeyExchange_DH_Anon. + cltCreds = filterCredentialsWithHashSignatures exts allCreds + sigCltCreds = filterSortCredentials signingRank cltCreds + sigAllCreds = filterSortCredentials signingRank allCreds + cltCiphers = selectCipher cltCreds sigCltCreds + allCiphers = selectCipher allCreds sigAllCreds + + resultTuple = if cipherListCredentialFallback cltCiphers + then (allCreds, sigAllCreds, allCiphers) + else (cltCreds, sigCltCreds, cltCiphers) + in resultTuple + _ -> (allCreds, allCreds, selectCipher allCreds allCreds) + -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle -- empty lists. - let ciphersFilteredVersion = filter cipherAllowed (commonCiphers extraCreds) when (null ciphersFilteredVersion) $ throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) let usedCipher = (onCipherChoosing $ serverHooks sparams) chosenVersion ciphersFilteredVersion - creds = extraCreds `mappend` sharedCredentials (ctxShared ctx) cred <- case cipherKeyExchange usedCipher of - CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds - CipherKeyExchange_DH_Anon -> return $ Nothing - CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning SignatureRSA creds - CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning SignatureDSS creds - CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning SignatureRSA creds - _ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure) + CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds + CipherKeyExchange_DH_Anon -> return $ Nothing + CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning RSA signatureCreds + CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning DSS signatureCreds + CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning RSA signatureCreds + _ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure) resumeSessionData <- case clientSession of - (Session (Just clientSessionId)) -> liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId + (Session (Just clientSessionId)) -> + let resume = liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId + in validateSession serverName <$> resume (Session Nothing) -> return Nothing maybe (return ()) (usingState_ ctx . setClientSNI) serverName @@ -191,10 +224,6 @@ Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos _ -> return () - case extensionLookup extensionID_EllipticCurves exts >>= extensionDecode False of - Just (EllipticCurvesSupported es) -> usingState_ ctx $ setClientEllipticCurveSuggest es - _ -> return () - -- Currently, we don't send back EcPointFormats. In this case, -- the client chooses EcPointFormat_Uncompressed. case extensionLookup extensionID_EcPointFormats exts >>= extensionDecode False of @@ -204,12 +233,23 @@ doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts where - commonCipherIDs extra = ciphers `intersect` map cipherID (ctxCiphers ctx extra) - commonCiphers extra = filter (flip elem (commonCipherIDs extra) . cipherID) (ctxCiphers ctx extra) + commonCiphers creds sigCreds = filter ((`elem` ciphers) . cipherID) (getCiphers sparams creds sigCreds) commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions usedCompression = head commonCompressions + validateSession _ Nothing = Nothing + validateSession sni m@(Just sd) + -- SessionData parameters are assumed to match the local server configuration + -- so we need to compare only to ClientHello inputs. Abbreviated handshake + -- uses the same server_name than full handshake so the same + -- credentials (and thus ciphers) are available. + | clientVersion < sessionVersion sd = Nothing + | sessionCipher sd `notElem` ciphers = Nothing + | sessionCompression sd `notElem` compressions = Nothing + | isJust sni && sessionClientSNI sd /= sni = Nothing + | otherwise = m + handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure) doHandshake :: ServerParams -> Maybe Credential -> Context -> Version -> Cipher @@ -222,24 +262,19 @@ liftIO $ contextFlush ctx -- Receive client info until client Finished. recvClientData sparams ctx - sendChangeCipherAndFinish (return ()) ctx ServerRole + sendChangeCipherAndFinish ctx ServerRole Just sessionData -> do usingState_ ctx (setSession clientSession True) serverhello <- makeServerHello clientSession sendPacket ctx $ Handshake [serverhello] usingHState ctx $ setMasterSecret chosenVersion ServerRole $ sessionSecret sessionData - sendChangeCipherAndFinish (return ()) ctx ServerRole + sendChangeCipherAndFinish ctx ServerRole recvChangeCipherAndFinish ctx handshakeTerminate ctx where - clientRequestedNPN = isJust $ extensionLookup extensionID_NextProtocolNegotiation exts clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts - applicationProtocol = do - protos <- alpn - if null protos then npn else return protos - - alpn | clientALPNSuggest = do + applicationProtocol | clientALPNSuggest = do suggest <- usingState_ ctx getClientALPNSuggest case (onALPNClientSuggest $ serverHooks sparams, suggest) of (Just io, Just protos) -> do @@ -251,21 +286,7 @@ (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ] (_, _) -> return [] | otherwise = return [] - npn = do - nextProtocols <- - if clientRequestedNPN - then liftIO $ onSuggestNextProtocols $ serverHooks sparams - else return Nothing - case nextProtocols of - Just protos -> do - usingState_ ctx $ do - setExtensionNPN True - setServerNextProtocolSuggest protos - return [ ExtensionRaw extensionID_NextProtocolNegotiation - (extensionEncode $ NextProtocolNegotiation protos) ] - Nothing -> return [] - --- -- When the client sends a certificate, check whether -- it is acceptable for the application. @@ -321,9 +342,9 @@ -- send server key exchange if needed skx <- case cipherKeyExchange usedCipher of CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon - CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE SignatureRSA - CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE SignatureDSS - CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE SignatureRSA + CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE RSA + CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE DSS + CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE RSA _ -> return Nothing maybe (return ()) (sendPacket ctx . Handshake . (:[]) . ServerKeyXchg) skx @@ -366,50 +387,45 @@ -- the "signature_algorithms" extension in a client hello. -- If RSA is also used for key exchange, this function is -- not called. - decideHash sigAlg = do + decideHashSig sigAlg = do usedVersion <- usingState_ ctx getVersion case usedVersion of TLS12 -> do let hashSigs = hashAndSignaturesInCommon ctx exts - case filter ((==) sigAlg . snd) hashSigs of + case filter (sigAlg `signatureCompatible`) hashSigs of [] -> error ("no hash signature for " ++ show sigAlg) - x:_ -> return $ Just (fst x) + x:_ -> return $ Just x _ -> return Nothing generateSKX_DHE sigAlg = do serverParams <- setup_DHE - mhash <- decideHash sigAlg - signed <- digitallySignDHParams ctx serverParams sigAlg mhash + mhashSig <- decideHashSig sigAlg + signed <- digitallySignDHParams ctx serverParams sigAlg mhashSig case sigAlg of - SignatureRSA -> return $ SKX_DHE_RSA serverParams signed - SignatureDSS -> return $ SKX_DHE_DSS serverParams signed - _ -> error ("generate skx_dhe unsupported signature type: " ++ show sigAlg) + RSA -> return $ SKX_DHE_RSA serverParams signed + DSS -> return $ SKX_DHE_DSS serverParams signed + _ -> error ("generate skx_dhe unsupported signature type: " ++ show sigAlg) generateSKX_DH_Anon = SKX_DH_Anon <$> setup_DHE - setup_ECDHE curvename = do - let ecdhparams = ecdhParams curvename - (priv, pub) <- generateECDHE ctx ecdhparams - - let serverParams = ServerECDHParams ecdhparams pub - + setup_ECDHE grp = do + (srvpri, srvpub) <- generateECDHE ctx grp + let serverParams = ServerECDHParams grp srvpub usingHState ctx $ setServerECDHParams serverParams - usingHState ctx $ setECDHPrivate priv - return (serverParams) + usingHState ctx $ setECDHPrivate srvpri + return serverParams generateSKX_ECDHE sigAlg = do - ncs <- usingState_ ctx getClientEllipticCurveSuggest - let common = availableEllipticCurves `intersect` fromJust "ClientEllipticCurveSuggest" ncs - -- FIXME: Currently maximum strength is chosen. - -- There may be a better way to choose EC. - nc = if null common then error "No common EllipticCurves" - else maximum $ map fromEnumSafe16 common - serverParams <- setup_ECDHE nc - mhash <- decideHash sigAlg - signed <- digitallySignECDHParams ctx serverParams sigAlg mhash + let possibleGroups = negotiatedGroupsInCommon ctx exts + grp <- case possibleGroups of + [] -> throwCore $ Error_Protocol ("no common group", True, HandshakeFailure) + g:_ -> return g + serverParams <- setup_ECDHE grp + mhashSig <- decideHashSig sigAlg + signed <- digitallySignECDHParams ctx serverParams sigAlg mhashSig case sigAlg of - SignatureRSA -> return $ SKX_ECDHE_RSA serverParams signed - _ -> error ("generate skx_ecdhe unsupported signature type: " ++ show sigAlg) + RSA -> return $ SKX_ECDHE_RSA serverParams signed + _ -> error ("generate skx_ecdhe unsupported signature type: " ++ show sigAlg) -- create a DigitallySigned objects for DHParams or ECDHParams. @@ -419,7 +435,6 @@ -- <- client key xchg -- <- [cert verify] -- <- change cipher --- <- [NPN] -- <- finish -- recvClientData :: ServerParams -> Context -> IO () @@ -468,7 +483,7 @@ -- FIXME should check certificate is allowed for signing - verif <- certificateVerifyCheck ctx usedVersion sigAlgExpected msgs dsig + verif <- checkCertificateVerify ctx usedVersion sigAlgExpected msgs dsig case verif of True -> do @@ -508,18 +523,15 @@ getRemoteSignatureAlg = do pk <- usingHState ctx getRemotePublicKey case pk of - PubKeyRSA _ -> return SignatureRSA - PubKeyDSA _ -> return SignatureDSS - PubKeyEC _ -> return SignatureECDSA + PubKeyRSA _ -> return RSA + PubKeyDSA _ -> return DSS + PubKeyEC _ -> return ECDSA _ -> throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure) expectChangeCipher ChangeCipherSpec = do - npn <- usingState_ ctx getExtensionNPN - return $ RecvStateHandshake $ if npn then expectNPN else expectFinish - expectChangeCipher p = unexpected (show p) (Just "change cipher") + return $ RecvStateHandshake $ expectFinish - expectNPN (HsNextProtocolNegotiation _) = return $ RecvStateHandshake expectFinish - expectNPN p = unexpected (show p) (Just "Handshake NextProtocolNegotiation") + expectChangeCipher p = unexpected (show p) (Just "change cipher") expectFinish (Finished _) = return RecvStateDone expectFinish p = unexpected (show p) (Just "Handshake Finished") @@ -547,11 +559,80 @@ -- to server preference in 'supportedHashSignatures'. in sHashSigs `intersect` cHashSigs +negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group] +negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode False of + Just (NegotiatedGroups clientGroups) -> + let serverGroups = supportedGroups (ctxSupported ctx) `intersect` availableGroups + in serverGroups `intersect` clientGroups + _ -> [] + +credentialDigitalSignatureAlg :: Credential -> Maybe DigitalSignatureAlg +credentialDigitalSignatureAlg cred = + findDigitalSignatureAlg (credentialPublicPrivateKeys cred) + +filterSortCredentials :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials +filterSortCredentials rankFun (Credentials creds) = + let orderedPairs = sortOn fst [ (rankFun cred, cred) | cred <- creds ] + in Credentials [ cred | (Just _, cred) <- orderedPairs ] + +filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials +filterCredentialsWithHashSignatures exts = + case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode False of + Nothing -> id + Just (SignatureAlgorithms sas) -> + let filterCredentials p (Credentials l) = Credentials (filter p l) + in filterCredentials (credentialMatchesHashSignatures sas) + +-- returns True if "signature_algorithms" certificate filtering produced no +-- ephemeral D-H nor TLS13 cipher (so handshake with lower security) +cipherListCredentialFallback :: [Cipher] -> Bool +cipherListCredentialFallback xs = all nonDH xs + where + nonDH x = case cipherKeyExchange x of + CipherKeyExchange_DHE_RSA -> False + CipherKeyExchange_DHE_DSS -> False + CipherKeyExchange_ECDHE_RSA -> False + CipherKeyExchange_ECDHE_ECDSA -> False + --CipherKeyExchange_TLS13 -> False + _ -> True + findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions = case filter (clientVersion >=) $ sortOn Down allowedVersions of [] -> Nothing v:_ -> Just v + +-- We filter our allowed ciphers here according to server DHE parameters and +-- dynamic credential lists. Credentials 'creds' come from server parameters +-- but also SNI callback. When the key exchange requires a signature, we use a +-- subset of this list named 'sigCreds'. This list has been filtered in order +-- to remove certificates that are not compatible with hash/signature +-- restrictions (TLS 1.2). +getCiphers :: ServerParams -> Credentials -> Credentials -> [Cipher] +getCiphers sparams creds sigCreds = filter authorizedCKE (supportedCiphers $ serverSupported sparams) + where authorizedCKE cipher = + case cipherKeyExchange cipher of + CipherKeyExchange_RSA -> canEncryptRSA + CipherKeyExchange_DH_Anon -> canDHE + CipherKeyExchange_DHE_RSA -> canSignRSA && canDHE + CipherKeyExchange_DHE_DSS -> canSignDSS && canDHE + CipherKeyExchange_ECDHE_RSA -> canSignRSA + -- unimplemented: EC + CipherKeyExchange_ECDHE_ECDSA -> False + -- unimplemented: non ephemeral DH & ECDH. + -- Note, these *should not* be implemented, and have + -- (for example) been removed in OpenSSL 1.1.0 + -- + CipherKeyExchange_DH_DSS -> False + CipherKeyExchange_DH_RSA -> False + CipherKeyExchange_ECDH_ECDSA -> False + CipherKeyExchange_ECDH_RSA -> False + + canDHE = isJust $ serverDHEParams sparams + canSignDSS = DSS `elem` signingAlgs + canSignRSA = RSA `elem` signingAlgs + canEncryptRSA = isJust $ credentialsFindForDecrypting creds + signingAlgs = credentialsListSigningAlgorithms sigCreds #if !MIN_VERSION_base(4,8,0) sortOn :: Ord b => (a -> b) -> [a] -> [a] 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 @@ -8,12 +8,13 @@ -- module Network.TLS.Handshake.Signature ( - certificateVerifyCreate - , certificateVerifyCheck + createCertificateVerify + , checkCertificateVerify , digitallySignDHParams , digitallySignECDHParams , digitallySignDHParamsVerify , digitallySignECDHParamsVerify + , signatureCompatible ) where import Network.TLS.Crypto @@ -27,142 +28,139 @@ import Network.TLS.Handshake.Key import Network.TLS.Util -import Control.Monad.State +import Control.Monad.State.Strict -certificateVerifyCheck :: Context +signatureCompatible :: DigitalSignatureAlg -> HashAndSignatureAlgorithm -> Bool +signatureCompatible RSA (_, SignatureRSA) = True +signatureCompatible RSA (_, SignatureRSApssSHA256) = True +signatureCompatible RSA (_, SignatureRSApssSHA384) = True +signatureCompatible RSA (_, SignatureRSApssSHA512) = True +signatureCompatible DSS (_, SignatureDSS) = True +signatureCompatible ECDSA (_, SignatureECDSA) = True +signatureCompatible _ (_, _) = False + +checkCertificateVerify :: Context -> Version - -> SignatureAlgorithm - -> Bytes + -> DigitalSignatureAlg + -> ByteString -> DigitallySigned -> IO Bool -certificateVerifyCheck ctx usedVersion sigAlgExpected msgs digSig@(DigitallySigned hashSigAlg _) = +checkCertificateVerify ctx usedVersion sigAlgExpected msgs digSig@(DigitallySigned hashSigAlg _) = case (usedVersion, hashSigAlg) of (TLS12, Nothing) -> return False - (TLS12, Just (h,s)) | s == sigAlgExpected -> doVerify (Just h) - | otherwise -> return False - (_, Nothing) -> doVerify Nothing + (TLS12, Just hs) | sigAlgExpected `signatureCompatible` hs -> doVerify + | otherwise -> return False + (_, Nothing) -> doVerify (_, Just _) -> return False where - doVerify mhash = - prepareCertificateVerifySignatureData ctx usedVersion sigAlgExpected mhash msgs >>= - signatureVerifyWithHashDescr ctx sigAlgExpected digSig + doVerify = + prepareCertificateVerifySignatureData ctx usedVersion sigAlgExpected hashSigAlg msgs >>= + signatureVerifyWithCertVerifyData ctx digSig -certificateVerifyCreate :: Context +createCertificateVerify :: Context -> Version - -> SignatureAlgorithm - -> Maybe HashAlgorithm -- TLS12 only - -> Bytes + -> DigitalSignatureAlg + -> Maybe HashAndSignatureAlgorithm -- TLS12 only + -> ByteString -> IO DigitallySigned -certificateVerifyCreate ctx usedVersion sigAlg mhash msgs = - prepareCertificateVerifySignatureData ctx usedVersion sigAlg mhash msgs >>= - signatureCreateWithHashDescr ctx (toAlg `fmap` mhash) - where - toAlg hashAlg = (hashAlg, sigAlg) +createCertificateVerify ctx usedVersion sigAlg hashSigAlg msgs = + prepareCertificateVerifySignatureData ctx usedVersion sigAlg hashSigAlg msgs >>= + signatureCreateWithCertVerifyData ctx hashSigAlg -type CertVerifyData = (Hash, Bytes) +type CertVerifyData = (SignatureParams, ByteString) +-- in the case of TLS < 1.2, RSA signing, then the data need to be hashed first, as +-- the SHA1_MD5 algorithm expect an already digested data +buildVerifyData :: SignatureParams -> ByteString -> CertVerifyData +buildVerifyData (RSAParams SHA1_MD5 enc) bs = (RSAParams SHA1_MD5 enc, hashFinal $ hashUpdate (hashInit SHA1_MD5) bs) +buildVerifyData sigParam bs = (sigParam, bs) + prepareCertificateVerifySignatureData :: Context -> Version - -> SignatureAlgorithm - -> Maybe HashAlgorithm -- TLS12 only - -> Bytes + -> DigitalSignatureAlg + -> Maybe HashAndSignatureAlgorithm -- TLS12 only + -> ByteString -> IO CertVerifyData -prepareCertificateVerifySignatureData ctx usedVersion sigAlg mhash msgs +prepareCertificateVerifySignatureData ctx usedVersion sigAlg hashSigAlg msgs | usedVersion == SSL3 = do - (h, generateCV_SSL) <- + (hashCtx, params, generateCV_SSL) <- case sigAlg of - SignatureRSA -> return (SHA1_MD5, generateCertificateVerify_SSL) - SignatureDSS -> return (SHA1, generateCertificateVerify_SSL_DSS) - _ -> throwCore $ Error_Misc ("unsupported CertificateVerify signature for SSL3: " ++ show sigAlg) + RSA -> return (hashInit SHA1_MD5, RSAParams SHA1_MD5 RSApkcs1, generateCertificateVerify_SSL) + DSS -> return (hashInit SHA1, DSSParams, generateCertificateVerify_SSL_DSS) + _ -> throwCore $ Error_Misc ("unsupported CertificateVerify signature for SSL3: " ++ show sigAlg) Just masterSecret <- usingHState ctx $ gets hstMasterSecret - return (h, generateCV_SSL masterSecret (hashUpdate (hashInit h) msgs)) + return (params, generateCV_SSL masterSecret $ hashUpdate hashCtx msgs) | usedVersion == TLS10 || usedVersion == TLS11 = - case signatureHashData sigAlg Nothing of - SHA1_MD5 -> return (SHA1_MD5, hashFinal $ hashUpdate (hashInit SHA1_MD5) msgs) - alg -> return (alg, msgs) - | otherwise = return (signatureHashData sigAlg mhash, msgs) - -signatureHashData :: SignatureAlgorithm -> Maybe HashAlgorithm -> Hash -signatureHashData SignatureRSA mhash = - case mhash of - Just HashSHA512 -> SHA512 - Just HashSHA384 -> SHA384 - Just HashSHA256 -> SHA256 - Just HashSHA1 -> SHA1 - Nothing -> SHA1_MD5 - Just hsh -> error ("unimplemented RSA signature hash type: " ++ show hsh) -signatureHashData SignatureDSS mhash = - case mhash of - Nothing -> SHA1 - Just HashSHA1 -> SHA1 - Just _ -> error "invalid DSA hash choice, only SHA1 allowed" -signatureHashData SignatureECDSA mhash = - case mhash of - Just HashSHA512 -> SHA512 - Just HashSHA384 -> SHA384 - Just HashSHA256 -> SHA256 - Just HashSHA1 -> SHA1 - Nothing -> SHA1 - Just hsh -> error ("unimplemented ECDSA signature hash type: " ++ show hsh) -signatureHashData sig _ = error ("unimplemented signature type: " ++ show sig) + return $ buildVerifyData (signatureParams sigAlg Nothing) msgs + | otherwise = return (signatureParams sigAlg hashSigAlg, msgs) ---signatureCreate :: Context -> Maybe HashAndSignatureAlgorithm -> HashDescr -> Bytes -> IO DigitallySigned -signatureCreate :: Context -> Maybe HashAndSignatureAlgorithm -> CertVerifyData -> IO DigitallySigned -signatureCreate ctx malg (hashAlg, toSign) = - -- in the case of TLS < 1.2, RSA signing, then the data need to be hashed first, as - -- the SHA_MD5 algorithm expect an already digested data - let signData = - case (malg, hashAlg) of - (Nothing, SHA1_MD5) -> hashFinal $ hashUpdate (hashInit SHA1_MD5) toSign - _ -> toSign - in signatureCreateWithHashDescr ctx malg (hashAlg, signData) +signatureParams :: DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -> SignatureParams +signatureParams RSA hashSigAlg = + case hashSigAlg of + Just (HashSHA512, SignatureRSA) -> RSAParams SHA512 RSApkcs1 + Just (HashSHA384, SignatureRSA) -> RSAParams SHA384 RSApkcs1 + Just (HashSHA256, SignatureRSA) -> RSAParams SHA256 RSApkcs1 + Just (HashSHA1 , SignatureRSA) -> RSAParams SHA1 RSApkcs1 + Just (HashIntrinsic , SignatureRSApssSHA512) -> RSAParams SHA512 RSApss + Just (HashIntrinsic , SignatureRSApssSHA384) -> RSAParams SHA384 RSApss + Just (HashIntrinsic , SignatureRSApssSHA256) -> RSAParams SHA256 RSApss + 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 DSS 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 ECDSA hashSigAlg = + case hashSigAlg of + Just (HashSHA512, SignatureECDSA) -> ECDSAParams SHA512 + Just (HashSHA384, SignatureECDSA) -> ECDSAParams SHA384 + Just (HashSHA256, SignatureECDSA) -> ECDSAParams SHA256 + Just (HashSHA1 , SignatureECDSA) -> ECDSAParams SHA1 + 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 sig _ = error ("unimplemented signature type: " ++ show sig) -signatureCreateWithHashDescr :: Context - -> Maybe HashAndSignatureAlgorithm - -> CertVerifyData - -> IO DigitallySigned -signatureCreateWithHashDescr ctx malg (hashDescr, toSign) = do +signatureCreateWithCertVerifyData :: Context + -> Maybe HashAndSignatureAlgorithm + -> CertVerifyData + -> IO DigitallySigned +signatureCreateWithCertVerifyData ctx malg (sigParam, toSign) = do cc <- usingState_ ctx $ isClientContext - DigitallySigned malg <$> signPrivate ctx cc hashDescr toSign + DigitallySigned malg <$> signPrivate ctx cc sigParam toSign -signatureVerify :: Context -> DigitallySigned -> SignatureAlgorithm -> Bytes -> IO Bool +signatureVerify :: Context -> DigitallySigned -> DigitalSignatureAlg -> ByteString -> IO Bool signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) sigAlgExpected toVerifyData = do usedVersion <- usingState_ ctx getVersion - -- in the case of TLS < 1.2, RSA signing, then the data need to be hashed first, as - -- the SHA_MD5 algorithm expect an already digested data - let (hashDescr, toVerify) = + let (sigParam, toVerify) = case (usedVersion, hashSigAlg) of (TLS12, Nothing) -> error "expecting hash and signature algorithm in a TLS12 digitally signed structure" - (TLS12, Just (h,s)) | s == sigAlgExpected -> (signatureHashData sigAlgExpected (Just h), toVerifyData) - | otherwise -> error "expecting different signature algorithm" - (_, Nothing) -> case signatureHashData sigAlgExpected Nothing of - SHA1_MD5 -> (SHA1_MD5, hashFinal $ hashUpdate (hashInit SHA1_MD5) toVerifyData) - alg -> (alg, toVerifyData) + (TLS12, Just hs) | sigAlgExpected `signatureCompatible` hs -> (signatureParams sigAlgExpected hashSigAlg, toVerifyData) + | otherwise -> error "expecting different signature algorithm" + (_, Nothing) -> buildVerifyData (signatureParams sigAlgExpected Nothing) toVerifyData (_, Just _) -> error "not expecting hash and signature algorithm in a < TLS12 digitially signed structure" - signatureVerifyWithHashDescr ctx sigAlgExpected digSig (hashDescr, toVerify) + signatureVerifyWithCertVerifyData ctx digSig (sigParam, toVerify) -signatureVerifyWithHashDescr :: Context - -> SignatureAlgorithm - -> DigitallySigned - -> CertVerifyData - -> IO Bool -signatureVerifyWithHashDescr ctx sigAlgExpected (DigitallySigned _ bs) (hashDescr, toVerify) = do +signatureVerifyWithCertVerifyData :: Context + -> DigitallySigned + -> CertVerifyData + -> IO Bool +signatureVerifyWithCertVerifyData ctx (DigitallySigned _ bs) (sigParam, toVerify) = do cc <- usingState_ ctx $ isClientContext - case sigAlgExpected of - SignatureRSA -> verifyPublic ctx cc hashDescr toVerify bs - SignatureDSS -> verifyPublic ctx cc hashDescr toVerify bs - SignatureECDSA -> verifyPublic ctx cc hashDescr toVerify bs - _ -> error "signature verification not implemented yet" + verifyPublic ctx cc sigParam toVerify bs -digitallySignParams :: Context -> Bytes -> SignatureAlgorithm -> Maybe HashAlgorithm -> IO DigitallySigned -digitallySignParams ctx signatureData sigAlg mhash = do - let hashDescr = signatureHashData sigAlg mhash - signatureCreate ctx (fmap (\h -> (h, sigAlg)) mhash) (hashDescr, signatureData) +digitallySignParams :: Context -> ByteString -> DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -> IO DigitallySigned +digitallySignParams ctx signatureData sigAlg hashSigAlg = + let sigParam = signatureParams sigAlg hashSigAlg + in signatureCreateWithCertVerifyData ctx hashSigAlg (buildVerifyData sigParam signatureData) digitallySignDHParams :: Context -> ServerDHParams - -> SignatureAlgorithm - -> Maybe HashAlgorithm -- TLS12 only + -> DigitalSignatureAlg + -> Maybe HashAndSignatureAlgorithm -- TLS12 only -> IO DigitallySigned digitallySignDHParams ctx serverParams sigAlg mhash = do dhParamsData <- withClientAndServerRandom ctx $ encodeSignedDHParams serverParams @@ -170,8 +168,8 @@ digitallySignECDHParams :: Context -> ServerECDHParams - -> SignatureAlgorithm - -> Maybe HashAlgorithm -- TLS12 only + -> DigitalSignatureAlg + -> Maybe HashAndSignatureAlgorithm -- TLS12 only -> IO DigitallySigned digitallySignECDHParams ctx serverParams sigAlg mhash = do ecdhParamsData <- withClientAndServerRandom ctx $ encodeSignedECDHParams serverParams @@ -179,7 +177,7 @@ digitallySignDHParamsVerify :: Context -> ServerDHParams - -> SignatureAlgorithm + -> DigitalSignatureAlg -> DigitallySigned -> IO Bool digitallySignDHParamsVerify ctx dhparams sigAlg signature = do @@ -188,7 +186,7 @@ digitallySignECDHParamsVerify :: Context -> ServerECDHParams - -> SignatureAlgorithm + -> DigitalSignatureAlg -> DigitallySigned -> IO Bool digitallySignECDHParamsVerify ctx dhparams sigAlg signature = 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 @@ -58,9 +58,10 @@ import Network.TLS.Compression import Network.TLS.Types import Control.Applicative (Applicative, (<$>)) -import Control.Monad.State +import Control.Monad.State.Strict import Data.X509 (CertificateChain) import Data.ByteArray (ByteArrayAccess) +import Data.ByteString (ByteString) data HandshakeKeyState = HandshakeKeyState { hksRemotePublicKey :: !(Maybe PubKey) @@ -71,14 +72,14 @@ { hstClientVersion :: !(Version) , hstClientRandom :: !ClientRandom , hstServerRandom :: !(Maybe ServerRandom) - , hstMasterSecret :: !(Maybe Bytes) + , hstMasterSecret :: !(Maybe ByteString) , hstKeyState :: !HandshakeKeyState , hstServerDHParams :: !(Maybe ServerDHParams) , hstDHPrivate :: !(Maybe DHPrivate) , hstServerECDHParams :: !(Maybe ServerECDHParams) - , hstECDHPrivate :: !(Maybe ECDHPrivate) - , hstHandshakeDigest :: !(Either [Bytes] HashCtx) - , hstHandshakeMessages :: [Bytes] + , hstECDHPrivate :: !(Maybe GroupPrivate) + , hstHandshakeDigest :: !(Either [ByteString] HashCtx) + , hstHandshakeMessages :: [ByteString] , hstClientCertRequest :: !(Maybe ClientCertRequestData) -- ^ Set to Just-value when certificate request was received , hstClientCertSent :: !Bool -- ^ Set to true when a client certificate chain was sent , hstCertReqSent :: !Bool -- ^ Set to true when a certificate request was sent @@ -159,13 +160,13 @@ getDHPrivate :: HandshakeM DHPrivate getDHPrivate = fromJust "server DH private" <$> gets hstDHPrivate -getECDHPrivate :: HandshakeM ECDHPrivate +getECDHPrivate :: HandshakeM GroupPrivate getECDHPrivate = fromJust "server ECDH private" <$> gets hstECDHPrivate setDHPrivate :: DHPrivate -> HandshakeM () setDHPrivate shp = modify (\hst -> hst { hstDHPrivate = Just shp }) -setECDHPrivate :: ECDHPrivate -> HandshakeM () +setECDHPrivate :: GroupPrivate -> HandshakeM () setECDHPrivate shp = modify (\hst -> hst { hstECDHPrivate = Just shp }) setCertReqSent :: Bool -> HandshakeM () @@ -195,19 +196,19 @@ getPendingCipher :: HandshakeM Cipher getPendingCipher = fromJust "pending cipher" <$> gets hstPendingCipher -addHandshakeMessage :: Bytes -> HandshakeM () +addHandshakeMessage :: ByteString -> HandshakeM () addHandshakeMessage content = modify $ \hs -> hs { hstHandshakeMessages = content : hstHandshakeMessages hs} -getHandshakeMessages :: HandshakeM [Bytes] +getHandshakeMessages :: HandshakeM [ByteString] getHandshakeMessages = gets (reverse . hstHandshakeMessages) -updateHandshakeDigest :: Bytes -> HandshakeM () +updateHandshakeDigest :: ByteString -> HandshakeM () updateHandshakeDigest content = modify $ \hs -> hs { hstHandshakeDigest = case hstHandshakeDigest hs of Left bytes -> Left (content:bytes) Right hashCtx -> Right $ hashUpdate hashCtx content } -getHandshakeDigest :: Version -> Role -> HandshakeM Bytes +getHandshakeDigest :: Version -> Role -> HandshakeM ByteString getHandshakeDigest ver role = gets gen where gen hst = case hstHandshakeDigest hst of Right hashCtx -> @@ -236,14 +237,14 @@ -- | Set master secret and as a side effect generate the key block -- with all the right parameters, and setup the pending tx/rx state. -setMasterSecret :: Version -> Role -> Bytes -> HandshakeM () +setMasterSecret :: Version -> Role -> ByteString -> HandshakeM () setMasterSecret ver role masterSecret = modify $ \hst -> let (pendingTx, pendingRx) = computeKeyBlock hst masterSecret ver role in hst { hstMasterSecret = Just masterSecret , hstPendingTxState = Just pendingTx , hstPendingRxState = Just pendingRx } -computeKeyBlock :: HandshakeState -> Bytes -> Version -> Role -> (RecordState, RecordState) +computeKeyBlock :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState) computeKeyBlock hst masterSecret ver cc = (pendingTx, pendingRx) where cipher = fromJust "cipher" $ hstPendingCipher hst keyblockSize = cipherKeyBlockSize cipher diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -20,30 +20,33 @@ import Network.TLS.Sending import Network.TLS.Receiving import qualified Data.ByteString as B -import Data.ByteString.Char8 () +import Data.ByteString.Char8 (ByteString) import Data.IORef -import Control.Monad.State +import Control.Monad.State.Strict import Control.Exception (throwIO) import System.IO.Error (mkIOError, eofErrorType) checkValid :: Context -> IO () checkValid ctx = do established <- ctxEstablished ctx - unless established $ liftIO $ throwIO ConnectionNotEstablished + unless established $ throwIO ConnectionNotEstablished eofed <- ctxEOF ctx - when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing + when eofed $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing -readExact :: Context -> Int -> IO Bytes +readExact :: Context -> Int -> IO (Either TLSError ByteString) readExact ctx sz = do - hdrbs <- liftIO $ contextRecv ctx sz - when (B.length hdrbs < sz) $ do - setEOF ctx - if B.null hdrbs - then throwCore Error_EOF - else throwCore (Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs))) - return hdrbs + hdrbs <- contextRecv ctx sz + if B.length hdrbs == sz + then return $ Right hdrbs + else do + setEOF ctx + return . Left $ + if B.null hdrbs + then Error_EOF + else Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs)) + -- | recvRecord receive a full TLS record (header + data), from the other side. -- -- The record is disengaged from the record layer @@ -52,29 +55,37 @@ -> IO (Either TLSError (Record Plaintext)) recvRecord compatSSLv2 ctx #ifdef SSLV2_COMPATIBLE - | compatSSLv2 = do - header <- readExact ctx 2 - if B.head header < 0x80 - then readExact ctx 3 >>= either (return . Left) recvLength . decodeHeader . B.append header - else either (return . Left) recvDeprecatedLength $ decodeDeprecatedHeaderLength header + | compatSSLv2 = readExact ctx 2 >>= either (return . Left) sslv2Header #endif - | otherwise = readExact ctx 5 >>= either (return . Left) recvLength . decodeHeader - where recvLength header@(Header _ _ readlen) + | otherwise = readExact ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) + + where recvLengthE = either (return . Left) recvLength + + recvLength header@(Header _ _ readlen) | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded - | otherwise = readExact ctx (fromIntegral readlen) >>= getRecord header + | otherwise = + readExact ctx (fromIntegral readlen) >>= + either (return . Left) (getRecord header) #ifdef SSLV2_COMPATIBLE + sslv2Header header = + if B.head header >= 0x80 + then either (return . Left) recvDeprecatedLength $ decodeDeprecatedHeaderLength header + else readExact ctx 3 >>= + either (return . Left) (recvLengthE . decodeHeader . B.append header) + recvDeprecatedLength readlen | readlen > 1024 * 4 = return $ Left maximumSizeExceeded | otherwise = do - content <- readExact ctx (fromIntegral readlen) - case decodeDeprecatedHeader readlen content of - Left err -> return $ Left err - Right header -> getRecord header content + res <- readExact ctx (fromIntegral readlen) + case res of + Left e -> return $ Left e + Right content -> + either (return . Left) (flip getRecord content) $ decodeDeprecatedHeader readlen content #endif maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow) - getRecord :: Header -> Bytes -> IO (Either TLSError (Record Plaintext)) + getRecord :: Header -> ByteString -> IO (Either TLSError (Record Plaintext)) getRecord header content = do - liftIO $ withLog ctx $ \logging -> loggingIORecv logging header content + withLog ctx $ \logging -> loggingIORecv logging header content runRxState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content) diff --git a/Network/TLS/Imports.hs b/Network/TLS/Imports.hs --- a/Network/TLS/Imports.hs +++ b/Network/TLS/Imports.hs @@ -9,22 +9,20 @@ module Network.TLS.Imports ( -- generic exports - Control.Applicative.Applicative(..) + ByteString + , Control.Applicative.Applicative(..) , (Control.Applicative.<$>) , Data.Monoid.Monoid(..) -- project definition - , Bytes , showBytesHex ) where import qualified Control.Applicative import qualified Data.Monoid -import qualified Data.ByteString as B +import Data.ByteString (ByteString) import Data.ByteArray.Encoding as B import qualified Prelude -type Bytes = B.ByteString - -showBytesHex :: Bytes -> Prelude.String -showBytesHex bs = Prelude.show (B.convertToBase B.Base16 bs :: Bytes) +showBytesHex :: ByteString -> Prelude.String +showBytesHex bs = Prelude.show (B.convertToBase B.Base16 bs :: ByteString) diff --git a/Network/TLS/MAC.hs b/Network/TLS/MAC.hs --- a/Network/TLS/MAC.hs +++ b/Network/TLS/MAC.hs @@ -17,8 +17,8 @@ import Network.TLS.Crypto import Network.TLS.Types -import qualified Data.ByteString as B import Data.ByteString (ByteString) +import qualified Data.ByteString as B import Data.Bits (xor) type HMAC = ByteString -> ByteString -> ByteString diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -73,7 +73,6 @@ import Network.TLS.Crypto import Network.TLS.MAC import Network.TLS.Cipher (CipherKeyExchangeType(..), Cipher(..)) -import Network.TLS.Util.Serialization (os2ip,i2ospOf_) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC @@ -83,7 +82,6 @@ data CurrentParams = CurrentParams { cParamsVersion :: Version -- ^ current protocol version , cParamsKeyXchgType :: Maybe CipherKeyExchangeType -- ^ current key exchange type - , cParamsSupportNPN :: Bool -- ^ support Next Protocol Negotiation extension } deriving (Show,Eq) {- marshall helpers -} @@ -165,7 +163,7 @@ where encodeAlert (al, ad) = putWord8 (valOfType al) >> putWord8 (valOfType ad) {- decode and encode HANDSHAKE -} -decodeHandshakeRecord :: ByteString -> GetResult (HandshakeType, Bytes) +decodeHandshakeRecord :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord = runGet "handshake-record" $ do ty <- getHandshakeType content <- getOpaque24 @@ -183,9 +181,6 @@ HandshakeType_CertVerify -> decodeCertVerify cp HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp HandshakeType_Finished -> decodeFinished - HandshakeType_NPN -> do - unless (cParamsSupportNPN cp) $ fail "unsupported handshake type" - decodeNextProtocolNegotiation decodeDeprecatedHandshake :: ByteString -> Either TLSError Handshake decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b @@ -252,12 +247,6 @@ decodeFinished :: Get Handshake decodeFinished = Finished <$> (remaining >>= getBytes) -decodeNextProtocolNegotiation :: Get Handshake -decodeNextProtocolNegotiation = do - opaque <- getOpaque8 - _ <- getOpaque8 -- ignore padding - return $ HsNextProtocolNegotiation opaque - decodeCertRequest :: CurrentParams -> Get Handshake decodeCertRequest cp = do certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8 @@ -293,22 +282,11 @@ parseCKE CipherKeyExchange_DHE_RSA = parseClientDHPublic parseCKE CipherKeyExchange_DHE_DSS = parseClientDHPublic parseCKE CipherKeyExchange_DH_Anon = parseClientDHPublic - parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic + parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic parseCKE _ = error "unsupported client key exchange type" parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16 - parseClientECDHPublic = do - len <- getWord8 - formatTy <- getWord8 - case formatTy of - 4 -> do -- uncompressed - let siz = fromIntegral len `div` 2 - xb <- getBytes siz - yb <- getBytes siz - let x = os2ip xb - y = os2ip yb - return $ CKX_ECDH $ ecdhPublic x y siz - _ -> error ("unsupported EC format type: " ++ show formatTy) + parseClientECDHPublic = CKX_ECDH <$> getOpaque8 decodeServerKeyXchg_DH :: Get ServerDHParams decodeServerKeyXchg_DH = getServerDHParams @@ -336,13 +314,13 @@ signature <- getDigitallySigned ver return $ SKX_DHE_DSS dhparams signature CipherKeyExchange_ECDHE_RSA -> do - dhparams <- getServerECDHParams + ecdhparams <- getServerECDHParams signature <- getDigitallySigned ver - return $ SKX_ECDHE_RSA dhparams signature + return $ SKX_ECDHE_RSA ecdhparams signature CipherKeyExchange_ECDHE_ECDSA -> do - dhparams <- getServerECDHParams + ecdhparams <- getServerECDHParams signature <- getDigitallySigned ver - return $ SKX_ECDHE_ECDSA dhparams signature + return $ SKX_ECDHE_ECDSA ecdhparams signature _ -> do bs <- remaining >>= getBytes return $ SKX_Unknown bs @@ -393,11 +371,7 @@ case ckx of CKX_RSA encryptedPreMaster -> putBytes encryptedPreMaster CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic - CKX_ECDH clientECDHPublic -> do - let (x,y,siz) = ecdhUnwrapPublic clientECDHPublic - let xb = i2ospOf_ siz x - yb = i2ospOf_ siz y - putOpaque8 $ B.concat [B.singleton 4,xb,yb] + CKX_ECDH bytes -> putOpaque8 bytes encodeHandshakeContent (ServerKeyXchg skg) = case skg of @@ -433,13 +407,8 @@ encodeHandshakeContent (Finished opaque) = putBytes opaque -encodeHandshakeContent (HsNextProtocolNegotiation protocol) = do - putOpaque8 protocol - putOpaque8 $ B.replicate paddingLen 0 - where paddingLen = 32 - ((B.length protocol + 2) `mod` 32) - {- FIXME make sure it return error if not 32 available -} -getRandom32 :: Get Bytes +getRandom32 :: Get ByteString getRandom32 = getBytes 32 getServerRandom32 :: Get ServerRandom @@ -448,7 +417,7 @@ getClientRandom32 :: Get ClientRandom getClientRandom32 = ClientRandom <$> getRandom32 -putRandom32 :: Bytes -> Put +putRandom32 :: ByteString -> Put putRandom32 = putBytes putClientRandom32 :: ClientRandom -> Put @@ -504,36 +473,23 @@ getServerECDHParams = do curveType <- getWord8 case curveType of - 1 -> do -- explicit prime - _prime <- getOpaque8 - _a <- getOpaque8 - _b <- getOpaque8 - _base <- getOpaque8 - _order <- getOpaque8 - _cofactor <- getOpaque8 - error "cannot handle explicit prime ECDH Params" - 2 -> -- explicit_char2 - error "cannot handle explicit char2 ECDH Params" - 3 -> do -- ECParameters ECCurveType: curve name type - w16 <- getWord16 -- ECParameters NamedCurve - mxy <- getOpaque8 -- ECPoint - let xy = B.drop 1 mxy - siz = B.length xy `div` 2 - (xb,yb) = B.splitAt siz xy - x = os2ip xb - y = os2ip yb - return $ ServerECDHParams (ecdhParams w16) (ecdhPublic x y siz) + 3 -> do -- ECParameters ECCurveType: curve name type + mgrp <- toEnumSafe16 <$> getWord16 -- ECParameters NamedCurve + case mgrp of + Nothing -> error "getServerECDHParams: unknown group" + Just grp -> do + mxy <- getOpaque8 -- ECPoint + case decodeGroupPublic grp mxy of + Left e -> error $ "getServerECDHParams: " ++ show e + Right grppub -> return $ ServerECDHParams grp grppub _ -> - error "unknown type for ECDH Params" + error "getServerECDHParams: unknown type for ECDH Params" putServerECDHParams :: ServerECDHParams -> Put -putServerECDHParams (ServerECDHParams ecdhparams ecdhpub) = do - let (w16,x,y,siz) = ecdhUnwrap ecdhparams ecdhpub - putWord8 3 -- ECParameters ECCurveType: curve name type - putWord16 w16 -- ECParameters NamedCurve - let xb = i2ospOf_ siz x - yb = i2ospOf_ siz y - putOpaque8 $ B.concat [B.singleton 4,xb,yb] -- ECPoint +putServerECDHParams (ServerECDHParams grp grppub) = do + putWord8 3 -- ECParameters ECCurveType + putWord16 $ fromEnumSafe16 grp -- ECParameters NamedCurve + putOpaque8 $ encodeGroupPublic grppub -- ECPoint getDigitallySigned :: Version -> Get DigitallySigned getDigitallySigned ver @@ -558,11 +514,11 @@ encodeChangeCipherSpec = runPut (putWord8 1) -- rsa pre master secret -decodePreMasterSecret :: Bytes -> Either TLSError (Version, Bytes) +decodePreMasterSecret :: ByteString -> Either TLSError (Version, ByteString) decodePreMasterSecret = runGetErr "pre-master-secret" $ do liftM2 (,) getVersion (getBytes 46) -encodePreMasterSecret :: Version -> Bytes -> Bytes +encodePreMasterSecret :: Version -> ByteString -> ByteString encodePreMasterSecret version bytes = runPut (putVersion version >> putBytes bytes) -- | in certain cases, we haven't manage to decode ServerKeyExchange properly, @@ -571,7 +527,7 @@ -- able to really decode the server key xchange if it's unparsed. decodeReallyServerKeyXchgAlgorithmData :: Version -> CipherKeyExchangeType - -> Bytes + -> ByteString -> Either TLSError ServerKeyXchgAlgorithmData decodeReallyServerKeyXchgAlgorithmData ver cke = runGetErr "server-key-xchg-algorithm-data" (decodeServerKeyXchgAlgorithmData ver cke) @@ -580,7 +536,7 @@ {- - generate things for packet content -} -type PRF = Bytes -> Bytes -> Int -> Bytes +type PRF = ByteString -> ByteString -> Int -> ByteString -- | The TLS12 PRF is cipher specific, and some TLS12 algorithms use SHA384 -- instead of the default SHA256. @@ -590,13 +546,13 @@ | maybe True (< TLS12) (cipherMinVer ciph) = prf_SHA256 | otherwise = prf_TLS ver $ maybe SHA256 id $ cipherPRFHash ciph -generateMasterSecret_SSL :: ByteArrayAccess preMaster => preMaster -> ClientRandom -> ServerRandom -> Bytes +generateMasterSecret_SSL :: ByteArrayAccess preMaster => preMaster -> ClientRandom -> ServerRandom -> ByteString generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) = B.concat $ map (computeMD5) ["A","BB","CCC"] where computeMD5 label = hash MD5 $ B.concat [ B.convert premasterSecret, computeSHA1 label ] computeSHA1 label = hash SHA1 $ B.concat [ label, B.convert premasterSecret, c, s ] -generateMasterSecret_TLS :: ByteArrayAccess preMaster => PRF -> preMaster -> ClientRandom -> ServerRandom -> Bytes +generateMasterSecret_TLS :: ByteArrayAccess preMaster => PRF -> preMaster -> ClientRandom -> ServerRandom -> ByteString generateMasterSecret_TLS prf premasterSecret (ClientRandom c) (ServerRandom s) = prf (B.convert premasterSecret) seed 48 where seed = B.concat [ "master secret", c, s ] @@ -607,16 +563,16 @@ -> preMaster -> ClientRandom -> ServerRandom - -> Bytes + -> ByteString generateMasterSecret SSL2 _ = generateMasterSecret_SSL generateMasterSecret SSL3 _ = generateMasterSecret_SSL generateMasterSecret v c = generateMasterSecret_TLS $ getPRF v c -generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes +generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mastersecret kbsize = prf mastersecret seed kbsize where seed = B.concat [ "key expansion", s, c ] -generateKeyBlock_SSL :: ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes +generateKeyBlock_SSL :: ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString generateKeyBlock_SSL (ClientRandom c) (ServerRandom s) mastersecret kbsize = B.concat $ map computeMD5 $ take ((kbsize `div` 16) + 1) labels where labels = [ uncurry BC.replicate x | x <- zip [1..] ['A'..'Z'] ] @@ -627,18 +583,18 @@ -> Cipher -> ClientRandom -> ServerRandom - -> Bytes + -> ByteString -> Int - -> Bytes + -> ByteString generateKeyBlock SSL2 _ = generateKeyBlock_SSL generateKeyBlock SSL3 _ = generateKeyBlock_SSL generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c -generateFinished_TLS :: PRF -> Bytes -> Bytes -> HashCtx -> Bytes +generateFinished_TLS :: PRF -> ByteString -> ByteString -> HashCtx -> ByteString generateFinished_TLS prf label mastersecret hashctx = prf mastersecret seed 12 where seed = B.concat [ label, hashFinal hashctx ] -generateFinished_SSL :: Bytes -> Bytes -> HashCtx -> Bytes +generateFinished_SSL :: ByteString -> ByteString -> HashCtx -> ByteString generateFinished_SSL sender mastersecret hashctx = B.concat [md5hash, sha1hash] where md5hash = hash MD5 $ B.concat [ mastersecret, pad2, md5left ] sha1hash = hash SHA1 $ B.concat [ mastersecret, B.take 40 pad2, sha1left ] @@ -651,28 +607,28 @@ generateClientFinished :: Version -> Cipher - -> Bytes + -> ByteString -> HashCtx - -> Bytes + -> ByteString generateClientFinished ver ciph | ver < TLS10 = generateFinished_SSL "CLNT" | otherwise = generateFinished_TLS (getPRF ver ciph) "client finished" generateServerFinished :: Version -> Cipher - -> Bytes + -> ByteString -> HashCtx - -> Bytes + -> ByteString generateServerFinished ver ciph | ver < TLS10 = generateFinished_SSL "SRVR" | otherwise = generateFinished_TLS (getPRF ver ciph) "server finished" {- returns *output* after final MD5/SHA1 -} -generateCertificateVerify_SSL :: Bytes -> HashCtx -> Bytes +generateCertificateVerify_SSL :: ByteString -> HashCtx -> ByteString generateCertificateVerify_SSL = generateFinished_SSL "" {- returns *input* before final SHA1 -} -generateCertificateVerify_SSL_DSS :: Bytes -> HashCtx -> Bytes +generateCertificateVerify_SSL_DSS :: ByteString -> HashCtx -> ByteString generateCertificateVerify_SSL_DSS mastersecret hashctx = toHash where toHash = B.concat [ mastersecret, pad2, sha1left ] @@ -681,13 +637,13 @@ pad2 = B.replicate 40 0x5c pad1 = B.replicate 40 0x36 -encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> Bytes +encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> ByteString encodeSignedDHParams dhparams cran sran = runPut $ putClientRandom32 cran >> putServerRandom32 sran >> putServerDHParams dhparams -- Combination of RFC 5246 and 4492 is ambiguous. -- Let's assume ecdhe_rsa and ecdhe_dss are identical to -- dhe_rsa and dhe_dss. -encodeSignedECDHParams :: ServerECDHParams -> ClientRandom -> ServerRandom -> Bytes +encodeSignedECDHParams :: ServerECDHParams -> ClientRandom -> ServerRandom -> ByteString encodeSignedECDHParams dhparams cran sran = runPut $ putClientRandom32 cran >> putServerRandom32 sran >> putServerECDHParams dhparams diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -37,6 +37,7 @@ import Network.TLS.X509 import Network.TLS.RNG (Seed) import Data.Default.Class +import Data.ByteString (ByteString) import qualified Data.ByteString as B #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty) @@ -79,7 +80,7 @@ -- The extra blob is useful to differentiate services running on the same host, but that -- might have different certificates given. It's only used as part of the X509 validation -- infrastructure. - , clientServerIdentification :: (HostName, Bytes) + , clientServerIdentification :: (HostName, ByteString) -- | Allow the use of the Server Name Indication TLS extension during handshake, which allow -- the client to specify which host name, it's trying to access. This is useful to distinguish -- CNAME aliasing (e.g. web virtual host). @@ -94,7 +95,7 @@ , clientDebug :: DebugParams } deriving (Show) -defaultParamsClient :: HostName -> Bytes -> ClientParams +defaultParamsClient :: HostName -> ByteString -> ClientParams defaultParamsClient serverName serverId = ClientParams { clientWantSessionResume = Nothing , clientUseMaxFragmentLength = Nothing @@ -157,10 +158,10 @@ -- ordered by decreasing priority. -- -- This list is sent to the peer as part of the signature_algorithms - -- extension. It is also used to restrict the choice of hash and - -- signature algorithm, but only when the TLS version is 1.2 or above. - -- In order to disable SHA-1 one must then also disable earlier protocol - -- versions in 'supportedVersions'. + -- extension. It is also used to restrict the choice of server + -- credential, signature and hash algorithm, but only when the TLS + -- version is 1.2 or above. In order to disable SHA-1 one must then + -- also disable earlier protocol versions in 'supportedVersions'. , supportedHashSignatures :: [HashAndSignatureAlgorithm] -- | Secure renegotiation defined in RFC5746. -- If 'True', clients send the renegotiation_info extension. @@ -185,6 +186,11 @@ -- 'False', empty packets will never be added, which is less secure, but might help in rare -- cases. , supportedEmptyPacket :: Bool + -- | A list of supported elliptic curves in the preferred order. + -- The default value is ['P256','P384','P521']. + -- 'P256' provides 128-bit security which is strong enough + -- until 2030 and is fast because its backend is written in C. + , supportedGroups :: [Group] } deriving (Show,Eq) defaultSupported :: Supported @@ -206,6 +212,7 @@ , supportedSession = True , supportedFallbackScsv = True , supportedEmptyPacket = True + , supportedGroups = [P256,P384,P521] } instance Default Supported where @@ -252,19 +259,19 @@ onCertificateRequest :: ([CertificateType], Maybe [HashAndSignatureAlgorithm], [DistinguishedName]) -> IO (Maybe (CertificateChain, PrivKey)) - , onNPNServerSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) -- | Used by the client to validate the server certificate. The default -- implementation calls 'validateDefault' which validates according to the -- default hooks and checks provided by "Data.X509.Validation". This can -- be replaced with a custom validation function using different settings. , onServerCertificate :: CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason] + -- | This action is called when the client sends ClientHello + -- to determine ALPN values such as '["h2", "http/1.1"]'. , onSuggestALPN :: IO (Maybe [B.ByteString]) } defaultClientHooks :: ClientHooks defaultClientHooks = ClientHooks { onCertificateRequest = \ _ -> return Nothing - , onNPNServerSuggest = Nothing , onServerCertificate = validateDefault , onSuggestALPN = return Nothing } @@ -303,12 +310,17 @@ -- This is most useful for transparent proxies where -- credentials must be generated on the fly according to -- the host the client is trying to connect to. + -- + -- Returned credentials may be ignored if a client does not support + -- the signature algorithms used in the certificate chain. , onServerNameIndication :: Maybe HostName -> IO Credentials - -- | suggested next protocols accoring to the next protocol negotiation extension. - , onSuggestNextProtocols :: IO (Maybe [B.ByteString]) -- | at each new handshake, we call this hook to see if we allow handshake to happens. , onNewHandshake :: Measurement -> IO Bool + + -- | Allow the server to choose an application layer protocol + -- suggested from the client through the ALPN + -- (Application Layer Protocol Negotiation) extensions. , onALPNClientSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) } @@ -318,7 +330,6 @@ , onClientCertificate = \_ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected" , onUnverifiedClientCert = return False , onServerNameIndication = \_ -> return mempty - , onSuggestNextProtocols = return Nothing , onNewHandshake = \_ -> return True , onALPNClientSuggest = Nothing } diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -14,7 +14,7 @@ ( processPacket ) where -import Control.Monad.State +import Control.Monad.State.Strict import Control.Concurrent.MVar import Network.TLS.Context.Internal @@ -43,11 +43,9 @@ processPacket ctx (Record ProtocolType_Handshake ver fragment) = do keyxchg <- getHState ctx >>= \hs -> return $ (hs >>= hstPendingCipher >>= Just . cipherKeyExchange) usingState ctx $ do - npn <- getExtensionNPN let currentParams = CurrentParams { cParamsVersion = ver , cParamsKeyXchgType = keyxchg - , cParamsSupportNPN = npn } -- get back the optional continuation, and parse as many handshake record as possible. mCont <- gets stHandshakeRecordCont 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 @@ -14,7 +14,7 @@ ( disengageRecord ) where -import Control.Monad.State +import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag(..)) import Network.TLS.Struct @@ -69,7 +69,7 @@ return $ cipherDataContent cdata -decryptData :: Version -> Record Ciphertext -> Bytes -> RecordState -> RecordM Bytes +decryptData :: Version -> Record Ciphertext -> ByteString -> RecordState -> RecordM ByteString decryptData ver record econtent tst = decryptOf (cstKey cst) where cipher = fromJust "cipher" $ stCipher tst bulk = cipherBulk cipher @@ -82,7 +82,7 @@ sanityCheckError = throwError (Error_Packet "encrypted content too small for encryption parameters") - decryptOf :: BulkState -> RecordM Bytes + decryptOf :: BulkState -> RecordM ByteString decryptOf (BulkStateBlock decryptF) = do let minContent = (if explicitIV then bulkIVSize bulk else 0) + max (macSize + 1) blockSize diff --git a/Network/TLS/Record/Engage.hs b/Network/TLS/Record/Engage.hs --- a/Network/TLS/Record/Engage.hs +++ b/Network/TLS/Record/Engage.hs @@ -14,7 +14,7 @@ ) where import Control.Applicative -import Control.Monad.State +import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag(..)) import Network.TLS.Cap diff --git a/Network/TLS/Record/State.hs b/Network/TLS/Record/State.hs --- a/Network/TLS/Record/State.hs +++ b/Network/TLS/Record/State.hs @@ -26,7 +26,7 @@ import Data.Word import Control.Applicative -import Control.Monad.State +import Control.Monad.State.Strict import Network.TLS.Compression import Network.TLS.Cipher import Network.TLS.ErrT @@ -37,12 +37,13 @@ import Network.TLS.MAC import Network.TLS.Util +import Data.ByteString (ByteString) import qualified Data.ByteString as B data CryptState = CryptState { cstKey :: !BulkState - , cstIV :: !Bytes - , cstMacSecret :: !Bytes + , cstIV :: !ByteString + , cstMacSecret :: !ByteString } deriving (Show) newtype MacState = MacState @@ -106,7 +107,7 @@ incrRecordState ts = ts { stMacState = MacState (ms + 1) } where (MacState ms) = stMacState ts -setRecordIV :: Bytes -> RecordState -> RecordState +setRecordIV :: ByteString -> RecordState -> RecordState setRecordIV iv st = st { stCryptState = (stCryptState st) { cstIV = iv } } withCompression :: (Compression -> (Compression, a)) -> RecordM a @@ -116,7 +117,7 @@ put $ st { stCompression = nc } return a -computeDigest :: Version -> RecordState -> Header -> Bytes -> (Bytes, RecordState) +computeDigest :: Version -> RecordState -> Header -> ByteString -> (ByteString, RecordState) computeDigest ver tstate hdr content = (digest, incrRecordState tstate) where digest = macF (cstMacSecret cst) msg cst = stCryptState tstate @@ -128,7 +129,7 @@ | ver < TLS10 = (macSSL hashA, B.concat [ encodedSeq, encodeHeaderNoVer hdr, content ]) | otherwise = (hmac hashA, B.concat [ encodedSeq, encodeHeader hdr, content ]) -makeDigest :: Header -> Bytes -> RecordM Bytes +makeDigest :: Header -> ByteString -> RecordM ByteString makeDigest hdr content = do ver <- getRecordVersion st <- get diff --git a/Network/TLS/Record/Types.hs b/Network/TLS/Record/Types.hs --- a/Network/TLS/Record/Types.hs +++ b/Network/TLS/Record/Types.hs @@ -40,48 +40,49 @@ import Network.TLS.Struct import Network.TLS.Record.State +import Data.ByteString (ByteString) import qualified Data.ByteString as B import Control.Applicative ((<$>)) -- | Represent a TLS record. data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq) -newtype Fragment a = Fragment { fragmentGetBytes :: Bytes } deriving (Show,Eq) +newtype Fragment a = Fragment { fragmentGetBytes :: ByteString } deriving (Show,Eq) data Plaintext data Compressed data Ciphertext -fragmentPlaintext :: Bytes -> Fragment Plaintext +fragmentPlaintext :: ByteString -> Fragment Plaintext fragmentPlaintext bytes = Fragment bytes -fragmentCiphertext :: Bytes -> Fragment Ciphertext +fragmentCiphertext :: ByteString -> Fragment Ciphertext fragmentCiphertext bytes = Fragment bytes onRecordFragment :: Record a -> (Fragment a -> RecordM (Fragment b)) -> RecordM (Record b) onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag -fragmentMap :: (Bytes -> RecordM Bytes) -> Fragment a -> RecordM (Fragment b) +fragmentMap :: (ByteString -> RecordM ByteString) -> Fragment a -> RecordM (Fragment b) fragmentMap f (Fragment b) = Fragment <$> f b -- | turn a plaintext record into a compressed record using the compression function supplied -fragmentCompress :: (Bytes -> RecordM Bytes) -> Fragment Plaintext -> RecordM (Fragment Compressed) +fragmentCompress :: (ByteString -> RecordM ByteString) -> Fragment Plaintext -> RecordM (Fragment Compressed) fragmentCompress f = fragmentMap f -- | turn a compressed record into a ciphertext record using the cipher function supplied -fragmentCipher :: (Bytes -> RecordM Bytes) -> Fragment Compressed -> RecordM (Fragment Ciphertext) +fragmentCipher :: (ByteString -> RecordM ByteString) -> Fragment Compressed -> RecordM (Fragment Ciphertext) fragmentCipher f = fragmentMap f -- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied -fragmentUncipher :: (Bytes -> RecordM Bytes) -> Fragment Ciphertext -> RecordM (Fragment Compressed) +fragmentUncipher :: (ByteString -> RecordM ByteString) -> Fragment Ciphertext -> RecordM (Fragment Compressed) fragmentUncipher f = fragmentMap f -- | turn a compressed fragment into a plaintext fragment using the decompression function supplied -fragmentUncompress :: (Bytes -> RecordM Bytes) -> Fragment Compressed -> RecordM (Fragment Plaintext) +fragmentUncompress :: (ByteString -> RecordM ByteString) -> Fragment Compressed -> RecordM (Fragment Plaintext) fragmentUncompress f = fragmentMap f -- | turn a record into an header and bytes -recordToRaw :: Record a -> (Header, Bytes) +recordToRaw :: Record a -> (Header, ByteString) recordToRaw (Record pt ver (Fragment bytes)) = (Header pt ver (fromIntegral $ B.length bytes), bytes) -- | turn a header and a fragment into a record diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs --- a/Network/TLS/Sending.hs +++ b/Network/TLS/Sending.hs @@ -11,7 +11,7 @@ module Network.TLS.Sending (writePacket) where import Control.Applicative -import Control.Monad.State +import Control.Monad.State.Strict import Control.Concurrent.MVar import Data.IORef diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -29,18 +29,12 @@ , getVersionWithDefault , setSecureRenegotiation , getSecureRenegotiation - , setExtensionNPN - , getExtensionNPN , setExtensionALPN , getExtensionALPN , setNegotiatedProtocol , getNegotiatedProtocol - , setServerNextProtocolSuggest - , getServerNextProtocolSuggest , setClientALPNSuggest , getClientALPNSuggest - , setClientEllipticCurveSuggest - , getClientEllipticCurveSuggest , setClientEcPointFormatSuggest , getClientEcPointFormatSuggest , getClientCertificateChain @@ -63,8 +57,9 @@ import Network.TLS.Types (Role(..)) import Network.TLS.Wire (GetContinuation) import Network.TLS.Extension +import Data.ByteString (ByteString) import qualified Data.ByteString as B -import Control.Monad.State +import Control.Monad.State.Strict import Network.TLS.ErrT import Crypto.Random import Data.X509 (CertificateChain) @@ -75,15 +70,13 @@ { stSession :: Session , stSessionResuming :: Bool , stSecureRenegotiation :: Bool -- RFC 5746 - , stClientVerifiedData :: Bytes -- RFC 5746 - , stServerVerifiedData :: Bytes -- RFC 5746 - , stExtensionNPN :: Bool -- NPN draft extension + , stClientVerifiedData :: ByteString -- RFC 5746 + , stServerVerifiedData :: ByteString -- RFC 5746 , stExtensionALPN :: Bool -- RFC 7301 - , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, Bytes)) - , stNegotiatedProtocol :: Maybe B.ByteString -- NPN and ALPN protocol - , stServerNextProtocolSuggest :: Maybe [B.ByteString] + , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, ByteString)) + , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol , stClientALPNSuggest :: Maybe [B.ByteString] - , stClientEllipticCurveSuggest :: Maybe [NamedCurve] + , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] , stClientCertificateChain :: Maybe CertificateChain , stClientSNI :: Maybe HostName @@ -112,13 +105,11 @@ , stSecureRenegotiation = False , stClientVerifiedData = B.empty , stServerVerifiedData = B.empty - , stExtensionNPN = False , stExtensionALPN = False , stHandshakeRecordCont = Nothing , stNegotiatedProtocol = Nothing - , stServerNextProtocolSuggest = Nothing , stClientALPNSuggest = Nothing - , stClientEllipticCurveSuggest = Nothing + , stClientGroupSuggest = Nothing , stClientEcPointFormatSuggest = Nothing , stClientCertificateChain = Nothing , stClientSNI = Nothing @@ -127,7 +118,7 @@ , stClientContext = clientContext } -updateVerifiedData :: Role -> Bytes -> TLSSt () +updateVerifiedData :: Role -> ByteString -> TLSSt () updateVerifiedData sending bs = do cc <- isClientContext if cc /= sending @@ -145,7 +136,6 @@ finishHandshakeTypeMaterial HandshakeType_CertRequest = True finishHandshakeTypeMaterial HandshakeType_CertVerify = True finishHandshakeTypeMaterial HandshakeType_Finished = True -finishHandshakeTypeMaterial HandshakeType_NPN = True finishHandshakeMaterial :: Handshake -> Bool finishHandshakeMaterial = finishHandshakeTypeMaterial . typeOfHandshake @@ -161,7 +151,6 @@ certVerifyHandshakeTypeMaterial HandshakeType_CertRequest = True certVerifyHandshakeTypeMaterial HandshakeType_CertVerify = False certVerifyHandshakeTypeMaterial HandshakeType_Finished = False -certVerifyHandshakeTypeMaterial HandshakeType_NPN = False certVerifyHandshakeMaterial :: Handshake -> Bool certVerifyHandshakeMaterial = certVerifyHandshakeTypeMaterial . typeOfHandshake @@ -196,12 +185,6 @@ getSecureRenegotiation :: TLSSt Bool getSecureRenegotiation = gets stSecureRenegotiation -setExtensionNPN :: Bool -> TLSSt () -setExtensionNPN b = modify (\st -> st { stExtensionNPN = b }) - -getExtensionNPN :: TLSSt Bool -getExtensionNPN = gets stExtensionNPN - setExtensionALPN :: Bool -> TLSSt () setExtensionALPN b = modify (\st -> st { stExtensionALPN = b }) @@ -214,24 +197,12 @@ getNegotiatedProtocol :: TLSSt (Maybe B.ByteString) getNegotiatedProtocol = gets stNegotiatedProtocol -setServerNextProtocolSuggest :: [B.ByteString] -> TLSSt () -setServerNextProtocolSuggest ps = modify (\st -> st { stServerNextProtocolSuggest = Just ps}) - -getServerNextProtocolSuggest :: TLSSt (Maybe [B.ByteString]) -getServerNextProtocolSuggest = gets stServerNextProtocolSuggest - setClientALPNSuggest :: [B.ByteString] -> TLSSt () setClientALPNSuggest ps = modify (\st -> st { stClientALPNSuggest = Just ps}) getClientALPNSuggest :: TLSSt (Maybe [B.ByteString]) getClientALPNSuggest = gets stClientALPNSuggest -setClientEllipticCurveSuggest :: [NamedCurve] -> TLSSt () -setClientEllipticCurveSuggest nc = modify (\st -> st { stClientEllipticCurveSuggest = Just nc}) - -getClientEllipticCurveSuggest :: TLSSt (Maybe [NamedCurve]) -getClientEllipticCurveSuggest = gets stClientEllipticCurveSuggest - setClientEcPointFormatSuggest :: [EcPointFormat] -> TLSSt () setClientEcPointFormatSuggest epf = modify (\st -> st { stClientEcPointFormatSuggest = Just epf}) @@ -250,13 +221,13 @@ getClientSNI :: TLSSt (Maybe HostName) getClientSNI = gets stClientSNI -getVerifiedData :: Role -> TLSSt Bytes +getVerifiedData :: Role -> TLSSt ByteString getVerifiedData client = gets (if client == ClientRole then stClientVerifiedData else stServerVerifiedData) isClientContext :: TLSSt Role isClientContext = gets stClientContext -genRandom :: Int -> TLSSt Bytes +genRandom :: Int -> TLSSt ByteString genRandom n = do withRNG (getRandomBytes n) diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -11,8 +11,7 @@ -- {-# LANGUAGE CPP #-} module Network.TLS.Struct - ( Bytes - , Version(..) + ( Version(..) , ConnectionEnd(..) , CipherType(..) , CipherData(..) @@ -68,8 +67,7 @@ import Data.Typeable import Control.Exception (Exception(..)) import Network.TLS.Types -import Network.TLS.Crypto.DH -import Network.TLS.Crypto.ECDH +import Network.TLS.Crypto import Network.TLS.Util.Serialization import Network.TLS.Imports #if MIN_VERSION_mtl(2,2,1) @@ -81,9 +79,9 @@ data CipherType = CipherStream | CipherBlock | CipherAEAD data CipherData = CipherData - { cipherDataContent :: Bytes - , cipherDataMAC :: Maybe Bytes - , cipherDataPadding :: Maybe Bytes + { cipherDataContent :: ByteString + , cipherDataMAC :: Maybe ByteString + , cipherDataPadding :: Maybe ByteString } deriving (Show,Eq) data CertificateType = @@ -105,6 +103,7 @@ | HashSHA256 | HashSHA384 | HashSHA512 + | HashIntrinsic | HashOther Word8 deriving (Show,Eq) @@ -113,12 +112,17 @@ | SignatureRSA | SignatureDSS | SignatureECDSA + | SignatureRSApssSHA256 + | SignatureRSApssSHA384 + | SignatureRSApssSHA512 + | SignatureEd25519 + | SignatureEd448 | SignatureOther Word8 deriving (Show,Eq) type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) -type Signature = Bytes +type Signature = ByteString data DigitallySigned = DigitallySigned (Maybe HashAndSignatureAlgorithm) Signature deriving (Show,Eq) @@ -173,26 +177,26 @@ data Header = Header ProtocolType Version Word16 deriving (Show,Eq) -newtype ServerRandom = ServerRandom { unServerRandom :: Bytes } deriving (Show, Eq) -newtype ClientRandom = ClientRandom { unClientRandom :: Bytes } deriving (Show, Eq) +newtype ServerRandom = ServerRandom { unServerRandom :: ByteString } deriving (Show, Eq) +newtype ClientRandom = ClientRandom { unClientRandom :: ByteString } deriving (Show, Eq) newtype Session = Session (Maybe SessionID) deriving (Show, Eq) -type FinishedData = Bytes +type FinishedData = ByteString type ExtensionID = Word16 -data ExtensionRaw = ExtensionRaw ExtensionID Bytes +data ExtensionRaw = ExtensionRaw ExtensionID ByteString deriving (Eq) instance Show ExtensionRaw where show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs ++ "" -constrRandom32 :: (Bytes -> a) -> Bytes -> Maybe a +constrRandom32 :: (ByteString -> a) -> ByteString -> Maybe a constrRandom32 constr l = if B.length l == 32 then Just (constr l) else Nothing -serverRandom :: Bytes -> Maybe ServerRandom +serverRandom :: ByteString -> Maybe ServerRandom serverRandom l = constrRandom32 ServerRandom l -clientRandom :: Bytes -> Maybe ClientRandom +clientRandom :: ByteString -> Maybe ClientRandom clientRandom l = constrRandom32 ClientRandom l data AlertLevel = @@ -243,10 +247,9 @@ | HandshakeType_CertVerify | HandshakeType_ClientKeyXchg | HandshakeType_Finished - | HandshakeType_NPN -- Next Protocol Negotiation extension deriving (Show,Eq) -newtype BigNum = BigNum Bytes +newtype BigNum = BigNum ByteString deriving (Show,Eq) bigNumToInteger :: BigNum -> Integer @@ -276,7 +279,7 @@ serverDHParamsToPublic serverParams = dhPublic (bigNumToInteger $ serverDHParams_y serverParams) -data ServerECDHParams = ServerECDHParams ECDHParams ECDHPublic +data ServerECDHParams = ServerECDHParams Group GroupPublic deriving (Show,Eq) data ServerRSAParams = ServerRSAParams @@ -293,14 +296,14 @@ | SKX_RSA (Maybe ServerRSAParams) | SKX_DH_DSS (Maybe ServerRSAParams) | SKX_DH_RSA (Maybe ServerRSAParams) - | SKX_Unparsed Bytes -- if we parse the server key xchg before knowing the actual cipher, we end up with this structure. - | SKX_Unknown Bytes + | SKX_Unparsed ByteString -- if we parse the server key xchg before knowing the actual cipher, we end up with this structure. + | SKX_Unknown ByteString deriving (Show,Eq) data ClientKeyXchgAlgorithmData = - CKX_RSA Bytes + CKX_RSA ByteString | CKX_DH DHPublic - | CKX_ECDH ECDHPublic + | CKX_ECDH ByteString deriving (Show,Eq) type DeprecatedRecord = ByteString @@ -316,7 +319,6 @@ | CertRequest [CertificateType] (Maybe [HashAndSignatureAlgorithm]) [DistinguishedName] | CertVerify DigitallySigned | Finished FinishedData - | HsNextProtocolNegotiation Bytes -- NPN extension deriving (Show,Eq) packetType :: Packet -> ProtocolType @@ -336,7 +338,6 @@ typeOfHandshake (CertRequest {}) = HandshakeType_CertRequest typeOfHandshake (CertVerify {}) = HandshakeType_CertVerify typeOfHandshake (Finished {}) = HandshakeType_Finished -typeOfHandshake (HsNextProtocolNegotiation {}) = HandshakeType_NPN numericalVer :: Version -> (Word8, Word8) numericalVer SSL2 = (2, 0) @@ -408,7 +409,6 @@ valOfType HandshakeType_CertVerify = 15 valOfType HandshakeType_ClientKeyXchg = 16 valOfType HandshakeType_Finished = 20 - valOfType HandshakeType_NPN = 67 valToType 0 = Just HandshakeType_HelloRequest valToType 1 = Just HandshakeType_ClientHello @@ -420,7 +420,6 @@ valToType 15 = Just HandshakeType_CertVerify valToType 16 = Just HandshakeType_ClientKeyXchg valToType 20 = Just HandshakeType_Finished - valToType 67 = Just HandshakeType_NPN valToType _ = Nothing instance TypeValuable AlertLevel where @@ -520,6 +519,7 @@ valOfType HashSHA256 = 4 valOfType HashSHA384 = 5 valOfType HashSHA512 = 6 + valOfType HashIntrinsic = 8 valOfType (HashOther i) = i valToType 0 = Just HashNone @@ -529,17 +529,52 @@ valToType 4 = Just HashSHA256 valToType 5 = Just HashSHA384 valToType 6 = Just HashSHA512 + valToType 8 = Just HashIntrinsic valToType i = Just (HashOther i) instance TypeValuable SignatureAlgorithm where - valOfType SignatureAnonymous = 0 - valOfType SignatureRSA = 1 - valOfType SignatureDSS = 2 - valOfType SignatureECDSA = 3 - valOfType (SignatureOther i) = i + valOfType SignatureAnonymous = 0 + valOfType SignatureRSA = 1 + valOfType SignatureDSS = 2 + valOfType SignatureECDSA = 3 + valOfType SignatureRSApssSHA256 = 4 + valOfType SignatureRSApssSHA384 = 5 + valOfType SignatureRSApssSHA512 = 6 + valOfType SignatureEd25519 = 7 + valOfType SignatureEd448 = 8 + valOfType (SignatureOther i) = i valToType 0 = Just SignatureAnonymous valToType 1 = Just SignatureRSA valToType 2 = Just SignatureDSS valToType 3 = Just SignatureECDSA + valToType 4 = Just SignatureRSApssSHA256 + valToType 5 = Just SignatureRSApssSHA384 + valToType 6 = Just SignatureRSApssSHA512 + valToType 7 = Just SignatureEd25519 + valToType 8 = Just SignatureEd448 valToType i = Just (SignatureOther i) + +instance EnumSafe16 Group where + fromEnumSafe16 P256 = 23 + fromEnumSafe16 P384 = 24 + fromEnumSafe16 P521 = 25 + fromEnumSafe16 X25519 = 29 + fromEnumSafe16 X448 = 30 + fromEnumSafe16 FFDHE2048 = 256 + fromEnumSafe16 FFDHE3072 = 257 + fromEnumSafe16 FFDHE4096 = 258 + fromEnumSafe16 FFDHE6144 = 259 + fromEnumSafe16 FFDHE8192 = 260 + + toEnumSafe16 23 = Just P256 + toEnumSafe16 24 = Just P384 + toEnumSafe16 25 = Just P521 + toEnumSafe16 29 = Just X25519 + toEnumSafe16 30 = Just X448 + toEnumSafe16 256 = Just FFDHE2048 + toEnumSafe16 257 = Just FFDHE3072 + toEnumSafe16 258 = Just FFDHE4096 + toEnumSafe16 259 = Just FFDHE6144 + toEnumSafe16 260 = Just FFDHE8192 + toEnumSafe16 _ = Nothing diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -19,6 +19,8 @@ import Data.ByteString (ByteString) import Data.Word +type HostName = String + -- | Versions known to TLS -- -- SSL2 is just defined, but this version is and will not be supported. @@ -29,9 +31,11 @@ -- | Session data to resume data SessionData = SessionData - { sessionVersion :: Version - , sessionCipher :: CipherID - , sessionSecret :: ByteString + { sessionVersion :: Version + , sessionCipher :: CipherID + , sessionCompression :: CompressionID + , sessionClientSNI :: Maybe HostName + , sessionSecret :: ByteString } deriving (Show,Eq) -- | Cipher identification diff --git a/Network/TLS/Util.hs b/Network/TLS/Util.hs --- a/Network/TLS/Util.hs +++ b/Network/TLS/Util.hs @@ -13,23 +13,24 @@ ) where import Data.List (foldl') -import Network.TLS.Imports (Bytes) +-- import Network.TLS.Imports (ByteString) +import Data.ByteString (ByteString) import qualified Data.ByteString as B import Control.Exception (SomeException) import Control.Concurrent.Async -sub :: Bytes -> Int -> Int -> Maybe Bytes +sub :: ByteString -> Int -> Int -> Maybe ByteString sub b offset len | B.length b < offset + len = Nothing | otherwise = Just $ B.take len $ snd $ B.splitAt offset b -takelast :: Int -> Bytes -> Maybe Bytes +takelast :: Int -> ByteString -> Maybe ByteString takelast i b | B.length b >= i = sub b (B.length b - i) i | otherwise = Nothing -partition3 :: Bytes -> (Int,Int,Int) -> Maybe (Bytes, Bytes, Bytes) +partition3 :: ByteString -> (Int,Int,Int) -> Maybe (ByteString, ByteString, ByteString) partition3 bytes (d1,d2,d3) | any (< 0) l = Nothing | sum l /= B.length bytes = Nothing @@ -39,7 +40,7 @@ (p2, r2) = B.splitAt d2 r1 (p3, _) = B.splitAt d3 r2 -partition6 :: Bytes -> (Int,Int,Int,Int,Int,Int) -> Maybe (Bytes, Bytes, Bytes, Bytes, Bytes, Bytes) +partition6 :: ByteString -> (Int,Int,Int,Int,Int,Int) -> Maybe (ByteString, ByteString, ByteString, ByteString, ByteString, ByteString) partition6 bytes (d1,d2,d3,d4,d5,d6) = if B.length bytes < s then Nothing else Just (p1,p2,p3,p4,p5,p6) where s = sum [d1,d2,d3,d4,d5,d6] (p1, r1) = B.splitAt d1 bytes @@ -67,15 +68,13 @@ -- | verify that 2 bytestrings are equals. -- it's a non lazy version, that will compare every bytes. -- arguments with different length will bail out early -bytesEq :: Bytes -> Bytes -> Bool +bytesEq :: ByteString -> ByteString -> Bool bytesEq b1 b2 | B.length b1 /= B.length b2 = False | otherwise = and' $ B.zipWith (==) b1 b2 fmapEither :: (a -> b) -> Either l a -> Either l b -fmapEither f e = case e of - Left l -> Left l - Right r -> Right (f r) +fmapEither f = fmap f catchException :: IO a -> (SomeException -> IO a) -> IO a catchException action handler = withAsync action waitCatch >>= either handler return diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -56,20 +56,21 @@ import Data.Serialize.Put import Control.Applicative ((<$>)) import Control.Monad +import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Word import Data.Bits import Network.TLS.Struct import Network.TLS.Util.Serialization -type GetContinuation a = Bytes -> GetResult a +type GetContinuation a = ByteString -> GetResult a data GetResult a = GotError TLSError | GotPartial (GetContinuation a) | GotSuccess a - | GotSuccessRemaining a Bytes + | GotSuccessRemaining a ByteString -runGet :: String -> Get a -> Bytes -> GetResult a +runGet :: String -> Get a -> ByteString -> GetResult a runGet lbl f = toGetResult <$> G.runGetPartial (label lbl f) where toGetResult (G.Fail err _) = GotError (Error_Packet_Parsing err) toGetResult (G.Partial cont) = GotPartial (toGetResult <$> cont) @@ -77,17 +78,17 @@ | B.null bsLeft = GotSuccess r | otherwise = GotSuccessRemaining r bsLeft -runGetErr :: String -> Get a -> Bytes -> Either TLSError a +runGetErr :: String -> Get a -> ByteString -> Either TLSError a runGetErr lbl getter b = toSimple $ runGet lbl getter b where toSimple (GotError err) = Left err toSimple (GotPartial _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: partial packet")) toSimple (GotSuccessRemaining _ _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: remaining bytes")) toSimple (GotSuccess r) = Right r -runGetMaybe :: Get a -> Bytes -> Maybe a +runGetMaybe :: Get a -> ByteString -> Maybe a runGetMaybe f = either (const Nothing) Just . G.runGet f -tryGet :: Get a -> Bytes -> Maybe a +tryGet :: Get a -> ByteString -> Maybe a tryGet f = either (const Nothing) Just . G.runGet f getWords8 :: Get [Word8] @@ -109,13 +110,13 @@ getWord32 :: Get Word32 getWord32 = getWord32be -getOpaque8 :: Get Bytes +getOpaque8 :: Get ByteString getOpaque8 = getWord8 >>= getBytes . fromIntegral -getOpaque16 :: Get Bytes +getOpaque16 :: Get ByteString getOpaque16 = getWord16 >>= getBytes . fromIntegral -getOpaque24 :: Get Bytes +getOpaque24 :: Get ByteString getOpaque24 = getWord24 >>= getBytes getInteger16 :: Get Integer @@ -157,16 +158,16 @@ let c = fromIntegral (i .&. 0xff) mapM_ putWord8 [a,b,c] -putBytes :: Bytes -> Put +putBytes :: ByteString -> Put putBytes = putByteString -putOpaque8 :: Bytes -> Put +putOpaque8 :: ByteString -> Put putOpaque8 b = putWord8 (fromIntegral $ B.length b) >> putBytes b -putOpaque16 :: Bytes -> Put +putOpaque16 :: ByteString -> Put putOpaque16 b = putWord16 (fromIntegral $ B.length b) >> putBytes b -putOpaque24 :: Bytes -> Put +putOpaque24 :: ByteString -> Put putOpaque24 b = putWord24 (B.length b) >> putBytes b putInteger16 :: Integer -> Put @@ -175,11 +176,11 @@ putBigNum16 :: BigNum -> Put putBigNum16 (BigNum b) = putOpaque16 b -encodeWord16 :: Word16 -> Bytes +encodeWord16 :: Word16 -> ByteString encodeWord16 = runPut . putWord16 -encodeWord32 :: Word32 -> Bytes +encodeWord32 :: Word32 -> ByteString encodeWord32 = runPut . putWord32 -encodeWord64 :: Word64 -> Bytes +encodeWord64 :: Word64 -> ByteString encodeWord64 = runPut . putWord64be diff --git a/Tests/Certificate.hs b/Tests/Certificate.hs --- a/Tests/Certificate.hs +++ b/Tests/Certificate.hs @@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Certificate ( arbitraryX509 , arbitraryX509WithKey @@ -8,14 +10,14 @@ import Control.Applicative import Test.Tasty.QuickCheck +import Data.ASN1.OID import Data.X509 import Data.Hourglass import qualified Data.ByteString as B import PubKey -testExtensionEncode critical ext = ExtensionRaw (extOID ext) critical (extEncode ext) - +arbitraryDN :: Gen DistinguishedName arbitraryDN = return $ DistinguishedName [] instance Arbitrary Date where @@ -39,11 +41,12 @@ instance Arbitrary DateTime where arbitrary = DateTime <$> arbitrary <*> arbitrary +maxSerial :: Integer maxSerial = 16777216 +arbitraryCertificate :: PubKey -> Gen Certificate arbitraryCertificate pubKey = do serial <- choose (0,maxSerial) - issuerdn <- arbitraryDN subjectdn <- arbitraryDN validity <- (,) <$> arbitrary <*> arbitrary let sigalg = SignatureALG HashSHA1 (pubkeyToAlg pubKey) @@ -56,10 +59,12 @@ , certValidity = validity , certPubKey = pubKey , certExtensions = Extensions $ Just - [ testExtensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment,KeyUsage_keyCertSign] + [ extensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment,KeyUsage_keyCertSign] ] } + where issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")] +simpleCertificate :: PubKey -> Certificate simpleCertificate pubKey = Certificate { certVersion = 3 @@ -70,13 +75,14 @@ , certValidity = (time1, time2) , certPubKey = pubKey , certExtensions = Extensions $ Just - [ testExtensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment] + [ extensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment] ] } where time1 = DateTime (Date 1999 January 1) (TimeOfDay 0 0 0 0) time2 = DateTime (Date 2049 January 1) (TimeOfDay 0 0 0 0) simpleDN = DistinguishedName [] +simpleX509 :: PubKey -> SignedCertificate simpleX509 pubKey = do let cert = simpleCertificate pubKey sig = replicate 40 1 @@ -84,6 +90,7 @@ (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig,sigalg,())) cert in signedExact +arbitraryX509WithKey :: (PubKey, t) -> Gen SignedCertificate arbitraryX509WithKey (pubKey, _) = do cert <- arbitraryCertificate pubKey sig <- resize 40 $ listOf1 arbitrary @@ -91,6 +98,7 @@ let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig,sigalg,())) cert return signedExact +arbitraryX509 :: Gen SignedCertificate arbitraryX509 = do let (pubKey, privKey) = getGlobalRSAPair arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey) diff --git a/Tests/Ciphers.hs b/Tests/Ciphers.hs --- a/Tests/Ciphers.hs +++ b/Tests/Ciphers.hs @@ -1,3 +1,5 @@ +-- Disable this warning so we can still test deprecated functionality. +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Ciphers ( propertyBulkFunctional ) where diff --git a/Tests/Connection.hs b/Tests/Connection.hs --- a/Tests/Connection.hs +++ b/Tests/Connection.hs @@ -1,115 +1,89 @@ +-- Disable this warning so we can still test deprecated functionality. +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Connection ( newPairContext + , arbitraryCiphers + , arbitraryVersions + , arbitraryHashSignatures + , arbitraryGroups , arbitraryPairParams , arbitraryPairParamsWithVersionsAndCiphers , arbitraryClientCredential + , leafPublicKey + , oneSessionManager , setPairParamsSessionManager , setPairParamsSessionResuming , establishDataPipe , initiateDataPipe - , blockCipher - , blockCipherDHE_RSA - , blockCipherDHE_DSS - , blockCipherECDHE_RSA - , blockCipherECDHE_RSA_SHA384 - , streamCipher ) where import Test.Tasty.QuickCheck import Certificate import PubKey import PipeChan -import Network.TLS -import Network.TLS.Extra.FFDHE +import Network.TLS as TLS +import Network.TLS.Extra import Data.X509 import Data.Default.Class +import Data.IORef import Control.Applicative import Control.Concurrent.Chan import Control.Concurrent import qualified Control.Exception as E +import Data.List (isInfixOf) import qualified Data.ByteString as B +debug :: Bool debug = False -blockCipher :: Cipher -blockCipher = Cipher - { cipherID = 0xff12 - , cipherName = "rsa-id-const" - , cipherBulk = Bulk - { bulkName = "id" - , bulkKeySize = 16 - , bulkIVSize = 16 - , bulkExplicitIV= 0 - , bulkAuthTagLen= 0 - , bulkBlockSize = 16 - , bulkF = BulkBlockF $ \_ _ _ -> (\m -> (m, B.empty)) - } - , cipherHash = MD5 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } - -blockCipherDHE_RSA :: Cipher -blockCipherDHE_RSA = blockCipher - { cipherID = 0xff14 - , cipherName = "dhe-rsa-id-const" - , cipherKeyExchange = CipherKeyExchange_DHE_RSA - } +knownCiphers :: [Cipher] +knownCiphers = filter nonECDSA (ciphersuite_all ++ ciphersuite_weak) + where + ciphersuite_weak = [ + cipher_DHE_DSS_RC4_SHA1 + , cipher_RC4_128_MD5 + , cipher_null_MD5 + , cipher_null_SHA1 + ] + -- arbitraryCredentialsOfEachType cannot generate ECDSA + nonECDSA c = not ("ECDSA" `isInfixOf` cipherName c) -blockCipherDHE_DSS :: Cipher -blockCipherDHE_DSS = blockCipher - { cipherID = 0xff15 - , cipherName = "dhe-dss-id-const" - , cipherKeyExchange = CipherKeyExchange_DHE_DSS - } +arbitraryCiphers :: Gen [Cipher] +arbitraryCiphers = listOf1 $ elements knownCiphers -blockCipherECDHE_RSA :: Cipher -blockCipherECDHE_RSA = blockCipher - { cipherID = 0xff16 - , cipherName = "ecdhe-rsa-id-const" - , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA - } +knownVersions :: [Version] +knownVersions = [SSL3,TLS10,TLS11,TLS12] -blockCipherECDHE_RSA_SHA384 :: Cipher -blockCipherECDHE_RSA_SHA384 = blockCipher - { cipherID = 0xff17 - , cipherName = "ecdhe-rsa-id-const-sha384" - , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA - , cipherHash = SHA384 - , cipherPRFHash = Just SHA384 - , cipherMinVer = Just TLS12 - } +arbitraryVersions :: Gen [Version] +arbitraryVersions = sublistOf knownVersions -streamCipher :: Cipher -streamCipher = blockCipher - { cipherID = 0xff13 - , cipherBulk = Bulk - { bulkName = "stream" - , bulkKeySize = 16 - , bulkIVSize = 0 - , bulkExplicitIV= 0 - , bulkAuthTagLen= 0 - , bulkBlockSize = 0 - , bulkF = BulkStreamF passThrough - } - } +knownHashSignatures :: [HashAndSignatureAlgorithm] +knownHashSignatures = filter nonECDSA availableHashSignatures where - passThrough _ _ = BulkStream go where go inp = (inp, BulkStream go) + availableHashSignatures = [(TLS.HashIntrinsic, SignatureRSApssSHA256) + ,(TLS.HashSHA512, SignatureRSA) + ,(TLS.HashSHA512, SignatureECDSA) + ,(TLS.HashSHA384, SignatureRSA) + ,(TLS.HashSHA384, SignatureECDSA) + ,(TLS.HashSHA256, SignatureRSA) + ,(TLS.HashSHA256, SignatureECDSA) + ,(TLS.HashSHA1, SignatureRSA) + ,(TLS.HashSHA1, SignatureDSS) + ] + -- arbitraryCredentialsOfEachType cannot generate ECDSA + nonECDSA (_,s) = s /= SignatureECDSA -knownCiphers :: [Cipher] -knownCiphers = [ blockCipher - , blockCipherDHE_RSA - , blockCipherDHE_DSS - , blockCipherECDHE_RSA - , blockCipherECDHE_RSA_SHA384 - , streamCipher - ] +arbitraryHashSignatures :: Gen [HashAndSignatureAlgorithm] +arbitraryHashSignatures = sublistOf knownHashSignatures -knownVersions :: [Version] -knownVersions = [SSL3,TLS10,TLS11,TLS12] +knownGroups :: [Group] +knownGroups = [P256,P384,P521,X25519,X448] +arbitraryGroups :: Gen [Group] +arbitraryGroups = listOf1 $ elements knownGroups + +arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)] arbitraryCredentialsOfEachType = do let (pubKey, privKey) = getGlobalRSAPair (dsaPub, dsaPriv) <- arbitraryDSAPair @@ -120,6 +94,10 @@ , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv) ] +leafPublicKey :: CertificateChain -> Maybe PubKey +leafPublicKey (CertificateChain []) = Nothing +leafPublicKey (CertificateChain (leaf:_)) = Just (certPubKey $ signedObject $ getSigned leaf) + arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher]) arbitraryCipherPair connectVersion = do serverCiphers <- arbitraryCiphers `suchThat` @@ -128,8 +106,6 @@ (\cs -> or [x `elem` serverCiphers && maybe True (<= connectVersion) (cipherMinVer x) | x <- cs]) return (clientCiphers, serverCiphers) - where - arbitraryCiphers = resize (length knownCiphers + 1) $ listOf1 (elements knownCiphers) arbitraryPairParams :: Gen (ClientParams, ServerParams) arbitraryPairParams = do @@ -142,6 +118,19 @@ serAllowedVersions <- (:[]) `fmap` elements allowedVersions arbitraryPairParamsWithVersionsAndCiphers (allowedVersions, serAllowedVersions) (clientCiphers, serverCiphers) +arbitraryGroupPair :: Gen ([Group], [Group]) +arbitraryGroupPair = do + serverGroups <- arbitraryGroups + clientGroups <- oneof [arbitraryGroups] `suchThat` + (\gs -> or [x `elem` serverGroups | x <- gs]) + return (clientGroups, serverGroups) + +arbitraryHashSignaturePair :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) +arbitraryHashSignaturePair = do + serverHashSignatures <- shuffle knownHashSignatures + clientHashSignatures <- shuffle knownHashSignatures + return (clientHashSignatures, serverHashSignatures) + arbitraryPairParamsWithVersionsAndCiphers :: ([Version], [Version]) -> ([Cipher], [Cipher]) -> Gen (ClientParams, ServerParams) @@ -150,10 +139,14 @@ dhparams <- elements [dhParams,ffdhe2048,ffdhe3072] creds <- arbitraryCredentialsOfEachType + (clientGroups, serverGroups) <- arbitraryGroupPair + (clientHashSignatures, serverHashSignatures) <- arbitraryHashSignaturePair let serverState = def { serverSupported = def { supportedCiphers = serverCiphers , supportedVersions = serverVersions , supportedSecureRenegotiation = secNeg + , supportedGroups = serverGroups + , supportedHashSignatures = serverHashSignatures } , serverDHEParams = Just dhparams , serverShared = def { sharedCredentials = Credentials creds } @@ -162,6 +155,8 @@ { clientSupported = def { supportedCiphers = clientCiphers , supportedVersions = clientVersions , supportedSecureRenegotiation = secNeg + , supportedGroups = clientGroups + , supportedHashSignatures = clientHashSignatures } , clientShared = def { sharedValidationCache = ValidationCache { cacheAdd = \_ _ _ -> return () @@ -174,16 +169,31 @@ arbitraryClientCredential :: Gen Credential arbitraryClientCredential = arbitraryCredentialsOfEachType >>= elements +-- | simple session manager to store one session id and session data for a single thread. +-- a Real concurrent session manager would use an MVar and have multiples items. +oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager +oneSessionManager ref = SessionManager + { sessionResume = \myId -> (>>= maybeResume myId) <$> readIORef ref + , sessionEstablish = \myId dat -> writeIORef ref $ Just (myId, dat) + , sessionInvalidate = \_ -> return () + } + where + maybeResume myId (sid, sdata) + | sid == myId = Just sdata + | otherwise = Nothing + setPairParamsSessionManager :: SessionManager -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) setPairParamsSessionManager manager (clientState, serverState) = (nc,ns) where nc = clientState { clientShared = updateSessionManager $ clientShared clientState } ns = serverState { serverShared = updateSessionManager $ serverShared serverState } updateSessionManager shared = shared { sharedSessionManager = manager } +setPairParamsSessionResuming :: (SessionID, SessionData) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) setPairParamsSessionResuming sessionStuff (clientState, serverState) = ( clientState { clientWantSessionResume = Just sessionStuff } , serverState) +newPairContext :: PipeChan -> (ClientParams, ServerParams) -> IO (Context, Context) newPairContext pipe (cParams, sParams) = do let noFlush = return () let noClose = return () @@ -204,6 +214,7 @@ , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) } else def +establishDataPipe :: (ClientParams, ServerParams) -> (Context -> Chan result -> IO ()) -> (Chan start -> Context -> IO ()) -> IO (Chan start, Chan result) establishDataPipe params tlsServer tlsClient = do -- initial setup pipe <- newPipe @@ -226,6 +237,7 @@ ", supported: " ++ show supported E.throw e +initiateDataPipe :: (ClientParams, ServerParams) -> (Context -> IO a1) -> (Context -> IO a) -> IO (Either E.SomeException a, Either E.SomeException a1) initiateDataPipe params tlsServer tlsClient = do -- initial setup pipe <- newPipe diff --git a/Tests/Marshalling.hs b/Tests/Marshalling.hs --- a/Tests/Marshalling.hs +++ b/Tests/Marshalling.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Marshalling where import Control.Monad @@ -99,4 +100,4 @@ GotError e -> error ("got error: " ++ show e) GotSuccessRemaining _ _ -> error "got remaining byte left" GotSuccess (ty, content) -> decodeHandshake cp ty content - cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = Just CipherKeyExchange_RSA, cParamsSupportNPN = True } + cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = Just CipherKeyExchange_RSA } diff --git a/Tests/PipeChan.hs b/Tests/PipeChan.hs --- a/Tests/PipeChan.hs +++ b/Tests/PipeChan.hs @@ -20,27 +20,41 @@ -- | represent a unidirectional pipe with a buffered read channel and a write channel data UniPipeChan = UniPipeChan (Chan ByteString) (Chan ByteString) +newUniPipeChan :: IO UniPipeChan newUniPipeChan = UniPipeChan <$> newChan <*> newChan +runUniPipe :: UniPipeChan -> IO ThreadId runUniPipe (UniPipeChan r w) = forkIO $ forever $ readChan r >>= writeChan w +getReadUniPipe :: UniPipeChan -> Chan ByteString getReadUniPipe (UniPipeChan r _) = r + +getWriteUniPipe :: UniPipeChan -> Chan ByteString getWriteUniPipe (UniPipeChan _ w) = w -- | Represent a bidirectional pipe with 2 nodes A and B data PipeChan = PipeChan (IORef ByteString) (IORef ByteString) UniPipeChan UniPipeChan +newPipe :: IO PipeChan newPipe = PipeChan <$> newIORef B.empty <*> newIORef B.empty <*> newUniPipeChan <*> newUniPipeChan +runPipe :: PipeChan -> IO ThreadId runPipe (PipeChan _ _ cToS sToC) = runUniPipe cToS >> runUniPipe sToC +readPipeA :: PipeChan -> Int -> IO ByteString readPipeA (PipeChan _ b _ s) sz = readBuffered b (getWriteUniPipe s) sz + +writePipeA :: PipeChan -> ByteString -> IO () writePipeA (PipeChan _ _ c _) = writeChan $ getWriteUniPipe c +readPipeB :: PipeChan -> Int -> IO ByteString readPipeB (PipeChan b _ c _) sz = readBuffered b (getWriteUniPipe c) sz + +writePipeB :: PipeChan -> ByteString -> IO () writePipeB (PipeChan _ _ _ s) = writeChan $ getReadUniPipe s -- helper to read buffered data. +readBuffered :: IORef ByteString -> Chan ByteString -> Int -> IO ByteString readBuffered buf chan sz = do left <- readIORef buf if B.length left >= sz diff --git a/Tests/Tests.hs b/Tests/Tests.hs --- a/Tests/Tests.hs +++ b/Tests/Tests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} import Test.Tasty import Test.Tasty.QuickCheck @@ -16,6 +17,7 @@ import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import Network.TLS +import Network.TLS.Extra import Control.Applicative import Control.Concurrent import Control.Monad @@ -43,8 +45,10 @@ return () +recvDataNonNull :: Context -> IO C8.ByteString recvDataNonNull ctx = recvData ctx >>= \l -> if B.null l then recvDataNonNull ctx else return l +runTLSPipe :: (ClientParams, ServerParams) -> (Context -> Chan C8.ByteString -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO () runTLSPipe params tlsServer tlsClient = do (startQueue, resultQueue) <- run (establishDataPipe params tlsServer tlsClient) -- send some data @@ -56,6 +60,7 @@ Just d `assertEq` dres return () +runTLSPipeSimple :: (ClientParams, ServerParams) -> PropertyM IO () runTLSPipeSimple params = runTLSPipe params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx @@ -69,33 +74,47 @@ bye ctx return () +runTLSInitFailure :: (ClientParams, ServerParams) -> PropertyM IO () runTLSInitFailure params = do (cRes, sRes) <- run (initiateDataPipe params tlsServer tlsClient) assertIsLeft cRes assertIsLeft sRes - where tlsServer ctx = handshake ctx >> bye ctx >> return "server success" - tlsClient ctx = handshake ctx >> bye ctx >> return "client success" + where tlsServer ctx = handshake ctx >> bye ctx >> return ("server success" :: String) + tlsClient ctx = handshake ctx >> bye ctx >> return ("client success" :: String) prop_handshake_initiate :: PropertyM IO () prop_handshake_initiate = do params <- pick arbitraryPairParams runTLSPipeSimple params --- test TLS12 protocol extensions with non-default configuration -prop_handshake_initiate_tls12 :: PropertyM IO () -prop_handshake_initiate_tls12 = do +prop_handshake_ciphersuites :: PropertyM IO () +prop_handshake_ciphersuites = do let clientVersions = [TLS12] serverVersions = [TLS12] - ciphers = [ blockCipherECDHE_RSA_SHA384 - , blockCipherECDHE_RSA - , blockCipherDHE_RSA - , blockCipherDHE_DSS + clientCiphers <- pick arbitraryCiphers + serverCiphers <- pick arbitraryCiphers + (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers + (clientVersions, serverVersions) + (clientCiphers, serverCiphers) + let shouldFail = null (clientCiphers `intersect` serverCiphers) + if shouldFail + then runTLSInitFailure (clientParam,serverParam) + else runTLSPipeSimple (clientParam,serverParam) + +prop_handshake_hashsignatures :: PropertyM IO () +prop_handshake_hashsignatures = do + let clientVersions = [TLS12] + serverVersions = [TLS12] + ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 + , cipher_ECDHE_RSA_AES128CBC_SHA + , cipher_DHE_RSA_AES128_SHA1 + , cipher_DHE_DSS_AES128_SHA1 ] (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (ciphers, ciphers) - clientHashSigs <- pick someHashSignatures - serverHashSigs <- pick someHashSignatures + clientHashSigs <- pick arbitraryHashSignatures + serverHashSigs <- pick arbitraryHashSignatures let clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedHashSignatures = clientHashSigs } } @@ -106,15 +125,70 @@ if shouldFail then runTLSInitFailure (clientParam',serverParam') else runTLSPipeSimple (clientParam',serverParam') - where someHashSignatures = sublistOf [ (HashSHA512, SignatureRSA) - , (HashSHA384, SignatureRSA) - , (HashSHA256, SignatureRSA) - , (HashSHA1, SignatureRSA) - , (HashSHA1, SignatureDSS) - ] -prop_handshake_client_auth_initiate :: PropertyM IO () -prop_handshake_client_auth_initiate = do +-- Tests ability to use or ignore client "signature_algorithms" extension when +-- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but +-- the server RSA certificate has a SHA-1 signature that the client does not +-- support. Server may choose the DSA certificate only when cipher +-- DHE_DSS_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA +-- certificate. +prop_handshake_cert_fallback :: PropertyM IO () +prop_handshake_cert_fallback = do + let clientVersions = [TLS12] + serverVersions = [TLS12] + commonCiphers = [ cipher_DHE_RSA_AES128_SHA1 ] + otherCiphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 + , cipher_ECDHE_RSA_AES128CBC_SHA + , cipher_DHE_DSS_AES128_SHA1 + ] + hashSignatures = [ (HashSHA256, SignatureRSA), (HashSHA1, SignatureDSS) ] + chainRef <- run $ newIORef Nothing + clientCiphers <- pick $ sublistOf otherCiphers + serverCiphers <- pick $ sublistOf otherCiphers + (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers + (clientVersions, serverVersions) + (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers) + let clientParam' = clientParam { clientSupported = (clientSupported clientParam) + { supportedHashSignatures = hashSignatures } + , clientHooks = (clientHooks clientParam) + { onServerCertificate = \_ _ _ chain -> + writeIORef chainRef (Just chain) >> return [] } + } + dssDisallowed = cipher_DHE_DSS_AES128_SHA1 `notElem` clientCiphers + || cipher_DHE_DSS_AES128_SHA1 `notElem` serverCiphers + runTLSPipeSimple (clientParam',serverParam) + serverChain <- run $ readIORef chainRef + dssDisallowed `assertEq` isLeafRSA serverChain + where + isLeafRSA chain = case chain >>= leafPublicKey of + Just (PubKeyRSA _) -> True + _ -> False + +prop_handshake_groups :: PropertyM IO () +prop_handshake_groups = do + let clientVersions = [TLS12] + serverVersions = [TLS12] + ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 + , cipher_ECDHE_RSA_AES128CBC_SHA + ] + (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers + (clientVersions, serverVersions) + (ciphers, ciphers) + clientGroups <- pick arbitraryGroups + serverGroups <- pick arbitraryGroups + let clientParam' = clientParam { clientSupported = (clientSupported clientParam) + { supportedGroups = clientGroups } + } + serverParam' = serverParam { serverSupported = (serverSupported serverParam) + { supportedGroups = serverGroups } + } + shouldFail = null (clientGroups `intersect` serverGroups) + if shouldFail + then runTLSInitFailure (clientParam',serverParam') + else runTLSPipeSimple (clientParam',serverParam') + +prop_handshake_client_auth :: PropertyM IO () +prop_handshake_client_auth = do (clientParam,serverParam) <- pick arbitraryPairParams cred <- pick arbitraryClientCredential let clientParam' = clientParam { clientHooks = (clientHooks clientParam) @@ -129,35 +203,61 @@ | chain == fst cred = return CertificateUsageAccept | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) -prop_handshake_npn_initiate :: PropertyM IO () -prop_handshake_npn_initiate = do +prop_handshake_alpn :: PropertyM IO () +prop_handshake_alpn = do (clientParam,serverParam) <- pick arbitraryPairParams let clientParam' = clientParam { clientHooks = (clientHooks clientParam) - { onNPNServerSuggest = Just $ \protos -> return (head protos) } + { onSuggestALPN = return $ Just ["h2", "http/1.1"] } } serverParam' = serverParam { serverHooks = (serverHooks serverParam) - { onSuggestNextProtocols = return $ Just [C8.pack "spdy/2", C8.pack "http/1.1"] } + { onALPNClientSuggest = Just alpn } } params' = (clientParam',serverParam') runTLSPipe params' tlsServer tlsClient where tlsServer ctx queue = do handshake ctx proto <- getNegotiatedProtocol ctx - Just (C8.pack "spdy/2") `assertEq` proto + Just "h2" `assertEq` proto d <- recvDataNonNull ctx writeChan queue d return () tlsClient queue ctx = do handshake ctx proto <- getNegotiatedProtocol ctx - Just (C8.pack "spdy/2") `assertEq` proto + Just "h2" `assertEq` proto d <- readChan queue sendData ctx (L.fromChunks [d]) bye ctx return () + alpn xs + | "h2" `elem` xs = return "h2" + | otherwise = return "http/1.1" -prop_handshake_renegociation :: PropertyM IO () -prop_handshake_renegociation = do +prop_handshake_sni :: PropertyM IO () +prop_handshake_sni = do + (clientParam,serverParam) <- pick arbitraryPairParams + let clientParam' = clientParam { clientServerIdentification = (serverName, "") + , clientUseServerNameIndication = True + } + params' = (clientParam',serverParam) + runTLSPipe params' tlsServer tlsClient + where tlsServer ctx queue = do + handshake ctx + sni <- getClientSNI ctx + Just serverName `assertEq` sni + d <- recvDataNonNull ctx + writeChan queue d + return () + tlsClient queue ctx = do + handshake ctx + d <- readChan queue + sendData ctx (L.fromChunks [d]) + bye ctx + return () + serverName = "haskell.org" + +prop_handshake_renegotiation :: PropertyM IO () +prop_handshake_renegotiation = do (cparams, sparams) <- pick arbitraryPairParams let sparams' = sparams { serverSupported = (serverSupported sparams) { @@ -178,19 +278,6 @@ bye ctx return () --- | simple session manager to store one session id and session data for a single thread. --- a Real concurrent session manager would use an MVar and have multiples items. -oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager -oneSessionManager ref = SessionManager - { sessionResume = \myId -> (>>= maybeResume myId) <$> readIORef ref - , sessionEstablish = \myId dat -> writeIORef ref $ Just (myId, dat) - , sessionInvalidate = \_ -> return () - } - where - maybeResume myId (sid, sdata) - | sid == myId = Just sdata - | otherwise = Nothing - prop_handshake_session_resumption :: PropertyM IO () prop_handshake_session_resumption = do sessionRef <- run $ newIORef Nothing @@ -231,11 +318,15 @@ -- high level tests between a client and server with fake ciphers. tests_handshake = testGroup "Handshakes" - [ testProperty "setup" (monadicIO prop_pipe_work) - , testProperty "initiate" (monadicIO prop_handshake_initiate) - , testProperty "initiate TLS12" (monadicIO prop_handshake_initiate_tls12) - , testProperty "clientAuthInitiate" (monadicIO prop_handshake_client_auth_initiate) - , testProperty "npnInitiate" (monadicIO prop_handshake_npn_initiate) - , testProperty "renegociation" (monadicIO prop_handshake_renegociation) - , testProperty "resumption" (monadicIO prop_handshake_session_resumption) + [ testProperty "Setup" (monadicIO prop_pipe_work) + , testProperty "Initiation" (monadicIO prop_handshake_initiate) + , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures) + , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites) + , testProperty "Groups" (monadicIO prop_handshake_groups) + , testProperty "Certificate fallback" (monadicIO prop_handshake_cert_fallback) + , testProperty "Client authentication" (monadicIO prop_handshake_client_auth) + , testProperty "ALPN" (monadicIO prop_handshake_alpn) + , testProperty "SNI" (monadicIO prop_handshake_sni) + , testProperty "Renegotiation" (monadicIO prop_handshake_renegotiation) + , testProperty "Resumption" (monadicIO prop_handshake_session_resumption) ] diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,5 +1,5 @@ Name: tls -version: 1.3.11 +Version: 1.4.0 Description: Native Haskell TLS and SSL protocol implementation for server and client. . @@ -48,11 +48,11 @@ , data-default-class -- crypto related , memory >= 0.14.6 - , cryptonite >= 0.21 + , cryptonite >= 0.24 -- certificate related , asn1-types >= 0.2.0 , asn1-encoding - , x509 >= 1.6.5 + , x509 >= 1.7.1 , x509-store >= 1.6 , x509-validation >= 1.6.5 , async >= 2.0 @@ -78,10 +78,10 @@ Network.TLS.Backend Network.TLS.Crypto Network.TLS.Crypto.DH - Network.TLS.Crypto.ECDH + Network.TLS.Crypto.IES + Network.TLS.Crypto.Types Network.TLS.ErrT Network.TLS.Extension - Network.TLS.Extension.EC Network.TLS.Handshake Network.TLS.Handshake.Common Network.TLS.Handshake.Certificate @@ -114,7 +114,7 @@ Network.TLS.Types Network.TLS.Wire Network.TLS.X509 - ghc-options: -Wall -fwarn-tabs -fno-warn-unused-imports + ghc-options: -Wall if flag(compat) cpp-options: -DSSLV2_COMPATIBLE @@ -138,10 +138,11 @@ , QuickCheck , cryptonite , bytestring + , asn1-types , x509 , x509-validation , hourglass - ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -fwarn-tabs + ghc-options: -Wall -fno-warn-unused-imports Benchmark bench-tls hs-source-dirs: Benchmarks Tests @@ -156,10 +157,12 @@ , criterion >= 1.0 , mtl , bytestring + , asn1-types , hourglass , QuickCheck >= 2 , tasty-quickcheck , tls + ghc-options: -Wall -fno-warn-unused-imports source-repository head type: git