Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

initial import (mostly imported from tls 0.4)

  • Loading branch information...
commit bd3c9546a45aba814c5e5119e9cdd9e63ebf7d97 0 parents
@vincenthz authored
123 Examples/CheckCiphers.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
+
+import Network.TLS.Internal
+import Network.TLS.Cipher
+import Network.TLS
+
+import qualified Data.ByteString as B
+import Data.Word
+import Data.Char
+
+import Network.Socket
+import Network.BSD
+import System.IO
+import Control.Monad
+import Control.Applicative ((<$>))
+import Control.Concurrent
+import Control.Exception (catch, SomeException(..))
+import Prelude hiding (catch)
+
+import Text.Printf
+
+import System.Console.CmdArgs
+
+fakeCipher cid = Cipher
+ { cipherID = cid
+ , cipherName = "cipher-" ++ show cid
+ , cipherDigestSize = 0
+ , cipherKeySize = 0
+ , cipherIVSize = 0
+ , cipherKeyBlockSize = 0
+ , cipherPaddingSize = 0
+ , cipherKeyExchange = CipherKeyExchangeRSA
+ , cipherMACHash = (\_ -> undefined)
+ , cipherF = undefined
+ , cipherMinVer = Nothing
+ }
+
+clienthello ciphers = ClientHello TLS10 (ClientRandom $ B.pack [0..31]) (Session Nothing) ciphers [0] Nothing
+
+openConnection :: String -> String -> [Word16] -> IO (Maybe Word16)
+openConnection s p ciphers = do
+ pn <- if and $ map isDigit $ p
+ then return $ fromIntegral $ (read p :: Int)
+ else do
+ service <- getServiceByName p "tcp"
+ return $ servicePort service
+ he <- getHostByName s
+ sock <- socket AF_INET Stream defaultProtocol
+ connect sock (SockAddrInet pn (head $ hostAddresses he))
+ handle <- socketToHandle sock ReadWriteMode
+
+ (Right rng) <- makeSRandomGen
+ let params = defaultParams { pCiphers = map fakeCipher ciphers }
+ ctx <- client params rng handle
+ sendPacket ctx $ Handshake $ clienthello ciphers
+ catch (do
+ rpkt <- recvPacket ctx
+ ccid <- case rpkt of
+ Right (h:_) -> case h of
+ (Handshake (ServerHello _ _ _ i _ _)) -> return i
+ _ -> error "didn't received serverhello"
+ _ -> error ("packet received: " ++ show rpkt)
+ bye ctx
+ hClose handle
+ return $ Just ccid
+ ) (\(_ :: SomeException) -> return Nothing)
+
+connectRange :: String -> String -> Int -> [Word16] -> IO (Int, [Word16])
+connectRange d p v r = do
+ ccidopt <- openConnection d p r
+ threadDelay v
+ case ccidopt of
+ Nothing -> return (1, [])
+ Just ccid -> do
+ {-divide and conquer TLS-}
+ let newr = filter ((/=) ccid) r
+ let (lr, rr) = if length newr > 2
+ then splitAt (length newr `div` 2) newr
+ else (newr, [])
+ (lc, ls) <- if length lr > 0
+ then connectRange d p v lr
+ else return (0,[])
+ (rc, rs) <- if length rr > 0
+ then connectRange d p v rr
+ else return (0,[])
+ return (1 + lc + rc, [ccid] ++ ls ++ rs)
+
+connectBetween d p v chunkSize ep sp = concat <$> loop sp where
+ loop a = liftM2 (:) (snd <$> connectRange d p v range)
+ (if a + chunkSize > ep then return [] else loop (a+64))
+ where
+ range = if a + chunkSize > ep
+ then [a..ep]
+ else [a..sp+chunkSize]
+
+data PArgs = PArgs
+ { destination :: String
+ , port :: String
+ , speed :: Int
+ , start :: Int
+ , end :: Int
+ , nb :: Int
+ } deriving (Show, Data, Typeable)
+
+progArgs = PArgs
+ { destination = "localhost" &= help "destination address to connect to" &= typ "address"
+ , port = "443" &= help "destination port to connect to" &= typ "port"
+ , speed = 100 &= help "speed between queries, in milliseconds" &= typ "speed"
+ , start = 0 &= help "starting cipher number (between 0 and 65535)" &= typ "cipher"
+ , end = 0xff &= help "end cipher number (between 0 and 65535)" &= typ "cipher"
+ , nb = 64 &= help "number of cipher to include per query " &= typ "range"
+ } &= summary "CheckCiphers -- SSL/TLS remotely check supported cipher"
+ &= details
+ [ "check the supported cipher of a remote destination."
+ , "Beware: this program make multiple connections to the destination"
+ , "which might be taken by the remote side as aggressive behavior"
+ ]
+
+main = do
+ a <- cmdArgs progArgs
+ _ <- printf "connecting to %s on port %s ...\n" (destination a) (port a)
+ supported <- connectBetween (destination a) (port a) (speed a) (fromIntegral $ nb a) (fromIntegral $ end a) (fromIntegral $ start a)
+ putStrLn $ show supported
258 Examples/Stunnel.hs
@@ -0,0 +1,258 @@
+{-# 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
+import Network.TLS.Extra
+
+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
27 LICENSE
@@ -0,0 +1,27 @@
+Copyright (c) 2010 Vincent Hanquez <vincent@snarc.org>
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.
5 Network/TLS/Extra.hs
@@ -0,0 +1,5 @@
+module Network.TLS.Extra
+ ( module Network.TLS.Extra.Cipher
+ ) where
+
+import Network.TLS.Extra.Cipher
234 Network/TLS/Extra/Cipher.hs
@@ -0,0 +1,234 @@
+-- |
+-- Module : Network.TLS.Extra.Cipher
+-- License : BSD-style
+-- Maintainer : Vincent Hanquez <vincent@snarc.org>
+-- Stability : experimental
+-- Portability : unknown
+--
+module Network.TLS.Extra.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
+ ) where
+
+import qualified Data.Vector.Unboxed as Vector (fromList, toList)
+import qualified Data.ByteString as B
+
+import Network.TLS (Version(..))
+import Network.TLS.Cipher
+import qualified Crypto.Cipher.AES as AES
+import qualified Crypto.Cipher.RC4 as RC4
+
+import qualified Crypto.Hash.SHA256 as SHA256
+import qualified Crypto.Hash.SHA1 as SHA1
+import qualified Crypto.Hash.MD5 as MD5
+
+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
+
+
+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
+ }
+
+{-
+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 };
+-}
2  Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
8 Tests.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE CPP #-}
+
+import qualified Tests.Connection as Connection
+import qualified Tests.Ciphers as Ciphers
+
+main = do
+ Ciphers.runTests
+ Connection.runTests
48 Tests/Certificate.hs
@@ -0,0 +1,48 @@
+module Tests.Certificate
+ ( arbitraryX509
+ ) where
+
+import Test.QuickCheck
+import qualified Data.Certificate.X509 as X509
+import qualified Data.Certificate.X509Cert as X509Cert
+import Control.Monad
+
+readableChar :: Gen Char
+readableChar = elements (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'])
+
+arbitraryDN = return []
+
+arbitraryTime = do
+ year <- choose (1951, 2050)
+ month <- choose (1, 12)
+ day <- choose (1, 30)
+ hour <- choose (0, 23)
+ minute <- choose (0, 59)
+ second <- choose (0, 59)
+ z <- arbitrary
+ return (year, month, day, hour, minute, second, z)
+
+arbitraryX509Cert pubKey = do
+ version <- choose (1,3)
+ serial <- choose (0,2^24)
+ issuerdn <- arbitraryDN
+ subjectdn <- arbitraryDN
+ time1 <- arbitraryTime
+ time2 <- arbitraryTime
+ let sigalg = X509.SignatureALG_md5WithRSAEncryption
+ return $ X509Cert.Certificate
+ { X509.certVersion = version
+ , X509.certSerial = serial
+ , X509.certSignatureAlg = sigalg
+ , X509.certIssuerDN = issuerdn
+ , X509.certSubjectDN = subjectdn
+ , X509.certValidity = (time1, time2)
+ , X509.certPubKey = pubKey
+ , X509.certExtensions = Nothing
+ }
+
+arbitraryX509 pubKey = do
+ cert <- arbitraryX509Cert pubKey
+ sig <- resize 40 $ listOf1 arbitrary
+ let sigalg = X509.SignatureALG_md5WithRSAEncryption
+ return (X509.X509 cert Nothing sigalg sig)
42 Tests/Ciphers.hs
@@ -0,0 +1,42 @@
+module Tests.Ciphers
+ ( runTests
+ ) where
+
+import Data.Word
+import Control.Applicative ((<$>))
+
+import Tests.Common
+import Test.QuickCheck
+
+import qualified Data.ByteString as B
+import Network.TLS.Cipher
+
+arbitraryKey :: Cipher -> Gen [Word8]
+arbitraryKey cipher = vector (fromIntegral $ cipherKeySize cipher)
+
+arbitraryIV :: Cipher -> Gen [Word8]
+arbitraryIV cipher = vector (fromIntegral $ cipherIVSize cipher)
+
+arbitraryText :: Cipher -> Gen [Word8]
+arbitraryText cipher = vector (fromIntegral $ cipherPaddingSize cipher)
+
+cipher_test cipher = run_test n t
+ where
+ n = ("cipher: " ++ cipherName cipher ++ ": decrypt . encrypt = id")
+ t = case cipherF cipher of
+ CipherBlockF enc dec -> do
+ key <- B.pack <$> arbitraryKey cipher
+ iv <- B.pack <$> arbitraryIV cipher
+ t <- B.pack <$> arbitraryText cipher
+ return $ block enc dec key iv t
+ CipherStreamF ktoi enc dec -> do
+ key <- B.pack <$> arbitraryKey cipher
+ t <- B.pack <$> arbitraryText cipher
+ return $ stream ktoi enc dec key t
+ CipherNoneF -> do
+ return True
+ block e d key iv t = (d key iv . e key iv) t == t
+ stream ktoi e d key t = (fst . d iv . fst . e iv) t == t
+ where iv = ktoi key
+
+runTests = mapM_ cipher_test supportedCiphers
33 Tests/Common.hs
@@ -0,0 +1,33 @@
+module Tests.Common where
+
+import System.IO
+import Test.QuickCheck
+import Network.TLS (Version(..))
+import Network.TLS.Cipher
+import Network.TLS.Extra
+
+supportedVersions :: [Version]
+supportedVersions = [SSL3, TLS10, TLS11]
+
+supportedCiphers :: [Cipher]
+supportedCiphers =
+ [ cipher_null_MD5
+ , cipher_null_SHA1
+ , cipher_AES128_SHA1
+ , cipher_AES256_SHA1
+ , cipher_RC4_128_MD5
+ , cipher_RC4_128_SHA1
+ ]
+
+{- main -}
+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) }
180 Tests/Connection.hs
@@ -0,0 +1,180 @@
+{-# LANGUAGE CPP #-}
+
+module Tests.Connection (runTests) where
+
+import Test.QuickCheck
+import Test.QuickCheck.Test
+import Test.QuickCheck.Monadic as QM
+
+import Tests.Common
+import Tests.Certificate
+
+import Text.Printf
+import Data.Word
+import Test.QuickCheck
+import Test.QuickCheck.Test
+import Test.QuickCheck.Monadic as QM
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+
+import Data.Certificate.PEM
+import Data.Certificate.X509
+import qualified Data.Certificate.KeyRSA as KeyRSA
+--import Network.TLS.Crypto
+--import Network.TLS.Cipher
+import Network.TLS
+import Control.Monad
+import Control.Monad.Trans (lift)
+import Control.Applicative ((<$>))
+import Control.Concurrent.Chan
+import Control.Concurrent
+import Control.Exception (catch, throw, SomeException)
+import System.IO
+
+import Network.Socket
+
+import qualified Data.Certificate.KeyRSA as KeyRSA
+import qualified Crypto.Cipher.RSA as RSA
+
+import Prelude hiding (catch)
+
+someWords8 :: Int -> Gen [Word8]
+someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int))
+
+#if MIN_VERSION_QuickCheck(2,3,0)
+#else
+instance Arbitrary Word8 where
+ arbitrary = fromIntegral <$> (choose (0,255) :: Gen Int)
+#endif
+
+{- helpers to prepare the tests -}
+getRandomGen :: IO SRandomGen
+getRandomGen = makeSRandomGen >>= either (fail . show) (return . id)
+
+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
+
+arbitraryVersions :: Gen [Version]
+arbitraryVersions = resize (length supportedVersions + 1) $ listOf1 (elements supportedVersions)
+arbitraryCiphers = resize (length supportedCiphers + 1) $ listOf1 (elements supportedCiphers)
+
+{- | create a client params and server params that is supposed to
+ - result in a valid connection -}
+makeValidParams serverCerts = do
+ -- it should also generate certificates, key exchange parameters
+ -- here instead of taking them from outside.
+ -- cert <- arbitraryX509 (PubKey SignatureALG_rsa (PubKeyRSA (0,0,0)))
+ allowedVersions <- arbitraryVersions
+ connectVersion <- elements supportedVersions `suchThat` (\c -> c `elem` allowedVersions)
+
+ serverCiphers <- arbitraryCiphers
+ clientCiphers <- oneof [arbitraryCiphers] `suchThat`
+ (\cs -> or [x `elem` serverCiphers | x <- cs])
+
+ let serverState = defaultParams
+ { pAllowedVersions = allowedVersions
+ , pCiphers = serverCiphers
+ , pCertificates = serverCerts
+ }
+
+ let clientState = defaultParams
+ { pConnectVersion = connectVersion
+ , pAllowedVersions = allowedVersions
+ , pCiphers = clientCiphers
+ }
+
+ return (clientState, serverState)
+
+{- | setup create all necessary connection point to create a data "pipe"
+ - ---(startQueue)---> tlsClient ---(socketPair)---> tlsServer ---(resultQueue)--->
+ -}
+setup :: (TLSParams, TLSParams) -> IO (TLSCtx, TLSCtx, Chan a, Chan a)
+setup (clientState, serverState) = do
+ (cSocket, sSocket) <- socketPair AF_UNIX Stream defaultProtocol
+ cHandle <- socketToHandle cSocket ReadWriteMode
+ sHandle <- socketToHandle sSocket ReadWriteMode
+
+ hSetBuffering cHandle NoBuffering
+ hSetBuffering sHandle NoBuffering
+
+ clientRNG <- getRandomGen
+ serverRNG <- getRandomGen
+ startQueue <- newChan
+ resultQueue <- newChan
+
+ cCtx <- client clientState clientRNG cHandle
+ sCtx <- server serverState serverRNG sHandle
+
+ return (cCtx, sCtx, startQueue, resultQueue)
+
+testInitiate spCert = do
+ states <- pick (makeValidParams spCert)
+ (cCtx, sCtx, startQueue, resultQueue) <- run (setup states)
+
+ run $ forkIO $ do
+ catch (tlsServer sCtx resultQueue)
+ (\e -> putStrLn ("server exception: " ++ show e) >> throw (e :: SomeException))
+ return ()
+ run $ forkIO $ do
+ catch (tlsClient startQueue cCtx)
+ (\e -> putStrLn ("client exception: " ++ show e) >> throw (e :: SomeException))
+ return ()
+
+ {- the test involves writing data on one side of the data "pipe" and
+ - then checking we receive them on the other side of the data "pipe" -}
+ d <- L.pack <$> pick (someWords8 256)
+ run $ writeChan startQueue d
+
+ dres <- run $ readChan resultQueue
+ assert $ d == dres
+
+ -- cleanup
+ run $ (hClose (ctxHandle cCtx) >> hClose (ctxHandle sCtx))
+
+ where
+ tlsServer handle queue = do
+ handshake handle
+ d <- recvData handle
+ writeChan queue d
+ return ()
+ tlsClient queue handle = do
+ handshake handle
+ d <- readChan queue
+ sendData handle d
+ return ()
+
+runTests = do
+ {- FIXME generate the certificate and key with arbitrary, for now rely on special files -}
+ cert <- readCertificate "host.cert"
+ pk <- readPrivateKey "host.key"
+
+ run_test "initiate" (monadicIO $ testInitiate [(cert, Just pk)])
99 Tests/Marshal.hs
@@ -0,0 +1,99 @@
+{-# LANGUAGE CPP #-}
+module Tests.Marshal (runTests) where
+
+import Test.QuickCheck
+import Test.QuickCheck.Test
+
+import Tests.Common
+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 ((<$>))
+
+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
+
+runTests = do
+ run_test "marshalling header = id" prop_header_marshalling_id
+ run_test "marshalling handshake = id" prop_handshake_marshalling_id
78 tls-extra.cabal
@@ -0,0 +1,78 @@
+Name: tls-extra
+Version: 0.1.0
+Description:
+ a set of extra definitions, default values and helpers for tls.
+License: BSD3
+License-file: LICENSE
+Copyright: Vincent Hanquez <vincent@snarc.org>
+Author: Vincent Hanquez <vincent@snarc.org>
+Maintainer: Vincent Hanquez <vincent@snarc.org>
+Synopsis: TLS extra default values and helpers
+Build-Type: Simple
+Category: Network
+stability: experimental
+Cabal-Version: >=1.6
+Homepage: http://github.com/vincenthz/hs-tls-extra
+
+Flag test
+ Description: Build unit test
+ Default: False
+
+Flag bench
+ Description: Build benchmarks
+ Default: False
+
+Flag executable
+ Description: Build the executable
+ Default: False
+
+Library
+ Build-Depends: tls >= 0.5 && < 0.6
+ , mtl
+ , cryptohash >= 0.6
+ , bytestring
+ , vector
+ , crypto-api >= 0.5
+ , cryptocipher >= 0.2.5
+ , certificate >= 0.7 && < 0.8
+ Exposed-modules: Network.TLS.Extra
+ other-modules: Network.TLS.Extra.Certificate
+ Network.TLS.Extra.Cipher
+ Network.TLS.Extra.Compression
+ Network.TLS.Extra.Thread
+ ghc-options: -Wall
+
+Executable stunnel
+ Main-is: Examples/Stunnel.hs
+ if flag(executable)
+ Build-Depends: network
+ , cmdargs
+ Buildable: True
+ else
+ Buildable: False
+ ghc-options: -Wall -fno-warn-missing-signatures
+
+Executable checkciphers
+ Main-is: Examples/CheckCiphers.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
+ if flag(test)
+ Buildable: True
+ Build-Depends: base >= 3 && < 5
+ , HUnit
+ , QuickCheck >= 2
+ , bytestring
+ else
+ Buildable: False
+
+source-repository head
+ type: git
+ location: git://github.com/vincenthz/hs-tls-extra
Please sign in to comment.
Something went wrong with that request. Please try again.