{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Simplex.Messaging.Transport.Client
  ( runTransportClient,
    runTLSTransportClient,
    smpClientHandshake,
    defaultSMPPort,
    defaultTcpConnectTimeout,
    defaultTransportClientConfig,
    defaultSocksProxyWithAuth,
    defaultSocksProxy,
    defaultSocksHost,
    TransportClientConfig (..),
    SocksProxy (..),
    SocksProxyWithAuth (..),
    SocksAuth (..),
    TransportHost (..),
    TransportHosts (..),
    TransportHosts_ (..),
    validateCertificateChain,
  )
where

import Control.Applicative (optional, (<|>))
import Control.Logger.Simple (logError)
import Control.Monad
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAsciiLower, isDigit, isHexDigit)
import Data.Default (def)
import Data.Functor (($>))
import Data.IORef
import Data.IP
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe)
import Data.String
import Data.Word (Word32, Word8)
import qualified Data.X509 as X
import qualified Data.X509.CertificateStore as XS
import Data.X509.Validation (Fingerprint (..))
import qualified Data.X509.Validation as XV
import GHC.IO.Exception (IOErrorType (..))
import Network.Socket
import Network.Socks5
import qualified Network.TLS as T
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll, parseString)
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Transport.Shared
import Simplex.Messaging.Util (bshow, catchAll, catchAll_, tshow, (<$?>))
import System.IO.Error
import Text.Read (readMaybe)
import UnliftIO.Exception (IOException)
import qualified UnliftIO.Exception as E
import UnliftIO.STM

data TransportHost
  = THIPv4 (Word8, Word8, Word8, Word8)
  | THIPv6 (Word32, Word32, Word32, Word32)
  | THOnionHost ByteString
  | THDomainName HostName
  deriving (TransportHost -> TransportHost -> Bool
(TransportHost -> TransportHost -> Bool)
-> (TransportHost -> TransportHost -> Bool) -> Eq TransportHost
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransportHost -> TransportHost -> Bool
== :: TransportHost -> TransportHost -> Bool
$c/= :: TransportHost -> TransportHost -> Bool
/= :: TransportHost -> TransportHost -> Bool
Eq, Eq TransportHost
Eq TransportHost =>
(TransportHost -> TransportHost -> Ordering)
-> (TransportHost -> TransportHost -> Bool)
-> (TransportHost -> TransportHost -> Bool)
-> (TransportHost -> TransportHost -> Bool)
-> (TransportHost -> TransportHost -> Bool)
-> (TransportHost -> TransportHost -> TransportHost)
-> (TransportHost -> TransportHost -> TransportHost)
-> Ord TransportHost
TransportHost -> TransportHost -> Bool
TransportHost -> TransportHost -> Ordering
TransportHost -> TransportHost -> TransportHost
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TransportHost -> TransportHost -> Ordering
compare :: TransportHost -> TransportHost -> Ordering
$c< :: TransportHost -> TransportHost -> Bool
< :: TransportHost -> TransportHost -> Bool
$c<= :: TransportHost -> TransportHost -> Bool
<= :: TransportHost -> TransportHost -> Bool
$c> :: TransportHost -> TransportHost -> Bool
> :: TransportHost -> TransportHost -> Bool
$c>= :: TransportHost -> TransportHost -> Bool
>= :: TransportHost -> TransportHost -> Bool
$cmax :: TransportHost -> TransportHost -> TransportHost
max :: TransportHost -> TransportHost -> TransportHost
$cmin :: TransportHost -> TransportHost -> TransportHost
min :: TransportHost -> TransportHost -> TransportHost
Ord, Int -> TransportHost -> ShowS
[TransportHost] -> ShowS
TransportHost -> HostName
(Int -> TransportHost -> ShowS)
-> (TransportHost -> HostName)
-> ([TransportHost] -> ShowS)
-> Show TransportHost
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransportHost -> ShowS
showsPrec :: Int -> TransportHost -> ShowS
$cshow :: TransportHost -> HostName
show :: TransportHost -> HostName
$cshowList :: [TransportHost] -> ShowS
showList :: [TransportHost] -> ShowS
Show)

instance Encoding TransportHost where
  smpEncode :: TransportHost -> ByteString
smpEncode = ByteString -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (ByteString -> ByteString)
-> (TransportHost -> ByteString) -> TransportHost -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportHost -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode
  smpP :: Parser TransportHost
smpP = Parser TransportHost -> ByteString -> Either HostName TransportHost
forall a. Parser a -> ByteString -> Either HostName a
parseAll Parser TransportHost
forall a. StrEncoding a => Parser a
strP (ByteString -> Either HostName TransportHost)
-> Parser ByteString ByteString -> Parser TransportHost
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either HostName b) -> m a -> m b
<$?> Parser ByteString ByteString
forall a. Encoding a => Parser a
smpP

instance StrEncoding TransportHost where
  strEncode :: TransportHost -> ByteString
strEncode = \case
    THIPv4 (Word8
a1, Word8
a2, Word8
a3, Word8
a4) -> ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"." ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word8 -> ByteString) -> [Word8] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> ByteString
forall a. Show a => a -> ByteString
bshow [Word8
a1, Word8
a2, Word8
a3, Word8
a4]
    THIPv6 (Word32, Word32, Word32, Word32)
addr -> IPv6 -> ByteString
forall a. Show a => a -> ByteString
bshow (IPv6 -> ByteString) -> IPv6 -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word32, Word32, Word32, Word32) -> IPv6
toIPv6w (Word32, Word32, Word32, Word32)
addr
    THOnionHost ByteString
host -> ByteString
host
    THDomainName HostName
host -> HostName -> ByteString
B.pack HostName
host
  strP :: Parser TransportHost
strP =
    [Parser TransportHost] -> Parser TransportHost
forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice
      [ (Word8, Word8, Word8, Word8) -> TransportHost
THIPv4 ((Word8, Word8, Word8, Word8) -> TransportHost)
-> Parser ByteString (Word8, Word8, Word8, Word8)
-> Parser TransportHost
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,,) (Word8 -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8))
-> Parser ByteString Word8
-> Parser
     ByteString
     (Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
ipNum Parser
  ByteString
  (Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8))
-> Parser ByteString Word8
-> Parser
     ByteString (Word8 -> Word8 -> (Word8, Word8, Word8, Word8))
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Word8
ipNum Parser ByteString (Word8 -> Word8 -> (Word8, Word8, Word8, Word8))
-> Parser ByteString Word8
-> Parser ByteString (Word8 -> (Word8, Word8, Word8, Word8))
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Word8
ipNum Parser ByteString (Word8 -> (Word8, Word8, Word8, Word8))
-> Parser ByteString Word8
-> Parser ByteString (Word8, Word8, Word8, Word8)
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Word8
forall a. Integral a => Parser a
A.decimal),
        Either HostName TransportHost
-> (IPv6 -> Either HostName TransportHost)
-> Maybe IPv6
-> Either HostName TransportHost
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HostName -> Either HostName TransportHost
forall a b. a -> Either a b
Left HostName
"bad IPv6") (TransportHost -> Either HostName TransportHost
forall a b. b -> Either a b
Right (TransportHost -> Either HostName TransportHost)
-> (IPv6 -> TransportHost) -> IPv6 -> Either HostName TransportHost
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32, Word32, Word32, Word32) -> TransportHost
THIPv6 ((Word32, Word32, Word32, Word32) -> TransportHost)
-> (IPv6 -> (Word32, Word32, Word32, Word32))
-> IPv6
-> TransportHost
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv6 -> (Word32, Word32, Word32, Word32)
fromIPv6w) (Maybe IPv6 -> Either HostName TransportHost)
-> (ByteString -> Maybe IPv6)
-> ByteString
-> Either HostName TransportHost
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostName -> Maybe IPv6
forall a. Read a => HostName -> Maybe a
readMaybe (HostName -> Maybe IPv6)
-> (ByteString -> HostName) -> ByteString -> Maybe IPv6
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HostName
B.unpack (ByteString -> Either HostName TransportHost)
-> Parser ByteString ByteString -> Parser TransportHost
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either HostName b) -> m a -> m b
<$?> Parser ByteString ByteString
ipv6StrP,
        ByteString -> TransportHost
THOnionHost (ByteString -> TransportHost)
-> Parser ByteString ByteString -> Parser TransportHost
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
(<>) (ByteString -> ByteString -> ByteString)
-> Parser ByteString ByteString
-> Parser ByteString (ByteString -> ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile (\Char
c -> Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c) Parser ByteString (ByteString -> ByteString)
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Parser ByteString ByteString
A.string ByteString
".onion"),
        HostName -> TransportHost
THDomainName (HostName -> TransportHost)
-> (ByteString -> HostName) -> ByteString -> TransportHost
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HostName
B.unpack (ByteString -> TransportHost)
-> Parser ByteString ByteString -> Parser TransportHost
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Either HostName ByteString
forall {a}. IsString a => ByteString -> Either a ByteString
notOnion (ByteString -> Either HostName ByteString)
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either HostName b) -> m a -> m b
<$?> (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile1 (HostName -> Char -> Bool
A.notInClass HostName
":#,;/ \n\r\t"))
      ]
    where
      ipNum :: Parser ByteString Word8
ipNum = Int -> Either HostName Word8
validIP (Int -> Either HostName Word8)
-> Parser ByteString Int -> Parser ByteString Word8
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either HostName b) -> m a -> m b
<$?> (Parser ByteString Int
forall a. Integral a => Parser a
A.decimal Parser ByteString Int
-> Parser ByteString Char -> Parser ByteString Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
A.char Char
'.')
      validIP :: Int -> Either String Word8
      validIP :: Int -> Either HostName Word8
validIP Int
n = if Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
255 then Word8 -> Either HostName Word8
forall a b. b -> Either a b
Right (Word8 -> Either HostName Word8) -> Word8 -> Either HostName Word8
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n else HostName -> Either HostName Word8
forall a b. a -> Either a b
Left HostName
"invalid IP address"
      ipv6StrP :: Parser ByteString ByteString
ipv6StrP =
        Char -> Parser ByteString Char
A.char Char
'[' Parser ByteString Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']') Parser ByteString ByteString
-> Parser ByteString Char -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
A.char Char
']'
          Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile1 (\Char
c -> Char -> Bool
isHexDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':')
      notOnion :: ByteString -> Either a ByteString
notOnion ByteString
s = if ByteString
".onion" ByteString -> ByteString -> Bool
`B.isSuffixOf` ByteString
s then a -> Either a ByteString
forall a b. a -> Either a b
Left a
"invalid onion host" else ByteString -> Either a ByteString
forall a b. b -> Either a b
Right ByteString
s

instance ToJSON TransportHost where
  toEncoding :: TransportHost -> Encoding
toEncoding = TransportHost -> Encoding
forall a. StrEncoding a => a -> Encoding
strToJEncoding
  toJSON :: TransportHost -> Value
toJSON = TransportHost -> Value
forall a. StrEncoding a => a -> Value
strToJSON

instance FromJSON TransportHost where
  parseJSON :: Value -> Parser TransportHost
parseJSON = HostName -> Value -> Parser TransportHost
forall a. StrEncoding a => HostName -> Value -> Parser a
strParseJSON HostName
"TransportHost"

newtype TransportHosts = TransportHosts {TransportHosts -> NonEmpty TransportHost
thList :: NonEmpty TransportHost}

instance StrEncoding TransportHosts where
  strEncode :: TransportHosts -> ByteString
strEncode = [TransportHost] -> ByteString
forall a. StrEncoding a => [a] -> ByteString
strEncodeList ([TransportHost] -> ByteString)
-> (TransportHosts -> [TransportHost])
-> TransportHosts
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty TransportHost -> [TransportHost]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty TransportHost -> [TransportHost])
-> (TransportHosts -> NonEmpty TransportHost)
-> TransportHosts
-> [TransportHost]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportHosts -> NonEmpty TransportHost
thList
  strP :: Parser TransportHosts
strP = NonEmpty TransportHost -> TransportHosts
TransportHosts (NonEmpty TransportHost -> TransportHosts)
-> ([TransportHost] -> NonEmpty TransportHost)
-> [TransportHost]
-> TransportHosts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TransportHost] -> NonEmpty TransportHost
forall a. HasCallStack => [a] -> NonEmpty a
L.fromList ([TransportHost] -> TransportHosts)
-> Parser ByteString [TransportHost] -> Parser TransportHosts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TransportHost
forall a. StrEncoding a => Parser a
strP Parser TransportHost
-> Parser ByteString Char -> Parser ByteString [TransportHost]
forall (m :: * -> *) a s. MonadPlus m => m a -> m s -> m [a]
`A.sepBy1'` Char -> Parser ByteString Char
A.char Char
','

newtype TransportHosts_ = TransportHosts_ {TransportHosts_ -> [TransportHost]
thList_ :: [TransportHost]}

instance StrEncoding TransportHosts_ where
  strEncode :: TransportHosts_ -> ByteString
strEncode = [TransportHost] -> ByteString
forall a. StrEncoding a => [a] -> ByteString
strEncodeList ([TransportHost] -> ByteString)
-> (TransportHosts_ -> [TransportHost])
-> TransportHosts_
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportHosts_ -> [TransportHost]
thList_
  strP :: Parser TransportHosts_
strP = [TransportHost] -> TransportHosts_
TransportHosts_ ([TransportHost] -> TransportHosts_)
-> Parser ByteString [TransportHost] -> Parser TransportHosts_
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TransportHost
forall a. StrEncoding a => Parser a
strP Parser TransportHost
-> Parser ByteString Char -> Parser ByteString [TransportHost]
forall (m :: * -> *) a s. MonadPlus m => m a -> m s -> m [a]
`A.sepBy'` Char -> Parser ByteString Char
A.char Char
','

instance IsString TransportHost where fromString :: HostName -> TransportHost
fromString = (ByteString -> Either HostName TransportHost)
-> HostName -> TransportHost
forall a. (ByteString -> Either HostName a) -> HostName -> a
parseString ByteString -> Either HostName TransportHost
forall a. StrEncoding a => ByteString -> Either HostName a
strDecode

instance IsString (NonEmpty TransportHost) where fromString :: HostName -> NonEmpty TransportHost
fromString = (ByteString -> Either HostName (NonEmpty TransportHost))
-> HostName -> NonEmpty TransportHost
forall a. (ByteString -> Either HostName a) -> HostName -> a
parseString ByteString -> Either HostName (NonEmpty TransportHost)
forall a. StrEncoding a => ByteString -> Either HostName a
strDecode

data TransportClientConfig = TransportClientConfig
  { TransportClientConfig -> Maybe SocksProxy
socksProxy :: Maybe SocksProxy,
    TransportClientConfig -> Int
tcpConnectTimeout :: Int,
    TransportClientConfig -> Maybe KeepAliveOpts
tcpKeepAlive :: Maybe KeepAliveOpts,
    TransportClientConfig -> Bool
logTLSErrors :: Bool,
    TransportClientConfig -> Maybe Credential
clientCredentials :: Maybe T.Credential,
    TransportClientConfig -> Maybe [ByteString]
clientALPN :: Maybe [ALPN],
    TransportClientConfig -> Bool
useSNI :: Bool
  }
  deriving (TransportClientConfig -> TransportClientConfig -> Bool
(TransportClientConfig -> TransportClientConfig -> Bool)
-> (TransportClientConfig -> TransportClientConfig -> Bool)
-> Eq TransportClientConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransportClientConfig -> TransportClientConfig -> Bool
== :: TransportClientConfig -> TransportClientConfig -> Bool
$c/= :: TransportClientConfig -> TransportClientConfig -> Bool
/= :: TransportClientConfig -> TransportClientConfig -> Bool
Eq, Int -> TransportClientConfig -> ShowS
[TransportClientConfig] -> ShowS
TransportClientConfig -> HostName
(Int -> TransportClientConfig -> ShowS)
-> (TransportClientConfig -> HostName)
-> ([TransportClientConfig] -> ShowS)
-> Show TransportClientConfig
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransportClientConfig -> ShowS
showsPrec :: Int -> TransportClientConfig -> ShowS
$cshow :: TransportClientConfig -> HostName
show :: TransportClientConfig -> HostName
$cshowList :: [TransportClientConfig] -> ShowS
showList :: [TransportClientConfig] -> ShowS
Show)

-- time to resolve host, connect socket, set up TLS
defaultTcpConnectTimeout :: Int
defaultTcpConnectTimeout :: Int
defaultTcpConnectTimeout = Int
25_000_000

defaultTransportClientConfig :: TransportClientConfig
defaultTransportClientConfig :: TransportClientConfig
defaultTransportClientConfig =
  TransportClientConfig
    { $sel:socksProxy:TransportClientConfig :: Maybe SocksProxy
socksProxy = Maybe SocksProxy
forall a. Maybe a
Nothing,
      $sel:tcpConnectTimeout:TransportClientConfig :: Int
tcpConnectTimeout = Int
defaultTcpConnectTimeout,
      $sel:tcpKeepAlive:TransportClientConfig :: Maybe KeepAliveOpts
tcpKeepAlive = KeepAliveOpts -> Maybe KeepAliveOpts
forall a. a -> Maybe a
Just KeepAliveOpts
defaultKeepAliveOpts,
      $sel:logTLSErrors:TransportClientConfig :: Bool
logTLSErrors = Bool
True,
      $sel:clientCredentials:TransportClientConfig :: Maybe Credential
clientCredentials = Maybe Credential
forall a. Maybe a
Nothing,
      $sel:clientALPN:TransportClientConfig :: Maybe [ByteString]
clientALPN = Maybe [ByteString]
forall a. Maybe a
Nothing,
      $sel:useSNI:TransportClientConfig :: Bool
useSNI = Bool
True
    }

clientTransportConfig :: TransportClientConfig -> TransportConfig
clientTransportConfig :: TransportClientConfig -> TransportConfig
clientTransportConfig TransportClientConfig {Bool
$sel:logTLSErrors:TransportClientConfig :: TransportClientConfig -> Bool
logTLSErrors :: Bool
logTLSErrors} =
  TransportConfig {Bool
logTLSErrors :: Bool
$sel:logTLSErrors:TransportConfig :: Bool
logTLSErrors, $sel:transportTimeout:TransportConfig :: Maybe Int
transportTimeout = Maybe Int
forall a. Maybe a
Nothing}

-- | Connect to passed TCP host:port and pass handle to the client.
runTransportClient :: Transport c => TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c 'TClient -> IO a) -> IO a
runTransportClient :: forall (c :: TransportPeer -> *) a.
Transport c =>
TransportClientConfig
-> Maybe SocksCredentials
-> TransportHost
-> HostName
-> Maybe KeyHash
-> (c 'TClient -> IO a)
-> IO a
runTransportClient = Supported
-> Maybe CertificateStore
-> TransportClientConfig
-> Maybe SocksCredentials
-> TransportHost
-> HostName
-> Maybe KeyHash
-> (c 'TClient -> IO a)
-> IO a
forall (c :: TransportPeer -> *) a.
Transport c =>
Supported
-> Maybe CertificateStore
-> TransportClientConfig
-> Maybe SocksCredentials
-> TransportHost
-> HostName
-> Maybe KeyHash
-> (c 'TClient -> IO a)
-> IO a
runTLSTransportClient Supported
defaultSupportedParams Maybe CertificateStore
forall a. Maybe a
Nothing

data ConnectionHandle c
  = CHSocket Socket
  | CHContext T.Context
  | CHTransport (c 'TClient)

runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c 'TClient -> IO a) -> IO a
runTLSTransportClient :: forall (c :: TransportPeer -> *) a.
Transport c =>
Supported
-> Maybe CertificateStore
-> TransportClientConfig
-> Maybe SocksCredentials
-> TransportHost
-> HostName
-> Maybe KeyHash
-> (c 'TClient -> IO a)
-> IO a
runTLSTransportClient Supported
tlsParams Maybe CertificateStore
caStore_ cfg :: TransportClientConfig
cfg@TransportClientConfig {Maybe SocksProxy
$sel:socksProxy:TransportClientConfig :: TransportClientConfig -> Maybe SocksProxy
socksProxy :: Maybe SocksProxy
socksProxy, Maybe KeepAliveOpts
$sel:tcpKeepAlive:TransportClientConfig :: TransportClientConfig -> Maybe KeepAliveOpts
tcpKeepAlive :: Maybe KeepAliveOpts
tcpKeepAlive, Maybe Credential
$sel:clientCredentials:TransportClientConfig :: TransportClientConfig -> Maybe Credential
clientCredentials :: Maybe Credential
clientCredentials, Maybe [ByteString]
$sel:clientALPN:TransportClientConfig :: TransportClientConfig -> Maybe [ByteString]
clientALPN :: Maybe [ByteString]
clientALPN, Bool
$sel:useSNI:TransportClientConfig :: TransportClientConfig -> Bool
useSNI :: Bool
useSNI} Maybe SocksCredentials
socksCreds TransportHost
host HostName
port Maybe KeyHash
keyHash c 'TClient -> IO a
client = do
  TMVar (Maybe CertificateChain)
serverCert <- IO (TMVar (Maybe CertificateChain))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  IORef Bool
clientCredsSent <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  let hostName :: HostName
hostName = ByteString -> HostName
B.unpack (ByteString -> HostName) -> ByteString -> HostName
forall a b. (a -> b) -> a -> b
$ TransportHost -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode TransportHost
host
      clientParams :: ClientParams
clientParams = Supported
-> Maybe CertificateStore
-> HostName
-> HostName
-> Maybe KeyHash
-> Maybe Credential
-> IORef Bool
-> Maybe [ByteString]
-> Bool
-> TMVar (Maybe CertificateChain)
-> ClientParams
mkTLSClientParams Supported
tlsParams Maybe CertificateStore
caStore_ HostName
hostName HostName
port Maybe KeyHash
keyHash Maybe Credential
clientCredentials IORef Bool
clientCredsSent Maybe [ByteString]
clientALPN Bool
useSNI TMVar (Maybe CertificateChain)
serverCert
      connectTCP :: HostName -> IO Socket
connectTCP = case Maybe SocksProxy
socksProxy of
        Just SocksProxy
proxy -> SocksProxy
-> Maybe SocksCredentials
-> SocksHostAddress
-> HostName
-> IO Socket
connectSocksClient SocksProxy
proxy Maybe SocksCredentials
socksCreds (TransportHost -> SocksHostAddress
hostAddr TransportHost
host)
        Maybe SocksProxy
_ -> HostName -> HostName -> IO Socket
connectTCPClient HostName
hostName
  IORef (Maybe (ConnectionHandle c))
h <- Maybe (ConnectionHandle c)
-> IO (IORef (Maybe (ConnectionHandle c)))
forall a. a -> IO (IORef a)
newIORef Maybe (ConnectionHandle c)
forall a. Maybe a
Nothing
  let set :: (b -> ConnectionHandle c) -> IO b -> IO b
set b -> ConnectionHandle c
hc = (IO b -> (b -> IO b) -> IO b
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
c -> IORef (Maybe (ConnectionHandle c))
-> Maybe (ConnectionHandle c) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (ConnectionHandle c))
h (ConnectionHandle c -> Maybe (ConnectionHandle c)
forall a. a -> Maybe a
Just (ConnectionHandle c -> Maybe (ConnectionHandle c))
-> ConnectionHandle c -> Maybe (ConnectionHandle c)
forall a b. (a -> b) -> a -> b
$ b -> ConnectionHandle c
hc b
c) IO () -> b -> IO b
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> b
c)
  IO Socket -> (Socket -> IO ()) -> (Socket -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket ((Socket -> ConnectionHandle c) -> IO Socket -> IO Socket
forall {b}. (b -> ConnectionHandle c) -> IO b -> IO b
set Socket -> ConnectionHandle c
forall (c :: TransportPeer -> *). Socket -> ConnectionHandle c
CHSocket (IO Socket -> IO Socket) -> IO Socket -> IO Socket
forall a b. (a -> b) -> a -> b
$ HostName -> IO Socket
connectTCP HostName
port) (\Socket
_ -> IORef (Maybe (ConnectionHandle c)) -> IO ()
closeConn IORef (Maybe (ConnectionHandle c))
h) ((Socket -> IO a) -> IO a) -> (Socket -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
    (KeepAliveOpts -> IO ()) -> Maybe KeepAliveOpts -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Socket -> KeepAliveOpts -> IO ()
setSocketKeepAlive Socket
sock) Maybe KeepAliveOpts
tcpKeepAlive IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchAll` \SomeException
e -> Text -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logError (Text
"Error setting TCP keep-alive " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
e)
    let tCfg :: TransportConfig
tCfg = TransportClientConfig -> TransportConfig
clientTransportConfig TransportClientConfig
cfg
    -- No TLS timeout to avoid failing connections via SOCKS
    Context
tls <- (Context -> ConnectionHandle c) -> IO Context -> IO Context
forall {b}. (b -> ConnectionHandle c) -> IO b -> IO b
set Context -> ConnectionHandle c
forall (c :: TransportPeer -> *). Context -> ConnectionHandle c
CHContext (IO Context -> IO Context) -> IO Context -> IO Context
forall a b. (a -> b) -> a -> b
$ Maybe HostName
-> TransportConfig -> ClientParams -> Socket -> IO Context
forall p.
TLSParams p =>
Maybe HostName -> TransportConfig -> p -> Socket -> IO Context
connectTLS (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
hostName) TransportConfig
tCfg ClientParams
clientParams Socket
sock
    CertificateChain
chain <- TMVar (Maybe CertificateChain) -> IO CertificateChain
takePeerCertChain TMVar (Maybe CertificateChain)
serverCert
    Bool
sent <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
clientCredsSent
    c 'TClient -> IO a
client (c 'TClient -> IO a) -> IO (c 'TClient) -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (c 'TClient -> ConnectionHandle c)
-> IO (c 'TClient) -> IO (c 'TClient)
forall {b}. (b -> ConnectionHandle c) -> IO b -> IO b
set c 'TClient -> ConnectionHandle c
forall (c :: TransportPeer -> *). c 'TClient -> ConnectionHandle c
CHTransport (TransportConfig
-> Bool -> CertificateChain -> Context -> IO (c 'TClient)
forall (p :: TransportPeer).
TransportPeerI p =>
TransportConfig -> Bool -> CertificateChain -> Context -> IO (c p)
forall (c :: TransportPeer -> *) (p :: TransportPeer).
(Transport c, TransportPeerI p) =>
TransportConfig -> Bool -> CertificateChain -> Context -> IO (c p)
getTransportConnection TransportConfig
tCfg Bool
sent CertificateChain
chain Context
tls)
  where
    closeConn :: IORef (Maybe (ConnectionHandle c)) -> IO ()
closeConn = IORef (Maybe (ConnectionHandle c))
-> IO (Maybe (ConnectionHandle c))
forall a. IORef a -> IO a
readIORef (IORef (Maybe (ConnectionHandle c))
 -> IO (Maybe (ConnectionHandle c)))
-> (Maybe (ConnectionHandle c) -> IO ())
-> IORef (Maybe (ConnectionHandle c))
-> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ConnectionHandle c -> IO ())
-> Maybe (ConnectionHandle c) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ConnectionHandle c
c -> IO () -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
E.uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConnectionHandle c -> IO ()
closeConn_ ConnectionHandle c
c IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchAll_` () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    closeConn_ :: ConnectionHandle c -> IO ()
closeConn_ = \case
      CHSocket Socket
sock -> Socket -> IO ()
close Socket
sock
      CHContext Context
tls -> Context -> IO ()
closeTLS Context
tls
      CHTransport c 'TClient
c -> c 'TClient -> IO ()
forall (p :: TransportPeer). c p -> IO ()
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> IO ()
closeConnection c 'TClient
c
    hostAddr :: TransportHost -> SocksHostAddress
hostAddr = \case
      THIPv4 (Word8, Word8, Word8, Word8)
addr -> Word32 -> SocksHostAddress
SocksAddrIPV4 (Word32 -> SocksHostAddress) -> Word32 -> SocksHostAddress
forall a b. (a -> b) -> a -> b
$ (Word8, Word8, Word8, Word8) -> Word32
tupleToHostAddress (Word8, Word8, Word8, Word8)
addr
      THIPv6 (Word32, Word32, Word32, Word32)
addr -> (Word32, Word32, Word32, Word32) -> SocksHostAddress
SocksAddrIPV6 (Word32, Word32, Word32, Word32)
addr
      THOnionHost ByteString
h -> ByteString -> SocksHostAddress
SocksAddrDomainName ByteString
h
      THDomainName HostName
h -> ByteString -> SocksHostAddress
SocksAddrDomainName (ByteString -> SocksHostAddress) -> ByteString -> SocksHostAddress
forall a b. (a -> b) -> a -> b
$ HostName -> ByteString
B.pack HostName
h

connectTCPClient :: HostName -> ServiceName -> IO Socket
connectTCPClient :: HostName -> HostName -> IO Socket
connectTCPClient HostName
host HostName
port = IO Socket -> IO Socket
forall a. IO a -> IO a
withSocketsDo (IO Socket -> IO Socket) -> IO Socket -> IO Socket
forall a b. (a -> b) -> a -> b
$ IO [AddrInfo]
resolve IO [AddrInfo] -> ([AddrInfo] -> IO Socket) -> IO Socket
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IOException -> [AddrInfo] -> IO Socket
tryOpen IOException
err
  where
    err :: IOException
    err :: IOException
err = IOErrorType
-> HostName -> Maybe Handle -> Maybe HostName -> IOException
mkIOError IOErrorType
NoSuchThing HostName
"no address" Maybe Handle
forall a. Maybe a
Nothing Maybe HostName
forall a. Maybe a
Nothing

    resolve :: IO [AddrInfo]
    resolve :: IO [AddrInfo]
resolve =
      let hints :: AddrInfo
hints = AddrInfo
defaultHints {addrSocketType = Stream}
       in Maybe AddrInfo -> Maybe HostName -> Maybe HostName -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
host) (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
port)

    tryOpen :: IOException -> [AddrInfo] -> IO Socket
    tryOpen :: IOException -> [AddrInfo] -> IO Socket
tryOpen IOException
e [] = IOException -> IO Socket
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO IOException
e
    tryOpen IOException
_ (AddrInfo
addr : [AddrInfo]
as) =
      IO Socket -> IO (Either IOException Socket)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
E.try (AddrInfo -> IO Socket
open AddrInfo
addr) IO (Either IOException Socket)
-> (Either IOException Socket -> IO Socket) -> IO Socket
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IOException -> IO Socket)
-> (Socket -> IO Socket) -> Either IOException Socket -> IO Socket
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IOException -> [AddrInfo] -> IO Socket
`tryOpen` [AddrInfo]
as) Socket -> IO Socket
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    open :: AddrInfo -> IO Socket
    open :: AddrInfo -> IO Socket
open AddrInfo
addr =
      IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracketOnError
        (Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr))
        Socket -> IO ()
close
        (\Socket
sock -> Socket -> SockAddr -> IO ()
connect Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
addr) IO () -> Socket -> IO Socket
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Socket
sock)

defaultSMPPort :: PortNumber
defaultSMPPort :: PortNumber
defaultSMPPort = PortNumber
5223

connectSocksClient :: SocksProxy -> Maybe SocksCredentials -> SocksHostAddress -> ServiceName -> IO Socket
connectSocksClient :: SocksProxy
-> Maybe SocksCredentials
-> SocksHostAddress
-> HostName
-> IO Socket
connectSocksClient (SocksProxy SockAddr
addr) Maybe SocksCredentials
socksCreds SocksHostAddress
hostAddr HostName
_port = do
  let port :: PortNumber
port = if HostName -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null HostName
_port then PortNumber
defaultSMPPort else PortNumber -> Maybe PortNumber -> PortNumber
forall a. a -> Maybe a -> a
fromMaybe PortNumber
defaultSMPPort (Maybe PortNumber -> PortNumber) -> Maybe PortNumber -> PortNumber
forall a b. (a -> b) -> a -> b
$ HostName -> Maybe PortNumber
forall a. Read a => HostName -> Maybe a
readMaybe HostName
_port
  (Socket, (SocksHostAddress, PortNumber)) -> Socket
forall a b. (a, b) -> a
fst ((Socket, (SocksHostAddress, PortNumber)) -> Socket)
-> IO (Socket, (SocksHostAddress, PortNumber)) -> IO Socket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe SocksCredentials
socksCreds of
    Just SocksCredentials
creds -> SocksConf
-> SocksAddress
-> SocksCredentials
-> IO (Socket, (SocksHostAddress, PortNumber))
socksConnectAuth (SockAddr -> SocksConf
defaultSocksConf SockAddr
addr) (SocksHostAddress -> PortNumber -> SocksAddress
SocksAddress SocksHostAddress
hostAddr PortNumber
port) SocksCredentials
creds
    Maybe SocksCredentials
_ -> SocksConf
-> SocksAddress -> IO (Socket, (SocksHostAddress, PortNumber))
socksConnect (SockAddr -> SocksConf
defaultSocksConf SockAddr
addr) (SocksHostAddress -> PortNumber -> SocksAddress
SocksAddress SocksHostAddress
hostAddr PortNumber
port)

defaultSocksHost :: (Word8, Word8, Word8, Word8)
defaultSocksHost :: (Word8, Word8, Word8, Word8)
defaultSocksHost = (Word8
127, Word8
0, Word8
0, Word8
1)

defaultSocksProxyWithAuth :: SocksProxyWithAuth
defaultSocksProxyWithAuth :: SocksProxyWithAuth
defaultSocksProxyWithAuth = SocksAuth -> SocksProxy -> SocksProxyWithAuth
SocksProxyWithAuth SocksAuth
SocksIsolateByAuth SocksProxy
defaultSocksProxy

defaultSocksProxy :: SocksProxy
defaultSocksProxy :: SocksProxy
defaultSocksProxy = SockAddr -> SocksProxy
SocksProxy (SockAddr -> SocksProxy) -> SockAddr -> SocksProxy
forall a b. (a -> b) -> a -> b
$ PortNumber -> Word32 -> SockAddr
SockAddrInet PortNumber
9050 (Word32 -> SockAddr) -> Word32 -> SockAddr
forall a b. (a -> b) -> a -> b
$ (Word8, Word8, Word8, Word8) -> Word32
tupleToHostAddress (Word8, Word8, Word8, Word8)
defaultSocksHost

newtype SocksProxy = SocksProxy SockAddr
  deriving (SocksProxy -> SocksProxy -> Bool
(SocksProxy -> SocksProxy -> Bool)
-> (SocksProxy -> SocksProxy -> Bool) -> Eq SocksProxy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocksProxy -> SocksProxy -> Bool
== :: SocksProxy -> SocksProxy -> Bool
$c/= :: SocksProxy -> SocksProxy -> Bool
/= :: SocksProxy -> SocksProxy -> Bool
Eq)

data SocksProxyWithAuth = SocksProxyWithAuth SocksAuth SocksProxy
  deriving (SocksProxyWithAuth -> SocksProxyWithAuth -> Bool
(SocksProxyWithAuth -> SocksProxyWithAuth -> Bool)
-> (SocksProxyWithAuth -> SocksProxyWithAuth -> Bool)
-> Eq SocksProxyWithAuth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocksProxyWithAuth -> SocksProxyWithAuth -> Bool
== :: SocksProxyWithAuth -> SocksProxyWithAuth -> Bool
$c/= :: SocksProxyWithAuth -> SocksProxyWithAuth -> Bool
/= :: SocksProxyWithAuth -> SocksProxyWithAuth -> Bool
Eq, Int -> SocksProxyWithAuth -> ShowS
[SocksProxyWithAuth] -> ShowS
SocksProxyWithAuth -> HostName
(Int -> SocksProxyWithAuth -> ShowS)
-> (SocksProxyWithAuth -> HostName)
-> ([SocksProxyWithAuth] -> ShowS)
-> Show SocksProxyWithAuth
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocksProxyWithAuth -> ShowS
showsPrec :: Int -> SocksProxyWithAuth -> ShowS
$cshow :: SocksProxyWithAuth -> HostName
show :: SocksProxyWithAuth -> HostName
$cshowList :: [SocksProxyWithAuth] -> ShowS
showList :: [SocksProxyWithAuth] -> ShowS
Show)

data SocksAuth
  = SocksAuthUsername {SocksAuth -> ByteString
username :: ByteString, SocksAuth -> ByteString
password :: ByteString}
  | SocksAuthNull
  | SocksIsolateByAuth -- this is default
  deriving (SocksAuth -> SocksAuth -> Bool
(SocksAuth -> SocksAuth -> Bool)
-> (SocksAuth -> SocksAuth -> Bool) -> Eq SocksAuth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocksAuth -> SocksAuth -> Bool
== :: SocksAuth -> SocksAuth -> Bool
$c/= :: SocksAuth -> SocksAuth -> Bool
/= :: SocksAuth -> SocksAuth -> Bool
Eq, Int -> SocksAuth -> ShowS
[SocksAuth] -> ShowS
SocksAuth -> HostName
(Int -> SocksAuth -> ShowS)
-> (SocksAuth -> HostName)
-> ([SocksAuth] -> ShowS)
-> Show SocksAuth
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocksAuth -> ShowS
showsPrec :: Int -> SocksAuth -> ShowS
$cshow :: SocksAuth -> HostName
show :: SocksAuth -> HostName
$cshowList :: [SocksAuth] -> ShowS
showList :: [SocksAuth] -> ShowS
Show)

instance Show SocksProxy where show :: SocksProxy -> HostName
show (SocksProxy SockAddr
addr) = SockAddr -> HostName
forall a. Show a => a -> HostName
show SockAddr
addr

instance StrEncoding SocksProxy where
  strEncode :: SocksProxy -> ByteString
strEncode = HostName -> ByteString
B.pack (HostName -> ByteString)
-> (SocksProxy -> HostName) -> SocksProxy -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SocksProxy -> HostName
forall a. Show a => a -> HostName
show
  strP :: Parser SocksProxy
strP = do
    TransportHost
host <- TransportHost -> Maybe TransportHost -> TransportHost
forall a. a -> Maybe a -> a
fromMaybe ((Word8, Word8, Word8, Word8) -> TransportHost
THIPv4 (Word8, Word8, Word8, Word8)
defaultSocksHost) (Maybe TransportHost -> TransportHost)
-> Parser ByteString (Maybe TransportHost) -> Parser TransportHost
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TransportHost -> Parser ByteString (Maybe TransportHost)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser TransportHost
forall a. StrEncoding a => Parser a
strP
    PortNumber
port <- PortNumber -> Maybe PortNumber -> PortNumber
forall a. a -> Maybe a -> a
fromMaybe PortNumber
9050 (Maybe PortNumber -> PortNumber)
-> Parser ByteString (Maybe PortNumber)
-> Parser ByteString PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString PortNumber
-> Parser ByteString (Maybe PortNumber)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser ByteString Char
A.char Char
':' Parser ByteString Char
-> Parser ByteString PortNumber -> Parser ByteString PortNumber
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger (Integer -> PortNumber)
-> Parser ByteString Integer -> Parser ByteString PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Integer
forall a. Integral a => Parser a
A.decimal))
    SockAddr -> SocksProxy
SocksProxy (SockAddr -> SocksProxy)
-> Parser ByteString SockAddr -> Parser SocksProxy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PortNumber -> TransportHost -> Parser ByteString SockAddr
forall {f :: * -> *}.
MonadFail f =>
PortNumber -> TransportHost -> f SockAddr
socksAddr PortNumber
port TransportHost
host
    where
      socksAddr :: PortNumber -> TransportHost -> f SockAddr
socksAddr PortNumber
port = \case
        THIPv4 (Word8, Word8, Word8, Word8)
addr -> SockAddr -> f SockAddr
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SockAddr -> f SockAddr) -> SockAddr -> f SockAddr
forall a b. (a -> b) -> a -> b
$ PortNumber -> Word32 -> SockAddr
SockAddrInet PortNumber
port (Word32 -> SockAddr) -> Word32 -> SockAddr
forall a b. (a -> b) -> a -> b
$ (Word8, Word8, Word8, Word8) -> Word32
tupleToHostAddress (Word8, Word8, Word8, Word8)
addr
        THIPv6 (Word32, Word32, Word32, Word32)
addr -> SockAddr -> f SockAddr
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SockAddr -> f SockAddr) -> SockAddr -> f SockAddr
forall a b. (a -> b) -> a -> b
$ PortNumber
-> Word32 -> (Word32, Word32, Word32, Word32) -> Word32 -> SockAddr
SockAddrInet6 PortNumber
port Word32
0 (Word32, Word32, Word32, Word32)
addr Word32
0
        TransportHost
_ -> HostName -> f SockAddr
forall a. HostName -> f a
forall (m :: * -> *) a. MonadFail m => HostName -> m a
fail HostName
"SOCKS5 host should be IPv4 or IPv6 address"

instance StrEncoding SocksProxyWithAuth where
  strEncode :: SocksProxyWithAuth -> ByteString
strEncode (SocksProxyWithAuth SocksAuth
auth SocksProxy
proxy) = SocksAuth -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode SocksAuth
auth ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> SocksProxy -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode SocksProxy
proxy
  strP :: Parser SocksProxyWithAuth
strP = SocksAuth -> SocksProxy -> SocksProxyWithAuth
SocksProxyWithAuth (SocksAuth -> SocksProxy -> SocksProxyWithAuth)
-> Parser ByteString SocksAuth
-> Parser ByteString (SocksProxy -> SocksProxyWithAuth)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString SocksAuth
forall a. StrEncoding a => Parser a
strP Parser ByteString (SocksProxy -> SocksProxyWithAuth)
-> Parser SocksProxy -> Parser SocksProxyWithAuth
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser SocksProxy
forall a. StrEncoding a => Parser a
strP

instance ToJSON SocksProxyWithAuth where
  toJSON :: SocksProxyWithAuth -> Value
toJSON = SocksProxyWithAuth -> Value
forall a. StrEncoding a => a -> Value
strToJSON
  toEncoding :: SocksProxyWithAuth -> Encoding
toEncoding = SocksProxyWithAuth -> Encoding
forall a. StrEncoding a => a -> Encoding
strToJEncoding

instance FromJSON SocksProxyWithAuth where
  parseJSON :: Value -> Parser SocksProxyWithAuth
parseJSON = HostName -> Value -> Parser SocksProxyWithAuth
forall a. StrEncoding a => HostName -> Value -> Parser a
strParseJSON HostName
"SocksProxyWithAuth"

instance StrEncoding SocksAuth where
  strEncode :: SocksAuth -> ByteString
strEncode = \case
    SocksAuthUsername {ByteString
$sel:username:SocksAuthUsername :: SocksAuth -> ByteString
username :: ByteString
username, ByteString
$sel:password:SocksAuthUsername :: SocksAuth -> ByteString
password :: ByteString
password} -> ByteString
username ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
password ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"@"
    SocksAuth
SocksAuthNull -> ByteString
"@"
    SocksAuth
SocksIsolateByAuth -> ByteString
""
  strP :: Parser ByteString SocksAuth
strP = Parser ByteString SocksAuth
usernameP Parser ByteString SocksAuth
-> Parser ByteString SocksAuth -> Parser ByteString SocksAuth
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (SocksAuth
SocksAuthNull SocksAuth -> Parser ByteString Char -> Parser ByteString SocksAuth
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
A.char Char
'@') Parser ByteString SocksAuth
-> Parser ByteString SocksAuth -> Parser ByteString SocksAuth
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SocksAuth -> Parser ByteString SocksAuth
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SocksAuth
SocksIsolateByAuth
    where
      usernameP :: Parser ByteString SocksAuth
usernameP = do
        ByteString
username <- (Char -> Bool) -> Parser ByteString ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Parser ByteString ByteString
-> Parser ByteString Char -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
A.char Char
':'
        ByteString
password <- (Char -> Bool) -> Parser ByteString ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@') Parser ByteString ByteString
-> Parser ByteString Char -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
A.char Char
'@'
        SocksAuth -> Parser ByteString SocksAuth
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SocksAuthUsername {ByteString
$sel:username:SocksAuthUsername :: ByteString
username :: ByteString
username, ByteString
$sel:password:SocksAuthUsername :: ByteString
password :: ByteString
password}

mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe T.Credential -> IORef Bool -> Maybe [ALPN] -> Bool -> TMVar (Maybe X.CertificateChain) -> T.ClientParams
mkTLSClientParams :: Supported
-> Maybe CertificateStore
-> HostName
-> HostName
-> Maybe KeyHash
-> Maybe Credential
-> IORef Bool
-> Maybe [ByteString]
-> Bool
-> TMVar (Maybe CertificateChain)
-> ClientParams
mkTLSClientParams Supported
supported Maybe CertificateStore
caStore_ HostName
host HostName
port Maybe KeyHash
cafp_ Maybe Credential
clientCreds_ IORef Bool
clientCredsSent Maybe [ByteString]
alpn_ Bool
sni TMVar (Maybe CertificateChain)
serverCerts =
  (HostName -> ByteString -> ClientParams
T.defaultParamsClient HostName
host ByteString
p)
    { T.clientUseServerNameIndication = sni,
      T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
      T.clientHooks =
        def
          { T.onServerCertificate = onServerCert,
            T.onCertificateRequest = onCertRequest,
            T.onSuggestALPN = pure alpn_
          },
      T.clientSupported = supported
    }
  where
    p :: ByteString
p = HostName -> ByteString
B.pack HostName
port
    onServerCert :: p -> p -> p -> CertificateChain -> IO [FailedReason]
onServerCert p
_ p
_ p
_ CertificateChain
cc = do
      [FailedReason]
errs <- IO [FailedReason]
-> (KeyHash -> IO [FailedReason])
-> Maybe KeyHash
-> IO [FailedReason]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO [FailedReason]
forall a. Default a => a
def (\KeyHash
ca -> KeyHash
-> HostName -> ByteString -> CertificateChain -> IO [FailedReason]
validateCertificateChain KeyHash
ca HostName
host ByteString
p CertificateChain
cc) Maybe KeyHash
cafp_
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe CertificateChain) -> Maybe CertificateChain -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Maybe CertificateChain)
serverCerts (Maybe CertificateChain -> STM ())
-> Maybe CertificateChain -> STM ()
forall a b. (a -> b) -> a -> b
$ if [FailedReason] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FailedReason]
errs then CertificateChain -> Maybe CertificateChain
forall a. a -> Maybe a
Just CertificateChain
cc else Maybe CertificateChain
forall a. Maybe a
Nothing
      [FailedReason] -> IO [FailedReason]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FailedReason]
errs
    onCertRequest :: p -> IO (Maybe Credential)
onCertRequest = case Maybe Credential
clientCreds_ of
      Just Credential
_ -> \p
_ -> Maybe Credential
clientCreds_ Maybe Credential -> IO () -> IO (Maybe Credential)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
clientCredsSent Bool
True
      Maybe Credential
Nothing -> \p
_ -> Maybe Credential -> IO (Maybe Credential)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Credential
forall a. Maybe a
Nothing

validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]
validateCertificateChain :: KeyHash
-> HostName -> ByteString -> CertificateChain -> IO [FailedReason]
validateCertificateChain (C.KeyHash ByteString
kh) HostName
host ByteString
port CertificateChain
cc = case CertificateChain -> ChainCertificates
chainIdCaCerts CertificateChain
cc of
  ChainCertificates
CCEmpty -> [FailedReason] -> IO [FailedReason]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FailedReason
XV.EmptyChain]
  CCSelf SignedCertificate
_ -> [FailedReason] -> IO [FailedReason]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FailedReason
XV.EmptyChain]
  CCValid {SignedCertificate
idCert :: SignedCertificate
idCert :: ChainCertificates -> SignedCertificate
idCert, SignedCertificate
caCert :: SignedCertificate
caCert :: ChainCertificates -> SignedCertificate
caCert} -> SignedCertificate -> SignedCertificate -> IO [FailedReason]
forall {a}.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> SignedCertificate -> IO [FailedReason]
validate SignedCertificate
idCert SignedCertificate
caCert
  ChainCertificates
CCLong -> [FailedReason] -> IO [FailedReason]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FailedReason
XV.AuthorityTooDeep]
  where
    validate :: SignedExact a -> SignedCertificate -> IO [FailedReason]
validate SignedExact a
idCert SignedCertificate
caCert
      | ByteString -> Fingerprint
Fingerprint ByteString
kh Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== SignedExact a -> HashALG -> Fingerprint
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> HashALG -> Fingerprint
XV.getFingerprint SignedExact a
idCert HashALG
X.HashSHA256 = SignedCertificate
-> ServiceID -> CertificateChain -> IO [FailedReason]
x509validate SignedCertificate
caCert (HostName
host, ByteString
port) CertificateChain
cc
      | Bool
otherwise = [FailedReason] -> IO [FailedReason]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FailedReason
XV.UnknownCA]