diff --git a/src/CheckCiphers.hs b/src/CheckCiphers.hs deleted file mode 100644 --- a/src/CheckCiphers.hs +++ /dev/null @@ -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 diff --git a/src/RetrieveCertificate.hs b/src/RetrieveCertificate.hs --- a/src/RetrieveCertificate.hs +++ b/src/RetrieveCertificate.hs @@ -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] [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 + -} diff --git a/src/SimpleClient.hs b/src/SimpleClient.hs --- a/src/SimpleClient.hs +++ b/src/SimpleClient.hs @@ -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] [port]\n\n\t(port default to: 443)\noptions:\n" options diff --git a/src/Stunnel.hs b/src/Stunnel.hs --- a/src/Stunnel.hs +++ b/src/Stunnel.hs @@ -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 [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) 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.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