2010-11-03 23:04:03 +00:00
|
|
|
{-# LANGUAGE CPP #-}
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2011-03-19 09:19:35 +00:00
|
|
|
import Test.QuickCheck
|
2011-11-14 22:12:09 +00:00
|
|
|
import Test.QuickCheck.Monadic
|
2011-11-12 16:09:39 +00:00
|
|
|
import Test.Framework (defaultMain, testGroup)
|
2011-10-23 16:54:07 +00:00
|
|
|
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
2011-03-19 09:19:35 +00:00
|
|
|
|
2011-11-11 22:53:17 +00:00
|
|
|
import Tests.Certificate
|
2011-11-14 22:12:09 +00:00
|
|
|
import Tests.PipeChan
|
|
|
|
import Tests.Connection
|
2011-03-19 09:19:35 +00:00
|
|
|
|
2011-12-20 07:49:28 +00:00
|
|
|
import Data.Maybe
|
2011-03-19 09:19:35 +00:00
|
|
|
import Data.Word
|
|
|
|
|
|
|
|
import qualified Data.ByteString as B
|
2011-11-14 22:12:09 +00:00
|
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
import Network.TLS.Core
|
2011-05-12 07:28:55 +00:00
|
|
|
import Network.TLS.Cipher
|
2011-03-19 09:19:35 +00:00
|
|
|
import Network.TLS.Struct
|
|
|
|
import Network.TLS.Packet
|
2011-10-23 17:00:45 +00:00
|
|
|
import Control.Applicative
|
2011-11-14 22:12:09 +00:00
|
|
|
import Control.Concurrent
|
|
|
|
import Control.Exception (throw, catch, SomeException)
|
|
|
|
import Control.Monad
|
|
|
|
|
2011-12-20 07:49:28 +00:00
|
|
|
import Data.IORef
|
|
|
|
|
2011-11-14 22:12:09 +00:00
|
|
|
import Prelude hiding (catch)
|
2011-03-19 09:19:35 +00:00
|
|
|
|
|
|
|
genByteString :: Int -> Gen B.ByteString
|
|
|
|
genByteString i = B.pack <$> vector i
|
|
|
|
|
|
|
|
instance Arbitrary Version where
|
|
|
|
arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12 ]
|
|
|
|
|
|
|
|
instance Arbitrary ProtocolType where
|
|
|
|
arbitrary = elements
|
|
|
|
[ ProtocolType_ChangeCipherSpec
|
|
|
|
, ProtocolType_Alert
|
|
|
|
, ProtocolType_Handshake
|
|
|
|
, ProtocolType_AppData ]
|
|
|
|
|
|
|
|
#if MIN_VERSION_QuickCheck(2,3,0)
|
|
|
|
#else
|
|
|
|
instance Arbitrary Word8 where
|
|
|
|
arbitrary = fromIntegral <$> (choose (0,255) :: Gen Int)
|
|
|
|
|
|
|
|
instance Arbitrary Word16 where
|
|
|
|
arbitrary = fromIntegral <$> (choose (0,65535) :: Gen Int)
|
|
|
|
#endif
|
|
|
|
|
|
|
|
instance Arbitrary Header where
|
2011-10-23 17:00:45 +00:00
|
|
|
arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary
|
2011-03-19 09:19:35 +00:00
|
|
|
|
|
|
|
instance Arbitrary ClientRandom where
|
2011-10-23 17:00:45 +00:00
|
|
|
arbitrary = ClientRandom <$> (genByteString 32)
|
2011-03-19 09:19:35 +00:00
|
|
|
|
|
|
|
instance Arbitrary ServerRandom where
|
2011-10-23 17:00:45 +00:00
|
|
|
arbitrary = ServerRandom <$> (genByteString 32)
|
2011-03-19 09:19:35 +00:00
|
|
|
|
|
|
|
instance Arbitrary Session where
|
|
|
|
arbitrary = do
|
|
|
|
i <- choose (1,2) :: Gen Int
|
|
|
|
case i of
|
|
|
|
2 -> liftM (Session . Just) (genByteString 32)
|
2011-12-01 08:52:01 +00:00
|
|
|
_ -> return $ Session Nothing
|
2011-03-19 09:19:35 +00:00
|
|
|
|
|
|
|
arbitraryCiphersIDs :: Gen [Word16]
|
|
|
|
arbitraryCiphersIDs = choose (0,200) >>= vector
|
|
|
|
|
|
|
|
arbitraryCompressionIDs :: Gen [Word8]
|
|
|
|
arbitraryCompressionIDs = choose (0,200) >>= vector
|
|
|
|
|
2011-12-11 20:43:53 +00:00
|
|
|
someWords8 :: Int -> Gen [Word8]
|
|
|
|
someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int))
|
|
|
|
|
2011-03-19 09:19:35 +00:00
|
|
|
instance Arbitrary CertificateType where
|
|
|
|
arbitrary = elements
|
|
|
|
[ CertificateType_RSA_Sign, CertificateType_DSS_Sign
|
|
|
|
, CertificateType_RSA_Fixed_DH, CertificateType_DSS_Fixed_DH
|
2011-05-12 07:16:38 +00:00
|
|
|
, CertificateType_RSA_Ephemeral_DH, CertificateType_DSS_Ephemeral_DH
|
2011-03-19 09:19:35 +00:00
|
|
|
, CertificateType_fortezza_dms ]
|
|
|
|
|
|
|
|
instance Arbitrary Handshake where
|
|
|
|
arbitrary = oneof
|
2011-10-23 17:00:45 +00:00
|
|
|
[ ClientHello
|
|
|
|
<$> arbitrary
|
|
|
|
<*> arbitrary
|
|
|
|
<*> arbitrary
|
|
|
|
<*> arbitraryCiphersIDs
|
|
|
|
<*> arbitraryCompressionIDs
|
|
|
|
<*> (return [])
|
|
|
|
, ServerHello
|
|
|
|
<$> arbitrary
|
|
|
|
<*> arbitrary
|
|
|
|
<*> arbitrary
|
|
|
|
<*> arbitrary
|
|
|
|
<*> arbitrary
|
|
|
|
<*> (return [])
|
2011-11-11 22:53:17 +00:00
|
|
|
, liftM Certificates (resize 2 $ listOf $ arbitraryX509)
|
2011-10-23 17:00:45 +00:00
|
|
|
, pure HelloRequest
|
|
|
|
, pure ServerHelloDone
|
2011-12-01 08:41:01 +00:00
|
|
|
, ClientKeyXchg <$> genByteString 48
|
2011-03-19 09:19:35 +00:00
|
|
|
--, liftM ServerKeyXchg
|
|
|
|
--, liftM3 CertRequest arbitrary (return Nothing) (return [])
|
|
|
|
--, liftM CertVerify (return [])
|
2011-10-23 17:00:45 +00:00
|
|
|
, Finished <$> (genByteString 12)
|
2011-03-19 09:19:35 +00:00
|
|
|
]
|
|
|
|
|
|
|
|
{- quickcheck property -}
|
|
|
|
|
2011-12-01 08:52:01 +00:00
|
|
|
prop_header_marshalling_id :: Header -> Bool
|
2011-03-19 09:19:35 +00:00
|
|
|
prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x
|
2011-12-01 08:52:01 +00:00
|
|
|
|
|
|
|
prop_handshake_marshalling_id :: Handshake -> Bool
|
2011-03-19 09:19:35 +00:00
|
|
|
prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x
|
|
|
|
where
|
2011-05-12 07:28:55 +00:00
|
|
|
decodeHs b = either (Left . id) (uncurry (decodeHandshake cp) . head) $ decodeHandshakes b
|
|
|
|
cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = CipherKeyExchange_RSA }
|
2011-03-19 09:19:35 +00:00
|
|
|
|
2011-12-01 08:52:01 +00:00
|
|
|
prop_pipe_work :: PropertyM IO ()
|
2011-11-14 22:12:09 +00:00
|
|
|
prop_pipe_work = do
|
|
|
|
pipe <- run newPipe
|
2011-12-01 08:52:01 +00:00
|
|
|
_ <- run (runPipe pipe)
|
2011-11-14 22:12:09 +00:00
|
|
|
|
|
|
|
let bSize = 16
|
|
|
|
n <- pick (choose (1, 32))
|
|
|
|
|
|
|
|
let d1 = B.replicate (bSize * n) 40
|
|
|
|
let d2 = B.replicate (bSize * n) 45
|
|
|
|
|
|
|
|
d1' <- run (writePipeA pipe d1 >> readPipeB pipe (B.length d1))
|
|
|
|
d1 `assertEq` d1'
|
|
|
|
|
|
|
|
d2' <- run (writePipeB pipe d2 >> readPipeA pipe (B.length d2))
|
|
|
|
d2 `assertEq` d2'
|
|
|
|
|
|
|
|
return ()
|
|
|
|
|
2011-12-11 20:43:53 +00:00
|
|
|
establish_data_pipe params tlsServer tlsClient = do
|
2011-11-14 22:12:09 +00:00
|
|
|
-- initial setup
|
2011-12-11 20:43:53 +00:00
|
|
|
pipe <- newPipe
|
|
|
|
_ <- (runPipe pipe)
|
|
|
|
startQueue <- newChan
|
|
|
|
resultQueue <- newChan
|
2011-11-14 22:12:09 +00:00
|
|
|
|
2011-12-11 20:43:53 +00:00
|
|
|
(cCtx, sCtx) <- newPairContext pipe params
|
|
|
|
|
|
|
|
_ <- forkIO $ catch (tlsServer sCtx resultQueue) (printAndRaise "server")
|
|
|
|
_ <- forkIO $ catch (tlsClient startQueue cCtx) (printAndRaise "client")
|
|
|
|
|
|
|
|
return (startQueue, resultQueue)
|
|
|
|
where
|
|
|
|
printAndRaise :: String -> SomeException -> IO ()
|
|
|
|
printAndRaise s e = putStrLn (s ++ " exception: " ++ show e) >> throw e
|
2011-11-14 22:12:09 +00:00
|
|
|
|
2011-12-11 20:43:53 +00:00
|
|
|
prop_handshake_initiate :: PropertyM IO ()
|
|
|
|
prop_handshake_initiate = do
|
|
|
|
params <- pick arbitraryPairParams
|
|
|
|
(startQueue, resultQueue) <- run (establish_data_pipe params tlsServer tlsClient)
|
2011-11-14 22:12:09 +00:00
|
|
|
|
|
|
|
{- the test involves writing data on one side of the data "pipe" and
|
|
|
|
- then checking we received them on the other side of the data "pipe" -}
|
|
|
|
d <- L.pack <$> pick (someWords8 256)
|
|
|
|
run $ writeChan startQueue d
|
|
|
|
|
|
|
|
dres <- run $ readChan resultQueue
|
|
|
|
d `assertEq` dres
|
|
|
|
|
|
|
|
return ()
|
|
|
|
where
|
2011-12-11 20:43:53 +00:00
|
|
|
tlsServer ctx queue = do
|
2012-01-18 06:29:29 +00:00
|
|
|
handshake ctx
|
2012-02-07 20:48:52 +00:00
|
|
|
d <- recvData' ctx
|
2011-12-11 20:43:53 +00:00
|
|
|
writeChan queue d
|
|
|
|
return ()
|
|
|
|
tlsClient queue ctx = do
|
2012-01-18 06:29:29 +00:00
|
|
|
handshake ctx
|
2011-12-11 20:43:53 +00:00
|
|
|
d <- readChan queue
|
|
|
|
sendData ctx d
|
|
|
|
bye ctx
|
|
|
|
return ()
|
|
|
|
|
|
|
|
prop_handshake_renegociation :: PropertyM IO ()
|
|
|
|
prop_handshake_renegociation = do
|
|
|
|
params <- pick arbitraryPairParams
|
|
|
|
(startQueue, resultQueue) <- run (establish_data_pipe params tlsServer tlsClient)
|
|
|
|
|
|
|
|
{- the test involves writing data on one side of the data "pipe" and
|
|
|
|
- then checking we received them on the other side of the data "pipe" -}
|
|
|
|
d <- L.pack <$> pick (someWords8 256)
|
|
|
|
run $ writeChan startQueue d
|
2011-11-16 21:14:32 +00:00
|
|
|
|
2011-12-11 20:43:53 +00:00
|
|
|
dres <- run $ readChan resultQueue
|
|
|
|
d `assertEq` dres
|
2011-11-14 22:12:09 +00:00
|
|
|
|
2011-12-11 20:43:53 +00:00
|
|
|
return ()
|
|
|
|
where
|
2011-11-14 22:16:52 +00:00
|
|
|
tlsServer ctx queue = do
|
2012-01-18 06:29:29 +00:00
|
|
|
handshake ctx
|
2012-02-07 20:48:52 +00:00
|
|
|
d <- recvData' ctx
|
2011-11-14 22:12:09 +00:00
|
|
|
writeChan queue d
|
|
|
|
return ()
|
2011-11-14 22:16:52 +00:00
|
|
|
tlsClient queue ctx = do
|
2012-01-18 06:29:29 +00:00
|
|
|
handshake ctx
|
|
|
|
handshake ctx
|
2011-12-20 07:49:28 +00:00
|
|
|
d <- readChan queue
|
|
|
|
sendData ctx d
|
|
|
|
bye ctx
|
|
|
|
return ()
|
|
|
|
|
|
|
|
prop_handshake_session_resumption :: PropertyM IO ()
|
|
|
|
prop_handshake_session_resumption = do
|
|
|
|
sessionRef <- run $ newIORef Nothing
|
|
|
|
|
|
|
|
plainParams <- pick arbitraryPairParams
|
|
|
|
let params = setPairParamsSessionSaving (\sid d -> writeIORef sessionRef $ Just (sid,d)) plainParams
|
|
|
|
|
|
|
|
-- establish a session.
|
|
|
|
(s1, r1) <- run (establish_data_pipe params tlsServer tlsClient)
|
|
|
|
|
|
|
|
d <- L.pack <$> pick (someWords8 256)
|
|
|
|
run $ writeChan s1 d
|
|
|
|
dres <- run $ readChan r1
|
|
|
|
d `assertEq` dres
|
|
|
|
|
|
|
|
-- and resume
|
|
|
|
sessionParams <- run $ readIORef sessionRef
|
|
|
|
assert (isJust sessionParams)
|
|
|
|
let params2 = setPairParamsSessionResuming (fromJust sessionParams) plainParams
|
|
|
|
|
|
|
|
-- resume
|
|
|
|
(startQueue, resultQueue) <- run (establish_data_pipe params2 tlsServer tlsClient)
|
|
|
|
|
|
|
|
{- the test involves writing data on one side of the data "pipe" and
|
|
|
|
- then checking we received them on the other side of the data "pipe" -}
|
2012-01-18 06:29:29 +00:00
|
|
|
d2 <- L.pack <$> pick (someWords8 256)
|
|
|
|
run $ writeChan startQueue d2
|
2011-12-20 07:49:28 +00:00
|
|
|
|
2012-01-18 06:29:29 +00:00
|
|
|
dres2 <- run $ readChan resultQueue
|
|
|
|
d2 `assertEq` dres2
|
2011-12-20 07:49:28 +00:00
|
|
|
|
|
|
|
return ()
|
|
|
|
where
|
|
|
|
tlsServer ctx queue = do
|
2012-01-18 06:29:29 +00:00
|
|
|
handshake ctx
|
2012-02-07 20:48:52 +00:00
|
|
|
d <- recvData' ctx
|
2011-12-20 07:49:28 +00:00
|
|
|
writeChan queue d
|
|
|
|
return ()
|
|
|
|
tlsClient queue ctx = do
|
2012-01-18 06:29:29 +00:00
|
|
|
handshake ctx
|
2011-11-14 22:12:09 +00:00
|
|
|
d <- readChan queue
|
2011-11-14 22:16:52 +00:00
|
|
|
sendData ctx d
|
2011-11-14 22:18:30 +00:00
|
|
|
bye ctx
|
2011-11-14 22:12:09 +00:00
|
|
|
return ()
|
|
|
|
|
2011-12-01 08:52:01 +00:00
|
|
|
assertEq :: (Show a, Monad m, Eq a) => a -> a -> m ()
|
2011-11-14 22:12:09 +00:00
|
|
|
assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected)
|
|
|
|
|
2011-12-01 08:52:01 +00:00
|
|
|
main :: IO ()
|
2011-11-11 22:53:17 +00:00
|
|
|
main = defaultMain
|
|
|
|
[ tests_marshalling
|
2011-11-14 22:12:09 +00:00
|
|
|
, tests_handshake
|
2011-11-11 22:53:17 +00:00
|
|
|
]
|
2011-12-01 08:47:34 +00:00
|
|
|
where
|
|
|
|
-- lowlevel tests to check the packet marshalling.
|
|
|
|
tests_marshalling = testGroup "Marshalling"
|
|
|
|
[ testProperty "Header" prop_header_marshalling_id
|
|
|
|
, testProperty "Handshake" prop_handshake_marshalling_id
|
|
|
|
]
|
|
|
|
|
|
|
|
-- 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)
|
2011-12-11 20:43:53 +00:00
|
|
|
, testProperty "renegociation" (monadicIO prop_handshake_renegociation)
|
2011-12-20 07:49:28 +00:00
|
|
|
, testProperty "resumption" (monadicIO prop_handshake_session_resumption)
|
2011-12-01 08:47:34 +00:00
|
|
|
]
|