merge tls-debug in tls.
This commit is contained in:
commit
2d6174d73d
7 changed files with 710 additions and 0 deletions
27
debug/LICENSE
Normal file
27
debug/LICENSE
Normal 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
2
debug/Setup.hs
Normal file
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
169
debug/src/CheckCiphers.hs
Normal file
169
debug/src/CheckCiphers.hs
Normal 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
90
debug/src/RetrieveCertificate.hs
Normal 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
84
debug/src/SimpleClient.hs
Normal 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
262
debug/src/Stunnel.hs
Normal 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
76
debug/tls-debug.cabal
Normal 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
|
Loading…
Reference in a new issue