2012-12-05 07:57:13 +00:00
|
|
|
module Connection
|
2012-03-28 07:06:13 +00:00
|
|
|
( newPairContext
|
|
|
|
, arbitraryPairParams
|
2012-07-12 07:59:59 +00:00
|
|
|
, setPairParamsSessionManager
|
2012-03-28 07:06:13 +00:00
|
|
|
, setPairParamsSessionResuming
|
|
|
|
) where
|
2011-11-14 22:12:09 +00:00
|
|
|
|
|
|
|
import Test.QuickCheck
|
2012-12-05 07:57:13 +00:00
|
|
|
import Certificate
|
|
|
|
import PubKey
|
|
|
|
import PipeChan
|
2011-11-14 22:12:09 +00:00
|
|
|
import Network.TLS
|
2013-05-19 07:05:46 +00:00
|
|
|
import Data.X509
|
2011-11-14 22:12:09 +00:00
|
|
|
|
|
|
|
import qualified Crypto.Random.AESCtr as RNG
|
|
|
|
import qualified Data.ByteString as B
|
|
|
|
|
2011-12-06 00:12:30 +00:00
|
|
|
debug = False
|
|
|
|
|
2011-12-11 20:43:32 +00:00
|
|
|
blockCipher :: Cipher
|
|
|
|
blockCipher = Cipher
|
2012-03-28 07:06:13 +00:00
|
|
|
{ cipherID = 0xff12
|
|
|
|
, cipherName = "rsa-id-const"
|
|
|
|
, cipherBulk = Bulk
|
|
|
|
{ bulkName = "id"
|
|
|
|
, bulkKeySize = 16
|
|
|
|
, bulkIVSize = 16
|
|
|
|
, bulkBlockSize = 16
|
|
|
|
, bulkF = BulkBlockF (\_ _ m -> m) (\_ _ m -> m)
|
|
|
|
}
|
|
|
|
, cipherHash = Hash
|
|
|
|
{ hashName = "const-hash"
|
|
|
|
, hashSize = 16
|
|
|
|
, hashF = (\_ -> B.replicate 16 1)
|
|
|
|
}
|
|
|
|
, cipherKeyExchange = CipherKeyExchange_RSA
|
|
|
|
, cipherMinVer = Nothing
|
|
|
|
}
|
2011-11-14 22:12:09 +00:00
|
|
|
|
2011-12-11 20:43:32 +00:00
|
|
|
streamCipher = blockCipher
|
2012-03-28 07:06:13 +00:00
|
|
|
{ cipherID = 0xff13
|
|
|
|
, cipherBulk = Bulk
|
|
|
|
{ bulkName = "stream"
|
|
|
|
, bulkKeySize = 16
|
|
|
|
, bulkIVSize = 0
|
|
|
|
, bulkBlockSize = 0
|
|
|
|
, bulkF = BulkStreamF (\k -> k) (\i m -> (m,i)) (\i m -> (m,i))
|
|
|
|
}
|
|
|
|
}
|
2011-12-11 20:43:32 +00:00
|
|
|
|
2011-11-14 22:12:09 +00:00
|
|
|
supportedCiphers :: [Cipher]
|
2013-02-09 16:56:47 +00:00
|
|
|
supportedCiphers = [blockCipher,streamCipher]
|
2011-11-14 22:12:09 +00:00
|
|
|
|
|
|
|
supportedVersions :: [Version]
|
|
|
|
supportedVersions = [SSL3,TLS10,TLS11,TLS12]
|
|
|
|
|
|
|
|
arbitraryPairParams = do
|
2012-03-28 07:06:13 +00:00
|
|
|
let (pubKey, privKey) = getGlobalRSAPair
|
|
|
|
servCert <- arbitraryX509WithPublicKey pubKey
|
|
|
|
allowedVersions <- arbitraryVersions
|
|
|
|
connectVersion <- elements supportedVersions `suchThat` (\c -> c `elem` allowedVersions)
|
|
|
|
serverCiphers <- arbitraryCiphers
|
|
|
|
clientCiphers <- oneof [arbitraryCiphers] `suchThat` (\cs -> or [x `elem` serverCiphers | x <- cs])
|
|
|
|
secNeg <- arbitrary
|
|
|
|
|
|
|
|
let serverState = defaultParamsServer
|
|
|
|
{ pAllowedVersions = allowedVersions
|
|
|
|
, pCiphers = serverCiphers
|
2013-05-19 07:05:46 +00:00
|
|
|
, pCertificates = Just (CertificateChain [servCert], Just $ PrivRSA privKey)
|
2012-03-28 07:06:13 +00:00
|
|
|
, pUseSecureRenegotiation = secNeg
|
|
|
|
, pLogging = logging "server: "
|
|
|
|
}
|
|
|
|
let clientState = defaultParamsClient
|
|
|
|
{ pConnectVersion = connectVersion
|
|
|
|
, pAllowedVersions = allowedVersions
|
|
|
|
, pCiphers = clientCiphers
|
|
|
|
, pUseSecureRenegotiation = secNeg
|
|
|
|
, pLogging = logging "client: "
|
|
|
|
}
|
|
|
|
return (clientState, serverState)
|
|
|
|
where
|
|
|
|
logging pre = if debug
|
|
|
|
then defaultLogging
|
|
|
|
{ loggingPacketSent = putStrLn . ((pre ++ ">> ") ++)
|
|
|
|
, loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) }
|
|
|
|
else defaultLogging
|
|
|
|
arbitraryVersions :: Gen [Version]
|
|
|
|
arbitraryVersions = resize (length supportedVersions + 1) $ listOf1 (elements supportedVersions)
|
|
|
|
arbitraryCiphers = resize (length supportedCiphers + 1) $ listOf1 (elements supportedCiphers)
|
2011-11-14 22:12:09 +00:00
|
|
|
|
2012-07-12 07:59:59 +00:00
|
|
|
setPairParamsSessionManager :: SessionManager s => s -> (Params, Params) -> (Params, Params)
|
|
|
|
setPairParamsSessionManager manager (clientState, serverState) = (nc,ns)
|
2012-03-28 07:06:13 +00:00
|
|
|
where
|
2012-07-12 07:59:59 +00:00
|
|
|
nc = setSessionManager manager clientState
|
|
|
|
ns = setSessionManager manager serverState
|
2011-12-20 07:48:19 +00:00
|
|
|
|
2012-07-12 08:02:10 +00:00
|
|
|
setPairParamsSessionResuming sessionStuff (clientState, serverState) = (nc,serverState)
|
2012-03-28 07:06:13 +00:00
|
|
|
where
|
2012-07-12 08:02:10 +00:00
|
|
|
nc = updateClientParams (\cparams -> cparams { clientWantSessionResume = Just sessionStuff }) clientState
|
2011-12-20 07:48:19 +00:00
|
|
|
|
2011-11-14 22:12:09 +00:00
|
|
|
newPairContext pipe (cParams, sParams) = do
|
2012-03-28 07:06:13 +00:00
|
|
|
let noFlush = return ()
|
2012-03-28 07:08:33 +00:00
|
|
|
let noClose = return ()
|
2011-11-14 22:12:09 +00:00
|
|
|
|
2012-03-28 07:06:13 +00:00
|
|
|
cRNG <- RNG.makeSystem
|
|
|
|
sRNG <- RNG.makeSystem
|
2011-11-14 22:12:09 +00:00
|
|
|
|
2012-03-28 07:08:33 +00:00
|
|
|
let cBackend = Backend noFlush noClose (writePipeA pipe) (readPipeA pipe)
|
|
|
|
let sBackend = Backend noFlush noClose (writePipeB pipe) (readPipeB pipe)
|
2012-03-28 07:06:13 +00:00
|
|
|
cCtx' <- contextNew cBackend cParams cRNG
|
|
|
|
sCtx' <- contextNew sBackend sParams sRNG
|
2011-11-14 22:12:09 +00:00
|
|
|
|
2012-03-28 07:06:13 +00:00
|
|
|
return (cCtx', sCtx')
|