    {-# Language BlockArguments, LambdaCase #-}
    {-|
    Module      : Hookup
    Description : Network connections generalized over TLS and SOCKS
    Copyright   : (c) Eric Mertens, 2016
    License     : ISC
    Maintainer  : emertens@gmail.com

    This module provides a uniform interface to network connections
    with optional support for TLS and SOCKS.

    This library is careful to support both IPv4 and IPv6. It will attempt to
    all of the addresses that a domain name resolves to until one the first
    successful connection.

    Use 'connect' and 'close' to establish and close network connections.

    Use 'recv', 'recvLine', and 'send' to receive and transmit data on an
    open network connection.

    TLS and SOCKS parameters can be provided. When both are provided a connection
    will first be established to the SOCKS server and then the TLS connection will
    be established through that proxy server. This is most useful when connecting
    through a dynamic port forward of an SSH client via the @-D@ flag.

    -}
    module Hookup
      (
      -- * Connections
      Connection,
      connect,
      connectWithSocket,
      close,
      upgradeTls,

      -- * Reading and writing data
      recv,
      recvLine,
      send,
      putBuf,

      -- * Configuration
      ConnectionParams(..),
      SocksParams(..),
      SocksAuthentication(..),
      TlsParams(..),
      TlsVerify(..),
      PEM.PemPasswordSupply(..),
      defaultTlsParams,

      -- * Errors
      ConnectionFailure(..),
      CommandReply(..)

      -- * SSL Information
      , getClientCertificate
      , getPeerCertificate
      , getPeerCertFingerprintSha1
      , getPeerCertFingerprintSha256
      , getPeerCertFingerprintSha512
      , getPeerPubkeyFingerprintSha1
      , getPeerPubkeyFingerprintSha256
      , getPeerPubkeyFingerprintSha512
      ) where

    import           Control.Concurrent
    import           Control.Exception
    import           Control.Monad (when, unless)
    import           System.IO.Error (isDoesNotExistError, ioeGetErrorString)
    import           Data.ByteString (ByteString)
    import qualified Data.ByteString as B
    import qualified Data.ByteString.Char8 as B8
    import           Data.Foldable (for_, traverse_)
    import           Data.List (intercalate, partition)
    import           Data.Maybe (fromMaybe, mapMaybe)
    import           Foreign.C.String (withCStringLen)
    import           Foreign.Ptr (nullPtr)
    import           Network.Socket (AddrInfo, HostName, PortNumber, SockAddr, Socket, Family)
    import qualified Network.Socket as Socket
    import qualified Network.Socket.ByteString as SocketB
    import           OpenSSL.Session (SSL, SSLContext)
    import qualified OpenSSL as SSL
    import qualified OpenSSL.Session as SSL
    import           OpenSSL.X509.SystemStore (contextLoadSystemCerts)
    import           OpenSSL.X509 (X509)
    import qualified OpenSSL.X509 as X509
    import qualified OpenSSL.PEM as PEM
    import qualified OpenSSL.EVP.Digest as Digest
    import           Data.Attoparsec.ByteString (Parser)
    import qualified Data.Attoparsec.ByteString as Parser

    import           Hookup.Concurrent (concurrentAttempts)
    import           Hookup.OpenSSL
    import           Hookup.Socks5

    -- | Parameters for 'connect'.
    --
    -- Common defaults for fields: 'defaultFamily', 'defaultTlsParams'
    --
    -- When a 'SocksParams' is provided the connection will be established
    -- using a SOCKS (version 5) proxy.
    --
    -- When a 'TlsParams' is provided the connection negotiate TLS at connect
    -- time in order to protect the stream.
    --
    -- The binding hostname can be used to force the connect to use a particular
    -- interface or IP protocol version.
    data ConnectionParams = ConnectionParams
      { ConnectionParams -> HostName
    cpHost  :: HostName          -- ^ Destination host
      , ConnectionParams -> PortNumber
    cpPort  :: PortNumber        -- ^ Destination TCP port
      , ConnectionParams -> Maybe SocksParams
    cpSocks :: Maybe SocksParams -- ^ Optional SOCKS parameters
      , ConnectionParams -> Maybe TlsParams
    cpTls   :: Maybe TlsParams   -- ^ Optional TLS parameters
      , ConnectionParams -> Maybe HostName
    cpBind  :: Maybe HostName    -- ^ Source address to bind
      }
      deriving Int -> ConnectionParams -> ShowS
    [ConnectionParams] -> ShowS
    ConnectionParams -> HostName
    (Int -> ConnectionParams -> ShowS)
    -> (ConnectionParams -> HostName)
    -> ([ConnectionParams] -> ShowS)
    -> Show ConnectionParams
    forall a.
    (Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> ConnectionParams -> ShowS
    showsPrec :: Int -> ConnectionParams -> ShowS
    $cshow :: ConnectionParams -> HostName
    show :: ConnectionParams -> HostName
    $cshowList :: [ConnectionParams] -> ShowS
    showList :: [ConnectionParams] -> ShowS
    Show

    -- | SOCKS connection parameters
    data SocksParams = SocksParams
      { SocksParams -> HostName
    spHost :: HostName   -- ^ SOCKS server host
      , SocksParams -> PortNumber
    spPort :: PortNumber -- ^ SOCKS server port
      , SocksParams -> SocksAuthentication
    spAuth :: SocksAuthentication -- ^ SOCKS authentication method
      }
      deriving Int -> SocksParams -> ShowS
    [SocksParams] -> ShowS
    SocksParams -> HostName
    (Int -> SocksParams -> ShowS)
    -> (SocksParams -> HostName)
    -> ([SocksParams] -> ShowS)
    -> Show SocksParams
    forall a.
    (Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> SocksParams -> ShowS
    showsPrec :: Int -> SocksParams -> ShowS
    $cshow :: SocksParams -> HostName
    show :: SocksParams -> HostName
    $cshowList :: [SocksParams] -> ShowS
    showList :: [SocksParams] -> ShowS
    Show

    data SocksAuthentication
      = NoSocksAuthentication -- ^ no credentials
      | UsernamePasswordSocksAuthentication ByteString ByteString -- ^ RFC 1929 username and password
      deriving Int -> SocksAuthentication -> ShowS
    [SocksAuthentication] -> ShowS
    SocksAuthentication -> HostName
    (Int -> SocksAuthentication -> ShowS)
    -> (SocksAuthentication -> HostName)
    -> ([SocksAuthentication] -> ShowS)
    -> Show SocksAuthentication
    forall a.
    (Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> SocksAuthentication -> ShowS
    showsPrec :: Int -> SocksAuthentication -> ShowS
    $cshow :: SocksAuthentication -> HostName
    show :: SocksAuthentication -> HostName
    $cshowList :: [SocksAuthentication] -> ShowS
    showList :: [SocksAuthentication] -> ShowS
    Show

    -- | TLS connection parameters. These parameters are passed to
    -- OpenSSL when making a secure connection.
    data TlsParams = TlsParams
      { TlsParams -> Maybe HostName
    tpClientCertificate  :: Maybe FilePath -- ^ Path to client certificate
      , TlsParams -> Maybe HostName
    tpClientPrivateKey   :: Maybe FilePath -- ^ Path to client private key
      , TlsParams -> Maybe ByteString
    tpClientPrivateKeyPassword :: Maybe ByteString -- ^ Private key decryption password
      , TlsParams -> Maybe HostName
    tpServerCertificate  :: Maybe FilePath -- ^ Path to CA certificate bundle
      , TlsParams -> HostName
    tpCipherSuite        :: String -- ^ OpenSSL cipher suite name (e.g. @\"HIGH\"@)
      , TlsParams -> Maybe HostName
    tpCipherSuiteTls13   :: Maybe String -- ^ OpenSSL cipher suites for TLS 1.3
      , TlsParams -> TlsVerify
    tpVerify             :: TlsVerify -- ^ Hostname to use when checking certificate validity
      }
      deriving Int -> TlsParams -> ShowS
    [TlsParams] -> ShowS
    TlsParams -> HostName
    (Int -> TlsParams -> ShowS)
    -> (TlsParams -> HostName)
    -> ([TlsParams] -> ShowS)
    -> Show TlsParams
    forall a.
    (Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> TlsParams -> ShowS
    showsPrec :: Int -> TlsParams -> ShowS
    $cshow :: TlsParams -> HostName
    show :: TlsParams -> HostName
    $cshowList :: [TlsParams] -> ShowS
    showList :: [TlsParams] -> ShowS
    Show

    data TlsVerify
      = VerifyDefault -- ^ Use the connection hostname to verify
      | VerifyNone -- ^ No verification
      | VerifyHostname String -- ^ Use the given hostname to verify
      deriving Int -> TlsVerify -> ShowS
    [TlsVerify] -> ShowS
    TlsVerify -> HostName
    (Int -> TlsVerify -> ShowS)
    -> (TlsVerify -> HostName)
    -> ([TlsVerify] -> ShowS)
    -> Show TlsVerify
    forall a.
    (Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> TlsVerify -> ShowS
    showsPrec :: Int -> TlsVerify -> ShowS
    $cshow :: TlsVerify -> HostName
    show :: TlsVerify -> HostName
    $cshowList :: [TlsVerify] -> ShowS
    showList :: [TlsVerify] -> ShowS
    Show

    -- | Type for errors that can be thrown by this package.
    data ConnectionFailure
      -- | Failure during 'getAddrInfo' resolving remote host
      = HostnameResolutionFailure HostName String
      -- | Failure during 'connect' to remote host
      | ConnectionFailure [ConnectError]
      -- | Failure during 'recvLine'
      | LineTooLong
      -- | Incomplete line during 'recvLine'
      | LineTruncated
      -- | Socks command rejected by server by given reply code
      | SocksError CommandReply
      -- | Socks authentication method was not accepted
      | SocksAuthenticationMethodRejected
      -- | Socks authentication method was not accepted
      | SocksAuthenticationCredentialsRejected
      -- | Username or password were too long
      | SocksBadAuthenticationCredentials
      -- | Socks server sent an invalid message or no message.
      | SocksProtocolError
      -- | Domain name was too long for SOCKS protocol
      | SocksBadDomainName
      deriving Int -> ConnectionFailure -> ShowS
    [ConnectionFailure] -> ShowS
    ConnectionFailure -> HostName
    (Int -> ConnectionFailure -> ShowS)
    -> (ConnectionFailure -> HostName)
    -> ([ConnectionFailure] -> ShowS)
    -> Show ConnectionFailure
    forall a.
    (Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> ConnectionFailure -> ShowS
    showsPrec :: Int -> ConnectionFailure -> ShowS
    $cshow :: ConnectionFailure -> HostName
    show :: ConnectionFailure -> HostName
    $cshowList :: [ConnectionFailure] -> ShowS
    showList :: [ConnectionFailure] -> ShowS
    Show

    -- | 'displayException' implemented for prettier messages
    instance Exception ConnectionFailure where
      displayException :: ConnectionFailure -> HostName
    displayException ConnectionFailure
    LineTruncated = HostName
    "connection closed while reading line"
      displayException ConnectionFailure
    LineTooLong   = HostName
    "line length exceeded maximum"
      displayException (ConnectionFailure [ConnectError]
    xs) =
        HostName
    "connection attempt failed due to: " HostName -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
          HostName -> [HostName] -> HostName
    forall a. [a] -> [[a]] -> [a]
    intercalate HostName
    ", " ((ConnectError -> HostName) -> [ConnectError] -> [HostName]
    forall a b. (a -> b) -> [a] -> [b]
    map ConnectError -> HostName
    forall e. Exception e => e -> HostName
    displayException [ConnectError]
    xs)
      displayException (HostnameResolutionFailure HostName
    h HostName
    s) =
        HostName
    "hostname resolution failed (" HostName -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ HostName
    h HostName -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ HostName
    "): "  HostName -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ HostName
    s
      displayException ConnectionFailure
    SocksAuthenticationMethodRejected =
        HostName
    "SOCKS authentication method rejected"
      displayException ConnectionFailure
    SocksAuthenticationCredentialsRejected =
        HostName
    "SOCKS authentication credentials rejected"
      displayException ConnectionFailure
    SocksBadAuthenticationCredentials =
        HostName
    "SOCKS authentication credentials too long"
      displayException ConnectionFailure
    SocksProtocolError =
        HostName
    "SOCKS server protocol error"
      displayException ConnectionFailure
    SocksBadDomainName =
        HostName
    "SOCKS domain name length limit exceeded"
      displayException (SocksError CommandReply
    reply) =
        HostName
    "SOCKS command rejected: " HostName -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
        case CommandReply
    reply of
          CommandReply
    Succeeded         -> HostName
    "succeeded"
          CommandReply
    GeneralFailure    -> HostName
    "general SOCKS server failure"
          CommandReply
    NotAllowed        -> HostName
    "connection not allowed by ruleset"
          CommandReply
    NetUnreachable    -> HostName
    "network unreachable"
          CommandReply
    HostUnreachable   -> HostName
    "host unreachable"
          CommandReply
    ConnectionRefused -> HostName
    "connection refused"
          CommandReply
    TTLExpired        -> HostName
    "TTL expired"
          CommandReply
    CmdNotSupported   -> HostName
    "command not supported"
          CommandReply
    AddrNotSupported  -> HostName
    "address type not supported"
          CommandReply Word8
    n    -> HostName
    "unknown reply " HostName -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Word8 -> HostName
    forall a. Show a => a -> HostName
    show Word8
    n

    data ConnectError = ConnectError SockAddr IOError
      deriving Int -> ConnectError -> ShowS
    [ConnectError] -> ShowS
    ConnectError -> HostName
    (Int -> ConnectError -> ShowS)
    -> (ConnectError -> HostName)
    -> ([ConnectError] -> ShowS)
    -> Show ConnectError
    forall a.
    (Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> ConnectError -> ShowS
    showsPrec :: Int -> ConnectError -> ShowS
    $cshow :: ConnectError -> HostName
    show :: ConnectError -> HostName
    $cshowList :: [ConnectError] -> ShowS
    showList :: [ConnectError] -> ShowS
    Show

    instance Exception ConnectError where
      displayException :: ConnectError -> HostName
    displayException (ConnectError SockAddr
    addr IOError
    e) = SockAddr -> HostName
    forall a. Show a => a -> HostName
    show SockAddr
    addr HostName -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ HostName
    ": " HostName -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ IOError -> HostName
    forall e. Exception e => e -> HostName
    displayException IOError
    e

    -- | Default values for TLS that use no client certificates, use
    -- system CA root, @\"HIGH\"@ cipher suite, and which validate hostnames.
    defaultTlsParams :: TlsParams
    defaultTlsParams :: TlsParams
    defaultTlsParams = TlsParams
      { tpClientCertificate :: Maybe HostName
    tpClientCertificate  = Maybe HostName
    forall a. Maybe a
    Nothing
      , tpClientPrivateKey :: Maybe HostName
    tpClientPrivateKey   = Maybe HostName
    forall a. Maybe a
    Nothing
      , tpClientPrivateKeyPassword :: Maybe ByteString
    tpClientPrivateKeyPassword = Maybe ByteString
    forall a. Maybe a
    Nothing
      , tpServerCertificate :: Maybe HostName
    tpServerCertificate  = Maybe HostName
    forall a. Maybe a
    Nothing -- use system provided CAs
      , tpCipherSuite :: HostName
    tpCipherSuite        = HostName
    "HIGH"
      , tpCipherSuiteTls13 :: Maybe HostName
    tpCipherSuiteTls13   = Maybe HostName
    forall a. Maybe a
    Nothing
      , tpVerify :: TlsVerify
    tpVerify             = TlsVerify
    VerifyDefault
      }

    ------------------------------------------------------------------------
    -- Opening sockets
    ------------------------------------------------------------------------

    -- | Open a socket using the given parameters either directly or
    -- via a SOCKS server.
    openSocket :: ConnectionParams -> IO Socket
    openSocket :: ConnectionParams -> IO Socket
    openSocket ConnectionParams
    params =
      case ConnectionParams -> Maybe SocksParams
    cpSocks ConnectionParams
    params of
        Maybe SocksParams
    Nothing -> HostName -> PortNumber -> Maybe HostName -> IO Socket
    openSocket' (ConnectionParams -> HostName
    cpHost ConnectionParams
    params) (ConnectionParams -> PortNumber
    cpPort ConnectionParams
    params) (ConnectionParams -> Maybe HostName
    cpBind ConnectionParams
    params)
        Just SocksParams
    sp ->
          IO Socket
    -> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracketOnError
            (HostName -> PortNumber -> Maybe HostName -> IO Socket
    openSocket' (SocksParams -> HostName
    spHost SocksParams
    sp) (SocksParams -> PortNumber
    spPort SocksParams
    sp) (ConnectionParams -> Maybe HostName
    cpBind ConnectionParams
    params))
            Socket -> IO ()
    Socket.close
            \Socket
    sock ->
              Socket
    sock Socket -> IO () -> IO Socket
    forall a b. a -> IO b -> IO a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ Socket -> HostName -> PortNumber -> SocksAuthentication -> IO ()
    socksConnect Socket
    sock (ConnectionParams -> HostName
    cpHost ConnectionParams
    params) (ConnectionParams -> PortNumber
    cpPort ConnectionParams
    params) (SocksParams -> SocksAuthentication
    spAuth SocksParams
    sp)

    netParse :: Show a => Socket -> Parser a -> IO a
    netParse :: forall a. Show a => Socket -> Parser a -> IO a
    netParse Socket
    sock Parser a
    parser =
      do -- receiving 1 byte at a time is not efficient, but these messages
         -- are very short and we don't want to read any more from the socket
         -- than is necessary
         result <- IO ByteString -> Parser a -> ByteString -> IO (Result a)
    forall (m :: * -> *) a.
    Monad m =>
    m ByteString -> Parser a -> ByteString -> m (Result a)
    Parser.parseWith
                     (Socket -> Int -> IO ByteString
    SocketB.recv Socket
    sock Int
    1)
                     Parser a
    parser
                     ByteString
    B.empty
         case result of
           Parser.Done ByteString
    i a
    x | ByteString -> Bool
    B.null ByteString
    i -> a -> IO a
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    x
           Result a
    _ -> ConnectionFailure -> IO a
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO ConnectionFailure
    SocksProtocolError

    socksConnect :: Socket -> HostName -> PortNumber -> SocksAuthentication -> IO ()
    socksConnect :: Socket -> HostName -> PortNumber -> SocksAuthentication -> IO ()
    socksConnect Socket
    sock HostName
    host PortNumber
    port SocksAuthentication
    auth =
     do case SocksAuthentication
    auth of
          SocksAuthentication
    NoSocksAuthentication ->
           do Socket -> ByteString -> IO ()
    SocketB.sendAll Socket
    sock (ByteString -> IO ()) -> ByteString -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                ClientHello -> ByteString
    buildClientHello ClientHello
                  { cHelloMethods :: [AuthMethod]
    cHelloMethods = [AuthMethod
    AuthNoAuthenticationRequired] }
              hello <- Socket -> Parser ServerHello -> IO ServerHello
    forall a. Show a => Socket -> Parser a -> IO a
    netParse Socket
    sock Parser ServerHello
    parseServerHello
              unless (sHelloMethod hello == AuthNoAuthenticationRequired)
                (throwIO SocksAuthenticationMethodRejected)

          UsernamePasswordSocksAuthentication ByteString
    u ByteString
    p ->
           do Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (ByteString -> Int
    B.length ByteString
    u Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    256 Bool -> Bool -> Bool
    && ByteString -> Int
    B.length ByteString
    p Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    256)
                (ConnectionFailure -> IO ()
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO ConnectionFailure
    SocksBadAuthenticationCredentials)

              Socket -> ByteString -> IO ()
    SocketB.sendAll Socket
    sock (ByteString -> IO ()) -> ByteString -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                ClientHello -> ByteString
    buildClientHello ClientHello
                  { cHelloMethods :: [AuthMethod]
    cHelloMethods = [AuthMethod
    AuthUsernamePassword] }
              hello <- Socket -> Parser ServerHello -> IO ServerHello
    forall a. Show a => Socket -> Parser a -> IO a
    netParse Socket
    sock Parser ServerHello
    parseServerHello
              unless (sHelloMethod hello == AuthUsernamePassword)
                (throwIO SocksAuthenticationMethodRejected)

              SocketB.sendAll sock $
                buildPlainAuthentication PlainAuthentication
                  { plainUsername = u, plainPassword = p }
              status <- netParse sock parsePlainAuthenticationReply
              unless (0 == plainStatus status)
                (throwIO SocksAuthenticationCredentialsRejected)

        let dnBytes :: ByteString
    dnBytes = HostName -> ByteString
    B8.pack HostName
    host
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (ByteString -> Int
    B.length ByteString
    dnBytes Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    256)
          (ConnectionFailure -> IO ()
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO ConnectionFailure
    SocksBadDomainName)

        Socket -> ByteString -> IO ()
    SocketB.sendAll Socket
    sock (ByteString -> IO ()) -> ByteString -> IO ()
    forall a b. (a -> b) -> a -> b
    $
          Request -> ByteString
    buildRequest Request
            { reqCommand :: Command
    reqCommand  = Command
    Connect
            , reqAddress :: Address
    reqAddress  = Host -> PortNumber -> Address
    Address (ByteString -> Host
    DomainName ByteString
    dnBytes) PortNumber
    port
            }

        response <- Socket -> Parser Response -> IO Response
    forall a. Show a => Socket -> Parser a -> IO a
    netParse Socket
    sock Parser Response
    parseResponse
        unless (rspReply response == Succeeded )
          (throwIO (SocksError (rspReply response)))

    openSocket' ::
      HostName       {- ^ destination      -} ->
      PortNumber     {- ^ destination port -} ->
      Maybe HostName {- ^ source           -} ->
      IO Socket      {- ^ connected socket -}
    openSocket' :: HostName -> PortNumber -> Maybe HostName -> IO Socket
    openSocket' HostName
    h PortNumber
    p Maybe HostName
    mbBind =
      do mbSrc <- (HostName -> IO [AddrInfo])
    -> Maybe HostName -> IO (Maybe [AddrInfo])
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Maybe a -> f (Maybe b)
    traverse (Maybe PortNumber -> HostName -> IO [AddrInfo]
    resolve Maybe PortNumber
    forall a. Maybe a
    Nothing) Maybe HostName
    mbBind
         dst   <- resolve (Just p) h
         let pairs = [(Maybe SockAddr, AddrInfo)] -> [(Maybe SockAddr, AddrInfo)]
    interleaveAddressFamilies (Maybe [AddrInfo] -> [AddrInfo] -> [(Maybe SockAddr, AddrInfo)]
    matchBindAddrs Maybe [AddrInfo]
    mbSrc [AddrInfo]
    dst)
         when (null pairs)
           (throwIO (HostnameResolutionFailure h "No source/destination address family match"))
         res <- concurrentAttempts connAttemptDelay Socket.close (uncurry connectToAddrInfo <$> pairs)
         case res of
           Left [SomeException]
    es -> ConnectionFailure -> IO Socket
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO ([ConnectError] -> ConnectionFailure
    ConnectionFailure ((SomeException -> Maybe ConnectError)
    -> [SomeException] -> [ConnectError]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe SomeException -> Maybe ConnectError
    forall e. Exception e => SomeException -> Maybe e
    fromException [SomeException]
    es))
           Right Socket
    s -> Socket -> IO Socket
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Socket
    s

    hints :: AddrInfo
    hints :: AddrInfo
    hints = AddrInfo
    Socket.defaultHints
      { Socket.addrSocketType = Socket.Stream
      , Socket.addrFlags      = [Socket.AI_NUMERICSERV]
      }

    resolve :: Maybe PortNumber -> HostName -> IO [AddrInfo]
    resolve :: Maybe PortNumber -> HostName -> IO [AddrInfo]
    resolve Maybe PortNumber
    mbPort HostName
    host =
      do res <- IO [AddrInfo] -> IO (Either IOError [AddrInfo])
    forall e a. Exception e => IO a -> IO (Either e a)
    try (Maybe AddrInfo -> Maybe HostName -> Maybe HostName -> IO [AddrInfo]
    forall (t :: * -> *).
    GetAddrInfo t =>
    Maybe AddrInfo
    -> Maybe HostName -> Maybe HostName -> IO (t AddrInfo)
    Socket.getAddrInfo (AddrInfo -> Maybe AddrInfo
    forall a. a -> Maybe a
    Just AddrInfo
    hints) (HostName -> Maybe HostName
    forall a. a -> Maybe a
    Just HostName
    host) (PortNumber -> HostName
    forall a. Show a => a -> HostName
    show(PortNumber -> HostName) -> Maybe PortNumber -> Maybe HostName
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$>Maybe PortNumber
    mbPort))
         case res of
           Right [AddrInfo]
    ais -> [AddrInfo] -> IO [AddrInfo]
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure [AddrInfo]
    ais
           Left IOError
    ioe
             | IOError -> Bool
    isDoesNotExistError IOError
    ioe ->
                 ConnectionFailure -> IO [AddrInfo]
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (HostName -> HostName -> ConnectionFailure
    HostnameResolutionFailure HostName
    host (IOError -> HostName
    ioeGetErrorString IOError
    ioe))
             | Bool
    otherwise -> IOError -> IO [AddrInfo]
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO IOError
    ioe -- unexpected

    -- | When no bind address is specified return the full list of destination
    -- addresses with no bind address specified.
    --
    -- When bind addresses are specified return a subset of the destination list
    -- matched up with the first address from the bind list that has the
    -- correct address family.
    matchBindAddrs :: Maybe [AddrInfo] -> [AddrInfo] -> [(Maybe SockAddr, AddrInfo)]
    matchBindAddrs :: Maybe [AddrInfo] -> [AddrInfo] -> [(Maybe SockAddr, AddrInfo)]
    matchBindAddrs Maybe [AddrInfo]
    Nothing    [AddrInfo]
    dst = [ (Maybe SockAddr
    forall a. Maybe a
    Nothing, AddrInfo
    x) | AddrInfo
    x <- [AddrInfo]
    dst ]
    matchBindAddrs (Just [AddrInfo]
    src) [AddrInfo]
    dst =
      [ (SockAddr -> Maybe SockAddr
    forall a. a -> Maybe a
    Just (AddrInfo -> SockAddr
    Socket.addrAddress AddrInfo
    s), AddrInfo
    d)
      | AddrInfo
    d <- [AddrInfo]
    dst
      , let ss :: [AddrInfo]
    ss = [AddrInfo
    s | AddrInfo
    s <- [AddrInfo]
    src, AddrInfo -> Family
    Socket.addrFamily AddrInfo
    d Family -> Family -> Bool
    forall a. Eq a => a -> a -> Bool
    == AddrInfo -> Family
    Socket.addrFamily AddrInfo
    s]
      , AddrInfo
    s <- Int -> [AddrInfo] -> [AddrInfo]
    forall a. Int -> [a] -> [a]
    take Int
    1 [AddrInfo]
    ss ]

    connAttemptDelay :: Int
    connAttemptDelay :: Int
    connAttemptDelay = Int
    150 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    1000 -- 150ms

    -- | Alternate list of addresses between IPv6 and other (IPv4) addresses.
    interleaveAddressFamilies :: [(Maybe SockAddr, AddrInfo)] -> [(Maybe SockAddr, AddrInfo)]
    interleaveAddressFamilies :: [(Maybe SockAddr, AddrInfo)] -> [(Maybe SockAddr, AddrInfo)]
    interleaveAddressFamilies [(Maybe SockAddr, AddrInfo)]
    xs = [(Maybe SockAddr, AddrInfo)]
    -> [(Maybe SockAddr, AddrInfo)] -> [(Maybe SockAddr, AddrInfo)]
    forall a. [a] -> [a] -> [a]
    interleave [(Maybe SockAddr, AddrInfo)]
    sixes [(Maybe SockAddr, AddrInfo)]
    others
      where
        ([(Maybe SockAddr, AddrInfo)]
    sixes, [(Maybe SockAddr, AddrInfo)]
    others) = ((Maybe SockAddr, AddrInfo) -> Bool)
    -> [(Maybe SockAddr, AddrInfo)]
    -> ([(Maybe SockAddr, AddrInfo)], [(Maybe SockAddr, AddrInfo)])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    partition (Maybe SockAddr, AddrInfo) -> Bool
    forall {a}. (a, AddrInfo) -> Bool
    is6 [(Maybe SockAddr, AddrInfo)]
    xs
        is6 :: (a, AddrInfo) -> Bool
    is6 (a, AddrInfo)
    x = Family
    Socket.AF_INET6 Family -> Family -> Bool
    forall a. Eq a => a -> a -> Bool
    == AddrInfo -> Family
    Socket.addrFamily ((a, AddrInfo) -> AddrInfo
    forall a b. (a, b) -> b
    snd (a, AddrInfo)
    x)

        interleave :: [a] -> [a] -> [a]
    interleave (a
    x:[a]
    xs) (a
    y:[a]
    ys) = a
    x a -> [a] -> [a]
    forall a. a -> [a] -> [a]
    : a
    y a -> [a] -> [a]
    forall a. a -> [a] -> [a]
    : [a] -> [a] -> [a]
    interleave [a]
    xs [a]
    ys
        interleave []     [a]
    ys     = [a]
    ys
        interleave [a]
    xs     []     = [a]
    xs

    -- | Create a socket and connect to the service identified
    -- by the given 'AddrInfo' and return the connected socket.
    connectToAddrInfo :: Maybe SockAddr -> AddrInfo -> IO Socket
    connectToAddrInfo :: Maybe SockAddr -> AddrInfo -> IO Socket
    connectToAddrInfo Maybe SockAddr
    mbSrc AddrInfo
    info
      = let addr :: SockAddr
    addr = AddrInfo -> SockAddr
    Socket.addrAddress AddrInfo
    info in
        IO Socket
    -> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracketOnError (AddrInfo -> IO Socket
    socket' AddrInfo
    info) Socket -> IO ()
    Socket.close \Socket
    s ->
        do (SockAddr -> IO ()) -> Maybe SockAddr -> IO ()
    forall (t :: * -> *) (f :: * -> *) a b.
    (Foldable t, Applicative f) =>
    (a -> f b) -> t a -> f ()
    traverse_ (Socket -> SockAddr -> IO ()
    bind' Socket
    s) Maybe SockAddr
    mbSrc
           Socket -> SockAddr -> IO ()
    Socket.connect Socket
    s SockAddr
    addr
           Socket -> IO Socket
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Socket
    s
        IO Socket -> (IOError -> IO Socket) -> IO Socket
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `catch` (ConnectError -> IO Socket
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (ConnectError -> IO Socket)
    -> (IOError -> ConnectError) -> IOError -> IO Socket
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . SockAddr -> IOError -> ConnectError
    ConnectError SockAddr
    addr)

    -- | A version of 'Socket.bind' that doesn't bother binding on the wildcard
    -- address. The effect of binding on a wildcard address in this library
    -- is to pick an address family. Because of the matching done earlier this
    -- is unnecessary for client connections and causes a local port to be
    -- unnecessarily fixed early.
    bind' :: Socket -> SockAddr -> IO ()
    bind' :: Socket -> SockAddr -> IO ()
    bind' Socket
    _ (Socket.SockAddrInet PortNumber
    _ HostAddress
    0) = () -> IO ()
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
    bind' Socket
    _ (Socket.SockAddrInet6 PortNumber
    _ HostAddress
    _ (HostAddress
    0,HostAddress
    0,HostAddress
    0,HostAddress
    0) HostAddress
    _) = () -> IO ()
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
    bind' Socket
    s SockAddr
    a = Socket -> SockAddr -> IO ()
    Socket.bind Socket
    s SockAddr
    a

    -- | Open a 'Socket' using the parameters from an 'AddrInfo'
    socket' :: AddrInfo -> IO Socket
    socket' :: AddrInfo -> IO Socket
    socket' AddrInfo
    ai =
      Family -> SocketType -> ProtocolNumber -> IO Socket
    Socket.socket
        (AddrInfo -> Family
    Socket.addrFamily     AddrInfo
    ai)
        (AddrInfo -> SocketType
    Socket.addrSocketType AddrInfo
    ai)
        (AddrInfo -> ProtocolNumber
    Socket.addrProtocol   AddrInfo
    ai)

    ------------------------------------------------------------------------
    -- Generalization of Socket
    ------------------------------------------------------------------------

    data NetworkHandle = SSL (Maybe X509) SSL | Socket Socket

    openNetworkHandle ::
      ConnectionParams {- ^ parameters             -} ->
      IO Socket        {- ^ socket creation action -} ->
      IO NetworkHandle {- ^ open network handle    -}
    openNetworkHandle :: ConnectionParams -> IO Socket -> IO NetworkHandle
    openNetworkHandle ConnectionParams
    params IO Socket
    mkSocket =
      case ConnectionParams -> Maybe TlsParams
    cpTls ConnectionParams
    params of
        Maybe TlsParams
    Nothing  -> Socket -> NetworkHandle
    Socket (Socket -> NetworkHandle) -> IO Socket -> IO NetworkHandle
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO Socket
    mkSocket
        Just TlsParams
    tls ->
            do (clientCert, ssl) <- TlsParams -> HostName -> IO Socket -> IO (Maybe X509, SSL)
    startTls TlsParams
    tls (ConnectionParams -> HostName
    cpHost ConnectionParams
    params) IO Socket
    mkSocket
               pure (SSL clientCert ssl)

    closeNetworkHandle :: NetworkHandle -> IO ()
    closeNetworkHandle :: NetworkHandle -> IO ()
    closeNetworkHandle (Socket Socket
    s) = Socket -> IO ()
    Socket.close Socket
    s
    closeNetworkHandle (SSL Maybe X509
    _ SSL
    s) =
      do SSL -> ShutdownType -> IO ()
    SSL.shutdown SSL
    s ShutdownType
    SSL.Unidirectional
         (Socket -> IO ()) -> Maybe Socket -> IO ()
    forall (t :: * -> *) (f :: * -> *) a b.
    (Foldable t, Applicative f) =>
    (a -> f b) -> t a -> f ()
    traverse_ Socket -> IO ()
    Socket.close (SSL -> Maybe Socket
    SSL.sslSocket SSL
    s)

    networkSend :: NetworkHandle -> ByteString -> IO ()
    networkSend :: NetworkHandle -> ByteString -> IO ()
    networkSend (Socket Socket
    s) = Socket -> ByteString -> IO ()
    SocketB.sendAll Socket
    s
    networkSend (SSL  Maybe X509
    _ SSL
    s) = SSL -> ByteString -> IO ()
    SSL.write       SSL
    s

    networkRecv :: NetworkHandle -> Int -> IO ByteString
    networkRecv :: NetworkHandle -> Int -> IO ByteString
    networkRecv (Socket Socket
    s) = Socket -> Int -> IO ByteString
    SocketB.recv Socket
    s
    networkRecv (SSL  Maybe X509
    _ SSL
    s) = SSL -> Int -> IO ByteString
    SSL.read     SSL
    s

    ------------------------------------------------------------------------
    -- Sockets with a receive buffer
    ------------------------------------------------------------------------

    -- | A connection to a network service along with its read buffer
    -- used for line-oriented protocols. The connection could be a plain
    -- network connection, SOCKS connected, or TLS.
    data Connection =
      Connection
      {-# UNPACK #-} !(MVar ByteString)
      {-# UNPACK #-} !(MVar NetworkHandle)

    -- | Open network connection to TCP service specified by
    -- the given parameters.
    --
    -- The resulting connection MUST be closed with 'close' to avoid leaking
    -- resources.
    --
    -- Throws 'IOError', 'SocksError', 'SSL.ProtocolError', 'ConnectionFailure'
    connect ::
      ConnectionParams {- ^ parameters      -} ->
      IO Connection    {- ^ open connection -}
    connect :: ConnectionParams -> IO Connection
    connect ConnectionParams
    params =
     do h <- ConnectionParams -> IO Socket -> IO NetworkHandle
    openNetworkHandle ConnectionParams
    params (ConnectionParams -> IO Socket
    openSocket ConnectionParams
    params)
        Connection <$> newMVar B.empty <*> newMVar h

    -- | Create a new 'Connection' using an already connected socket.
    -- This will attempt to start TLS if configured but will ignore
    -- any SOCKS server settings as it is assumed that the socket
    -- is already actively connected to the intended service.
    --
    -- Throws 'SSL.ProtocolError'
    connectWithSocket ::
      ConnectionParams {- ^ parameters       -} ->
      Socket           {- ^ connected socket -} ->
      IO Connection    {- ^ open connection  -}
    connectWithSocket :: ConnectionParams -> Socket -> IO Connection
    connectWithSocket ConnectionParams
    params Socket
    sock =
     do h <- ConnectionParams -> IO Socket -> IO NetworkHandle
    openNetworkHandle ConnectionParams
    params (Socket -> IO Socket
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Socket
    sock)
        Connection <$> newMVar B.empty <*> newMVar h

    -- | Close network connection.
    close ::
      Connection {- ^ open connection -} ->
      IO ()
    close :: Connection -> IO ()
    close (Connection MVar ByteString
    _ MVar NetworkHandle
    m) = MVar NetworkHandle -> (NetworkHandle -> IO ()) -> IO ()
    forall a b. MVar a -> (a -> IO b) -> IO b
    withMVar MVar NetworkHandle
    m \NetworkHandle
    h -> NetworkHandle -> IO ()
    closeNetworkHandle NetworkHandle
    h

    -- | Receive the next chunk from the stream. This operation will first
    -- return the buffer if it contains a non-empty chunk. Otherwise it will
    -- request up to the requested number of bytes from the stream.
    --
    -- Throws: 'IOError', 'SSL.ConnectionAbruptlyTerminated', 'SSL.ProtocolError'
    recv ::
      Connection    {- ^ open connection              -} ->
      Int           {- ^ maximum underlying recv size -} ->
      IO ByteString {- ^ next chunk from stream       -}
    recv :: Connection -> Int -> IO ByteString
    recv (Connection MVar ByteString
    bufVar MVar NetworkHandle
    hVar) Int
    n =
      MVar ByteString
    -> (ByteString -> IO (ByteString, ByteString)) -> IO ByteString
    forall a b. MVar a -> (a -> IO (a, b)) -> IO b
    modifyMVar MVar ByteString
    bufVar \ByteString
    bufChunk ->
      if ByteString -> Bool
    B.null ByteString
    bufChunk then
       do h <- MVar NetworkHandle -> IO NetworkHandle
    forall a. MVar a -> IO a
    readMVar MVar NetworkHandle
    hVar
          bs <- networkRecv h n
          pure (B.empty, bs)
      else
          (ByteString, ByteString) -> IO (ByteString, ByteString)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (ByteString
    B.empty, ByteString
    bufChunk)

    -- | Receive a line from the network connection. Both
    -- @"\\r\\n"@ and @"\\n"@ are recognized.
    --
    -- Returning 'Nothing' means that the peer has closed its half of
    -- the connection.
    --
    -- Unterminated lines will raise a 'LineTruncated' exception. This
    -- can happen if the peer transmits some data and closes its end
    -- without transmitting a line terminator.
    --
    -- Throws: 'SSL.ConnectionAbruptlyTerminated', 'SSL.ProtocolError', 'ConnectionFailure', 'IOError'
    recvLine ::
      Connection            {- ^ open connection            -} ->
      Int                   {- ^ maximum line length        -} ->
      IO (Maybe ByteString) {- ^ next line or end-of-stream -}
    recvLine :: Connection -> Int -> IO (Maybe ByteString)
    recvLine (Connection MVar ByteString
    bufVar MVar NetworkHandle
    hVar) Int
    n =
      MVar ByteString
    -> (ByteString -> IO (ByteString, Maybe ByteString))
    -> IO (Maybe ByteString)
    forall a b. MVar a -> (a -> IO (a, b)) -> IO b
    modifyMVar MVar ByteString
    bufVar \ByteString
    bs ->
       do h <- MVar NetworkHandle -> IO NetworkHandle
    forall a. MVar a -> IO a
    readMVar MVar NetworkHandle
    hVar
          go h (B.length bs) bs []
      where
        -- bsn: cached length of concatenation of (bs:bss)
        -- bs : most recent chunk
        -- bss: other chunks ordered from most to least recent
        go :: NetworkHandle
    -> Int
    -> ByteString
    -> [ByteString]
    -> IO (ByteString, Maybe ByteString)
    go NetworkHandle
    h Int
    bsn ByteString
    bs [ByteString]
    bss =
          case Char -> ByteString -> Maybe Int
    B8.elemIndex Char
    '\n' ByteString
    bs of
            Just Int
    i -> (ByteString, Maybe ByteString) -> IO (ByteString, Maybe ByteString)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (HasCallStack => ByteString -> ByteString
    ByteString -> ByteString
    B.tail ByteString
    b, -- tail drops newline
                            ByteString -> Maybe ByteString
    forall a. a -> Maybe a
    Just (ByteString -> ByteString
    cleanEnd ([ByteString] -> ByteString
    B.concat ([ByteString] -> [ByteString]
    forall a. [a] -> [a]
    reverse (ByteString
    aByteString -> [ByteString] -> [ByteString]
    forall a. a -> [a] -> [a]
    :[ByteString]
    bss)))))
              where
                (ByteString
    a,ByteString
    b) = Int -> ByteString -> (ByteString, ByteString)
    B.splitAt Int
    i ByteString
    bs
            Maybe Int
    Nothing ->
              do Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    bsn Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    n) (ConnectionFailure -> IO ()
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO ConnectionFailure
    LineTooLong)
                 more <- NetworkHandle -> Int -> IO ByteString
    networkRecv NetworkHandle
    h Int
    n
                 if B.null more -- connection closed
                   then if bsn == 0 then pure (B.empty, Nothing)
                                    else throwIO LineTruncated
                   else go h (bsn + B.length more) more (bs:bss)

    -- | Push a 'ByteString' onto the buffer so that it will be the first
    -- bytes to be read on the next receive operation. This could perhaps
    -- be useful for putting the unused portion of a 'recv' back into the
    -- buffer for future 'recvLine' or 'recv' operations.
    putBuf ::
      Connection {- ^ connection         -} ->
      ByteString {- ^ new head of buffer -} ->
      IO ()
    putBuf :: Connection -> ByteString -> IO ()
    putBuf (Connection MVar ByteString
    bufVar MVar NetworkHandle
    _) ByteString
    bs =
      MVar ByteString -> (ByteString -> IO ByteString) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ MVar ByteString
    bufVar (\ByteString
    old -> ByteString -> IO ByteString
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $! ByteString -> ByteString -> ByteString
    B.append ByteString
    bs ByteString
    old)

    -- | Remove the trailing @'\\r'@ if one is found.
    cleanEnd :: ByteString -> ByteString
    cleanEnd :: ByteString -> ByteString
    cleanEnd ByteString
    bs
      | ByteString -> Bool
    B.null ByteString
    bs Bool -> Bool -> Bool
    || ByteString -> Char
    B8.last ByteString
    bs Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\r' = ByteString
    bs
      | Bool
    otherwise                       = HasCallStack => ByteString -> ByteString
    ByteString -> ByteString
    B.init ByteString
    bs

    -- | Send bytes on the network connection. This ensures the whole chunk is
    -- transmitted, which might take multiple underlying sends.
    --
    -- Throws: 'IOError', 'SSL.ProtocolError'
    send ::
      Connection {- ^ open connection -} ->
      ByteString {- ^ chunk           -} ->
      IO ()
    send :: Connection -> ByteString -> IO ()
    send (Connection MVar ByteString
    _ MVar NetworkHandle
    hVar) ByteString
    bs =
      do h <- MVar NetworkHandle -> IO NetworkHandle
    forall a. MVar a -> IO a
    readMVar MVar NetworkHandle
    hVar
         networkSend h bs

    upgradeTls ::
      TlsParams {- ^ connection params -} ->
      String {- ^ hostname -} ->
      Connection ->
      IO ()
    upgradeTls :: TlsParams -> HostName -> Connection -> IO ()
    upgradeTls TlsParams
    tp HostName
    hostname (Connection MVar ByteString
    bufVar MVar NetworkHandle
    hVar) =
      MVar ByteString -> (ByteString -> IO ByteString) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ MVar ByteString
    bufVar \ByteString
    buf ->
      MVar NetworkHandle
    -> (NetworkHandle -> IO (NetworkHandle, ByteString))
    -> IO ByteString
    forall a b. MVar a -> (a -> IO (a, b)) -> IO b
    modifyMVar  MVar NetworkHandle
    hVar   \NetworkHandle
    h ->
      case NetworkHandle
    h of
        SSL{} -> (NetworkHandle, ByteString) -> IO (NetworkHandle, ByteString)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (NetworkHandle
    h, ByteString
    buf)
        Socket Socket
    s ->
          do (cert, ssl) <- TlsParams -> HostName -> IO Socket -> IO (Maybe X509, SSL)
    startTls TlsParams
    tp HostName
    hostname (Socket -> IO Socket
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Socket
    s)
             pure (SSL cert ssl, B.empty)

    ------------------------------------------------------------------------

    -- | Initiate a TLS session on the given socket destined for
    -- the given hostname. When successful an active TLS connection
    -- is returned with certificate verification successful when
    -- requested. This function requires that the TLSParams component
    -- of 'ConnectionParams' is set.
    startTls ::
      TlsParams {- ^ connection params      -} ->
      String    {- ^ hostname               -} ->
      IO Socket {- ^ socket creation action -} ->
      IO (Maybe X509, SSL) {- ^ (client certificate, connected TLS) -}
    startTls :: TlsParams -> HostName -> IO Socket -> IO (Maybe X509, SSL)
    startTls TlsParams
    tp HostName
    hostname IO Socket
    mkSocket = IO (Maybe X509, SSL) -> IO (Maybe X509, SSL)
    forall a. IO a -> IO a
    SSL.withOpenSSL (IO (Maybe X509, SSL) -> IO (Maybe X509, SSL))
    -> IO (Maybe X509, SSL) -> IO (Maybe X509, SSL)
    forall a b. (a -> b) -> a -> b
    $
     do ctx <- IO SSLContext
    SSL.context

        -- configure context
        SSL.contextSetCiphers          ctx (tpCipherSuite tp)
        traverse_ (contextSetTls13Ciphers ctx) (tpCipherSuiteTls13 tp)

        case tpVerify tp of
          TlsVerify
    VerifyNone -> () -> IO ()
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
          TlsVerify
    VerifyDefault ->
           do SSLContext -> HostName -> IO ()
    installVerification SSLContext
    ctx HostName
    hostname
              SSLContext -> VerificationMode -> IO ()
    SSL.contextSetVerificationMode SSLContext
    ctx VerificationMode
    verifyPeer
          VerifyHostname HostName
    h ->
           do SSLContext -> HostName -> IO ()
    installVerification SSLContext
    ctx HostName
    h
              SSLContext -> VerificationMode -> IO ()
    SSL.contextSetVerificationMode SSLContext
    ctx VerificationMode
    verifyPeer

        SSL.contextAddOption           ctx SSL.SSL_OP_ALL
        SSL.contextRemoveOption        ctx SSL.SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS

        -- configure certificates
        setupCaCertificates ctx (tpServerCertificate tp)
        clientCert <- traverse (setupCertificate ctx) (tpClientCertificate tp)

        for_ (tpClientPrivateKey tp) \HostName
    path ->
          SSLContext -> Maybe ByteString -> IO () -> IO ()
    forall a. SSLContext -> Maybe ByteString -> IO a -> IO a
    withDefaultPassword SSLContext
    ctx (TlsParams -> Maybe ByteString
    tpClientPrivateKeyPassword TlsParams
    tp) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            SSLContext -> HostName -> IO ()
    SSL.contextSetPrivateKeyFile SSLContext
    ctx HostName
    path

        -- add socket to context
        -- creation of the socket is delayed until this point to avoid
        -- leaking the file descriptor in the cases of exceptions above.
        ssl <- SSL.connection ctx =<< mkSocket

        -- configure hostname used for SNI
        isip <- isIpAddress hostname
        unless isip (SSL.setTlsextHostName ssl hostname)

        SSL.connect ssl

        pure (clientCert, ssl)

    isIpAddress :: HostName -> IO Bool
    isIpAddress :: HostName -> IO Bool
    isIpAddress HostName
    host =
     do res <- IO [AddrInfo] -> IO (Either IOError [AddrInfo])
    forall e a. Exception e => IO a -> IO (Either e a)
    try (Maybe AddrInfo -> Maybe HostName -> Maybe HostName -> IO [AddrInfo]
    forall (t :: * -> *).
    GetAddrInfo t =>
    Maybe AddrInfo
    -> Maybe HostName -> Maybe HostName -> IO (t AddrInfo)
    Socket.getAddrInfo
                      (AddrInfo -> Maybe AddrInfo
    forall a. a -> Maybe a
    Just AddrInfo
    Socket.defaultHints{Socket.addrFlags=[Socket.AI_NUMERICHOST]})
                      (HostName -> Maybe HostName
    forall a. a -> Maybe a
    Just HostName
    host) Maybe HostName
    forall a. Maybe a
    Nothing)
        case res :: Either IOError [AddrInfo] of
          Right{} -> Bool -> IO Bool
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    True
          Left {} -> Bool -> IO Bool
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    False

    setupCaCertificates :: SSLContext -> Maybe FilePath -> IO ()
    setupCaCertificates :: SSLContext -> Maybe HostName -> IO ()
    setupCaCertificates SSLContext
    ctx Maybe HostName
    mbPath =
      case Maybe HostName
    mbPath of
        Maybe HostName
    Nothing   -> SSLContext -> IO ()
    contextLoadSystemCerts SSLContext
    ctx
        Just HostName
    path -> SSLContext -> Maybe ByteString -> IO () -> IO ()
    forall a. SSLContext -> Maybe ByteString -> IO a -> IO a
    withDefaultPassword SSLContext
    ctx Maybe ByteString
    forall a. Maybe a
    Nothing (SSLContext -> HostName -> IO ()
    SSL.contextSetCAFile SSLContext
    ctx HostName
    path)

    setupCertificate :: SSLContext -> FilePath -> IO X509
    setupCertificate :: SSLContext -> HostName -> IO X509
    setupCertificate SSLContext
    ctx HostName
    path =
      do x509 <- HostName -> IO X509
    PEM.readX509 (HostName -> IO X509) -> IO HostName -> IO X509
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< HostName -> IO HostName
    readFile HostName
    path -- EX
         SSL.contextSetCertificate ctx x509
         pure x509

    verifyPeer :: SSL.VerificationMode
    verifyPeer :: VerificationMode
    verifyPeer = SSL.VerifyPeer
      { vpFailIfNoPeerCert :: Bool
    SSL.vpFailIfNoPeerCert = Bool
    True
      , vpClientOnce :: Bool
    SSL.vpClientOnce       = Bool
    True
      , vpCallback :: Maybe (Bool -> X509StoreCtx -> IO Bool)
    SSL.vpCallback         = Maybe (Bool -> X509StoreCtx -> IO Bool)
    forall a. Maybe a
    Nothing
      }

    -- | Get peer certificate if one exists.
    getPeerCertificate :: Connection -> IO (Maybe X509.X509)
    getPeerCertificate :: Connection -> IO (Maybe X509)
    getPeerCertificate (Connection MVar ByteString
    _ MVar NetworkHandle
    hVar) =
      MVar NetworkHandle
    -> (NetworkHandle -> IO (Maybe X509)) -> IO (Maybe X509)
    forall a b. MVar a -> (a -> IO b) -> IO b
    withMVar MVar NetworkHandle
    hVar \case
        Socket{} -> Maybe X509 -> IO (Maybe X509)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe X509
    forall a. Maybe a
    Nothing
        SSL Maybe X509
    _ SSL
    ssl -> SSL -> IO (Maybe X509)
    SSL.getPeerCertificate SSL
    ssl

    -- | Get peer certificate if one exists.
    getClientCertificate :: Connection -> IO (Maybe X509.X509)
    getClientCertificate :: Connection -> IO (Maybe X509)
    getClientCertificate (Connection MVar ByteString
    _ MVar NetworkHandle
    hVar) =
     do h <- MVar NetworkHandle -> IO NetworkHandle
    forall a. MVar a -> IO a
    readMVar MVar NetworkHandle
    hVar
        pure case h of
          Socket{} -> Maybe X509
    forall a. Maybe a
    Nothing
          SSL Maybe X509
    c SSL
    _  -> Maybe X509
    c

    getPeerCertFingerprintSha1 :: Connection -> IO (Maybe ByteString)
    getPeerCertFingerprintSha1 :: Connection -> IO (Maybe ByteString)
    getPeerCertFingerprintSha1 = HostName -> Connection -> IO (Maybe ByteString)
    getPeerCertFingerprint HostName
    "sha1"

    getPeerCertFingerprintSha256 :: Connection -> IO (Maybe ByteString)
    getPeerCertFingerprintSha256 :: Connection -> IO (Maybe ByteString)
    getPeerCertFingerprintSha256 = HostName -> Connection -> IO (Maybe ByteString)
    getPeerCertFingerprint HostName
    "sha256"

    getPeerCertFingerprintSha512 :: Connection -> IO (Maybe ByteString)
    getPeerCertFingerprintSha512 :: Connection -> IO (Maybe ByteString)
    getPeerCertFingerprintSha512 = HostName -> Connection -> IO (Maybe ByteString)
    getPeerCertFingerprint HostName
    "sha512"

    getPeerCertFingerprint :: String -> Connection -> IO (Maybe ByteString)
    getPeerCertFingerprint :: HostName -> Connection -> IO (Maybe ByteString)
    getPeerCertFingerprint HostName
    name Connection
    h =
       do mb <- Connection -> IO (Maybe X509)
    getPeerCertificate Connection
    h
          case mb of
            Maybe X509
    Nothing -> Maybe ByteString -> IO (Maybe ByteString)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe ByteString
    forall a. Maybe a
    Nothing
            Just X509
    x509 ->
             do der <- X509 -> IO ByteString
    X509.writeDerX509 X509
    x509
                mbdigest <- Digest.getDigestByName name
                pure $! case mbdigest of
                  Maybe Digest
    Nothing -> Maybe ByteString
    forall a. Maybe a
    Nothing
                  Just Digest
    digest -> ByteString -> Maybe ByteString
    forall a. a -> Maybe a
    Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
    forall a b. (a -> b) -> a -> b
    $! Digest -> ByteString -> ByteString
    Digest.digestLBS Digest
    digest ByteString
    der

    getPeerPubkeyFingerprintSha1 :: Connection -> IO (Maybe ByteString)
    getPeerPubkeyFingerprintSha1 :: Connection -> IO (Maybe ByteString)
    getPeerPubkeyFingerprintSha1 = HostName -> Connection -> IO (Maybe ByteString)
    getPeerPubkeyFingerprint HostName
    "sha1"

    getPeerPubkeyFingerprintSha256 :: Connection -> IO (Maybe ByteString)
    getPeerPubkeyFingerprintSha256 :: Connection -> IO (Maybe ByteString)
    getPeerPubkeyFingerprintSha256 = HostName -> Connection -> IO (Maybe ByteString)
    getPeerPubkeyFingerprint HostName
    "sha256"

    getPeerPubkeyFingerprintSha512 :: Connection -> IO (Maybe ByteString)
    getPeerPubkeyFingerprintSha512 :: Connection -> IO (Maybe ByteString)
    getPeerPubkeyFingerprintSha512 = HostName -> Connection -> IO (Maybe ByteString)
    getPeerPubkeyFingerprint HostName
    "sha512"

    getPeerPubkeyFingerprint :: String -> Connection -> IO (Maybe ByteString)
    getPeerPubkeyFingerprint :: HostName -> Connection -> IO (Maybe ByteString)
    getPeerPubkeyFingerprint HostName
    name Connection
    h =
     do mb <- Connection -> IO (Maybe X509)
    getPeerCertificate Connection
    h
        case mb of
          Maybe X509
    Nothing -> Maybe ByteString -> IO (Maybe ByteString)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe ByteString
    forall a. Maybe a
    Nothing
          Just X509
    x509 ->
           do der <- X509 -> IO ByteString
    getPubKeyDer X509
    x509
              mbdigest <- Digest.getDigestByName name
              pure $! case mbdigest of
                Maybe Digest
    Nothing -> Maybe ByteString
    forall a. Maybe a
    Nothing
                Just Digest
    digest -> ByteString -> Maybe ByteString
    forall a. a -> Maybe a
    Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
    forall a b. (a -> b) -> a -> b
    $! Digest -> ByteString -> ByteString
    Digest.digestBS Digest
    digest ByteString
    der