diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,20 @@ +# openssl-streams changelog # + +## 1.2.0.0 + - Added `withConnection`, a convenience function for initiating an SSL + connection to a given `(host, port)` pair. The socket and SSL connection + are closed after the user handler runs. + - Moved changelog from cabal file to changelog.md + - Updated the dependency list to allow latest `io-streams` and `network`. + +## 1.1.0.2 +Fixed a bug in the `connect` routine uncovered by the recent network upgrade. + +## 1.1.0.1 +Widened @network@ dependency to include 2.5. + +## 1.1.0.0 +Updated `openssl-streams` to work with `io-streams` 1.1.0.0. + +## 1.0.0.0 +First release. diff --git a/openssl-streams.cabal b/openssl-streams.cabal --- a/openssl-streams.cabal +++ b/openssl-streams.cabal @@ -1,5 +1,5 @@ Name: openssl-streams -Version: 1.1.0.2 +Version: 1.2.0.0 License: BSD3 License-file: LICENSE Category: Network, IO-Streams @@ -10,16 +10,9 @@ Description: The openssl-streams library contains io-streams routines for secure networking using OpenSSL (by way of HsOpenSSL). - . - /ChangeLog/ - [@1.1.0.2@] Fixed a bug in the \"connect\" routine uncovered by the recent - network upgrade. - . - [@1.1.0.1@] Widened @network@ dependency to include 2.5. - . - [@1.1.0.0@] Updated @openssl-streams@ to work with @io-streams@ 1.1.0.0. Extra-Source-Files: CONTRIBUTORS, + changelog.md test/cert.pem, test/key.pem @@ -37,9 +30,9 @@ Build-depends: base >= 4 && <5, bytestring >= 0.9.2 && <0.11, - HsOpenSSL >= 0.10.3 && <0.11, - io-streams >= 1.0 && <1.2, - network >= 2.4 && <2.6 + HsOpenSSL >= 0.10.3 && <0.12, + io-streams >= 1.0 && <1.3, + network >= 2.4 && <2.7 ------------------------------------------------------------------------------ @@ -54,15 +47,15 @@ -fno-warn-unused-do-bind ghc-prof-options: -prof -auto-all - Build-depends: base >= 4 && <5, - bytestring >= 0.9.2 && <0.11, - HsOpenSSL >= 0.10.3 && <0.11, - io-streams >= 1.0 && <1.2, - network >= 2.3 && <2.6, + Build-depends: base >= 4 && <5, + bytestring >= 0.9.2 && <0.11, + HsOpenSSL >= 0.10.3 && <0.12, + io-streams >= 1.0 && <1.3, + network >= 2.3 && <2.7, -- test deps follow. - HUnit >= 1.2 && <2, - test-framework >= 0.6 && <0.7, - test-framework-hunit >= 0.2.7 && <0.3 + HUnit >= 1.2 && <2, + test-framework >= 0.8.0.3 && <0.9, + test-framework-hunit >= 0.3 && <0.4 other-extensions: OverloadedStrings diff --git a/src/System/IO/Streams/SSL.hs b/src/System/IO/Streams/SSL.hs --- a/src/System/IO/Streams/SSL.hs +++ b/src/System/IO/Streams/SSL.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + -- | This module provides convenience functions for interfacing @io-streams@ -- with @HsOpenSSL@. It is intended to be imported @qualified@, e.g.: -- @@ -24,9 +26,12 @@ module System.IO.Streams.SSL ( connect + , withConnection , sslToStreams ) where +import qualified Control.Exception as E +import Control.Monad (void) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import Network.Socket (HostName, PortNumber) @@ -90,15 +95,65 @@ let protocol = N.addrProtocol addrInfo let address = N.addrAddress addrInfo - sock <- N.socket family socketType protocol - N.connect sock address - ssl <- SSL.connection ctx sock - SSL.connect ssl - (is, os) <- sslToStreams ssl - return $! (is, os, ssl) + E.bracketOnError (N.socket family socketType protocol) + N.close + (\sock -> do N.connect sock address + ssl <- SSL.connection ctx sock + SSL.connect ssl + (is, os) <- sslToStreams ssl + return $! (is, os, ssl) + ) where hints = N.defaultHints { N.addrFlags = [N.AI_ADDRCONFIG, N.AI_NUMERICSERV] , N.addrSocketType = N.Stream } + + +------------------------------------------------------------------------------ +-- | 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. +-- +-- /Since: 1.2.0.0./ +withConnection :: + SSLContext -- ^ SSL context. See the @HsOpenSSL@ + -- documentation for information on creating + -- this. + -> HostName -- ^ hostname to connect to + -> PortNumber -- ^ port number to connect to + -> (InputStream ByteString -> OutputStream ByteString -> SSL -> IO a) + -- ^ Action to run with the new connection + -> IO a +withConnection ctx host port action = do + (addrInfo:_) <- N.getAddrInfo (Just hints) (Just host) (Just $ show port) + E.bracket (connectTo addrInfo) cleanup go + + where + go (is, os, ssl, _) = action is os ssl + + connectTo addrInfo = do + let family = N.addrFamily addrInfo + let socketType = N.addrSocketType addrInfo + let protocol = N.addrProtocol addrInfo + let address = N.addrAddress addrInfo + E.bracketOnError (N.socket family socketType protocol) + N.close + (\sock -> do N.connect sock address + ssl <- SSL.connection ctx sock + SSL.connect ssl + (is, os) <- sslToStreams ssl + return $! (is, os, ssl, sock)) + + cleanup (_, os, ssl, sock) = E.mask_ $ do + eatException $! Streams.write Nothing os + eatException $! SSL.shutdown ssl $! SSL.Unidirectional + eatException $! N.close sock + + hints = N.defaultHints { + N.addrFlags = [N.AI_ADDRCONFIG, N.AI_NUMERICSERV] + , N.addrSocketType = N.Stream + } + + eatException m = void m `E.catch` (\(_::E.SomeException) -> return $! ()) diff --git a/test/TestSuite.hs b/test/TestSuite.hs --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -17,30 +17,20 @@ main :: IO () -main = defaultMain [sanityCheck] +main = N.withSocketsDo + $ SSL.withOpenSSL + $ defaultMain [sanityCheck, withConnection] ------------------------------------------------------------------------------ sanityCheck :: Test -sanityCheck = testCase "sanitycheck" $ N.withSocketsDo $ - SSL.withOpenSSL $ do +sanityCheck = testCase "sanitycheck" $ do ctx1 <- setupContext ctx2 <- setupContext x <- timeout (10 * 10^(6::Int)) $ go ctx1 ctx2 assertEqual "ok" (Just ()) x where - setupContext = do - ctx <- SSL.context - SSL.contextSetDefaultCiphers ctx - SSL.contextSetCertificateFile ctx "test/cert.pem" - SSL.contextSetPrivateKeyFile ctx "test/key.pem" - SSL.contextSetVerificationMode ctx SSL.VerifyNone - - certOK <- SSL.contextCheckPrivateKey ctx - assertBool "private key is bad" certOK - return ctx - go ctx1 ctx2 = do portMVar <- newEmptyMVar resultMVar <- newEmptyMVar @@ -57,25 +47,66 @@ Streams.toList is >>= putMVar resultMVar maybe (return ()) N.sClose $ SSL.sslSocket ssl - server ctx mvar = do - let hint = N.defaultHints { - N.addrFamily = N.AF_INET, - N.addrSocketType = N.Stream, - N.addrFlags = [N.AI_NUMERICHOST] - } - xs <- N.getAddrInfo (Just hint) (Just "127.0.0.1") Nothing - let [addr] = xs - sock <- N.socket N.AF_INET N.Stream N.defaultProtocol - let saddr = N.addrAddress addr - N.bind sock saddr - N.listen sock 5 - port <- N.socketPort sock - putMVar mvar port - (csock, _) <- N.accept sock - ssl <- SSL.connection ctx csock - SSL.accept ssl - (is, os) <- SSLStreams.sslToStreams ssl - Streams.toList is >>= flip Streams.writeList os - SSL.shutdown ssl SSL.Unidirectional - maybe (return ()) N.close $ SSL.sslSocket ssl - N.close sock + +------------------------------------------------------------------------------ +withConnection :: Test +withConnection = testCase "withConnection" $ do + ctx1 <- setupContext + ctx2 <- setupContext + x <- timeout (10 * 10^(6::Int)) $ go ctx1 ctx2 + assertEqual "ok" (Just ()) x + + where + go ctx1 ctx2 = do + portMVar <- newEmptyMVar + resultMVar <- newEmptyMVar + forkIO $ client ctx1 portMVar resultMVar + server ctx2 portMVar + l <- takeMVar resultMVar + assertEqual "testSocket" l ["ok"] + + client ctx mvar resultMVar = do + port <- takeMVar mvar + SSLStreams.withConnection ctx "127.0.0.1" port $ \is os ssl -> do + Streams.fromList ["ok"] >>= Streams.connectTo os + SSL.shutdown ssl SSL.Unidirectional + Streams.toList is >>= putMVar resultMVar + maybe (return ()) N.sClose $ SSL.sslSocket ssl + +------------------------------------------------------------------------------ +server :: SSL.SSLContext -> MVar N.PortNumber -> IO () +server ctx mvar = do + let hint = N.defaultHints { + N.addrFamily = N.AF_INET, + N.addrSocketType = N.Stream, + N.addrFlags = [N.AI_NUMERICHOST] + } + xs <- N.getAddrInfo (Just hint) (Just "127.0.0.1") Nothing + let [addr] = xs + sock <- N.socket N.AF_INET N.Stream N.defaultProtocol + let saddr = N.addrAddress addr + N.bind sock saddr + N.listen sock 5 + port <- N.socketPort sock + putMVar mvar port + (csock, _) <- N.accept sock + ssl <- SSL.connection ctx csock + SSL.accept ssl + (is, os) <- SSLStreams.sslToStreams ssl + Streams.toList is >>= flip Streams.writeList os + SSL.shutdown ssl SSL.Unidirectional + maybe (return ()) N.close $ SSL.sslSocket ssl + N.close sock + + +setupContext :: IO SSL.SSLContext +setupContext = do + ctx <- SSL.context + SSL.contextSetDefaultCiphers ctx + SSL.contextSetCertificateFile ctx "test/cert.pem" + SSL.contextSetPrivateKeyFile ctx "test/key.pem" + SSL.contextSetVerificationMode ctx SSL.VerifyNone + + certOK <- SSL.contextCheckPrivateKey ctx + assertBool "private key is bad" certOK + return ctx