yogsototh/hs-tls
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

merge tls-debug in tls.

Browse source
This commit is contained in:
Vincent Hanquez 2012-09-05 06:49:38 +01:00
commit 2d6174d73d
7 changed files with 710 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
debug/LICENSE Normal file
View file

@ -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.

2
debug/Setup.hs Normal file
View file

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

169
debug/src/CheckCiphers.hs Normal file
View file

@ -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 = defaultParamsClient { pCiphers = map fakeCipher ciphers }
ctx <- contextNewOnHandle handle params rng
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

90
debug/src/RetrieveCertificate.hs Normal file
View file

@ -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 = defaultParamsClient
{ 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)

84
debug/src/SimpleClient.hs Normal file
View file

@ -0,0 +1,84 @@
{-# 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 <- contextNewOnHandle dsth params rng
f ctx
hClose dsth
data SessionRef = SessionRef (IORef (SessionID, SessionData))
instance SessionManager SessionRef where
sessionEstablish (SessionRef ref) sid sdata = writeIORef ref (sid,sdata)
sessionResume (SessionRef ref) sid = readIORef ref >>= \(s,d) -> if s == sid then return (Just d) else return Nothing
sessionInvalidate _ _ = return ()
getDefaultParams sStorage session = updateClientParams setCParams $ setSessionManager (SessionRef sStorage) $ defaultParams
{ pConnectVersion = TLS10
, pAllowedVersions = [TLS10,TLS11,TLS12]
, pCiphers = ciphers
, pCertificates = []
, pLogging = logging
, onCertificatesRecv = crecv
}
where
setCParams cparams = cparams { clientWantSessionResume = session }
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 ()
-}

262
debug/src/Stunnel.hs Normal file
View file

@ -0,0 +1,262 @@
{-# 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 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 -> 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")
return False
putStrLn "end"
data MemSessionManager = MemSessionManager (MVar [(SessionID, SessionData)])
instance SessionManager MemSessionManager where
sessionEstablish (MemSessionManager mvar) sid sdata = modifyMVar_ mvar (\l -> return $ (sid,sdata) : l)
sessionResume (MemSessionManager mvar) sid = withMVar mvar (return . lookup sid)
sessionInvalidate (MemSessionManager mvar) _ = return ()
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 = maybe id (setSessionManager . MemSessionManager) sessionStorage $ defaultParamsServer
{ pAllowedVersions = [SSL3,TLS10,TLS11,TLS12]
, pCiphers = ciphers
, pCertificates = certs
, pLogging = logging
}
ctx <- contextNewOnHandle handle serverstate rng
tlsserver ctx dsthandle
data Stunnel =
ClientConfig
{ destinationType :: String
, destination :: String
, sourceType :: String
, source :: String
, debug :: Bool
, validCert :: Bool }
| ServerConfig
{ destinationType :: String
, destination :: String
, sourceType :: String
, source :: String
, debug :: Bool
, disableSession :: Bool
, certificate :: FilePath
, key :: FilePath }
deriving (Show, Data, Typeable)
clientOpts = ClientConfig
{ 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"
&= name "client"
serverOpts = ServerConfig
{ 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"
&= name "server"
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 = defaultParamsClient
{ 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 <- contextNewOnHandle dsth clientstate rng
_ <- forkIO $ finally
(tlsclient srch dstctx)
(hClose srch >> hClose dsth)
return ()
AddrFD _ _ -> error "bad error fd. not implemented"
doServer :: Stunnel -> IO ()
doServer pargs = do
cert <- fileReadCertificate $ certificate pargs
pk <- fileReadPrivateKey $ 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
ClientConfig {} -> doClient x
ServerConfig {} -> doServer x

76
debug/tls-debug.cabal Normal file
View file

@ -0,0 +1,76 @@
Name: tls-debug
Version: 0.1.1
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 >= 1.0 && < 1.1
, tls-extra >= 0.5 && < 0.6
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 >= 1.0 && < 1.1
, tls-extra >= 0.5 && < 0.6
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 >= 1.0 && < 1.1
, tls-extra >= 0.5 && < 0.6
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 >= 1.0 && < 1.1
, tls-extra >= 0.5 && < 0.6
Buildable: True
ghc-options: -Wall -fno-warn-missing-signatures
source-repository head
type: git
location: git://github.com/vincenthz/hs-tls-debug