diff --git a/src/CheckCiphers.hs b/src/CheckCiphers.hs --- a/src/CheckCiphers.hs +++ b/src/CheckCiphers.hs @@ -24,146 +24,146 @@ 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") - ] + [ (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 - } + { 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 + 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) + 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) + 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] + 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) + { 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" - ] + { 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 + 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 @@ -13,77 +13,76 @@ import qualified Crypto.Random.AESCtr as RNG import Text.Printf +import Text.Groom import System.Console.CmdArgs 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 - _ <- handshake ctx - bye ctx - r <- readIORef ref - case r of - Nothing -> error "cannot retrieve any certificate" - Just certs -> return certs + 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 + _ <- handshake ctx + bye ctx + r <- readIORef ref + case r of + Nothing -> error "cannot retrieve any certificate" + Just certs -> return certs data PArgs = PArgs - { destination :: String - , port :: String - , chain :: Bool - , output :: String - , verify :: Bool - , verifyFQDN :: String - } deriving (Show, Data, Typeable) + { destination :: String + , port :: String + , chain :: Bool + , output :: String + , verify :: Bool + , verifyFQDN :: String + } 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" - , 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" - ] + { 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" + ] -showCert "full" cert = putStrLn $ show cert +showCert "full" cert = putStrLn $ groom cert showCert _ (x509Cert -> cert) = 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)) + 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)) main = do - a <- cmdArgs progArgs - _ <- printf "connecting to %s on port %s ...\n" (destination a) (port a) + a <- cmdArgs progArgs + _ <- printf "connecting to %s on port %s ...\n" (destination a) (port a) - 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 + 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 (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) + 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) diff --git a/src/SimpleClient.hs b/src/SimpleClient.hs --- a/src/SimpleClient.hs +++ b/src/SimpleClient.hs @@ -6,6 +6,7 @@ import Network.TLS.Extra import System.Console.GetOpt import System.IO +import System.Timeout import qualified Crypto.Random.AESCtr as RNG import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Char8 as BC @@ -20,23 +21,23 @@ ciphers :: [Cipher] ciphers = - [ cipher_AES128_SHA1 - , cipher_AES256_SHA1 - , cipher_RC4_128_MD5 - , cipher_RC4_128_SHA1 - ] + [ cipher_AES128_SHA1 + , cipher_AES256_SHA1 + , cipher_RC4_128_MD5 + , cipher_RC4_128_SHA1 + ] runTLS 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 - () <- f ctx - hClose dsth + 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 + () <- f ctx + hClose dsth data SessionRef = SessionRef (IORef (SessionID, SessionData)) @@ -45,7 +46,7 @@ sessionResume (SessionRef ref) sid = readIORef ref >>= \(s,d) -> if s == sid then return (Just d) else return Nothing sessionInvalidate _ _ = return () -getDefaultParams flags store sStorage session = +getDefaultParams flags host store sStorage session = updateClientParams setCParams $ setSessionManager (SessionRef sStorage) $ defaultParamsClient { pConnectVersion = tlsConnectVer , pAllowedVersions = [TLS10,TLS11,TLS12] @@ -55,12 +56,17 @@ , onCertificatesRecv = crecv } where - setCParams cparams = cparams { clientWantSessionResume = session } + 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 certificateVerifyChain store else (\_ -> return CertificateUsageAccept) + crecv = if validateCert + then certificateChecks [certificateVerifyChain store,return . certificateVerifyDomain host] + else (\_ -> return CertificateUsageAccept) tlsConnectVer | Tls12 `elem` flags = TLS12 @@ -72,6 +78,7 @@ data Flag = Verbose | Debug | NoValidateCert | Session | Http11 | Ssl3 | Tls11 | Tls12 + | NoSNI | Uri String | Help deriving (Show,Eq) @@ -84,6 +91,7 @@ , 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 [] ["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 [] ["uri"] (ReqArg Uri "URI") "optional URI requested by default /" @@ -102,13 +110,19 @@ ++ (if Http11 `elem` flags then (" HTTP/1.1\r\nHost: " ++ hostname) else " HTTP/1.0") ++ "\r\n\r\n") when (Verbose `elem` flags) (putStrLn "sending query:" >> LC.putStrLn query >> putStrLn "") - runTLS (getDefaultParams flags certStore sStorage sess) hostname (fromIntegral port) $ \ctx -> do + runTLS (getDefaultParams flags hostname certStore sStorage sess) hostname port $ \ctx -> do handshake ctx sendData ctx $ query - d <- recvData ctx + loopRecv ctx bye ctx - BC.putStrLn d return () + loopRecv 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 + findURI [] = "/" findURI (Uri u:_) = u findURI (_:xs) = findURI xs @@ -131,5 +145,5 @@ sStorage <- newIORef undefined case other of [hostname] -> runOn (sStorage, certStore) opts 443 hostname - [hostname,port] -> runOn (sStorage, certStore) opts (read port) hostname + [hostname,port] -> runOn (sStorage, certStore) opts (fromInteger $ read port) hostname _ -> printUsage >> exitFailure diff --git a/src/Stunnel.hs b/src/Stunnel.hs --- a/src/Stunnel.hs +++ b/src/Stunnel.hs @@ -24,55 +24,55 @@ ciphers :: [Cipher] ciphers = - [ cipher_AES128_SHA1 - , cipher_AES256_SHA1 - , cipher_RC4_128_MD5 - , cipher_RC4_128_SHA1 - ] + [ cipher_AES128_SHA1 + , cipher_AES256_SHA1 + , cipher_RC4_128_MD5 + , cipher_RC4_128_SHA1 + ] loopUntil :: Monad m => m Bool -> m () loopUntil f = f >>= \v -> if v then return () else loopUntil f readOne h = do - r <- E.try $ hWaitForInput h (-1) - case r of - Left err -> if isEOFError err then return B.empty else throw err - Right True -> B.hGetNonBlocking h 4096 - Right False -> return B.empty + r <- E.try $ hWaitForInput h (-1) + case r of + Left err -> if isEOFError err then return B.empty else throw err + Right True -> B.hGetNonBlocking h 4096 + Right False -> return B.empty tlsclient :: Handle -> TLSCtx -> IO () tlsclient srchandle dsthandle = do - hSetBuffering srchandle NoBuffering + hSetBuffering srchandle NoBuffering - handshake dsthandle + handshake dsthandle - _ <- forkIO $ forever $ do - dat <- recvData dsthandle - putStrLn ("received " ++ show dat) - B.hPut srchandle dat - loopUntil $ do - b <- readOne srchandle - putStrLn ("sending " ++ show b) - if B.null b - then do - bye dsthandle - return True - else do - sendData dsthandle (L.fromChunks [b]) - return False - return () + _ <- forkIO $ forever $ do + dat <- recvData dsthandle + putStrLn ("received " ++ show dat) + B.hPut srchandle dat + loopUntil $ do + b <- readOne srchandle + putStrLn ("sending " ++ show b) + if B.null b + then do + bye dsthandle + return True + else do + sendData dsthandle (L.fromChunks [b]) + return False + return () tlsserver srchandle dsthandle = do - hSetBuffering dsthandle NoBuffering + hSetBuffering dsthandle NoBuffering - handshake srchandle + handshake srchandle - loopUntil $ do - d <- recvData srchandle - putStrLn ("received: " ++ show d) - sendData srchandle (L.pack $ map (toEnum . fromEnum) "this is some data") - return False - putStrLn "end" + loopUntil $ do + d <- recvData srchandle + putStrLn ("received: " ++ show d) + sendData srchandle (L.pack $ map (toEnum . fromEnum) "this is some data") + return False + putStrLn "end" data MemSessionManager = MemSessionManager (MVar [(SessionID, SessionData)]) @@ -82,182 +82,182 @@ sessionInvalidate (MemSessionManager mvar) _ = return () clientProcess certs 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: " ++) - } + 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 - } + 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 + 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) + 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) 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" + { 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" 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" + { 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" mode = cmdArgsMode $ modes [clientOpts,serverOpts] - &= help "create SSL/TLS tunnel in client or server mode" &= program "stunnel" &= summary "Stunnel v0.1 (Haskell TLS)" + &= help "create SSL/TLS tunnel in client or server mode" &= program "stunnel" &= summary "Stunnel v0.1 (Haskell TLS)" data StunnelAddr = - AddrSocket Family SockAddr - | AddrFD Handle Handle + AddrSocket Family SockAddr + | AddrFD Handle Handle data StunnelHandle = - StunnelSocket Socket - | StunnelFd Handle Handle + StunnelSocket Socket + | StunnelFd Handle Handle getAddressDescription :: String -> String -> IO StunnelAddr getAddressDescription "tcp" desc = do - let (s, p) = break ((==) ':') desc - when (p == "") (error "missing port: expecting [source]:port") - pn <- if and $ map isDigit $ drop 1 p - then return $ fromIntegral $ (read (drop 1 p) :: Int) - else do - service <- getServiceByName (drop 1 p) "tcp" - return $ servicePort service - he <- getHostByName s - return $ AddrSocket AF_INET (SockAddrInet pn (head $ hostAddresses he)) + let (s, p) = break ((==) ':') desc + when (p == "") (error "missing port: expecting [source]:port") + pn <- if and $ map isDigit $ drop 1 p + then return $ fromIntegral $ (read (drop 1 p) :: Int) + else do + service <- getServiceByName (drop 1 p) "tcp" + return $ servicePort service + he <- getHostByName s + return $ AddrSocket AF_INET (SockAddrInet pn (head $ hostAddresses he)) getAddressDescription "unix" desc = do - return $ AddrSocket AF_UNIX (SockAddrUnix desc) + return $ AddrSocket AF_UNIX (SockAddrUnix desc) getAddressDescription "fd" _ = - return $ AddrFD stdin stdout + return $ AddrFD stdin stdout getAddressDescription _ _ = error "unrecognized source type (expecting tcp/unix/fd)" 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)) - return $ StunnelSocket sock + sock <- socket family Stream defaultProtocol + E.catch (connect sock sockaddr) + (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) + return $ StunnelSocket sock connectAddressDescription (AddrFD h1 h2) = do - return $ StunnelFd h1 h2 + return $ StunnelFd h1 h2 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)) - return $ StunnelSocket sock + 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)) + return $ StunnelSocket sock listenAddressDescription (AddrFD _ _) = do - error "cannot listen on fd" + error "cannot listen on fd" doClient :: Stunnel -> IO () doClient pargs = do - srcaddr <- getAddressDescription (sourceType pargs) (source pargs) - dstaddr <- getAddressDescription (destinationType pargs) (destination pargs) + srcaddr <- getAddressDescription (sourceType pargs) (source pargs) + dstaddr <- getAddressDescription (destinationType pargs) (destination pargs) - let logging = if not $ debug pargs then defaultLogging else defaultLogging - { loggingPacketSent = putStrLn . ("debug: send: " ++) - , loggingPacketRecv = putStrLn . ("debug: recv: " ++) - } + let logging = if not $ debug pargs then defaultLogging else defaultLogging + { 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 - } + 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 + } - case srcaddr of - AddrSocket _ _ -> do - (StunnelSocket srcsocket) <- listenAddressDescription srcaddr - forever $ do - (s, _) <- accept srcsocket - rng <- RNG.makeSystem - srch <- socketToHandle s ReadWriteMode + case srcaddr of + AddrSocket _ _ -> do + (StunnelSocket srcsocket) <- listenAddressDescription srcaddr + forever $ do + (s, _) <- accept srcsocket + rng <- RNG.makeSystem + srch <- socketToHandle s ReadWriteMode - (StunnelSocket dst) <- connectAddressDescription dstaddr + (StunnelSocket dst) <- connectAddressDescription dstaddr - dsth <- socketToHandle dst ReadWriteMode - dstctx <- contextNewOnHandle dsth clientstate rng - _ <- forkIO $ finally - (tlsclient srch dstctx) - (hClose srch >> hClose dsth) - return () - AddrFD _ _ -> error "bad error fd. not implemented" + dsth <- socketToHandle dst ReadWriteMode + dstctx <- contextNewOnHandle dsth clientstate rng + _ <- 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) + cert <- fileReadCertificate $ certificate pargs + pk <- fileReadPrivateKey $ key pargs + srcaddr <- getAddressDescription (sourceType pargs) (source pargs) + dstaddr <- getAddressDescription (destinationType pargs) (destination pargs) - sessionStorage <- if disableSession pargs then return Nothing else (Just `fmap` newMVar []) + sessionStorage <- if disableSession pargs then return Nothing else (Just `fmap` newMVar []) - case srcaddr of - AddrSocket _ _ -> do - (StunnelSocket srcsocket) <- listenAddressDescription srcaddr - forever $ do - (s, addr) <- accept srcsocket - srch <- socketToHandle s ReadWriteMode - r <- connectAddressDescription dstaddr - dsth <- case r of - StunnelFd _ _ -> return stdout - StunnelSocket dst -> socketToHandle dst ReadWriteMode + case srcaddr of + AddrSocket _ _ -> do + (StunnelSocket srcsocket) <- listenAddressDescription srcaddr + forever $ do + (s, addr) <- accept srcsocket + srch <- socketToHandle s ReadWriteMode + r <- connectAddressDescription dstaddr + dsth <- case r of + StunnelFd _ _ -> return stdout + StunnelSocket dst -> socketToHandle dst ReadWriteMode - _ <- forkIO $ finally - (clientProcess [(cert, Just pk)] srch dsth (debug pargs) sessionStorage addr >> return ()) - (hClose srch >> (when (dsth /= stdout) $ hClose dsth)) - return () - AddrFD _ _ -> error "bad error fd. not implemented" + _ <- forkIO $ finally + (clientProcess [(cert, Just pk)] srch dsth (debug pargs) sessionStorage addr >> return ()) + (hClose srch >> (when (dsth /= stdout) $ hClose dsth)) + return () + AddrFD _ _ -> error "bad error fd. not implemented" main :: IO () main = do - x <- cmdArgsRun mode - case x of - ClientConfig {} -> doClient x - ServerConfig {} -> doServer x + x <- cmdArgsRun mode + case x of + ClientConfig {} -> doClient x + ServerConfig {} -> doServer x 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.3 +Version: 0.2.5 Description: A set of program to test and debug various aspect of the TLS package. . @@ -23,7 +23,7 @@ , bytestring , cmdargs , certificate >= 1.0 - , cprng-aes >= 0.3.0 + , cprng-aes >= 0.5.0 , tls >= 1.1 && < 1.2 , tls-extra >= 0.6.1 && < 0.7 Buildable: True @@ -49,8 +49,9 @@ , network , bytestring , cmdargs + , groom , time - , cprng-aes >= 0.3.0 + , cprng-aes >= 0.5.0 , certificate >= 1.0 , tls >= 1.1 && < 1.2 , tls-extra >= 0.6.1 && < 0.7 @@ -64,7 +65,7 @@ , network , bytestring , cmdargs - , cprng-aes >= 0.3.0 + , cprng-aes >= 0.5.0 , certificate >= 1.0 , tls >= 1.1 && < 1.2 , tls-extra >= 0.6.1 && < 0.7