diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2010-2012 Vincent Hanquez + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/CheckCiphers.hs b/src/CheckCiphers.hs new file mode 100644 --- /dev/null +++ b/src/CheckCiphers.hs @@ -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 diff --git a/src/RetrieveCertificate.hs b/src/RetrieveCertificate.hs new file mode 100644 --- /dev/null +++ b/src/RetrieveCertificate.hs @@ -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) diff --git a/src/SimpleClient.hs b/src/SimpleClient.hs new file mode 100644 --- /dev/null +++ b/src/SimpleClient.hs @@ -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 () +-} diff --git a/src/Stunnel.hs b/src/Stunnel.hs new file mode 100644 --- /dev/null +++ b/src/Stunnel.hs @@ -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 diff --git a/tls-debug.cabal b/tls-debug.cabal new file mode 100644 --- /dev/null +++ b/tls-debug.cabal @@ -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 +Author: Vincent Hanquez +Maintainer: Vincent Hanquez +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