{-# 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 :: forall (m :: * -> *). MonadIO m => ServiceID -> m ClientParams
newDefaultClientParams ServiceID
sid = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  CertificateStore
cs <- IO CertificateStore
getSystemCertificateStore
  SessionManager
sm <- Config -> IO SessionManager
TSM.newSessionManager Config
TSM.defaultConfig
  let cp0 :: ClientParams
cp0 = ServiceID -> [Credential] -> CertificateStore -> ClientParams
makeClientParams ServiceID
sid [] CertificateStore
cs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ClientParams
cp0
    { clientShared :: Shared
T.clientShared = (ClientParams -> Shared
T.clientShared ClientParams
cp0)
        { sharedSessionManager :: SessionManager
T.sharedSessionManager = SessionManager
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 :: ServiceID -> [Credential] -> CertificateStore -> ClientParams
makeClientParams ([Char]
hn, ByteString
sp) [Credential]
creds CertificateStore
cStore =
    ([Char] -> ByteString -> ClientParams
T.defaultParamsClient [Char]
hn ByteString
sp)
      { clientUseServerNameIndication :: Bool
T.clientUseServerNameIndication = Bool
True
      , clientSupported :: Supported
T.clientSupported = forall a. Default a => a
def
        { supportedVersions :: [Version]
T.supportedVersions = [Version
T.TLS13, Version
T.TLS12, Version
T.TLS11]
        , supportedCiphers :: [Cipher]
T.supportedCiphers = [Cipher]
TE.ciphersuite_default
        , supportedSecureRenegotiation :: Bool
T.supportedSecureRenegotiation = Bool
True
        , supportedClientInitiatedRenegotiation :: Bool
T.supportedClientInitiatedRenegotiation = Bool
True }
      , clientShared :: Shared
T.clientShared = forall a. Default a => a
def { sharedCAStore :: CertificateStore
T.sharedCAStore = CertificateStore
cStore }
      , clientHooks :: ClientHooks
T.clientHooks = forall a. Default a => a
def
        { onServerCertificate :: OnServerCertificate
T.onServerCertificate = OnServerCertificate
X.validateDefault
        , onCertificateRequest :: OnCertificateRequest
T.onCertificateRequest = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CertificateType], Maybe [HashAndSignatureAlgorithm],
 [DistinguishedName])
-> Maybe Credential
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 :: ([CertificateType], Maybe [HashAndSignatureAlgorithm],
 [DistinguishedName])
-> Maybe Credential
findCredential ([CertificateType]
_, Maybe [HashAndSignatureAlgorithm]
_, [DistinguishedName]
dns) = forall a. [a] -> Maybe a
listToMaybe (forall a. (a -> Bool) -> [a] -> [a]
filter forall {b}. (CertificateChain, b) -> Bool
isSubject [Credential]
creds)
      where
        isSubject :: (CertificateChain, b) -> Bool
isSubject (X.CertificateChain [SignedExact Certificate]
cc, b
_) =
          forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\SignedExact Certificate
c -> (Certificate -> DistinguishedName
X.certSubjectDN forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedExact Certificate -> Certificate
X.getCertificate) SignedExact Certificate
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DistinguishedName]
dns) [SignedExact Certificate]
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 :: Credential -> Maybe CertificateStore -> ServerParams
makeServerParams Credential
cred Maybe CertificateStore
ycStore = forall a. Default a => a
def
      { serverWantClientCert :: Bool
T.serverWantClientCert = forall a. Maybe a -> Bool
isJust Maybe CertificateStore
ycStore
      , serverShared :: Shared
T.serverShared = forall a. Default a => a
def
        { sharedCredentials :: Credentials
T.sharedCredentials = [Credential] -> Credentials
T.Credentials [Credential
cred] }
      , serverCACertificates :: [SignedExact Certificate]
T.serverCACertificates = []
      , serverSupported :: Supported
T.serverSupported = forall a. Default a => a
def
        { supportedVersions :: [Version]
T.supportedVersions = [Version
T.TLS13, Version
T.TLS12, Version
T.TLS11]
        , supportedCiphers :: [Cipher]
T.supportedCiphers = [Cipher]
TE.ciphersuite_strong
        , supportedSession :: Bool
T.supportedSession = Bool
True
        , supportedSecureRenegotiation :: Bool
T.supportedSecureRenegotiation = Bool
True
        , supportedClientInitiatedRenegotiation :: Bool
T.supportedClientInitiatedRenegotiation = Bool
False }
      , serverHooks :: ServerHooks
T.serverHooks = forall a. Default a => a
def
        { onClientCertificate :: CertificateChain -> IO CertificateUsage
T.onClientCertificate = CertificateChain -> IO CertificateUsage
clientCertsCheck
        , onCipherChoosing :: Version -> [Cipher] -> Cipher
T.onCipherChoosing = Version -> [Cipher] -> Cipher
chooseCipher }
      }
  where
    clientCertsCheck :: X.CertificateChain -> IO T.CertificateUsage
    clientCertsCheck :: CertificateChain -> IO CertificateUsage
clientCertsCheck CertificateChain
certs = case Maybe CertificateStore
ycStore of
      Maybe CertificateStore
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return CertificateUsage
T.CertificateUsageAccept
      Just CertificateStore
cs -> do
        let checks :: ValidationChecks
checks = ValidationChecks
X.defaultChecks { checkFQHN :: Bool
X.checkFQHN = Bool
False }
        [FailedReason]
es <- HashALG
-> ValidationHooks -> ValidationChecks -> OnServerCertificate
X.validate HashALG
X.HashSHA256 ValidationHooks
X.defaultHooks ValidationChecks
checks CertificateStore
cs forall a. Default a => a
def ([Char]
"",ByteString
"") CertificateChain
certs
        case [FailedReason]
es of
          [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CertificateUsage
T.CertificateUsageAccept
          [FailedReason]
errs' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (CertificateRejectReason -> CertificateUsage
T.CertificateUsageReject ([Char] -> CertificateRejectReason
T.CertificateRejectOther
                            ([Char]
"Unacceptable client cert: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [FailedReason]
errs')))
    -- Ciphers prefered by the server take precedence.
    chooseCipher :: T.Version -> [T.Cipher] -> T.Cipher
    chooseCipher :: Version -> [Cipher] -> Cipher
chooseCipher Version
_ [Cipher]
cCiphs = forall a. [a] -> a
head (forall a. Eq a => [a] -> [a] -> [a]
intersect [Cipher]
TE.ciphersuite_strong [Cipher]
cCiphs)

-- | 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 :: forall (m :: * -> *). MonadIO m => Credential -> m ServerParams
newDefaultServerParams Credential
cred = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  SessionManager
sm <- Config -> IO SessionManager
TSM.newSessionManager Config
TSM.defaultConfig
  let sp0 :: ServerParams
sp0 = Credential -> Maybe CertificateStore -> ServerParams
makeServerParams Credential
cred forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ServerParams
sp0
    { serverShared :: Shared
T.serverShared = (ServerParams -> Shared
T.serverShared ServerParams
sp0)
        { sharedSessionManager :: SessionManager
T.sharedSessionManager = SessionManager
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 :: forall (m :: * -> *).
MonadIO m =>
ServerParams
-> HostPreference
-> [Char]
-> ((Context, SockAddr) -> IO ())
-> m ()
serve ServerParams
ss HostPreference
hp [Char]
port (Context, SockAddr) -> IO ()
k = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) r.
(MonadIO m, MonadMask m) =>
HostPreference -> [Char] -> ((Socket, SockAddr) -> m r) -> m r
S.listen HostPreference
hp [Char]
port forall a b. (a -> b) -> a -> b
$ \(Socket
lsock,SockAddr
_) -> do
      forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
ServerParams
-> Socket -> ((Context, SockAddr) -> IO ()) -> m ThreadId
acceptFork ServerParams
ss Socket
lsock (Context, SockAddr) -> IO ()
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 :: forall (m :: * -> *) r.
(MonadIO m, MonadMask m) =>
ServerParams -> Socket -> ((Context, SockAddr) -> m r) -> m r
accept ServerParams
ss Socket
lsock (Context, SockAddr) -> m r
k = forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket (forall (m :: * -> *).
MonadIO m =>
ServerParams -> Socket -> m (Context, SockAddr)
acceptTls ServerParams
ss Socket
lsock)
                              (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> IO ()
T.contextClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                              (forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
((Context, SockAddr) -> m a) -> (Context, SockAddr) -> m a
useTls (Context, SockAddr) -> m r
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 :: forall (m :: * -> *).
MonadIO m =>
ServerParams
-> Socket -> ((Context, SockAddr) -> IO ()) -> m ThreadId
acceptFork ServerParams
ss Socket
lsock (Context, SockAddr) -> IO ()
k = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracketOnError (forall (m :: * -> *).
MonadIO m =>
ServerParams -> Socket -> m (Context, SockAddr)
acceptTls ServerParams
ss Socket
lsock)
                     (Context -> IO ()
T.contextClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                     (forall (m :: * -> *).
MonadIO m =>
((Context, SockAddr) -> IO ()) -> (Context, SockAddr) -> m ThreadId
useTlsThenCloseFork (Context, SockAddr) -> IO ()
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 :: forall (m :: * -> *) r.
(MonadIO m, MonadMask m) =>
ClientParams
-> [Char] -> [Char] -> ((Context, SockAddr) -> m r) -> m r
connect ClientParams
cs [Char]
host [Char]
port (Context, SockAddr) -> m r
k = forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket (forall (m :: * -> *).
MonadIO m =>
ClientParams -> [Char] -> [Char] -> m (Context, SockAddr)
connectTls ClientParams
cs [Char]
host [Char]
port)
                                   (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> IO ()
T.contextClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                                   (forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
((Context, SockAddr) -> m a) -> (Context, SockAddr) -> m a
useTls (Context, SockAddr) -> m r
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 :: forall (m :: * -> *) r.
(MonadIO m, MonadMask m) =>
[Char]
-> [Char]
-> ClientParams
-> [Char]
-> [Char]
-> ((Context, SockAddr, SockAddr) -> m r)
-> m r
connectOverSOCKS5 [Char]
phn [Char]
psn ClientParams
cs [Char]
dhn [Char]
dsn (Context, SockAddr, SockAddr) -> m r
k = do
  forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket (forall (m :: * -> *).
MonadIO m =>
[Char]
-> [Char]
-> ClientParams
-> [Char]
-> [Char]
-> m (Context, SockAddr, SockAddr)
connectTlsOverSOCKS5 [Char]
phn [Char]
psn ClientParams
cs [Char]
dhn [Char]
dsn)
            (\(Context
ctx, SockAddr
_, SockAddr
_) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Context -> IO ()
T.contextClose Context
ctx))
            (\(Context
ctx, SockAddr
paddr, SockAddr
daddr) ->
                forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
((Context, SockAddr) -> m a) -> (Context, SockAddr) -> m a
useTls (\(Context, SockAddr)
_ -> (Context, SockAddr, SockAddr) -> m r
k (Context
ctx, SockAddr
paddr, SockAddr
daddr))
                       (Context
ctx, SockAddr
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 :: forall (m :: * -> *).
MonadIO m =>
ClientParams -> [Char] -> [Char] -> m (Context, SockAddr)
connectTls ClientParams
cs [Char]
host [Char]
port = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracketOnError
        (forall (m :: * -> *).
MonadIO m =>
[Char] -> [Char] -> m (Socket, SockAddr)
S.connectSock [Char]
host [Char]
port)
        (forall (m :: * -> *). MonadIO m => Socket -> m ()
S.closeSock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
        (\(Socket
sock, SockAddr
addr) -> do
             Context
ctx <- forall (m :: * -> *).
MonadIO m =>
ClientParams -> Socket -> m Context
makeClientContext ClientParams
cs Socket
sock
             forall (m :: * -> *) a. Monad m => a -> m a
return (Context
ctx, SockAddr
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 :: forall (m :: * -> *).
MonadIO m =>
[Char]
-> [Char]
-> ClientParams
-> [Char]
-> [Char]
-> m (Context, SockAddr, SockAddr)
connectTlsOverSOCKS5 [Char]
phn [Char]
psn ClientParams
cs [Char]
dhn [Char]
dsn = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracketOnError
     (forall (m :: * -> *).
MonadIO m =>
[Char] -> [Char] -> m (Socket, SockAddr)
S.connectSock [Char]
phn [Char]
psn)
     (forall (m :: * -> *). MonadIO m => Socket -> m ()
S.closeSock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
     (\(Socket
psock, SockAddr
paddr) -> do
          SockAddr
daddr <- forall (m :: * -> *).
MonadIO m =>
Socket -> [Char] -> [Char] -> m SockAddr
S.connectSockSOCKS5 Socket
psock [Char]
dhn [Char]
dsn
          Context
ctx <- forall (m :: * -> *).
MonadIO m =>
ClientParams -> Socket -> m Context
makeClientContext ClientParams
cs Socket
psock
          forall (m :: * -> *) a. Monad m => a -> m a
return (Context
ctx, SockAddr
paddr, SockAddr
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 :: forall (m :: * -> *).
MonadIO m =>
ClientParams -> Socket -> m Context
makeClientContext ClientParams
params Socket
sock = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
T.contextNew Socket
sock ClientParams
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 :: forall (m :: * -> *).
MonadIO m =>
ServerParams -> Socket -> m (Context, SockAddr)
acceptTls ServerParams
sp Socket
lsock = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracketOnError
        (Socket -> IO (Socket, SockAddr)
NS.accept Socket
lsock)
        (forall (m :: * -> *). MonadIO m => Socket -> m ()
S.closeSock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
        (\(Socket
sock, SockAddr
addr) -> do
             Context
ctx <- forall (m :: * -> *).
MonadIO m =>
ServerParams -> Socket -> m Context
makeServerContext ServerParams
sp Socket
sock
             forall (m :: * -> *) a. Monad m => a -> m a
return (Context
ctx, SockAddr
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 :: forall (m :: * -> *).
MonadIO m =>
ServerParams -> Socket -> m Context
makeServerContext ServerParams
params Socket
sock = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
T.contextNew Socket
sock ServerParams
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 :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
((Context, SockAddr) -> m a) -> (Context, SockAddr) -> m a
useTls (Context, SockAddr) -> m a
k conn :: (Context, SockAddr)
conn@(Context
ctx,SockAddr
_) = forall (m :: * -> *) a b c. MonadMask m => m a -> m b -> m c -> m c
E.bracket_ (forall (m :: * -> *). MonadIO m => Context -> m ()
T.handshake Context
ctx)
                                   (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Context -> IO ()
silentBye Context
ctx)
                                   ((Context, SockAddr) -> m a
k (Context, SockAddr)
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 :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
((Context, SockAddr) -> m a) -> (Context, SockAddr) -> m a
useTlsThenClose (Context, SockAddr) -> m a
k conn :: (Context, SockAddr)
conn@(Context
ctx,SockAddr
_) = do
    forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
((Context, SockAddr) -> m a) -> (Context, SockAddr) -> m a
useTls (Context, SockAddr) -> m a
k (Context, SockAddr)
conn forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`E.finally` forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Context -> IO ()
T.contextClose Context
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 :: forall (m :: * -> *).
MonadIO m =>
((Context, SockAddr) -> IO ()) -> (Context, SockAddr) -> m ThreadId
useTlsThenCloseFork (Context, SockAddr) -> IO ()
k conn :: (Context, SockAddr)
conn@(Context
ctx,SockAddr
_) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (forall (m :: * -> *) a b c. MonadMask m => m a -> m b -> m c -> m c
E.bracket_ (forall (m :: * -> *). MonadIO m => Context -> m ()
T.handshake Context
ctx) (Context -> IO ()
silentBye Context
ctx) ((Context, SockAddr) -> IO ()
k (Context, SockAddr)
conn))
                (\Either SomeException ()
eu -> Context -> IO ()
T.contextClose Context
ctx forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
E.throwIO forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException ()
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 :: forall (m :: * -> *). MonadIO m => Context -> m (Maybe ByteString)
recv Context
ctx = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
E.handle (\case TLSError
T.Error_EOF -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                    TLSError
e -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
E.throwM TLSError
e)
             (do ByteString
bs <- forall (m :: * -> *). MonadIO m => Context -> m ByteString
T.recvData Context
ctx
                 if ByteString -> Bool
B.null ByteString
bs
                    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing -- I think this never happens
                    else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ByteString
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 :: forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
send Context
ctx = \ByteString
bs -> forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
T.sendData Context
ctx (ByteString -> ByteString
BL.fromStrict ByteString
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 :: forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
sendLazy = forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
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 :: forall (m :: * -> *).
MonadIO m =>
[Char] -> [Char] -> m (Either [Char] Credential)
credentialLoadX509 [Char]
cert [Char]
key = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO (Either [Char] Credential)
T.credentialLoadX509 [Char]
cert [Char]
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 :: Context -> IO ()
silentBye Context
ctx = do
    forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch (forall (m :: * -> *). MonadIO m => Context -> m ()
T.bye Context
ctx) forall a b. (a -> b) -> a -> b
$ \IOException
e -> case IOException
e of
        Eg.IOError{ ioe_type :: IOException -> IOErrorType
Eg.ioe_type  = IOErrorType
Eg.ResourceVanished
                  , ioe_errno :: IOException -> Maybe CInt
Eg.ioe_errno = Just CInt
ioe
                  } | CInt -> Errno
Errno CInt
ioe forall a. Eq a => a -> a -> Bool
== Errno
ePIPE
          -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        IOException
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
E.throwIO IOException
e