diff --git a/src/Common.hs b/src/Common.hs new file mode 100644 --- /dev/null +++ b/src/Common.hs @@ -0,0 +1,88 @@ +-- Disable this warning so we can still test deprecated functionality. +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +module Common + ( printCiphers + , printDHParams + , readNumber + , readCiphers + , readDHParams + , printHandshakeInfo + ) where + +import Control.Monad + +import Data.Char (isDigit) + +import Numeric (showHex) + +import Network.TLS +import Network.TLS.Extra.Cipher +import Network.TLS.Extra.FFDHE + +namedDHParams :: [(String, DHParams)] +namedDHParams = + [ ("ffdhe2048", ffdhe2048) + , ("ffdhe3072", ffdhe3072) + , ("ffdhe4096", ffdhe4096) + , ("ffdhe6144", ffdhe6144) + , ("ffdhe8192", ffdhe8192) + ] + +namedCiphersuites :: [(String, [CipherID])] +namedCiphersuites = + [ ("all", map cipherID ciphersuite_all) + , ("default", map cipherID ciphersuite_default) + , ("strong", map cipherID ciphersuite_strong) + ] + +readNumber :: (Num a, Read a) => String -> Maybe a +readNumber s + | all isDigit s = Just $ read s + | otherwise = Nothing + +readCiphers :: String -> Maybe [CipherID] +readCiphers s = + case lookup s namedCiphersuites of + Nothing -> (:[]) `fmap` readNumber s + just -> just + +readDHParams :: String -> IO (Maybe DHParams) +readDHParams s = + case lookup s namedDHParams of + Nothing -> (Just . read) `fmap` readFile s + mparams -> return mparams + +printCiphers :: IO () +printCiphers = do + putStrLn "Supported ciphers" + putStrLn "=====================================" + forM_ ciphersuite_all $ \c -> do + putStrLn (pad 50 (cipherName c) ++ " = " ++ pad 5 (show $ cipherID c) ++ " 0x" ++ showHex (cipherID c) "") + putStrLn "" + putStrLn "Ciphersuites" + putStrLn "=====================================" + forM_ namedCiphersuites $ \(name, _) -> putStrLn name + where + pad n s + | length s < n = s ++ replicate (n - length s) ' ' + | otherwise = s + +printDHParams :: IO () +printDHParams = do + putStrLn "DH Parameters" + putStrLn "=====================================" + forM_ namedDHParams $ \(name, _) -> putStrLn name + putStrLn "(or /path/to/dhparams)" + +printHandshakeInfo ctx = do + info <- contextGetInformation ctx + case info of + Nothing -> return () + Just i -> do + putStrLn ("version: " ++ show (infoVersion i)) + putStrLn ("cipher: " ++ show (infoCipher i)) + putStrLn ("compression: " ++ show (infoCompression i)) + sni <- getClientSNI ctx + case sni of + Nothing -> return () + Just n -> putStrLn ("server name indication: " ++ n) diff --git a/src/RetrieveCertificate.hs b/src/RetrieveCertificate.hs --- a/src/RetrieveCertificate.hs +++ b/src/RetrieveCertificate.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable, ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} import Network.TLS import Network.TLS.Extra.Cipher @@ -40,7 +41,7 @@ else servicePort <$> getServiceByName p "tcp" he <- getHostByName s - sock <- bracketOnError (socket AF_INET Stream defaultProtocol) sClose $ \sock -> do + sock <- bracketOnError (socket AF_INET Stream defaultProtocol) close $ \sock -> do connect sock (SockAddrInet pn (head $ hostAddresses he)) return sock ctx <- contextNew sock params diff --git a/src/SimpleClient.hs b/src/SimpleClient.hs --- a/src/SimpleClient.hs +++ b/src/SimpleClient.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} import Crypto.Random import Network.BSD -import Network.Socket (socket, Family(..), SocketType(..), sClose, SockAddr(..), connect) +import Network.Socket (socket, Family(..), SocketType(..), close, SockAddr(..), connect) import Network.TLS import Network.TLS.Extra.Cipher import System.Console.GetOpt @@ -21,33 +21,12 @@ import Data.Default.Class import Data.IORef import Data.Monoid -import Data.Char (isDigit) -import Data.X509.Validation - -import Numeric (showHex) +import Data.List (find) +import Data.Maybe (isJust, mapMaybe) +import Common import HexDump -ciphers :: [Cipher] -ciphers = - [ 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 - , cipher_RSA_3DES_EDE_CBC_SHA1 - , cipher_DHE_RSA_AES128GCM_SHA256 - --, cipher_ECDHE_RSA_AES256GCM_SHA384 - , cipher_ECDHE_RSA_AES256CBC_SHA - , cipher_ECDHE_RSA_AES128GCM_SHA256 - , cipher_ECDHE_ECDSA_AES128GCM_SHA256 - ] - defaultBenchAmount = 1024 * 1024 defaultTimeout = 2000 @@ -58,11 +37,11 @@ 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)) + (\(SomeException e) -> close sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) ctx <- contextNew sock params contextHookSetLogging ctx getLogging () <- f ctx - sClose sock + close sock where getLogging = ioLogging $ packetLogging $ def packetLogging logging | debug = logging { loggingPacketSent = putStrLn . ("debug: >> " ++) @@ -84,7 +63,7 @@ } getDefaultParams flags host store sStorage certCredsRequest session = - (defaultParamsClient host BC.empty) + (defaultParamsClient serverName BC.empty) { clientSupported = def { supportedVersions = supportedVers, supportedCiphers = myCiphers } , clientWantSessionResume = session , clientUseServerNameIndication = not (NoSNI `elem` flags) @@ -101,27 +80,32 @@ } } where + serverName = foldl f host flags + where f _ (SNI n) = n + f acc _ = acc + validateCache | validateCert = def | otherwise = ValidationCache (\_ _ _ -> return ValidationCachePass) (\_ _ _ -> return ()) - myCiphers = foldl accBogusCipher (filter withUseCipher ciphers) flags + myCiphers = foldl accBogusCipher getSelectedCiphers flags where accBogusCipher acc (BogusCipher c) = case reads c of [(v, "")] -> acc ++ [bogusCipher v] _ -> acc accBogusCipher acc _ = acc - getUsedCiphers = foldl f [] flags - where f acc (UseCipher am) = case readNumber am of - Nothing -> acc - Just i -> i : acc + getUsedCipherIDs = foldl f [] flags + where f acc (UseCipher am) = + case readCiphers am of + Just l -> l ++ acc + Nothing -> acc f acc _ = acc - withUseCipher c = - case getUsedCiphers of - [] -> True - l -> cipherID c `elem` l + getSelectedCiphers = + case getUsedCipherIDs of + [] -> ciphersuite_all + l -> mapMaybe (\cid -> find ((== cid) . cipherID) ciphersuite_all) l getDebugSeed :: Maybe Seed -> Flag -> Maybe Seed getDebugSeed _ (DebugSeed seed) = seedFromInteger `fmap` readNumber seed @@ -141,6 +125,7 @@ data Flag = Verbose | Debug | IODebug | NoValidateCert | Session | Http11 | Ssl3 | Tls10 | Tls11 | Tls12 + | SNI String | NoSNI | Uri String | NoVersionDowngrade @@ -171,6 +156,7 @@ , Option [] ["client-cert"] (ReqArg ClientCert "cert-file:key-file") "add a client certificate to use with the server" , 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" , Option [] ["no-sni"] (NoArg NoSNI) "don't use server name indication" , Option [] ["user-agent"] (ReqArg UserAgent "user-agent") "use a user agent" , Option [] ["tls10"] (NoArg Tls10) "use TLS 1.0" @@ -183,7 +169,7 @@ , Option [] ["bench-send"] (NoArg BenchSend) "benchmark send path. only with compatible server" , Option [] ["bench-recv"] (NoArg BenchRecv) "benchmark recv path. only with compatible server" , Option [] ["bench-data"] (ReqArg BenchData "amount") "amount of data to benchmark with" - , Option [] ["use-cipher"] (ReqArg UseCipher "cipher-id") "use a specific cipher" + , Option [] ["use-cipher"] (ReqArg UseCipher "cipher-id") "use a specific cipher" , Option [] ["list-ciphers"] (NoArg ListCiphers) "list all ciphers 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" @@ -232,15 +218,17 @@ ++ userAgent ++ "\r\n\r\n") when (Verbose `elem` flags) (putStrLn "sending query:" >> LC.putStrLn query >> putStrLn "") - out <- maybe (return stdout) (flip openFile WriteMode) getOutput + 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 handshake ctx + when (Verbose `elem` flags) $ printHandshakeInfo ctx sendData ctx $ query loopRecv out ctx - bye ctx + bye ctx `catch` \(SomeException e) -> putStrLn $ "bye failed: " ++ show e return () + when (isJust getOutput) $ hClose out loopRecv out ctx = do d <- timeout (timeoutMs * 1000) (recvData ctx) -- 2s per recv case d of @@ -286,23 +274,8 @@ Just i -> i f acc _ = acc -readNumber :: (Num a, Read a) => String -> Maybe a -readNumber s - | all isDigit s = Just $ read s - | otherwise = Nothing - printUsage = putStrLn $ usageInfo "usage: simpleclient [opts] [port]\n\n\t(port default to: 443)\noptions:\n" options - -printCiphers = do - putStrLn "Supported ciphers" - putStrLn "=====================================" - forM_ ciphers $ \c -> do - putStrLn (pad 50 (cipherName c) ++ " = " ++ pad 5 (show $ cipherID c) ++ " 0x" ++ showHex (cipherID c) "") - where - pad n s - | length s < n = s ++ replicate (n - length s) ' ' - | otherwise = s main = do args <- getArgs diff --git a/src/SimpleServer.hs b/src/SimpleServer.hs --- a/src/SimpleServer.hs +++ b/src/SimpleServer.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +-- Disable this warning so we can still test deprecated functionality. +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} import Crypto.Random import Network.BSD -import Network.Socket (socket, Family(..), SocketType(..), sClose, SockAddr(..), bind, listen, accept, iNADDR_ANY) +import Network.Socket (socket, Family(..), SocketType(..), close, SockAddr(..), bind, listen, accept, iNADDR_ANY) +import qualified Network.Socket as S import Network.TLS import Network.TLS.Extra.Cipher import System.Console.GetOpt @@ -11,8 +13,6 @@ 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 System.Environment import System.Exit @@ -22,49 +22,21 @@ import Data.Default.Class import Data.IORef import Data.Monoid -import Data.Char (isDigit) -import Data.X509.Validation - -import Numeric (showHex) +import Data.List (find) +import Data.Maybe (isJust, mapMaybe) +import Common import HexDump -ciphers :: [Cipher] -ciphers = - [ 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 - , cipher_RSA_3DES_EDE_CBC_SHA1 - , cipher_DHE_RSA_AES128GCM_SHA256 - ] - defaultBenchAmount = 1024 * 1024 defaultTimeout = 2000 bogusCipher cid = cipher_AES128_SHA1 { cipherID = cid } -runTLS debug ioDebug params portNumber f = do - sock <- socket AF_INET Stream defaultProtocol - let sockaddr = SockAddrInet portNumber iNADDR_ANY - - bind sock sockaddr - listen sock 1 - (cSock, cAddr) <- accept sock - - putStrLn ("connection from " ++ show cAddr) - +runTLS debug ioDebug params cSock f = do ctx <- contextNew cSock params contextHookSetLogging ctx getLogging - () <- f ctx - sClose cSock - sClose sock + f ctx where getLogging = ioLogging $ packetLogging $ def packetLogging logging | debug = logging { loggingPacketSent = putStrLn . ("debug: >> " ++) @@ -85,19 +57,25 @@ , sessionInvalidate = \_ -> return () } -getDefaultParams :: [Flag] -> CertificateStore -> IORef (SessionID, SessionData) -> Credential -> Maybe (SessionID, SessionData) -> ServerParams -getDefaultParams flags store sStorage cred session = - ServerParams +getDefaultParams :: [Flag] -> CertificateStore -> IORef (SessionID, SessionData) -> Credential -> IO ServerParams +getDefaultParams flags store sStorage cred = do + dhParams <- case getDHParams flags of + Nothing -> return Nothing + Just name -> readDHParams name + + return ServerParams { serverWantClientCert = False , serverCACertificates = [] - , serverDHEParams = Nothing + , serverDHEParams = dhParams , serverShared = def { sharedSessionManager = sessionRef sStorage , sharedCAStore = store , sharedValidationCache = validateCache , sharedCredentials = Credentials [cred] } , serverHooks = def - , serverSupported = def { supportedVersions = supportedVers, supportedCiphers = myCiphers } + , serverSupported = def { supportedVersions = supportedVers + , supportedCiphers = myCiphers + , supportedClientInitiatedRenegotiation = allowRenegotiation } , serverDebug = def { debugSeed = foldl getDebugSeed Nothing flags , debugPrintSeed = if DebugPrintSeed `elem` flags then (\seed -> putStrLn ("seed: " ++ show (seedToInteger seed))) @@ -110,24 +88,29 @@ | otherwise = ValidationCache (\_ _ _ -> return ValidationCachePass) (\_ _ _ -> return ()) - myCiphers = foldl accBogusCipher (filter withUseCipher ciphers) flags + myCiphers = foldl accBogusCipher getSelectedCiphers flags where accBogusCipher acc (BogusCipher c) = case reads c of [(v, "")] -> acc ++ [bogusCipher v] _ -> acc accBogusCipher acc _ = acc - getUsedCiphers = foldl f [] flags - where f acc (UseCipher am) = case readNumber am of - Nothing -> acc - Just i -> i : acc + getUsedCipherIDs = foldl f [] flags + where f acc (UseCipher am) = + case readCiphers am of + Just l -> l ++ acc + Nothing -> acc f acc _ = acc - withUseCipher c = - case getUsedCiphers of - [] -> True - l -> cipherID c `elem` l + getSelectedCiphers = + case getUsedCipherIDs of + [] -> ciphersuite_default + l -> mapMaybe (\cid -> find ((== cid) . cipherID) ciphersuite_all) l + getDHParams opts = foldl accf Nothing opts + where accf _ (DHParams file) = Just file + accf acc _ = acc + getDebugSeed :: Maybe Seed -> Flag -> Maybe Seed getDebugSeed _ (DebugSeed seed) = seedFromInteger `fmap` readNumber seed getDebugSeed acc _ = acc @@ -143,11 +126,12 @@ | otherwise = filter (<= tlsConnectVer) allVers allVers = [SSL3, TLS10, TLS11, TLS12] validateCert = not (NoValidateCert `elem` flags) + allowRenegotiation = AllowRenegotiation `elem` flags data Flag = Verbose | Debug | IODebug | NoValidateCert | Session | Http11 | Ssl3 | Tls10 | Tls11 | Tls12 - | NoSNI | NoVersionDowngrade + | AllowRenegotiation | Output String | Timeout String | BogusCipher String @@ -156,8 +140,10 @@ | BenchData String | UseCipher String | ListCiphers + | ListDHParams | Certificate String | Key String + | DHParams String | DebugSeed String | DebugPrintSeed | Help @@ -174,26 +160,26 @@ , 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" - , Option [] ["no-sni"] (NoArg NoSNI) "don't use server name indication" , 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 [] ["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" , Option ['h'] ["help"] (NoArg Help) "request help" , Option [] ["bench-send"] (NoArg BenchSend) "benchmark send path. only with compatible server" , Option [] ["bench-recv"] (NoArg BenchRecv) "benchmark recv path. only with compatible server" , Option [] ["bench-data"] (ReqArg BenchData "amount") "amount of data to benchmark with" - , Option [] ["use-cipher"] (ReqArg UseCipher "cipher-id") "use a specific cipher" + , Option [] ["use-cipher"] (ReqArg UseCipher "cipher-id") "use a specific cipher" , Option [] ["list-ciphers"] (NoArg ListCiphers) "list all ciphers 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" , Option [] ["debug-print-seed"] (NoArg DebugPrintSeed) "debug: set a specific seed for randomness" , Option [] ["key"] (ReqArg Key "key") "certificate file" + , Option [] ["dhparams"] (ReqArg DHParams "dhparams") "DH parameters (name or file)" ] -noSession = Nothing - loadCred (Just key) (Just cert) = do res <- credentialLoadX509 cert key case res of @@ -204,25 +190,34 @@ loadCred _ Nothing = error "missing credential certificate" -runOn (sStorage, certStore) flags port - | BenchSend `elem` flags = runBench True - | BenchRecv `elem` flags = runBench False - | otherwise = do - --certCredRequest <- getCredRequest - doTLS noSession - when (Session `elem` flags) $ do - session <- readIORef sStorage - doTLS (Just session) +runOn (sStorage, certStore) flags port = do + sock <- socket AF_INET Stream defaultProtocol + S.setSocketOption sock S.ReuseAddr 1 + let sockaddr = SockAddrInet port iNADDR_ANY + bind sock sockaddr + listen sock 10 + runOn' sock + close sock where - runBench isSend = do + runOn' sock + | BenchSend `elem` flags = runBench True sock + | BenchRecv `elem` flags = runBench False sock + | otherwise = do + --certCredRequest <- getCredRequest + doTLS sock + when (Session `elem` flags) $ doTLS sock + runBench isSend sock = do + (cSock, cAddr) <- accept sock + putStrLn ("connection from " ++ show cAddr) cred <- loadCred getKey getCertificate - runTLS False False - (getDefaultParams flags certStore sStorage cred noSession) port $ \ctx -> do + params <- getDefaultParams flags certStore sStorage cred + runTLS False False params cSock $ \ctx -> do handshake ctx if isSend then loopSendData getBenchAmount ctx else loopRecvData getBenchAmount ctx bye ctx + close cSock where dataSend = BC.replicate 4096 'a' loopSendData bytes ctx @@ -237,19 +232,25 @@ d <- recvData ctx loopRecvData (bytes - B.length d) ctx - doTLS sess = do - out <- maybe (return stdout) (flip openFile WriteMode) getOutput + doTLS sock = 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 runTLS (Debug `elem` flags) (IODebug `elem` flags) - (getDefaultParams flags certStore sStorage cred sess) port $ \ctx -> do + 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 loopRecv out ctx = do d <- timeout (timeoutMs * 1000) (recvData ctx) -- 2s per recv case d of @@ -292,24 +293,9 @@ Just i -> i f acc _ = acc -readNumber :: (Num a, Read a) => String -> Maybe a -readNumber s - | all isDigit s = Just $ read s - | otherwise = Nothing - printUsage = putStrLn $ usageInfo "usage: simpleserver [opts] [port]\n\n\t(port default to: 443)\noptions:\n" options -printCiphers = do - putStrLn "Supported ciphers" - putStrLn "=====================================" - forM_ ciphers $ \c -> do - putStrLn (pad 50 (cipherName c) ++ " = " ++ pad 5 (show $ cipherID c) ++ " 0x" ++ showHex (cipherID c) "") - where - pad n s - | length s < n = s ++ replicate (n - length s) ' ' - | otherwise = s - main = do args <- getArgs let (opts,other,errs) = getOpt Permute options args @@ -323,6 +309,10 @@ when (ListCiphers `elem` opts) $ do printCiphers + exitSuccess + + when (ListDHParams `elem` opts) $ do + printDHParams exitSuccess certStore <- getSystemCertificateStore diff --git a/src/Stunnel.hs b/src/Stunnel.hs --- a/src/Stunnel.hs +++ b/src/Stunnel.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} +-- 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 @@ -15,33 +16,19 @@ import Control.Concurrent (forkIO) import Control.Concurrent.MVar -import Control.Exception (finally, throw, SomeException) +import Control.Exception (finally, throw, SomeException(..)) import qualified Control.Exception as E import Control.Monad (when, forever) import Data.Char (isDigit) import Data.Default.Class -import Crypto.Random import Network.TLS import Network.TLS.Extra.Cipher import qualified Crypto.PubKey.DH as DH () -ciphers :: [Cipher] -ciphers = - [ 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 - ] +import Common loopUntil :: Monad m => m Bool -> m () loopUntil f = f >>= \v -> if v then return () else loopUntil f @@ -104,10 +91,10 @@ dhParams <- case dhParamsFile of Nothing -> return Nothing - Just file -> (Just . read) `fmap` readFile file + Just name -> readDHParams name let serverstate = def - { serverSupported = def { supportedCiphers = ciphers } + { serverSupported = def { supportedCiphers = ciphersuite_default } , serverShared = def { sharedCredentials = creds , sharedSessionManager = maybe noSessionManager (memSessionManager . MemSessionManager) sessionStorage } @@ -149,7 +136,7 @@ connectAddressDescription (AddrSocket family sockaddr) = do sock <- socket family Stream defaultProtocol E.catch (connect sock sockaddr) - (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) + (\(SomeException e) -> close sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) return $ StunnelSocket sock connectAddressDescription (AddrFD h1 h2) = do @@ -157,8 +144,8 @@ listenAddressDescription (AddrSocket family sockaddr) = do sock <- socket family Stream defaultProtocol - E.catch (bindSocket sock sockaddr >> listen sock 10 >> setSocketOption sock ReuseAddr 1) - (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) + E.catch (bind sock sockaddr >> listen sock 10 >> setSocketOption sock ReuseAddr 1) + (\(SomeException e) -> close sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) return $ StunnelSocket sock listenAddressDescription (AddrFD _ _) = do @@ -183,7 +170,7 @@ (\_ _ _ -> return ()) | otherwise = def let clientstate = (defaultParamsClient a B.empty) - { clientSupported = def { supportedCiphers = ciphers } + { clientSupported = def { supportedCiphers = ciphersuite_all } , clientShared = def { sharedCAStore = store, sharedValidationCache = validateCache } } @@ -250,6 +237,7 @@ | DestinationType String | Debug | Help + | ListDHParams | Certificate String | Key String | DHParams String @@ -265,9 +253,10 @@ , 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 [] ["list-dhparams"] (NoArg ListDHParams) "list all DH parameters supported and exit" , Option [] ["certificate"] (ReqArg Certificate "certificate") "certificate file" , Option [] ["key"] (ReqArg Key "key") "certificate file" - , Option [] ["dhparams"] (ReqArg DHParams "dhparams") "DH parameter file" + , 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" ] @@ -314,6 +303,10 @@ when (Help `elem` opts) $ do printUsage + exitSuccess + + when (ListDHParams `elem` opts) $ do + printDHParams exitSuccess let source = getSource opts diff --git a/tls-debug.cabal b/tls-debug.cabal --- a/tls-debug.cabal +++ b/tls-debug.cabal @@ -1,5 +1,5 @@ Name: tls-debug -Version: 0.4.4 +Version: 0.4.5 Description: A set of program to test and debug various aspect of the TLS package. . @@ -14,18 +14,18 @@ stability: experimental Cabal-Version: >=1.6 Homepage: http://github.com/vincenthz/hs-tls -extra-source-files: src/HexDump.hs Executable tls-stunnel Main-is: Stunnel.hs + Other-modules: Common Hs-Source-Dirs: src Build-Depends: base >= 4 && < 5 , network , bytestring , x509-system >= 1.0 , data-default-class - , cryptonite - , tls >= 1.3.0 && < 1.4 + , cryptonite >= 0.24 + , tls >= 1.3.0 && < 1.5 if os(windows) Buildable: False else @@ -56,12 +56,14 @@ , x509 , x509-system >= 1.4 , x509-validation >= 1.5.0 - , tls >= 1.3 && < 1.4 + , tls >= 1.3 && < 1.5 Buildable: True ghc-options: -Wall -fno-warn-missing-signatures Executable tls-simpleclient Main-is: SimpleClient.hs + Other-modules: Common + , HexDump Hs-Source-Dirs: src Build-Depends: base >= 4 && < 5 , network @@ -69,12 +71,14 @@ , data-default-class , cryptonite >= 0.14 , x509-system >= 1.0 - , tls >= 1.3.6 && < 1.4 + , tls >= 1.3.6 && < 1.5 Buildable: True ghc-options: -Wall -fno-warn-missing-signatures Executable tls-simpleserver Main-is: SimpleServer.hs + Other-modules: Common + , HexDump Hs-Source-Dirs: src Build-Depends: base >= 4 && < 5 , network @@ -83,10 +87,10 @@ , cryptonite , x509-store , x509-system >= 1.0 - , tls >= 1.3 && < 1.4 + , tls >= 1.3 && < 1.5 Buildable: True ghc-options: -Wall -fno-warn-missing-signatures source-repository head type: git - location: git://github.com/vincenthz/hs-tls + location: https://github.com/vincenthz/hs-tls