network-simple-tls-0.4.2: src/Network/Simple/TCP/TLS.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- | This module exports simple tools for establishing TLS-secured TCP
-- connections, relevant to both the client side and server side of the
-- connection.
--
-- This module re-exports some functions from the "Network.Simple.TCP" module in
-- the [network-simple](https://hackage.haskell.org/package/network-simple)
-- package. Consider using that module directly if you need a similar API
-- without TLS support.
--
-- This module uses 'MonadIO' and 'E.MonadMask' 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
serve
-- ** Listening
, S.listen
-- ** Accepting
, accept
, acceptFork
-- ** Server TLS Settings
, newDefaultServerParams
, makeServerParams
-- * Client side
, connect
, connectOverSOCKS5
-- ** Client TLS Settings
, newDefaultClientParams
, makeClientParams
-- * Utils
, recv
, send
, sendLazy
-- * Low level support
, useTls
, useTlsThenClose
, useTlsThenCloseFork
, connectTls
, connectTlsOverSOCKS5
, acceptTls
, makeClientContext
, makeServerContext
-- * Re-exports
-- $reexports
, NS.withSocketsDo
, S.HostPreference(..)
, NS.HostName
, NS.ServiceName
-- | A service port like @"80"@ or its name @"www"@.
, NS.Socket
, NS.SockAddr
, T.Context
, T.ClientParams
-- | Please refer to the "Network.TLS" module for more documentation on
-- 'T.ClientParams`.
--
-- There's plenty to be changed, but the documentation for
-- 'T.ClientParams' is not rendered inside "Network.Simple.TCP.TLS" module.
, T.ServerParams
-- | Please refer to the "Network.TLS" module for more documentation on
-- 'T.ServerParams`.
--
-- There's plenty to be changed, but the documentation for
-- 'T.ServerParams' is not rendered inside "Network.Simple.TCP.TLS" module.
, T.Credential
, credentialLoadX509
) where
import Control.Concurrent (ThreadId, forkFinally)
import qualified Control.Exception.Safe as E
import Control.Monad
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Default (def)
import Data.List (intersect)
import Data.Maybe (isJust, listToMaybe)
import qualified Data.X509 as X
import qualified Data.X509.CertificateStore as X
import qualified Data.X509.Validation as X
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.TLS as T
import qualified Network.TLS.SessionManager as TSM
import qualified Network.TLS.Extra as TE
import System.X509 (getSystemCertificateStore)
--------------------------------------------------------------------------------
-- $reexports
--
-- For your convenience, this module module also re-exports the following types
-- from other modules:
--
-- [From "Network.Socket"] 'NS.HostName', 'NS.ServiceName', 'NS.Socket',
-- 'NS.SockAddr', 'NS.withSocketsDo'.
--
-- [From "Network.Simple.TCP"]
-- @'S.HostPreference'('S.Host','S.HostAny','S.HostIPv4','S.HostIPv6')@.
--
-- [From "Network.TLS"] 'T.Context', 'T.Credential', 'T.ServerParams',
-- 'T.ClientParams', 'credentialLoadX509'.
--------------------------------------------------------------------------------
-- Client side TLS settings
-- | Obtain new default 'T.ClientParams' for a particular 'X.ServiceID'.
--
-- * No client credentials sumbitted to the server.
--
-- * Use system-wide CA certificate store.
--
-- * Use an in-memory TLS session manager from the
-- [tls-session-manager](https://hackage.haskell.org/package/tls-session-manager)
-- package.
--
-- * Everything else as proposed by 'makeClientParams'.
newDefaultClientParams
:: MonadIO m
=> X.ServiceID
-- ^
-- @
-- 'X.ServiceID' ~ ('S.HostName', 'B.ByteString')
-- @
--
-- Identification of the connection consisting of the fully qualified host
-- name for the server (e.g. www.example.com) and an optional suffix.
--
-- It is important that the hostname part is properly filled for security
-- reasons, as it allow to properly associate the remote side with the given
-- certificate during a handshake.
--
-- The suffix is used to identity a certificate per service on a specific
-- host. For example, a same host might have different certificates on
-- differents ports (443 and 995). For TCP connections, it's recommended
-- to use: @:port@, or @:service@ for the blob (e.g., \@":443"@, @\":https"@).
-> m T.ClientParams
newDefaultClientParams sid = liftIO $ do
cs <- getSystemCertificateStore
sm <- TSM.newSessionManager TSM.defaultConfig
let cp0 = makeClientParams sid [] cs
pure $ cp0
{ T.clientShared = (T.clientShared cp0)
{ T.sharedSessionManager = sm }
}
-- | Make defaults 'T.ClientParams'.
--
-- * Certificate chain validation is done by 'X.validateDefault' from the
-- "Data.X509.Validation" module.
--
-- * The Server Name Indication (SNI) TLS extension is enabled.
--
-- * The supported cipher suites are those enumerated by 'TE.ciphersuite_default',
-- in decreasing order of preference.
--
-- * Secure renegotiation is enabled.
--
-- * Only the __TLS 1.1__, __TLS 1.2__ and __TLS 1.3__ protocols are supported by default.
--
-- If you are unsatisfied with any of these settings, please
-- please refer to the "Network.TLS" module for more documentation on
-- 'T.ClientParams`.
makeClientParams
:: X.ServiceID
-- ^
-- @
-- 'X.ServiceID' ~ ('S.HostName', 'B.ByteString')
-- @
--
-- Identification of the connection consisting of the fully qualified host
-- name for the server (e.g. www.example.com) and an optional suffix.
--
-- It is important that the hostname part is properly filled for security
-- reasons, as it allow to properly associate the remote side with the given
-- certificate during a handshake.
--
-- The suffix is used to identity a certificate per service on a specific
-- host. For example, a same host might have different certificates on
-- differents ports (443 and 995). For TCP connections, it's recommended
-- to use: @:port@, or @:service@ for the blob (e.g., \@":443"@, @\":https"@).
-> [T.Credential]
-- ^ Credentials to provide to the server if requested. Only credentials
-- matching the server's 'X.DistinguishedName' will be submitted.
--
-- Can be loaded with 'credentialLoadX509' or similar functions.
-> X.CertificateStore
-- ^ CAs used to verify the server certificate.
--
-- Use 'getSystemCertificateStore' to obtain the operating system's defaults.
-> T.ClientParams
makeClientParams (hn, sp) creds cStore =
(T.defaultParamsClient hn sp)
{ T.clientUseServerNameIndication = True
, T.clientSupported = def
{ T.supportedVersions = [T.TLS13, T.TLS12, T.TLS11]
, T.supportedCiphers = TE.ciphersuite_default
, T.supportedSecureRenegotiation = True
, T.supportedClientInitiatedRenegotiation = True }
, T.clientShared = def { T.sharedCAStore = cStore }
, T.clientHooks = def
{ T.onServerCertificate = X.validateDefault
, T.onCertificateRequest = pure . findCredential }
}
where
-- | Find the first Credential that matches the given requirements.
-- Currently, the only requirement considered is the subject DN.
findCredential
:: ([T.CertificateType],
Maybe [T.HashAndSignatureAlgorithm],
[X.DistinguishedName])
-> Maybe (X.CertificateChain, X.PrivKey)
findCredential (_, _, dns) = listToMaybe (filter isSubject creds)
where
isSubject (X.CertificateChain cc, _) =
any (\c -> (X.certSubjectDN . X.getCertificate) c `elem` dns) cc
--------------------------------------------------------------------------------
-- Server side TLS settings
-- | Make default 'T.ServerParams'.
--
-- * The supported cipher suites are those enumerated by 'TE.ciphersuite_strong',
-- in decreasing order of preference. The cipher suite preferred by the server
-- is used.
--
-- * Secure renegotiation initiated by the server is enabled, but renegotiation
-- initiated by the client is disabled.
--
-- * Only the __TLS 1.1__, __TLS 1.2__ and __TLS 1.3__ protocols are supported by default.
--
-- If you are unsatisfied with any of these settings, please
-- please refer to the "Network.TLS" module for more documentation on
-- 'T.ServerParams`.
makeServerParams
:: T.Credential
-- ^ Server credential.
--
-- Can be loaded with 'credentialLoadX509' or similar functions.
-> Maybe X.CertificateStore
-- ^ CAs used to verify the client certificate.
--
-- If specified, then a valid client certificate will be expected during
-- handshake.
--
-- Use 'getSystemCertificateStore' to obtain the operating system's defaults.
-> T.ServerParams
makeServerParams cred ycStore = def
{ T.serverWantClientCert = isJust ycStore
, T.serverShared = def
{ T.sharedCredentials = T.Credentials [cred] }
, T.serverCACertificates = []
, T.serverSupported = def
{ T.supportedVersions = [T.TLS13, T.TLS12, T.TLS11]
, T.supportedCiphers = TE.ciphersuite_strong
, T.supportedSession = True
, T.supportedSecureRenegotiation = True
, T.supportedClientInitiatedRenegotiation = False }
, T.serverHooks = def
{ T.onClientCertificate = clientCertsCheck
, T.onCipherChoosing = chooseCipher }
}
where
clientCertsCheck :: X.CertificateChain -> IO T.CertificateUsage
clientCertsCheck certs = case ycStore of
Nothing -> return T.CertificateUsageAccept
Just cs -> do
let checks = X.defaultChecks { X.checkFQHN = False }
es <- X.validate X.HashSHA256 X.defaultHooks checks cs def ("","") certs
case es of
[] -> pure T.CertificateUsageAccept
errs' -> pure (T.CertificateUsageReject (T.CertificateRejectOther
("Unacceptable client cert: " ++ show errs')))
-- Ciphers prefered by the server take precedence.
chooseCipher :: T.Version -> [T.Cipher] -> T.Cipher
chooseCipher _ cCiphs = case intersect TE.ciphersuite_strong cCiphs of
c : _ -> c
_ -> error "chooseCipher: no ciphers"
-- | Obtain new default 'T.ServerParams' for a particular server 'T.Credential'.
--
-- * Don't require credentials from clients.
--
-- * Use an in-memory TLS session manager from the
-- [tls-session-manager](https://hackage.haskell.org/package/tls-session-manager)
-- package.
--
-- * Everything else as proposed by 'makeServerParams'.
newDefaultServerParams
:: MonadIO m
=> T.Credential
-- ^ Server credential.
--
-- Can be loaded with 'credentialLoadX509' or similar functions.
-> m T.ServerParams
newDefaultServerParams cred = liftIO $ do
sm <- TSM.newSessionManager TSM.defaultConfig
let sp0 = makeServerParams cred Nothing
pure $ sp0
{ T.serverShared = (T.serverShared sp0)
{ T.sharedSessionManager = sm }
}
--------------------------------------------------------------------------------
-- | Start a TLS-secured TCP server that accepts incoming connections and
-- handles each of them concurrently, in different threads.
--
-- Any acquired network resources are properly closed and discarded when done or
-- in case of exceptions. This function binds a listening socket, accepts an
-- incoming connection, performs a TLS handshake and then safely closes the
-- connection when done or in case of exceptions. You don't need to perform any
-- of those steps manually.
serve
:: MonadIO m
=> T.ServerParams -- ^TLS settings.
-> S.HostPreference -- ^Preferred host to bind.
-> S.ServiceName -- ^Service port to bind.
-> ((T.Context, S.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.
-> m ()
serve ss hp port k = liftIO $ do
S.listen hp port $ \(lsock,_) -> do
forever $ acceptFork ss lsock k
--------------------------------------------------------------------------------
-- | Accepts a single incomming TLS-secured TCP connection and use it.
--
-- A TLS handshake is performed immediately after establishing the TCP
-- 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
:: (MonadIO m, E.MonadMask m)
=> T.ServerParams -- ^TLS settings.
-> S.Socket -- ^Listening and bound socket.
-> ((T.Context, S.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.
-> m r
accept ss lsock k = E.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
:: MonadIO m
=> T.ServerParams -- ^TLS settings.
-> S.Socket -- ^Listening and bound socket.
-> ((T.Context, S.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.
-> 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 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
:: (MonadIO m, E.MonadMask m)
=> T.ClientParams -- ^ TLS settings.
-> S.HostName -- ^ Server hostname.
-> S.ServiceName -- ^ Destination server service port name or number.
-> ((T.Context, S.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.
-> m r
connect cs host port k = E.bracket (connectTls cs host port)
(liftIO . T.contextClose . fst)
(useTls k)
-- | Like 'connect', but connects to the destination server over a SOCKS5 proxy.
connectOverSOCKS5
:: (MonadIO m, E.MonadMask m)
=> S.HostName -- ^ SOCKS5 proxy server hostname or IP address.
-> S.ServiceName -- ^ SOCKS5 proxy server service port name or number.
-> T.ClientParams -- ^ TLS settings.
-> S.HostName
-- ^ Destination server hostname or IP address. We connect to this host
-- /through/ the SOCKS5 proxy specified in the previous arguments.
--
-- Note that if hostname resolution on this 'S.HostName' is necessary, it
-- will happen on the proxy side for security reasons, not locally.
-> S.ServiceName -- ^ Destination server service port name or number.
-> ((T.Context, S.SockAddr, S.SockAddr) -> m r)
-- ^ Computation to run after establishing TLS-secured TCP connection to the
-- remote server. Takes the TLS connection that can be used to interact with
-- the destination server, as well as the address of the SOCKS5 server and the
-- address of the destination server, in that order.
-> m r
connectOverSOCKS5 phn psn cs dhn dsn k = do
E.bracket (connectTlsOverSOCKS5 phn psn cs dhn dsn)
(\(ctx, _, _) -> liftIO (T.contextClose ctx))
(\(ctx, paddr, daddr) ->
useTls (\_ -> k (ctx, paddr, daddr))
(ctx, paddr))
--------------------------------------------------------------------------------
-- | Estalbishes a TCP connection to a remote server and returns a TLS
-- 'T.Context' configured on top of it using the given 'T.ClientParams'.
-- The remote end address is also returned.
--
-- Prefer to use 'connect' if you will be using the obtained 'T.Context' within a
-- limited scope.
--
-- You need to perform a TLS handshake on the resulting 'T.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
=> T.ClientParams -- ^ TLS settings.
-> S.HostName -- ^ Server hostname.
-> S.ServiceName -- ^ Server service name or port number.
-> m (T.Context, S.SockAddr)
connectTls cs host port = liftIO $ do
E.bracketOnError
(S.connectSock host port)
(S.closeSock . fst)
(\(sock, addr) -> do
ctx <- makeClientContext cs sock
return (ctx, addr))
-- | Like 'connectTls', but connects to the destination server over a SOCKS5
-- proxy.
connectTlsOverSOCKS5
:: MonadIO m
=> S.HostName -- ^ SOCKS5 proxy server hostname or IP address.
-> S.ServiceName -- ^ SOCKS5 proxy server service port name or number.
-> T.ClientParams -- ^ TLS settings.
-> S.HostName
-- ^ Destination server hostname or IP address. We connect to this host
-- /through/ the SOCKS5 proxy specified in the previous arguments.
--
-- Note that if hostname resolution on this 'S.HostName' is necessary, it
-- will happen on the proxy side for security reasons, not locally.
-> S.ServiceName -- ^ Destination server service port name or number.
-> m (T.Context, S.SockAddr, S.SockAddr)
-- ^ Returns the 'T.Context' that can be used to interact with the destination
-- server, as well as the address of the SOCKS5 server and the address of the
-- destination server, in that order.
connectTlsOverSOCKS5 phn psn cs dhn dsn = liftIO $ do
E.bracketOnError
(S.connectSock phn psn)
(S.closeSock . fst)
(\(psock, paddr) -> do
daddr <- S.connectSockSOCKS5 psock dhn dsn
ctx <- makeClientContext cs psock
return (ctx, paddr, daddr))
-- | Make a client-side TLS 'T.Context' for the given settings, on top of the
-- given TCP `S.Socket` connected to the remote end.
makeClientContext :: MonadIO m => T.ClientParams -> S.Socket -> m T.Context
makeClientContext params sock = liftIO $ T.contextNew sock params
--------------------------------------------------------------------------------
-- | Accepts an incoming TCP connection and returns a TLS 'T.Context' configured
-- on top of it using the given 'T.ServerParams'. The remote end address is also
-- returned.
--
-- Prefer to use 'accept' if you will be using the obtained 'T.Context' within a
-- limited scope.
--
-- You need to perform a TLS handshake on the resulting 'T.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
=> T.ServerParams -- ^TLS settings.
-> S.Socket -- ^Listening and bound socket.
-> m (T.Context, S.SockAddr)
acceptTls sp lsock = liftIO $ do
E.bracketOnError
(NS.accept lsock)
(S.closeSock . fst)
(\(sock, addr) -> do
ctx <- makeServerContext sp sock
return (ctx, addr))
-- | Make a server-side TLS 'T.Context' for the given settings, on top of the
-- given TCP `S.Socket` connected to the remote end.
makeServerContext :: MonadIO m => T.ServerParams -> S.Socket -> m T.Context
makeServerContext params sock = liftIO $ T.contextNew sock params
--------------------------------------------------------------------------------
-- | Perform a TLS handshake on the given 'T.Context', then perform the
-- given action and at last gracefully close the TLS session using `T.bye`.
--
-- 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, E.MonadMask m)
=> ((T.Context, S.SockAddr) -> m a)
-> ((T.Context, S.SockAddr) -> m a)
useTls k conn@(ctx,_) = E.bracket_ (T.handshake ctx)
(liftIO $ silentBye ctx)
(k conn)
-- | Like 'useTls', except it also fully closes the TCP connection when done.
useTlsThenClose
:: (MonadIO m, E.MonadMask m)
=> ((T.Context, S.SockAddr) -> m a)
-> ((T.Context, S.SockAddr) -> m a)
useTlsThenClose k conn@(ctx,_) = do
useTls k conn `E.finally` liftIO (T.contextClose ctx)
-- | Similar to 'useTlsThenClose', except it performs the all the IO actions
-- in a new thread.
--
-- Use this instead of forking `useTlsThenClose` yourself, as that won't give
-- the right behavior.
useTlsThenCloseFork
:: MonadIO m
=> ((T.Context, S.SockAddr) -> IO ())
-> ((T.Context, S.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'
-- on EOF.
--
-- Up to @16384@ decrypted bytes will be received at once.
recv :: MonadIO m => T.Context -> m (Maybe B.ByteString)
recv ctx = liftIO $ do
bs <- T.recvData ctx
if B.null bs
then return Nothing
else return (Just bs)
{-# INLINABLE recv #-}
-- | Encrypts the given strict 'B.ByteString' and sends it through the
-- 'T.Context'.
send :: MonadIO m => T.Context -> B.ByteString -> m ()
send ctx = \bs -> T.sendData ctx (BL.fromStrict bs)
{-# INLINABLE send #-}
-- | Encrypts the given lazy 'BL.ByteString' and sends it through the
-- 'T.Context'.
sendLazy :: MonadIO m => T.Context -> BL.ByteString -> m ()
sendLazy = T.sendData
{-# INLINE sendLazy #-}
--------------------------------------------------------------------------------
-- | Try to create a new credential object from a public certificate and the
-- associated private key that are stored on the filesystem in PEM format.
credentialLoadX509
:: MonadIO m
=> FilePath -- ^ Public certificate (X.509 format).
-> FilePath -- ^ Private key associated with the certificate.
-> m (Either String T.Credential)
credentialLoadX509 cert key = liftIO $ T.credentialLoadX509 cert key
--------------------------------------------------------------------------------
-- Internal utils
-- | 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 :: T.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