tls-debug 0.2.5 → 0.3.0
raw patch · 5 files changed
+372/−397 lines, 5 filesdep +crypto-pubkeydep +data-default-classdep +pemdep −certificatedep −cmdargsdep −tls-extradep ~cprng-aesdep ~tls
Dependencies added: crypto-pubkey, data-default-class, pem, x509, x509-system, x509-validation
Dependencies removed: certificate, cmdargs, tls-extra
Dependency ranges changed: cprng-aes, tls
Files
- src/CheckCiphers.hs +0/−169
- src/RetrieveCertificate.hs +109/−52
- src/SimpleClient.hs +66/−46
- src/Stunnel.hs +169/−104
- tls-debug.cabal +28/−26
− src/CheckCiphers.hs
@@ -1,169 +0,0 @@-{-# 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 (SomeException(..))-import qualified Control.Exception as E--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] [] Nothing--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]- E.catch (do- rpkt <- recvPacket ctx- ccid <- case rpkt of- Right (Handshake ((ServerHello _ _ _ i _ _):_)) -> return i- _ -> error ("expecting server hello, packet received: " ++ show rpkt)- bye ctx- hClose handle- return $ Just ccid- ) (\(_ :: SomeException) -> return Nothing)--connectRange :: String -> String -> Int -> [Word16] -> IO (Int, [Word16])-connectRange d p v r = do- ccidopt <- openConnection d p r- threadDelay v- case ccidopt of- Nothing -> return (1, [])- Just ccid -> do- {-divide and conquer TLS-}- let newr = filter ((/=) ccid) r- let (lr, rr) = if length newr > 2- then splitAt (length newr `div` 2) newr- else (newr, [])- (lc, ls) <- if length lr > 0- then connectRange d p v lr - else return (0,[])- (rc, rs) <- if length rr > 0- then connectRange d p v rr- else return (0,[])- return (1 + lc + rc, [ccid] ++ ls ++ rs)--connectBetween d p v chunkSize ep sp = concat <$> loop sp where- loop a = liftM2 (:) (snd <$> connectRange d p v range)- (if a + chunkSize > ep then return [] else loop (a+64))- where- range = if a + chunkSize > ep- then [a..ep]- else [a..sp+chunkSize]--data PArgs = PArgs- { destination :: String- , port :: String- , speed :: Int- , start :: Int- , end :: Int- , nb :: Int- } deriving (Show, Data, Typeable)--progArgs = PArgs- { destination = "localhost" &= help "destination address to connect to" &= typ "address"- , port = "443" &= help "destination port to connect to" &= typ "port"- , speed = 100 &= help "speed between queries, in milliseconds" &= typ "speed"- , start = 0 &= help "starting cipher number (between 0 and 65535)" &= typ "cipher"- , end = 0xff &= help "end cipher number (between 0 and 65535)" &= typ "cipher"- , nb = 64 &= help "number of cipher to include per query " &= typ "range"- } &= summary "CheckCiphers -- SSL/TLS remotely check supported cipher"- &= details- [ "check the supported cipher of a remote destination."- , "Beware: this program make multiple connections to the destination"- , "which might be taken by the remote side as aggressive behavior"- ]--main = do- a <- cmdArgs progArgs- _ <- printf "connecting to %s on port %s ...\n" (destination a) (port a)- supported <- connectBetween (destination a) (port a) (speed a) (fromIntegral $ nb a) (fromIntegral $ end a) (fromIntegral $ start a)- forM_ supported $ \i -> do- putStrLn $ maybe ("cipher " ++ show i) id $ lookup i tableCiphers
src/RetrieveCertificate.hs view
@@ -1,88 +1,145 @@ {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-} import Network.TLS-import Network.TLS.Extra+import Network.TLS.Extra.Cipher +import Network.BSD+import Network.Socket++import Data.Default.Class import Data.IORef-import Data.Time.Clock-import Data.Certificate.X509-import System.Certificate.X509+import Data.X509 as X509+import Data.X509.Validation +import Control.Applicative import Control.Monad+import Control.Exception import qualified Crypto.Random.AESCtr as RNG +import Data.Char (isDigit)+import Data.PEM+ import Text.Printf import Text.Groom -import System.Console.CmdArgs+import System.Console.GetOpt+import System.Environment+import System.Exit +import qualified Data.ByteString.Char8 as B+ 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+ let params = (defaultParamsClient s (B.pack p))+ { clientSupported = def { supportedCiphers = ciphersuite_all }+ , clientShared = def { sharedValidationCache = noValidate }+ }++ --ctx <- connectionClient s p params rng+ pn <- if and $ map isDigit $ p+ then return $ fromIntegral $ (read p :: Int)+ else servicePort <$> getServiceByName p "tcp"+ he <- getHostByName s++ sock <- bracketOnError (socket AF_INET Stream defaultProtocol) sClose $ \sock -> do+ connect sock (SockAddrInet pn (head $ hostAddresses he))+ return sock+ ctx <- contextNew sock params rng++ contextHookSetCertificateRecv ctx $ \l -> modifyIORef ref (const $ Just l)+ _ <- handshake ctx bye ctx r <- readIORef ref case r of Nothing -> error "cannot retrieve any certificate" Just certs -> return certs+ where noValidate = ValidationCache (\_ _ _ -> return ValidationCachePass)+ (\_ _ _ -> return ()) -data PArgs = PArgs- { destination :: String- , port :: String- , chain :: Bool- , output :: String- , verify :: Bool- , verifyFQDN :: String- } deriving (Show, Data, Typeable)+data Flag = PrintChain+ | Format String+ | Verify+ | GetFingerprint+ | VerifyFQDN String+ | Help+ deriving (Show,Eq) -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"- ]+options :: [OptDescr Flag]+options =+ [ Option [] ["chain"] (NoArg PrintChain) "output the chain of certificate used"+ , Option [] ["format"] (ReqArg Format "format") "define the output format (full, pem, default: simple)"+ , Option [] ["verify"] (NoArg Verify) "verify the chain received with the trusted system certificate"+ , Option [] ["fingerprint"] (NoArg GetFingerprint) "show fingerprint (SHA1)"+ , Option [] ["verify-domain-name"] (ReqArg VerifyFQDN "fqdn") "verify the chain against a specific FQDN"+ , Option ['h'] ["help"] (NoArg Help) "request help"+ ] +showCert "pem" cert = B.putStrLn $ pemWriteBS pem+ where pem = PEM { pemName = "CERTIFICATE"+ , pemHeader = []+ , pemContent = encodeSignedObject cert+ } showCert "full" cert = putStrLn $ groom cert -showCert _ (x509Cert -> cert) = do+showCert _ (signedCert) = 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))+ where cert = getCertificate signedCert +printUsage =+ putStrLn $ usageInfo "usage: retrieve-certificate [opts] <hostname> [port]\n\n\t(port default to: 443)\noptions:\n" options+ main = do- a <- cmdArgs progArgs- _ <- printf "connecting to %s on port %s ...\n" (destination a) (port a)+ args <- getArgs+ let (opts,other,errs) = getOpt Permute options args+ when (not $ null errs) $ do+ putStrLn $ show errs+ exitFailure - 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 (Help `elem` opts) $ do+ printUsage+ exitSuccess - when (verify a) $ do- store <- getSystemCertificateStore- putStrLn "### certificate chain trust"- ctime <- utctDay `fmap` getCurrentTime- certificateVerifyChain store 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)+ case other of+ [destination,port] -> doMain destination port opts+ _ -> printUsage >> exitFailure++ where outputFormat [] = "simple"+ outputFormat (Format s:_ ) = s+ outputFormat (_ :xs) = outputFormat xs++ doMain destination port opts = do+ _ <- printf "connecting to %s on port %s ...\n" destination port++ chain <- openConnection destination port+ let (CertificateChain certs) = chain+ format = outputFormat opts+ case PrintChain `elem` opts of+ True ->+ forM_ (zip [0..] certs) $ \(n, cert) -> do+ putStrLn ("###### Certificate " ++ show (n + 1 :: Int) ++ " ######")+ showCert format cert+ False ->+ showCert format $ head certs++ let fingerprints = foldl (doFingerprint (head certs)) [] opts+ unless (null fingerprints) $ putStrLn ("Fingerprints:")+ mapM_ (\(alg,fprint) -> putStrLn (" " ++ alg ++ " = " ++ show fprint)) fingerprints++ doFingerprint cert acc GetFingerprint =+ ("SHA1", getFingerprint cert X509.HashSHA1) : acc+ doFingerprint _ acc _ = acc+{-+ when (Verify `elem` opts) $ do+ store <- getSystemCertificateStore+ putStrLn "### certificate chain trust"+ let checks = (defaultChecks Nothing) { checkExhaustive = True }+ reasons <- validate checks store chain+ when (not $ null reasons) $ do putStrLn "fail validation:"+ putStrLn $ show reasons+ -}
src/SimpleClient.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} import Network.BSD-import Network.Socket (socket, socketToHandle, Family(..), SocketType(..), sClose, SockAddr(..), connect)+import Network.Socket (socket, Family(..), SocketType(..), sClose, SockAddr(..), connect) import Network.TLS-import Network.TLS.Extra+import Network.TLS.Extra.Cipher import System.Console.GetOpt import System.IO import System.Timeout@@ -15,71 +15,78 @@ import Control.Monad import System.Environment import System.Exit-import System.Certificate.X509+import System.X509 +import Data.Default.Class import Data.IORef+import Data.X509.Validation ciphers :: [Cipher] ciphers =- [ cipher_AES128_SHA1+ [ cipher_DHE_RSA_AES256_SHA256+ , cipher_DHE_RSA_AES128_SHA256+ , cipher_DHE_RSA_AES256_SHA1+ , cipher_DHE_RSA_AES128_SHA1+ , cipher_DHE_DSS_AES256_SHA1+ , cipher_DHE_DSS_AES128_SHA1+ , cipher_AES128_SHA1 , cipher_AES256_SHA1 , cipher_RC4_128_MD5 , cipher_RC4_128_SHA1 ] -runTLS params hostname portNumber f = do+runTLS debug params hostname portNumber f = do rng <- RNG.makeSystem he <- getHostByName hostname sock <- socket AF_INET Stream defaultProtocol let sockaddr = SockAddrInet portNumber (head $ hostAddresses he) E.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+ ctx <- contextNew sock params rng+ contextHookSetLogging ctx logging () <- f ctx- hClose dsth--data SessionRef = SessionRef (IORef (SessionID, SessionData))+ sClose sock+ where logging = if not debug then def else def+ { loggingPacketSent = putStrLn . ("debug: >> " ++)+ , loggingPacketRecv = putStrLn . ("debug: << " ++)+ } -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 ()+sessionRef ref = SessionManager+ { sessionEstablish = \sid sdata -> writeIORef ref (sid,sdata)+ , sessionResume = \sid -> readIORef ref >>= \(s,d) -> if s == sid then return (Just d) else return Nothing+ , sessionInvalidate = \_ -> return ()+ } getDefaultParams flags host store sStorage session =- updateClientParams setCParams $ setSessionManager (SessionRef sStorage) $ defaultParamsClient- { pConnectVersion = tlsConnectVer- , pAllowedVersions = [TLS10,TLS11,TLS12]- , pCiphers = ciphers- , pCertificates = []- , pLogging = logging- , onCertificatesRecv = crecv+ (defaultParamsClient host BC.empty)+ { clientSupported = def { supportedVersions = [tlsConnectVer], supportedCiphers = ciphers }+ , clientWantSessionResume = session+ , clientUseServerNameIndication = not (NoSNI `elem` flags)+ , clientShared = def { sharedSessionManager = sessionRef sStorage+ , sharedCAStore = store+ , sharedValidationCache = validateCache+ } } where- setCParams cparams = cparams- { clientWantSessionResume = session- , clientUseServerName = if NoSNI `elem` flags then Nothing else Just host- }- logging = if not debug then defaultLogging else defaultLogging- { loggingPacketSent = putStrLn . ("debug: >> " ++)- , loggingPacketRecv = putStrLn . ("debug: << " ++)- }- crecv = if validateCert- then certificateChecks [certificateVerifyChain store,return . certificateVerifyDomain host]- else (\_ -> return CertificateUsageAccept)+ validateCache+ | validateCert = def+ | otherwise = ValidationCache (\_ _ _ -> return ValidationCachePass)+ (\_ _ _ -> return ()) tlsConnectVer | Tls12 `elem` flags = TLS12 | Tls11 `elem` flags = TLS11 | Ssl3 `elem` flags = SSL3- | otherwise = TLS10- debug = Debug `elem` flags+ | Tls10 `elem` flags = TLS10+ | otherwise = TLS12 validateCert = not (NoValidateCert `elem` flags) data Flag = Verbose | Debug | NoValidateCert | Session | Http11- | Ssl3 | Tls11 | Tls12+ | Ssl3 | Tls10 | Tls11 | Tls12 | NoSNI | Uri String+ | UserAgent String+ | Output String | Help deriving (Show,Eq) @@ -88,12 +95,15 @@ [ Option ['v'] ["verbose"] (NoArg Verbose) "verbose output on stdout" , Option ['d'] ["debug"] (NoArg Debug) "TLS debug output on stdout" , Option ['s'] ["session"] (NoArg Session) "try to resume a session"+ , Option ['O'] ["output"] (ReqArg Output "stdout") "output " , Option [] ["no-validation"] (NoArg NoValidateCert) "disable certificate validation" , Option [] ["http1.1"] (NoArg Http11) "use http1.1 instead of http1.0"- , Option [] ["ssl3"] (NoArg Ssl3) "use SSL 3.0 as default"+ , Option [] ["ssl3"] (NoArg Ssl3) "use SSL 3.0" , Option [] ["no-sni"] (NoArg NoSNI) "don't use server name indication"- , Option [] ["tls11"] (NoArg Tls11) "use TLS 1.1 as default"- , Option [] ["tls12"] (NoArg Tls12) "use TLS 1.2 as default"+ , Option [] ["user-agent"] (ReqArg UserAgent "user-agent") "use a user agent"+ , Option [] ["tls10"] (NoArg Tls11) "use TLS 1.0"+ , Option [] ["tls11"] (NoArg Tls11) "use TLS 1.1"+ , Option [] ["tls12"] (NoArg Tls12) "use TLS 1.2 (default)" , Option [] ["uri"] (ReqArg Uri "URI") "optional URI requested by default /" , Option ['h'] ["help"] (NoArg Help) "request help" ]@@ -103,29 +113,39 @@ when (Session `elem` flags) $ do session <- readIORef sStorage doTLS (Just session)- where doTLS sess = do+ where doTLS sess = do let query = LC.pack ( "GET " ++ findURI flags ++ (if Http11 `elem` flags then (" HTTP/1.1\r\nHost: " ++ hostname) else " HTTP/1.0")+ ++ userAgent ++ "\r\n\r\n") when (Verbose `elem` flags) (putStrLn "sending query:" >> LC.putStrLn query >> putStrLn "")- runTLS (getDefaultParams flags hostname certStore sStorage sess) hostname port $ \ctx -> do+ out <- maybe (return stdout) (flip openFile WriteMode) getOutput+ runTLS (Debug `elem` flags) (getDefaultParams flags hostname certStore sStorage sess) hostname port $ \ctx -> do handshake ctx sendData ctx $ query- loopRecv ctx+ loopRecv out ctx bye ctx return ()- loopRecv ctx = do+ loopRecv out ctx = do d <- timeout 2000000 (recvData ctx) -- 2s per recv case d of Nothing -> when (Debug `elem` flags) (hPutStrLn stderr "timeout") >> return () Just b | BC.null b -> return ()- | otherwise -> BC.putStrLn b >> loopRecv ctx+ | otherwise -> BC.hPutStrLn out b >> loopRecv out ctx - findURI [] = "/"- findURI (Uri u:_) = u- findURI (_:xs) = findURI xs+ findURI [] = "/"+ findURI (Uri u:_) = u+ findURI (_:xs) = findURI xs++ userAgent = maybe "" (\s -> "\r\nUser-Agent: " ++ s) mUserAgent+ mUserAgent = foldl f Nothing flags+ where f _ (UserAgent ua) = Just ua+ f acc _ = acc+ getOutput = foldl f Nothing flags+ where f _ (Output o) = Just o+ f acc _ = acc printUsage = putStrLn $ usageInfo "usage: simpleclient [opts] <hostname> [port]\n\n\t(port default to: 443)\noptions:\n" options
src/Stunnel.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} import Network.BSD-import Network.Socket+import Network.Socket hiding (Debug) import System.IO import System.IO.Error (isEOFError)-import System.Console.CmdArgs-import System.Certificate.X509+import System.Console.GetOpt+import System.Environment (getArgs)+import System.Exit+import System.X509+import Data.X509.Validation import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L@@ -17,14 +20,24 @@ import Control.Monad (when, forever) import Data.Char (isDigit)+import Data.Default.Class import qualified Crypto.Random.AESCtr as RNG import Network.TLS-import Network.TLS.Extra+import Network.TLS.Extra.Cipher +import qualified Crypto.PubKey.DH as DH ()+ ciphers :: [Cipher] ciphers =- [ cipher_AES128_SHA1+ [ cipher_DHE_RSA_AES256_SHA256+ , cipher_DHE_RSA_AES128_SHA256+ , cipher_DHE_RSA_AES256_SHA1+ , cipher_DHE_RSA_AES128_SHA1+ , cipher_DHE_DSS_AES128_SHA1+ , cipher_DHE_DSS_AES256_SHA1+ , cipher_DHE_DSS_RC4_SHA1+ , cipher_AES128_SHA1 , cipher_AES256_SHA1 , cipher_RC4_128_MD5 , cipher_RC4_128_SHA1@@ -40,7 +53,7 @@ Right True -> B.hGetNonBlocking h 4096 Right False -> return B.empty -tlsclient :: Handle -> TLSCtx -> IO ()+tlsclient :: Handle -> Context -> IO () tlsclient srchandle dsthandle = do hSetBuffering srchandle NoBuffering @@ -74,76 +87,37 @@ return False putStrLn "end" -data MemSessionManager = MemSessionManager (MVar [(SessionID, SessionData)])+newtype 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 ()+memSessionManager (MemSessionManager mvar) = SessionManager+ { sessionEstablish = \sid sdata -> modifyMVar_ mvar (\l -> return $ (sid,sdata) : l)+ , sessionResume = \sid -> withMVar mvar (return . lookup sid)+ , sessionInvalidate = \_ -> return ()+ } -clientProcess certs handle dsthandle dbg sessionStorage _ = do+clientProcess dhParamsFile creds 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)+ then def+ else def { loggingPacketSent = putStrLn . ("debug: send: " ++)+ , loggingPacketRecv = putStrLn . ("debug: recv: " ++)+ } -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"+ dhParams <- case dhParamsFile of+ Nothing -> return Nothing+ Just file -> (Just . read) `fmap` readFile file -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"+ let serverstate = def+ { serverSupported = def { supportedCiphers = ciphers }+ , serverShared = def { sharedCredentials = creds+ , sharedSessionManager = maybe noSessionManager (memSessionManager . MemSessionManager) sessionStorage+ }+ , serverDHEParams = dhParams+ } -mode = cmdArgsMode $ modes [clientOpts,serverOpts]- &= help "create SSL/TLS tunnel in client or server mode" &= program "stunnel" &= summary "Stunnel v0.1 (Haskell TLS)"+ ctx <- contextNew handle serverstate rng+ contextHookSetLogging ctx logging+ tlsserver ctx dsthandle data StunnelAddr = AddrSocket Family SockAddr@@ -153,10 +127,10 @@ StunnelSocket Socket | StunnelFd Handle Handle -getAddressDescription :: String -> String -> IO StunnelAddr-getAddressDescription "tcp" desc = do+getAddressDescription :: Address -> IO StunnelAddr+getAddressDescription (Address "tcp" desc) = do let (s, p) = break ((==) ':') desc- when (p == "") (error "missing port: expecting [source]:port")+ when (p == "") (error $ "missing port: expecting [source]:port got " ++ show desc) pn <- if and $ map isDigit $ drop 1 p then return $ fromIntegral $ (read (drop 1 p) :: Int) else do@@ -165,13 +139,13 @@ he <- getHostByName s return $ AddrSocket AF_INET (SockAddrInet pn (head $ hostAddresses he)) -getAddressDescription "unix" desc = do+getAddressDescription (Address "unix" desc) = do return $ AddrSocket AF_UNIX (SockAddrUnix desc) -getAddressDescription "fd" _ =+getAddressDescription (Address "fd" _) = return $ AddrFD stdin stdout -getAddressDescription _ _ = error "unrecognized source type (expecting tcp/unix/fd)"+getAddressDescription a = error ("unrecognized source type (expecting tcp/unix/fd, got " ++ show a ++ ")") connectAddressDescription (AddrSocket family sockaddr) = do sock <- socket family Stream defaultProtocol@@ -191,25 +165,28 @@ 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)+doClient :: Address -> Address -> [Flag] -> IO ()+doClient source destination@(Address a _) flags = do+ srcaddr <- getAddressDescription source+ dstaddr <- getAddressDescription destination - let logging = if not $ debug pargs then defaultLogging else defaultLogging- { loggingPacketSent = putStrLn . ("debug: send: " ++)- , loggingPacketRecv = putStrLn . ("debug: recv: " ++)- }+ let logging =+ if not (Debug `elem` flags)+ then def+ else def { loggingPacketSent = putStrLn . ("debug: send: " ++)+ , loggingPacketRecv = putStrLn . ("debug: recv: " ++)+ } store <- getSystemCertificateStore- let crecv = if validCert pargs then certificateVerifyChain store else (\_ -> return CertificateUsageAccept)- let clientstate = defaultParamsClient { pConnectVersion = TLS10- , pAllowedVersions = [TLS10,TLS11,TLS12]- , pCiphers = ciphers- , pCertificates = []- , pLogging = logging- , onCertificatesRecv = crecv- }+ let validateCache+ | NoCertValidation `elem` flags =+ ValidationCache (\_ _ _ -> return ValidationCachePass)+ (\_ _ _ -> return ())+ | otherwise = def+ let clientstate = (defaultParamsClient a B.empty)+ { clientSupported = def { supportedCiphers = ciphers }+ , clientShared = def { sharedCAStore = store, sharedValidationCache = validateCache }+ } case srcaddr of AddrSocket _ _ -> do@@ -222,22 +199,32 @@ (StunnelSocket dst) <- connectAddressDescription dstaddr dsth <- socketToHandle dst ReadWriteMode- dstctx <- contextNewOnHandle dsth clientstate rng+ dstctx <- contextNew dsth clientstate rng+ contextHookSetLogging dstctx logging _ <- 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)+loadCred (cert, priv) = do+ putStrLn ("loading credential " ++ show cert ++ " : key=" ++ show priv)+ res <- credentialLoadX509 cert priv+ case res of+ Left _ -> putStrLn "ERR"+ Right _ -> putStrLn "OK"+ return res - sessionStorage <- if disableSession pargs then return Nothing else (Just `fmap` newMVar []) +doServer :: Address -> Address -> [Flag] -> IO ()+doServer source destination flags = do+ creds <- (either (error . show) Credentials . sequence) `fmap` mapM loadCred (zip (getCertificate flags) (getKey flags))+ srcaddr <- getAddressDescription source+ dstaddr <- getAddressDescription destination+ let dhParamsFile = getDHParams flags++ sessionStorage <- if NoSession `elem` flags then return Nothing else (Just `fmap` newMVar [])+ case srcaddr of AddrSocket _ _ -> do (StunnelSocket srcsocket) <- listenAddressDescription srcaddr@@ -250,14 +237,92 @@ StunnelSocket dst -> socketToHandle dst ReadWriteMode _ <- forkIO $ finally- (clientProcess [(cert, Just pk)] srch dsth (debug pargs) sessionStorage addr >> return ())+ (clientProcess dhParamsFile creds srch dsth (Debug `elem` flags) sessionStorage addr >> return ()) (hClose srch >> (when (dsth /= stdout) $ hClose dsth)) return () AddrFD _ _ -> error "bad error fd. not implemented" +printUsage =+ putStrLn $ usageInfo "usage: tls-stunnel <mode> [opts]\n\n\tmode:\n\tclient\n\tserver\n\nclient options:\n" options++data Flag =+ Source String+ | Destination String+ | SourceType String+ | DestinationType String+ | Debug+ | Help+ | Certificate String+ | Key String+ | DHParams String+ | NoSession+ | NoCertValidation+ deriving (Show,Eq)++options :: [OptDescr Flag]+options =+ [ Option ['s'] ["source"] (ReqArg Source "source") "source address influenced by source type"+ , Option ['d'] ["destination"] (ReqArg Destination "destination") "destination address influenced by destination type"+ , Option [] ["source-type"] (ReqArg SourceType "source-type") "type of source (tcp, unix, fd)"+ , Option [] ["destination-type"] (ReqArg DestinationType "source-type") "type of source (tcp, unix, fd)"+ , Option [] ["debug"] (NoArg Debug) "debug the TLS protocol printing debugging to stdout"+ , Option ['h'] ["help"] (NoArg Help) "request help"+ , Option [] ["certificate"] (ReqArg Certificate "certificate") "certificate file"+ , Option [] ["key"] (ReqArg Key "key") "certificate file"+ , Option [] ["dhparams"] (ReqArg DHParams "dhparams") "DH parameter file"+ , Option [] ["no-session"] (NoArg NoSession) "disable support for session"+ , Option [] ["no-cert-validation"] (NoArg NoCertValidation) "disable certificate validation"+ ]++data Address = Address String String+ deriving (Show,Eq)++defaultSource = Address "tcp" "localhost:6060"+defaultDestination = Address "tcp" "localhost:6061"++getSource opts = foldl accf defaultSource opts+ where accf (Address t _) (Source s) = Address t s+ accf (Address _ s) (SourceType t) = Address t s+ accf acc _ = acc++getDestination opts = foldl accf defaultDestination opts+ where accf (Address t _) (Destination s) = Address t s+ accf (Address _ s) (DestinationType t) = Address t s+ accf acc _ = acc++onNull defVal l | null l = defVal+ | otherwise = l++getCertificate :: [Flag] -> [String]+getCertificate opts = reverse $ onNull ["certificate.pem"] $ foldl accf [] opts+ where accf acc (Certificate cert) = cert:acc+ accf acc _ = acc++getKey opts = reverse $ onNull ["certificate.key"] $ foldl accf [] opts+ where accf acc (Key key) = key : acc+ accf acc _ = acc++getDHParams opts = foldl accf Nothing opts+ where accf _ (DHParams file) = Just file+ accf acc _ = acc+ main :: IO () main = do- x <- cmdArgsRun mode- case x of- ClientConfig {} -> doClient x- ServerConfig {} -> doServer x+ args <- getArgs+ let (opts,other,errs) = getOpt Permute options args+ when (not $ null errs) $ do+ putStrLn $ show errs+ exitFailure++ when (Help `elem` opts) $ do+ printUsage+ exitSuccess++ let source = getSource opts+ destination = getDestination opts++ case other of+ [] -> printUsage+ "client":_ -> doClient source destination opts+ "server":_ -> doServer source destination opts+ mode:_ -> error ("unknown mode " ++ show mode)
tls-debug.cabal view
@@ -1,5 +1,5 @@ Name: tls-debug-Version: 0.2.5+Version: 0.3.0 Description: A set of program to test and debug various aspect of the TLS package. .@@ -21,26 +21,28 @@ Build-Depends: base >= 4 && < 5 , network , bytestring- , cmdargs- , certificate >= 1.0+ , x509-system >= 1.0 , cprng-aes >= 0.5.0- , tls >= 1.1 && < 1.2- , tls-extra >= 0.6.1 && < 0.7- Buildable: True+ , data-default-class+ , crypto-pubkey+ , tls >= 1.2 && < 1.3+ if os(windows)+ Buildable: False+ else+ 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.1 && < 1.2- , tls-extra >= 0.6.1 && < 0.7- 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+-- , x509-system >= 1.0+-- , tls >= 1.2 && < 1.3+-- Buildable: True+-- ghc-options: -Wall -fno-warn-missing-signatures Executable tls-retrievecertificate Main-is: RetrieveCertificate.hs@@ -48,13 +50,14 @@ Build-Depends: base >= 4 && < 5 , network , bytestring- , cmdargs , groom , time+ , pem , cprng-aes >= 0.5.0- , certificate >= 1.0- , tls >= 1.1 && < 1.2- , tls-extra >= 0.6.1 && < 0.7+ , x509+ , x509-system >= 1.4+ , x509-validation >= 1.5.0+ , tls >= 1.2 && < 1.3 Buildable: True ghc-options: -Wall -fno-warn-missing-signatures @@ -64,11 +67,10 @@ Build-Depends: base >= 4 && < 5 , network , bytestring- , cmdargs+ , data-default-class , cprng-aes >= 0.5.0- , certificate >= 1.0- , tls >= 1.1 && < 1.2- , tls-extra >= 0.6.1 && < 0.7+ , x509-system >= 1.0+ , tls >= 1.2 && < 1.3 Buildable: True ghc-options: -Wall -fno-warn-missing-signatures