diff --git a/src/CheckCiphers.hs b/src/CheckCiphers.hs --- a/src/CheckCiphers.hs +++ b/src/CheckCiphers.hs @@ -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 diff --git a/src/RetrieveCertificate.hs b/src/RetrieveCertificate.hs --- a/src/RetrieveCertificate.hs +++ b/src/RetrieveCertificate.hs @@ -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) diff --git a/src/SimpleClient.hs b/src/SimpleClient.hs --- a/src/SimpleClient.hs +++ b/src/SimpleClient.hs @@ -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 diff --git a/src/Stunnel.hs b/src/Stunnel.hs --- a/src/Stunnel.hs +++ b/src/Stunnel.hs @@ -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 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.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