diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/examples/tls-echo.hs b/examples/tls-echo.hs --- a/examples/tls-echo.hs +++ b/examples/tls-echo.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/examples/tls-tunnel.hs b/examples/tls-tunnel.hs deleted file mode 100644 --- a/examples/tls-tunnel.hs +++ /dev/null @@ -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 } diff --git a/pipes-network-tls.cabal b/pipes-network-tls.cabal --- a/pipes-network-tls.cabal +++ b/pipes-network-tls.cabal @@ -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 + diff --git a/src/Control/Proxy/TCP/TLS.hs b/src/Control/Proxy/TCP/TLS.hs deleted file mode 100644 --- a/src/Control/Proxy/TCP/TLS.hs +++ /dev/null @@ -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 #-} - diff --git a/src/Control/Proxy/TCP/TLS/Safe.hs b/src/Control/Proxy/TCP/TLS/Safe.hs deleted file mode 100644 --- a/src/Control/Proxy/TCP/TLS/Safe.hs +++ /dev/null @@ -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 #-} - - diff --git a/src/Pipes/Network/TCP/TLS.hs b/src/Pipes/Network/TCP/TLS.hs new file mode 100644 --- /dev/null +++ b/src/Pipes/Network/TCP/TLS.hs @@ -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. diff --git a/src/Pipes/Network/TCP/TLS/Safe.hs b/src/Pipes/Network/TCP/TLS/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Pipes/Network/TCP/TLS/Safe.hs @@ -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 +