network-conduit-tls 1.0.2 → 1.0.3
raw patch · 4 files changed
+257/−52 lines, 4 filesdep +HUnitdep +mtldep +network-conduit-tlsdep ~basedep ~bytestringdep ~conduit
Dependencies added: HUnit, mtl, network-conduit-tls
Dependency ranges changed: base, bytestring, conduit, network-conduit
Files
- Data/Conduit/Network/TLS.hs +153/−49
- Data/Conduit/Network/TLS/Internal.hs +8/−2
- network-conduit-tls.cabal +16/−1
- test/main.hs +80/−0
Data/Conduit/Network/TLS.hs view
@@ -7,18 +7,21 @@ module Data.Conduit.Network.TLS ( -- * Server TLSConfig+ , tlsConfigBS , tlsConfig , tlsHost , tlsPort- , tlsCertificate- , tlsKey+-- , tlsCertificate+-- , tlsKey , tlsNeedLocalAddr , tlsAppData , runTCPServerTLS+ , runTCPServerStartTLS -- * Client , TLSClientConfig , tlsClientConfig , runTLSClient+ , runTLSClientStartTLS , tlsClientPort , tlsClientHost , tlsClientUseTLS@@ -39,7 +42,7 @@ import qualified Data.PEM as PEM import qualified Network.TLS as TLS import qualified Data.Certificate.X509 as X509-import Data.Conduit.Network (HostPreference, Application, bindPort, sinkSocket, acceptSafe)+import Data.Conduit.Network (HostPreference, Application, bindPort, sinkSocket, acceptSafe, runTCPServerWithHandle, ConnectionHandle(..), serverSettings, sourceSocket) import Data.Conduit.Network.Internal (AppData (..)) import Data.Conduit.Network.TLS.Internal import Data.Conduit (($$), yield, awaitForever, Producer, Consumer)@@ -67,55 +70,60 @@ import Control.Monad.Trans.Control import Data.Default +++makeCertDataPath :: FilePath -> FilePath -> TlsCertData+makeCertDataPath certPath keyPath = TlsCertData (readFile certPath) (readFile keyPath)++makeCertDataBS :: S.ByteString -> S.ByteString -> TlsCertData+makeCertDataBS certBS keyBS = TlsCertData (return certBS) (return keyBS)++ tlsConfig :: HostPreference -> Int -- ^ port -> FilePath -- ^ certificate -> FilePath -- ^ key -> TLSConfig-tlsConfig a b c d = TLSConfig a b c d False+tlsConfig a b c d = TLSConfig a b (makeCertDataPath c d) False -runTCPServerTLS :: TLSConfig -> Application IO -> IO ()-runTCPServerTLS TLSConfig{..} app = do- certs <- readCertificates tlsCertificate- key <- readPrivateKey tlsKey- bracket- (bindPort tlsPort tlsHost)- sClose- (forever . serve certs key)- where- serve certs key lsocket = do- (socket, addr) <- acceptSafe lsocket- mlocal <- if tlsNeedLocalAddr- then fmap Just $ getSocketName socket- else return Nothing- _ <- forkIO $ handle socket addr mlocal- return ()- where- handle socket addr mlocal = do++-- | allow to build a server config directly from raw bytestring data (exact same+-- string as if the certificates were read from the filesystem).+-- this enables to plug another backend to fetch certifcates (other than FS) +tlsConfigBS :: HostPreference+ -> Int -- ^ port+ -> S.ByteString -- ^ Certificate raw data+ -> S.ByteString -- ^ Key file raw data+ -> TLSConfig+tlsConfigBS a b c d = TLSConfig a b (makeCertDataBS c d ) False+++serverHandshake :: Socket -> [X509.X509] -> TLS.PrivateKey -> IO (TLS.Context)+serverHandshake socket certs key = do #if MIN_VERSION_tls(1, 1, 3)- gen <- Crypto.Random.AESCtr.makeSystem+ gen <- Crypto.Random.AESCtr.makeSystem #elif MIN_VERSION_tls(1, 1, 0)- gen <- getSystemRandomGen+ gen <- getSystemRandomGen #else- gen <- newGenIO+ gen <- newGenIO #endif #if MIN_VERSION_tls(1, 0, 0)- ctx <- TLS.contextNew- TLS.Backend+ ctx <- TLS.contextNew+ TLS.Backend { TLS.backendFlush = return () , TLS.backendClose = return () , TLS.backendSend = sendAll socket , TLS.backendRecv = recvExact socket }- params+ params #if MIN_VERSION_tls(1, 1, 3)- gen+ gen #else- (gen :: SystemRandom)+ (gen :: SystemRandom) #endif #else- ctx <- TLS.serverWith+ ctx <- TLS.serverWith params (gen :: SystemRandom) socket@@ -124,21 +132,21 @@ (recvExact socket) #endif - TLS.handshake ctx-- app (tlsAppData ctx addr mlocal) `finally` sClose socket+ TLS.handshake ctx+ return ctx - params =+ where+ params = #if MIN_VERSION_tls(1, 0, 0)- TLS.updateServerParams- (\sp -> sp { TLS.serverWantClientCert = False }) $- TLS.defaultParamsServer- { TLS.pAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12]- , TLS.pCiphers = ciphers- , TLS.pCertificates = zip certs $ Just key : repeat Nothing- }+ TLS.updateServerParams+ (\sp -> sp { TLS.serverWantClientCert = False }) $+ TLS.defaultParamsServer+ { TLS.pAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12]+ , TLS.pCiphers = ciphers+ , TLS.pCertificates = zip certs $ Just key : repeat Nothing+ } #else- TLS.defaultParams+ TLS.defaultParams { TLS.pWantClientCert = False , TLS.pAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12] , TLS.pCiphers = ciphers@@ -146,6 +154,63 @@ } #endif +runTCPServerTLS :: TLSConfig -> Application IO -> IO ()+runTCPServerTLS TLSConfig{..} app = do+ certs <- readCertificates tlsCertData+ key <- readPrivateKey tlsCertData++ runTCPServerWithHandle settings (wrapApp certs key)++ where+ -- convert tls settings to regular conduit network ones+ settings = serverSettings tlsPort tlsHost -- (const $ return () ) tlsNeedLocalAddr++ wrapApp certs key = ConnectionHandle app'+ where+ app' socket addr mlocal = do+ ctx <- serverHandshake socket certs key+ app (tlsAppData ctx addr mlocal)+++type ApplicationStartTLS = (AppData IO, Application IO -> IO ()) -> IO ()++-- | run a server un-crypted but also pass a call-back to trigger a StartTLS handshake+-- on the underlying connection+--+-- example usage :+-- @+-- runTCPServerStartTLS serverConfig $ (appData,startTLS) -> do+-- abortTLS <- doSomethingInClear appData+-- unless (abortTLS) $ startTls $ appDataTls -> do+-- doSomethingSSL appDataTls+-- @+runTCPServerStartTLS :: TLSConfig -> ApplicationStartTLS -> IO ()+runTCPServerStartTLS TLSConfig{..} app = do+ certs <- readCertificates tlsCertData+ key <- readPrivateKey tlsCertData++ runTCPServerWithHandle settings (wrapApp certs key)++ where+ -- convert tls settings to regular conduit network ones+ settings = serverSettings tlsPort tlsHost -- (const $ return () ) tlsNeedLocalAddr++ wrapApp certs key = ConnectionHandle clearapp+ where clearapp socket addr mlocal = let+ -- setup app data for the clear part of the connection+ clearData = AppData+ { appSource = sourceSocket socket+ , appSink = sinkSocket socket+ , appSockAddr = addr+ , appLocalAddr = mlocal+ }+ -- wrap up the current connection with TLS+ startTls = \app' -> do+ ctx <- serverHandshake socket certs key+ app' (tlsAppData ctx addr mlocal)+ in+ app (clearData, startTls)+ -- | Create an @AppData@ from an existing tls @Context@ value. This is a lower level function, allowing you to create a connection in any way you want. -- -- Sample usage:@@ -180,9 +245,9 @@ , TLSExtra.cipher_RC4_128_SHA1 ] -readCertificates :: FilePath -> IO [X509.X509]-readCertificates filepath = do- certs <- rights . parseCerts . PEM.pemParseBS <$> readFile filepath+readCertificates :: TlsCertData -> IO [X509.X509]+readCertificates certData = do+ certs <- rights . parseCerts . PEM.pemParseBS <$> getTLSCert certData case certs of [] -> error "no valid certificate found" (_:_) -> return certs@@ -190,9 +255,9 @@ $ filter (flip elem ["CERTIFICATE", "TRUSTED CERTIFICATE"] . PEM.pemName) pems parseCerts (Left err) = error $ "cannot parse PEM file: " ++ err -readPrivateKey :: FilePath -> IO TLS.PrivateKey-readPrivateKey filepath = do- pk <- rights . parseKey . PEM.pemParseBS <$> readFile filepath+readPrivateKey :: TlsCertData -> IO TLS.PrivateKey+readPrivateKey certData = do+ pk <- rights . parseKey . PEM.pemParseBS <$> getTLSKey certData case pk of [] -> error "no valid RSA key found" (x:_) -> return x@@ -289,6 +354,45 @@ , appSockAddr = SockAddrInet (fromIntegral tlsClientPort) 0 -- FIXME , appLocalAddr = Nothing })+++-- | Run an application with the given configuration. starting with a clear connection+-- but provide also a call back to trigger a StartTLS handshake on the connection+--+-- Since 1.0.2+runTLSClientStartTLS :: TLSClientConfig IO+ -> ApplicationStartTLS+ -> IO ()+runTLSClientStartTLS TLSClientConfig {..} app = do+ context <- maybe (liftIO NC.initConnectionContext) return tlsClientConnectionContext+ let params = NC.ConnectionParams+ { NC.connectionHostname = S8.unpack tlsClientHost+ , NC.connectionPort = fromIntegral tlsClientPort+ , NC.connectionUseSecure = Nothing+ , NC.connectionUseSocks = tlsClientSockSettings+ }+ tlsSettings = tlsClientTLSSettings+ control $ \run -> bracket+ (NC.connectTo context params)+ NC.connectionClose+ (\conn -> run $ app (+ AppData+ { appSource = sourceConnection conn+ , appSink = sinkConnection conn+ , appSockAddr = SockAddrInet (fromIntegral tlsClientPort) 0 -- FIXME+ , appLocalAddr = Nothing+ }+ , \app' -> do+ NC.connectionSetSecure context conn tlsClientTLSSettings+ app' AppData+ { appSource = sourceConnection conn+ , appSink = sinkConnection conn+ , appSockAddr = SockAddrInet (fromIntegral tlsClientPort) 0 -- FIXME+ , appLocalAddr = Nothing+ }+ )+ )+ -- | Read from a 'NC.Connection'. --
Data/Conduit/Network/TLS/Internal.hs view
@@ -1,16 +1,22 @@ {-# OPTIONS_HADDOCK not-home #-} module Data.Conduit.Network.TLS.Internal ( TLSConfig (..)+ , TlsCertData (..) ) where import Prelude hiding (FilePath) import Data.Conduit.Network (HostPreference) import Filesystem.Path.CurrentOS (FilePath)+import qualified Data.ByteString as S +-- structure providing access to certificate and key data through call backs +data TlsCertData = TlsCertData { getTLSCert :: IO S.ByteString+ , getTLSKey :: IO S.ByteString }++ data TLSConfig = TLSConfig { tlsHost :: HostPreference , tlsPort :: Int- , tlsCertificate :: FilePath- , tlsKey :: FilePath+ , tlsCertData :: TlsCertData , tlsNeedLocalAddr :: Bool }
network-conduit-tls.cabal view
@@ -1,5 +1,5 @@ name: network-conduit-tls-version: 1.0.2+version: 1.0.3 synopsis: Create TLS-aware network code with conduits description: Uses the tls package for a pure-Haskell implementation. homepage: https://github.com/snoyberg/conduit@@ -33,3 +33,18 @@ , connection , monad-control , data-default++test-suite test+ hs-source-dirs: test+ main-is: main.hs+ type: exitcode-stdio-1.0+ cpp-options: -DTEST+ build-depends: conduit+ , network-conduit+ , connection+ , base+ , mtl+ , network-conduit-tls+ , bytestring+ , HUnit+ ghc-options: -Wall -threaded
+ test/main.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}+import Test.HUnit+import Data.Conduit+import Data.Conduit.Network (HostPreference(..), appSource, appSink)+import Data.Conduit.Network.TLS+import Control.Concurrent (forkIO, threadDelay, killThread)+import qualified Network.Connection as NC+import qualified Data.ByteString as BS+++testKeyRaw :: BS.ByteString+testKeyRaw = "-----BEGIN RSA PRIVATE KEY-----\nMIIEpAIBAAKCAQEAwAU371YZKOVON+S/TpNERcSbe5vWk0kdodR/cC7iwQ40ukO6\nIH7H40THVAWQwlD6kasRdsxcsk+KcOpoBgivw9izJ7ggBp7reFe8mJRp2qMGyK+n89ZRHNlVWl1qSAC/o0A1ldvyfZ2X4nNYHVAFqwhPSsFTxQgxORJbL7qdKy1tirqg\nWpHQMgK6dQJjOEEhrMKmOC2q6l9vbTYuAghDsdtbbEc8FWWVeExiIj8RopPY9+if\nj3BoXxp4WhfiDWmnnBWp71oJIfB1uziLV6PJdA1nKfVbPUeAM0wCFFUCbrjaxdg3\n4RenckCZIJwDo+ff/OSpKynrwznunZW847m2lwIDAQABAoIBAEqjPKS5MLpmt0qe\njYX7VDRSQaWAY52IdA4tTQPMFbO40+H65WQwI35Bg8EzEJuXYm4wsm8c7IMay9Ms\nKhb+VWOo3ap4tWodZ6W1ZMdiGOs1JzPmoz/ydEDkcXrYiLFIKTVJhgqkHdOZ6CnL\nb9qk+i8K4ddK4kbZ8lgevHcG8ISRTV2B8dRc3iohGJ0F6VlL62GnjbExjegsUs4N\n4Ozy8xI4oxlKdZcgutBkfPqdJOWixWPnMXf0PtJVFMzKzVujZlupoonqUUGn51c6\nTVVXAh1pcF0XrmKNscuODFMwBtVfIrfNf/iL1KvIIlKFbUSb/Yu9/9KBvLmfKdxf\nyrtvNBECgYEA5rRdd8IaskROgQxRTJagZn39Sl6oBVFLQ+fy0LGXV3bDbgl7myx8\nOtkKiTMHGT8g6JWv5NMWUgGSZBkMnZSQ/QCtbCxpuDjajxY2GVKU+1EbJjPccuWH\nTnopBuss6WiDbI/Jl9JjPBmhs8EsuAgAOo9yPzgs6SLiMfUwWKkPRdUCgYEA1RMH\nhhKUULqE+/xF214aUqcIk38BCw9g9Uo0pGp4cIfA8iuRachZGsbRpDQyaGRWL+4A\n9hOLPdV2ey6TvNcP/7H6dXrvj4TXLqrxPC2ne2zawqeCkqigxq8Rk55pBF5c52Xz\nX5Rie98TC++gf+fyUTIUS4OqMLg4q1Erk23g5LsCgYEApZg3MtvXj7ep5cUyodfI\nYGj0oyoYTmDQtnhJ+PRQHk637kbOO06OCSt6/YnsAXono+q1q3i8n7ZTHphATuex\nvnh7ApdKdxoP/v7BbCGzoETSSPSWur34BiN3SWkK/qqvEwCOgfRYmG4JfF4fPCU6\nDM6kAa7PxbPtSlClGC6ZMNUCgYEAwp+tIaPa4ZpdWiXmUSe1d4Wm6cL6WvXjJGpx\nhzTRakg1z35IRo2ABltQpmIfIQd1SjZlnl/fsc1HeeDjhXwT2wTgt2phY4B9ZN0z\nmDpDXxPhBigntnpc0N6ceXAakKj4x0xybv2Er4zlQuPQgMSGq+/IZemQDQxYhvOP\nkAyvfX0CgYBEVKvhcXQ9ETmEsk0FxPvpS9CtWXaNWItVzC/z3+mrU2B5JPcBQF72\nBsuoupeq52S+SGH7el5Xp2AoLXjZYsQ9S0t76p6G3lE/cHmnc/QNt4kT6oe5mpv1\nYXIo3/044Cbw2FEkEaj0iucagYCoqhlZTFN8aR6dXFTmvU+k6VP7pg==\n-----END RSA PRIVATE KEY-----"+++-- self signed certificate corresponding to private key above.+-- this certificate will expire circa january 2015 ... +testCertificateRaw :: BS.ByteString+testCertificateRaw = "-----BEGIN CERTIFICATE-----\nMIIDBjCCAe4CCQDBE77UEng3SDANBgkqhkiG9w0BAQsFADBFMQswCQYDVQQGEwJG\nUjETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0\ncyBQdHkgTHRkMB4XDTE0MDEwNjIxNTA1OVoXDTE1MDEwNjIxNTA1OVowRTELMAkG\nA1UEBhMCRlIxEzARBgNVBAgMClNvbWUtU3RhdGUxITAfBgNVBAoMGEludGVybmV0\nIFdpZGdpdHMgUHR5IEx0ZDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEB\nAMAFN+9WGSjlTjfkv06TREXEm3ub1pNJHaHUf3Au4sEONLpDuiB+x+NEx1QFkMJQ\n+pGrEXbMXLJPinDqaAYIr8PYsye4IAae63hXvJiUadqjBsivp/PWURzZVVpdakgA\nv6NANZXb8n2dl+JzWB1QBasIT0rBU8UIMTkSWy+6nSstbYq6oFqR0DICunUCYzhB\nIazCpjgtqupfb202LgIIQ7HbW2xHPBVllXhMYiI/EaKT2Pfon49waF8aeFoX4g1p\np5wVqe9aCSHwdbs4i1ejyXQNZyn1Wz1HgDNMAhRVAm642sXYN+EXp3JAmSCcA6Pn\n3/zkqSsp68M57p2VvOO5tpcCAwEAATANBgkqhkiG9w0BAQsFAAOCAQEAq1Vy0VBj\nKxuXrpzU8O8bMNrH571Mtjb7tNAhpv77HeyfssW151Rltn71DDPIOqwhoA9zN47I\ns/t/aq1+BmXSdEEb9chbOkZ+KOsJlG/Y0Io4jSK4j4JHlnSBhjItTaoEkkvQtr45\nbyrLYSeixGY5JZd8hIOUcGuru+PPx+SKtuZrnxHF+oXyT9O4BLIe9BYWHvE0Qpop\nvc060w8CIDW4gfYcxxMsA45IrULv5mq2J8bLAtcI9hQY3Z8dPNejsChYTHK6JDEL\n7/G6POAMxenO5cg+Y6Y3OKp5+LrzJNIwfnAnLLFl+/Gb2kC+GcfwZDojuiCJ9iIG\njPwFEAl/7WuMlg==\n-----END CERTIFICATE-----"+++serverConfig :: TLSConfig+serverConfig = tlsConfigBS HostIPv4 4242 testCertificateRaw testKeyRaw ++clientConfig :: TLSClientConfig IO+clientConfig = tlsClientConfig 4242 "127.0.0.1"++clientConfigNoCA :: TLSClientConfig IO +clientConfigNoCA = clientConfig {tlsClientTLSSettings = NC.TLSSettingsSimple True False False}++testSimpleServerClient :: IO ()+testSimpleServerClient = do+ -- a simple server that says hello over tls + serverThreadId <- forkIO $ runTCPServerTLS serverConfig $ \ad ->+ yield "hello world" $$ appSink ad+ + -- wait for server to be ready + threadDelay 1000000+ + -- default settings checks CA, the test cert is self-signed. should+ runTLSClient clientConfigNoCA $ \ad -> do+ d <- appSource ad $$ (await >>= return)+ assertEqual "client receives hello world" (Just "hello world") d+ + -- kill the server + killThread serverThreadId+++testSimpleServerClientStartTLS :: IO ()+testSimpleServerClientStartTLS = do+ serverThreadId <- forkIO $ runTCPServerStartTLS serverConfig serve+ threadDelay 100000++ runTLSClientStartTLS clientConfigNoCA client++ killThread serverThreadId++ where+ serve (ad, startTls) = do+ yield "proceed" $$ appSink ad+ startTls $ \app -> (yield "crypted") $$ appSink app+++ client (ad, startTls) = do+ -- reads one message from server+ msg <- appSource ad $$ (await >>= return)+ assertEqual "server sends proceed" (Just "proceed") msg+ startTls $ \app -> do+ msgTls <- appSource app $$ (await >>= return)+ assertEqual "server sends crypted" (Just "crypted") msgTls+++main :: IO (Counts)+main = runTestTT $ TestList [ TestLabel "TLS Server" $ TestCase testSimpleServerClient+ , TestLabel "StartTLS" $ TestCase testSimpleServerClientStartTLS ]+ + ++ + +