packages feed

tls-debug 0.4.4 → 0.4.5

raw patch · 6 files changed

+225/−176 lines, 6 filesdep ~cryptonitedep ~tls

Dependency ranges changed: cryptonite, tls

Files

+ src/Common.hs view
@@ -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)
src/RetrieveCertificate.hs view
@@ -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
src/SimpleClient.hs view
@@ -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] <hostname> [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
src/SimpleServer.hs view
@@ -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
src/Stunnel.hs view
@@ -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
tls-debug.cabal view
@@ -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