pipes-network-tls 0.1.1.0 → 0.2.0
raw patch · 8 files changed
+396/−862 lines, 8 filesdep +network-simpledep ~network-simple-tlsdep ~pipesdep ~pipes-network
Dependencies added: network-simple
Dependency ranges changed: network-simple-tls, pipes, pipes-network, pipes-safe
Files
- README.md +3/−3
- examples/tls-echo.hs +13/−14
- examples/tls-tunnel.hs +0/−143
- pipes-network-tls.cabal +17/−14
- src/Control/Proxy/TCP/TLS.hs +0/−216
- src/Control/Proxy/TCP/TLS/Safe.hs +0/−472
- src/Pipes/Network/TCP/TLS.hs +182/−0
- src/Pipes/Network/TCP/TLS/Safe.hs +181/−0
README.md view
@@ -16,7 +16,7 @@ ## Building the development version -Use [cabal-meta](http://hackage.haskell.org/package/cabal-meta) and-[cabal-dev](http://hackage.haskell.org/package/cabal-dev):+Use [cabal-meta](http://hackage.haskell.org/package/cabal-meta): - cabal-meta --dev install+ cabal sandbox init+ cabal-meta install -j
examples/tls-echo.hs view
@@ -4,42 +4,41 @@ module Main (main) where import Control.Applicative-import Control.Proxy ((>->))-import qualified Control.Proxy as P-import Control.Proxy.TCP.TLS (contextReadS, contextWriteD)+import Pipes+import qualified Pipes.Prelude as P import qualified Data.ByteString.Char8 as B import Data.Certificate.X509 (X509) import Data.Char (toUpper) import Data.Monoid ((<>))-import qualified Network.Simple.TCP.TLS as Z-import qualified Network.Socket as NS-import qualified Network.TLS as T+import qualified Network.Simple.TCP.TLS as TLS+import qualified Pipes.Network.TCP.TLS as TLS import Network.TLS.Extra as TE+import qualified Network.TLS as T import System.Console.GetOpt import System.Environment (getProgName, getArgs) import qualified Data.CertificateStore as C -server :: Z.Credential -> Z.HostPreference -> NS.ServiceName+server :: TLS.Credential -> TLS.HostPreference -> TLS.ServiceName -> Maybe C.CertificateStore -> IO () server cred hp port mcs = do- let ss = Z.makeServerSettings cred mcs- Z.serve ss hp port $ \(ctx,caddr) -> do+ let ss = TLS.makeServerSettings cred mcs+ TLS.serve ss hp port $ \(ctx,caddr) -> do putStrLn $ show caddr <> " joined."- P.runProxy $ contextReadS ctx >-> P.mapD (B.map toUpper) >-> contextWriteD ctx+ runEffect $ TLS.fromContext ctx >-> P.map (B.map toUpper) >-> TLS.toContext ctx putStrLn $ show caddr <> " quit." main :: IO ()-main = Z.withSocketsDo $ do+main = TLS.withSocketsDo $ do args <- getArgs case getOpt RequireOrder options args of (actions, [hostname,port], _) -> do opts <- foldl (>>=) (return defaultOptions) actions- let !cred = Z.Credential (optServerCert opts) (optServerKey opts) []- server cred (Z.Host hostname) port+ let !cred = TLS.Credential (optServerCert opts) (optServerKey opts) []+ server cred (TLS.Host hostname) port (C.makeCertificateStore . pure <$> optCACert opts) (_,_,msgs) -> do pn <- getProgName- let header = "Usage: " <> pn <> " [OPTIONS] HOSTNAME PORT"+ let header = "Usage: " <> pn <> " [OPTIOTLS] HOSTNAME PORT" error $ concat msgs ++ usageInfo header options --------------------------------------------------------------------------------
− examples/tls-tunnel.hs
@@ -1,143 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- Yeah, yeah... I know. This code could be a bit more organized.--module Main (main) where--import Control.Concurrent.Async as A-import Control.Applicative-import Control.Proxy ((>->))-import qualified Control.Proxy as P-import qualified Control.Proxy.TCP.TLS as Pt-import Data.Certificate.X509 (X509)-import Data.Maybe (maybeToList)-import Data.Monoid ((<>))-import qualified Network.Socket as NS-import qualified Network.TLS as T-import Network.TLS.Extra as TE-import System.Certificate.X509 (getSystemCertificateStore)-import System.Console.GetOpt-import System.Environment (getProgName, getArgs)-import qualified Data.CertificateStore as C--runTlsTunnel- :: Pt.ServerSettings -- ^Local server settings- -> Pt.HostPreference -- ^Local host to bind- -> NS.ServiceName -- ^Local port to bind- -> Pt.ClientSettings -- ^Client to remote server settings.- -> NS.HostName -- ^Remote host name to connect to- -> NS.ServiceName -- ^Remote tcp port to connect to- -> IO ()-runTlsTunnel sS sHp sPort cS cHost cPort = do- Pt.serve sS sHp sPort $ \(sCtx, sAddr) -> do- let sMsg = show sAddr- putStrLn $ sMsg <> " joined."- putStrLn $ sMsg <> " is being tunneled to " <> show (cHost, cPort)- Pt.connect cS cHost cPort $ \(cCtx, cAddr) -> do- let cMsg = "Secure connection to " <> show cAddr- putStrLn $ cMsg <> " established."- a1 <- A.async . P.runProxy $ Pt.contextReadS sCtx >-> Pt.contextWriteD cCtx- P.runProxy $ Pt.contextReadS cCtx >-> Pt.contextWriteD sCtx- A.wait a1- putStrLn $ cMsg <> " closed."- putStrLn $ sMsg <> " quit."---main :: IO ()-main = Pt.withSocketsDo $ do- args <- getArgs- case getOpt RequireOrder options args of- (actions, [locHost,locPort,remHost,remPort], _) -> do- opts <- foldl (>>=) (return defaultOptions) actions- let !sCred = Pt.Credential (optLocalCert opts) (optLocalKey opts) []- smcStore = C.makeCertificateStore . pure <$> optLocalCACert opts- sS = Pt.makeServerSettings sCred smcStore- ccStore <- case optRemoteCACert opts of- Nothing -> getSystemCertificateStore- Just ca -> return $ C.makeCertificateStore [ca]- let !cCreds = maybeToList $ Pt.Credential <$> optRemoteCert opts- <*> optRemoteKey opts- <*> pure []- cS = Pt.makeClientSettings cCreds (Nothing) ccStore- runTlsTunnel sS (Pt.Host locHost) locPort cS remHost remPort- (_,_,msgs) -> do- pn <- getProgName- let header = "Usage: " <> pn- <> " [OPTIONS] LOCAL-HOST LOCAL-PORT REMOTE-HOST REMOTE-PORT"- error $ concat msgs ++ usageInfo header options-------------------------------------------------------------------------------------- The boring stuff below is related to command line parsing---data Options = Options- { optLocalCert :: X509- , optLocalKey :: T.PrivateKey- , optLocalCACert :: Maybe X509- , optRemoteCert :: Maybe X509- , optRemoteKey :: Maybe T.PrivateKey- , optRemoteCACert :: Maybe X509- } deriving (Show)--defaultOptions :: Options-defaultOptions = Options- { optLocalCert = error "Missing optLocalCert"- , optLocalKey = error "Missing optLocalKey"- , optLocalCACert = Nothing- , optRemoteCert = Nothing- , optRemoteKey = Nothing- , optRemoteCACert = Nothing- }--options :: [OptDescr (Options -> IO Options)]-options =- [ Option [] ["lcert"] (ReqArg readLocalCert "FILE")- "Local server certificate"- , Option [] ["lkey"] (ReqArg readLocalKey "FILE")- "Local server private key"- , Option [] ["lcacert"] (OptArg readLocalCACert "FILE")- "If given, request a client certificate for incomming connections\- \ and verify it against this CA."- , Option [] ["rcert"] (OptArg readRemoteCert "FILE")- "Certificate to provide to remote server if requested"- , Option [] ["rkey"] (OptArg readRemoteKey "FILE")- "Key to use together with 'rcert', if requested"- , Option [] ["rcacert"] (OptArg readRemoteCACert "FILE")- "If given, verify the remote server certificate using this CA,\- \ otherwise use the operating system default CAs."- ]--readLocalCert :: FilePath -> Options -> IO Options-readLocalCert arg opt = do- cert <- TE.fileReadCertificate arg- return $ opt { optLocalCert = cert }--readLocalKey :: FilePath -> Options -> IO Options-readLocalKey arg opt = do- key <- TE.fileReadPrivateKey arg- return $ opt { optLocalKey = key }--readLocalCACert :: Maybe FilePath -> Options -> IO Options-readLocalCACert Nothing opt = return opt-readLocalCACert (Just arg) opt = do- cert <- TE.fileReadCertificate arg- return $ opt { optLocalCACert = Just cert }--readRemoteCert :: Maybe FilePath -> Options -> IO Options-readRemoteCert Nothing opt = return opt-readRemoteCert (Just arg) opt = do- cert <- TE.fileReadCertificate arg- return $ opt { optRemoteCert = Just cert }--readRemoteKey :: Maybe FilePath -> Options -> IO Options-readRemoteKey Nothing opt = return opt-readRemoteKey (Just arg) opt = do- key <- TE.fileReadPrivateKey arg- return $ opt { optRemoteKey = Just key }--readRemoteCACert :: Maybe FilePath -> Options -> IO Options-readRemoteCACert Nothing opt = return opt-readRemoteCACert (Just arg) opt = do- cert <- TE.fileReadCertificate arg- return $ opt { optRemoteCACert = Just cert }
pipes-network-tls.cabal view
@@ -1,5 +1,5 @@ name: pipes-network-tls-version: 0.1.1.0+version: 0.2.0 license: BSD3 license-file: LICENSE copyright: Copyright (c) Renzo Carbonara 2013@@ -17,18 +17,19 @@ README.md PEOPLE examples/tls-echo.hs- examples/tls-tunnel.hs description: Use TLS-secured network connections together with the @pipes@ ecosystem. . This package is organized using the following namespaces: .- * "Control.Proxy.TCP.TLS" exports 'Control.Proxy.Proxy's and functions for- establishing and using TLS-secured TCP connections.+ * "Pipes.Network.TCP.TLS" exports pipes and utilities for using+ TLS-secured TCP connections in a streaming fashion. .- * "Control.Proxy.TCP.TLS.Safe" is similar to "Control.Proxy.TCP.TLS", except- the exported 'Control.Proxy.Proxy's themselves can obtain new TLS resources- safely by using the facilities providied by the @pipes-safe@ package.+ * "Pipes.Network.TCP.TLS.Safe" subsumes "Pipes.Network.TCP.TLS",+ exporting pipes and functions that allow you to safely establish new+ TCP connections within a pipeline using the @pipes-safe@ facilities.+ You only need to use this module if you want to acquire and release+ operating system resources within a pipeline. . See the @NEWS@ file in the source distribution to learn about any important changes between version.@@ -43,15 +44,17 @@ base (==4.*), bytestring (>=0.9.2.1), network,- network-simple-tls (>=0.1.1 && <0.2),- pipes (>=3.3 && <3.4),- pipes-safe (>=1.2 && <1.3),- pipes-network (>=0.5.1 && <0.6),+ network-simple (>=0.3 && <0.4),+ network-simple-tls (>=0.2 && <0.3),+ pipes (>=4.0 && <4.1),+ pipes-network (>=0.6 && <0.7),+ pipes-safe (>=2.0 && <2.1), tls (>=1.1 && <1.2), transformers (>=0.2 && <0.4) exposed-modules:- Control.Proxy.TCP.TLS- Control.Proxy.TCP.TLS.Safe- ghc-options: -Wall -fno-warn-unused-do-bind+ Pipes.Network.TCP.TLS+ Pipes.Network.TCP.TLS.Safe+ ghc-options: -Wall -O2+
− src/Control/Proxy/TCP/TLS.hs
@@ -1,216 +0,0 @@--- | This module exports functions that allow you to use TLS-secured--- TCP connections as streams, as well as utilities to connect to a--- TLS-enabled TCP server or running your own.------ If you need to safely connect to a TLS-enabled TCP server or run your own--- /within/ a pipes pipeline, then you /must/ use the functions exported from--- the module "Control.Proxy.TCP.TLS.Safe" instead.------ This module re-exports many functions and types from "Network.Simple.TCP.TLS"--- module in the @network-simple@ package. You might refer to that module for--- more documentation.--module Control.Proxy.TCP.TLS (- -- * Client side- -- $client-side- S.connect- , S.ClientSettings- , S.getDefaultClientSettings- , S.makeClientSettings-- -- * Server side- -- $server-side- , S.serve- , S.ServerSettings- , S.makeServerSettings- -- ** Listening- , S.listen- -- ** Accepting- , S.accept- , S.acceptFork-- -- * TLS context streams- -- $socket-streaming- , contextReadS- , contextWriteD- -- ** Timeouts- -- $socket-streaming-timeout- , contextReadTimeoutS- , contextWriteTimeoutD-- -- * Note to Windows users- -- $windows-users- , S.withSocketsDo-- -- * Exports- , S.HostPreference(..)- , S.Credential(..)- , Timeout(..)- ) where--import Control.Monad.Trans.Class-import qualified Control.Proxy as P-import Control.Proxy.TCP (Timeout(..))-import qualified Control.Proxy.Trans.Either as PE-import qualified Data.ByteString as B-import Data.Monoid-import qualified Network.Simple.TCP.TLS as S-import qualified Network.TLS as T-import System.Timeout (timeout)-------------------------------------------------------------------------------------- $windows-users------ If you are running Windows, then you /must/ call 'S.withSocketsDo', just--- once, right at the beginning of your program. That is, change your program's--- 'main' function from:------ @--- main = do--- print \"Hello world\"--- -- rest of the program...--- @------ To:------ @--- main = 'S.withSocketsDo' $ do--- print \"Hello world\"--- -- rest of the program...--- @------ If you don't do this, your networking code won't work and you will get many--- unexpected errors at runtime. If you use an operating system other than--- Windows then you don't need to do this, but it is harmless to do it, so it's--- recommended that you do for portability reasons.-------------------------------------------------------------------------------------- $client-side------ Here's how you could run a simple TLS-secured TCP client:------ @--- import "Control.Proxy.TCP.TLS"------ \ settings <- 'S.getDefaultClientSettings'--- 'S.connect' settings \"www.example.org\" \"443\" $ \(tlsCtx, remoteAddr) -> do--- putStrLn $ \"Secure connection established to \" ++ show remoteAddr--- -- now you may use tlsCtx as you please within this scope, possibly with--- -- the 'contextReadS' or 'contextWriteD' proxies explained below.--- @-------------------------------------------------------------------------------------- $server-side------ Here's how you could run a simple TLS-secured TCP server that handles in--- different threads each incoming connection to port @4433@ at hostname--- @example.org@. You will need a X509 certificate and a private key appropiate--- to be used at that hostname.------ @--- import "Control.Proxy.TCP.TLS"--- import "Network.TLS.Extra" (fileReadCertificate, fileReadPrivateKey)------ \ cert <- 'Network.TLS.Extra.fileReadCertificate' \"~/example.org.crt\"--- pkey <- 'Network.TLS.Extra.fileReadPrivateKey' \"~/example.org.key\"--- let cred = 'S.Credential' cert pkey []--- settings = 'S.makeServerSettings' cred Nothing------ \ 'S.serve' settings ('S.Host' \"example.org\") \"4433\" $ \(tlsCtx, remoteAddr) -> do--- putStrLn $ \"Secure connection established from \" ++ show remoteAddr--- -- now you may use tlsCtx as you please within this scope, possibly with--- -- the 'contextReadS' or 'contextWriteD' proxies explained below.--- @------ If you need more control on the way your server runs, then you can use more--- advanced functions such as 'S.listen', 'S.accept' and 'S.acceptFork'.-------------------------------------------------------------------------------------- $socket-streaming------ Once you have an established TLS connection 'T.Context', then you can use the--- following 'P.Proxy's to interact with the other connection end using streams.---- | Receives decrypted bytes from the remote end, sending them downstream.------ Up to @16384@ decrypted bytes will be received at once. The TLS connection is--- automatically renegotiated if a /ClientHello/ message is received.------ If the remote peer closes its side of the connection or EOF is reached,--- this proxy returns.-contextReadS- :: P.Proxy p- => T.Context -- ^Established TLS connection context.- -> () -> P.Producer p B.ByteString IO ()-contextReadS ctx = P.runIdentityK loop where- loop () = do- mbs <- lift (S.recv ctx)- case mbs of- Just bs -> P.respond bs >>= loop- Nothing -> return ()-{-# INLINABLE contextReadS #-}---- | Encrypts and sends to the remote end the bytes received from upstream,--- then forwards such same bytes downstream.------ If the remote peer closes its side of the connection, this proxy returns.------ Requests from downstream are forwarded upstream.-contextWriteD- :: P.Proxy p- => T.Context -- ^Established TLS connection context.- -> x -> p x B.ByteString x B.ByteString IO r-contextWriteD ctx = P.runIdentityK loop where- loop x = do- a <- P.request x- lift (S.send ctx a)- P.respond a >>= loop-{-# INLINABLE contextWriteD #-}-------------------------------------------------------------------------------------- $socket-streaming-timeout------ These proxies behave like the similarly named ones above, except they support--- timing out the interaction with the remote end.---- | Like 'contextReadS', except it throws a 'Timeout' exception in the--- 'PE.EitherP' proxy transformer if receiving data from the remote end takes--- more time than specified.-contextReadTimeoutS- :: P.Proxy p- => Int -- ^Timeout in microseconds (1/10^6 seconds).- -> T.Context -- ^Established TLS connection context.- -> () -> P.Producer (PE.EitherP Timeout p) B.ByteString IO ()-contextReadTimeoutS wait ctx = loop where- loop () = do- mmbs <- lift (timeout wait (S.recv ctx))- case mmbs of- Just (Just bs) -> P.respond bs >>= loop- Just Nothing -> return ()- Nothing -> PE.throw ex- ex = Timeout $ "contextReadTimeoutS: " <> show wait <> " microseconds."-{-# INLINABLE contextReadTimeoutS #-}---- | Like 'contextWriteD', except it throws a 'Timeout' exception in the--- 'PE.EitherP' proxy transformer if sending data to the remote end takes--- more time than specified.-contextWriteTimeoutD- :: P.Proxy p- => Int -- ^Timeout in microseconds (1/10^6 seconds).- -> T.Context -- ^Established TLS connection context.- -> x -> (PE.EitherP Timeout p) x B.ByteString x B.ByteString IO r-contextWriteTimeoutD wait ctx = loop where- loop x = do- a <- P.request x- m <- lift (timeout wait (S.send ctx a))- case m of- Just () -> P.respond a >>= loop- Nothing -> PE.throw ex- ex = Timeout $ "contextWriteTimeoutD: " <> show wait <> " microseconds."-{-# INLINABLE contextWriteTimeoutD #-}-
− src/Control/Proxy/TCP/TLS/Safe.hs
@@ -1,472 +0,0 @@-{-# LANGUAGE Rank2Types #-}---- | This module exports functions that allow you to use TLS-secured--- TCP connections as 'P.Proxy' streams, as well as utilities to connect to a--- TLS-enabled TCP server or running your own, possibly within the pipeline--- itself by relying on the facilities provided by 'P.ExceptionP' from the--- @pipes-safe@ library.------ If you don't need to establish new TLS connections within your pipeline,--- then consider using the simpler and similar functions exported by--- "Control.Proxy.TCP.TLS".------ This module re-exports many functions and types from "Network.Simple.TCP.TLS"--- module in the @network-simple@ package. You might refer to that module for--- more documentation.--module Control.Proxy.TCP.TLS.Safe (- -- * Client side- -- $client-side- connect- , S.ClientSettings- , S.getDefaultClientSettings- , S.makeClientSettings- -- ** Streaming- -- $client-streaming- , connectReadS- , connectWriteD-- -- * Server side- -- $server-side- , serve- , S.ServerSettings- , S.makeServerSettings- -- ** Listening- , listen- -- ** Accepting- , accept- , acceptFork- -- ** Streaming- -- $server-streaming- , serveReadS- , serveWriteD-- -- * Socket streams- -- $socket-streaming- , contextReadS- , contextWriteD-- -- * Note to Windows users- -- $windows-users- , NS.withSocketsDo-- -- * Exports- , S.HostPreference(..)- , S.Credential(..)- , Timeout(..)- ) where---import Control.Concurrent (ThreadId)-import qualified Control.Exception as E-import Control.Monad-import qualified Control.Proxy as P-import qualified Control.Proxy.Safe as P-import Control.Proxy.TCP.Safe (listen, Timeout(..))-import qualified Data.ByteString as B-import Data.Monoid-import qualified GHC.IO.Exception as Eg-import qualified Network.Socket as NS-import qualified Network.Simple.TCP.TLS as S-import qualified Network.TLS as T-import System.Timeout (timeout)-------------------------------------------------------------------------------------- $windows-users------ If you are running Windows, then you /must/ call 'NS.withSocketsDo', just--- once, right at the beginning of your program. That is, change your program's--- 'main' function from:------ @--- main = do--- print \"Hello world\"--- -- rest of the program...--- @------ To:------ @--- main = 'NS.withSocketsDo' $ do--- print \"Hello world\"--- -- rest of the program...--- @------ If you don't do this, your networking code won't work and you will get many--- unexpected errors at runtime. If you use an operating system other than--- Windows then you don't need to do this, but it is harmless to do it, so it's--- recommended that you do for portability reasons.-------------------------------------------------------------------------------------- $client-side------ Here's how you could run a simple TLS-secured TCP client:------ @--- import "Control.Proxy.TCP.TLS.Safe"------ \ settings <- 'S.getDefaultClientSettings'--- 'connect' settings \"www.example.org\" \"443\" $ \(tlsCtx, remoteAddr) -> do--- tryIO . putStrLn $ \"Secure connection established to \" ++ show remoteAddr--- -- now you may use tlsCtx as you please within this scope, possibly with--- -- the 'contextReadS' or 'contextWriteD' proxies explained below.--- @------ You might prefer to use the simpler but less general solutions offered by--- 'connectReadS' and 'connectWriteD', so check those too.-------------------------------------------------------------------------------------- | Connect to a TLS-secured TCP server and use the connection.------ A TLS handshake is performed immediately after establishing the TCP--- connection.------ The connection is properly closed when done or in case of exceptions. If you--- need to manage the lifetime of the connection resources yourself, then use--- 'S.connectTls' instead.-connect- :: (P.Proxy p, Monad m)- => (forall x. P.SafeIO x -> m x) -- ^Monad morphism.- -> S.ClientSettings -- ^TLS settings.- -> NS.HostName -- ^Server hostname.- -> NS.ServiceName -- ^Server service port.- -> ((T.Context, NS.SockAddr) -> P.ExceptionP p a' a b' b m r)- -- ^Computation to run in a different thread- -- once a TLS-secured connection is established. Takes- -- the TLS connection context and remote end address.- -> P.ExceptionP p a' a b' b m r-connect morph cs host port k = do- P.bracket morph (S.connectTls cs host port)- (contextCloseNoVanish . fst)- (useTls morph k)-------------------------------------------------------------------------------------- $client-streaming------ The following proxies allow you to easily connect to a TLS-secured TCP server--- and immediately interact with it using streams, all at once, instead of--- having to perform the individual steps separately.-------------------------------------------------------------------------------------- | Connect to a TLS-secured TCP server and send downstream the decrypted bytes--- received from the remote end.------ Up to @16384@ decrypted bytes will be received at once. The TLS connection is--- automatically renegotiated if a /ClientHello/ message is received.------ If an optional timeout is given and receiveing data from the remote end takes--- more time that such timeout, then throw a 'Timeout' exception in the--- 'P.ExceptionP' proxy transformer.------ If the remote peer closes its side of the connection of EOF is reached, this--- proxy returns.------ The connection is closed when done or in case of exceptions.-connectReadS- :: P.Proxy p- => Maybe Int -- ^Optional timeout in microseconds (1/10^6 seconds).- -> S.ClientSettings -- ^TLS settings.- -> NS.HostName- -> NS.ServiceName -- ^Server service port.- -> () -> P.Producer (P.ExceptionP p) B.ByteString P.SafeIO ()-connectReadS mwait cs host port = \() -> do- connect id cs host port $ \(ctx,_) -> do- contextReadS mwait ctx ()---- | Connects to a TLS-secured TCP server, encrypts and sends to the remote end--- the bytes received from upstream, then forwards such same bytes downstream.------ Requests from downstream are forwarded upstream.------ If an optional timeout is given and sending data to the remote end takes--- more time that such timeout, then throw a 'Timeout' exception in the--- 'P.ExceptionP' proxy transformer.------ The connection is properly closed when done or in case of exceptions.-connectWriteD- :: P.Proxy p- => Maybe Int -- ^Optional timeout in microseconds (1/10^6 seconds).- -> S.ClientSettings -- ^TLS settings.- -> NS.HostName -- ^Server host name.- -> NS.ServiceName -- ^Server service port.- -> x -> (P.ExceptionP p) x B.ByteString x B.ByteString P.SafeIO r-connectWriteD mwait cs hp port = \x -> do- connect id cs hp port $ \(ctx,_) ->- contextWriteD mwait ctx x-------------------------------------------------------------------------------------- $server-side------ Here's how you could run a simple TLS-secured TCP server that handles in--- different threads each incoming connection to port @4433@ at hostname--- @example.org@. You will need a X509 certificate and a private key appropiate--- to be used at that hostname.------ @--- import "Control.Proxy.TCP.TLS.Safe"--- import "Network.TLS.Extra" (fileReadCertificate, fileReadPrivateKey)------ \ cert <- 'Network.TLS.Extra.fileReadCertificate' \"~/example.org.crt\"--- pkey <- 'Network.TLS.Extra.fileReadPrivateKey' \"~/example.org.key\"--- let cred = 'S.Credential' cert pkey []--- settings = 'S.makeServerSettings' cred Nothing------ \ 'serve' settings ('S.Host' \"example.org\") \"4433\" $ \(tlsCtx, remoteAddr) -> do--- tryIO . putStrLn $ \"Secure connection established from \" ++ show remoteAddr--- -- now you may use tlsCtx as you please within this scope, possibly with--- -- the 'contextReadS' or 'contextWriteD' proxies explained below.--- @------ You might prefer to use the simpler but less general solutions offered by--- 'serveReadS' and 'serveWriteD', or if you need to control the way your--- server runs, then you can use more advanced functions such as 'listen',--- 'accept' and 'acceptFork', so check those functions too.-------------------------------------------------------------------------------------- | Start a TLS-secured TCP server that accepts incoming connections and--- handles each of them concurrently, in different threads.------ A TLS handshake is performed immediately after establishing each TCP--- connection.------ Any acquired network resources are properly closed and discarded when done or--- in case of exceptions.------ Note: This function binds a listening socket, accepts an connection, performs--- a TLS handshake and then safely closes the connection. You don't need to--- perform any of those steps manually.-serve- :: (P.Proxy p, Monad m)- => (forall x. P.SafeIO x -> m x) -- ^Monad morphism.- -> S.ServerSettings -- ^TLS settings.- -> S.HostPreference -- ^Preferred host to bind.- -> NS.ServiceName -- ^Service port to bind.- -> ((T.Context, NS.SockAddr) -> IO ())- -- ^Computation to run in a different thread- -- once an incomming connection is accepted and a- -- TLS-secured communication is established. Takes the- -- TLS connection context and remote end address.- -> P.ExceptionP p a' a b' b m r-serve morph ss hp port k = do- listen morph hp port $ \(lsock,_) -> do- forever $ acceptFork morph ss lsock k-------------------------------------------------------------------------------------- | Accept a single incoming TLS-secured TCP connection and use it.------ A TLS handshake is performed immediately after establishing each TCP--- connection.------ The connection properly closed when done or in case of exceptions.-accept- :: (P.Proxy p, Monad m)- => (forall x. P.SafeIO x -> m x) -- ^Monad morphism.- -> S.ServerSettings -- ^TLS settings.- -> NS.Socket -- ^Listening and bound socket.- -> ((T.Context, NS.SockAddr) -> P.ExceptionP p a' a b' b m r)- -- ^Computation to run once an incomming connection is- -- accepted and a TLS-secured communication is- -- established. Takes the TLS connection context and- -- remote end address.- -> P.ExceptionP p a' a b' b m r-accept morph ss lsock k = do- P.bracket morph (S.acceptTls ss lsock)- (contextCloseNoVanish . fst)- (useTls morph k)-{-# INLINABLE accept #-}---- | Like 'accept', except it uses a different thread to performs the TLS--- handshake and run the given computation.-acceptFork- :: (P.Proxy p, Monad m)- => (forall x. P.SafeIO x -> m x) -- ^Monad morphism.- -> S.ServerSettings -- ^TLS settings.- -> NS.Socket -- ^Listening and bound socket.- -> ((T.Context, NS.SockAddr) -> IO ())- -- ^Computation to run in a different thread- -- once an incomming connection is accepted and a- -- TLS-secured communication is established. Takes the- -- TLS connection context and remote end address.- -> P.ExceptionP p a' a b' b m ThreadId-acceptFork morph ss lsock k = P.hoist morph . P.tryIO $ S.acceptFork ss lsock k-{-# INLINABLE acceptFork #-}-------------------------------------------------------------------------------------- $server-streaming------ The following proxies allow you to easily run a TLS-secured TCP server and--- immediately interact with incoming connections using streams, all at once,--- instead of having to perform the individual steps separately.-------------------------------------------------------------------------------------- | Binds a listening TCP socket, accepts a single TLS-secured connection and--- sends downstream any decrypted bytes received from the remote end.------ Up to @16384@ decrypted bytes will be received at once. The TLS connection is--- automatically renegotiated if a /ClientHello/ message is received.------ If an optional timeout is given and receiveing data from the remote end takes--- more time that such timeout, then throw a 'Timeout' exception in the--- 'P.ExceptionP' proxy transformer.------ If the remote peer closes its side of the connection of EOF is reached, this--- proxy returns.------ Both the listening and connection sockets are closed when done or in case of--- exceptions.-serveReadS- :: P.Proxy p- => Maybe Int -- ^Optional timeout in microseconds (1/10^6 seconds).- -> S.ServerSettings -- ^TLS settings.- -> S.HostPreference -- ^Preferred host to bind.- -> NS.ServiceName -- ^Service port to bind.- -> () -> P.Producer (P.ExceptionP p) B.ByteString P.SafeIO ()-serveReadS mwait ss hp port = \() -> do- listen id hp port $ \(lsock,_) -> do- accept id ss lsock $ \(csock,_) -> do- contextReadS mwait csock ()---- | Binds a listening TCP socket, accepts a single TLS-secured connection,--- sends to the remote end the bytes received from upstream and then forwards--- such sames bytesdownstream.------ Requests from downstream are forwarded upstream.------ If an optional timeout is given and sending data to the remote end takes--- more time that such timeout, then throw a 'Timeout' exception in the--- 'P.ExceptionP' proxy transformer.------ If the remote peer closes its side of the connection, this proxy returns.------ Both the listening and connection sockets are closed when done or in case of--- exceptions.-serveWriteD- :: P.Proxy p- => Maybe Int -- ^Optional timeout in microseconds (1/10^6 seconds).- -> S.ServerSettings -- ^TLS settings.- -> S.HostPreference -- ^Preferred host to bind.- -> NS.ServiceName -- ^Service port to bind.- -> x -> (P.ExceptionP p) x B.ByteString x B.ByteString P.SafeIO r-serveWriteD mwait ss hp port = \x -> do- listen id hp port $ \(lsock,_) -> do- accept id ss lsock $ \(csock,_) -> do- contextWriteD mwait csock x-------------------------------------------------------------------------------------- $socket-streaming------ Once you have a an established TLS 'T.Context', you can use the following--- 'P.Proxy's to interact with the other connection end using pipes streams.-------------------------------------------------------------------------------------- | Receives decrypted bytes from the remote end, sending them downstream.------ Up to @16384@ decrypted bytes will be received at once. The TLS connection is--- automatically renegotiated if a /ClientHello/ message is received.------ If an optional timeout is given and receiveing data from the remote end takes--- more time that such timeout, then throw a 'Timeout' exception in the--- 'P.ExceptionP' proxy transformer.------ If the remote peer closes its side of the connection or EOF is reached, this--- proxy returns.-contextReadS- :: P.Proxy p- => Maybe Int -- ^Optional timeout in microseconds (1/10^6 seconds).- -> T.Context -- ^Established TLS connection context.- -> () -> P.Producer (P.ExceptionP p) B.ByteString P.SafeIO ()-contextReadS Nothing ctx = loop where- loop () = do- mbs <- P.tryIO (S.recv ctx)- case mbs of- Nothing -> return ()- Just bs -> P.respond bs >>= loop-contextReadS (Just wait) ctx = loop where- loop () = do- mmbs <- P.tryIO (timeout wait (S.recv ctx))- case mmbs of- Nothing -> P.throw ex- Just Nothing -> return ()- Just (Just bs) -> P.respond bs >>= loop- ex = Timeout $ "contextReadS: " <> show wait <> " microseconds."-{-# INLINABLE contextReadS #-}---- | Encrypts and sends to the remote end the bytes received from upstream,--- then forwards such same bytes downstream.------ If an optional timeout is given and sending data to the remote end takes--- more time that such timeout, then throw a 'Timeout' exception in the--- 'P.ExceptionP' proxy transformer.------ If the remote peer closes its side of the connection, this proxy returns.------ Requests from downstream are forwarded upstream.-contextWriteD- :: P.Proxy p- => Maybe Int -- ^Optional timeout in microseconds (1/10^6 seconds).- -> T.Context -- ^Established TLS connection context.- -> x -> (P.ExceptionP p) x B.ByteString x B.ByteString P.SafeIO r-contextWriteD Nothing ctx = loop where- loop x = do- a <- P.request x- P.tryIO (S.send ctx a)- P.respond a >>= loop-contextWriteD (Just wait) ctx = loop where- loop x = do- a <- P.request x- m <- P.tryIO (timeout wait (S.send ctx a))- case m of- Just () -> P.respond a >>= loop- Nothing -> P.throw ex- ex = Timeout $ "contextWriteD: " <> show wait <> " microseconds."-{-# INLINABLE contextWriteD #-}--------------------------------------------------------------------------------------- Internal stuff----- | Perform a TLS 'T.handshake' on the given 'T.Context', then perform the--- given action, and at last say 'T.bye' and close the TLS connection, even in--- case of exceptions. Like 'S.useTls', except it runs within 'P.ExceptionP'.------ This function discards 'Eg.ResourceVanished' exceptions that will happen when--- trying to say 'T.bye' if the remote end has done it before.-useTls- :: (Monad m, P.Proxy p)- => (forall x. P.SafeIO x -> m x) -- ^Monad morphism.- -> ((T.Context, NS.SockAddr) -> P.ExceptionP p a' a b' b m r)- -> (T.Context, NS.SockAddr) -> P.ExceptionP p a' a b' b m r-useTls morph k = \conn@(ctx,_) -> do- P.bracket_ morph (T.handshake ctx) (byeNoVanish ctx) (k conn)-{-# INLINABLE useTls #-}----- | Like `T.bye`, except it ignores `ResourceVanished` exceptions.-byeNoVanish :: T.Context -> IO ()-byeNoVanish ctx =- E.handle (\Eg.IOError{Eg.ioe_type=Eg.ResourceVanished} -> return ())- (T.bye ctx)-{-# INLINABLE byeNoVanish #-}---- | Like `T.contextClose`, except it ignores `ResourceVanished` exceptions.-contextCloseNoVanish :: T.Context -> IO ()-contextCloseNoVanish = \ctx ->- E.handle (\Eg.IOError{Eg.ioe_type=Eg.ResourceVanished} -> return ())- (T.contextClose ctx)-{-# INLINABLE contextCloseNoVanish #-}--
+ src/Pipes/Network/TCP/TLS.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE RankNTypes #-}++-- | This module exports functions that allow you to use TLS-secured+-- TCP connections in a streaming fashion.+--+-- You are encouraged to use this module together with "Network.Simple.TCP.TLS"+-- as follows:+--+-- @+-- import qualified "Network.Simple.TCP.TLS" as TLS+-- import qualified "Pipes.Network.TCP.TLS" as TLS+-- @+--+-- This module /does not/ export facilities that would allow you to establish+-- new connections within a pipeline. If you need to do so, then you should use+-- "Pipes.Network.TCP.TLS.Safe" instead, which exports a similar API to the one+-- exported by this module. Don't be confused by the word “safe” in that module;+-- this module is equally safe to use as long as you don't try to acquire new+-- resources within the pipeline.++module Pipes.Network.TCP.TLS (+ -- * Receiving+ -- $receiving+ fromContext+ , fromContextTimeout+ -- * Sending+ -- $sending+ , toContext+ , toContextTimeout+ ) where++import Pipes+import qualified Data.ByteString as B+import Foreign.C.Error (errnoToIOError, eTIMEDOUT)+import Network.Simple.TCP.TLS+import System.Timeout (timeout)++--------------------------------------------------------------------------------++-- $client-side+--+-- Here's how you could run a simple TLS-secured TCP client:+--+-- @+-- import qualified "Pipes.Network.TCP.TLS" as TLS+--+-- \ settings <- 'getDefaultClientSettings'+-- 'connect' settings \"www.example.org\" \"443\" $ \(tlsCtx, remoteAddr) -> do+-- putStrLn $ \"Secure connection established to \" ++ show remoteAddr+-- -- now you may use tlsCtx as you please within this scope, possibly with+-- -- the 'fromContext' or 'toContext' proxies explained below.+-- @++--------------------------------------------------------------------------------++-- $server-side+--+-- Here's how you could run a simple TLS-secured TCP server that handles in+-- different threads each incoming connection to port @4433@ at hostname+-- @example.org@. You will need a X509 certificate and a private key appropiate+-- to be used at that hostname.+--+-- @+-- import qualified "Pipes.Network.TCP.TLS" as TLS+-- import "Network.TLS.Extra" (fileReadCertificate, fileReadPrivateKey)+--+-- \ cert <- 'Network.TLS.Extra.fileReadCertificate' \"~/example.org.crt\"+-- pkey <- 'Network.TLS.Extra.fileReadPrivateKey' \"~/example.org.key\"+-- let cred = 'Credential' cert pkey []+-- settings = 'makeServerSettings' cred Nothing+--+-- \ 'serve' settings ('Host' \"example.org\") \"4433\" $ \(tlsCtx, remoteAddr) -> do+-- putStrLn $ \"Secure connection established from \" ++ show remoteAddr+-- -- now you may use tlsCtx as you please within this scope, possibly with+-- -- the 'fromContext' or 'toContext' proxies explained below.+-- @+--+-- If you need more control on the way your server runs, then you can use more+-- advanced functions such as 'listen', 'accept' or 'acceptFork'.++--------------------------------------------------------------------------------++-- $sending+--+-- The following pipes allow you to send bytes to the remote end over a+-- TLS-secured TCP connection.+--+-- Besides the pipes below, you might want to use "Network.Simple.TCP.TLS"'s+-- 'Network.Simple.TCP.TLS.send', which happens to be an 'Effect'':+--+-- @+-- 'TLS.send' :: 'MonadIO' m => 'TLS.Context' -> 'B.ByteString' -> 'Effect'' m ()+-- @+++-- | Encrypts and sends to the remote end each 'B.ByteString' received from+-- upstream.+toContext+ :: MonadIO m+ => Context -- ^Established TLS connection context.+ -> Consumer' B.ByteString m r+toContext ctx = for cat (\a -> send ctx a)+{-# INLINABLE toContext #-}++-- | Like 'toContext', except with the first 'Int' argument you can specify+-- the maximum time that each interaction with the remote end can take. If such+-- time elapses before the interaction finishes, then an 'IOError' exception is+-- thrown. The time is specified in microseconds (10e6).+toContextTimeout+ :: MonadIO m+ => Int -- ^Timeout in microseconds (1/10^6 seconds).+ -> Context -- ^Established TLS connection context.+ -> Consumer' B.ByteString m r+toContextTimeout wait ctx = for cat $ \a -> do+ mu <- liftIO $ timeout wait (send ctx a)+ case mu of+ Just () -> return ()+ Nothing -> liftIO $ ioError $ errnoToIOError+ "Pipes.Network.TCP.TLS.toContextTimeout" eTIMEDOUT Nothing Nothing+{-# INLINABLE toContextTimeout #-}++--------------------------------------------------------------------------------++-- $receiving+--+-- The following pipes allow you to receive bytes from the remote end over a+-- TLS-secured TCP connection.+--+-- Besides the pipes below, you might want to use "Network.Simple.TCP.TLS"'s+-- 'TLS.recv', which happens to be an 'Effect'':+--+-- @+-- 'TLS.recv' :: 'MonadIO' m => 'TLS.Context' -> 'Effect'' m ('Maybe' 'B.ByteString')+-- @+++-- | Receives decrypted bytes from the remote end and sends them downstream.+--+-- The number of bytes received at once is always in the interval+-- /[1 .. 16384]/.+--+-- The TLS connection is automatically renegotiated if a /ClientHello/ message+-- is received.+--+-- This 'Producer'' returns if the remote peer closes its side of the connection+-- or EOF is received.+fromContext+ :: MonadIO m+ => Context -- ^Established TLS connection context.+ -> Producer' B.ByteString m ()+fromContext ctx = loop where+ loop = do+ mbs <- recv ctx+ case mbs of+ Nothing -> return ()+ Just bs -> yield bs >> loop+{-# INLINABLE fromContext #-}++-- | Like 'fromContext', except with the first 'Int' argument you can specify+-- the maximum time that each interaction with the remote end can take. If such+-- time elapses before the interaction finishes, then an 'IOError' exception is+-- thrown. The time is specified in microseconds (10e6).+fromContextTimeout+ :: MonadIO m+ => Int -- ^Timeout in microseconds (1/10^6 seconds).+ -> Context -- ^Established TLS connection context.+ -> Producer' B.ByteString m ()+fromContextTimeout wait ctx = loop where+ loop = do+ mmbs <- liftIO $ timeout wait (recv ctx)+ case mmbs of+ Just (Just bs) -> yield bs >> loop+ Just Nothing -> return ()+ Nothing -> liftIO $ ioError $ errnoToIOError+ "Pipes.Network.TCP.TLS.fromContextTimeout" eTIMEDOUT Nothing Nothing+{-# INLINABLE fromContextTimeout #-}++--------------------------------------------------------------------------------++-- $exports++-- The entire "Network.Simple.TCP.TLS" module is exported.
+ src/Pipes/Network/TCP/TLS/Safe.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module exports facilities allowing you to safely obtain, use and+-- release TLS-secured TCP connections within a /Pipes/ pipeline, by relying on+-- @pipes-safe@.+--+-- This module is meant to be used together with "Pipes.Network.TCP.TLS", and it+-- overrides some functions from "Network.Simple.TCP" so that they support+-- 'P.MonadSafe'. Additionally, it also exports pipes that establish a+-- TLS-secured TCP connection and interact with it unidirectionally, in a+-- streaming fashion at once.+--+-- You are encouraged to use this module together with "Pipes.Network.TCP.TLS"+-- and "Network.Simple.TCP.TLS" as follows:+--+-- @+-- import qualified "Network.Simple.TCP.TLS" as TLS hiding (connect, serve, listen, accept)+-- import qualified "Pipes.Network.TCP.TLS" as TLS+-- import qualified "Pipes.Network.TCP.TLS.Safe" as TLS+-- @++module Pipes.Network.TCP.TLS.Safe (+ -- * @MonadSafe@-compatible upgrades+ -- $network-simple-upgrades+ connect+ , serve+ , listen+ , accept+ -- * Streaming+ -- ** Client side+ -- $client-streaming+ , fromConnect+ , toConnect+ -- ** Server side+ -- $server-streaming+ , fromServe+ , toServe+ ) where+++import Control.Monad (forever)+import Data.ByteString (ByteString)+import qualified Network.Simple.TCP.TLS as S+import Network.TLS (contextClose)+import Pipes+import Pipes.Network.TCP.Safe (listen)+import Pipes.Network.TCP.TLS (fromContext, toContext)+import qualified Pipes.Safe as P++--------------------------------------------------------------------------------++-- $network-simple-upgrades+--+-- The following functions are analogous versions of those exported by+-- "Network.Simple.TCP.TLS", but compatible with 'P.MonadSafe'.++-- | Like 'Network.Simple.TCP.TLS.connect' from "Network.Simple.TCP.TLS", but+-- compatible with 'P.MonadSafe'.+connect+ :: (P.MonadSafe m, P.Base m ~ IO)+ => S.ClientSettings -> S.HostName -> S.ServiceName+ -> ((S.Context, S.SockAddr) -> m r) -> m r+connect cs host port k = P.bracket (S.connectTls cs host port)+ (liftIO . contextClose . fst)+ (S.useTls k)++-- | Like 'Network.Simple.TCP.TLS.serve' from "Network.Simple.TCP.TLS", but+-- compatible with 'P.MonadSafe'.+serve+ :: (P.MonadSafe m, P.Base m ~ IO)+ => S.ServerSettings -> S.HostPreference -> S.ServiceName+ -> ((S.Context, S.SockAddr) -> IO ()) -> m r+serve ss hp port k = do+ listen hp port $ \(lsock,_) -> do+ forever $ S.acceptFork ss lsock k++-- | Like 'Network.Simple.TCP.TLS.accept' from "Network.Simple.TCP.TLS", but+-- compatible with 'P.MonadSafe'.+accept+ :: (P.MonadSafe m, P.Base m ~ IO)+ => S.ServerSettings -> S.Socket -> ((S.Context, S.SockAddr) -> m r) -> m r+accept ss lsock k = P.bracket (S.acceptTls ss lsock)+ (liftIO . contextClose . fst)+ (S.useTls k)+{-# INLINABLE accept #-}++--------------------------------------------------------------------------------++-- $client-streaming+--+-- The following proxies allow you to easily connect to a TLS-secured TCP server+-- and immediately interact with it in a streaming fashion, all at once, instead+-- of having to perform the individual steps separately.++--------------------------------------------------------------------------------++-- | Connect to a TLS-secured TCP server and send downstream the decrypted bytes+-- received from the remote end.+--+-- Up to @16384@ decrypted bytes will be received at once. The TLS connection is+-- automatically renegotiated if a /ClientHello/ message is received.+--+-- If the remote peer closes its side of the connection of EOF is reached, this+-- proxy returns.+--+-- The connection is closed when done or in case of exceptions.+fromConnect+ :: (P.MonadSafe m, P.Base m ~ IO)+ => S.ClientSettings -- ^TLS settings.+ -> S.HostName+ -> S.ServiceName -- ^Server service port.+ -> Producer' ByteString m ()+fromConnect cs host port = do+ connect cs host port $ \(ctx,_) -> do+ fromContext ctx++-- | Connects to a TLS-secured TCP server, then repeatedly encrypts and sends to+-- the remote end the bytes received from upstream.+--+-- The connection is properly closed when done or in case of exceptions.+toConnect+ :: (P.MonadSafe m, P.Base m ~ IO)+ => S.ClientSettings -- ^TLS settings.+ -> S.HostName -- ^Server host name.+ -> S.ServiceName -- ^Server service port.+ -> Consumer' ByteString m ()+toConnect cs hp port = do+ connect cs hp port $ \(ctx,_) ->+ toContext ctx++--------------------------------------------------------------------------------++-- $server-streaming+--+-- The following proxies allow you to easily run a TLS-secured TCP server and+-- immediately interact with incoming connections in a streaming fashion, all at+-- once, instead of having to perform the individual steps separately.++--------------------------------------------------------------------------------++-- | Binds a listening TCP socket, accepts a single TLS-secured connection and+-- sends downstream any decrypted bytes received from the remote end.+--+-- Up to @16384@ decrypted bytes will be received at once. The TLS connection is+-- automatically renegotiated if a /ClientHello/ message is received.+--+-- If the remote peer closes its side of the connection of EOF is reached, this+-- proxy returns.+--+-- Both the listening and connection sockets are closed when done or in case of+-- exceptions.+fromServe+ :: (P.MonadSafe m, P.Base m ~ IO)+ => S.ServerSettings -- ^TLS settings.+ -> S.HostPreference -- ^Preferred host to bind.+ -> S.ServiceName -- ^Service port to bind.+ -> Producer' ByteString m ()+fromServe ss hp port = do+ listen hp port $ \(lsock,_) -> do+ accept ss lsock $ \(ctx,_) -> do+ fromContext ctx++-- | Binds a listening TCP socket, accepts a single TLS-secured connection,+-- and repeatedly sends to the remote end any bytes received from upstream.+--+-- If the remote peer closes its side of the connection, this proxy returns.+--+-- Both the listening and connection sockets are closed when done or in case of+-- exceptions.+toServe+ :: (P.MonadSafe m, P.Base m ~ IO)+ => S.ServerSettings -- ^TLS settings.+ -> S.HostPreference -- ^Preferred host to bind.+ -> S.ServiceName -- ^Service port to bind.+ -> Consumer' ByteString m r+toServe ss hp port = do+ listen hp port $ \(lsock,_) -> do+ accept ss lsock $ \(ctx,_) -> do+ toContext ctx+