diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -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 diff --git a/Network/TLS/Cipher.hs b/Network/TLS/Cipher.hs --- a/Network/TLS/Cipher.hs +++ b/Network/TLS/Cipher.hs @@ -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 - } diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -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" diff --git a/Network/TLS/Internal.hs b/Network/TLS/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Internal.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Network.TLS.Internal +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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) diff --git a/Stunnel.hs b/Stunnel.hs deleted file mode 100644 --- a/Stunnel.hs +++ /dev/null @@ -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 diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -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 diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -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