tls-debug 0.2.3 → 0.2.5
raw patch · 5 files changed
+389/−375 lines, 5 filesdep +groomdep ~cprng-aes
Dependencies added: groom
Dependency ranges changed: cprng-aes
Files
- src/CheckCiphers.hs +124/−124
- src/RetrieveCertificate.hs +58/−59
- src/SimpleClient.hs +36/−22
- src/Stunnel.hs +166/−166
- tls-debug.cabal +5/−4
src/CheckCiphers.hs view
@@ -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
src/RetrieveCertificate.hs view
@@ -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)
src/SimpleClient.hs view
@@ -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
src/Stunnel.hs view
@@ -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
tls-debug.cabal view
@@ -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