diff --git a/PEOPLE b/PEOPLE --- a/PEOPLE +++ b/PEOPLE @@ -6,3 +6,4 @@ Vincent Hanquez Joseph Abrahamson Gabriel Gonzalez +Nickolay Kudasov diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ # network-simple-tls +[![Build Status](https://secure.travis-ci.org/k0001/network-simple-tls.png)](http://travis-ci.org/k0001/network-simple-tls) + Haskell library simplifying the useage of TLS secured network connections. Currently, only TCP sockets are supported. This package aims to be similar and compatible with the `network-simple` package. diff --git a/network-simple-tls.cabal b/network-simple-tls.cabal --- a/network-simple-tls.cabal +++ b/network-simple-tls.cabal @@ -1,5 +1,5 @@ name: network-simple-tls -version: 0.1.1.0 +version: 0.2.0 synopsis: Simple interface to TLS secured network sockets. description: Simple interface to TLS secured network sockets. homepage: https://github.com/k0001/network-simple-tls @@ -23,12 +23,15 @@ exposed-modules: Network.Simple.TCP.TLS build-depends: base (>=4.5 && <5.0) , bytestring (>=0.9.2.1 && <0.11) - , certificate (>=1.3 && <1.4) - , crypto-random-api (>=0.2 && <0.3) , network (>=2.3 && <2.5) - , network-simple (>=0.2 && <0.3) - , tls (>=1.1 && <1.2) - , tls-extra (>=0.6 && <0.7) + -- Packages not in The Haskell Platform + , certificate (>=1.3 && <1.4) + , cprng-aes (>=0.3 && <0.6) + , exceptions (>=0.3 && <0.4) + , network-simple (>=0.3 && <0.4) + , tls (>=1.1.4 && <1.2) + , tls-extra (>=0.6.5 && <0.7) + , transformers (>=0.2 && <0.4) ghc-options: -Wall -O2 ghc-prof-options: -prof -fprof-auto-top diff --git a/src/Network/Simple/TCP/TLS.hs b/src/Network/Simple/TCP/TLS.hs --- a/src/Network/Simple/TCP/TLS.hs +++ b/src/Network/Simple/TCP/TLS.hs @@ -7,6 +7,11 @@ -- This module re-exports some functions from the "Network.Simple.TCP" module -- in the @network-simple@ package. Consider using that module directly if you -- need a similar API without TLS support. +-- +-- This module uses 'MonadIO' and 'C.MonadCatch' extensively so that you can +-- reuse these functions in monads other than 'IO'. However, if you don't care +-- about any of that, just pretend you are using the 'IO' monad all the time +-- and everything will work as expected. module Network.Simple.TCP.TLS ( -- * Server side @@ -40,64 +45,63 @@ , send -- * Low level support - , connectTls - , acceptTls , useTls + , useTlsThenClose , useTlsThenCloseFork + , connectTls + , acceptTls + , makeClientContext + , makeServerContext -- * Note to Windows users - -- $windows-users , NS.withSocketsDo -- * Exports - , S.HostPreference(..) + -- $exports + , module Network.Simple.TCP + , module Network.Socket + , module Network.TLS ) where import Control.Concurrent (ThreadId, forkIO) import qualified Control.Exception as E -import Control.Monad (forever) -import Crypto.Random.API (getSystemRandomGen) +import Control.Monad +import qualified Control.Monad.Catch as C +import Control.Monad.IO.Class (MonadIO(liftIO)) +import qualified Crypto.Random.AESCtr as AESCtr import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Certificate.X509 as X import qualified Data.CertificateStore as C import Data.Maybe (listToMaybe) import Data.List (intersect) +import Foreign.C.Error (Errno(Errno), ePIPE) import qualified GHC.IO.Exception as Eg import qualified Network.Simple.TCP as S import qualified Network.Socket as NS +import qualified Network.Socket.ByteString as NSB import qualified Network.TLS as T import Network.TLS.Extra as TE import System.Certificate.X509 (getSystemCertificateStore) -import System.IO (IOMode(ReadWriteMode)) - -------------------------------------------------------------------------------- --- $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: + +import Network.Simple.TCP (HostPreference(Host, HostAny, HostIPv4, HostIPv6)) +import Network.Socket (HostName, ServiceName, Socket, SockAddr) +import Network.TLS (Context) + +-- $exports -- --- @ --- main = do --- print \"Hello world\" --- -- rest of the program... --- @ +-- For your convenience, this module module also re-exports the following types +-- from other modules: -- --- To: +-- [From "Network.Socket"] 'HostName', 'ServiceName', 'Socket', 'SockAddr'. -- --- @ --- main = 'NS.withSocketsDo' $ do --- print \"Hello world\" --- -- rest of the program... --- @ +-- [From "Network.Simple.TCP"] +-- @'HostPreference'('Host','HostAny','HostIPv4','HostIPv6')@. -- --- 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. +-- [From "Network.TLS"] 'Context'. -------------------------------------------------------------------------------- @@ -122,8 +126,8 @@ -- | Get the system default 'ClientSettings'. -- -- See 'makeClientSettings' for the for the default TLS settings used. -getDefaultClientSettings :: IO ClientSettings -getDefaultClientSettings = +getDefaultClientSettings :: MonadIO m => m ClientSettings +getDefaultClientSettings = liftIO $ do makeClientSettings [] Nothing `fmap` getSystemCertificateStore -- | Make defaults 'ClientSettings'. @@ -145,7 +149,7 @@ :: [Credential] -- ^Credentials to provide to the server, if requested. -- The first one is used in case we can't choose one -- based on information provided by the server. - -> Maybe NS.HostName -- ^Explicit Server Name Identification (SNI). + -> Maybe HostName -- ^Explicit Server Name Identification (SNI). -> C.CertificateStore -- ^CAs used to verify the server certificate. -- Use 'getSystemCertificateStore' to obtain -- the operating system's defaults. @@ -273,16 +277,17 @@ -- connection when done or in case of exceptions. You don't need to perform any -- of those steps manually. serve - :: ServerSettings -- ^TLS settings. + :: MonadIO m + => ServerSettings -- ^TLS settings. -> S.HostPreference -- ^Preferred host to bind. - -> NS.ServiceName -- ^Service port to bind. - -> ((T.Context, NS.SockAddr) -> IO ()) + -> ServiceName -- ^Service port to bind. + -> ((Context, 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. - -> IO () -serve ss hp port k = + -> m () +serve ss hp port k = liftIO $ do S.listen hp port $ \(lsock,_) -> do forever $ acceptFork ss lsock k @@ -291,145 +296,182 @@ -- | Accepts a single incomming TLS-secured TCP connection and use it. -- -- 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 --- 'acceptTls' instead. +-- connection and the TLS and TCP connections are properly closed when done or +-- in case of exceptions. If you need to manage the lifetime of the connection +-- resources yourself, then use 'acceptTls' instead. accept - :: ServerSettings -- ^TLS settings. - -> NS.Socket -- ^Listening and bound socket. - -> ((T.Context, NS.SockAddr) -> IO b) + :: (MonadIO m, C.MonadCatch m) + => ServerSettings -- ^TLS settings. + -> Socket -- ^Listening and bound socket. + -> ((Context, SockAddr) -> m r) -- ^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. - -> IO b -accept ss lsock k = E.bracket (acceptTls ss lsock) - (contextCloseNoVanish . fst) + -> m r +accept ss lsock k = C.bracket (acceptTls ss lsock) + (liftIO . T.contextClose . fst) (useTls k) -- | Like 'accept', except it uses a different thread to performs the TLS -- handshake and run the given computation. acceptFork - :: ServerSettings -- ^TLS settings. - -> NS.Socket -- ^Listening and bound socket. - -> ((T.Context, NS.SockAddr) -> IO ()) + :: MonadIO m + => ServerSettings -- ^TLS settings. + -> Socket -- ^Listening and bound socket. + -> ((Context, 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. - -> IO ThreadId -acceptFork ss lsock k = E.bracketOnError (acceptTls ss lsock) - (contextCloseNoVanish . fst) - (useTlsThenCloseFork k) + -> m ThreadId +acceptFork ss lsock k = liftIO $ do + E.bracketOnError (acceptTls ss lsock) + (T.contextClose . fst) + (useTlsThenCloseFork k) -------------------------------------------------------------------------------- -- | 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 --- 'connectTls' instead. +-- connection and the TLS and TCP connections are properly closed when done or +-- in case of exceptions. If you need to manage the lifetime of the connection +-- resources yourself, then use 'connectTls' instead. connect - :: ClientSettings -- ^TLS settings. - -> NS.HostName -- ^Server hostname. - -> NS.ServiceName -- ^Server service port. - -> ((T.Context, NS.SockAddr) -> IO r) + :: (MonadIO m, C.MonadCatch m) + => ClientSettings -- ^TLS settings. + -> HostName -- ^Server hostname. + -> ServiceName -- ^Server service port. + -> ((Context, SockAddr) -> m r) -- ^Computation to run after establishing TLS-secured -- TCP connection to the remote server. Takes the TLS -- connection context and remote end address. - -> IO r -connect cs host port k = E.bracket (connectTls cs host port) - (contextCloseNoVanish . fst) + -> m r +connect cs host port k = C.bracket (connectTls cs host port) + (liftIO . T.contextClose . fst) (useTls k) -------------------------------------------------------------------------------- -- | Estalbishes a TCP connection to a remote server and returns a TLS --- 'T.Context' configured on top of it using the given 'ClientSettings'. +-- 'Context' configured on top of it using the given 'ClientSettings'. -- The remote end address is also returned. -- --- Prefer to use 'connect' if you will be used the obtained 'T.Context' within a +-- Prefer to use 'connect' if you will be using the obtained 'Context' within a -- limited scope. -- --- You need to call 'T.handshake' on the resulting 'T.Context' before using it --- for communication purposes, and 'T.bye' afterwards. The 'useTls' or --- 'useTlsThenCloseFork' functions can perform those steps for you. -connectTls :: ClientSettings -> NS.HostName -> NS.ServiceName - -> IO (T.Context, NS.SockAddr) -connectTls (ClientSettings params) host port = do - (csock, caddr) <- S.connectSock host port - (`E.onException` NS.sClose csock) $ do - h <- NS.socketToHandle csock ReadWriteMode - ctx <- T.contextNewOnHandle h params' =<< getSystemRandomGen - return (ctx, caddr) +-- You need to perform a TLS handshake on the resulting 'Context' before using +-- it for communication purposes, and gracefully close the TLS and TCP +-- connections afterwards using. The 'useTls', 'useTlsThenClose' and +-- 'useTlsThenCloseFork' can help you with that. +connectTls + :: MonadIO m + => ClientSettings -- ^TLS settings. + -> HostName -- ^Server hostname. + -> ServiceName -- ^Service port to bind. + -> m (Context, SockAddr) +connectTls cs host port = liftIO $ do + E.bracketOnError + (S.connectSock host port) + (S.closeSock . fst) + (\(sock, addr) -> do + ctx <- makeClientContext (updateClientParams up cs) sock + return (ctx, addr)) where - params' = params { T.onCertificatesRecv = TE.certificateChecks certsCheck } - certsCheck = [T.onCertificatesRecv params, return . checkHost] - checkHost = - let T.Client cparams = T.roleParams params in - case T.clientUseServerName cparams of - Nothing -> TE.certificateVerifyDomain host - Just sni -> TE.certificateVerifyDomain sni + up params = + let certsCheck = [T.onCertificatesRecv params, return . checkHost] + checkHost = let T.Client cparams = T.roleParams params in + case T.clientUseServerName cparams of + Nothing -> TE.certificateVerifyDomain host + Just sni -> TE.certificateVerifyDomain sni + in params { T.onCertificatesRecv = TE.certificateChecks certsCheck } --- | Accepts an incoming TCP connection and returns a TLS 'T.Context' configured +-- | Make a client-side TLS 'Context' for the given settings, on top of the +-- given TCP `Socket` connected to the remote end. +makeClientContext :: MonadIO m => ClientSettings -> Socket -> m Context +makeClientContext (ClientSettings params) sock = liftIO $ do + T.contextNew (socketBackend sock) params =<< AESCtr.makeSystem + +-------------------------------------------------------------------------------- + +-- | Accepts an incoming TCP connection and returns a TLS 'Context' configured -- on top of it using the given 'ServerSettings'. The remote end address is also -- returned. -- --- Prefer to use 'accept' if you will be used the obtained 'T.Context' within a +-- Prefer to use 'accept' if you will be using the obtained 'Context' within a -- limited scope. -- --- You need to call 'T.handshake' on the resulting 'T.Context' before using it --- for communication purposes, and 'T.bye' afterwards. The 'useTls' or --- 'useTlsThenCloseFork' functions can perform those steps for you. -acceptTls :: ServerSettings -> NS.Socket -> IO (T.Context, NS.SockAddr) -acceptTls (ServerSettings params) lsock = do - (csock, caddr) <- NS.accept lsock - (`E.onException` NS.sClose csock) $ do - h <- NS.socketToHandle csock ReadWriteMode - ctx <- T.contextNewOnHandle h params =<< getSystemRandomGen - return (ctx, caddr) +-- You need to perform a TLS handshake on the resulting 'Context' before using +-- it for communication purposes, and gracefully close the TLS and TCP +-- connections afterwards using. The 'useTls', 'useTlsThenClose' and +-- 'useTlsThenCloseFork' can help you with that. +acceptTls + :: MonadIO m + => ServerSettings -- ^TLS settings. + -> Socket -- ^Listening and bound socket. + -> m (Context, SockAddr) +acceptTls sp lsock = liftIO $ do + E.bracketOnError + (NS.accept lsock) + (S.closeSock . fst) + (\(sock, addr) -> do + ctx <- makeServerContext sp sock + return (ctx, addr)) --- | Perform a TLS 'T.handshake' on the given 'T.Context', then perform the --- given action and at last say 'T.bye', even in case of exceptions. +-- | Make a server-side TLS 'Context' for the given settings, on top of the +-- given TCP `Socket` connected to the remote end. +makeServerContext :: MonadIO m => ServerSettings -> Socket -> m Context +makeServerContext (ServerSettings params) sock = liftIO $ do + T.contextNew (socketBackend sock) params =<< AESCtr.makeSystem + +-------------------------------------------------------------------------------- + +-- | Perform a TLS handshake on the given 'Context', then perform the +-- given action and at last gracefully close the TLS session using `T.bye`. -- --- This function discards 'Eg.ResourceVanished' exceptions that will happen when --- trying to say 'T.bye' if the remote end has done it before. -useTls :: ((T.Context, NS.SockAddr) -> IO a) -> (T.Context, NS.SockAddr) -> IO a -useTls k conn@(ctx,_) = E.bracket_ (T.handshake ctx) (byeNoVanish ctx) (k conn) +-- This function does not close the underlying TCP connection when done. +-- Prefer to use `useTlsThenClose` or `useTlsThenCloseFork` if you need that +-- behavior. Otherwise, you must call `T.contextClose` yourself at some point. +useTls + :: (MonadIO m, C.MonadCatch m) + => ((Context, SockAddr) -> m a) + -> ((Context, SockAddr) -> m a) +useTls k conn@(ctx,_) = C.bracket_ (T.handshake ctx) + (liftIO $ silentBye ctx) + (k conn) --- | Similar to 'useTls', except it performs the all the IO actions safely in a --- new thread and closes the connection backend after using it. Use this instead --- of forking `useTls` yourself. +-- | Like 'useTls', except it also fully closes the TCP connection when done. +useTlsThenClose + :: (MonadIO m, C.MonadCatch m) + => ((Context, SockAddr) -> m a) + -> ((Context, SockAddr) -> m a) +useTlsThenClose k conn@(ctx,_) = do + useTls k conn `C.finally` liftIO (T.contextClose ctx) + +-- | Similar to 'useTlsThenClose', except it performs the all the IO actions +-- in a new thread. -- --- This function discards 'Eg.ResourceVanished' exceptions that will happen when --- trying to close the connection backend if the remote end has done it before. -useTlsThenCloseFork :: ((T.Context, NS.SockAddr) -> IO ()) - -> (T.Context, NS.SockAddr) -> IO ThreadId -useTlsThenCloseFork k conn@(ctx,_) = do - forkFinally (E.bracket_ (T.handshake ctx) (byeNoVanish ctx) (k conn)) - (\e1 -> do - e2 <- E.try $ contextCloseNoVanish ctx - -- in case both e1 and e2 hold exceptions, we throw e1. - case (e1,e2) of - (Left e, _) -> E.throwIO e - (_, Left e) -> E.throwIO (e :: E.SomeException) - _ -> return ()) +-- Use this instead of forking `useTlsThenClose` yourself, as that won't give +-- the right behavior. +useTlsThenCloseFork + :: MonadIO m + => ((Context, SockAddr) -> IO ()) + -> ((Context, SockAddr) -> m ThreadId) +useTlsThenCloseFork k conn@(ctx,_) = liftIO $ do + forkFinally (E.bracket_ (T.handshake ctx) (silentBye ctx) (k conn)) + (\eu -> T.contextClose ctx >> either E.throwIO return eu) -------------------------------------------------------------------------------- -- Utils --- | Receives decrypted bytes from the given 'T.Context'. Returns 'Nothing' +-- | Receives decrypted bytes from the given 'Context'. Returns 'Nothing' -- on EOF. -- -- Up to @16384@ decrypted bytes will be received at once. The TLS connection is -- automatically renegotiated if a /ClientHello/ message is received. -recv :: T.Context -> IO (Maybe B.ByteString) -recv ctx = +recv :: MonadIO m => Context -> m (Maybe B.ByteString) +recv ctx = liftIO $ do E.handle (\T.Error_EOF -> return Nothing) (do bs <- T.recvData ctx if B.null bs @@ -438,9 +480,9 @@ {-# INLINABLE recv #-} -- | Encrypts the given strict 'B.ByteString' and sends it through the --- 'T.Context'. -send :: T.Context -> B.ByteString -> IO () -send ctx bs = T.sendData ctx (BL.fromChunks [bs]) +-- 'Context'. +send :: MonadIO m => Context -> B.ByteString -> m () +send ctx = \bs -> T.sendData ctx (BL.fromChunks [bs]) {-# INLINABLE send #-} -------------------------------------------------------------------------------- @@ -465,21 +507,25 @@ -------------------------------------------------------------------------------- -- Internal utils --- | Like 'T.bye', except it ignores 'Eg.ResourceVanished' exceptions. -byeNoVanish :: T.Context -> IO () -byeNoVanish ctx = - E.handle (\Eg.IOError{Eg.ioe_type=Eg.ResourceVanished} -> return ()) - (T.bye ctx) - --- | Like 'T.contextClose', except it ignores 'Eg.ResourceVanished' exceptions. -contextCloseNoVanish :: T.Context -> IO () -contextCloseNoVanish ctx = - E.handle (\Eg.IOError{Eg.ioe_type=Eg.ResourceVanished} -> return ()) - (T.contextClose ctx) - -- | 'Control.Concurrent.forkFinally' was introduced in base==4.6.0.0. We'll use -- our own version here for a while, until base==4.6.0.0 is widely establised. forkFinally :: IO a -> (Either E.SomeException a -> IO ()) -> IO ThreadId forkFinally action and_then = E.mask $ \restore -> forkIO $ E.try (restore action) >>= and_then + +-- | Like 'T.bye' from the "Network.TLS" module, except it ignores 'ePIPE' +-- errors which might happen if the remote peer closes the connection first. +silentBye :: Context -> IO () +silentBye ctx = do + E.catch (T.bye ctx) $ \e -> case e of + Eg.IOError{ Eg.ioe_type = Eg.ResourceVanished + , Eg.ioe_errno = Just ioe + } | Errno ioe == ePIPE + -> return () + _ -> E.throwIO e + +-- | Makes an TLS context `T.Backend` from a `Socket`. +socketBackend :: Socket -> T.Backend +socketBackend sock = do + T.Backend (return ()) (S.closeSock sock) (NSB.sendAll sock) (NSB.recv sock)