Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

318 lines (259 sloc) 9.167 kb
{-# LANGUAGE CPP #-}
import Test.QuickCheck
import Test.QuickCheck.Monadic
import Test.Framework (defaultMain, testGroup)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Tests.Certificate
import Tests.PipeChan
import Tests.Connection
import Data.Maybe
import Data.Word
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as L
import Network.TLS
import Network.TLS.Core
import Network.TLS.Cipher
import Network.TLS.Struct
import Network.TLS.Packet
import Control.Applicative
import Control.Concurrent
import Control.Exception (throw, catch, SomeException)
import Control.Monad
import Data.IORef
import Prelude hiding (catch)
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
arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary ClientRandom where
arbitrary = ClientRandom <$> (genByteString 32)
instance Arbitrary ServerRandom where
arbitrary = ServerRandom <$> (genByteString 32)
instance Arbitrary Session where
arbitrary = do
i <- choose (1,2) :: Gen Int
case i of
2 -> liftM (Session . Just) (genByteString 32)
_ -> return $ Session Nothing
arbitraryCiphersIDs :: Gen [Word16]
arbitraryCiphersIDs = choose (0,200) >>= vector
arbitraryCompressionIDs :: Gen [Word8]
arbitraryCompressionIDs = choose (0,200) >>= vector
someWords8 :: Int -> Gen [Word8]
someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int))
instance Arbitrary CertificateType where
arbitrary = elements
[ CertificateType_RSA_Sign, CertificateType_DSS_Sign
, CertificateType_RSA_Fixed_DH, CertificateType_DSS_Fixed_DH
, CertificateType_RSA_Ephemeral_DH, CertificateType_DSS_Ephemeral_DH
, CertificateType_fortezza_dms ]
instance Arbitrary Handshake where
arbitrary = oneof
[ ClientHello
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitraryCiphersIDs
<*> arbitraryCompressionIDs
<*> (return [])
, ServerHello
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> (return [])
, liftM Certificates (resize 2 $ listOf $ arbitraryX509)
, pure HelloRequest
, pure ServerHelloDone
, ClientKeyXchg <$> genByteString 48
--, liftM ServerKeyXchg
--, liftM3 CertRequest arbitrary (return Nothing) (return [])
--, liftM CertVerify (return [])
, Finished <$> (genByteString 12)
]
{- quickcheck property -}
prop_header_marshalling_id :: Header -> Bool
prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x
prop_handshake_marshalling_id :: Handshake -> Bool
prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x
where
decodeHs b = either (Left . id) (uncurry (decodeHandshake cp) . head) $ decodeHandshakes b
cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = CipherKeyExchange_RSA }
prop_pipe_work :: PropertyM IO ()
prop_pipe_work = do
pipe <- run newPipe
_ <- run (runPipe pipe)
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 ()
establish_data_pipe params tlsServer tlsClient = do
-- initial setup
pipe <- newPipe
_ <- (runPipe pipe)
startQueue <- newChan
resultQueue <- newChan
(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
prop_handshake_initiate :: PropertyM IO ()
prop_handshake_initiate = 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
dres <- run $ readChan resultQueue
d `assertEq` dres
return ()
where
tlsServer ctx queue = do
handshake ctx
d <- recvData' ctx
writeChan queue d
return ()
tlsClient queue ctx = do
handshake ctx
d <- readChan queue
sendData ctx d
bye ctx
return ()
prop_handshake_npn_initiate :: PropertyM IO ()
prop_handshake_npn_initiate = do
(clientParam,serverParam) <- pick arbitraryPairParams
let clientParam' = clientParam { onNPNServerSuggest = Just $ \protos -> return (head protos) }
let serverParam' = serverParam { onSuggestNextProtocols = return $ Just [C8.pack "spdy/2", C8.pack "http/1.1"] }
let params' = (clientParam',serverParam')
(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
dres <- run $ readChan resultQueue
d `assertEq` dres
return ()
where
tlsServer ctx queue = do
handshake ctx
protocol <- getNegotiatedProtocol ctx
Just (C8.pack "spdy/2") `assertEq` protocol
d <- recvData' ctx
writeChan queue d
return ()
tlsClient queue ctx = do
handshake ctx
protocol <- getNegotiatedProtocol ctx
Just (C8.pack "spdy/2") `assertEq` protocol
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
dres <- run $ readChan resultQueue
d `assertEq` dres
return ()
where
tlsServer ctx queue = do
handshake ctx
d <- recvData' ctx
writeChan queue d
return ()
tlsClient queue ctx = do
handshake ctx
handshake ctx
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" -}
d2 <- L.pack <$> pick (someWords8 256)
run $ writeChan startQueue d2
dres2 <- run $ readChan resultQueue
d2 `assertEq` dres2
return ()
where
tlsServer ctx queue = do
handshake ctx
d <- recvData' ctx
writeChan queue d
return ()
tlsClient queue ctx = do
handshake ctx
d <- readChan queue
sendData ctx d
bye ctx
return ()
assertEq :: (Show a, Monad m, Eq a) => a -> a -> m ()
assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected)
main :: IO ()
main = defaultMain
[ tests_marshalling
, tests_handshake
]
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)
, testProperty "initiate with npn" (monadicIO prop_handshake_npn_initiate)
, testProperty "renegociation" (monadicIO prop_handshake_renegociation)
, testProperty "resumption" (monadicIO prop_handshake_session_resumption)
]
-- vim: tabstop=8 softtabstop=8 shiftwidth=8 noexpandtab
Jump to Line
Something went wrong with that request. Please try again.