tls-debug (empty) → 0.1.0
raw patch · 7 files changed
+728/−0 lines, 7 filesdep +basedep +bytestringdep +certificatesetup-changed
Dependencies added: base, bytestring, certificate, cmdargs, cprng-aes, network, time, tls, tls-extra
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- src/CheckCiphers.hs +169/−0
- src/RetrieveCertificate.hs +90/−0
- src/SimpleClient.hs +78/−0
- src/Stunnel.hs +286/−0
- tls-debug.cabal +76/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2010-2012 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/CheckCiphers.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}++import Network.TLS.Internal+import Network.TLS.Cipher+import Network.TLS++import qualified Crypto.Random.AESCtr as RNG++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++tableCiphers =+ [ (0x0000, "NULL_WITH_NULL_NULL")+ , (0x0001, "RSA_WITH_NULL_MD5")+ , (0x0002, "RSA_WITH_NULL_SHA")+ , (0x003B, "RSA_WITH_NULL_SHA256")+ , (0x0004, "RSA_WITH_RC4_128_MD5")+ , (0x0005, "RSA_WITH_RC4_128_SHA")+ , (0x000A, "RSA_WITH_3DES_EDE_CBC_SHA")+ , (0x002F, "RSA_WITH_AES_128_CBC_SHA")+ , (0x0035, "RSA_WITH_AES_256_CBC_SHA")+ , (0x003C, "RSA_WITH_AES_128_CBC_SHA256")+ , (0x003D, "RSA_WITH_AES_256_CBC_SHA256")+ , (0x000D, "DH_DSS_WITH_3DES_EDE_CBC_SHA")+ , (0x0010, "DH_RSA_WITH_3DES_EDE_CBC_SHA")+ , (0x0013, "DHE_DSS_WITH_3DES_EDE_CBC_SHA")+ , (0x0016, "DHE_RSA_WITH_3DES_EDE_CBC_SHA")+ , (0x0030, "DH_DSS_WITH_AES_128_CBC_SHA")+ , (0x0031, "DH_RSA_WITH_AES_128_CBC_SHA")+ , (0x0032, "DHE_DSS_WITH_AES_128_CBC_SHA")+ , (0x0033, "DHE_RSA_WITH_AES_128_CBC_SHA")+ , (0x0036, "DH_DSS_WITH_AES_256_CBC_SHA")+ , (0x0037, "DH_RSA_WITH_AES_256_CBC_SHA")+ , (0x0038, "DHE_DSS_WITH_AES_256_CBC_SHA")+ , (0x0039, "DHE_RSA_WITH_AES_256_CBC_SHA")+ , (0x003E, "DH_DSS_WITH_AES_128_CBC_SHA256")+ , (0x003F, "DH_RSA_WITH_AES_128_CBC_SHA256")+ , (0x0040, "DHE_DSS_WITH_AES_128_CBC_SHA256")+ , (0x0067, "DHE_RSA_WITH_AES_128_CBC_SHA256")+ , (0x0068, "DH_DSS_WITH_AES_256_CBC_SHA256")+ , (0x0069, "DH_RSA_WITH_AES_256_CBC_SHA256")+ , (0x006A, "DHE_DSS_WITH_AES_256_CBC_SHA256")+ , (0x006B, "DHE_RSA_WITH_AES_256_CBC_SHA256")+ , (0x0018, "DH_anon_WITH_RC4_128_MD5")+ , (0x001B, "DH_anon_WITH_3DES_EDE_CBC_SHA")+ , (0x0034, "DH_anon_WITH_AES_128_CBC_SHA")+ , (0x003A, "DH_anon_WITH_AES_256_CBC_SHA")+ , (0x006C, "DH_anon_WITH_AES_128_CBC_SHA256")+ , (0x006D, "DH_anon_WITH_AES_256_CBC_SHA256")+ ]++fakeCipher cid = Cipher+ { cipherID = cid+ , cipherName = "cipher-" ++ show cid+ , cipherBulk = Bulk+ { bulkName = "fake"+ , bulkKeySize = 0+ , bulkIVSize = 0+ , bulkBlockSize = 0+ , bulkF = undefined+ }+ , cipherKeyExchange = CipherKeyExchange_RSA+ , cipherHash = Hash+ { hashName = "fake"+ , hashSize = 0+ , hashF = undefined+ }+ , cipherMinVer = Nothing+ }++clienthello ciphers = ClientHello TLS10 (ClientRandom $ B.pack [0..31]) (Session Nothing) ciphers [0] []++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++ rng <- RNG.makeSystem+ 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 (Handshake ((ServerHello _ _ _ i _ _):_)) -> return i+ _ -> error ("expecting server hello, 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)+ forM_ supported $ \i -> do+ putStrLn $ maybe ("cipher " ++ show i) id $ lookup i tableCiphers
+ src/RetrieveCertificate.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-}++import Network.TLS+import Network.TLS.Extra++import Data.Char+import Data.IORef+import Data.Time.Clock+import Data.Certificate.X509++import System.IO+import Control.Monad+import Prelude hiding (catch)++import qualified Crypto.Random.AESCtr as RNG++import Text.Printf++import System.Console.CmdArgs++openConnection s p = do+ ref <- newIORef Nothing+ rng <- RNG.makeSystem+ let params = defaultParams+ { pCiphers = ciphersuite_all+ , onCertificatesRecv = \l -> do+ modifyIORef ref (const $ Just l)+ return CertificateUsageAccept+ }+ ctx <- connectionClient s p params rng+ _ <- handshake ctx+ bye ctx+ r <- readIORef ref+ case r of+ Nothing -> error "cannot retrieve any certificate"+ Just certs -> return certs++data PArgs = PArgs+ { destination :: String+ , port :: String+ , chain :: Bool+ , output :: String+ , verify :: Bool+ , verifyFQDN :: String+ } 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"+ , chain = False &= help "also output the chain of certificate used"+ , output = "simple" &= help "define the format of output (full, pem, default: simple)" &= typ "format"+ , verify = False &= help "verify the chain received with the trusted system certificates"+ , verifyFQDN = "" &= help "verify the chain against a specific fully qualified domain name (e.g. web.example.com)" &= explicit &= name "verify-domain-name"+ } &= summary "RetrieveCertificate remotely for SSL/TLS protocol"+ &= details+ [ "Retrieve the remote certificate and optionally its chain from a remote destination"+ ]++showCert "full" cert = putStrLn $ show cert++showCert _ (x509Cert -> cert) = do+ putStrLn ("serial: " ++ (show $ certSerial cert))+ putStrLn ("issuer: " ++ (show $ certIssuerDN cert))+ putStrLn ("subject: " ++ (show $ certSubjectDN cert))+ putStrLn ("validity: " ++ (show $ fst $ certValidity cert) ++ " to " ++ (show $ snd $ certValidity cert))++main = do+ a <- cmdArgs progArgs+ _ <- printf "connecting to %s on port %s ...\n" (destination a) (port a)++ certs <- openConnection (destination a) (port a)+ case (chain a) of+ True ->+ forM_ (zip [0..] certs) $ \(n, cert) -> do+ putStrLn ("###### Certificate " ++ show (n + 1 :: Int) ++ " ######")+ showCert (output a) cert+ False ->+ showCert (output a) $ head certs++ when (verify a) $ do+ putStrLn "### certificate chain trust"+ ctime <- utctDay `fmap` getCurrentTime+ certificateVerifyChain certs >>= showUsage "chain validity"+ showUsage "time validity" (certificateVerifyValidity ctime certs)+ when (verifyFQDN a /= "") $+ showUsage "fqdn match" (certificateVerifyDomain (verifyFQDN a) certs)+ where+ showUsage :: String -> TLSCertificateUsage -> IO ()+ showUsage s CertificateUsageAccept = printf "%s : accepted\n" s+ showUsage s (CertificateUsageReject r) = printf "%s : rejected: %s\n" s (show r)
+ src/SimpleClient.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+import Network.BSD+import Network.Socket+import Network.TLS+import Network.TLS.Extra+import System.IO+import qualified Crypto.Random.AESCtr as RNG+import qualified Data.ByteString.Lazy.Char8 as LC+import Control.Exception+import System.Environment+import Prelude hiding (catch)++import Data.IORef++validateCert = True+debug = False++ciphers :: [Cipher]+ciphers =+ [ cipher_AES128_SHA1+ , cipher_AES256_SHA1+ , cipher_RC4_128_MD5+ , cipher_RC4_128_SHA1+ ]++runTLS params hostname portNumber f = do+ rng <- RNG.makeSystem+ he <- getHostByName hostname+ sock <- socket AF_INET Stream defaultProtocol+ let sockaddr = SockAddrInet portNumber (head $ hostAddresses he)+ catch (connect sock sockaddr)+ (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e))+ dsth <- socketToHandle sock ReadWriteMode+ ctx <- client params rng dsth+ f ctx+ hClose dsth++getDefaultParams sStorage session = defaultParams+ { pConnectVersion = TLS10+ , pAllowedVersions = [TLS10,TLS11,TLS12]+ , pCiphers = ciphers+ , pCertificates = []+ , pLogging = logging+ , onCertificatesRecv = crecv+ , onSessionEstablished = \s d -> writeIORef sStorage (s,d)+ , sessionResumeWith = session+ }+ where+ logging = if not debug then defaultLogging else defaultLogging+ { loggingPacketSent = putStrLn . ("debug: >> " ++)+ , loggingPacketRecv = putStrLn . ("debug: << " ++)+ }+ crecv = if validateCert then certificateVerifyChain else (\_ -> return CertificateUsageAccept)+++main = do+ sStorage <- newIORef undefined+ args <- getArgs+ let hostname = args !! 0+ let port = read (args !! 1) :: Int+ runTLS (getDefaultParams sStorage Nothing) hostname (fromIntegral port) $ \ctx -> do+ handshake ctx+ sendData ctx $ LC.pack "GET / HTTP/1.0\r\n\r\n"+ d <- recvData' ctx+ bye ctx+ LC.putStrLn d+ return ()+{-+ session <- readIORef sStorage+ runTLS (getDefaultParams sStorage $ Just session) hostname port $ \ctx -> do+ handshake ctx+ sendData ctx $ LC.pack "GET / HTTP/1.0\r\n\r\n"+ d <- recvData ctx+ bye ctx+ LC.putStrLn d+ return ()+-}
+ src/Stunnel.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+import Network.BSD+import Network.Socket+import System.IO+import System.IO.Error hiding (try, catch)+import System.Console.CmdArgs++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar+import Control.Exception (finally, try, throw, catch, SomeException)+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.Random.AESCtr as RNG+import Network.TLS+import Network.TLS.Extra++import Prelude hiding (catch)++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 Handle -> IO ()+tlsclient srchandle dsthandle = do+ hSetBuffering srchandle NoBuffering++ handshake dsthandle++ _ <- forkIO $ forever $ do+ dat <- recvData dsthandle+ putStrLn ("received " ++ show dat)+ B.hPut srchandle dat+ 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 ()++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 (ctxConnection srchandle)+ return False+ putStrLn "end"++clientProcess certs handle dsthandle dbg sessionStorage _ = do+ rng <- RNG.makeSystem+ let logging = if not dbg then defaultLogging else defaultLogging+ { loggingPacketSent = putStrLn . ("debug: send: " ++)+ , loggingPacketRecv = putStrLn . ("debug: recv: " ++)+ }++ let serverstate = defaultParams+ { pAllowedVersions = [SSL3,TLS10,TLS11,TLS12]+ , pCiphers = ciphers+ , pCertificates = certs+ , pWantClientCert = False+ , pLogging = logging+ }+ let serverState' = case sessionStorage of+ Nothing -> serverstate+ Just storage -> serverstate+ { onSessionResumption = \s -> withMVar storage (return . lookup s)+ , onSessionEstablished = \s d -> modifyMVar_ storage (\l -> return $ (s,d) : l)+ }++ 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]+ case KeyRSA.decodePrivate pkdata of+ Left err -> error ("cannot decode key: " ++ err)+ Right (_,pk) -> return $ PrivRSA pk++data Stunnel =+ Client+ { destinationType :: String+ , destination :: String+ , sourceType :: String+ , source :: String+ , debug :: Bool+ , validCert :: Bool }+ | Server+ { destinationType :: String+ , destination :: String+ , sourceType :: String+ , source :: String+ , debug :: Bool+ , disableSession :: Bool+ , 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"+ , debug = False &= help "debug the TLS protocol printing debugging to stdout" &= typ "Bool"+ , validCert = False &= help "check if the certificate receive is valid" &= typ "Bool"+ }+ &= 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"+ , disableSession = False &= help "disable support for session" &= typ "Bool"+ , debug = False &= help "debug the TLS protocol printing debugging to stdout" &= typ "Bool"+ , 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)+ (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e))+ 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)+ (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e))+ 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 logging = if not $ debug pargs then defaultLogging else defaultLogging+ { loggingPacketSent = putStrLn . ("debug: send: " ++)+ , loggingPacketRecv = putStrLn . ("debug: recv: " ++)+ }++ let crecv = if validCert pargs then certificateVerifyChain else (\_ -> return CertificateUsageAccept)+ let clientstate = defaultParams+ { pConnectVersion = TLS10+ , pAllowedVersions = [TLS10,TLS11,TLS12]+ , pCiphers = ciphers+ , pCertificates = []+ , pLogging = logging+ , onCertificatesRecv = crecv+ }++ case srcaddr of+ AddrSocket _ _ -> do+ (StunnelSocket srcsocket) <- listenAddressDescription srcaddr+ forever $ do+ (s, _) <- accept srcsocket+ rng <- RNG.makeSystem+ 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)++ sessionStorage <- if disableSession pargs then return Nothing else (Just `fmap` newMVar [])++ case srcaddr of+ AddrSocket _ _ -> do+ (StunnelSocket srcsocket) <- listenAddressDescription srcaddr+ forever $ do+ (s, addr) <- accept srcsocket+ srch <- socketToHandle s ReadWriteMode+ r <- connectAddressDescription dstaddr+ dsth <- case r of+ StunnelFd _ _ -> return stdout+ StunnelSocket dst -> socketToHandle dst ReadWriteMode++ _ <- forkIO $ finally+ (clientProcess [(cert, Just pk)] srch dsth (debug pargs) sessionStorage addr >> return ())+ (hClose srch >> (when (dsth /= stdout) $ 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
+ tls-debug.cabal view
@@ -0,0 +1,76 @@+Name: tls-debug+Version: 0.1.0+Description:+ A set of program to test and debug various aspect of the TLS package.+ .+License: BSD3+License-file: LICENSE+Copyright: Vincent Hanquez <vincent@snarc.org>+Author: Vincent Hanquez <vincent@snarc.org>+Maintainer: Vincent Hanquez <vincent@snarc.org>+Synopsis: Set of programs for TLS testing and debugging+Build-Type: Simple+Category: Network+stability: experimental+Cabal-Version: >=1.6+Homepage: http://github.com/vincenthz/hs-tls-debug++Executable tls-stunnel+ Main-is: Stunnel.hs+ Hs-Source-Dirs: src+ Build-Depends: base >= 4 && < 5+ , network+ , bytestring+ , cmdargs+ , certificate >= 1.0+ , cprng-aes >= 0.2.3+ , tls >= 0.9.0 && < 1.0+ , tls-extra >= 0.4.3 && < 0.5.0+ Buildable: True+ ghc-options: -Wall -fno-warn-missing-signatures++Executable tls-checkciphers+ Main-is: CheckCiphers.hs+ Hs-Source-Dirs: src+ Build-Depends: base >= 4 && < 5+ , network+ , bytestring+ , cprng-aes+ , certificate >= 1.0+ , tls >= 0.9.0 && < 1.0+ , tls-extra >= 0.4.3 && < 0.5.0+ Buildable: True+ ghc-options: -Wall -fno-warn-missing-signatures++Executable tls-retrievecertificate+ Main-is: RetrieveCertificate.hs+ Hs-Source-Dirs: src+ Build-Depends: base >= 4 && < 5+ , network+ , bytestring+ , cmdargs+ , time+ , cprng-aes >= 0.2.3+ , certificate >= 1.0+ , tls >= 0.9.0 && < 1.0+ , tls-extra >= 0.4.3 && < 0.5.0+ Buildable: True+ ghc-options: -Wall -fno-warn-missing-signatures++Executable tls-simpleclient+ Main-is: SimpleClient.hs+ Hs-Source-Dirs: src+ Build-Depends: base >= 4 && < 5+ , network+ , bytestring+ , cmdargs+ , cprng-aes >= 0.2.3+ , certificate >= 1.0+ , tls >= 0.9.0 && < 1.0+ , tls-extra >= 0.4.3 && < 0.5.0+ Buildable: True+ ghc-options: -Wall -fno-warn-missing-signatures++source-repository head+ type: git+ location: git://github.com/vincenthz/hs-tls-debug