tls 0.4.1 → 0.5.0
raw patch · 7 files changed
+164/−520 lines, 7 filesdep −cmdargsdep −networkdep −vector
Dependencies removed: cmdargs, network, vector
Files
- Network/TLS.hs +21/−11
- Network/TLS/Cipher.hs +0/−225
- Network/TLS/Core.hs +8/−9
- Network/TLS/Internal.hs +22/−0
- Stunnel.hs +0/−257
- Tests.hs +111/−6
- tls.cabal +2/−12
Network/TLS.hs view
@@ -7,7 +7,26 @@ -- module Network.TLS (- module Network.TLS.Core+ -- * Context configuration+ TLSParams(..)+ , defaultParams++ -- * Context object+ , TLSCtx+ , ctxHandle++ -- * Creating a context+ , client+ , server++ -- * Initialisation and Termination of context+ , bye+ , handshake++ -- * High level API+ , sendData+ , recvData+ -- * Crypto Key , PrivateKey(..) -- * Crypto RNG@@ -17,15 +36,6 @@ , nullCompression -- * Ciphers & Predefined ciphers , Cipher- , cipher_null_null- , cipher_null_SHA1- , cipher_null_MD5- , cipher_RC4_128_MD5- , cipher_RC4_128_SHA1- , cipher_AES128_SHA1- , cipher_AES256_SHA1- , cipher_AES128_SHA256- , cipher_AES256_SHA256 -- * Versions , Version(..) -- * Errors@@ -34,7 +44,7 @@ import Network.TLS.Struct (Version(..), TLSError(..)) import Network.TLS.Crypto (PrivateKey(..))-import Network.TLS.Cipher (Cipher(..), cipher_null_null , cipher_null_SHA1 , cipher_null_MD5 , cipher_RC4_128_MD5 , cipher_RC4_128_SHA1 , cipher_AES128_SHA1 , cipher_AES256_SHA1 , cipher_AES128_SHA256 , cipher_AES256_SHA256)+import Network.TLS.Cipher (Cipher(..)) import Network.TLS.Compression (Compression(..), nullCompression) import Network.TLS.SRandom (makeSRandomGen, SRandomGen) import Network.TLS.Core
Network/TLS/Cipher.hs view
@@ -13,32 +13,13 @@ , Key , IV , cipherExchangeNeedMoreData-- -- * builtin ciphers for ease of use, might move later to a tls-ciphers library- , cipher_null_null- , cipher_null_SHA1- , cipher_null_MD5- , cipher_RC4_128_MD5- , cipher_RC4_128_SHA1- , cipher_AES128_SHA1- , cipher_AES256_SHA1- , cipher_AES128_SHA256- , cipher_AES256_SHA256 ) where import Data.Word import Network.TLS.Struct (Version(..)) -import qualified Crypto.Hash.SHA256 as SHA256-import qualified Crypto.Hash.SHA1 as SHA1-import qualified Crypto.Hash.MD5 as MD5--import qualified Data.Vector.Unboxed as Vector (fromList, toList) import qualified Data.ByteString as B -import qualified Crypto.Cipher.AES as AES-import qualified Crypto.Cipher.RC4 as RC4- -- FIXME convert to newtype type Key = B.ByteString type IV = B.ByteString@@ -93,209 +74,3 @@ cipherExchangeNeedMoreData CipherKeyExchangeECDH_ECDSA = True cipherExchangeNeedMoreData CipherKeyExchangeECDH_RSA = True cipherExchangeNeedMoreData CipherKeyExchangeECDHE_ECDSA = True--aes128_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString-aes128_cbc_encrypt key iv d = AES.encryptCBC pkey iv d- where (Right pkey) = AES.initKey128 key--aes128_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString-aes128_cbc_decrypt key iv d = AES.decryptCBC pkey iv d- where (Right pkey) = AES.initKey128 key--aes256_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString-aes256_cbc_encrypt key iv d = AES.encryptCBC pkey iv d- where (Right pkey) = AES.initKey256 key--aes256_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString-aes256_cbc_decrypt key iv d = AES.decryptCBC pkey iv d- where (Right pkey) = AES.initKey256 key--toIV :: RC4.Ctx -> IV-toIV (v, x, y) = B.pack (x : y : Vector.toList v)--toCtx :: IV -> RC4.Ctx-toCtx iv =- case B.unpack iv of- x:y:l -> (Vector.fromList l, x, y)- _ -> (Vector.fromList [], 0, 0)--initF_rc4 :: Key -> IV-initF_rc4 key = toIV $ RC4.initCtx (B.unpack key)--encryptF_rc4 :: IV -> B.ByteString -> (B.ByteString, IV)-encryptF_rc4 iv d = (\(ctx, e) -> (e, toIV ctx)) $ RC4.encrypt (toCtx iv) d--decryptF_rc4 :: IV -> B.ByteString -> (B.ByteString, IV)-decryptF_rc4 iv e = (\(ctx, d) -> (d, toIV ctx)) $ RC4.decrypt (toCtx iv) e--{--TLS 1.0 ciphers definition--CipherSuite TLS_NULL_WITH_NULL_NULL = { 0x00,0x00 };-CipherSuite TLS_RSA_WITH_NULL_MD5 = { 0x00,0x01 };-CipherSuite TLS_RSA_WITH_NULL_SHA = { 0x00,0x02 };-CipherSuite TLS_RSA_EXPORT_WITH_RC4_40_MD5 = { 0x00,0x03 };-CipherSuite TLS_RSA_WITH_RC4_128_MD5 = { 0x00,0x04 };-CipherSuite TLS_RSA_WITH_RC4_128_SHA = { 0x00,0x05 };-CipherSuite TLS_RSA_EXPORT_WITH_RC2_CBC_40_MD5 = { 0x00,0x06 };-CipherSuite TLS_RSA_WITH_IDEA_CBC_SHA = { 0x00,0x07 };-CipherSuite TLS_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x08 };-CipherSuite TLS_RSA_WITH_DES_CBC_SHA = { 0x00,0x09 };-CipherSuite TLS_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x0A };-CipherSuite TLS_DH_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x0B };-CipherSuite TLS_DH_DSS_WITH_DES_CBC_SHA = { 0x00,0x0C };-CipherSuite TLS_DH_DSS_WITH_3DES_EDE_CBC_SHA = { 0x00,0x0D };-CipherSuite TLS_DH_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x0E };-CipherSuite TLS_DH_RSA_WITH_DES_CBC_SHA = { 0x00,0x0F };-CipherSuite TLS_DH_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x10 };-CipherSuite TLS_DHE_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x11 };-CipherSuite TLS_DHE_DSS_WITH_DES_CBC_SHA = { 0x00,0x12 };-CipherSuite TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA = { 0x00,0x13 };-CipherSuite TLS_DHE_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x14 };-CipherSuite TLS_DHE_RSA_WITH_DES_CBC_SHA = { 0x00,0x15 };-CipherSuite TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x16 };-CipherSuite TLS_DH_anon_EXPORT_WITH_RC4_40_MD5 = { 0x00,0x17 };-CipherSuite TLS_DH_anon_WITH_RC4_128_MD5 = { 0x00,0x18 };-CipherSuite TLS_DH_anon_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x19 };-CipherSuite TLS_DH_anon_WITH_DES_CBC_SHA = { 0x00,0x1A };-CipherSuite TLS_DH_anon_WITH_3DES_EDE_CBC_SHA = { 0x00,0x1B };--}--{-- - some builtin ciphers description- -}--cipher_null_null :: Cipher-cipher_null_null = Cipher- { cipherID = 0x0- , cipherName = "null-null"- , cipherDigestSize = 0- , cipherKeySize = 0- , cipherIVSize = 0- , cipherKeyBlockSize = 0- , cipherPaddingSize = 0- , cipherMACHash = (const B.empty)- , cipherKeyExchange = CipherKeyExchangeRSA- , cipherF = CipherNoneF- , cipherMinVer = Nothing- }--cipher_null_MD5 :: Cipher-cipher_null_MD5 = Cipher- { cipherID = 0x1- , cipherName = "RSA-null-MD5"- , cipherDigestSize = 16- , cipherKeySize = 0- , cipherIVSize = 0- , cipherKeyBlockSize = 2 * (16 + 0 + 0)- , cipherPaddingSize = 0- , cipherMACHash = MD5.hash- , cipherKeyExchange = CipherKeyExchangeRSA- , cipherF = CipherNoneF- , cipherMinVer = Nothing- }--cipher_null_SHA1 :: Cipher-cipher_null_SHA1 = Cipher- { cipherID = 0x2- , cipherName = "RSA-null-SHA1"- , cipherDigestSize = 20- , cipherKeySize = 0- , cipherIVSize = 0- , cipherKeyBlockSize = 2 * (20 + 0 + 0)- , cipherPaddingSize = 0- , cipherMACHash = SHA1.hash- , cipherKeyExchange = CipherKeyExchangeRSA- , cipherF = CipherNoneF- , cipherMinVer = Nothing- }--cipher_RC4_128_MD5 :: Cipher-cipher_RC4_128_MD5 = Cipher- { cipherID = 0x04- , cipherName = "RSA-rc4-128-md5"- , cipherDigestSize = 16- , cipherKeySize = 16- , cipherIVSize = 0- , cipherKeyBlockSize = 2 * (16 + 16 + 0)- , cipherPaddingSize = 0- , cipherMACHash = MD5.hash- , cipherKeyExchange = CipherKeyExchangeRSA- , cipherF = CipherStreamF initF_rc4 encryptF_rc4 decryptF_rc4- , cipherMinVer = Nothing- }--cipher_RC4_128_SHA1 :: Cipher-cipher_RC4_128_SHA1 = Cipher- { cipherID = 0x05- , cipherName = "RSA-rc4-128-sha1"- , cipherDigestSize = 20- , cipherKeySize = 16- , cipherIVSize = 0- , cipherKeyBlockSize = 2 * (20 + 16 + 0)- , cipherPaddingSize = 0- , cipherMACHash = SHA1.hash- , cipherKeyExchange = CipherKeyExchangeRSA- , cipherF = CipherStreamF initF_rc4 encryptF_rc4 decryptF_rc4- , cipherMinVer = Nothing- }--cipher_AES128_SHA1 :: Cipher-cipher_AES128_SHA1 = Cipher- { cipherID = 0x2f- , cipherName = "RSA-aes128-sha1"- , cipherDigestSize = 20- , cipherKeySize = 16- , cipherIVSize = 16- , cipherKeyBlockSize = 2 * (20 + 16 + 16)- , cipherPaddingSize = 16- , cipherMACHash = SHA1.hash- , cipherKeyExchange = CipherKeyExchangeRSA- , cipherF = CipherBlockF aes128_cbc_encrypt aes128_cbc_decrypt- , cipherMinVer = Just SSL3- }--cipher_AES256_SHA1 :: Cipher-cipher_AES256_SHA1 = Cipher- { cipherID = 0x35- , cipherName = "RSA-aes256-sha1"- , cipherDigestSize = 20- , cipherKeySize = 32- , cipherIVSize = 16- , cipherKeyBlockSize = 2 * (20 + 32 + 16)- , cipherPaddingSize = 16- , cipherMACHash = SHA1.hash- , cipherKeyExchange = CipherKeyExchangeRSA- , cipherF = CipherBlockF aes256_cbc_encrypt aes256_cbc_decrypt- , cipherMinVer = Just SSL3- }--cipher_AES128_SHA256 :: Cipher-cipher_AES128_SHA256 = Cipher- { cipherID = 0x3c- , cipherName = "RSA-aes128-sha256"- , cipherDigestSize = 32- , cipherKeySize = 16- , cipherIVSize = 16- , cipherKeyBlockSize = 2 * (32 + 16 + 16)- , cipherPaddingSize = 16- , cipherMACHash = SHA256.hash- , cipherKeyExchange = CipherKeyExchangeRSA- , cipherF = CipherBlockF aes128_cbc_encrypt aes128_cbc_decrypt- , cipherMinVer = Just TLS12- }--cipher_AES256_SHA256 :: Cipher-cipher_AES256_SHA256 = Cipher- { cipherID = 0x3d- , cipherName = "RSA-aes256-sha256"- , cipherDigestSize = 32- , cipherKeySize = 32- , cipherIVSize = 16- , cipherKeyBlockSize = 2 * (32 + 32 + 16)- , cipherPaddingSize = 16- , cipherMACHash = SHA256.hash- , cipherKeyExchange = CipherKeyExchangeRSA- , cipherF = CipherBlockF aes256_cbc_encrypt aes256_cbc_decrypt- , cipherMinVer = Just TLS12- }
Network/TLS/Core.hs view
@@ -16,6 +16,10 @@ , TLSCtx , ctxHandle + -- * Internal packet sending and receiving+ , sendPacket+ , recvPacket+ -- * Creating a context , client , server@@ -83,8 +87,8 @@ -- | A TLS Context is a handle augmented by tls specific state and parameters data TLSCtx = TLSCtx- { ctxHandle :: Handle- , ctxParams :: TLSParams -- ^ return the handle associated with this context+ { ctxHandle :: Handle -- ^ return the handle associated with this context+ , ctxParams :: TLSParams , ctxState :: MVar TLSState } @@ -337,11 +341,6 @@ -- on client context, receiving a hello request == renegociation Right [Handshake HelloRequest] -> handshakeClient ctx >> recvData ctx- Right l -> do- let dat = map getAppData l- when (length dat < length l) $ error "error mixed type packet"- return $ L.fromChunks $ catMaybes dat+ Right [AppData x] -> return $ L.fromChunks [x] Left err -> error ("error received: " ++ show err)- where- getAppData (AppData x) = Just x- getAppData _ = Nothing+ _ -> error "unexpected item"
+ Network/TLS/Internal.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Network.TLS.Internal+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS.Internal+ ( module Network.TLS.Struct+ , module Network.TLS.Packet+ , module Network.TLS.Receiving+ , module Network.TLS.Sending+ , sendPacket+ , recvPacket+ ) where++import Network.TLS.Struct+import Network.TLS.Packet+import Network.TLS.Receiving+import Network.TLS.Sending+import Network.TLS.Core (sendPacket, recvPacket)
− Stunnel.hs
@@ -1,257 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-import Network.BSD-import Network.Socket-import System.IO-import System.IO.Error hiding (try)-import System.Console.CmdArgs--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L--import Control.Concurrent (forkIO)-import Control.Exception (finally, try, throw)-import Control.Monad (when, forever)--import Data.Char (isDigit)--import Data.Certificate.PEM-import Data.Certificate.X509-import qualified Data.Certificate.KeyRSA as KeyRSA-import qualified Crypto.Cipher.RSA as RSA--import Network.TLS--ciphers :: [Cipher]-ciphers =- [ cipher_AES128_SHA1- , cipher_AES256_SHA1- , cipher_RC4_128_MD5- , cipher_RC4_128_SHA1- ]--loopUntil :: Monad m => m Bool -> m ()-loopUntil f = f >>= \v -> if v then return () else loopUntil f--readOne h = do- r <- try $ hWaitForInput h (-1)- case r of- Left err -> if isEOFError err then return B.empty else throw err- Right True -> B.hGetNonBlocking h 4096- Right False -> return B.empty--tlsclient :: Handle -> TLSCtx -> IO ()-tlsclient srchandle dsthandle = do- hSetBuffering srchandle NoBuffering-- handshake dsthandle-- loopUntil $ do- b <- readOne srchandle- putStrLn ("sending " ++ show b)- if B.null b- then do- bye dsthandle- return True- else do- sendData dsthandle (L.fromChunks [b])- return False- return ()--getRandomGen :: IO SRandomGen-getRandomGen = makeSRandomGen >>= either (fail . show) (return . id)--tlsserver srchandle dsthandle = do- hSetBuffering dsthandle NoBuffering-- handshake srchandle-- loopUntil $ do- d <- recvData srchandle- putStrLn ("received: " ++ show d)- sendData srchandle (L.pack $ map (toEnum . fromEnum) "this is some data")- hFlush (ctxHandle srchandle)- return False- putStrLn "end"--clientProcess certs handle dsthandle _ = do- rng <- getRandomGen-- let serverstate = defaultParams- { pAllowedVersions = [SSL3,TLS10,TLS11]- , pCiphers = ciphers- , pCertificates = certs- , pWantClientCert = False- }- ctx <- server serverstate rng handle- tlsserver ctx dsthandle--readCertificate :: FilePath -> IO X509-readCertificate filepath = do- content <- B.readFile filepath- let certdata = case parsePEMCert content of- Nothing -> error ("no valid certificate section")- Just x -> x- let cert = case decodeCertificate $ L.fromChunks [certdata] of- Left err -> error ("cannot decode certificate: " ++ err)- Right x -> x- return cert--readPrivateKey :: FilePath -> IO PrivateKey-readPrivateKey filepath = do- content <- B.readFile filepath- let pkdata = case parsePEMKeyRSA content of- Nothing -> error ("no valid RSA key section")- Just x -> L.fromChunks [x]- let pk = case KeyRSA.decodePrivate pkdata of- Left err -> error ("cannot decode key: " ++ err)- Right x -> PrivRSA $ RSA.PrivateKey- { RSA.private_sz = fromIntegral $ KeyRSA.lenmodulus x- , RSA.private_n = KeyRSA.modulus x- , RSA.private_d = KeyRSA.private_exponant x- , RSA.private_p = KeyRSA.p1 x- , RSA.private_q = KeyRSA.p2 x- , RSA.private_dP = KeyRSA.exp1 x- , RSA.private_dQ = KeyRSA.exp2 x- , RSA.private_qinv = KeyRSA.coef x- }- return pk--data Stunnel =- Client- { destinationType :: String- , destination :: String- , sourceType :: String- , source :: String }- | Server- { destinationType :: String- , destination :: String- , sourceType :: String- , source :: String- , certificate :: FilePath- , key :: FilePath }- deriving (Show, Data, Typeable)--clientOpts = Client- { destinationType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "DESTTYPE"- , destination = "localhost:6061" &= help "destination address influenced by destination type" &= typ "ADDRESS"- , sourceType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "SOURCETYPE"- , source = "localhost:6060" &= help "source address influenced by source type" &= typ "ADDRESS"- }- &= help "connect to a remote destination that use SSL/TLS"--serverOpts = Server- { destinationType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "DESTTYPE"- , destination = "localhost:6060" &= help "destination address influenced by destination type" &= typ "ADDRESS"- , sourceType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "SOURCETYPE"- , source = "localhost:6061" &= help "source address influenced by source type" &= typ "ADDRESS"- , certificate = "certificate.pem" &= help "X509 public certificate to use" &= typ "FILE"- , key = "certificate.key" &= help "private key linked to the certificate" &= typ "FILE"- }- &= help "listen for connection that use SSL/TLS and relay it to a different connection"--mode = cmdArgsMode $ modes [clientOpts,serverOpts]- &= help "create SSL/TLS tunnel in client or server mode" &= program "stunnel" &= summary "Stunnel v0.1 (Haskell TLS)"--data StunnelAddr =- AddrSocket Family SockAddr- | AddrFD Handle Handle--data StunnelHandle =- StunnelSocket Socket- | StunnelFd Handle Handle--getAddressDescription :: String -> String -> IO StunnelAddr-getAddressDescription "tcp" desc = do- let (s, p) = break ((==) ':') desc- when (p == "") (error "missing port: expecting [source]:port")- pn <- if and $ map isDigit $ drop 1 p- then return $ fromIntegral $ (read (drop 1 p) :: Int)- else do- service <- getServiceByName (drop 1 p) "tcp"- return $ servicePort service- he <- getHostByName s- return $ AddrSocket AF_INET (SockAddrInet pn (head $ hostAddresses he))--getAddressDescription "unix" desc = do- return $ AddrSocket AF_UNIX (SockAddrUnix desc)--getAddressDescription "fd" _ =- return $ AddrFD stdin stdout--getAddressDescription _ _ = error "unrecognized source type (expecting tcp/unix/fd)"--connectAddressDescription (AddrSocket family sockaddr) = do- sock <- socket family Stream defaultProtocol- catch (connect sock sockaddr)- (\_ -> sClose sock >> error ("cannot open socket " ++ show sockaddr))- return $ StunnelSocket sock--connectAddressDescription (AddrFD h1 h2) = do- return $ StunnelFd h1 h2--listenAddressDescription (AddrSocket family sockaddr) = do- sock <- socket family Stream defaultProtocol- catch (bindSocket sock sockaddr >> listen sock 10 >> setSocketOption sock ReuseAddr 1)- (\_ -> sClose sock >> error ("cannot open socket " ++ show sockaddr))- return $ StunnelSocket sock--listenAddressDescription (AddrFD _ _) = do- error "cannot listen on fd"--doClient :: Stunnel -> IO ()-doClient pargs = do- srcaddr <- getAddressDescription (sourceType pargs) (source pargs)- dstaddr <- getAddressDescription (destinationType pargs) (destination pargs)-- let clientstate = defaultParams- { pConnectVersion = TLS10- , pAllowedVersions = [ TLS10, TLS11 ]- , pCiphers = ciphers- , pCertificates = []- }-- case srcaddr of- AddrSocket _ _ -> do- (StunnelSocket srcsocket) <- listenAddressDescription srcaddr- forever $ do- (s, _) <- accept srcsocket- rng <- getRandomGen- srch <- socketToHandle s ReadWriteMode-- (StunnelSocket dst) <- connectAddressDescription dstaddr-- dsth <- socketToHandle dst ReadWriteMode- dstctx <- client clientstate rng dsth- _ <- forkIO $ finally- (tlsclient srch dstctx)- (hClose srch >> hClose dsth)- return ()- AddrFD _ _ -> error "bad error fd. not implemented"--doServer :: Stunnel -> IO ()-doServer pargs = do- cert <- readCertificate $ certificate pargs- pk <- readPrivateKey $ key pargs- srcaddr <- getAddressDescription (sourceType pargs) (source pargs)- dstaddr <- getAddressDescription (destinationType pargs) (destination pargs)-- case srcaddr of- AddrSocket _ _ -> do- (StunnelSocket srcsocket) <- listenAddressDescription srcaddr- forever $ do- (s, addr) <- accept srcsocket- srch <- socketToHandle s ReadWriteMode- (StunnelSocket dst) <- connectAddressDescription dstaddr- dsth <- socketToHandle dst ReadWriteMode- _ <- forkIO $ finally- (clientProcess [(cert, Just pk)] srch dsth addr >> return ())- (hClose srch >> hClose dsth)- return ()- AddrFD _ _ -> error "bad error fd. not implemented"--main :: IO ()-main = do- x <- cmdArgsRun mode- case x of- Client _ _ _ _ -> doClient x- Server _ _ _ _ _ _ -> doServer x
Tests.hs view
@@ -1,10 +1,115 @@ {-# LANGUAGE CPP #-} -import qualified Tests.Marshal as Marshal-import qualified Tests.Connection as Connection-import qualified Tests.Ciphers as Ciphers+import Test.QuickCheck+import Test.QuickCheck.Test +import Tests.Certificate++import Data.Word+import Data.Certificate.X509++import qualified Data.ByteString as B+import Network.TLS.Struct+import Network.TLS.Packet+import Control.Monad+import Control.Applicative ((<$>))+import System.IO++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 = liftM3 Header arbitrary arbitrary arbitrary++instance Arbitrary ClientRandom where+ arbitrary = liftM ClientRandom (genByteString 32)++instance Arbitrary ServerRandom where+ arbitrary = liftM ServerRandom (genByteString 32)++instance Arbitrary ClientKeyData where+ arbitrary = liftM ClientKeyData (genByteString 46)++instance Arbitrary Session where+ arbitrary = do+ i <- choose (1,2) :: Gen Int+ case i of+ 1 -> return $ Session Nothing+ 2 -> liftM (Session . Just) (genByteString 32)++arbitraryCiphersIDs :: Gen [Word16]+arbitraryCiphersIDs = choose (0,200) >>= vector++arbitraryCompressionIDs :: Gen [Word8]+arbitraryCompressionIDs = choose (0,200) >>= vector++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 ]++-- we hardcode the pubkey for generated X509. at later stage this will be generated as well.+pubkey = PubKeyRSA (1,2,3)++instance Arbitrary Handshake where+ arbitrary = oneof+ [ liftM6 ClientHello arbitrary arbitrary arbitrary arbitraryCiphersIDs arbitraryCompressionIDs (return Nothing)+ , liftM6 ServerHello arbitrary arbitrary arbitrary arbitrary arbitrary (return Nothing)+ , liftM Certificates (resize 2 $ listOf $ arbitraryX509 pubkey)+ , return HelloRequest+ , return ServerHelloDone+ , liftM2 ClientKeyXchg arbitrary arbitrary+ --, liftM ServerKeyXchg+ --, liftM3 CertRequest arbitrary (return Nothing) (return [])+ --, liftM CertVerify (return [])+ , liftM Finished (vector 12)+ ]++{- quickcheck property -}++prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x+prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x+ where+ decodeHs b = either (Left . id) (uncurry (decodeHandshake TLS10) . head) $ decodeHandshakes b+--import qualified Tests.Connection as Connection+--import qualified Tests.Ciphers as Ciphers++myQuickCheckArgs = stdArgs+ { replay = Nothing+ , maxSuccess = 500+ , maxDiscard = 2000+ , maxSize = 500+ }++run_test n t =+ putStr (" " ++ n ++ " ... ") >> hFlush stdout >> quickCheckWith myQuickCheckArgs t++liftM6 f m1 m2 m3 m4 m5 m6 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6) }+ main = do- Marshal.runTests- Ciphers.runTests- Connection.runTests+ run_test "marshalling header = id" prop_header_marshalling_id+ run_test "marshalling handshake = id" prop_handshake_marshalling_id+ --Marshal.runTests+ --Ciphers.runTests+ --Connection.runTests
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 0.4.1+Version: 0.5.0 Description: native TLS protocol implementation, focusing on purity and more type-checking. .@@ -36,13 +36,13 @@ , binary >= 0.5 , cereal >= 0.3 , bytestring- , vector , crypto-api >= 0.5 , cryptocipher >= 0.2.5 , certificate >= 0.7 && < 0.8 Exposed-modules: Network.TLS Network.TLS.Cipher Network.TLS.Compression+ Network.TLS.Internal other-modules: Network.TLS.Cap Network.TLS.SRandom Network.TLS.Struct@@ -56,16 +56,6 @@ Network.TLS.Util Network.TLS.Wire ghc-options: -Wall--Executable stunnel- Main-is: Stunnel.hs- if flag(executable)- Build-Depends: network- , cmdargs- Buildable: True- else- Buildable: False- ghc-options: -Wall -fno-warn-missing-signatures executable Tests Main-is: Tests.hs