tls-debug 0.1.1 → 0.2.0
raw patch · 5 files changed
+66/−57 lines, 5 filesdep ~tlsdep ~tls-extra
Dependency ranges changed: tls, tls-extra
Files
- src/CheckCiphers.hs +6/−6
- src/RetrieveCertificate.hs +4/−5
- src/SimpleClient.hs +16/−8
- src/Stunnel.hs +29/−27
- tls-debug.cabal +11/−11
src/CheckCiphers.hs view
@@ -16,8 +16,8 @@ import Control.Monad import Control.Applicative ((<$>)) import Control.Concurrent-import Control.Exception (catch, SomeException(..))-import Prelude hiding (catch)+import Control.Exception (SomeException(..))+import qualified Control.Exception as E import Text.Printf @@ -91,16 +91,16 @@ else do service <- getServiceByName p "tcp" return $ servicePort service- he <- getHostByName s+ 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 = defaultParams { pCiphers = map fakeCipher ciphers }- ctx <- client params rng handle+ let params = defaultParamsClient { pCiphers = map fakeCipher ciphers }+ ctx <- contextNewOnHandle handle params rng sendPacket ctx $ Handshake [clienthello ciphers]- catch (do+ E.catch (do rpkt <- recvPacket ctx ccid <- case rpkt of Right (Handshake ((ServerHello _ _ _ i _ _):_)) -> return i
src/RetrieveCertificate.hs view
@@ -3,14 +3,12 @@ import Network.TLS import Network.TLS.Extra -import Data.Char import Data.IORef import Data.Time.Clock import Data.Certificate.X509+import System.Certificate.X509 -import System.IO import Control.Monad-import Prelude hiding (catch) import qualified Crypto.Random.AESCtr as RNG @@ -21,7 +19,7 @@ openConnection s p = do ref <- newIORef Nothing rng <- RNG.makeSystem- let params = defaultParams+ let params = defaultParamsClient { pCiphers = ciphersuite_all , onCertificatesRecv = \l -> do modifyIORef ref (const $ Just l)@@ -78,9 +76,10 @@ showCert (output a) $ head certs when (verify a) $ do+ store <- getSystemCertificateStore putStrLn "### certificate chain trust" ctime <- utctDay `fmap` getCurrentTime- certificateVerifyChain certs >>= showUsage "chain validity"+ certificateVerifyChain store certs >>= showUsage "chain validity" showUsage "time validity" (certificateVerifyValidity ctime certs) when (verifyFQDN a /= "") $ showUsage "fqdn match" (certificateVerifyDomain (verifyFQDN a) certs)
src/SimpleClient.hs view
@@ -8,8 +8,9 @@ import qualified Crypto.Random.AESCtr as RNG import qualified Data.ByteString.Lazy.Char8 as LC import Control.Exception+import qualified Control.Exception as E import System.Environment-import Prelude hiding (catch)+import System.Certificate.X509 import Data.IORef @@ -29,29 +30,35 @@ he <- getHostByName hostname sock <- socket AF_INET Stream defaultProtocol let sockaddr = SockAddrInet portNumber (head $ hostAddresses he)- catch (connect sock sockaddr)+ E.catch (connect sock sockaddr) (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) dsth <- socketToHandle sock ReadWriteMode- ctx <- client params rng dsth+ ctx <- contextNewOnHandle dsth params rng f ctx hClose dsth -getDefaultParams sStorage session = defaultParams+data SessionRef = SessionRef (IORef (SessionID, SessionData))++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 ()++getDefaultParams store sStorage session = updateClientParams setCParams $ setSessionManager (SessionRef sStorage) $ defaultParamsClient { pConnectVersion = TLS10 , pAllowedVersions = [TLS10,TLS11,TLS12] , pCiphers = ciphers , pCertificates = [] , pLogging = logging , onCertificatesRecv = crecv- , onSessionEstablished = \s d -> writeIORef sStorage (s,d)- , sessionResumeWith = session } where+ setCParams cparams = cparams { clientWantSessionResume = session } logging = if not debug then defaultLogging else defaultLogging { loggingPacketSent = putStrLn . ("debug: >> " ++) , loggingPacketRecv = putStrLn . ("debug: << " ++) }- crecv = if validateCert then certificateVerifyChain else (\_ -> return CertificateUsageAccept)+ crecv = if validateCert then certificateVerifyChain store else (\_ -> return CertificateUsageAccept) main = do@@ -59,7 +66,8 @@ args <- getArgs let hostname = args !! 0 let port = read (args !! 1) :: Int- runTLS (getDefaultParams sStorage Nothing) hostname (fromIntegral port) $ \ctx -> do+ store <- getSystemCertificateStore+ runTLS (getDefaultParams store sStorage Nothing) hostname (fromIntegral port) $ \ctx -> do handshake ctx sendData ctx $ LC.pack "GET / HTTP/1.0\r\n\r\n" d <- recvData' ctx
src/Stunnel.hs view
@@ -3,15 +3,17 @@ import Network.BSD import Network.Socket import System.IO-import System.IO.Error hiding (try, catch)+import System.IO.Error (isEOFError) import System.Console.CmdArgs+import System.Certificate.X509 import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Control.Concurrent (forkIO) import Control.Concurrent.MVar-import Control.Exception (finally, try, throw, catch, SomeException)+import Control.Exception (finally, throw, SomeException)+import qualified Control.Exception as E import Control.Monad (when, forever) import Data.Char (isDigit)@@ -20,8 +22,6 @@ import Network.TLS import Network.TLS.Extra -import Prelude hiding (catch)- ciphers :: [Cipher] ciphers = [ cipher_AES128_SHA1@@ -34,13 +34,13 @@ loopUntil f = f >>= \v -> if v then return () else loopUntil f readOne h = do- r <- try $ hWaitForInput h (-1)+ 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 Handle -> IO ()+tlsclient :: Handle -> TLSCtx -> IO () tlsclient srchandle dsthandle = do hSetBuffering srchandle NoBuffering @@ -71,10 +71,16 @@ d <- recvData srchandle putStrLn ("received: " ++ show d) sendData srchandle (L.pack $ map (toEnum . fromEnum) "this is some data")- hFlush (ctxConnection srchandle) return False putStrLn "end" +data 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 ()+ clientProcess certs handle dsthandle dbg sessionStorage _ = do rng <- RNG.makeSystem let logging = if not dbg then defaultLogging else defaultLogging@@ -82,32 +88,25 @@ , loggingPacketRecv = putStrLn . ("debug: recv: " ++) } - let serverstate = defaultParams+ let serverstate = maybe id (setSessionManager . MemSessionManager) sessionStorage $ defaultParamsServer { pAllowedVersions = [SSL3,TLS10,TLS11,TLS12] , pCiphers = ciphers , pCertificates = certs- , pWantClientCert = False , pLogging = logging }- let serverState' = case sessionStorage of- Nothing -> serverstate- Just storage -> serverstate- { onSessionResumption = \s -> withMVar storage (return . lookup s)- , onSessionEstablished = \s d -> modifyMVar_ storage (\l -> return $ (s,d) : l)- } - ctx <- server serverState' rng handle+ ctx <- contextNewOnHandle handle serverstate rng tlsserver ctx dsthandle data Stunnel =- Client+ ClientConfig { destinationType :: String , destination :: String , sourceType :: String , source :: String , debug :: Bool , validCert :: Bool }- | Server+ | ServerConfig { destinationType :: String , destination :: String , sourceType :: String@@ -118,7 +117,7 @@ , key :: FilePath } deriving (Show, Data, Typeable) -clientOpts = Client+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"@@ -127,8 +126,9 @@ , 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 = Server+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"@@ -139,6 +139,7 @@ , 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)"@@ -173,7 +174,7 @@ connectAddressDescription (AddrSocket family sockaddr) = do sock <- socket family Stream defaultProtocol- catch (connect sock sockaddr)+ E.catch (connect sock sockaddr) (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) return $ StunnelSocket sock @@ -182,7 +183,7 @@ listenAddressDescription (AddrSocket family sockaddr) = do sock <- socket family Stream defaultProtocol- catch (bindSocket sock sockaddr >> listen sock 10 >> setSocketOption sock ReuseAddr 1)+ 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 @@ -199,8 +200,9 @@ , loggingPacketRecv = putStrLn . ("debug: recv: " ++) } - let crecv = if validCert pargs then certificateVerifyChain else (\_ -> return CertificateUsageAccept)- let clientstate = defaultParams+ store <- getSystemCertificateStore+ let crecv = if validCert pargs then certificateVerifyChain store else (\_ -> return CertificateUsageAccept)+ let clientstate = defaultParamsClient { pConnectVersion = TLS10 , pAllowedVersions = [TLS10,TLS11,TLS12] , pCiphers = ciphers@@ -220,7 +222,7 @@ (StunnelSocket dst) <- connectAddressDescription dstaddr dsth <- socketToHandle dst ReadWriteMode- dstctx <- client clientstate rng dsth+ dstctx <- contextNewOnHandle dsth clientstate rng _ <- forkIO $ finally (tlsclient srch dstctx) (hClose srch >> hClose dsth)@@ -257,5 +259,5 @@ main = do x <- cmdArgsRun mode case x of- Client {} -> doClient x- Server {} -> doServer x+ ClientConfig {} -> doClient x+ ServerConfig {} -> doServer x
tls-debug.cabal view
@@ -1,5 +1,5 @@ Name: tls-debug-Version: 0.1.1+Version: 0.2.0 Description: A set of program to test and debug various aspect of the TLS package. .@@ -13,7 +13,7 @@ Category: Network stability: experimental Cabal-Version: >=1.6-Homepage: http://github.com/vincenthz/hs-tls-debug+Homepage: http://github.com/vincenthz/hs-tls Executable tls-stunnel Main-is: Stunnel.hs@@ -24,8 +24,8 @@ , cmdargs , certificate >= 1.0 , cprng-aes >= 0.2.3- , tls >= 0.9.4 && < 1.0- , tls-extra >= 0.4.6 && < 0.5.0+ , tls >= 1.0 && < 1.1+ , tls-extra >= 0.5 && < 0.6 Buildable: True ghc-options: -Wall -fno-warn-missing-signatures @@ -37,8 +37,8 @@ , bytestring , cprng-aes , certificate >= 1.0- , tls >= 0.9.4 && < 1.0- , tls-extra >= 0.4.6 && < 0.5.0+ , tls >= 1.0 && < 1.1+ , tls-extra >= 0.5 && < 0.6 Buildable: True ghc-options: -Wall -fno-warn-missing-signatures @@ -52,8 +52,8 @@ , time , cprng-aes >= 0.2.3 , certificate >= 1.0- , tls >= 0.9.4 && < 1.0- , tls-extra >= 0.4.6 && < 0.5.0+ , tls >= 1.0 && < 1.1+ , tls-extra >= 0.5 && < 0.6 Buildable: True ghc-options: -Wall -fno-warn-missing-signatures @@ -66,11 +66,11 @@ , cmdargs , cprng-aes >= 0.2.3 , certificate >= 1.0- , tls >= 0.9.4 && < 1.0- , tls-extra >= 0.4.6 && < 0.5.0+ , tls >= 1.0 && < 1.1+ , tls-extra >= 0.5 && < 0.6 Buildable: True ghc-options: -Wall -fno-warn-missing-signatures source-repository head type: git- location: git://github.com/vincenthz/hs-tls-debug+ location: git://github.com/vincenthz/hs-tls