tls-debug 0.4.5 → 0.4.6
raw patch · 8 files changed
+324/−180 lines, 8 filesdep +tls-session-managerdep −timedep ~cryptonitedep ~tlsdep ~x509-validation
Dependencies added: tls-session-manager
Dependencies removed: time
Dependency ranges changed: cryptonite, tls, x509-validation
Files
- src/Common.hs +66/−4
- src/HexDump.hs +3/−3
- src/Imports.hs +17/−0
- src/RetrieveCertificate.hs +14/−24
- src/SimpleClient.hs +101/−49
- src/SimpleServer.hs +78/−52
- src/Stunnel.hs +28/−39
- tls-debug.cabal +17/−9
src/Common.hs view
@@ -3,22 +3,31 @@ module Common ( printCiphers , printDHParams+ , printGroups , readNumber , readCiphers , readDHParams+ , readGroups , printHandshakeInfo+ , makeAddrInfo+ , AddrInfo(..)+ , getCertificateStore ) where -import Control.Monad- import Data.Char (isDigit)-+import Data.Maybe (fromJust) import Numeric (showHex)+import Network.Socket -import Network.TLS+import Data.X509.CertificateStore+import System.X509++import Network.TLS hiding (HostName) import Network.TLS.Extra.Cipher import Network.TLS.Extra.FFDHE +import Imports+ namedDHParams :: [(String, DHParams)] namedDHParams = [ ("ffdhe2048", ffdhe2048)@@ -35,6 +44,20 @@ , ("strong", map cipherID ciphersuite_strong) ] +namedGroups :: [(String, Group)]+namedGroups =+ [ ("ffdhe2048", FFDHE2048)+ , ("ffdhe3072", FFDHE3072)+ , ("ffdhe4096", FFDHE4096)+ , ("ffdhe6144", FFDHE6144)+ , ("ffdhe8192", FFDHE8192)+ , ("p256", P256)+ , ("p384", P384)+ , ("p521", P521)+ , ("x25519", X25519)+ , ("x448", X448)+ ]+ readNumber :: (Num a, Read a) => String -> Maybe a readNumber s | all isDigit s = Just $ read s@@ -52,6 +75,9 @@ Nothing -> (Just . read) `fmap` readFile s mparams -> return mparams +readGroups :: String -> Maybe [Group]+readGroups s = traverse (`lookup` namedGroups) (split ',' s)+ printCiphers :: IO () printCiphers = do putStrLn "Supported ciphers"@@ -74,6 +100,12 @@ forM_ namedDHParams $ \(name, _) -> putStrLn name putStrLn "(or /path/to/dhparams)" +printGroups :: IO ()+printGroups = do+ putStrLn "Groups"+ putStrLn "====================================="+ forM_ namedGroups $ \(name, _) -> putStrLn name+ printHandshakeInfo ctx = do info <- contextGetInformation ctx case info of@@ -82,7 +114,37 @@ putStrLn ("version: " ++ show (infoVersion i)) putStrLn ("cipher: " ++ show (infoCipher i)) putStrLn ("compression: " ++ show (infoCompression i))+ putStrLn ("group: " ++ maybe "(none)" show (infoNegotiatedGroup i))+ when (infoVersion i == TLS13) $ do+ putStrLn ("handshake emode: " ++ show (fromJust (infoTLS13HandshakeMode i)))+ putStrLn ("early data accepted: " ++ show (infoIsEarlyDataAccepted i)) sni <- getClientSNI ctx case sni of Nothing -> return () Just n -> putStrLn ("server name indication: " ++ n)++makeAddrInfo :: Maybe HostName -> PortNumber -> IO AddrInfo+makeAddrInfo maddr port = do+ let flgs = [AI_ADDRCONFIG, AI_NUMERICSERV, AI_PASSIVE]+ hints = defaultHints {+ addrFlags = flgs+ , addrSocketType = Stream+ }+ head <$> getAddrInfo (Just hints) maddr (Just $ show port)++split :: Char -> String -> [String]+split _ "" = []+split c s = case break (c==) s of+ ("",r) -> split c (tail r)+ (s',"") -> [s']+ (s',r) -> s' : split c (tail r)++getCertificateStore :: [FilePath] -> IO CertificateStore+getCertificateStore [] = getSystemCertificateStore+getCertificateStore paths = foldM readPathAppend mempty paths+ where+ readPathAppend acc path = do+ mstore <- readCertificateStore path+ case mstore of+ Nothing -> error ("invalid certificate store: " ++ path)+ Just st -> return $! mappend st acc
src/HexDump.hs view
@@ -2,11 +2,11 @@ ( hexdump ) where -import Data.List-import Data.Word import qualified Data.ByteString as B -hexdump :: String -> B.ByteString -> [String]+import Imports++hexdump :: String -> ByteString -> [String] hexdump pre b = disptable (defaultConfig { configRowLeft = pre ++ " | " } ) $ B.unpack b data BytedumpConfig = BytedumpConfig
+ src/Imports.hs view
@@ -0,0 +1,17 @@+module Imports (+ ByteString+ , module Control.Applicative+ , module Control.Monad+ , module Data.List+ , module Data.Maybe+ , module Data.Monoid+ , module Data.Word+ ) where++import Control.Applicative+import Control.Monad+import Data.ByteString (ByteString)+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Word
src/RetrieveCertificate.hs view
@@ -1,33 +1,25 @@ {-# LANGUAGE DeriveDataTypeable, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -import Network.TLS-import Network.TLS.Extra.Cipher--import Network.BSD-import Network.Socket-+import Control.Exception+import qualified Data.ByteString.Char8 as B import Data.Default.Class import Data.IORef+import Data.PEM import Data.X509 as X509 import Data.X509.Validation-import System.X509--import Control.Applicative-import Control.Monad-import Control.Exception--import Data.Char (isDigit)-import Data.PEM--import Text.Printf-+import Network.Socket import System.Console.GetOpt import System.Environment import System.Exit+import System.X509+import Text.Printf -import qualified Data.ByteString.Char8 as B+import Network.TLS+import Network.TLS.Extra.Cipher +import Imports+ openConnection s p = do ref <- newIORef Nothing let params = (defaultParamsClient s (B.pack p))@@ -36,13 +28,11 @@ } --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+ let hints = defaultHints { addrSocketType = Stream }+ addr:_ <- getAddrInfo (Just hints) (Just s) (Just p) - sock <- bracketOnError (socket AF_INET Stream defaultProtocol) close $ \sock -> do- connect sock (SockAddrInet pn (head $ hostAddresses he))+ sock <- bracketOnError (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) close $ \sock -> do+ connect sock $ addrAddress addr return sock ctx <- contextNew sock params
src/SimpleClient.hs view
@@ -1,47 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++import Control.Exception (SomeException(..))+import qualified Control.Exception as E import Crypto.Random-import Network.BSD-import Network.Socket (socket, Family(..), SocketType(..), close, SockAddr(..), connect)-import Network.TLS-import Network.TLS.Extra.Cipher-import System.Console.GetOpt-import System.IO-import System.Timeout-import qualified Data.ByteString.Lazy.Char8 as LC-import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString as B-import Control.Exception-import qualified Control.Exception as E-import Control.Monad+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy.Char8 as LC+import Data.Default.Class+import Data.IORef+import Network.Socket (socket, close, connect)+import System.Console.GetOpt import System.Environment import System.Exit-import System.X509+import System.IO+import System.Timeout -import Data.Default.Class-import Data.IORef-import Data.Monoid-import Data.List (find)-import Data.Maybe (isJust, mapMaybe)+import Network.TLS+import Network.TLS.Extra.Cipher import Common import HexDump+import Imports defaultBenchAmount = 1024 * 1024 defaultTimeout = 2000 bogusCipher cid = cipher_AES128_SHA1 { cipherID = cid } -runTLS debug ioDebug params hostname portNumber f = do- he <- getHostByName hostname- sock <- socket AF_INET Stream defaultProtocol- let sockaddr = SockAddrInet portNumber (head $ hostAddresses he)- E.catch (connect sock sockaddr)- (\(SomeException e) -> close sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e))- ctx <- contextNew sock params- contextHookSetLogging ctx getLogging- () <- f ctx- close sock+runTLS debug ioDebug params hostname portNumber f =+ E.bracket setup teardown $ \sock -> do+ ctx <- contextNew sock params+ contextHookSetLogging ctx getLogging+ f ctx where getLogging = ioLogging $ packetLogging $ def packetLogging logging | debug = logging { loggingPacketSent = putStrLn . ("debug: >> " ++)@@ -55,29 +46,40 @@ mapM_ putStrLn $ hexdump "<<" body } | otherwise = logging+ setup = do+ ai <- makeAddrInfo (Just hostname) portNumber+ sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)+ let sockaddr = addrAddress ai+ connect sock sockaddr+ return sock+ teardown sock = close sock 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 ()+ { sessionEstablish = \sid sdata -> writeIORef ref (sid,sdata)+ , sessionResume = \sid -> readIORef ref >>= \(s,d) -> if s == sid then return (Just d) else return Nothing+ , sessionResumeOnlyOnce = \_ -> fail "sessionResumeOnlyOnce not implemented for simple client"+ , sessionInvalidate = \_ -> return () } -getDefaultParams flags host store sStorage certCredsRequest session =+getDefaultParams flags host store sStorage certCredsRequest session earlyData = (defaultParamsClient serverName BC.empty)- { clientSupported = def { supportedVersions = supportedVers, supportedCiphers = myCiphers }+ { clientSupported = def { supportedVersions = supportedVers+ , supportedCiphers = myCiphers+ , supportedGroups = getGroups flags+ } , clientWantSessionResume = session- , clientUseServerNameIndication = not (NoSNI `elem` flags)+ , clientUseServerNameIndication = NoSNI `notElem` flags , clientShared = def { sharedSessionManager = sessionRef sStorage , sharedCAStore = store , sharedValidationCache = validateCache- , sharedCredentials = maybe mempty fst certCredsRequest }- , clientHooks = def { onCertificateRequest = maybe (onCertificateRequest def) snd certCredsRequest }+ , clientHooks = def { onCertificateRequest = fromMaybe (onCertificateRequest def) certCredsRequest } , clientDebug = def { debugSeed = foldl getDebugSeed Nothing flags , debugPrintSeed = if DebugPrintSeed `elem` flags then (\seed -> putStrLn ("seed: " ++ show (seedToInteger seed))) else (\_ -> return ()) }+ , clientEarlyData = earlyData } where serverName = foldl f host flags@@ -112,6 +114,7 @@ getDebugSeed acc _ = acc tlsConnectVer+ | Tls13 `elem` flags = TLS13 | Tls12 `elem` flags = TLS12 | Tls11 `elem` flags = TLS11 | Ssl3 `elem` flags = SSL3@@ -120,28 +123,43 @@ supportedVers | NoVersionDowngrade `elem` flags = [tlsConnectVer] | otherwise = filter (<= tlsConnectVer) allVers- allVers = [SSL3, TLS10, TLS11, TLS12]+ allVers = [SSL3, TLS10, TLS11, TLS12, TLS13] validateCert = not (NoValidateCert `elem` flags) +getGroups flags = case getGroup >>= readGroups of+ Nothing -> defaultGroups+ Just [] -> defaultGroups+ Just groups -> groups+ where+ defaultGroups = supportedGroups def+ getGroup = foldl f Nothing flags+ where f _ (Group g) = Just g+ f acc _ = acc+ data Flag = Verbose | Debug | IODebug | NoValidateCert | Session | Http11- | Ssl3 | Tls10 | Tls11 | Tls12+ | Ssl3 | Tls10 | Tls11 | Tls12 | Tls13 | SNI String | NoSNI | Uri String | NoVersionDowngrade | UserAgent String+ | Input String | Output String | Timeout String | BogusCipher String | ClientCert String+ | TrustAnchor String | BenchSend | BenchRecv | BenchData String | UseCipher String | ListCiphers+ | ListGroups | DebugSeed String | DebugPrintSeed+ | Group String | Help+ | UpdateKey deriving (Show,Eq) options :: [OptDescr Flag]@@ -150,10 +168,14 @@ , Option ['d'] ["debug"] (NoArg Debug) "TLS debug output on stdout" , Option [] ["io-debug"] (NoArg IODebug) "TLS IO debug output on stdout" , Option ['s'] ["session"] (NoArg Session) "try to resume a session"+ , Option ['Z'] ["zerortt"] (ReqArg Input "inpfile") "input for TLS 1.3 0RTT data" , Option ['O'] ["output"] (ReqArg Output "stdout") "output "+ , Option ['g'] ["group"] (ReqArg Group "group") "group" , Option ['t'] ["timeout"] (ReqArg Timeout "timeout") "timeout in milliseconds (2s by default)"+ , Option ['u'] ["update-key"] (NoArg UpdateKey) "Updating keys after sending the first request then sending the same request again (TLS 1.3 only)" , Option [] ["no-validation"] (NoArg NoValidateCert) "disable certificate validation" , Option [] ["client-cert"] (ReqArg ClientCert "cert-file:key-file") "add a client certificate to use with the server"+ , Option [] ["trust-anchor"] (ReqArg TrustAnchor "pem-or-dir") "use provided CAs instead of system certificate store" , Option [] ["http1.1"] (NoArg Http11) "use http1.1 instead of http1.0" , Option [] ["ssl3"] (NoArg Ssl3) "use SSL 3.0" , Option [] ["sni"] (ReqArg SNI "server-name") "use non-default server name indication"@@ -162,6 +184,7 @@ , Option [] ["tls10"] (NoArg Tls10) "use TLS 1.0" , Option [] ["tls11"] (NoArg Tls11) "use TLS 1.1" , Option [] ["tls12"] (NoArg Tls12) "use TLS 1.2 (default)"+ , Option [] ["tls13"] (NoArg Tls13) "use TLS 1.3" , Option [] ["bogocipher"] (ReqArg BogusCipher "cipher-id") "add a bogus cipher id for testing" , Option ['x'] ["no-version-downgrade"] (NoArg NoVersionDowngrade) "do not allow version downgrade" , Option [] ["uri"] (ReqArg Uri "URI") "optional URI requested by default /"@@ -171,6 +194,7 @@ , Option [] ["bench-data"] (ReqArg BenchData "amount") "amount of data to benchmark with" , Option [] ["use-cipher"] (ReqArg UseCipher "cipher-id") "use a specific cipher" , Option [] ["list-ciphers"] (NoArg ListCiphers) "list all ciphers supported and exit"+ , Option [] ["list-groups"] (NoArg ListGroups) "list all groups supported and exit" , Option [] ["debug-seed"] (ReqArg DebugSeed "debug-seed") "debug: set a specific seed for randomness" , Option [] ["debug-print-seed"] (NoArg DebugPrintSeed) "debug: set a specific seed for randomness" ]@@ -182,15 +206,19 @@ | BenchRecv `elem` flags = runBench False | otherwise = do certCredRequest <- getCredRequest- doTLS certCredRequest noSession+ doTLS certCredRequest noSession Nothing `E.catch` \(SomeException e) -> print e when (Session `elem` flags) $ do+ putStrLn "\nResuming the session..." session <- readIORef sStorage- doTLS certCredRequest (Just session)+ earlyData <- case getInput of+ Nothing -> return Nothing+ Just i -> Just <$> B.readFile i+ doTLS certCredRequest (Just session) earlyData `E.catch` \(SomeException e) -> print e where runBench isSend = runTLS (Debug `elem` flags) (IODebug `elem` flags)- (getDefaultParams flags hostname certStore sStorage Nothing noSession) hostname port $ \ctx -> do+ (getDefaultParams flags hostname certStore sStorage Nothing noSession Nothing) hostname port $ \ctx -> do handshake ctx if isSend then loopSendData getBenchAmount ctx@@ -210,7 +238,7 @@ d <- recvData ctx loopRecvData (bytes - B.length d) ctx - doTLS certCredRequest sess = do+ doTLS certCredRequest sess earlyData = E.bracket setup teardown $ \out -> do let query = LC.pack ( "GET " ++ findURI flags@@ -218,17 +246,30 @@ ++ userAgent ++ "\r\n\r\n") when (Verbose `elem` flags) (putStrLn "sending query:" >> LC.putStrLn query >> putStrLn "")- out <- maybe (return stdout) (flip openFile AppendMode) getOutput runTLS (Debug `elem` flags) (IODebug `elem` flags)- (getDefaultParams flags hostname certStore sStorage certCredRequest sess) hostname port $ \ctx -> do+ (getDefaultParams flags hostname certStore sStorage certCredRequest sess earlyData) hostname port $ \ctx -> do handshake ctx when (Verbose `elem` flags) $ printHandshakeInfo ctx+ case earlyData of+ Just edata -> do+ minfo <- contextGetInformation ctx+ case minfo of+ Nothing -> return () -- what should we do?+ Just info -> unless (infoIsEarlyDataAccepted info) $ do+ putStrLn "Resending 0RTT data ..."+ sendData ctx $ LC.fromStrict edata+ _ -> return () sendData ctx $ query loopRecv out ctx- bye ctx `catch` \(SomeException e) -> putStrLn $ "bye failed: " ++ show e+ when (UpdateKey `elem` flags) $ do+ _tls13 <- updateKey ctx TwoWay+ sendData ctx $ query+ loopRecv out ctx+ bye ctx `E.catch` \(SomeException e) -> putStrLn $ "bye failed: " ++ show e return ()- when (isJust getOutput) $ hClose out+ setup = maybe (return stdout) (flip openFile AppendMode) getOutput+ teardown out = when (isJust getOutput) $ hClose out loopRecv out ctx = do d <- timeout (timeoutMs * 1000) (recvData ctx) -- 2s per recv case d of@@ -239,7 +280,7 @@ getCredRequest = case clientCert of Nothing -> return Nothing- Just s -> do+ Just s -> case break (== ':') s of (_ ,"") -> error "wrong format for client-cert, expecting 'cert-file:key-file'" (cert,':':key) -> do@@ -248,7 +289,7 @@ Left err -> error ("cannot load client certificate: " ++ err) Right cred -> do let certRequest _ = return $ Just cred- return $ Just (Credentials [cred], certRequest)+ return $ Just certRequest (_ ,_) -> error "wrong format for client-cert, expecting 'cert-file:key-file'" findURI [] = "/"@@ -259,6 +300,9 @@ mUserAgent = foldl f Nothing flags where f _ (UserAgent ua) = Just ua f acc _ = acc+ getInput = foldl f Nothing flags+ where f _ (Input i) = Just i+ f acc _ = acc getOutput = foldl f Nothing flags where f _ (Output o) = Just o f acc _ = acc@@ -274,6 +318,10 @@ Just i -> i f acc _ = acc +getTrustAnchors flags = getCertificateStore (foldr getPaths [] flags)+ where getPaths (TrustAnchor path) acc = path : acc+ getPaths _ acc = acc+ printUsage = putStrLn $ usageInfo "usage: simpleclient [opts] <hostname> [port]\n\n\t(port default to: 443)\noptions:\n" options @@ -292,7 +340,11 @@ printCiphers exitSuccess - certStore <- getSystemCertificateStore+ when (ListGroups `elem` opts) $ do+ printGroups+ exitSuccess++ certStore <- getTrustAnchors opts sStorage <- newIORef (error "storage ioref undefined") case other of [hostname] -> runOn (sStorage, certStore) opts 443 hostname
src/SimpleServer.hs view
@@ -1,32 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} -- Disable this warning so we can still test deprecated functionality. {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++import Control.Concurrent+import qualified Control.Exception as E import Crypto.Random-import Network.BSD-import Network.Socket (socket, Family(..), SocketType(..), close, SockAddr(..), bind, listen, accept, iNADDR_ANY)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy.Char8 as LC+import Data.Default.Class+import Data.X509.CertificateStore+import Network.Socket (socket, close, bind, listen, accept) import qualified Network.Socket as S-import Network.TLS-import Network.TLS.Extra.Cipher+import Network.TLS.SessionManager import System.Console.GetOpt-import System.IO-import System.Timeout-import qualified Data.ByteString.Lazy.Char8 as LC-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString as B-import Control.Monad import System.Environment import System.Exit-import System.X509-import Data.X509.CertificateStore+import System.IO+import System.Timeout -import Data.Default.Class-import Data.IORef-import Data.Monoid-import Data.List (find)-import Data.Maybe (isJust, mapMaybe)+import Network.TLS+import Network.TLS.Extra.Cipher import Common import HexDump+import Imports defaultBenchAmount = 1024 * 1024 defaultTimeout = 2000@@ -51,14 +49,8 @@ } | otherwise = logging -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 :: [Flag] -> CertificateStore -> IORef (SessionID, SessionData) -> Credential -> IO ServerParams-getDefaultParams flags store sStorage cred = do+getDefaultParams :: [Flag] -> CertificateStore -> SessionManager -> Credential -> Bool -> IO ServerParams+getDefaultParams flags store smgr cred rtt0accept = do dhParams <- case getDHParams flags of Nothing -> return Nothing Just name -> readDHParams name@@ -67,7 +59,7 @@ { serverWantClientCert = False , serverCACertificates = [] , serverDHEParams = dhParams- , serverShared = def { sharedSessionManager = sessionRef sStorage+ , serverShared = def { sharedSessionManager = smgr , sharedCAStore = store , sharedValidationCache = validateCache , sharedCredentials = Credentials [cred]@@ -75,12 +67,15 @@ , serverHooks = def , serverSupported = def { supportedVersions = supportedVers , supportedCiphers = myCiphers- , supportedClientInitiatedRenegotiation = allowRenegotiation }+ , supportedGroups = getGroups flags+ , supportedClientInitiatedRenegotiation = allowRenegotiation+ } , serverDebug = def { debugSeed = foldl getDebugSeed Nothing flags , debugPrintSeed = if DebugPrintSeed `elem` flags then (\seed -> putStrLn ("seed: " ++ show (seedToInteger seed))) else (\_ -> return ()) }+ , serverEarlyDataSize = if rtt0accept then 2048 else 0 } where validateCache@@ -116,6 +111,7 @@ getDebugSeed acc _ = acc tlsConnectVer+ | Tls13 `elem` flags = TLS13 | Tls12 `elem` flags = TLS12 | Tls11 `elem` flags = TLS11 | Ssl3 `elem` flags = SSL3@@ -124,28 +120,42 @@ supportedVers | NoVersionDowngrade `elem` flags = [tlsConnectVer] | otherwise = filter (<= tlsConnectVer) allVers- allVers = [SSL3, TLS10, TLS11, TLS12]+ allVers = [SSL3, TLS10, TLS11, TLS12, TLS13] validateCert = not (NoValidateCert `elem` flags) allowRenegotiation = AllowRenegotiation `elem` flags -data Flag = Verbose | Debug | IODebug | NoValidateCert | Session | Http11- | Ssl3 | Tls10 | Tls11 | Tls12+getGroups flags = case getGroup >>= readGroups of+ Nothing -> defaultGroups+ Just [] -> defaultGroups+ Just groups -> groups+ where+ defaultGroups = supportedGroups def+ getGroup = foldl f Nothing flags+ where f _ (Group g) = Just g+ f acc _ = acc++data Flag = Verbose | Debug | IODebug | NoValidateCert | Http11+ | Ssl3 | Tls10 | Tls11 | Tls12 | Tls13 | NoVersionDowngrade | AllowRenegotiation | Output String | Timeout String | BogusCipher String+ | TrustAnchor String | BenchSend | BenchRecv | BenchData String | UseCipher String | ListCiphers+ | ListGroups | ListDHParams | Certificate String | Key String | DHParams String+ | Rtt0 | DebugSeed String | DebugPrintSeed+ | Group String | Help deriving (Show,Eq) @@ -154,15 +164,18 @@ [ Option ['v'] ["verbose"] (NoArg Verbose) "verbose output on stdout" , Option ['d'] ["debug"] (NoArg Debug) "TLS debug output on stdout" , Option [] ["io-debug"] (NoArg IODebug) "TLS IO debug output on stdout"- , Option ['s'] ["session"] (NoArg Session) "try to resume a session"+ , Option ['Z'] ["zerortt"] (NoArg Rtt0) "accept TLS 1.3 0RTT data" , Option ['O'] ["output"] (ReqArg Output "stdout") "output "+ , Option ['g'] ["group"] (ReqArg Group "group") "group" , Option ['t'] ["timeout"] (ReqArg Timeout "timeout") "timeout in milliseconds (2s by default)" , Option [] ["no-validation"] (NoArg NoValidateCert) "disable certificate validation"+ , Option [] ["trust-anchor"] (ReqArg TrustAnchor "pem-or-dir") "use provided CAs instead of system certificate store" , Option [] ["http1.1"] (NoArg Http11) "use http1.1 instead of http1.0" , Option [] ["ssl3"] (NoArg Ssl3) "use SSL 3.0" , Option [] ["tls10"] (NoArg Tls10) "use TLS 1.0" , Option [] ["tls11"] (NoArg Tls11) "use TLS 1.1" , Option [] ["tls12"] (NoArg Tls12) "use TLS 1.2 (default)"+ , Option [] ["tls13"] (NoArg Tls13) "use TLS 1.3" , Option [] ["bogocipher"] (ReqArg BogusCipher "cipher-id") "add a bogus cipher id for testing" , Option ['x'] ["no-version-downgrade"] (NoArg NoVersionDowngrade) "do not allow version downgrade" , Option [] ["allow-renegotiation"] (NoArg AllowRenegotiation) "allow client-initiated renegotiation"@@ -172,6 +185,7 @@ , Option [] ["bench-data"] (ReqArg BenchData "amount") "amount of data to benchmark with" , Option [] ["use-cipher"] (ReqArg UseCipher "cipher-id") "use a specific cipher" , Option [] ["list-ciphers"] (NoArg ListCiphers) "list all ciphers supported and exit"+ , Option [] ["list-groups"] (NoArg ListGroups) "list all groups supported and exit" , Option [] ["list-dhparams"] (NoArg ListDHParams) "list all DH parameters supported and exit" , Option [] ["certificate"] (ReqArg Certificate "certificate") "certificate file" , Option [] ["debug-seed"] (ReqArg DebugSeed "debug-seed") "debug: set a specific seed for randomness"@@ -191,9 +205,10 @@ error "missing credential certificate" runOn (sStorage, certStore) flags port = do- sock <- socket AF_INET Stream defaultProtocol+ ai <- makeAddrInfo Nothing port+ sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai) S.setSocketOption sock S.ReuseAddr 1- let sockaddr = SockAddrInet port iNADDR_ANY+ let sockaddr = addrAddress ai bind sock sockaddr listen sock 10 runOn' sock@@ -204,13 +219,14 @@ | BenchRecv `elem` flags = runBench False sock | otherwise = do --certCredRequest <- getCredRequest- doTLS sock- when (Session `elem` flags) $ doTLS sock+ E.bracket (maybe (return stdout) (flip openFile AppendMode) getOutput)+ (\out -> when (isJust getOutput) $ hClose out)+ (doTLS sock) runBench isSend sock = do (cSock, cAddr) <- accept sock putStrLn ("connection from " ++ show cAddr) cred <- loadCred getKey getCertificate- params <- getDefaultParams flags certStore sStorage cred+ params <- getDefaultParams flags certStore sStorage cred False runTLS False False params cSock $ \ctx -> do handshake ctx if isSend@@ -232,25 +248,27 @@ d <- recvData ctx loopRecvData (bytes - B.length d) ctx - doTLS sock = do+ doTLS sock out = do (cSock, cAddr) <- accept sock putStrLn ("connection from " ++ show cAddr)- out <- maybe (return stdout) (flip openFile AppendMode) getOutput cred <- loadCred getKey getCertificate- params <- getDefaultParams flags certStore sStorage cred+ let rtt0accept = Rtt0 `elem` flags+ params <- getDefaultParams flags certStore sStorage cred rtt0accept - runTLS (Debug `elem` flags)- (IODebug `elem` flags)- params cSock $ \ctx -> do- handshake ctx- when (Verbose `elem` flags) $ printHandshakeInfo ctx- loopRecv out ctx- --sendData ctx $ query- bye ctx- return ()- close cSock- when (isJust getOutput) $ hClose out+ void $ forkIO $ do+ runTLS (Debug `elem` flags)+ (IODebug `elem` flags)+ params cSock $ \ctx -> do+ handshake ctx+ when (Verbose `elem` flags) $ printHandshakeInfo ctx+ loopRecv out ctx+ --sendData ctx $ query+ bye ctx+ return ()+ close cSock+ doTLS sock out+ loopRecv out ctx = do d <- timeout (timeoutMs * 1000) (recvData ctx) -- 2s per recv case d of@@ -293,6 +311,10 @@ Just i -> i f acc _ = acc +getTrustAnchors flags = getCertificateStore (foldr getPaths [] flags)+ where getPaths (TrustAnchor path) acc = path : acc+ getPaths _ acc = acc+ printUsage = putStrLn $ usageInfo "usage: simpleserver [opts] [port]\n\n\t(port default to: 443)\noptions:\n" options @@ -315,8 +337,12 @@ printDHParams exitSuccess - certStore <- getSystemCertificateStore- sStorage <- newIORef (error "storage ioref undefined")+ when (ListGroups `elem` opts) $ do+ printGroups+ exitSuccess++ certStore <- getTrustAnchors opts+ sStorage <- newSessionManager defaultConfig case other of [] -> runOn (sStorage, certStore) opts 443 [port] -> runOn (sStorage, certStore) opts (fromInteger $ read port)
src/Stunnel.hs view
@@ -1,34 +1,27 @@-{-# LANGUAGE DeriveDataTypeable #-} -- Disable this warning so we can still test deprecated functionality. {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}-import Network.BSD-import Network.Socket hiding (Debug)-import System.IO-import System.IO.Error (isEOFError)-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- import Control.Concurrent (forkIO)-import Control.Concurrent.MVar import Control.Exception (finally, throw, SomeException(..)) import qualified Control.Exception as E-import Control.Monad (when, forever)--import Data.Char (isDigit)+import qualified Crypto.PubKey.DH as DH ()+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L import Data.Default.Class+import Data.X509.Validation+import Network.Socket hiding (Debug)+import Network.TLS.SessionManager+import System.Console.GetOpt+import System.Environment (getArgs)+import System.Exit+import System.IO+import System.IO.Error (isEOFError) import Network.TLS import Network.TLS.Extra.Cipher -import qualified Crypto.PubKey.DH as DH ()- import Common+import Imports loopUntil :: Monad m => m Bool -> m () loopUntil f = f >>= \v -> if v then return () else loopUntil f@@ -74,15 +67,7 @@ return False putStrLn "end" -newtype MemSessionManager = MemSessionManager (MVar [(SessionID, SessionData)])--memSessionManager (MemSessionManager mvar) = SessionManager- { sessionEstablish = \sid sdata -> modifyMVar_ mvar (\l -> return $ (sid,sdata) : l)- , sessionResume = \sid -> withMVar mvar (return . lookup sid)- , sessionInvalidate = \_ -> return ()- }--clientProcess dhParamsFile creds handle dsthandle dbg sessionStorage _ = do+clientProcess dhParamsFile creds handle dsthandle dbg sessionManager _ = do let logging = if not dbg then def else def { loggingPacketSent = putStrLn . ("debug: send: " ++)@@ -96,7 +81,7 @@ let serverstate = def { serverSupported = def { supportedCiphers = ciphersuite_default } , serverShared = def { sharedCredentials = creds- , sharedSessionManager = maybe noSessionManager (memSessionManager . MemSessionManager) sessionStorage+ , sharedSessionManager = sessionManager } , serverDHEParams = dhParams }@@ -117,13 +102,8 @@ getAddressDescription (Address "tcp" desc) = do let (s, p) = break ((==) ':') desc 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- service <- getServiceByName (drop 1 p) "tcp"- return $ servicePort service- he <- getHostByName s- return $ AddrSocket AF_INET (SockAddrInet pn (head $ hostAddresses he))+ addr:_ <- getAddrInfo Nothing (Just s) (Just $ drop 1 p)+ return $ AddrSocket (addrFamily addr) (addrAddress addr) getAddressDescription (Address "unix" desc) = do return $ AddrSocket AF_UNIX (SockAddrUnix desc)@@ -163,7 +143,7 @@ , loggingPacketRecv = putStrLn . ("debug: recv: " ++) } - store <- getSystemCertificateStore+ store <- getTrustAnchors flags let validateCache | NoCertValidation `elem` flags = ValidationCache (\_ _ _ -> return ValidationCachePass)@@ -208,7 +188,10 @@ dstaddr <- getAddressDescription destination let dhParamsFile = getDHParams flags - sessionStorage <- if NoSession `elem` flags then return Nothing else (Just `fmap` newMVar [])+ sessionManager <-+ if NoSession `elem` flags+ then return noSessionManager+ else newSessionManager defaultConfig case srcaddr of AddrSocket _ _ -> do@@ -222,7 +205,7 @@ StunnelSocket dst -> socketToHandle dst ReadWriteMode _ <- forkIO $ finally- (clientProcess dhParamsFile creds srch dsth (Debug `elem` flags) sessionStorage addr >> return ())+ (clientProcess dhParamsFile creds srch dsth (Debug `elem` flags) sessionManager addr >> return ()) (hClose srch >> (when (dsth /= stdout) $ hClose dsth)) return () AddrFD _ _ -> error "bad error fd. not implemented"@@ -243,6 +226,7 @@ | DHParams String | NoSession | NoCertValidation+ | TrustAnchor String deriving (Show,Eq) options :: [OptDescr Flag]@@ -259,6 +243,7 @@ , Option [] ["dhparams"] (ReqArg DHParams "dhparams") "DH parameters (name or file)" , Option [] ["no-session"] (NoArg NoSession) "disable support for session" , Option [] ["no-cert-validation"] (NoArg NoCertValidation) "disable certificate validation"+ , Option [] ["trust-anchor"] (ReqArg TrustAnchor "pem-or-dir") "use provided CAs instead of system certificate store" ] data Address = Address String String@@ -288,6 +273,10 @@ getKey opts = reverse $ onNull ["certificate.key"] $ foldl accf [] opts where accf acc (Key key) = key : acc accf acc _ = acc++getTrustAnchors flags = getCertificateStore (foldr getPaths [] flags)+ where getPaths (TrustAnchor path) acc = path : acc+ getPaths _ acc = acc getDHParams opts = foldl accf Nothing opts where accf _ (DHParams file) = Just file
tls-debug.cabal view
@@ -1,5 +1,5 @@ Name: tls-debug-Version: 0.4.5+Version: 0.4.6 Description: A set of program to test and debug various aspect of the TLS package. .@@ -18,14 +18,18 @@ Executable tls-stunnel Main-is: Stunnel.hs Other-modules: Common+ , Imports Hs-Source-Dirs: src Build-Depends: base >= 4 && < 5 , network , bytestring+ , x509-store , x509-system >= 1.0+ , x509-validation >= 1.5 , data-default-class , cryptonite >= 0.24- , tls >= 1.3.0 && < 1.5+ , tls >= 1.5.0+ , tls-session-manager if os(windows) Buildable: False else@@ -40,23 +44,23 @@ -- , bytestring -- , cprng-aes -- , x509-system >= 1.0--- , tls >= 1.2 && < 1.3+-- , tls >= 1.2 && < 1.6 -- Buildable: True -- ghc-options: -Wall -fno-warn-missing-signatures Executable tls-retrievecertificate Main-is: RetrieveCertificate.hs+ Other-modules: Imports Hs-Source-Dirs: src Build-Depends: base >= 4 && < 5 , network , bytestring- , time , pem- , cryptonite , x509 , x509-system >= 1.4- , x509-validation >= 1.5.0- , tls >= 1.3 && < 1.5+ , x509-validation >= 1.5+ , data-default-class+ , tls >= 1.3 && < 1.6 Buildable: True ghc-options: -Wall -fno-warn-missing-signatures @@ -64,14 +68,16 @@ Main-is: SimpleClient.hs Other-modules: Common , HexDump+ , Imports Hs-Source-Dirs: src Build-Depends: base >= 4 && < 5 , network , bytestring , data-default-class , cryptonite >= 0.14+ , x509-store , x509-system >= 1.0- , tls >= 1.3.6 && < 1.5+ , tls >= 1.5.0 && < 1.6 Buildable: True ghc-options: -Wall -fno-warn-missing-signatures @@ -79,6 +85,7 @@ Main-is: SimpleServer.hs Other-modules: Common , HexDump+ , Imports Hs-Source-Dirs: src Build-Depends: base >= 4 && < 5 , network@@ -87,7 +94,8 @@ , cryptonite , x509-store , x509-system >= 1.0- , tls >= 1.3 && < 1.5+ , tls >= 1.5.0 && < 1.6+ , tls-session-manager Buildable: True ghc-options: -Wall -fno-warn-missing-signatures