tls 1.3.11 → 1.4.0
raw patch · 48 files changed
+1449/−1177 lines, 48 filesdep ~asn1-typesdep ~cryptonitedep ~x509
Dependency ranges changed: asn1-types, cryptonite, x509
Files
- Benchmarks/Benchmarks.hs +61/−6
- CHANGELOG.md +56/−0
- Network/TLS.hs +9/−3
- Network/TLS/Cap.hs +1/−1
- Network/TLS/Context.hs +1/−41
- Network/TLS/Context/Internal.hs +6/−8
- Network/TLS/Core.hs +9/−14
- Network/TLS/Credentials.hs +65/−20
- Network/TLS/Crypto.hs +53/−11
- Network/TLS/Crypto/DH.hs +7/−1
- Network/TLS/Crypto/ECDH.hs +0/−76
- Network/TLS/Crypto/IES.hs +182/−0
- Network/TLS/Crypto/Types.hs +20/−0
- Network/TLS/Extension.hs +13/−65
- Network/TLS/Extension/EC.hs +0/−67
- Network/TLS/Extra/Cipher.hs +68/−153
- Network/TLS/Handshake.hs +16/−7
- Network/TLS/Handshake/Certificate.hs +1/−1
- Network/TLS/Handshake/Client.hs +31/−56
- Network/TLS/Handshake/Common.hs +12/−10
- Network/TLS/Handshake/Key.hs +13/−9
- Network/TLS/Handshake/Process.hs +13/−13
- Network/TLS/Handshake/Server.hs +180/−99
- Network/TLS/Handshake/Signature.hs +105/−107
- Network/TLS/Handshake/State.hs +14/−13
- Network/TLS/IO.hs +37/−26
- Network/TLS/Imports.hs +5/−7
- Network/TLS/MAC.hs +1/−1
- Network/TLS/Packet.hs +45/−89
- Network/TLS/Parameters.hs +22/−11
- Network/TLS/Receiving.hs +1/−3
- Network/TLS/Record/Disengage.hs +3/−3
- Network/TLS/Record/Engage.hs +1/−1
- Network/TLS/Record/State.hs +7/−6
- Network/TLS/Record/Types.hs +10/−9
- Network/TLS/Sending.hs +1/−1
- Network/TLS/State.hs +11/−40
- Network/TLS/Struct.hs +66/−31
- Network/TLS/Types.hs +7/−3
- Network/TLS/Util.hs +8/−9
- Network/TLS/Wire.hs +17/−16
- Tests/Certificate.hs +13/−5
- Tests/Ciphers.hs +2/−0
- Tests/Connection.hs +92/−80
- Tests/Marshalling.hs +2/−1
- Tests/PipeChan.hs +14/−0
- Tests/Tests.hs +138/−47
- tls.cabal +10/−7
Benchmarks/Benchmarks.hs view
@@ -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" ] ]
CHANGELOG.md view
@@ -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
Network/TLS.hs view
@@ -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
Network/TLS/Cap.hs view
@@ -11,7 +11,7 @@ , hasExplicitBlockIV ) where -import Network.TLS.Struct+import Network.TLS.Types hasHelloExtensions, hasExplicitBlockIV :: Version -> Bool
Network/TLS/Context.hs view
@@ -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
Network/TLS/Context/Internal.hs view
@@ -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
Network/TLS/Core.hs view
@@ -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
Network/TLS/Credentials.hs view
@@ -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
Network/TLS/Crypto.hs view
@@ -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
Network/TLS/Crypto/DH.hs view
@@ -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]
− Network/TLS/Crypto/ECDH.hs
@@ -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
+ Network/TLS/Crypto/IES.hs view
@@ -0,0 +1,182 @@+-- |+-- Module : Network.TLS.Crypto.IES+-- License : BSD-style+-- Maintainer : Kazu Yamamoto <kazu@iij.ad.jp>+-- 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
+ Network/TLS/Crypto/Types.hs view
@@ -0,0 +1,20 @@+-- |+-- Module : Network.TLS.Crypto.Types+-- License : BSD-style+-- Maintainer : Kazu Yamamoto <kazu@iij.ad.jp>+-- 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)
Network/TLS/Extension.hs view
@@ -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)
− Network/TLS/Extension/EC.hs
@@ -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
Network/TLS/Extra/Cipher.hs view
@@ -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:- <http://www.thesprawl.org/research/tls-and-ssl-cipher-suites/>---}+-- A list of cipher suite is found from:+-- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4
Network/TLS/Handshake.hs view
@@ -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
Network/TLS/Handshake/Certificate.hs view
@@ -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.
Network/TLS/Handshake/Client.hs view
@@ -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
Network/TLS/Handshake/Common.hs view
@@ -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)
Network/TLS/Handshake/Key.hs view
@@ -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
Network/TLS/Handshake/Process.hs view
@@ -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
Network/TLS/Handshake/Server.hs view
@@ -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]
Network/TLS/Handshake/Signature.hs view
@@ -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
Network/TLS/Handshake/State.hs view
@@ -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
Network/TLS/IO.hs view
@@ -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)
Network/TLS/Imports.hs view
@@ -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)
Network/TLS/MAC.hs view
@@ -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
Network/TLS/Packet.hs view
@@ -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
Network/TLS/Parameters.hs view
@@ -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 }
Network/TLS/Receiving.hs view
@@ -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
Network/TLS/Record/Disengage.hs view
@@ -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
Network/TLS/Record/Engage.hs view
@@ -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
Network/TLS/Record/State.hs view
@@ -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
Network/TLS/Record/Types.hs view
@@ -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
Network/TLS/Sending.hs view
@@ -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
Network/TLS/State.hs view
@@ -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)
Network/TLS/Struct.hs view
@@ -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
Network/TLS/Types.hs view
@@ -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
Network/TLS/Util.hs view
@@ -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
Network/TLS/Wire.hs view
@@ -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
Tests/Certificate.hs view
@@ -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)
Tests/Ciphers.hs view
@@ -1,3 +1,5 @@+-- Disable this warning so we can still test deprecated functionality.+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Ciphers ( propertyBulkFunctional ) where
Tests/Connection.hs view
@@ -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
Tests/Marshalling.hs view
@@ -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 }
Tests/PipeChan.hs view
@@ -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
Tests/Tests.hs view
@@ -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) ]
tls.cabal view
@@ -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