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