diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +## Version 1.4.1 + +- Enable X25519 in default parameters [#265](https://github.com/vincenthz/hs-tls/pull/265) +- Checking EOF in bye [#262] (https://github.com/vincenthz/hs-tls/pull/262) +- Improving validation in DH key exchange [#256](https://github.com/vincenthz/hs-tls/pull/256) +- Handle TCP reset during handshake [#251](https://github.com/vincenthz/hs-tls/pull/251) +- Accepting hlint suggestions. + ## Version 1.4.0 - Wrap renegotiation failures with HandshakeFailed [#237](https://github.com/vincenthz/hs-tls/pull/237) diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -15,6 +15,7 @@ , ServerParams(..) , DebugParams(..) , DHParams + , DHPublic , ClientHooks(..) , ServerHooks(..) , Supported(..) @@ -23,6 +24,7 @@ , Handshake , Logging(..) , Measurement(..) + , GroupUsage(..) , CertificateUsage(..) , CertificateRejectReason(..) , defaultParamsClient @@ -137,7 +139,7 @@ , AlertDescription(..) , ClientRandom(..), ServerRandom(..) , Handshake) -import Network.TLS.Crypto (KxError(..), DHParams, Group(..)) +import Network.TLS.Crypto (KxError(..), DHParams, DHPublic, Group(..)) import Network.TLS.Cipher import Network.TLS.Hooks import Network.TLS.Measurement diff --git a/Network/TLS/Backend.hs b/Network/TLS/Backend.hs --- a/Network/TLS/Backend.hs +++ b/Network/TLS/Backend.hs @@ -21,12 +21,11 @@ , Backend(..) ) where -import Data.ByteString (ByteString) +import Network.TLS.Imports import qualified Data.ByteString as B import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush, hClose) #ifdef INCLUDE_NETWORK -import Control.Monad import qualified Network.Socket as Network (Socket, close) import qualified Network.Socket.ByteString as Network #endif @@ -73,7 +72,7 @@ instance HasBackend Network.Socket where initializeBackend _ = return () getBackend sock = Backend (return ()) (Network.close sock) (Network.sendAll sock) recvAll - where recvAll n = B.concat `fmap` loop n + where recvAll n = B.concat <$> loop n where loop 0 = return [] loop left = do r <- safeRecv sock left @@ -87,7 +86,7 @@ initializeBackend _ = return () getBackend sock = Backend (return ()) (Hans.close sock) sendAll recvAll where sendAll x = do - amt <- fromIntegral `fmap` Hans.sendBytes sock (L.fromStrict x) + amt <- fromIntegral <$> Hans.sendBytes sock (L.fromStrict x) if (amt == 0) || (amt == B.length x) then return () else sendAll (B.drop amt x) diff --git a/Network/TLS/Cipher.hs b/Network/TLS/Cipher.hs --- a/Network/TLS/Cipher.hs +++ b/Network/TLS/Cipher.hs @@ -53,7 +53,7 @@ show (BulkStateStream _) = "BulkStateStream" show (BulkStateBlock _) = "BulkStateBlock" show (BulkStateAEAD _) = "BulkStateAEAD" - show (BulkStateUninitialized) = "BulkStateUninitialized" + show BulkStateUninitialized = "BulkStateUninitialized" newtype BulkStream = BulkStream (B.ByteString -> (B.ByteString, BulkStream)) diff --git a/Network/TLS/Compression.hs b/Network/TLS/Compression.hs --- a/Network/TLS/Compression.hs +++ b/Network/TLS/Compression.hs @@ -23,9 +23,8 @@ , compressionIntersectID ) where -import Data.Word import Network.TLS.Types (CompressionID) -import Data.ByteString (ByteString) +import Network.TLS.Imports import Control.Arrow (first) -- | supported compression algorithms need to be part of this class @@ -60,7 +59,7 @@ -- the function keeps the list of compression in order, to be able to find quickly the prefered -- compression. compressionIntersectID :: [Compression] -> [Word8] -> [Compression] -compressionIntersectID l ids = filter (\c -> elem (compressionID c) ids) l +compressionIntersectID l ids = filter (\c -> compressionID c `elem` ids) l -- | This is the default compression which is a NOOP. data NullCompression = NullCompression diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -121,7 +121,7 @@ seed <- case debugSeed debug of Nothing -> do seed <- seedNew - debugPrintSeed debug $ seed + debugPrintSeed debug seed return seed Just determ -> return determ let rng = newStateRNG seed @@ -145,7 +145,7 @@ lockRead <- newMVar () lockState <- newMVar () - return $ Context + return Context { ctxConnection = getBackend backend , ctxShared = shared , ctxSupported = supported diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs --- a/Network/TLS/Context/Internal.hs +++ b/Network/TLS/Context/Internal.hs @@ -65,7 +65,7 @@ import Network.TLS.Record.State import Network.TLS.Parameters import Network.TLS.Measurement -import Data.ByteString (ByteString) +import Network.TLS.Imports import qualified Data.ByteString as B import Control.Concurrent.MVar @@ -195,7 +195,7 @@ usingHState ctx f = liftIO $ modifyMVar (ctxHandshake ctx) $ \mst -> case mst of Nothing -> throwCore $ Error_Misc "missing handshake" - Just st -> return $ swap (Just `fmap` runHandshake st f) + Just st -> return $ swap (Just <$> runHandshake st f) getHState :: Context -> IO (Maybe HandshakeState) getHState ctx = liftIO $ readMVar (ctxHandshake ctx) diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -39,7 +39,6 @@ import Network.TLS.Util (catchException) import qualified Network.TLS.State as S import qualified Data.ByteString as B -import Data.ByteString.Char8 () import qualified Data.ByteString.Lazy as L import qualified Control.Exception as E @@ -52,7 +51,9 @@ -- -- this doesn't actually close the handle bye :: MonadIO m => Context -> m () -bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] +bye ctx = do + eof <- liftIO $ ctxEOF ctx + unless eof $ sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] -- | If the ALPN extensions have been used, this will -- return get the protocol agreed upon. @@ -92,7 +93,7 @@ onError err = terminate err AlertLevel_Fatal InternalError (show err) - process (Handshake [ch@(ClientHello {})]) = + process (Handshake [ch@ClientHello{}]) = handshakeWith ctx ch >> recvData ctx process (Handshake [hr@HelloRequest]) = handshakeWith ctx hr >> recvData ctx diff --git a/Network/TLS/Credentials.hs b/Network/TLS/Credentials.hs --- a/Network/TLS/Credentials.hs +++ b/Network/TLS/Credentials.hs @@ -5,6 +5,7 @@ -- Stability : experimental -- Portability : unknown -- +{-# LANGUAGE CPP #-} module Network.TLS.Credentials ( Credential , Credentials(..) @@ -19,12 +20,9 @@ , credentialMatchesHashSignatures ) where -import Data.ByteString (ByteString) -import Data.Monoid -import Data.Maybe (catMaybes) -import Data.List (find) import Network.TLS.Crypto import Network.TLS.X509 +import Network.TLS.Imports import Data.X509.File import Data.X509.Memory import Data.X509 @@ -36,9 +34,16 @@ newtype Credentials = Credentials [Credential] +#if MIN_VERSION_base(4,9,0) +instance Semigroup Credentials where + Credentials l1 <> Credentials l2 = Credentials (l1 ++ l2) +#endif + instance Monoid Credentials where mempty = Credentials [] +#if !(MIN_VERSION_base(4,11,0)) mappend (Credentials l1) (Credentials l2) = Credentials (l1 ++ l2) +#endif -- | try to create a new credential object from a public certificate -- and the associated private key that are stored on the filesystem @@ -86,7 +91,7 @@ (k:_) -> Right (CertificateChain . concat $ x509 : chains, k) credentialsListSigningAlgorithms :: Credentials -> [DigitalSignatureAlg] -credentialsListSigningAlgorithms (Credentials l) = catMaybes $ map credentialCanSign l +credentialsListSigningAlgorithms (Credentials l) = mapMaybe credentialCanSign l credentialsFindForSigning :: DigitalSignatureAlg -> Credentials -> Maybe Credential credentialsFindForSigning sigAlg (Credentials l) = find forSigning l diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -26,6 +26,7 @@ , PrivateKey , SignatureParams(..) , findDigitalSignatureAlg + , findFiniteFieldGroup , kxEncrypt , kxDecrypt , kxSign @@ -37,8 +38,8 @@ import qualified Crypto.Hash as H import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert) -import Data.ByteString (ByteString) import Crypto.Random +import qualified Crypto.PubKey.DH as DH import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Prim as ECC @@ -52,11 +53,11 @@ import Network.TLS.Crypto.DH import Network.TLS.Crypto.IES import Network.TLS.Crypto.Types +import Network.TLS.Imports import Data.ASN1.Types import Data.ASN1.Encoding import Data.ASN1.BinaryEncoding (DER(..), BER(..)) -import Data.List (find) {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey @@ -76,6 +77,15 @@ --(PubKeyECDSA _, PrivKeyECDSA _) -> Just ECDSA _ -> Nothing +findFiniteFieldGroup :: DH.Params -> Maybe Group +findFiniteFieldGroup params = lookup (pg params) table + where + pg (DH.Params p g _) = (p, g) + + table = [ (pg prms, grp) | grp <- availableFFGroups + , let Just prms = dhParamsForGroup grp + ] + -- functions to use the hidden class. hashInit :: Hash -> HashContext hashInit MD5 = HashContext $ ContextSimple (H.hashInit :: H.Context H.MD5) @@ -160,11 +170,11 @@ generalizeRSAError (Right x) = Right x kxEncrypt :: MonadRandom r => PublicKey -> ByteString -> r (Either KxError ByteString) -kxEncrypt (PubKeyRSA pk) b = generalizeRSAError `fmap` RSA.encrypt pk b +kxEncrypt (PubKeyRSA pk) b = generalizeRSAError <$> RSA.encrypt pk b kxEncrypt _ _ = return (Left KxUnsupported) kxDecrypt :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString) -kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError `fmap` RSA.decryptSafer pk b +kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError <$> RSA.decryptSafer pk b kxDecrypt _ _ = return (Left KxUnsupported) data RSAEncoding = RSApkcs1 | RSApss deriving (Show,Eq) @@ -198,10 +208,10 @@ Right asn1 -> case asn1 of Start Sequence:IntVal r:IntVal s:End Sequence:_ -> - Just $ DSA.Signature { DSA.sign_r = r, DSA.sign_s = s } + Just DSA.Signature { DSA.sign_r = r, DSA.sign_s = s } _ -> Nothing -kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = maybe False id $ do +kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = fromMaybe False $ do -- get the curve name and the public key data (curveName, pubBS) <- case key of PubKeyEC_Named curveName' pub -> Just (curveName',pub) @@ -264,9 +274,9 @@ -> ByteString -> r (Either KxError ByteString) kxSign (PrivKeyRSA pk) (RSAParams hashAlg RSApkcs1) msg = - generalizeRSAError `fmap` rsaSignHash hashAlg pk msg + generalizeRSAError <$> rsaSignHash hashAlg pk msg kxSign (PrivKeyRSA pk) (RSAParams hashAlg RSApss) msg = - generalizeRSAError `fmap` rsapssSignHash hashAlg pk msg + generalizeRSAError <$> rsapssSignHash hashAlg pk msg kxSign (PrivKeyDSA pk) DSSParams msg = do sign <- DSA.sign pk H.SHA1 msg return (Right $ encodeASN1' DER $ dsaSequence sign) diff --git a/Network/TLS/Crypto/DH.hs b/Network/TLS/Crypto/DH.hs --- a/Network/TLS/Crypto/DH.hs +++ b/Network/TLS/Crypto/DH.hs @@ -4,6 +4,7 @@ DHParams , DHPublic , DHPrivate + , DHKey -- * DH methods , dhPublic @@ -13,6 +14,7 @@ , dhParamsGetG , dhGenerateKeyPair , dhGetShared + , dhValid , dhUnwrap , dhUnwrapPublic ) where @@ -39,7 +41,7 @@ dhGenerateKeyPair :: MonadRandom r => DHParams -> r (DHPrivate, DHPublic) dhGenerateKeyPair params = do priv <- DH.generatePrivate params - let pub = DH.generatePublic params priv + let pub = DH.calculatePublic params priv return (priv, pub) dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey @@ -49,6 +51,12 @@ -- 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) + +-- Check that group element in not in the 2-element subgroup { 1, p - 1 }. +-- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1. +-- This verification is enough when using a safe prime. +dhValid :: DHParams -> Integer -> Bool +dhValid (DH.Params p _ _) y = 1 < y && y < p - 1 dhUnwrap :: DHParams -> DHPublic -> [Integer] dhUnwrap (DH.Params p g _) (DH.PublicNumber y) = [p,g,y] diff --git a/Network/TLS/Crypto/IES.hs b/Network/TLS/Crypto/IES.hs --- a/Network/TLS/Crypto/IES.hs +++ b/Network/TLS/Crypto/IES.hs @@ -16,13 +16,19 @@ , groupGetShared , encodeGroupPublic , decodeGroupPublic + -- * Compatibility with 'Network.TLS.Crypto.DH' + , dhParamsForGroup + , dhGroupGenerateKeyPair + , dhGroupGetPubShared ) where import Control.Arrow import Crypto.ECC import Crypto.Error -import Crypto.PubKey.DH +import Crypto.Number.Generate +import Crypto.PubKey.DH hiding (generateParams) import Crypto.PubKey.ECIES +import qualified Data.ByteArray as B import Data.Proxy import Network.TLS.Crypto.Types import Network.TLS.Extra.FFDHE @@ -71,6 +77,14 @@ x448 :: Proxy Curve_X448 x448 = Proxy +dhParamsForGroup :: Group -> Maybe Params +dhParamsForGroup FFDHE2048 = Just ffdhe2048 +dhParamsForGroup FFDHE3072 = Just ffdhe3072 +dhParamsForGroup FFDHE4096 = Just ffdhe4096 +dhParamsForGroup FFDHE6144 = Just ffdhe6144 +dhParamsForGroup FFDHE8192 = Just ffdhe8192 +dhParamsForGroup _ = Nothing + groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublic) groupGenerateKeyPair P256 = (GroupPri_P256,GroupPub_P256) `fs` curveGenerateKeyPair p256 @@ -82,12 +96,23 @@ (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 +groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPub_FFDHE2048 +groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPub_FFDHE3072 +groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPub_FFDHE4096 +groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPub_FFDHE6144 +groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPub_FFDHE8192 +dhGroupGenerateKeyPair :: MonadRandom r => Group -> r (Params, PrivateNumber, PublicNumber) +dhGroupGenerateKeyPair FFDHE2048 = addParams ffdhe2048 (gen' ffdhe2048 exp2048) +dhGroupGenerateKeyPair FFDHE3072 = addParams ffdhe3072 (gen' ffdhe3072 exp3072) +dhGroupGenerateKeyPair FFDHE4096 = addParams ffdhe4096 (gen' ffdhe4096 exp4096) +dhGroupGenerateKeyPair FFDHE6144 = addParams ffdhe6144 (gen' ffdhe6144 exp6144) +dhGroupGenerateKeyPair FFDHE8192 = addParams ffdhe8192 (gen' ffdhe8192 exp8192) +dhGroupGenerateKeyPair grp = error ("invalid FFDHE group: " ++ show grp) + +addParams :: Functor f => Params -> f (a, b) -> f (Params, a, b) +addParams params = fmap $ \(a, b) -> (params, a, b) + fs :: MonadRandom r => (Scalar a -> GroupPrivate, Point a -> GroupPublic) -> r (KeyPair a) @@ -100,14 +125,18 @@ gen :: MonadRandom r => Params + -> Int -> (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) +gen params expBits priTag pubTag = (priTag *** pubTag) <$> gen' params expBits +gen' :: MonadRandom r + => Params + -> Int + -> r (PrivateNumber, PublicNumber) +gen' params expBits = (id &&& calculatePublic params) <$> generatePriv expBits + groupGetPubShared :: MonadRandom r => GroupPublic -> r (Maybe (GroupPublic, GroupKey)) groupGetPubShared (GroupPub_P256 pub) = fmap (first GroupPub_P256) . maybeCryptoError <$> deriveEncrypt p256 pub @@ -119,38 +148,62 @@ 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 +groupGetPubShared (GroupPub_FFDHE2048 pub) = getPubShared ffdhe2048 exp2048 pub GroupPub_FFDHE2048 +groupGetPubShared (GroupPub_FFDHE3072 pub) = getPubShared ffdhe3072 exp3072 pub GroupPub_FFDHE3072 +groupGetPubShared (GroupPub_FFDHE4096 pub) = getPubShared ffdhe4096 exp4096 pub GroupPub_FFDHE4096 +groupGetPubShared (GroupPub_FFDHE6144 pub) = getPubShared ffdhe6144 exp6144 pub GroupPub_FFDHE6144 +groupGetPubShared (GroupPub_FFDHE8192 pub) = getPubShared ffdhe8192 exp8192 pub GroupPub_FFDHE8192 +dhGroupGetPubShared :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, SharedKey)) +dhGroupGetPubShared FFDHE2048 pub = getPubShared' ffdhe2048 exp2048 pub +dhGroupGetPubShared FFDHE3072 pub = getPubShared' ffdhe3072 exp3072 pub +dhGroupGetPubShared FFDHE4096 pub = getPubShared' ffdhe4096 exp4096 pub +dhGroupGetPubShared FFDHE6144 pub = getPubShared' ffdhe6144 exp6144 pub +dhGroupGetPubShared FFDHE8192 pub = getPubShared' ffdhe8192 exp8192 pub +dhGroupGetPubShared _ _ = return Nothing + getPubShared :: MonadRandom r => Params + -> Int -> PublicNumber -> (PublicNumber -> GroupPublic) -> r (Maybe (GroupPublic, GroupKey)) -getPubShared params pub pubTag = do - mypri <- generatePrivate params +getPubShared params expBits pub pubTag | not (valid params pub) = return Nothing + | otherwise = do + mypri <- generatePriv expBits let mypub = calculatePublic params mypri let SharedKey share = getShared params mypri pub return $ Just (pubTag mypub, SharedSecret share) +getPubShared' :: MonadRandom r + => Params + -> Int + -> PublicNumber + -> r (Maybe (PublicNumber, SharedKey)) +getPubShared' params expBits pub + | not (valid params pub) = return Nothing + | otherwise = do + mypri <- generatePriv expBits + let share = stripLeadingZeros (getShared params mypri pub) + return $ Just (calculatePublic params mypri, SharedKey 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 (GroupPub_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcShared ffdhe2048 pub pri +groupGetShared (GroupPub_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcShared ffdhe3072 pub pri +groupGetShared (GroupPub_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcShared ffdhe4096 pub pri +groupGetShared (GroupPub_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcShared ffdhe6144 pub pri +groupGetShared (GroupPub_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcShared ffdhe8192 pub pri groupGetShared _ _ = Nothing -calcShared :: Params -> PublicNumber -> PrivateNumber -> SharedSecret -calcShared params pub pri = SharedSecret share +calcShared :: Params -> PublicNumber -> PrivateNumber -> Maybe SharedSecret +calcShared params pub pri + | valid params pub = Just $ SharedSecret share + | otherwise = Nothing where SharedKey share = getShared params pri pub @@ -180,3 +233,31 @@ 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 + +-- Check that group element in not in the 2-element subgroup { 1, p - 1 }. +-- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1. +valid :: Params -> PublicNumber -> Bool +valid (Params p _ _) (PublicNumber y) = 1 < y && y < p - 1 + +-- strips leading zeros from the result of getShared, as required +-- for DH(E) premaster secret in SSL/TLS before version 1.3. +stripLeadingZeros :: SharedKey -> B.ScrubbedBytes +stripLeadingZeros (SharedKey sb) = snd $ B.span (== 0) sb + +-- Use short exponents as optimization, see RFC 7919 section 5.2. +generatePriv :: MonadRandom r => Int -> r PrivateNumber +generatePriv e = PrivateNumber <$> generateParams e (Just SetHighest) False + +-- Short exponent bit sizes from RFC 7919 appendix A, rounded to next +-- multiple of 16 bits, i.e. going through a function like: +-- let shortExp n = head [ e | i <- [1..], let e = n + i, e `mod` 16 == 0 ] +exp2048 :: Int +exp3072 :: Int +exp4096 :: Int +exp6144 :: Int +exp8192 :: Int +exp2048 = 240 -- shortExp 225 +exp3072 = 288 -- shortExp 275 +exp4096 = 336 -- shortExp 325 +exp6144 = 384 -- shortExp 375 +exp8192 = 416 -- shortExp 400 diff --git a/Network/TLS/Crypto/Types.hs b/Network/TLS/Crypto/Types.hs --- a/Network/TLS/Crypto/Types.hs +++ b/Network/TLS/Crypto/Types.hs @@ -11,8 +11,14 @@ | FFDHE2048 | FFDHE3072 | FFDHE4096 | FFDHE6144 | FFDHE8192 deriving (Eq, Show) +availableFFGroups :: [Group] +availableFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192] + +availableECGroups :: [Group] +availableECGroups = [P256,P384,P521,X25519,X448] + availableGroups :: [Group] -availableGroups = [P256,P384,P521,X25519,X448] +availableGroups = availableECGroups ++ availableFFGroups -- Digital signature algorithm, in close relation to public/private key types -- and cipher key exchange. diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -37,11 +37,6 @@ , SignatureAlgorithms(..) ) where -import Control.Monad - -import Data.Word -import Data.Maybe (fromMaybe, catMaybes) -import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC @@ -157,8 +152,7 @@ -- | Server Name extension including the name type and the associated name. -- the associated name decoding is dependant of its name type. -- name type = 0 : hostname -data ServerName = ServerName [ServerNameType] - deriving (Show,Eq) +newtype ServerName = ServerName [ServerNameType] deriving (Show,Eq) data ServerNameType = ServerNameHostName HostName | ServerNameOther (Word8, ByteString) @@ -169,7 +163,7 @@ extensionEncode (ServerName l) = runPut $ putOpaque16 (runPut $ mapM_ encodeNameType l) where encodeNameType (ServerNameHostName hn) = putWord8 0 >> putOpaque16 (BC.pack hn) -- FIXME: should be puny code conversion encodeNameType (ServerNameOther (nt,opaque)) = putWord8 nt >> putBytes opaque - extensionDecode _ = runGetMaybe (getWord16 >>= \len -> getList (fromIntegral len) getServerName >>= return . ServerName) + extensionDecode _ = runGetMaybe (getWord16 >>= \len -> ServerName <$> getList (fromIntegral len) getServerName) where getServerName = do ty <- getWord8 sname <- getOpaque16 @@ -178,8 +172,7 @@ _ -> ServerNameOther (ty, sname)) -- | Max fragment extension with length from 512 bytes to 4096 bytes -data MaxFragmentLength = MaxFragmentLength MaxFragmentEnum - deriving (Show,Eq) +newtype MaxFragmentLength = MaxFragmentLength MaxFragmentEnum deriving (Show,Eq) data MaxFragmentEnum = MaxFragment512 | MaxFragment1024 | MaxFragment2048 | MaxFragment4096 deriving (Show,Eq) @@ -213,8 +206,7 @@ else return $ SecureRenegotiation opaque Nothing -- | Application Layer Protocol Negotiation (ALPN) -data ApplicationLayerProtocolNegotiation = ApplicationLayerProtocolNegotiation [ByteString] - deriving (Show,Eq) +newtype ApplicationLayerProtocolNegotiation = ApplicationLayerProtocolNegotiation [ByteString] deriving (Show,Eq) instance Extension ApplicationLayerProtocolNegotiation where extensionID _ = extensionID_ApplicationLayerProtocolNegotiation @@ -231,17 +223,15 @@ _ -> (:) <$> getOpaque8 <*> getALPN' -data NegotiatedGroups = NegotiatedGroups [Group] - deriving (Show,Eq) +newtype NegotiatedGroups = NegotiatedGroups [Group] deriving (Show,Eq) -- on decode, filter all unknown curves instance Extension NegotiatedGroups where extensionID _ = extensionID_NegotiatedGroups extensionEncode (NegotiatedGroups groups) = runPut $ putWords16 $ map fromEnumSafe16 groups - extensionDecode _ = runGetMaybe (NegotiatedGroups . catMaybes . map toEnumSafe16 <$> getWords16) + extensionDecode _ = runGetMaybe (NegotiatedGroups . mapMaybe toEnumSafe16 <$> getWords16) -data EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat] - deriving (Show,Eq) +newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat] deriving (Show,Eq) data EcPointFormat = EcPointFormat_Uncompressed @@ -263,18 +253,17 @@ instance Extension EcPointFormatsSupported where extensionID _ = extensionID_EcPointFormats extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEnumSafe8 formats - extensionDecode _ = runGetMaybe (EcPointFormatsSupported . catMaybes . map toEnumSafe8 <$> getWords8) + extensionDecode _ = runGetMaybe (EcPointFormatsSupported . mapMaybe toEnumSafe8 <$> getWords8) data SessionTicket = SessionTicket deriving (Show,Eq) instance Extension SessionTicket where extensionID _ = extensionID_SessionTicket - extensionEncode (SessionTicket {}) = runPut $ return () + extensionEncode SessionTicket{} = runPut $ return () extensionDecode _ = runGetMaybe (return SessionTicket) -data HeartBeat = HeartBeat HeartBeatMode - deriving (Show,Eq) +newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show,Eq) data HeartBeatMode = HeartBeat_PeerAllowedToSend @@ -297,8 +286,7 @@ Just (Just mode) -> Just $ HeartBeat mode _ -> Nothing -data SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] - deriving (Show,Eq) +newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] deriving (Show,Eq) instance Extension SignatureAlgorithms where extensionID _ = extensionID_SignatureAlgorithms diff --git a/Network/TLS/Extra/Cipher.hs b/Network/TLS/Extra/Cipher.hs --- a/Network/TLS/Extra/Cipher.hs +++ b/Network/TLS/Extra/Cipher.hs @@ -56,6 +56,7 @@ import Network.TLS.Types (Version(..)) import Network.TLS.Cipher +import Network.TLS.Imports import Data.Tuple (swap) import Crypto.Cipher.AES @@ -123,7 +124,7 @@ noFail = throwCryptoError makeIV_ :: BlockCipher a => B.ByteString -> IV a -makeIV_ = maybe (error "makeIV_") id . makeIV +makeIV_ = fromMaybe (error "makeIV_") . makeIV tripledes_ede :: BulkDirection -> BulkKey -> BulkBlock tripledes_ede BulkEncrypt key = @@ -134,7 +135,7 @@ in (\iv input -> let output = cbcDecrypt ctx (tripledes_iv iv) input in (output, takelast 8 input)) tripledes_iv :: BulkIV -> IV DES_EDE3 -tripledes_iv iv = maybe (error "tripledes cipher iv internal error") id $ makeIV iv +tripledes_iv iv = fromMaybe (error "tripledes cipher iv internal error") $ makeIV iv rc4 :: BulkDirection -> BulkKey -> BulkStream rc4 _ bulkKey = BulkStream (combineRC4 $ RC4.initialize bulkKey) diff --git a/Network/TLS/Handshake.hs b/Network/TLS/Handshake.hs --- a/Network/TLS/Handshake.hs +++ b/Network/TLS/Handshake.hs @@ -18,29 +18,33 @@ import Network.TLS.Struct import Network.TLS.IO import Network.TLS.Util (catchException) +import Network.TLS.Imports import Network.TLS.Handshake.Common import Network.TLS.Handshake.Client import Network.TLS.Handshake.Server import Control.Monad.State.Strict -import Control.Exception (fromException) +import Control.Exception (IOException, catch, 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 ctx $ withRWLock ctx (ctxDoHandshake ctx $ ctx) + 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) + 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 + let tlserror = fromMaybe (Error_Misc $ show exception) $ fromException exception setEstablished ctx False - sendPacket ctx (errorToAlert tlserror) + sendPacket ctx (errorToAlert tlserror) `catch` ignoreIOErr handshakeFailed tlserror + where + ignoreIOErr :: IOException -> IO () + ignoreIOErr _ = return () diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -28,10 +28,7 @@ import Network.TLS.Util (bytesEq, catchException) import Network.TLS.Types import Network.TLS.X509 -import Data.Maybe -import Data.List (find, intersect) import qualified Data.ByteString as B -import Data.ByteString.Char8 () import Control.Monad.State.Strict import Control.Exception (SomeException) @@ -66,7 +63,7 @@ getExtensions = sequence [sniExtension ,secureReneg ,alpnExtension - ,curveExtension + ,groupExtension ,ecPointExtension --,sessionTicketExtension ,signatureAlgExtension @@ -93,7 +90,7 @@ return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] else return Nothing - curveExtension = return $ Just $ toExtensionRaw $ NegotiatedGroups ((supportedGroups $ ctxSupported ctx) `intersect` availableGroups) + groupExtension = return $ Just $ toExtensionRaw $ NegotiatedGroups (supportedGroups $ ctxSupported ctx) ecPointExtension = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed] --[EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2] --heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend @@ -102,8 +99,8 @@ signatureAlgExtension = return $ Just $ toExtensionRaw $ SignatureAlgorithms $ supportedHashSignatures $ clientSupported cparams sendClientHello = do - crand <- getStateRNG ctx 32 >>= return . ClientRandom - let clientSession = Session . maybe Nothing (Just . fst) $ clientWantSessionResume cparams + crand <- ClientRandom <$> getStateRNG ctx 32 + let clientSession = Session . (fst <$>) $ clientWantSessionResume cparams highestVer = maximum $ supportedVersions $ ctxSupported ctx extensions <- catMaybes <$> getExtensions startHandshake ctx highestVer crand @@ -193,11 +190,30 @@ where getCKX_DHE = do xver <- usingState_ ctx getVersion serverParams <- usingHState ctx getServerDHParams - (clientDHPriv, clientDHPub) <- generateDHE ctx (serverDHParamsToParams serverParams) - let premaster = dhGetShared (serverDHParamsToParams serverParams) - clientDHPriv - (serverDHParamsToPublic serverParams) + let params = serverDHParamsToParams serverParams + ffGroup = findFiniteFieldGroup params + srvpub = serverDHParamsToPublic serverParams + + (clientDHPub, premaster) <- + case ffGroup of + Nothing -> do + groupUsage <- (onCustomFFDHEGroup $ clientHooks cparams) params srvpub `catchException` + throwMiscErrorOnException "custom group callback failed" + case groupUsage of + GroupUsageInsecure -> throwCore $ Error_Protocol ("FFDHE group is not secure enough", True, InsufficientSecurity) + GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason, True, HandshakeFailure) + GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure) + GroupUsageValid -> do + (clientDHPriv, clientDHPub) <- generateDHE ctx params + let premaster = dhGetShared params clientDHPriv srvpub + return (clientDHPub, premaster) + Just grp -> do + dhePair <- generateFFDHEShared ctx grp srvpub + case dhePair of + Nothing -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure) + Just pair -> return pair + usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster return $ CKX_DH clientDHPub @@ -227,33 +243,30 @@ -- Only send a certificate verify message when we -- have sent a non-empty list of certificates. -- - certSent <- usingHState ctx $ getClientCertSent - case certSent of - True -> do - sigAlg <- getLocalSignatureAlg - - mhashSig <- case usedVersion of - TLS12 -> do - Just (_, Just hashSigs, _) <- usingHState ctx $ getClientCertRequest - -- The values in the "signature_algorithms" extension - -- are in descending order of preference. - -- However here the algorithms are selected according - -- to client preference in 'supportedHashSignatures'. - let suppHashSigs = supportedHashSignatures $ ctxSupported ctx - matchHashSigs = filter (sigAlg `signatureCompatible`) suppHashSigs - hashSigs' = filter (\ a -> a `elem` hashSigs) matchHashSigs + certSent <- usingHState ctx getClientCertSent + when certSent $ do + sigAlg <- getLocalSignatureAlg - when (null hashSigs') $ - throwCore $ Error_Protocol ("no " ++ show sigAlg ++ " hash algorithm in common with the server", True, HandshakeFailure) - return $ Just $ head hashSigs' - _ -> return Nothing + mhashSig <- case usedVersion of + TLS12 -> do + Just (_, Just hashSigs, _) <- usingHState ctx getClientCertRequest + -- The values in the "signature_algorithms" extension + -- are in descending order of preference. + -- However here the algorithms are selected according + -- to client preference in 'supportedHashSignatures'. + let suppHashSigs = supportedHashSignatures $ ctxSupported ctx + matchHashSigs = filter (sigAlg `signatureCompatible`) suppHashSigs + hashSigs' = filter (`elem` hashSigs) matchHashSigs - -- Fetch all handshake messages up to now. - msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages - sigDig <- createCertificateVerify ctx usedVersion sigAlg mhashSig msgs - sendPacket ctx $ Handshake [CertVerify sigDig] + when (null hashSigs') $ + throwCore $ Error_Protocol ("no " ++ show sigAlg ++ " hash algorithm in common with the server", True, HandshakeFailure) + return $ Just $ head hashSigs' + _ -> return Nothing - _ -> return () + -- Fetch all handshake messages up to now. + msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages + sigDig <- createCertificateVerify ctx usedVersion sigAlg mhashSig msgs + sendPacket ctx $ Handshake [CertVerify sigDig] getLocalSignatureAlg = do pk <- usingHState ctx getLocalPrivateKey @@ -285,7 +298,7 @@ onServerHello :: Context -> ClientParams -> [ExtensionID] -> Handshake -> IO (RecvState IO) onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) - case find ((==) rver) (supportedVersions $ ctxSupported ctx) of + case find (== rver) (supportedVersions $ ctxSupported ctx) of 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. @@ -298,7 +311,7 @@ -- intersect sent extensions in client and the received extensions from server. -- if server returns extensions that we didn't request, fail. - when (not $ null $ filter (not . flip elem sentExts . (\(ExtensionRaw i _) -> i)) exts) $ + unless (null $ filter (not . flip elem sentExts . (\(ExtensionRaw i _) -> i)) exts) $ throwCore $ Error_Protocol ("spurious extensions received", True, UnsupportedExtension) let resumingSession = @@ -311,11 +324,11 @@ setVersion rver usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg - case extensionDecode False `fmap` (extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts) of + case extensionDecode False <$> extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts of Just (Just (ApplicationLayerProtocolNegotiation [proto])) -> usingState_ ctx $ do mprotos <- getClientALPNSuggest case mprotos of - Just protos -> when (elem proto protos) $ do + Just protos -> when (proto `elem` protos) $ do setExtensionALPN True setNegotiatedProtocol proto _ -> return () @@ -331,7 +344,7 @@ processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) processCertificate cparams ctx (Certificates certs) = do -- run certificate recv hook - ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks $ certs) + ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks certs) -- then run certificate validation usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException case usage of @@ -376,15 +389,15 @@ -- we need to resolve the result. and recall processWithCipher .. (c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c, True, HandshakeFailure) doDHESignature dhparams signature signatureType = do - -- TODO verify DHParams + -- FIXME verify if FF group is one of supported groups verified <- digitallySignDHParamsVerify ctx dhparams signatureType signature - when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature for dhparams " ++ show dhparams, True, HandshakeFailure) + unless 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 + -- FIXME verify if EC group is one of supported groups verified <- digitallySignECDHParamsVerify ctx ecdhparams signatureType signature - when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature for ecdhparams", True, HandshakeFailure) + unless verified $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature for ecdhparams", True, HandshakeFailure) usingHState ctx $ setServerECDHParams ecdhparams processServerKeyExchange ctx p = processCertificateRequest ctx p diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -32,8 +32,7 @@ import Network.TLS.Types import Network.TLS.Cipher import Network.TLS.Util -import Data.List (find) -import Data.ByteString.Char8 (ByteString) +import Network.TLS.Imports import Control.Monad.State.Strict import Control.Exception (throwIO) @@ -45,12 +44,12 @@ errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)] errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)] -unexpected :: String -> Maybe [Char] -> IO a +unexpected :: String -> Maybe String -> IO a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) newSession :: Context -> IO Session newSession ctx - | supportedSession $ ctxSupported ctx = getStateRNG ctx 32 >>= return . Session . Just + | supportedSession $ ctxSupported ctx = Session . Just <$> getStateRNG ctx 32 | otherwise = return $ Session Nothing -- | when a new handshake is done, wrap up & clean up. @@ -117,7 +116,7 @@ onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing runRecvState :: Context -> RecvState IO -> IO () -runRecvState _ (RecvStateDone) = return () +runRecvState _ RecvStateDone = return () runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx runRecvState ctx iniState = recvPacketHandshake ctx >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx @@ -129,7 +128,7 @@ tx <- liftIO $ readMVar (ctxTxState ctx) case mms of Nothing -> return Nothing - Just ms -> return $ Just $ SessionData + Just ms -> return $ Just SessionData { sessionVersion = ver , sessionCipher = cipherID $ fromJust "cipher" $ stCipher tx , sessionCompression = compressionID $ stCompression tx diff --git a/Network/TLS/Handshake/Key.hs b/Network/TLS/Handshake/Key.hs --- a/Network/TLS/Handshake/Key.hs +++ b/Network/TLS/Handshake/Key.hs @@ -15,9 +15,10 @@ , generateDHE , generateECDHE , generateECDHEShared + , generateFFDHE + , generateFFDHEShared ) where -import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Handshake.State @@ -25,6 +26,7 @@ import Network.TLS.Crypto import Network.TLS.Types import Network.TLS.Context.Internal +import Network.TLS.Imports {- if the RSA encryption fails we just return an empty bytestring, and let the protocol - fail by itself; however it would be probably better to just report it since it's an internal problem. @@ -68,3 +70,9 @@ generateECDHEShared :: Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey)) generateECDHEShared ctx pub = usingState_ ctx $ withRNG $ groupGetPubShared pub + +generateFFDHE :: Context -> Group -> IO (DHParams, DHPrivate, DHPublic) +generateFFDHE ctx grp = usingState_ ctx $ withRNG $ dhGroupGenerateKeyPair grp + +generateFFDHEShared :: Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey)) +generateFFDHEShared ctx grp pub = usingState_ ctx $ withRNG $ dhGroupGetPubShared grp pub diff --git a/Network/TLS/Handshake/Process.hs b/Network/TLS/Handshake/Process.hs --- a/Network/TLS/Handshake/Process.hs +++ b/Network/TLS/Handshake/Process.hs @@ -15,7 +15,6 @@ import Control.Concurrent.MVar import Control.Monad.State.Strict (gets) -import Control.Monad import Control.Monad.IO.Class (liftIO) import Network.TLS.Types (Role(..), invertRole) @@ -94,8 +93,12 @@ role <- usingState_ ctx isClientContext serverParams <- usingHState ctx getServerDHParams + let params = serverDHParamsToParams serverParams + unless (dhValid params $ dhUnwrapPublic clientDHValue) $ + throwCore $ Error_Protocol ("invalid client public key", True, HandshakeFailure) + dhpriv <- usingHState ctx getDHPrivate - let premaster = dhGetShared (serverDHParamsToParams serverParams) dhpriv clientDHValue + let premaster = dhGetShared params dhpriv clientDHValue usingHState ctx $ setMasterSecretFromPre rver role premaster processClientKeyXchg ctx (CKX_ECDH bytes) = do diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Handshake.Server -- License : BSD-style @@ -30,17 +29,7 @@ import Network.TLS.Handshake.Process import Network.TLS.Handshake.Key import Network.TLS.Measurement -import Data.Maybe (isJust, listToMaybe, mapMaybe) -import Data.List (findIndex, intersect) import qualified Data.ByteString as B -import Data.ByteString.Char8 () -import Data.Ord (Down(..)) -#if MIN_VERSION_base(4,8,0) -import Data.List (sortOn) -#else -import Data.List (sortBy) -import Data.Ord (comparing) -#endif import Control.Monad.State.Strict @@ -145,16 +134,24 @@ -- negotiated signature parameters. Then ciphers are evalutated from -- the resulting credentials. - let possibleGroups = negotiatedGroupsInCommon ctx exts - hasCommonGroupForECDHE = not (null possibleGroups) + let possibleGroups = negotiatedGroupsInCommon ctx exts + possibleECGroups = possibleGroups `intersect` availableECGroups + possibleFFGroups = possibleGroups `intersect` availableFFGroups + hasCommonGroupForECDHE = not (null possibleECGroups) + hasCommonGroupForFFDHE = not (null possibleFFGroups) + hasCustomGroupForFFDHE = isJust (serverDHEParams sparams) + canFFDHE = hasCustomGroupForFFDHE || hasCommonGroupForFFDHE hasCommonGroup cipher = case cipherKeyExchange cipher of + CipherKeyExchange_DH_Anon -> canFFDHE + CipherKeyExchange_DHE_RSA -> canFFDHE + CipherKeyExchange_DHE_DSS -> canFFDHE CipherKeyExchange_ECDHE_RSA -> hasCommonGroupForECDHE CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE _ -> True -- group not used - -- Ciphers are selected according to TLS version, availability of ECDHE - -- group and credential depending on key exchange. + -- Ciphers are selected according to TLS version, availability of + -- (EC)DHE group and credential depending on key exchange. cipherAllowed cipher = cipherAllowedForVersion chosenVersion cipher && hasCommonGroup cipher selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials) @@ -206,7 +203,7 @@ cred <- case cipherKeyExchange usedCipher of CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds - CipherKeyExchange_DH_Anon -> return $ Nothing + 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 @@ -372,8 +369,17 @@ extractCAname cert = certSubjectDN $ getCertificate cert setup_DHE = do - let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams - (priv, pub) <- generateDHE ctx dhparams + let possibleFFGroups = negotiatedGroupsInCommon ctx exts `intersect` availableFFGroups + (dhparams, priv, pub) <- + case possibleFFGroups of + [] -> + let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams + in case findFiniteFieldGroup dhparams of + Just g -> generateFFDHE ctx g + Nothing -> do + (priv, pub) <- generateDHE ctx dhparams + return (dhparams, priv, pub) + g:_ -> generateFFDHE ctx g let serverParams = serverDHParamsFrom dhparams pub @@ -416,8 +422,8 @@ return serverParams generateSKX_ECDHE sigAlg = do - let possibleGroups = negotiatedGroupsInCommon ctx exts - grp <- case possibleGroups of + let possibleECGroups = negotiatedGroupsInCommon ctx exts `intersect` availableECGroups + grp <- case possibleECGroups of [] -> throwCore $ Error_Protocol ("no common group", True, HandshakeFailure) g:_ -> return g serverParams <- setup_ECDHE grp @@ -485,31 +491,28 @@ verif <- checkCertificateVerify ctx usedVersion sigAlgExpected msgs dsig - case verif of - True -> do - -- When verification succeeds, commit the - -- client certificate chain to the context. - -- - Just certs <- usingHState ctx getClientCertChain - usingState_ ctx $ setClientCertificateChain certs - return () - - False -> do - -- Either verification failed because of an - -- invalid format (with an error message), or - -- the signature is wrong. In either case, - -- ask the application if it wants to - -- proceed, we will do that. - res <- liftIO $ onUnverifiedClientCert (serverHooks sparams) - if res - then do - -- When verification fails, but the - -- application callbacks accepts, we - -- also commit the client certificate - -- chain to the context. - Just certs <- usingHState ctx getClientCertChain - usingState_ ctx $ setClientCertificateChain certs - else throwCore $ Error_Protocol ("verification failed", True, BadCertificate) + if verif then do + -- When verification succeeds, commit the + -- client certificate chain to the context. + -- + Just certs <- usingHState ctx getClientCertChain + usingState_ ctx $ setClientCertificateChain certs + return () + else do + -- Either verification failed because of an + -- invalid format (with an error message), or + -- the signature is wrong. In either case, + -- ask the application if it wants to + -- proceed, we will do that. + res <- liftIO $ onUnverifiedClientCert (serverHooks sparams) + if res then do + -- When verification fails, but the + -- application callbacks accepts, we + -- also commit the client certificate + -- chain to the context. + Just certs <- usingHState ctx getClientCertChain + usingState_ ctx $ setClientCertificateChain certs + else throwCore $ Error_Protocol ("verification failed", True, BadCertificate) return $ RecvStateNext expectChangeCipher processCertificateVerify p = do @@ -529,7 +532,7 @@ _ -> throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure) expectChangeCipher ChangeCipherSpec = do - return $ RecvStateHandshake $ expectFinish + return $ RecvStateHandshake expectFinish expectChangeCipher p = unexpected (show p) (Just "change cipher") @@ -562,7 +565,7 @@ 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 + let serverGroups = supportedGroups (ctxSupported ctx) in serverGroups `intersect` clientGroups _ -> [] @@ -602,9 +605,9 @@ [] -> 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 +-- We filter our allowed ciphers here according to 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). @@ -613,9 +616,9 @@ 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_DH_Anon -> True + CipherKeyExchange_DHE_RSA -> canSignRSA + CipherKeyExchange_DHE_DSS -> canSignDSS CipherKeyExchange_ECDHE_RSA -> canSignRSA -- unimplemented: EC CipherKeyExchange_ECDHE_ECDSA -> False @@ -628,14 +631,7 @@ 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] -sortOn f = - map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) -#endif diff --git a/Network/TLS/Handshake/Signature.hs b/Network/TLS/Handshake/Signature.hs --- a/Network/TLS/Handshake/Signature.hs +++ b/Network/TLS/Handshake/Signature.hs @@ -129,7 +129,7 @@ -> CertVerifyData -> IO DigitallySigned signatureCreateWithCertVerifyData ctx malg (sigParam, toSign) = do - cc <- usingState_ ctx $ isClientContext + cc <- usingState_ ctx isClientContext DigitallySigned malg <$> signPrivate ctx cc sigParam toSign signatureVerify :: Context -> DigitallySigned -> DigitalSignatureAlg -> ByteString -> IO Bool @@ -149,7 +149,7 @@ -> CertVerifyData -> IO Bool signatureVerifyWithCertVerifyData ctx (DigitallySigned _ bs) (sigParam, toVerify) = do - cc <- usingState_ ctx $ isClientContext + cc <- usingState_ ctx isClientContext verifyPublic ctx cc sigParam toVerify bs digitallySignParams :: Context -> ByteString -> DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -> IO DigitallySigned diff --git a/Network/TLS/Handshake/State.hs b/Network/TLS/Handshake/State.hs --- a/Network/TLS/Handshake/State.hs +++ b/Network/TLS/Handshake/State.hs @@ -57,11 +57,10 @@ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Types -import Control.Applicative (Applicative, (<$>)) +import Network.TLS.Imports import Control.Monad.State.Strict import Data.X509 (CertificateChain) import Data.ByteArray (ByteArrayAccess) -import Data.ByteString (ByteString) data HandshakeKeyState = HandshakeKeyState { hksRemotePublicKey :: !(Maybe PubKey) @@ -69,7 +68,7 @@ } deriving (Show) data HandshakeState = HandshakeState - { hstClientVersion :: !(Version) + { hstClientVersion :: !Version , hstClientRandom :: !ClientRandom , hstServerRandom :: !(Maybe ServerRandom) , hstMasterSecret :: !(Maybe ByteString) @@ -99,7 +98,7 @@ instance MonadState HandshakeState HandshakeM where put x = HandshakeM (put x) - get = HandshakeM (get) + get = HandshakeM get #if MIN_VERSION_mtl(2,1,0) state f = HandshakeM (state f) #endif diff --git a/Network/TLS/Hooks.hs b/Network/TLS/Hooks.hs --- a/Network/TLS/Hooks.hs +++ b/Network/TLS/Hooks.hs @@ -28,10 +28,10 @@ defaultLogging :: Logging defaultLogging = Logging - { loggingPacketSent = (\_ -> return ()) - , loggingPacketRecv = (\_ -> return ()) - , loggingIOSent = (\_ -> return ()) - , loggingIORecv = (\_ _ -> return ()) + { loggingPacketSent = \_ -> return () + , loggingPacketRecv = \_ -> return () + , loggingIOSent = \_ -> return () + , loggingIORecv = \_ _ -> return () } instance Default Logging where @@ -49,7 +49,7 @@ defaultHooks :: Hooks defaultHooks = Hooks - { hookRecvHandshake = \hs -> return hs + { hookRecvHandshake = return , hookRecvCertificates = return . const () , hookLogging = def } diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -19,8 +19,8 @@ import Network.TLS.Hooks import Network.TLS.Sending import Network.TLS.Receiving +import Network.TLS.Imports import qualified Data.ByteString as B -import Data.ByteString.Char8 (ByteString) import Data.IORef import Control.Monad.State.Strict @@ -44,7 +44,7 @@ return . Left $ if B.null hdrbs then Error_EOF - else Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs)) + 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. @@ -103,7 +103,7 @@ pkt <- case pktRecv of Right (Handshake hss) -> ctxWithHooks ctx $ \hooks -> - (mapM (hookRecvHandshake hooks) hss) >>= return . Right . Handshake + Right . Handshake <$> mapM (hookRecvHandshake hooks) hss _ -> return pktRecv case pkt of Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p diff --git a/Network/TLS/Imports.hs b/Network/TLS/Imports.hs --- a/Network/TLS/Imports.hs +++ b/Network/TLS/Imports.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} -- Char8 + -- | -- Module : Network.TLS.Imports -- License : BSD-style @@ -5,24 +9,57 @@ -- Stability : experimental -- Portability : unknown -- -{-# LANGUAGE NoImplicitPrelude #-} module Network.TLS.Imports ( -- generic exports ByteString - , Control.Applicative.Applicative(..) - , (Control.Applicative.<$>) - , Data.Monoid.Monoid(..) + , module Data.ByteString.Char8 -- instance + , module Control.Applicative + , module Control.Monad + , module Data.Bits + , module Data.List + , module Data.Maybe +#if MIN_VERSION_base(4,9,0) + , module Data.Semigroup +#else + , module Data.Monoid +#endif + , module Data.Ord + , module Data.Word +#if !MIN_VERSION_base(4,8,0) + , sortOn +#endif -- project definition , showBytesHex ) where -import qualified Control.Applicative -import qualified Data.Monoid +import Data.ByteString (ByteString) +import Data.ByteString.Char8 () -import Data.ByteString (ByteString) -import Data.ByteArray.Encoding as B -import qualified Prelude +import Control.Applicative +import Control.Monad +import Data.Bits +import Data.List +import Data.Maybe hiding (fromJust) +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup +#else +import Data.Monoid +#endif +import Data.Ord +import Data.Word -showBytesHex :: ByteString -> Prelude.String -showBytesHex bs = Prelude.show (B.convertToBase B.Base16 bs :: ByteString) +import Data.ByteArray.Encoding as B +import qualified Prelude as P + +#if !MIN_VERSION_base(4,8,0) +import Prelude ((.)) + +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = + map P.snd . sortBy (comparing P.fst) . map (\x -> let y = f x in y `P.seq` (y, x)) +#endif + +showBytesHex :: ByteString -> P.String +showBytesHex bs = P.show (B.convertToBase B.Base16 bs :: ByteString) + diff --git a/Network/TLS/MAC.hs b/Network/TLS/MAC.hs --- a/Network/TLS/MAC.hs +++ b/Network/TLS/MAC.hs @@ -17,9 +17,8 @@ import Network.TLS.Crypto import Network.TLS.Types -import Data.ByteString (ByteString) +import Network.TLS.Imports import qualified Data.ByteString as B -import Data.Bits (xor) type HMAC = ByteString -> ByteString -> ByteString diff --git a/Network/TLS/Measurement.hs b/Network/TLS/Measurement.hs --- a/Network/TLS/Measurement.hs +++ b/Network/TLS/Measurement.hs @@ -14,7 +14,7 @@ , incrementNbHandshakes ) where -import Data.Word +import Network.TLS.Imports -- | record some data about this connection. data Measurement = Measurement diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -63,9 +63,6 @@ import Network.TLS.Struct import Network.TLS.Wire import Network.TLS.Cap -import Data.Maybe (fromJust) -import Data.Word -import Control.Monad import Data.ASN1.Types (fromASN1, toASN1) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.BinaryEncoding (DER(..)) @@ -73,7 +70,6 @@ import Network.TLS.Crypto import Network.TLS.MAC import Network.TLS.Cipher (CipherKeyExchangeType(..), Cipher(..)) -import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.ByteArray (ByteArrayAccess) @@ -151,7 +147,7 @@ (_, Nothing) -> fail "cannot decode alert description" decodeAlerts :: ByteString -> Either TLSError [(AlertLevel, AlertDescription)] -decodeAlerts = runGetErr "alerts" $ loop +decodeAlerts = runGetErr "alerts" loop where loop = do r <- remaining if r == 0 @@ -216,7 +212,7 @@ compressions <- getWords8 r <- remaining exts <- if hasHelloExtensions ver && r > 0 - then fmap fromIntegral getWord16 >>= getExtensions + then fromIntegral <$> getWord16 >>= getExtensions else return [] return $ ClientHello ver random session ciphers compressions exts Nothing @@ -229,7 +225,7 @@ compressionid <- getWord8 r <- remaining exts <- if hasHelloExtensions ver && r > 0 - then fmap fromIntegral getWord16 >>= getExtensions + then fromIntegral <$> getWord16 >>= getExtensions else return [] return $ ServerHello ver random session cipherid compressionid exts @@ -249,8 +245,8 @@ decodeCertRequest :: CurrentParams -> Get Handshake decodeCertRequest cp = do - certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8 - + mcertTypes <- map (valToType . fromIntegral) <$> getWords8 + certTypes <- mapM (fromJustM "decodeCertRequest") mcertTypes sigHashAlgs <- if cParamsVersion cp >= TLS12 then Just <$> (getWord16 >>= getSignatureHashAlgorithms) else return Nothing @@ -384,14 +380,14 @@ SKX_Unparsed bytes -> putBytes bytes _ -> error ("encodeHandshakeContent: cannot handle: " ++ show skg) -encodeHandshakeContent (HelloRequest) = return () -encodeHandshakeContent (ServerHelloDone) = return () +encodeHandshakeContent HelloRequest = return () +encodeHandshakeContent ServerHelloDone = return () encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do putWords8 (map valOfType certTypes) case sigAlgs of Nothing -> return () - Just l -> putWords16 $ map (\(x,y) -> (fromIntegral $ valOfType x) * 256 + (fromIntegral $ valOfType y)) l + Just l -> putWords16 $ map (\(x,y) -> fromIntegral (valOfType x) * 256 + fromIntegral (valOfType y)) l encodeCertAuthorities certAuthorities where -- Convert a distinguished name to its DER encoding. encodeCA dn = return $ encodeASN1' DER (toASN1 dn []) --B.concat $ L.toChunks $ encodeDN dn @@ -399,7 +395,7 @@ -- Encode a list of distinguished names. encodeCertAuthorities certAuths = do enc <- mapM encodeCA certAuths - let totLength = sum $ map (((+) 2) . B.length) enc + let totLength = sum $ map ((+) 2 . B.length) enc putWord16 (fromIntegral totLength) mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc @@ -455,8 +451,8 @@ getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm getSignatureHashAlgorithm = do - h <- fromJust . valToType <$> getWord8 - s <- fromJust . valToType <$> getWord8 + h <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" + s <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" return (h,s) putSignatureHashAlgorithm :: HashAndSignatureAlgorithm -> Put @@ -544,11 +540,11 @@ getPRF ver ciph | ver < TLS12 = prf_MD5SHA1 | maybe True (< TLS12) (cipherMinVer ciph) = prf_SHA256 - | otherwise = prf_TLS ver $ maybe SHA256 id $ cipherPRFHash ciph + | otherwise = prf_TLS ver $ fromMaybe SHA256 $ cipherPRFHash ciph generateMasterSecret_SSL :: ByteArrayAccess preMaster => preMaster -> ClientRandom -> ServerRandom -> ByteString generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) = - B.concat $ map (computeMD5) ["A","BB","CCC"] + 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 ] @@ -647,3 +643,7 @@ encodeSignedECDHParams :: ServerECDHParams -> ClientRandom -> ServerRandom -> ByteString encodeSignedECDHParams dhparams cran sran = runPut $ putClientRandom32 cran >> putServerRandom32 sran >> putServerECDHParams dhparams + +fromJustM :: Monad m => String -> Maybe a -> m a +fromJustM what Nothing = fail ("fromJust " ++ what ++ ": Nothing") +fromJustM _ (Just x) = return x diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -1,5 +1,3 @@ - {-# LANGUAGE CPP #-} - -- | -- Module : Network.TLS.Parameters -- License : BSD-style @@ -21,6 +19,7 @@ , defaultParamsClient -- * Parameters , MaxFragmentEnum(..) + , GroupUsage(..) , CertificateUsage(..) , CertificateRejectReason(..) ) where @@ -36,12 +35,9 @@ import Network.TLS.Credentials import Network.TLS.X509 import Network.TLS.RNG (Seed) +import Network.TLS.Imports import Data.Default.Class -import Data.ByteString (ByteString) import qualified Data.ByteString as B -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mempty) -#endif type HostName = String @@ -116,8 +112,13 @@ -- messages. For TLS1.0, it should not be empty. , serverCACertificates :: [SignedCertificate] - -- | Server Optional Diffie Hellman parameters. If this value is not - -- properly set, no Diffie Hellman key exchange will take place. + -- | Server Optional Diffie Hellman parameters. Setting parameters is + -- necessary for FFDHE key exchange when clients are not compatible + -- with RFC 7919. + -- + -- Value can be one of the standardized groups from module + -- "Network.TLS.Extra.FFDHE" or custom parameters generated with + -- 'Crypto.PubKey.DH.generateParams'. , serverDHEParams :: Maybe DHParams , serverShared :: Shared @@ -186,10 +187,12 @@ -- '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. + -- | A list of supported elliptic curves and finite-field groups in the + -- preferred order. + -- The default value is ['X25519','P256','P384','P521']. + -- 'X25519' and 'P256' provide 128-bit security which is strong + -- enough until 2030. Both curves are fast because their + -- backends are written in C. , supportedGroups :: [Group] } deriving (Show,Eq) @@ -212,7 +215,7 @@ , supportedSession = True , supportedFallbackScsv = True , supportedEmptyPacket = True - , supportedGroups = [P256,P384,P521] + , supportedGroups = [X25519,P256,P384,P521] } instance Default Supported where @@ -235,6 +238,21 @@ , sharedValidationCache = def } +-- | Group usage callback possible return values. +data GroupUsage = + GroupUsageValid -- ^ usage of group accepted + | GroupUsageInsecure -- ^ usage of group provides insufficient security + | GroupUsageUnsupported String -- ^ usage of group rejected for other reason (specified as string) + | GroupUsageInvalidPublic -- ^ usage of group with an invalid public value + deriving (Show,Eq) + +defaultGroupUsage :: DHParams -> DHPublic -> IO GroupUsage +defaultGroupUsage params public + | even $ dhParamsGetP params = return $ GroupUsageUnsupported "invalid odd prime" + | not $ dhValid params (dhParamsGetG params) = return $ GroupUsageUnsupported "invalid generator" + | not $ dhValid params (dhUnwrapPublic public) = return GroupUsageInvalidPublic + | otherwise = return GroupUsageValid + -- | A set of callbacks run by the clients for various corners of TLS establishment data ClientHooks = ClientHooks { -- | This action is called when the server sends a @@ -267,6 +285,11 @@ -- | This action is called when the client sends ClientHello -- to determine ALPN values such as '["h2", "http/1.1"]'. , onSuggestALPN :: IO (Maybe [B.ByteString]) + -- | This action is called to validate DHE parameters when + -- the server selected a finite-field group not part of + -- the "Supported Groups Registry". + -- See RFC 7919 section 3.1 for recommandations. + , onCustomFFDHEGroup :: DHParams -> DHPublic -> IO GroupUsage } defaultClientHooks :: ClientHooks @@ -274,6 +297,7 @@ { onCertificateRequest = \ _ -> return Nothing , onServerCertificate = validateDefault , onSuggestALPN = return Nothing + , onCustomFFDHEGroup = defaultGroupUsage } instance Show ClientHooks where diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -27,12 +27,13 @@ import Network.TLS.Handshake.State import Network.TLS.Cipher import Network.TLS.Util +import Network.TLS.Imports processPacket :: Context -> Record Plaintext -> IO (Either TLSError Packet) processPacket _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment -processPacket _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` (decodeAlerts $ fragmentGetBytes fragment)) +processPacket _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` decodeAlerts (fragmentGetBytes fragment)) processPacket ctx (Record ProtocolType_ChangeCipherSpec _ fragment) = case decodeChangeCipherSpec $ fragmentGetBytes fragment of @@ -41,7 +42,7 @@ return $ Right ChangeCipherSpec processPacket ctx (Record ProtocolType_Handshake ver fragment) = do - keyxchg <- getHState ctx >>= \hs -> return $ (hs >>= hstPendingCipher >>= Just . cipherKeyExchange) + keyxchg <- getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange) usingState ctx $ do let currentParams = CurrentParams { cParamsVersion = ver @@ -53,7 +54,7 @@ hss <- parseMany currentParams mCont (fragmentGetBytes fragment) return $ Handshake hss where parseMany currentParams mCont bs = - case maybe decodeHandshakeRecord id mCont $ bs of + case fromMaybe decodeHandshakeRecord mCont bs of GotError err -> throwError err GotPartial cont -> modify (\st -> st { stHandshakeRecordCont = Just cont }) >> return [] GotSuccess (ty,content) -> @@ -61,7 +62,7 @@ GotSuccessRemaining (ty,content) left -> case decodeHandshake currentParams ty content of Left err -> throwError err - Right hh -> (hh:) `fmap` parseMany currentParams Nothing left + Right hh -> (hh:) <$> parseMany currentParams Nothing left processPacket _ (Record ProtocolType_DeprecatedHandshake _ fragment) = case decodeDeprecatedHandshake $ fragmentGetBytes fragment of diff --git a/Network/TLS/Record/Disengage.hs b/Network/TLS/Record/Disengage.hs --- a/Network/TLS/Record/Disengage.hs +++ b/Network/TLS/Record/Disengage.hs @@ -28,7 +28,7 @@ import Network.TLS.Util import Network.TLS.Wire import Network.TLS.Packet -import Data.ByteString (ByteString) +import Network.TLS.Imports import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert) @@ -62,7 +62,7 @@ Just pad -> do cver <- getRecordVersion let b = B.length pad - 1 - return (if cver < TLS10 then True else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad) + return (cver < TLS10 || B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad) unless (macValid &&! paddingValid) $ do throwError $ Error_Protocol ("bad record mac", True, BadRecordMac) @@ -87,7 +87,7 @@ let minContent = (if explicitIV then bulkIVSize bulk else 0) + max (macSize + 1) blockSize -- check if we have enough bytes to cover the minimum for this cipher - when ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent) $ sanityCheckError + when ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent) sanityCheckError {- update IV -} (iv, econtent') <- if explicitIV @@ -99,7 +99,7 @@ let paddinglength = fromIntegral (B.last content') + 1 let contentlen = B.length content' - paddinglength - macSize (content, mac, padding) <- get3 content' (contentlen, macSize, paddinglength) - getCipherData record $ CipherData + getCipherData record CipherData { cipherDataContent = content , cipherDataMAC = Just mac , cipherDataPadding = Just padding @@ -107,14 +107,14 @@ decryptOf (BulkStateStream (BulkStream decryptF)) = do -- check if we have enough bytes to cover the minimum for this cipher - when (econtentLen < macSize) $ sanityCheckError + when (econtentLen < macSize) sanityCheckError let (content', bulkStream') = decryptF econtent {- update Ctx -} let contentlen = B.length content' - macSize (content, mac) <- get2 content' (contentlen, macSize) modify $ \txs -> txs { stCryptState = cst { cstKey = BulkStateStream bulkStream' } } - getCipherData record $ CipherData + getCipherData record CipherData { cipherDataContent = content , cipherDataMAC = Just mac , cipherDataPadding = Nothing @@ -126,7 +126,7 @@ cipherLen = econtentLen - authTagLen - nonceExpLen -- check if we have enough bytes to cover the minimum for this cipher - when (econtentLen < (authTagLen + nonceExpLen)) $ sanityCheckError + when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError (enonce, econtent', authTag) <- get3 econtent (nonceExpLen, cipherLen, authTagLen) let encodedSeq = encodeWord64 $ msSequence $ stMacState tst diff --git a/Network/TLS/Record/Engage.hs b/Network/TLS/Record/Engage.hs --- a/Network/TLS/Record/Engage.hs +++ b/Network/TLS/Record/Engage.hs @@ -13,7 +13,6 @@ ( engageRecord ) where -import Control.Applicative import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag(..)) @@ -24,7 +23,7 @@ import Network.TLS.Compression import Network.TLS.Wire import Network.TLS.Packet -import Data.ByteString (ByteString) +import Network.TLS.Imports import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert) diff --git a/Network/TLS/Record/State.hs b/Network/TLS/Record/State.hs --- a/Network/TLS/Record/State.hs +++ b/Network/TLS/Record/State.hs @@ -24,8 +24,6 @@ , getMacSequence ) where -import Data.Word -import Control.Applicative import Control.Monad.State.Strict import Network.TLS.Compression import Network.TLS.Cipher @@ -36,8 +34,8 @@ import Network.TLS.Packet import Network.TLS.MAC import Network.TLS.Util +import Network.TLS.Imports -import Data.ByteString (ByteString) import qualified Data.ByteString as B data CryptState = CryptState diff --git a/Network/TLS/Record/Types.hs b/Network/TLS/Record/Types.hs --- a/Network/TLS/Record/Types.hs +++ b/Network/TLS/Record/Types.hs @@ -39,10 +39,9 @@ ) where import Network.TLS.Struct +import Network.TLS.Imports 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) diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs --- a/Network/TLS/Sending.hs +++ b/Network/TLS/Sending.hs @@ -10,12 +10,10 @@ -- module Network.TLS.Sending (writePacket) where -import Control.Applicative import Control.Monad.State.Strict import Control.Concurrent.MVar import Data.IORef -import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Types (Role(..)) @@ -29,6 +27,7 @@ import Network.TLS.Handshake.State import Network.TLS.Cipher import Network.TLS.Util +import Network.TLS.Imports -- | 'makePacketData' create a Header and a content bytestring related to a packet -- this doesn't change any state @@ -38,7 +37,7 @@ return $ Record (packetType pkt) ver (fragmentPlaintext $ writePacketContent pkt) where writePacketContent (Handshake hss) = encodeHandshakes hss writePacketContent (Alert a) = encodeAlerts a - writePacketContent (ChangeCipherSpec) = encodeChangeCipherSpec + writePacketContent ChangeCipherSpec = encodeChangeCipherSpec writePacketContent (AppData x) = x -- | marshall packet data @@ -70,7 +69,7 @@ prepareRecord ctx f = do ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) txState <- readMVar $ ctxTxState ctx - let sz = case stCipher $ txState of + let sz = case stCipher txState of Nothing -> 0 Just cipher -> if hasRecordIV $ bulkF $ cipherBulk cipher then bulkIVSize $ cipherBulk cipher diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -57,7 +57,6 @@ 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.Strict import Network.TLS.ErrT @@ -174,10 +173,10 @@ Just _ -> st getVersion :: TLSSt Version -getVersion = maybe (error $ "internal error: version hasn't been set yet") id <$> gets stVersion +getVersion = fromMaybe (error "internal error: version hasn't been set yet") <$> gets stVersion getVersionWithDefault :: Version -> TLSSt Version -getVersionWithDefault defaultVer = maybe defaultVer id <$> gets stVersion +getVersionWithDefault defaultVer = fromMaybe defaultVer <$> gets stVersion setSecureRenegotiation :: Bool -> TLSSt () setSecureRenegotiation b = modify (\st -> st { stSecureRenegotiation = b }) diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -60,9 +60,7 @@ , typeOfHandshake ) where -import Data.ByteString (ByteString) import qualified Data.ByteString as B (length) -import Data.Word import Data.X509 (CertificateChain, DistinguishedName) import Data.Typeable import Control.Exception (Exception(..)) @@ -328,16 +326,16 @@ packetType (AppData _) = ProtocolType_AppData typeOfHandshake :: Handshake -> HandshakeType -typeOfHandshake (ClientHello {}) = HandshakeType_ClientHello -typeOfHandshake (ServerHello {}) = HandshakeType_ServerHello -typeOfHandshake (Certificates {}) = HandshakeType_Certificate -typeOfHandshake HelloRequest = HandshakeType_HelloRequest -typeOfHandshake (ServerHelloDone) = HandshakeType_ServerHelloDone -typeOfHandshake (ClientKeyXchg {}) = HandshakeType_ClientKeyXchg -typeOfHandshake (ServerKeyXchg {}) = HandshakeType_ServerKeyXchg -typeOfHandshake (CertRequest {}) = HandshakeType_CertRequest -typeOfHandshake (CertVerify {}) = HandshakeType_CertVerify -typeOfHandshake (Finished {}) = HandshakeType_Finished +typeOfHandshake ClientHello{} = HandshakeType_ClientHello +typeOfHandshake ServerHello{} = HandshakeType_ServerHello +typeOfHandshake Certificates{} = HandshakeType_Certificate +typeOfHandshake HelloRequest = HandshakeType_HelloRequest +typeOfHandshake ServerHelloDone = HandshakeType_ServerHelloDone +typeOfHandshake ClientKeyXchg{} = HandshakeType_ClientKeyXchg +typeOfHandshake ServerKeyXchg{} = HandshakeType_ServerKeyXchg +typeOfHandshake CertRequest{} = HandshakeType_CertRequest +typeOfHandshake CertVerify{} = HandshakeType_CertVerify +typeOfHandshake Finished{} = HandshakeType_Finished numericalVer :: Version -> (Word8, Word8) numericalVer SSL2 = (2, 0) diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -16,8 +16,7 @@ , Direction(..) ) where -import Data.ByteString (ByteString) -import Data.Word +import Network.TLS.Imports type HostName = String diff --git a/Network/TLS/Util.hs b/Network/TLS/Util.hs --- a/Network/TLS/Util.hs +++ b/Network/TLS/Util.hs @@ -12,10 +12,8 @@ , catchException ) where -import Data.List (foldl') --- import Network.TLS.Imports (ByteString) -import Data.ByteString (ByteString) import qualified Data.ByteString as B +import Network.TLS.Imports import Control.Exception (SomeException) import Control.Concurrent.Async diff --git a/Network/TLS/Util/ASN1.hs b/Network/TLS/Util/ASN1.hs --- a/Network/TLS/Util/ASN1.hs +++ b/Network/TLS/Util/ASN1.hs @@ -12,10 +12,10 @@ , encodeASN1Object ) where +import Network.TLS.Imports import Data.ASN1.Types (fromASN1, toASN1, ASN1Object) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.BinaryEncoding (DER(..)) -import Data.ByteString (ByteString) -- | Attempt to decode a bytestring representing -- an DER ASN.1 serialized object into the object. diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -54,13 +54,9 @@ import Data.Serialize.Get hiding (runGet) import qualified Data.Serialize.Get as G 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.Imports import Network.TLS.Util.Serialization type GetContinuation a = ByteString -> GetResult a @@ -125,12 +121,12 @@ getBigNum16 :: Get BigNum getBigNum16 = BigNum <$> getOpaque16 -getList :: Int -> (Get (Int, a)) -> Get [a] +getList :: Int -> Get (Int, a) -> Get [a] getList totalLen getElement = isolate totalLen (getElements totalLen) where getElements len | len < 0 = error "list consumed too much data. should never happen with isolate." | len == 0 = return [] - | otherwise = getElement >>= \(elementLen, a) -> liftM ((:) a) (getElements (len - elementLen)) + | otherwise = getElement >>= \(elementLen, a) -> (:) a <$> getElements (len - elementLen) processBytes :: Int -> Get a -> Get a processBytes i f = isolate i f @@ -148,7 +144,7 @@ putWords16 :: [Word16] -> Put putWords16 l = do - putWord16 $ 2 * (fromIntegral $ length l) + putWord16 $ 2 * fromIntegral (length l) mapM_ putWord16 l putWord24 :: Int -> Put diff --git a/Network/TLS/X509.hs b/Network/TLS/X509.hs --- a/Network/TLS/X509.hs +++ b/Network/TLS/X509.hs @@ -53,7 +53,7 @@ wrapCertificateChecks :: [FailedReason] -> CertificateUsage wrapCertificateChecks [] = CertificateUsageAccept wrapCertificateChecks l - | Expired `elem` l = CertificateUsageReject $ CertificateRejectExpired - | InFuture `elem` l = CertificateUsageReject $ CertificateRejectExpired - | UnknownCA `elem` l = CertificateUsageReject $ CertificateRejectUnknownCA + | Expired `elem` l = CertificateUsageReject CertificateRejectExpired + | InFuture `elem` l = CertificateUsageReject CertificateRejectExpired + | UnknownCA `elem` l = CertificateUsageReject CertificateRejectUnknownCA | otherwise = CertificateUsageReject $ CertificateRejectOther (show l) diff --git a/Tests/Ciphers.hs b/Tests/Ciphers.hs --- a/Tests/Ciphers.hs +++ b/Tests/Ciphers.hs @@ -13,13 +13,13 @@ import Network.TLS.Extra.Cipher arbitraryKey :: Bulk -> Gen B.ByteString -arbitraryKey bulk = B.pack `fmap` vector (fromIntegral $ bulkKeySize bulk) +arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk) arbitraryIV :: Bulk -> Gen B.ByteString -arbitraryIV bulk = B.pack `fmap` vector (fromIntegral $ bulkIVSize bulk) +arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk) arbitraryText :: Bulk -> Gen B.ByteString -arbitraryText bulk = B.pack `fmap` vector (fromIntegral $ bulkBlockSize bulk) +arbitraryText bulk = B.pack `fmap` vector (bulkBlockSize bulk) data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString B.ByteString deriving (Show,Eq) diff --git a/Tests/Connection.hs b/Tests/Connection.hs --- a/Tests/Connection.hs +++ b/Tests/Connection.hs @@ -9,6 +9,7 @@ , arbitraryPairParams , arbitraryPairParamsWithVersionsAndCiphers , arbitraryClientCredential + , isCustomDHParams , leafPublicKey , oneSessionManager , setPairParamsSessionManager @@ -77,8 +78,10 @@ arbitraryHashSignatures :: Gen [HashAndSignatureAlgorithm] arbitraryHashSignatures = sublistOf knownHashSignatures -knownGroups :: [Group] -knownGroups = [P256,P384,P521,X25519,X448] +knownGroups, knownECGroups, knownFFGroups :: [Group] +knownECGroups = [P256,P384,P521,X25519,X448] +knownFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192] +knownGroups = knownECGroups ++ knownFFGroups arbitraryGroups :: Gen [Group] arbitraryGroups = listOf1 $ elements knownGroups @@ -94,6 +97,9 @@ , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv) ] +isCustomDHParams :: DHParams -> Bool +isCustomDHParams params = params == dhParams + leafPublicKey :: CertificateChain -> Maybe PubKey leafPublicKey (CertificateChain []) = Nothing leafPublicKey (CertificateChain (leaf:_)) = Just (certPubKey $ signedObject $ getSigned leaf) @@ -102,7 +108,7 @@ arbitraryCipherPair connectVersion = do serverCiphers <- arbitraryCiphers `suchThat` (\cs -> or [maybe True (<= connectVersion) (cipherMinVer x) | x <- cs]) - clientCiphers <- oneof [arbitraryCiphers] `suchThat` + clientCiphers <- arbitraryCiphers `suchThat` (\cs -> or [x `elem` serverCiphers && maybe True (<= connectVersion) (cipherMinVer x) | x <- cs]) return (clientCiphers, serverCiphers) @@ -118,11 +124,11 @@ 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]) +arbitraryECGroupPair :: Gen ([Group], [Group]) +arbitraryECGroupPair = do + let arbitraryECGroups = listOf1 $ elements knownECGroups + serverGroups <- arbitraryECGroups + clientGroups <- arbitraryECGroups `suchThat` any (`elem` serverGroups) return (clientGroups, serverGroups) arbitraryHashSignaturePair :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) @@ -139,7 +145,7 @@ dhparams <- elements [dhParams,ffdhe2048,ffdhe3072] creds <- arbitraryCredentialsOfEachType - (clientGroups, serverGroups) <- arbitraryGroupPair + (clientGroups, serverGroups) <- arbitraryECGroupPair (clientHashSignatures, serverHashSignatures) <- arbitraryHashSignaturePair let serverState = def { serverSupported = def { supportedCiphers = serverCiphers diff --git a/Tests/Tests.hs b/Tests/Tests.hs --- a/Tests/Tests.hs +++ b/Tests/Tests.hs @@ -170,19 +170,26 @@ serverVersions = [TLS12] ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA + , cipher_DHE_RSA_AES256GCM_SHA384 + , cipher_DHE_RSA_AES128_SHA1 ] (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (ciphers, ciphers) clientGroups <- pick arbitraryGroups serverGroups <- pick arbitraryGroups - let clientParam' = clientParam { clientSupported = (clientSupported clientParam) + denyCustom <- pick arbitrary + let groupUsage = if denyCustom then GroupUsageUnsupported "custom group denied" else GroupUsageValid + clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedGroups = clientGroups } + , clientHooks = (clientHooks clientParam) + { onCustomFFDHEGroup = \_ _ -> return groupUsage } } serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedGroups = serverGroups } } - shouldFail = null (clientGroups `intersect` serverGroups) + isCustom = maybe True isCustomDHParams (serverDHEParams serverParam') + shouldFail = null (clientGroups `intersect` serverGroups) && isCustom && denyCustom if shouldFail then runTLSInitFailure (clientParam',serverParam') else runTLSPipeSimple (clientParam',serverParam') diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,5 +1,5 @@ Name: tls -Version: 1.4.0 +Version: 1.4.1 Description: Native Haskell TLS and SSL protocol implementation for server and client. .