diff --git a/Data/Conduit/Network/TLS.hs b/Data/Conduit/Network/TLS.hs --- a/Data/Conduit/Network/TLS.hs +++ b/Data/Conduit/Network/TLS.hs @@ -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'. -- diff --git a/Data/Conduit/Network/TLS/Internal.hs b/Data/Conduit/Network/TLS/Internal.hs --- a/Data/Conduit/Network/TLS/Internal.hs +++ b/Data/Conduit/Network/TLS/Internal.hs @@ -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 } diff --git a/network-conduit-tls.cabal b/network-conduit-tls.cabal --- a/network-conduit-tls.cabal +++ b/network-conduit-tls.cabal @@ -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 diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -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 ] + + + + + +