diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ =================== [![Hackage](https://img.shields.io/hackage/v/tcp-streams-openssl.svg?style=flat)](http://hackage.haskell.org/package/tcp-streams-openssl) -[![Build Status](https://travis-ci.org/winterland1989/tcp-streams.svg)](https://travis-ci.org/winterland1989/tcp-streams) +[![Build Status](https://travis-ci.org/didi-FP/tcp-streams.svg)](https://travis-ci.org/didi-FP/tcp-streams) This package provides TLS support based on [tcp-streams](http://hackage.haskell.org/package/tcp-streams) using [HsOpenSSL](http://hackage.haskell.org/package/HsOpenSSL). By default `tcp-streams` use `tls` package which is much easier to install but slightly slower. diff --git a/System/IO/Streams/OpenSSL.hs b/System/IO/Streams/OpenSSL.hs --- a/System/IO/Streams/OpenSSL.hs +++ b/System/IO/Streams/OpenSSL.hs @@ -1,74 +1,61 @@ {-# LANGUAGE ScopedTypeVariables #-} --- | This module provides convenience functions for interfacing @io-streams@ --- with @HsOpenSSL@. @ssl/SSL@ here stand for @HsOpenSSL@ library, not the --- deprecated SSL 2.0/3.0 protocol. the receive buffer size is 32752. --- sending is unbuffered, anything write into 'OutputStream' will be immediately --- send to underlying socket. --- --- The same exceptions rule which applied to TCP apply here, with addtional --- 'SSL.SomeSSLException` to be watched out. +-- | This module provides convenience functions for interfacing @HsOpenSSL@. +-- @ssl/SSL@ here stand for @HsOpenSSL@ library, not the deprecated SSL 2.0/3.0 protocol. -- -- This module is intended to be imported @qualified@, e.g.: -- -- @ +-- import "Data.Connection" -- import qualified "System.IO.Streams.OpenSSL" as SSL -- @ -- module System.IO.Streams.OpenSSL - ( -- * client - connect + ( TLSConnection + -- * client + , connect , connectWithVerifier - , withConnection + , sslToConnection -- * server , accept - -- * helpers - , sslToStreams - , close - -- * re-export helpers + -- * re-export , module Data.OpenSSLSetting ) where import qualified Control.Exception as E -import Control.Monad (unless, void) -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as S +import Control.Monad (unless) +import Data.Connection +import qualified Data.ByteString as S import Data.OpenSSLSetting -import Network.Socket (HostName, PortNumber, Socket) import qualified Network.Socket as N import OpenSSL (withOpenSSL) -import OpenSSL.Session (SSL, SSLContext) import qualified OpenSSL.Session as SSL import qualified OpenSSL.X509 as X509 -import System.IO.Streams (InputStream, OutputStream) import qualified System.IO.Streams as Streams import qualified System.IO.Streams.TCP as TCP -bUFSIZ :: Int -bUFSIZ = 32752 +-- | Type alias for tls connection. +-- +-- Normally you shouldn't use 'SSL.SSL' in 'connExtraInfo' directly. +-- +type TLSConnection = Connection (SSL.SSL , N.SockAddr) -- | Given an existing HsOpenSSL 'SSL' connection, produces an 'InputStream' \/ -- 'OutputStream' pair. -- -sslToStreams :: SSL -- ^ SSL connection object - -> IO (InputStream ByteString, OutputStream ByteString) -sslToStreams ssl = do +sslToConnection :: (SSL.SSL, N.SockAddr) -- ^ SSL connection object + -> IO TLSConnection +sslToConnection (ssl, addr) = do is <- Streams.makeInputStream input - os <- Streams.makeOutputStream output - return (is, os) - + return (Connection is (SSL.lazyWrite ssl) (closeSSL ssl) (ssl, addr)) where input = ( do - s <- SSL.read ssl bUFSIZ + s <- SSL.read ssl TCP.defaultChunkSize return $! if S.null s then Nothing else Just s ) `E.catch` (\(_::E.SomeException) -> return Nothing) - output Nothing = return () - output (Just s) = SSL.write ssl s -{-# INLINABLE sslToStreams #-} - -close :: SSL.SSL -> IO () -close ssl = withOpenSSL $ do +closeSSL :: SSL.SSL -> IO () +closeSSL ssl = withOpenSSL $ do SSL.shutdown ssl SSL.Unidirectional maybe (return ()) N.close (SSL.sslSocket ssl) @@ -89,14 +76,13 @@ -- -- If the certificate or hostname is not verified, a 'SSL.ProtocolError' will be thrown. -- -connect :: SSLContext -- ^ SSL context. See the @HsOpenSSL@ - -- documentation for information on creating - -- this. +connect :: SSL.SSLContext -- ^ SSL context, see the @HsOpenSSL@ + -- documentation for more information -> Maybe String -- ^ Optional certificate subject name, if set to 'Nothing' - -- then we will try to verify 'HostName' as subject name. - -> HostName -- ^ hostname to connect to - -> PortNumber -- ^ port number to connect to - -> IO (InputStream ByteString, OutputStream ByteString, SSL) + -- then we will try to verify 'HostName' as subject name + -> N.HostName -- ^ hostname to connect to + -> N.PortNumber -- ^ port number to connect to + -> IO TLSConnection connect ctx vhost host port = withOpenSSL $ do connectWithVerifier ctx verify host port where @@ -119,18 +105,18 @@ -- -- @since 0.6.0.0@ -- -connectWithVerifier :: SSLContext -- ^ SSL context. See the @HsOpenSSL@ +connectWithVerifier :: SSL.SSLContext -- ^ SSL context. See the @HsOpenSSL@ -- documentation for information on creating -- this. -> (Bool -> Maybe String -> Bool) -- ^ A verify callback, the first param is - -- the result of certificate verification, the - -- second param is the certificate's subject name. - -> HostName -- ^ hostname to connect to - -> PortNumber -- ^ port number to connect to - -> IO (InputStream ByteString, OutputStream ByteString, SSL) + -- the result of certificate verification, the + -- second param is the certificate's subject name + -> N.HostName -- ^ hostname to connect to + -> N.PortNumber -- ^ port number to connect to + -> IO TLSConnection connectWithVerifier ctx f host port = withOpenSSL $ do - sock <- TCP.connectSocket host port - E.bracketOnError (SSL.connection ctx sock) close $ \ ssl -> do + (sock, addr) <- TCP.connectSocket host port + E.bracketOnError (SSL.connection ctx sock) closeSSL $ \ ssl -> do SSL.connect ssl trusted <- SSL.getVerifyResult ssl cert <- SSL.getPeerCertificate ssl @@ -138,49 +124,20 @@ let cnname = lookup "CN" subnames verified = f trusted cnname unless verified (E.throwIO $ SSL.ProtocolError "fail to verify certificate") - (is, os) <- sslToStreams ssl - return (is, os, ssl) - - --- | Convenience function for initiating an SSL connection to the given --- @('HostName', 'PortNumber')@ combination. The socket and SSL connection are --- closed and deleted after the user handler runs. --- -withConnection :: SSLContext - - - -> Maybe String - -> HostName - -> PortNumber - -> (InputStream ByteString -> OutputStream ByteString -> SSL -> IO a) - -- ^ Action to run with the new connection - -> IO a -withConnection ctx subname host port action = - E.bracket (connect ctx subname host port) cleanup go - - where - go (is, os, ssl) = action is os ssl - - cleanup (_, os, ssl) = E.mask_ $ - eatException $! Streams.write Nothing os >> close ssl - - eatException m = void m `E.catch` (\(_::E.SomeException) -> return ()) - + sslToConnection (ssl, addr) -- | Accept a new connection from remote client, return a 'InputStream' / 'OutputStream' -- pair and remote 'N.SockAddr', you should call 'TCP.bindAndListen' first. -- -- this operation will throw 'SSL.SomeSSLException' on failure. -- -accept :: SSL.SSLContext -- ^ check "Data.OpenSSLSetting". - -> Socket -- ^ the listening 'Socket'. - -> IO (InputStream ByteString, OutputStream ByteString, SSL.SSL, N.SockAddr) +accept :: SSL.SSLContext -- ^ check "Data.OpenSSLSetting" + -> N.Socket -- ^ the listening 'Socket' + -> IO TLSConnection accept ctx sock = withOpenSSL $ do - (sock', sockAddr) <- N.accept sock - E.bracketOnError (SSL.connection ctx sock') close $ \ ssl -> do + (sock', addr) <- N.accept sock + E.bracketOnError (SSL.connection ctx sock') closeSSL $ \ ssl -> do SSL.accept ssl trusted <- SSL.getVerifyResult ssl unless trusted (E.throwIO $ SSL.ProtocolError "fail to verify certificate") - (is, os) <- sslToStreams ssl - return (is, os, ssl, sockAddr) - + sslToConnection (ssl, addr) diff --git a/tcp-streams-openssl.cabal b/tcp-streams-openssl.cabal --- a/tcp-streams-openssl.cabal +++ b/tcp-streams-openssl.cabal @@ -1,12 +1,12 @@ name: tcp-streams-openssl -version: 0.6.0.0 +version: 1.0.0.0 synopsis: Tcp streams using openssl for tls support. description: Tcp streams using openssl for tls support. license: BSD3 license-file: LICENSE author: winterland1989 maintainer: winterland1989@gmail.com -homepage: https://github.com/winterland1989/tcp-streams +homepage: https://github.com/didi-FP/tcp-streams copyright: (c) Winterland 2016 category: Network build-type: Simple @@ -19,7 +19,7 @@ source-repository head type: git - location: git://github.com/winterland1989/tcp-streams.git + location: git://github.com/didi-FP/tcp-streams.git library exposed-modules: Data.OpenSSLSetting @@ -30,7 +30,7 @@ , network >=2.3 && < 3.0 , bytestring >= 0.10.2.0 , io-streams >= 1.2 && < 2.0 - , tcp-streams >= 0.6 && < 0.7 + , tcp-streams >= 1.0 && < 1.1 , HsOpenSSL >=0.10.3 && <0.12 , HsOpenSSL-x509-system == 0.1.* @@ -40,7 +40,7 @@ test-suite testsuite type: exitcode-stdio-1.0 - Hs-source-dirs: src test + Hs-source-dirs: test main-is: Main.hs default-language: Haskell2010 ghc-options: -Wall -threaded @@ -51,8 +51,5 @@ , network , bytestring , HUnit >= 1.2 && <2 - , QuickCheck >= 2.3.0.2 && <3 , test-framework >= 0.6 && <0.9 , test-framework-hunit >= 0.2.7 && <0.4 - , test-framework-quickcheck2 >= 0.2.12.1 && <0.4 - , directory == 1.* diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -13,28 +13,29 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) import qualified Data.ByteString as B -import System.Directory (removeFile) +import qualified Data.ByteString.Lazy as L ------------------------------------------------------------------------------ +import Data.Connection import qualified Data.OpenSSLSetting as SSL import qualified System.IO.Streams as Stream -import qualified System.IO.Streams.TCP as Raw +import qualified System.IO.Streams.TCP as TCP import qualified System.IO.Streams.OpenSSL as SSL ------------------------------------------------------------------------------ main :: IO () main = defaultMain tests where - tests = [ testGroup "TCP" rawTests + tests = [ testGroup "TCP" tcpTests , testGroup "OpenSSL" sslTests ] ------------------------------------------------------------------------------ -rawTests :: [Test] -rawTests = [ testRawSocket ] +tcpTests :: [Test] +tcpTests = [ testTCPSocket ] -testRawSocket :: Test -testRawSocket = testCase "network/socket" $ +testTCPSocket :: Test +testTCPSocket = testCase "network/socket" $ N.withSocketsDo $ do x <- timeout (10 * 10^(6::Int)) go assertEqual "ok" (Just ()) x @@ -50,18 +51,18 @@ client mvar resultMVar = do _ <- takeMVar mvar - (is, os, sock) <- Raw.connect "127.0.0.1" 8888 - Stream.fromList ["", "ok"] >>= Stream.connectTo os - N.shutdown sock N.ShutdownSend - Stream.toList is >>= putMVar resultMVar - N.close sock + conn <- TCP.connect "127.0.0.1" 8888 + send conn "ok" + Stream.toList (source conn) >>= putMVar resultMVar + close conn server mvar = do - sock <- Raw.bindAndListen 8888 1024 + sock <- TCP.bindAndListen 1024 8888 putMVar mvar () - (is, os, csock, _) <- Raw.accept sock - os' <- Stream.atEndOfOutput (N.close csock) os - os' `Stream.connectTo` is + conn <- TCP.accept sock + req <- Stream.readExactly 2 (source conn) + send conn (L.fromStrict req) + close conn ------------------------------------------------------------------------------ @@ -81,23 +82,24 @@ forkIO $ client portMVar resultMVar server portMVar l <- takeMVar resultMVar - assertEqual "testSocket" l (Just "ok") + assertEqual "testSocket" l ["ok"] client mvar resultMVar = do _ <- takeMVar mvar cp <- SSL.makeClientSSLContext (SSL.CustomCAStore "./test/cert/ca.pem") - (is, os, ctx) <- SSL.connect cp (Just "Winter") "127.0.0.1" 8890 - Stream.fromList ["", "ok"] >>= Stream.connectTo os - Stream.read is >>= putMVar resultMVar -- There's no shutdown in tls, so we won't get a 'Nothing' - SSL.close ctx + conn <- SSL.connect cp (Just "Winter") "127.0.0.1" 8890 + send conn "ok" + Stream.toList (source conn) >>= putMVar resultMVar + close conn server mvar = do sp <- SSL.makeServerSSLContext "./test/cert/server.crt" [] "./test/cert/server.key" - sock <- Raw.bindAndListen 8890 1024 + sock <- TCP.bindAndListen 1024 8890 putMVar mvar () - (is, os, ssl, _) <- SSL.accept sp sock - os' <- Stream.atEndOfOutput (SSL.close ssl) os - os' `Stream.connectTo` is + conn <- SSL.accept sp sock + req <- Stream.readExactly 2 (source conn) + send conn (L.fromStrict req) + close conn testHTTPS' :: Test testHTTPS' = testCase "network/https" $ @@ -107,10 +109,10 @@ where go = do cp <- SSL.makeClientSSLContext SSL.SystemCAStore - (is, os, ctx) <- SSL.connect cp (Just "*.google.com") "www.google.com" 443 - Stream.write (Just "GET / HTTP/1.1\r\n") os - Stream.write (Just "Host: www.google.com\r\n") os - Stream.write (Just "\r\n") os - bs <- Stream.readExactly 1024 is - SSL.close ctx + conn <- SSL.connect cp (Just "*.bing.com") "www.bing.com" 443 + send conn "GET / HTTP/1.1\r\n" + send conn "Host: www.bing.com\r\n" + send conn "\r\n" + bs <- Stream.readExactly 1024 (source conn) + close conn return (B.length bs)