{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Simplex.Messaging.Client
-- Copyright   : (c) simplex.chat
-- License     : AGPL-3
--
-- Maintainer  : chat@simplex.chat
-- Stability   : experimental
-- Portability : non-portable
--
-- This module provides a functional client API for SMP protocol.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
module Simplex.Messaging.Client
  ( -- * Connect (disconnect) client to (from) SMP server
    TransportSession,
    SMPTransportSession,
    ProtocolClient (thParams, sessionTs),
    SMPClient,
    ProxiedRelay (..),
    getProtocolClient,
    closeProtocolClient,
    protocolClientServer,
    protocolClientServer',
    transportHost',
    transportSession',
    useWebPort,
    isPresetDomain,

    -- * SMP protocol command functions
    createSMPQueue,
    subscribeSMPQueue,
    subscribeSMPQueues,
    streamSubscribeSMPQueues,
    getSMPMessage,
    subscribeSMPQueueNotifications,
    subscribeSMPQueuesNtfs,
    subscribeService,
    smpClientService,
    secureSMPQueue,
    secureSndSMPQueue,
    proxySecureSndSMPQueue,
    addSMPQueueLink,
    deleteSMPQueueLink,
    secureGetSMPQueueLink,
    proxySecureGetSMPQueueLink,
    getSMPQueueLink,
    proxyGetSMPQueueLink,
    enableSMPQueueNotifications,
    disableSMPQueueNotifications,
    enableSMPQueuesNtfs,
    disableSMPQueuesNtfs,
    sendSMPMessage,
    ackSMPMessage,
    suspendSMPQueue,
    deleteSMPQueue,
    deleteSMPQueues,
    connectSMPProxiedRelay,
    proxySMPMessage,
    forwardSMPTransmission,
    getSMPQueueInfo,
    sendProtocolCommand,
    sendProtocolCommands,

    -- * Supporting types and client configuration
    ProtocolClientError (..),
    SMPClientError,
    ProxyClientError (..),
    Response (..),
    unexpectedResponse,
    ProtocolClientConfig (..),
    NetworkConfig (..),
    NetworkTimeout (..),
    NetworkRequestMode (..),
    pattern NRMInteractive,
    TransportSessionMode (..),
    HostMode (..),
    SocksMode (..),
    SMPProxyMode (..),
    SMPProxyFallback (..),
    SMPWebPortServers (..),
    netTimeoutInt,
    defaultClientConfig,
    defaultSMPClientConfig,
    defaultNetworkConfig,
    transportClientConfig,
    clientSocksCredentials,
    chooseTransportHost,
    temporaryClientError,
    smpClientServiceError,
    smpProxyError,
    smpErrorClientNotice,
    textToHostMode,
    ServerTransmissionBatch,
    ServerTransmission (..),
    ClientCommand,

    -- * For testing
    PCTransmission,
    mkTransmission,
    authTransmission,
    smpClientStub,

    -- * For debugging
    TBQueueInfo (..),
    getTBQueueInfo,
    getProtocolClientQueuesInfo,
    nonBlockingWriteTBQueue,
  )
where

import Control.Applicative ((<|>))
import Control.Concurrent (ThreadId, forkFinally, forkIO, killThread, mkWeakThreadId)
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson.TH as J
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Base64 as B64
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (find, isSuffixOf)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
import Network.Socket (HostName, ServiceName)
import Network.Socks5 (SocksCredentials (..))
import Numeric.Natural
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
import Simplex.Messaging.Protocol
import Simplex.Messaging.Protocol.Types
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, runTransportClient)
import Simplex.Messaging.Transport.HTTP2 (httpALPN11)
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Transport.Shared (ChainCertificates (..), chainIdCaCerts, x509validate)
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import System.Mem.Weak (Weak, deRefWeak)
import System.Timeout (timeout)

-- | 'SMPClient' is a handle used to send commands to a specific SMP server.
--
-- Use 'getSMPClient' to connect to an SMP server and create a client handle.
data ProtocolClient v err msg = ProtocolClient
  { forall v err msg. ProtocolClient v err msg -> Maybe (Weak ThreadId)
action :: Maybe (Weak ThreadId),
    forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams :: THandleParams v 'TClient,
    forall v err msg. ProtocolClient v err msg -> UTCTime
sessionTs :: UTCTime,
    forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ :: PClient v err msg
  }

data PClient v err msg = PClient
  { forall v err msg. PClient v err msg -> TVar Bool
connected :: TVar Bool,
    forall v err msg. PClient v err msg -> TransportSession msg
transportSession :: TransportSession msg,
    forall v err msg. PClient v err msg -> TransportHost
transportHost :: TransportHost,
    forall v err msg. PClient v err msg -> NetworkTimeout
tcpConnectTimeout :: NetworkTimeout,
    forall v err msg. PClient v err msg -> NetworkTimeout
tcpTimeout :: NetworkTimeout,
    forall v err msg. PClient v err msg -> TVar Bool
sendPings :: TVar Bool,
    forall v err msg. PClient v err msg -> TVar UTCTime
lastReceived :: TVar UTCTime,
    forall v err msg. PClient v err msg -> TVar Int
timeoutErrorCount :: TVar Int,
    forall v err msg. PClient v err msg -> TVar ChaChaDRG
clientCorrId :: TVar ChaChaDRG,
    forall v err msg.
PClient v err msg -> TMap CorrId (Request err msg)
sentCommands :: TMap CorrId (Request err msg),
    forall v err msg.
PClient v err msg -> TBQueue (Maybe (Request err msg), ByteString)
sndQ :: TBQueue (Maybe (Request err msg), ByteString),
    forall v err msg.
PClient v err msg
-> TBQueue (NonEmpty (Transmission (Either err msg)))
rcvQ :: TBQueue (NonEmpty (Transmission (Either err msg))),
    forall v err msg.
PClient v err msg
-> Maybe (TBQueue (ServerTransmissionBatch v err msg))
msgQ :: Maybe (TBQueue (ServerTransmissionBatch v err msg))
  }

smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe (THandleAuth 'TClient) -> IO SMPClient
smpClientStub :: TVar ChaChaDRG
-> ByteString
-> Version SMPVersion
-> Maybe (THandleAuth 'TClient)
-> IO SMPClient
smpClientStub TVar ChaChaDRG
g ByteString
sessionId Version SMPVersion
thVersion Maybe (THandleAuth 'TClient)
thAuth = do
  let ts :: UTCTime
ts = Day -> DiffTime -> UTCTime
UTCTime (String -> Day
forall a. Read a => String -> a
read String
"2024-03-31") DiffTime
0
  TVar Bool
connected <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
  TVar ChaChaDRG
clientCorrId <- STM (TVar ChaChaDRG) -> IO (TVar ChaChaDRG)
forall a. STM a -> IO a
atomically (STM (TVar ChaChaDRG) -> IO (TVar ChaChaDRG))
-> STM (TVar ChaChaDRG) -> IO (TVar ChaChaDRG)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (TVar ChaChaDRG)
C.newRandomDRG TVar ChaChaDRG
g
  TMap CorrId (Request ErrorType BrokerMsg)
sentCommands <- IO (TMap CorrId (Request ErrorType BrokerMsg))
forall k a. IO (TMap k a)
TM.emptyIO
  TVar Bool
sendPings <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
  TVar UTCTime
lastReceived <- UTCTime -> IO (TVar UTCTime)
forall a. a -> IO (TVar a)
newTVarIO UTCTime
ts
  TVar Int
timeoutErrorCount <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0
  TBQueue (Maybe (Request ErrorType BrokerMsg), ByteString)
sndQ <- Natural
-> IO (TBQueue (Maybe (Request ErrorType BrokerMsg), ByteString))
forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
100
  TBQueue (NonEmpty (Transmission (Either ErrorType BrokerMsg)))
rcvQ <- Natural
-> IO
     (TBQueue (NonEmpty (Transmission (Either ErrorType BrokerMsg))))
forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
100
  let NetworkConfig {NetworkTimeout
tcpConnectTimeout :: NetworkTimeout
$sel:tcpConnectTimeout:NetworkConfig :: NetworkConfig -> NetworkTimeout
tcpConnectTimeout, NetworkTimeout
tcpTimeout :: NetworkTimeout
$sel:tcpTimeout:NetworkConfig :: NetworkConfig -> NetworkTimeout
tcpTimeout} = NetworkConfig
defaultNetworkConfig
  SMPClient -> IO SMPClient
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ProtocolClient
      { $sel:action:ProtocolClient :: Maybe (Weak ThreadId)
action = Maybe (Weak ThreadId)
forall a. Maybe a
Nothing,
        $sel:thParams:ProtocolClient :: THandleParams SMPVersion 'TClient
thParams =
          THandleParams
            { ByteString
sessionId :: ByteString
$sel:sessionId:THandleParams :: ByteString
sessionId,
              Version SMPVersion
thVersion :: Version SMPVersion
$sel:thVersion:THandleParams :: Version SMPVersion
thVersion,
              $sel:thServerVRange:THandleParams :: VersionRangeSMP
thServerVRange = VersionRangeSMP
supportedServerSMPRelayVRange,
              Maybe (THandleAuth 'TClient)
thAuth :: Maybe (THandleAuth 'TClient)
$sel:thAuth:THandleParams :: Maybe (THandleAuth 'TClient)
thAuth,
              $sel:blockSize:THandleParams :: Int
blockSize = Int
smpBlockSize,
              $sel:implySessId:THandleParams :: Bool
implySessId = Version SMPVersion
thVersion Version SMPVersion -> Version SMPVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version SMPVersion
authCmdsSMPVersion,
              $sel:encryptBlock:THandleParams :: Maybe TSbChainKeys
encryptBlock = Maybe TSbChainKeys
forall a. Maybe a
Nothing,
              $sel:batch:THandleParams :: Bool
batch = Bool
True,
              $sel:serviceAuth:THandleParams :: Bool
serviceAuth = Version SMPVersion
thVersion Version SMPVersion -> Version SMPVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version SMPVersion
serviceCertsSMPVersion
            },
        $sel:sessionTs:ProtocolClient :: UTCTime
sessionTs = UTCTime
ts,
        $sel:client_:ProtocolClient :: PClient SMPVersion ErrorType BrokerMsg
client_ =
          PClient
            { TVar Bool
$sel:connected:PClient :: TVar Bool
connected :: TVar Bool
connected,
              $sel:transportSession:PClient :: TransportSession BrokerMsg
transportSession = (Int64
1, ProtocolServer (ProtoType BrokerMsg)
ProtocolServer 'PSMP
"smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Maybe ByteString
forall a. Maybe a
Nothing),
              $sel:transportHost:PClient :: TransportHost
transportHost = TransportHost
"localhost",
              NetworkTimeout
$sel:tcpConnectTimeout:PClient :: NetworkTimeout
tcpConnectTimeout :: NetworkTimeout
tcpConnectTimeout,
              NetworkTimeout
$sel:tcpTimeout:PClient :: NetworkTimeout
tcpTimeout :: NetworkTimeout
tcpTimeout,
              TVar Bool
$sel:sendPings:PClient :: TVar Bool
sendPings :: TVar Bool
sendPings,
              TVar UTCTime
$sel:lastReceived:PClient :: TVar UTCTime
lastReceived :: TVar UTCTime
lastReceived,
              TVar Int
$sel:timeoutErrorCount:PClient :: TVar Int
timeoutErrorCount :: TVar Int
timeoutErrorCount,
              TVar ChaChaDRG
$sel:clientCorrId:PClient :: TVar ChaChaDRG
clientCorrId :: TVar ChaChaDRG
clientCorrId,
              TMap CorrId (Request ErrorType BrokerMsg)
$sel:sentCommands:PClient :: TMap CorrId (Request ErrorType BrokerMsg)
sentCommands :: TMap CorrId (Request ErrorType BrokerMsg)
sentCommands,
              TBQueue (Maybe (Request ErrorType BrokerMsg), ByteString)
$sel:sndQ:PClient :: TBQueue (Maybe (Request ErrorType BrokerMsg), ByteString)
sndQ :: TBQueue (Maybe (Request ErrorType BrokerMsg), ByteString)
sndQ,
              TBQueue (NonEmpty (Transmission (Either ErrorType BrokerMsg)))
$sel:rcvQ:PClient :: TBQueue (NonEmpty (Transmission (Either ErrorType BrokerMsg)))
rcvQ :: TBQueue (NonEmpty (Transmission (Either ErrorType BrokerMsg)))
rcvQ,
              $sel:msgQ:PClient :: Maybe
  (TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg))
msgQ = Maybe
  (TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg))
Maybe
  (TBQueue
     ((Int64, ProtocolServer 'PSMP, Maybe ByteString),
      Version SMPVersion, ByteString,
      NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg)))
forall a. Maybe a
Nothing
            }
      }

type SMPClient = ProtocolClient SMPVersion ErrorType BrokerMsg

-- | Type for client command data
type ClientCommand msg = (EntityId, Maybe C.APrivateAuthKey, ProtoCommand msg)

-- | Type synonym for transmission from SPM servers.
-- Batch response is presented as a single `ServerTransmissionBatch` tuple.
type ServerTransmissionBatch v err msg = (TransportSession msg, Version v, SessionId, NonEmpty (EntityId, ServerTransmission err msg))

data ServerTransmission err msg
  = STEvent (Either (ProtocolClientError err) msg)
  | STResponse (ProtoCommand msg) (Either (ProtocolClientError err) msg)
  | STUnexpectedError (ProtocolClientError err)

data HostMode
  = -- | prefer (or require) onion hosts when connecting via SOCKS proxy
    HMOnionViaSocks
  | -- | prefer (or require) onion hosts
    HMOnion
  | -- | prefer (or require) public hosts
    HMPublic
  deriving (HostMode -> HostMode -> Bool
(HostMode -> HostMode -> Bool)
-> (HostMode -> HostMode -> Bool) -> Eq HostMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HostMode -> HostMode -> Bool
== :: HostMode -> HostMode -> Bool
$c/= :: HostMode -> HostMode -> Bool
/= :: HostMode -> HostMode -> Bool
Eq, Int -> HostMode -> ShowS
[HostMode] -> ShowS
HostMode -> String
(Int -> HostMode -> ShowS)
-> (HostMode -> String) -> ([HostMode] -> ShowS) -> Show HostMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HostMode -> ShowS
showsPrec :: Int -> HostMode -> ShowS
$cshow :: HostMode -> String
show :: HostMode -> String
$cshowList :: [HostMode] -> ShowS
showList :: [HostMode] -> ShowS
Show)

textToHostMode :: Text -> Either String HostMode
textToHostMode :: Text -> Either String HostMode
textToHostMode = \case
  Text
"public" -> HostMode -> Either String HostMode
forall a b. b -> Either a b
Right HostMode
HMPublic
  Text
"onion" -> HostMode -> Either String HostMode
forall a b. b -> Either a b
Right HostMode
HMOnionViaSocks
  Text
s -> String -> Either String HostMode
forall a b. a -> Either a b
Left (String -> Either String HostMode)
-> String -> Either String HostMode
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Invalid host_mode: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s

data SocksMode
  = -- | always use SOCKS proxy when enabled
    SMAlways
  | -- | use SOCKS proxy only for .onion hosts when no public host is available
    -- This mode is used in SMP proxy and in notifications server to minimize SOCKS proxy usage.
    SMOnion
  deriving (SocksMode -> SocksMode -> Bool
(SocksMode -> SocksMode -> Bool)
-> (SocksMode -> SocksMode -> Bool) -> Eq SocksMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocksMode -> SocksMode -> Bool
== :: SocksMode -> SocksMode -> Bool
$c/= :: SocksMode -> SocksMode -> Bool
/= :: SocksMode -> SocksMode -> Bool
Eq, Int -> SocksMode -> ShowS
[SocksMode] -> ShowS
SocksMode -> String
(Int -> SocksMode -> ShowS)
-> (SocksMode -> String)
-> ([SocksMode] -> ShowS)
-> Show SocksMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocksMode -> ShowS
showsPrec :: Int -> SocksMode -> ShowS
$cshow :: SocksMode -> String
show :: SocksMode -> String
$cshowList :: [SocksMode] -> ShowS
showList :: [SocksMode] -> ShowS
Show)

instance StrEncoding SocksMode where
  strEncode :: SocksMode -> ByteString
strEncode = \case
    SocksMode
SMAlways -> ByteString
"always"
    SocksMode
SMOnion -> ByteString
"onion"
  strP :: Parser SocksMode
strP =
    (Char -> Bool) -> Parser ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString
-> (ByteString -> Parser SocksMode) -> Parser SocksMode
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"always" -> SocksMode -> Parser SocksMode
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SocksMode
SMAlways
      ByteString
"onion" -> SocksMode -> Parser SocksMode
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SocksMode
SMOnion
      ByteString
_ -> String -> Parser SocksMode
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid Socks mode"

-- | network configuration for the client
data NetworkConfig = NetworkConfig
  { -- | use SOCKS5 proxy
    NetworkConfig -> Maybe SocksProxyWithAuth
socksProxy :: Maybe SocksProxyWithAuth,
    -- | when to use SOCKS proxy
    NetworkConfig -> SocksMode
socksMode :: SocksMode,
    -- | determines critera which host is chosen from the list
    NetworkConfig -> HostMode
hostMode :: HostMode,
    -- | if above criteria is not met, if the below setting is True return error, otherwise use the first host
    NetworkConfig -> Bool
requiredHostMode :: Bool,
    -- | transport sessions are created per user or per entity
    NetworkConfig -> TransportSessionMode
sessionMode :: TransportSessionMode,
    -- | SMP proxy mode
    NetworkConfig -> SMPProxyMode
smpProxyMode :: SMPProxyMode,
    -- | Fallback to direct connection when destination SMP relay does not support SMP proxy protocol extensions
    NetworkConfig -> SMPProxyFallback
smpProxyFallback :: SMPProxyFallback,
    -- | use web port 443 for SMP protocol
    NetworkConfig -> SMPWebPortServers
smpWebPortServers :: SMPWebPortServers,
    -- | timeout for the initial client TCP/TLS connection (microseconds)
    NetworkConfig -> NetworkTimeout
tcpConnectTimeout :: NetworkTimeout,
    -- | timeout of protocol commands (microseconds)
    NetworkConfig -> NetworkTimeout
tcpTimeout :: NetworkTimeout,
    -- | additional timeout per kilobyte (1024 bytes) to be sent
    NetworkConfig -> Int64
tcpTimeoutPerKb :: Int64,
    -- | break response timeouts into groups, so later responses get later deadlines
    NetworkConfig -> Int
rcvConcurrency :: Int,
    -- | TCP keep-alive options, Nothing to skip enabling keep-alive
    NetworkConfig -> Maybe KeepAliveOpts
tcpKeepAlive :: Maybe KeepAliveOpts,
    -- | period for SMP ping commands (microseconds, 0 to disable)
    NetworkConfig -> Int64
smpPingInterval :: Int64,
    -- | the count of timeout errors after which SMP client terminates (and will be reconnected), 0 to disable
    NetworkConfig -> Int
smpPingCount :: Int,
    NetworkConfig -> Bool
logTLSErrors :: Bool
  }
  deriving (NetworkConfig -> NetworkConfig -> Bool
(NetworkConfig -> NetworkConfig -> Bool)
-> (NetworkConfig -> NetworkConfig -> Bool) -> Eq NetworkConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NetworkConfig -> NetworkConfig -> Bool
== :: NetworkConfig -> NetworkConfig -> Bool
$c/= :: NetworkConfig -> NetworkConfig -> Bool
/= :: NetworkConfig -> NetworkConfig -> Bool
Eq, Int -> NetworkConfig -> ShowS
[NetworkConfig] -> ShowS
NetworkConfig -> String
(Int -> NetworkConfig -> ShowS)
-> (NetworkConfig -> String)
-> ([NetworkConfig] -> ShowS)
-> Show NetworkConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NetworkConfig -> ShowS
showsPrec :: Int -> NetworkConfig -> ShowS
$cshow :: NetworkConfig -> String
show :: NetworkConfig -> String
$cshowList :: [NetworkConfig] -> ShowS
showList :: [NetworkConfig] -> ShowS
Show)

data NetworkTimeout = NetworkTimeout {NetworkTimeout -> Int
backgroundTimeout :: Int, NetworkTimeout -> Int
interactiveTimeout :: Int}
  deriving (NetworkTimeout -> NetworkTimeout -> Bool
(NetworkTimeout -> NetworkTimeout -> Bool)
-> (NetworkTimeout -> NetworkTimeout -> Bool) -> Eq NetworkTimeout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NetworkTimeout -> NetworkTimeout -> Bool
== :: NetworkTimeout -> NetworkTimeout -> Bool
$c/= :: NetworkTimeout -> NetworkTimeout -> Bool
/= :: NetworkTimeout -> NetworkTimeout -> Bool
Eq, Int -> NetworkTimeout -> ShowS
[NetworkTimeout] -> ShowS
NetworkTimeout -> String
(Int -> NetworkTimeout -> ShowS)
-> (NetworkTimeout -> String)
-> ([NetworkTimeout] -> ShowS)
-> Show NetworkTimeout
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NetworkTimeout -> ShowS
showsPrec :: Int -> NetworkTimeout -> ShowS
$cshow :: NetworkTimeout -> String
show :: NetworkTimeout -> String
$cshowList :: [NetworkTimeout] -> ShowS
showList :: [NetworkTimeout] -> ShowS
Show)

data NetworkRequestMode
  = NRMBackground
  | NRMInteractive' {NetworkRequestMode -> Int
retryCount :: Int}

pattern NRMInteractive :: NetworkRequestMode
pattern $mNRMInteractive :: forall {r}. NetworkRequestMode -> ((# #) -> r) -> ((# #) -> r) -> r
$bNRMInteractive :: NetworkRequestMode
NRMInteractive = NRMInteractive' 0

netTimeoutInt :: NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt :: NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout {Int
$sel:backgroundTimeout:NetworkTimeout :: NetworkTimeout -> Int
backgroundTimeout :: Int
backgroundTimeout, Int
$sel:interactiveTimeout:NetworkTimeout :: NetworkTimeout -> Int
interactiveTimeout :: Int
interactiveTimeout} = \case
  NetworkRequestMode
NRMBackground -> Int
backgroundTimeout
  NRMInteractive' Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 -> Int
interactiveTimeout
    | Bool
otherwise ->
        let (Int
m, Int
d)
              | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = (Int
3, Int
2)
              | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = (Int
9, Int
4)
              | Bool
otherwise = (Int
27, Int
8)
         in (Int
interactiveTimeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
m) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
d

data TransportSessionMode = TSMUser | TSMSession | TSMServer | TSMEntity
  deriving (TransportSessionMode -> TransportSessionMode -> Bool
(TransportSessionMode -> TransportSessionMode -> Bool)
-> (TransportSessionMode -> TransportSessionMode -> Bool)
-> Eq TransportSessionMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransportSessionMode -> TransportSessionMode -> Bool
== :: TransportSessionMode -> TransportSessionMode -> Bool
$c/= :: TransportSessionMode -> TransportSessionMode -> Bool
/= :: TransportSessionMode -> TransportSessionMode -> Bool
Eq, Int -> TransportSessionMode -> ShowS
[TransportSessionMode] -> ShowS
TransportSessionMode -> String
(Int -> TransportSessionMode -> ShowS)
-> (TransportSessionMode -> String)
-> ([TransportSessionMode] -> ShowS)
-> Show TransportSessionMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransportSessionMode -> ShowS
showsPrec :: Int -> TransportSessionMode -> ShowS
$cshow :: TransportSessionMode -> String
show :: TransportSessionMode -> String
$cshowList :: [TransportSessionMode] -> ShowS
showList :: [TransportSessionMode] -> ShowS
Show)

-- SMP proxy mode for sending messages
data SMPProxyMode
  = SPMAlways
  | SPMUnknown -- use with unknown relays
  | SPMUnprotected -- use with unknown relays when IP address is not protected (i.e., when neither SOCKS proxy nor .onion address is used)
  | SPMNever
  deriving (SMPProxyMode -> SMPProxyMode -> Bool
(SMPProxyMode -> SMPProxyMode -> Bool)
-> (SMPProxyMode -> SMPProxyMode -> Bool) -> Eq SMPProxyMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SMPProxyMode -> SMPProxyMode -> Bool
== :: SMPProxyMode -> SMPProxyMode -> Bool
$c/= :: SMPProxyMode -> SMPProxyMode -> Bool
/= :: SMPProxyMode -> SMPProxyMode -> Bool
Eq, Int -> SMPProxyMode -> ShowS
[SMPProxyMode] -> ShowS
SMPProxyMode -> String
(Int -> SMPProxyMode -> ShowS)
-> (SMPProxyMode -> String)
-> ([SMPProxyMode] -> ShowS)
-> Show SMPProxyMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SMPProxyMode -> ShowS
showsPrec :: Int -> SMPProxyMode -> ShowS
$cshow :: SMPProxyMode -> String
show :: SMPProxyMode -> String
$cshowList :: [SMPProxyMode] -> ShowS
showList :: [SMPProxyMode] -> ShowS
Show)

data SMPProxyFallback
  = SPFAllow -- connect directly when chosen proxy or destination relay do not support proxy protocol.
  | SPFAllowProtected -- connect directly only when IP address is protected (SOCKS proxy or .onion address is used).
  | SPFProhibit -- prohibit direct connection to destination relay.
  deriving (SMPProxyFallback -> SMPProxyFallback -> Bool
(SMPProxyFallback -> SMPProxyFallback -> Bool)
-> (SMPProxyFallback -> SMPProxyFallback -> Bool)
-> Eq SMPProxyFallback
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SMPProxyFallback -> SMPProxyFallback -> Bool
== :: SMPProxyFallback -> SMPProxyFallback -> Bool
$c/= :: SMPProxyFallback -> SMPProxyFallback -> Bool
/= :: SMPProxyFallback -> SMPProxyFallback -> Bool
Eq, Int -> SMPProxyFallback -> ShowS
[SMPProxyFallback] -> ShowS
SMPProxyFallback -> String
(Int -> SMPProxyFallback -> ShowS)
-> (SMPProxyFallback -> String)
-> ([SMPProxyFallback] -> ShowS)
-> Show SMPProxyFallback
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SMPProxyFallback -> ShowS
showsPrec :: Int -> SMPProxyFallback -> ShowS
$cshow :: SMPProxyFallback -> String
show :: SMPProxyFallback -> String
$cshowList :: [SMPProxyFallback] -> ShowS
showList :: [SMPProxyFallback] -> ShowS
Show)

data SMPWebPortServers
  = SWPAll
  | SWPPreset
  | SWPOff
  deriving (SMPWebPortServers -> SMPWebPortServers -> Bool
(SMPWebPortServers -> SMPWebPortServers -> Bool)
-> (SMPWebPortServers -> SMPWebPortServers -> Bool)
-> Eq SMPWebPortServers
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SMPWebPortServers -> SMPWebPortServers -> Bool
== :: SMPWebPortServers -> SMPWebPortServers -> Bool
$c/= :: SMPWebPortServers -> SMPWebPortServers -> Bool
/= :: SMPWebPortServers -> SMPWebPortServers -> Bool
Eq, Int -> SMPWebPortServers -> ShowS
[SMPWebPortServers] -> ShowS
SMPWebPortServers -> String
(Int -> SMPWebPortServers -> ShowS)
-> (SMPWebPortServers -> String)
-> ([SMPWebPortServers] -> ShowS)
-> Show SMPWebPortServers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SMPWebPortServers -> ShowS
showsPrec :: Int -> SMPWebPortServers -> ShowS
$cshow :: SMPWebPortServers -> String
show :: SMPWebPortServers -> String
$cshowList :: [SMPWebPortServers] -> ShowS
showList :: [SMPWebPortServers] -> ShowS
Show)

instance StrEncoding SMPProxyMode where
  strEncode :: SMPProxyMode -> ByteString
strEncode = \case
    SMPProxyMode
SPMAlways -> ByteString
"always"
    SMPProxyMode
SPMUnknown -> ByteString
"unknown"
    SMPProxyMode
SPMUnprotected -> ByteString
"unprotected"
    SMPProxyMode
SPMNever -> ByteString
"never"
  strP :: Parser SMPProxyMode
strP =
    (Char -> Bool) -> Parser ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString
-> (ByteString -> Parser SMPProxyMode) -> Parser SMPProxyMode
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"always" -> SMPProxyMode -> Parser SMPProxyMode
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPProxyMode
SPMAlways
      ByteString
"unknown" -> SMPProxyMode -> Parser SMPProxyMode
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPProxyMode
SPMUnknown
      ByteString
"unprotected" -> SMPProxyMode -> Parser SMPProxyMode
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPProxyMode
SPMUnprotected
      ByteString
"never" -> SMPProxyMode -> Parser SMPProxyMode
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPProxyMode
SPMNever
      ByteString
_ -> String -> Parser SMPProxyMode
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid SMP proxy mode"

instance StrEncoding SMPProxyFallback where
  strEncode :: SMPProxyFallback -> ByteString
strEncode = \case
    SMPProxyFallback
SPFAllow -> ByteString
"yes"
    SMPProxyFallback
SPFAllowProtected -> ByteString
"protected"
    SMPProxyFallback
SPFProhibit -> ByteString
"no"
  strP :: Parser SMPProxyFallback
strP =
    (Char -> Bool) -> Parser ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString
-> (ByteString -> Parser SMPProxyFallback)
-> Parser SMPProxyFallback
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"yes" -> SMPProxyFallback -> Parser SMPProxyFallback
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPProxyFallback
SPFAllow
      ByteString
"protected" -> SMPProxyFallback -> Parser SMPProxyFallback
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPProxyFallback
SPFAllowProtected
      ByteString
"no" -> SMPProxyFallback -> Parser SMPProxyFallback
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPProxyFallback
SPFProhibit
      ByteString
_ -> String -> Parser SMPProxyFallback
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid SMP proxy fallback mode"

instance StrEncoding SMPWebPortServers where
  strEncode :: SMPWebPortServers -> ByteString
strEncode = \case
    SMPWebPortServers
SWPAll -> ByteString
"all"
    SMPWebPortServers
SWPPreset -> ByteString
"preset"
    SMPWebPortServers
SWPOff -> ByteString
"off"
  strP :: Parser SMPWebPortServers
strP =
    (Char -> Bool) -> Parser ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString
-> (ByteString -> Parser SMPWebPortServers)
-> Parser SMPWebPortServers
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"all" -> SMPWebPortServers -> Parser SMPWebPortServers
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPWebPortServers
SWPAll
      ByteString
"preset" -> SMPWebPortServers -> Parser SMPWebPortServers
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPWebPortServers
SWPPreset
      ByteString
"off" -> SMPWebPortServers -> Parser SMPWebPortServers
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPWebPortServers
SWPOff
      ByteString
_ -> String -> Parser SMPWebPortServers
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid SMP wep port setting"

defaultNetworkConfig :: NetworkConfig
defaultNetworkConfig :: NetworkConfig
defaultNetworkConfig =
  NetworkConfig
    { $sel:socksProxy:NetworkConfig :: Maybe SocksProxyWithAuth
socksProxy = Maybe SocksProxyWithAuth
forall a. Maybe a
Nothing,
      $sel:socksMode:NetworkConfig :: SocksMode
socksMode = SocksMode
SMAlways,
      $sel:hostMode:NetworkConfig :: HostMode
hostMode = HostMode
HMOnionViaSocks,
      $sel:requiredHostMode:NetworkConfig :: Bool
requiredHostMode = Bool
False,
      $sel:sessionMode:NetworkConfig :: TransportSessionMode
sessionMode = TransportSessionMode
TSMSession,
      $sel:smpProxyMode:NetworkConfig :: SMPProxyMode
smpProxyMode = SMPProxyMode
SPMNever,
      $sel:smpProxyFallback:NetworkConfig :: SMPProxyFallback
smpProxyFallback = SMPProxyFallback
SPFAllow,
      $sel:smpWebPortServers:NetworkConfig :: SMPWebPortServers
smpWebPortServers = SMPWebPortServers
SWPPreset,
      $sel:tcpConnectTimeout:NetworkConfig :: NetworkTimeout
tcpConnectTimeout = NetworkTimeout {$sel:backgroundTimeout:NetworkTimeout :: Int
backgroundTimeout = Int
45_000000, $sel:interactiveTimeout:NetworkTimeout :: Int
interactiveTimeout = Int
15_000000},
      $sel:tcpTimeout:NetworkConfig :: NetworkTimeout
tcpTimeout = NetworkTimeout {$sel:backgroundTimeout:NetworkTimeout :: Int
backgroundTimeout = Int
30_000000, $sel:interactiveTimeout:NetworkTimeout :: Int
interactiveTimeout = Int
10_000000},
      $sel:tcpTimeoutPerKb:NetworkConfig :: Int64
tcpTimeoutPerKb = Int64
5_000,
      $sel:rcvConcurrency:NetworkConfig :: Int
rcvConcurrency = Int
8,
      $sel:tcpKeepAlive:NetworkConfig :: Maybe KeepAliveOpts
tcpKeepAlive = KeepAliveOpts -> Maybe KeepAliveOpts
forall a. a -> Maybe a
Just KeepAliveOpts
defaultKeepAliveOpts,
      $sel:smpPingInterval:NetworkConfig :: Int64
smpPingInterval = Int64
600_000_000, -- 10min
      $sel:smpPingCount:NetworkConfig :: Int
smpPingCount = Int
3,
      $sel:logTLSErrors:NetworkConfig :: Bool
logTLSErrors = Bool
False
    }

transportClientConfig :: NetworkConfig -> NetworkRequestMode -> TransportHost -> Bool -> Maybe [ALPN] -> TransportClientConfig
transportClientConfig :: NetworkConfig
-> NetworkRequestMode
-> TransportHost
-> Bool
-> Maybe [ByteString]
-> TransportClientConfig
transportClientConfig NetworkConfig {Maybe SocksProxyWithAuth
$sel:socksProxy:NetworkConfig :: NetworkConfig -> Maybe SocksProxyWithAuth
socksProxy :: Maybe SocksProxyWithAuth
socksProxy, SocksMode
$sel:socksMode:NetworkConfig :: NetworkConfig -> SocksMode
socksMode :: SocksMode
socksMode, NetworkTimeout
$sel:tcpConnectTimeout:NetworkConfig :: NetworkConfig -> NetworkTimeout
tcpConnectTimeout :: NetworkTimeout
tcpConnectTimeout, Maybe KeepAliveOpts
$sel:tcpKeepAlive:NetworkConfig :: NetworkConfig -> Maybe KeepAliveOpts
tcpKeepAlive :: Maybe KeepAliveOpts
tcpKeepAlive, Bool
$sel:logTLSErrors:NetworkConfig :: NetworkConfig -> Bool
logTLSErrors :: Bool
logTLSErrors} NetworkRequestMode
nm TransportHost
host Bool
useSNI Maybe [ByteString]
clientALPN =
  TransportClientConfig {$sel:socksProxy:TransportClientConfig :: Maybe SocksProxy
socksProxy = SocksMode -> Maybe SocksProxy
useSocksProxy SocksMode
socksMode, $sel:tcpConnectTimeout:TransportClientConfig :: Int
tcpConnectTimeout = Int
tOut, Maybe KeepAliveOpts
tcpKeepAlive :: Maybe KeepAliveOpts
$sel:tcpKeepAlive:TransportClientConfig :: Maybe KeepAliveOpts
tcpKeepAlive, Bool
logTLSErrors :: Bool
$sel:logTLSErrors:TransportClientConfig :: Bool
logTLSErrors, $sel:clientCredentials:TransportClientConfig :: Maybe Credential
clientCredentials = Maybe Credential
forall a. Maybe a
Nothing, Maybe [ByteString]
clientALPN :: Maybe [ByteString]
$sel:clientALPN:TransportClientConfig :: Maybe [ByteString]
clientALPN, Bool
useSNI :: Bool
$sel:useSNI:TransportClientConfig :: Bool
useSNI}
  where
    tOut :: Int
tOut = NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout
tcpConnectTimeout NetworkRequestMode
nm
    socksProxy' :: Maybe SocksProxy
socksProxy' = (\(SocksProxyWithAuth SocksAuth
_ SocksProxy
proxy) -> SocksProxy
proxy) (SocksProxyWithAuth -> SocksProxy)
-> Maybe SocksProxyWithAuth -> Maybe SocksProxy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SocksProxyWithAuth
socksProxy
    useSocksProxy :: SocksMode -> Maybe SocksProxy
useSocksProxy SocksMode
SMAlways = Maybe SocksProxy
socksProxy'
    useSocksProxy SocksMode
SMOnion = case TransportHost
host of
      THOnionHost ByteString
_ -> Maybe SocksProxy
socksProxy'
      TransportHost
_ -> Maybe SocksProxy
forall a. Maybe a
Nothing

clientSocksCredentials :: ProtocolTypeI (ProtoType msg) => NetworkConfig -> UTCTime -> TransportSession msg -> Maybe SocksCredentials
clientSocksCredentials :: forall msg.
ProtocolTypeI (ProtoType msg) =>
NetworkConfig
-> UTCTime -> TransportSession msg -> Maybe SocksCredentials
clientSocksCredentials NetworkConfig {Maybe SocksProxyWithAuth
$sel:socksProxy:NetworkConfig :: NetworkConfig -> Maybe SocksProxyWithAuth
socksProxy :: Maybe SocksProxyWithAuth
socksProxy, TransportSessionMode
$sel:sessionMode:NetworkConfig :: NetworkConfig -> TransportSessionMode
sessionMode :: TransportSessionMode
sessionMode} UTCTime
proxySessTs (Int64
userId, ProtocolServer (ProtoType msg)
srv, Maybe ByteString
entityId_) = case Maybe SocksProxyWithAuth
socksProxy of
  Just (SocksProxyWithAuth SocksAuth
auth SocksProxy
_) -> case SocksAuth
auth of
    SocksAuthUsername {ByteString
username :: ByteString
$sel:username:SocksAuthUsername :: SocksAuth -> ByteString
username, ByteString
password :: ByteString
$sel:password:SocksAuthUsername :: SocksAuth -> ByteString
password} -> SocksCredentials -> Maybe SocksCredentials
forall a. a -> Maybe a
Just (SocksCredentials -> Maybe SocksCredentials)
-> SocksCredentials -> Maybe SocksCredentials
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> SocksCredentials
SocksCredentials ByteString
username ByteString
password
    SocksAuth
SocksAuthNull -> Maybe SocksCredentials
forall a. Maybe a
Nothing
    SocksAuth
SocksIsolateByAuth -> SocksCredentials -> Maybe SocksCredentials
forall a. a -> Maybe a
Just (SocksCredentials -> Maybe SocksCredentials)
-> SocksCredentials -> Maybe SocksCredentials
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> SocksCredentials
SocksCredentials ByteString
sessionUsername ByteString
""
  Maybe SocksProxyWithAuth
Nothing -> Maybe SocksCredentials
forall a. Maybe a
Nothing
  where
    sessionUsername :: ByteString
sessionUsername =
      ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
C.sha256Hash (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
        Int64 -> ByteString
forall a. Show a => a -> ByteString
bshow Int64
userId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> case TransportSessionMode
sessionMode of
          TransportSessionMode
TSMUser -> ByteString
""
          TransportSessionMode
TSMSession -> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> UTCTime -> ByteString
forall a. Show a => a -> ByteString
bshow UTCTime
proxySessTs
          TransportSessionMode
TSMServer -> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> UTCTime -> ByteString
forall a. Show a => a -> ByteString
bshow UTCTime
proxySessTs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"@" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ProtocolServer (ProtoType msg) -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtocolServer (ProtoType msg)
srv
          TransportSessionMode
TSMEntity -> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> UTCTime -> ByteString
forall a. Show a => a -> ByteString
bshow UTCTime
proxySessTs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"@" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ProtocolServer (ProtoType msg) -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtocolServer (ProtoType msg)
srv ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) Maybe ByteString
entityId_

-- | protocol client configuration.
data ProtocolClientConfig v = ProtocolClientConfig
  { -- | size of TBQueue to use for server commands and responses
    forall v. ProtocolClientConfig v -> Natural
qSize :: Natural,
    -- | default server port if port is not specified in ProtocolServer
    forall v. ProtocolClientConfig v -> (String, ATransport 'TClient)
defaultTransport :: (ServiceName, ATransport 'TClient),
    -- | network configuration
    forall v. ProtocolClientConfig v -> NetworkConfig
networkConfig :: NetworkConfig,
    forall v. ProtocolClientConfig v -> Maybe [ByteString]
clientALPN :: Maybe [ALPN],
    forall v. ProtocolClientConfig v -> Maybe ServiceCredentials
serviceCredentials :: Maybe ServiceCredentials,
    -- | client-server protocol version range
    forall v. ProtocolClientConfig v -> VersionRange v
serverVRange :: VersionRange v,
    -- | agree shared session secret (used in SMP proxy for additional encryption layer)
    forall v. ProtocolClientConfig v -> Bool
agreeSecret :: Bool,
    -- | Whether connecting client is a proxy server. See comment in ClientHandshake
    forall v. ProtocolClientConfig v -> Bool
proxyServer :: Bool,
    -- | send SNI to server, False for SMP
    forall v. ProtocolClientConfig v -> Bool
useSNI :: Bool
  }

-- | Default protocol client configuration.
defaultClientConfig :: Maybe [ALPN] -> Bool -> VersionRange v -> ProtocolClientConfig v
defaultClientConfig :: forall v.
Maybe [ByteString]
-> Bool -> VersionRange v -> ProtocolClientConfig v
defaultClientConfig Maybe [ByteString]
clientALPN Bool
useSNI VersionRange v
serverVRange =
  ProtocolClientConfig
    { $sel:qSize:ProtocolClientConfig :: Natural
qSize = Natural
64,
      $sel:defaultTransport:ProtocolClientConfig :: (String, ATransport 'TClient)
defaultTransport = (String
"443", forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
ATransport p
transport @TLS),
      $sel:networkConfig:ProtocolClientConfig :: NetworkConfig
networkConfig = NetworkConfig
defaultNetworkConfig,
      Maybe [ByteString]
$sel:clientALPN:ProtocolClientConfig :: Maybe [ByteString]
clientALPN :: Maybe [ByteString]
clientALPN,
      $sel:serviceCredentials:ProtocolClientConfig :: Maybe ServiceCredentials
serviceCredentials = Maybe ServiceCredentials
forall a. Maybe a
Nothing,
      VersionRange v
$sel:serverVRange:ProtocolClientConfig :: VersionRange v
serverVRange :: VersionRange v
serverVRange,
      $sel:agreeSecret:ProtocolClientConfig :: Bool
agreeSecret = Bool
False,
      $sel:proxyServer:ProtocolClientConfig :: Bool
proxyServer = Bool
False,
      Bool
$sel:useSNI:ProtocolClientConfig :: Bool
useSNI :: Bool
useSNI
    }
{-# INLINE defaultClientConfig #-}

defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
defaultSMPClientConfig =
  (Maybe [ByteString]
-> Bool -> VersionRangeSMP -> ProtocolClientConfig SMPVersion
forall v.
Maybe [ByteString]
-> Bool -> VersionRange v -> ProtocolClientConfig v
defaultClientConfig ([ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
Just [ByteString]
alpnSupportedSMPHandshakes) Bool
False VersionRangeSMP
supportedClientSMPRelayVRange)
    { defaultTransport = (show defaultSMPPort, transport @TLS),
      agreeSecret = True
    }
{-# INLINE defaultSMPClientConfig #-}

data Request err msg = Request
  { forall err msg. Request err msg -> CorrId
corrId :: CorrId,
    forall err msg. Request err msg -> RecipientId
entityId :: EntityId,
    forall err msg. Request err msg -> ProtoCommand msg
command :: ProtoCommand msg,
    forall err msg. Request err msg -> TVar Bool
pending :: TVar Bool,
    forall err msg.
Request err msg -> TMVar (Either (ProtocolClientError err) msg)
responseVar :: TMVar (Either (ProtocolClientError err) msg)
  }

data Response err msg = Response
  { forall err msg. Response err msg -> RecipientId
entityId :: EntityId,
    forall err msg.
Response err msg -> Either (ProtocolClientError err) msg
response :: Either (ProtocolClientError err) msg
  }

chooseTransportHost :: NetworkConfig -> NonEmpty TransportHost -> Either (ProtocolClientError err) TransportHost
chooseTransportHost :: forall err.
NetworkConfig
-> NonEmpty TransportHost
-> Either (ProtocolClientError err) TransportHost
chooseTransportHost NetworkConfig {Maybe SocksProxyWithAuth
$sel:socksProxy:NetworkConfig :: NetworkConfig -> Maybe SocksProxyWithAuth
socksProxy :: Maybe SocksProxyWithAuth
socksProxy, HostMode
$sel:hostMode:NetworkConfig :: NetworkConfig -> HostMode
hostMode :: HostMode
hostMode, Bool
$sel:requiredHostMode:NetworkConfig :: NetworkConfig -> Bool
requiredHostMode :: Bool
requiredHostMode} NonEmpty TransportHost
hosts =
  Maybe TransportHost
-> Either (ProtocolClientError err) TransportHost
firstOrError (Maybe TransportHost
 -> Either (ProtocolClientError err) TransportHost)
-> Maybe TransportHost
-> Either (ProtocolClientError err) TransportHost
forall a b. (a -> b) -> a -> b
$ case HostMode
hostMode of
    HostMode
HMOnionViaSocks -> Maybe TransportHost
-> (SocksProxyWithAuth -> Maybe TransportHost)
-> Maybe SocksProxyWithAuth
-> Maybe TransportHost
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe TransportHost
publicHost (Maybe TransportHost -> SocksProxyWithAuth -> Maybe TransportHost
forall a b. a -> b -> a
const Maybe TransportHost
onionHost) Maybe SocksProxyWithAuth
socksProxy
    HostMode
HMOnion -> Maybe TransportHost
onionHost
    HostMode
HMPublic -> Maybe TransportHost
publicHost
  where
    firstOrError :: Maybe TransportHost
-> Either (ProtocolClientError err) TransportHost
firstOrError
      | Bool
requiredHostMode = Either (ProtocolClientError err) TransportHost
-> (TransportHost
    -> Either (ProtocolClientError err) TransportHost)
-> Maybe TransportHost
-> Either (ProtocolClientError err) TransportHost
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ProtocolClientError err
-> Either (ProtocolClientError err) TransportHost
forall a b. a -> Either a b
Left ProtocolClientError err
forall err. ProtocolClientError err
PCEIncompatibleHost) TransportHost -> Either (ProtocolClientError err) TransportHost
forall a b. b -> Either a b
Right
      | Bool
otherwise = TransportHost -> Either (ProtocolClientError err) TransportHost
forall a b. b -> Either a b
Right (TransportHost -> Either (ProtocolClientError err) TransportHost)
-> (Maybe TransportHost -> TransportHost)
-> Maybe TransportHost
-> Either (ProtocolClientError err) TransportHost
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportHost -> Maybe TransportHost -> TransportHost
forall a. a -> Maybe a -> a
fromMaybe (NonEmpty TransportHost -> TransportHost
forall a. NonEmpty a -> a
L.head NonEmpty TransportHost
hosts)
    isOnionHost :: TransportHost -> Bool
isOnionHost = \case THOnionHost ByteString
_ -> Bool
True; TransportHost
_ -> Bool
False
    onionHost :: Maybe TransportHost
onionHost = (TransportHost -> Bool)
-> NonEmpty TransportHost -> Maybe TransportHost
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find TransportHost -> Bool
isOnionHost NonEmpty TransportHost
hosts
    publicHost :: Maybe TransportHost
publicHost = (TransportHost -> Bool)
-> NonEmpty TransportHost -> Maybe TransportHost
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Bool -> Bool
not (Bool -> Bool) -> (TransportHost -> Bool) -> TransportHost -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportHost -> Bool
isOnionHost) NonEmpty TransportHost
hosts

protocolClientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient v err msg -> String
protocolClientServer :: forall msg v err.
ProtocolTypeI (ProtoType msg) =>
ProtocolClient v err msg -> String
protocolClientServer = ByteString -> String
B.unpack (ByteString -> String)
-> (ProtocolClient v err msg -> ByteString)
-> ProtocolClient v err msg
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolServer (ProtoType msg) -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (ProtocolServer (ProtoType msg) -> ByteString)
-> (ProtocolClient v err msg -> ProtocolServer (ProtoType msg))
-> ProtocolClient v err msg
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolClient v err msg -> ProtocolServer (ProtoType msg)
forall v err msg. ProtocolClient v err msg -> ProtoServer msg
protocolClientServer'
{-# INLINE protocolClientServer #-}

protocolClientServer' :: ProtocolClient v err msg -> ProtoServer msg
protocolClientServer' :: forall v err msg. ProtocolClient v err msg -> ProtoServer msg
protocolClientServer' = (Int64, ProtocolServer (ProtoType msg), Maybe ByteString)
-> ProtocolServer (ProtoType msg)
forall {a} {b} {c}. (a, b, c) -> b
snd3 ((Int64, ProtocolServer (ProtoType msg), Maybe ByteString)
 -> ProtocolServer (ProtoType msg))
-> (ProtocolClient v err msg
    -> (Int64, ProtocolServer (ProtoType msg), Maybe ByteString))
-> ProtocolClient v err msg
-> ProtocolServer (ProtoType msg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PClient v err msg
-> (Int64, ProtocolServer (ProtoType msg), Maybe ByteString)
forall v err msg. PClient v err msg -> TransportSession msg
transportSession (PClient v err msg
 -> (Int64, ProtocolServer (ProtoType msg), Maybe ByteString))
-> (ProtocolClient v err msg -> PClient v err msg)
-> ProtocolClient v err msg
-> (Int64, ProtocolServer (ProtoType msg), Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolClient v err msg -> PClient v err msg
forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_
  where
    snd3 :: (a, b, c) -> b
snd3 (a
_, b
s, c
_) = b
s
{-# INLINE protocolClientServer' #-}

transportHost' :: ProtocolClient v err msg -> TransportHost
transportHost' :: forall v err msg. ProtocolClient v err msg -> TransportHost
transportHost' = PClient v err msg -> TransportHost
forall v err msg. PClient v err msg -> TransportHost
transportHost (PClient v err msg -> TransportHost)
-> (ProtocolClient v err msg -> PClient v err msg)
-> ProtocolClient v err msg
-> TransportHost
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolClient v err msg -> PClient v err msg
forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_
{-# INLINE transportHost' #-}

transportSession' :: ProtocolClient v err msg -> TransportSession msg
transportSession' :: forall v err msg. ProtocolClient v err msg -> TransportSession msg
transportSession' = PClient v err msg
-> (Int64, ProtocolServer (ProtoType msg), Maybe ByteString)
forall v err msg. PClient v err msg -> TransportSession msg
transportSession (PClient v err msg
 -> (Int64, ProtocolServer (ProtoType msg), Maybe ByteString))
-> (ProtocolClient v err msg -> PClient v err msg)
-> ProtocolClient v err msg
-> (Int64, ProtocolServer (ProtoType msg), Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolClient v err msg -> PClient v err msg
forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_
{-# INLINE transportSession' #-}

type UserId = Int64

-- | Transport session key - includes entity ID if `sessionMode = TSMEntity`.
-- Please note that for SMP connection ID is used as entity ID, not queue ID.
type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)

type SMPTransportSession = TransportSession BrokerMsg

-- | Connects to 'ProtocolServer' using passed client configuration
-- and queue for messages and notifications.
--
-- A single queue can be used for multiple 'SMPClient' instances,
-- as 'SMPServerTransmission' includes server information.
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> NetworkRequestMode -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
getProtocolClient :: forall v err msg.
Protocol v err msg =>
TVar ChaChaDRG
-> NetworkRequestMode
-> TransportSession msg
-> ProtocolClientConfig v
-> [String]
-> Maybe (TBQueue (ServerTransmissionBatch v err msg))
-> UTCTime
-> (ProtocolClient v err msg -> IO ())
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
getProtocolClient TVar ChaChaDRG
g NetworkRequestMode
nm transportSession :: TransportSession msg
transportSession@(Int64
_, ProtoServer msg
srv, Maybe ByteString
_) cfg :: ProtocolClientConfig v
cfg@ProtocolClientConfig {Natural
$sel:qSize:ProtocolClientConfig :: forall v. ProtocolClientConfig v -> Natural
qSize :: Natural
qSize, NetworkConfig
$sel:networkConfig:ProtocolClientConfig :: forall v. ProtocolClientConfig v -> NetworkConfig
networkConfig :: NetworkConfig
networkConfig, Maybe [ByteString]
$sel:clientALPN:ProtocolClientConfig :: forall v. ProtocolClientConfig v -> Maybe [ByteString]
clientALPN :: Maybe [ByteString]
clientALPN, Maybe ServiceCredentials
$sel:serviceCredentials:ProtocolClientConfig :: forall v. ProtocolClientConfig v -> Maybe ServiceCredentials
serviceCredentials :: Maybe ServiceCredentials
serviceCredentials, VersionRange v
$sel:serverVRange:ProtocolClientConfig :: forall v. ProtocolClientConfig v -> VersionRange v
serverVRange :: VersionRange v
serverVRange, Bool
$sel:agreeSecret:ProtocolClientConfig :: forall v. ProtocolClientConfig v -> Bool
agreeSecret :: Bool
agreeSecret, Bool
$sel:proxyServer:ProtocolClientConfig :: forall v. ProtocolClientConfig v -> Bool
proxyServer :: Bool
proxyServer, Bool
$sel:useSNI:ProtocolClientConfig :: forall v. ProtocolClientConfig v -> Bool
useSNI :: Bool
useSNI} [String]
presetDomains Maybe (TBQueue (ServerTransmissionBatch v err msg))
msgQ UTCTime
proxySessTs ProtocolClient v err msg -> IO ()
disconnected = do
  case NetworkConfig
-> NonEmpty TransportHost
-> Either (ProtocolClientError err) TransportHost
forall err.
NetworkConfig
-> NonEmpty TransportHost
-> Either (ProtocolClientError err) TransportHost
chooseTransportHost NetworkConfig
networkConfig (ProtoServer msg -> NonEmpty TransportHost
forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host ProtoServer msg
srv) of
    Right TransportHost
useHost ->
      (IO UTCTime
getCurrentTime IO UTCTime
-> (UTCTime -> IO (PClient v err msg)) -> IO (PClient v err msg)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TransportHost -> UTCTime -> IO (PClient v err msg)
mkProtocolClient TransportHost
useHost IO (PClient v err msg)
-> (PClient v err msg
    -> IO
         (Either (ProtocolClientError err) (ProtocolClient v err msg)))
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String, ATransport 'TClient)
-> TransportHost
-> PClient v err msg
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
runClient (String, ATransport 'TClient)
useTransport TransportHost
useHost)
        IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
-> (IOException
    -> IO
         (Either (ProtocolClientError err) (ProtocolClient v err msg)))
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) -> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ProtocolClientError err) (ProtocolClient v err msg)
 -> IO
      (Either (ProtocolClientError err) (ProtocolClient v err msg)))
-> (ProtocolClientError err
    -> Either (ProtocolClientError err) (ProtocolClient v err msg))
-> ProtocolClientError err
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolClientError err
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
forall a b. a -> Either a b
Left (ProtocolClientError err
 -> IO
      (Either (ProtocolClientError err) (ProtocolClient v err msg)))
-> ProtocolClientError err
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall a b. (a -> b) -> a -> b
$ IOException -> ProtocolClientError err
forall err. IOException -> ProtocolClientError err
PCEIOError IOException
e
    Left ProtocolClientError err
e -> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ProtocolClientError err) (ProtocolClient v err msg)
 -> IO
      (Either (ProtocolClientError err) (ProtocolClient v err msg)))
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall a b. (a -> b) -> a -> b
$ ProtocolClientError err
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
forall a b. a -> Either a b
Left ProtocolClientError err
e
  where
    NetworkConfig {NetworkTimeout
$sel:tcpConnectTimeout:NetworkConfig :: NetworkConfig -> NetworkTimeout
tcpConnectTimeout :: NetworkTimeout
tcpConnectTimeout, NetworkTimeout
$sel:tcpTimeout:NetworkConfig :: NetworkConfig -> NetworkTimeout
tcpTimeout :: NetworkTimeout
tcpTimeout, Int64
$sel:smpPingInterval:NetworkConfig :: NetworkConfig -> Int64
smpPingInterval :: Int64
smpPingInterval} = NetworkConfig
networkConfig
    mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg)
    mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg)
mkProtocolClient TransportHost
transportHost UTCTime
ts = do
      TVar Bool
connected <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
      TVar Bool
sendPings <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
      TVar UTCTime
lastReceived <- UTCTime -> IO (TVar UTCTime)
forall a. a -> IO (TVar a)
newTVarIO UTCTime
ts
      TVar Int
timeoutErrorCount <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0
      TVar ChaChaDRG
clientCorrId <- STM (TVar ChaChaDRG) -> IO (TVar ChaChaDRG)
forall a. STM a -> IO a
atomically (STM (TVar ChaChaDRG) -> IO (TVar ChaChaDRG))
-> STM (TVar ChaChaDRG) -> IO (TVar ChaChaDRG)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (TVar ChaChaDRG)
C.newRandomDRG TVar ChaChaDRG
g
      TMap CorrId (Request err msg)
sentCommands <- IO (TMap CorrId (Request err msg))
forall k a. IO (TMap k a)
TM.emptyIO
      TBQueue (Maybe (Request err msg), ByteString)
sndQ <- Natural -> IO (TBQueue (Maybe (Request err msg), ByteString))
forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
qSize
      TBQueue (NonEmpty (Transmission (Either err msg)))
rcvQ <- Natural -> IO (TBQueue (NonEmpty (Transmission (Either err msg))))
forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
qSize
      PClient v err msg -> IO (PClient v err msg)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        PClient
          { TVar Bool
$sel:connected:PClient :: TVar Bool
connected :: TVar Bool
connected,
            TransportSession msg
$sel:transportSession:PClient :: TransportSession msg
transportSession :: TransportSession msg
transportSession,
            TransportHost
$sel:transportHost:PClient :: TransportHost
transportHost :: TransportHost
transportHost,
            NetworkTimeout
$sel:tcpConnectTimeout:PClient :: NetworkTimeout
tcpConnectTimeout :: NetworkTimeout
tcpConnectTimeout,
            NetworkTimeout
$sel:tcpTimeout:PClient :: NetworkTimeout
tcpTimeout :: NetworkTimeout
tcpTimeout,
            TVar Bool
$sel:sendPings:PClient :: TVar Bool
sendPings :: TVar Bool
sendPings,
            TVar UTCTime
$sel:lastReceived:PClient :: TVar UTCTime
lastReceived :: TVar UTCTime
lastReceived,
            TVar Int
$sel:timeoutErrorCount:PClient :: TVar Int
timeoutErrorCount :: TVar Int
timeoutErrorCount,
            TVar ChaChaDRG
$sel:clientCorrId:PClient :: TVar ChaChaDRG
clientCorrId :: TVar ChaChaDRG
clientCorrId,
            TMap CorrId (Request err msg)
$sel:sentCommands:PClient :: TMap CorrId (Request err msg)
sentCommands :: TMap CorrId (Request err msg)
sentCommands,
            TBQueue (Maybe (Request err msg), ByteString)
$sel:sndQ:PClient :: TBQueue (Maybe (Request err msg), ByteString)
sndQ :: TBQueue (Maybe (Request err msg), ByteString)
sndQ,
            TBQueue (NonEmpty (Transmission (Either err msg)))
$sel:rcvQ:PClient :: TBQueue (NonEmpty (Transmission (Either err msg)))
rcvQ :: TBQueue (NonEmpty (Transmission (Either err msg)))
rcvQ,
            Maybe (TBQueue (ServerTransmissionBatch v err msg))
$sel:msgQ:PClient :: Maybe (TBQueue (ServerTransmissionBatch v err msg))
msgQ :: Maybe (TBQueue (ServerTransmissionBatch v err msg))
msgQ
          }

    runClient :: (ServiceName, ATransport 'TClient) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
    runClient :: (String, ATransport 'TClient)
-> TransportHost
-> PClient v err msg
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
runClient (String
port', ATransport TProxy c 'TClient
t) TransportHost
useHost PClient v err msg
c = do
      TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg))
cVar <- IO
  (TMVar
     (Either (ProtocolClientError err) (ProtocolClient v err msg)))
forall a. IO (TMVar a)
newEmptyTMVarIO
      let tcConfig :: TransportClientConfig
tcConfig = (NetworkConfig
-> NetworkRequestMode
-> TransportHost
-> Bool
-> Maybe [ByteString]
-> TransportClientConfig
transportClientConfig NetworkConfig
networkConfig NetworkRequestMode
nm TransportHost
useHost Bool
useSNI Maybe [ByteString]
useALPN) {clientCredentials = serviceCreds <$> serviceCredentials}
          socksCreds :: Maybe SocksCredentials
socksCreds = NetworkConfig
-> UTCTime -> TransportSession msg -> Maybe SocksCredentials
forall msg.
ProtocolTypeI (ProtoType msg) =>
NetworkConfig
-> UTCTime -> TransportSession msg -> Maybe SocksCredentials
clientSocksCredentials NetworkConfig
networkConfig UTCTime
proxySessTs TransportSession msg
transportSession
      ThreadId
tId <-
        TransportClientConfig
-> Maybe SocksCredentials
-> TransportHost
-> String
-> Maybe KeyHash
-> (c 'TClient -> IO ())
-> IO ()
forall (c :: TransportPeer -> *) a.
Transport c =>
TransportClientConfig
-> Maybe SocksCredentials
-> TransportHost
-> String
-> Maybe KeyHash
-> (c 'TClient -> IO a)
-> IO a
runTransportClient TransportClientConfig
tcConfig Maybe SocksCredentials
socksCreds TransportHost
useHost String
port' (KeyHash -> Maybe KeyHash
forall a. a -> Maybe a
Just (KeyHash -> Maybe KeyHash) -> KeyHash -> Maybe KeyHash
forall a b. (a -> b) -> a -> b
$ ProtoServer msg -> KeyHash
forall (p :: ProtocolType). ProtocolServer p -> KeyHash
keyHash ProtoServer msg
srv) (TProxy c 'TClient
-> PClient v err msg
-> TMVar
     (Either (ProtocolClientError err) (ProtocolClient v err msg))
-> c 'TClient
-> IO ()
forall (c :: TransportPeer -> *).
Transport c =>
TProxy c 'TClient
-> PClient v err msg
-> TMVar
     (Either (ProtocolClientError err) (ProtocolClient v err msg))
-> c 'TClient
-> IO ()
client TProxy c 'TClient
t PClient v err msg
c TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg))
cVar)
          IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
`forkFinally` \Either SomeException ()
r ->
            let err :: NetworkError
err = (SomeException -> NetworkError)
-> (() -> NetworkError) -> Either SomeException () -> NetworkError
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> NetworkError
toNetworkError (NetworkError -> () -> NetworkError
forall a b. a -> b -> a
const NetworkError
NEFailedError) Either SomeException ()
r
             in IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg))
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg))
cVar (Either (ProtocolClientError err) (ProtocolClient v err msg)
 -> STM Bool)
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> STM Bool
forall a b. (a -> b) -> a -> b
$ ProtocolClientError err
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
forall a b. a -> Either a b
Left (ProtocolClientError err
 -> Either (ProtocolClientError err) (ProtocolClient v err msg))
-> ProtocolClientError err
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
forall a b. (a -> b) -> a -> b
$ NetworkError -> ProtocolClientError err
forall err. NetworkError -> ProtocolClientError err
PCENetworkError NetworkError
err
      Maybe (Either (ProtocolClientError err) (ProtocolClient v err msg))
c_ <- NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout
tcpConnectTimeout NetworkRequestMode
nm Int
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
-> IO
     (Maybe
        (Either (ProtocolClientError err) (ProtocolClient v err msg)))
forall a. Int -> IO a -> IO (Maybe a)
`timeout` STM (Either (ProtocolClientError err) (ProtocolClient v err msg))
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall a. STM a -> IO a
atomically (TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg))
-> STM
     (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall a. TMVar a -> STM a
takeTMVar TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg))
cVar)
      case Maybe (Either (ProtocolClientError err) (ProtocolClient v err msg))
c_ of
        Just (Right ProtocolClient v err msg
c') -> ThreadId -> IO (Weak ThreadId)
mkWeakThreadId ThreadId
tId IO (Weak ThreadId)
-> (Weak ThreadId
    -> IO
         (Either (ProtocolClientError err) (ProtocolClient v err msg)))
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Weak ThreadId
tId' -> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ProtocolClientError err) (ProtocolClient v err msg)
 -> IO
      (Either (ProtocolClientError err) (ProtocolClient v err msg)))
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall a b. (a -> b) -> a -> b
$ ProtocolClient v err msg
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
forall a b. b -> Either a b
Right ProtocolClient v err msg
c' {action = Just tId'}
        Just (Left ProtocolClientError err
e) -> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ProtocolClientError err) (ProtocolClient v err msg)
 -> IO
      (Either (ProtocolClientError err) (ProtocolClient v err msg)))
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall a b. (a -> b) -> a -> b
$ ProtocolClientError err
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
forall a b. a -> Either a b
Left ProtocolClientError err
e
        Maybe (Either (ProtocolClientError err) (ProtocolClient v err msg))
Nothing -> ThreadId -> IO ()
killThread ThreadId
tId IO ()
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ProtocolClientError err
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
forall a b. a -> Either a b
Left (NetworkError -> ProtocolClientError err
forall err. NetworkError -> ProtocolClientError err
PCENetworkError NetworkError
NETimeoutError)

    useTransport :: (ServiceName, ATransport 'TClient)
    useTransport :: (String, ATransport 'TClient)
useTransport = case ProtoServer msg -> String
forall (p :: ProtocolType). ProtocolServer p -> String
port ProtoServer msg
srv of
      String
"" -> case forall (p :: ProtocolType). ProtocolTypeI p => SProtocolType p
protocolTypeI @(ProtoType msg) of
        SProtocolType (ProtoType msg)
SPSMP | Bool
web -> (String
"443", forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
ATransport p
transport @TLS)
        SProtocolType (ProtoType msg)
_ -> ProtocolClientConfig v -> (String, ATransport 'TClient)
forall v. ProtocolClientConfig v -> (String, ATransport 'TClient)
defaultTransport ProtocolClientConfig v
cfg
      String
p -> (String
p, forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
ATransport p
transport @TLS)

    useALPN :: Maybe [ALPN]
    useALPN :: Maybe [ByteString]
useALPN = if Bool
web then [ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
Just [ByteString
Item [ByteString]
httpALPN11] else Maybe [ByteString]
clientALPN

    web :: Bool
web = NetworkConfig -> [String] -> ProtoServer msg -> Bool
forall (p :: ProtocolType).
NetworkConfig -> [String] -> ProtocolServer p -> Bool
useWebPort NetworkConfig
networkConfig [String]
presetDomains ProtoServer msg
srv

    client :: forall c. Transport c => TProxy c 'TClient -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c 'TClient -> IO ()
    client :: forall (c :: TransportPeer -> *).
Transport c =>
TProxy c 'TClient
-> PClient v err msg
-> TMVar
     (Either (ProtocolClientError err) (ProtocolClient v err msg))
-> c 'TClient
-> IO ()
client TProxy c 'TClient
_ PClient v err msg
c TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg))
cVar c 'TClient
h = do
      Maybe (PublicKeyX25519, PrivateKey 'X25519)
ks <- if Bool
agreeSecret then (PublicKeyX25519, PrivateKey 'X25519)
-> Maybe (PublicKeyX25519, PrivateKey 'X25519)
forall a. a -> Maybe a
Just ((PublicKeyX25519, PrivateKey 'X25519)
 -> Maybe (PublicKeyX25519, PrivateKey 'X25519))
-> IO (PublicKeyX25519, PrivateKey 'X25519)
-> IO (Maybe (PublicKeyX25519, PrivateKey 'X25519))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (PublicKeyX25519, PrivateKey 'X25519)
-> IO (PublicKeyX25519, PrivateKey 'X25519)
forall a. STM a -> IO a
atomically (TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
g) else Maybe (PublicKeyX25519, PrivateKey 'X25519)
-> IO (Maybe (PublicKeyX25519, PrivateKey 'X25519))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (PublicKeyX25519, PrivateKey 'X25519)
forall a. Maybe a
Nothing
      Maybe
  (ServiceCredentials, (PublicKey 'Ed25519, PrivateKey 'Ed25519))
serviceKeys_ <- (ServiceCredentials
 -> IO
      (ServiceCredentials, (PublicKey 'Ed25519, PrivateKey 'Ed25519)))
-> Maybe ServiceCredentials
-> IO
     (Maybe
        (ServiceCredentials, (PublicKey 'Ed25519, PrivateKey 'Ed25519)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (\ServiceCredentials
creds -> (ServiceCredentials
creds,) ((PublicKey 'Ed25519, PrivateKey 'Ed25519)
 -> (ServiceCredentials, (PublicKey 'Ed25519, PrivateKey 'Ed25519)))
-> IO (PublicKey 'Ed25519, PrivateKey 'Ed25519)
-> IO
     (ServiceCredentials, (PublicKey 'Ed25519, PrivateKey 'Ed25519))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (PublicKey 'Ed25519, PrivateKey 'Ed25519)
-> IO (PublicKey 'Ed25519, PrivateKey 'Ed25519)
forall a. STM a -> IO a
atomically (TVar ChaChaDRG -> STM (KeyPair 'Ed25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
g)) Maybe ServiceCredentials
serviceCredentials
      ExceptT TransportError IO (THandle v c 'TClient)
-> IO (Either TransportError (THandle v c 'TClient))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall v err msg (c :: TransportPeer -> *).
(Protocol v err msg, Transport c) =>
c 'TClient
-> Maybe (KeyPair 'X25519)
-> KeyHash
-> VersionRange v
-> Bool
-> Maybe (ServiceCredentials, KeyPair 'Ed25519)
-> ExceptT TransportError IO (THandle v c 'TClient)
protocolClientHandshake @v @err @msg c 'TClient
h Maybe (KeyPair 'X25519)
Maybe (PublicKeyX25519, PrivateKey 'X25519)
ks (ProtoServer msg -> KeyHash
forall (p :: ProtocolType). ProtocolServer p -> KeyHash
keyHash ProtoServer msg
srv) VersionRange v
serverVRange Bool
proxyServer Maybe (ServiceCredentials, KeyPair 'Ed25519)
Maybe
  (ServiceCredentials, (PublicKey 'Ed25519, PrivateKey 'Ed25519))
serviceKeys_) IO (Either TransportError (THandle v c 'TClient))
-> (Either TransportError (THandle v c 'TClient) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left TransportError
e -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (ProtocolClientError err -> STM ())
-> ProtocolClientError err
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg))
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg))
cVar (Either (ProtocolClientError err) (ProtocolClient v err msg)
 -> STM ())
-> (ProtocolClientError err
    -> Either (ProtocolClientError err) (ProtocolClient v err msg))
-> ProtocolClientError err
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolClientError err
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
forall a b. a -> Either a b
Left (ProtocolClientError err -> IO ())
-> ProtocolClientError err -> IO ()
forall a b. (a -> b) -> a -> b
$ TransportError -> ProtocolClientError err
forall err. TransportError -> ProtocolClientError err
PCETransportError TransportError
e
        Right th :: THandle v c 'TClient
th@THandle {THandleParams v 'TClient
params :: THandleParams v 'TClient
$sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params} -> do
          UTCTime
sessionTs <- IO UTCTime
getCurrentTime
          let c' :: ProtocolClient v err msg
c' = ProtocolClient {$sel:action:ProtocolClient :: Maybe (Weak ThreadId)
action = Maybe (Weak ThreadId)
forall a. Maybe a
Nothing, $sel:client_:ProtocolClient :: PClient v err msg
client_ = PClient v err msg
c, $sel:thParams:ProtocolClient :: THandleParams v 'TClient
thParams = THandleParams v 'TClient
params, UTCTime
$sel:sessionTs:ProtocolClient :: UTCTime
sessionTs :: UTCTime
sessionTs}
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar UTCTime -> UTCTime -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PClient v err msg -> TVar UTCTime
forall v err msg. PClient v err msg -> TVar UTCTime
lastReceived PClient v err msg
c) UTCTime
sessionTs
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PClient v err msg -> TVar Bool
forall v err msg. PClient v err msg -> TVar Bool
connected PClient v err msg
c) Bool
True
            TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg))
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg))
cVar (Either (ProtocolClientError err) (ProtocolClient v err msg)
 -> STM ())
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
-> STM ()
forall a b. (a -> b) -> a -> b
$ ProtocolClient v err msg
-> Either (ProtocolClientError err) (ProtocolClient v err msg)
forall a b. b -> Either a b
Right ProtocolClient v err msg
c'
          [IO ()] -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => [m a] -> m ()
raceAny_ ([ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
forall (c :: TransportPeer -> *).
Transport c =>
ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
send ProtocolClient v err msg
c' THandle v c 'TClient
th, ProtocolClient v err msg -> IO ()
process ProtocolClient v err msg
c', ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
forall (c :: TransportPeer -> *).
Transport c =>
ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
receive ProtocolClient v err msg
c' THandle v c 'TClient
th] [IO ()] -> [IO ()] -> [IO ()]
forall a. Semigroup a => a -> a -> a
<> [ProtocolClient v err msg -> IO ()
monitor ProtocolClient v err msg
c' | Int64
smpPingInterval Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0])
            IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` ProtocolClient v err msg -> IO ()
disconnected ProtocolClient v err msg
c'

    send :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
    send :: forall (c :: TransportPeer -> *).
Transport c =>
ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
send ProtocolClient {$sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {TBQueue (Maybe (Request err msg), ByteString)
$sel:sndQ:PClient :: forall v err msg.
PClient v err msg -> TBQueue (Maybe (Request err msg), ByteString)
sndQ :: TBQueue (Maybe (Request err msg), ByteString)
sndQ}} THandle v c 'TClient
h = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (Maybe (Request err msg), ByteString)
-> IO (Maybe (Request err msg), ByteString)
forall a. STM a -> IO a
atomically (TBQueue (Maybe (Request err msg), ByteString)
-> STM (Maybe (Request err msg), ByteString)
forall a. TBQueue a -> STM a
readTBQueue TBQueue (Maybe (Request err msg), ByteString)
sndQ) IO (Maybe (Request err msg), ByteString)
-> ((Maybe (Request err msg), ByteString) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe (Request err msg), ByteString) -> IO ()
sendPending
      where
        sendPending :: (Maybe (Request err msg), ByteString) -> IO ()
sendPending (Maybe (Request err msg)
r, ByteString
s) = case Maybe (Request err msg)
r of
          Maybe (Request err msg)
Nothing -> IO (Either TransportError ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either TransportError ()) -> IO ())
-> IO (Either TransportError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ THandle v c 'TClient -> ByteString -> IO (Either TransportError ())
forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p -> ByteString -> IO (Either TransportError ())
tPutLog THandle v c 'TClient
h ByteString
s
          Just Request {TVar Bool
$sel:pending:Request :: forall err msg. Request err msg -> TVar Bool
pending :: TVar Bool
pending, TMVar (Either (ProtocolClientError err) msg)
$sel:responseVar:Request :: forall err msg.
Request err msg -> TMVar (Either (ProtocolClientError err) msg)
responseVar :: TMVar (Either (ProtocolClientError err) msg)
responseVar} ->
            IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (TVar Bool -> IO Bool
forall a. TVar a -> IO a
readTVarIO TVar Bool
pending) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ THandle v c 'TClient -> ByteString -> IO (Either TransportError ())
forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p -> ByteString -> IO (Either TransportError ())
tPutLog THandle v c 'TClient
h ByteString
s IO (Either TransportError ())
-> (Either TransportError () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TransportError -> IO ())
-> (() -> IO ()) -> Either TransportError () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either TransportError -> IO ()
responseErr () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            where
              responseErr :: TransportError -> IO ()
responseErr = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (TransportError -> STM ()) -> TransportError -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (Either (ProtocolClientError err) msg)
-> Either (ProtocolClientError err) msg -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either (ProtocolClientError err) msg)
responseVar (Either (ProtocolClientError err) msg -> STM ())
-> (TransportError -> Either (ProtocolClientError err) msg)
-> TransportError
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. a -> Either a b
Left (ProtocolClientError err -> Either (ProtocolClientError err) msg)
-> (TransportError -> ProtocolClientError err)
-> TransportError
-> Either (ProtocolClientError err) msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportError -> ProtocolClientError err
forall err. TransportError -> ProtocolClientError err
PCETransportError

    receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
    receive :: forall (c :: TransportPeer -> *).
Transport c =>
ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
receive ProtocolClient {$sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {TBQueue (NonEmpty (Transmission (Either err msg)))
$sel:rcvQ:PClient :: forall v err msg.
PClient v err msg
-> TBQueue (NonEmpty (Transmission (Either err msg)))
rcvQ :: TBQueue (NonEmpty (Transmission (Either err msg)))
rcvQ, TVar UTCTime
$sel:lastReceived:PClient :: forall v err msg. PClient v err msg -> TVar UTCTime
lastReceived :: TVar UTCTime
lastReceived, TVar Int
$sel:timeoutErrorCount:PClient :: forall v err msg. PClient v err msg -> TVar Int
timeoutErrorCount :: TVar Int
timeoutErrorCount}} THandle v c 'TClient
h = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      THandle v c 'TClient
-> IO (NonEmpty (Transmission (Either err msg)))
forall v err cmd (c :: TransportPeer -> *).
(ProtocolEncoding v err cmd, Transport c) =>
THandle v c 'TClient
-> IO (NonEmpty (Transmission (Either err cmd)))
tGetClient THandle v c 'TClient
h IO (NonEmpty (Transmission (Either err msg)))
-> (NonEmpty (Transmission (Either err msg)) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (NonEmpty (Transmission (Either err msg)) -> STM ())
-> NonEmpty (Transmission (Either err msg))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue (NonEmpty (Transmission (Either err msg)))
-> NonEmpty (Transmission (Either err msg)) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (NonEmpty (Transmission (Either err msg)))
rcvQ
      IO UTCTime
getCurrentTime IO UTCTime -> (UTCTime -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (UTCTime -> STM ()) -> UTCTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar UTCTime -> UTCTime -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar UTCTime
lastReceived
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
timeoutErrorCount Int
0

    monitor :: ProtocolClient v err msg -> IO ()
    monitor :: ProtocolClient v err msg -> IO ()
monitor c :: ProtocolClient v err msg
c@ProtocolClient {$sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {TVar Bool
$sel:sendPings:PClient :: forall v err msg. PClient v err msg -> TVar Bool
sendPings :: TVar Bool
sendPings, TVar UTCTime
$sel:lastReceived:PClient :: forall v err msg. PClient v err msg -> TVar UTCTime
lastReceived :: TVar UTCTime
lastReceived, TVar Int
$sel:timeoutErrorCount:PClient :: forall v err msg. PClient v err msg -> TVar Int
timeoutErrorCount :: TVar Int
timeoutErrorCount}} = Int64 -> IO ()
loop Int64
smpPingInterval
      where
        loop :: Int64 -> IO ()
        loop :: Int64 -> IO ()
loop Int64
delay = do
          Int64 -> IO ()
threadDelay' Int64
delay
          NominalDiffTime
diff <- UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime (UTCTime -> UTCTime -> NominalDiffTime)
-> IO UTCTime -> IO (UTCTime -> NominalDiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime IO (UTCTime -> NominalDiffTime) -> IO UTCTime -> IO NominalDiffTime
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar UTCTime -> IO UTCTime
forall a. TVar a -> IO a
readTVarIO TVar UTCTime
lastReceived
          let idle :: Int64
idle = NominalDiffTime -> Int64
diffToMicroseconds NominalDiffTime
diff
              remaining :: Int64
remaining = Int64
smpPingInterval Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
idle
          if Int64
remaining Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
1_000_000 -- delay pings only for significant time
            then Int64 -> IO ()
loop Int64
remaining
            else do
              IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (TVar Bool -> IO Bool
forall a. TVar a -> IO a
readTVarIO TVar Bool
sendPings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Either (ProtocolClientError err) msg) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either (ProtocolClientError err) msg) -> IO ())
-> (ExceptT (ProtocolClientError err) IO msg
    -> IO (Either (ProtocolClientError err) msg))
-> ExceptT (ProtocolClientError err) IO msg
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (ProtocolClientError err) IO msg
-> IO (Either (ProtocolClientError err) msg)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (ProtocolClientError err) IO msg -> IO ())
-> ExceptT (ProtocolClientError err) IO msg -> IO ()
forall a b. (a -> b) -> a -> b
$ ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand msg
-> ExceptT (ProtocolClientError err) IO msg
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand msg
-> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand ProtocolClient v err msg
c NetworkRequestMode
NRMBackground Maybe SndPrivateAuthKey
forall a. Maybe a
Nothing RecipientId
NoEntity (forall v err msg. Protocol v err msg => ProtoCommand msg
protocolPing @v @err @msg)
              -- sendProtocolCommand/getResponse updates counter for each command
              Int
cnt <- TVar Int -> IO Int
forall a. TVar a -> IO a
readTVarIO TVar Int
timeoutErrorCount
              -- drop client when maxCnt of commands have timed out in sequence, but only after some time has passed after last received response
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
maxCnt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxCnt Bool -> Bool -> Bool
|| NominalDiffTime
diff NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
recoverWindow) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int64 -> IO ()
loop Int64
smpPingInterval
        recoverWindow :: NominalDiffTime
recoverWindow = NominalDiffTime
15 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60 -- seconds
        maxCnt :: Int
maxCnt = NetworkConfig -> Int
smpPingCount NetworkConfig
networkConfig

    process :: ProtocolClient v err msg -> IO ()
    process :: ProtocolClient v err msg -> IO ()
process ProtocolClient v err msg
c = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (NonEmpty (Transmission (Either err msg)))
-> IO (NonEmpty (Transmission (Either err msg)))
forall a. STM a -> IO a
atomically (TBQueue (NonEmpty (Transmission (Either err msg)))
-> STM (NonEmpty (Transmission (Either err msg)))
forall a. TBQueue a -> STM a
readTBQueue (TBQueue (NonEmpty (Transmission (Either err msg)))
 -> STM (NonEmpty (Transmission (Either err msg))))
-> TBQueue (NonEmpty (Transmission (Either err msg)))
-> STM (NonEmpty (Transmission (Either err msg)))
forall a b. (a -> b) -> a -> b
$ PClient v err msg
-> TBQueue (NonEmpty (Transmission (Either err msg)))
forall v err msg.
PClient v err msg
-> TBQueue (NonEmpty (Transmission (Either err msg)))
rcvQ (PClient v err msg
 -> TBQueue (NonEmpty (Transmission (Either err msg))))
-> PClient v err msg
-> TBQueue (NonEmpty (Transmission (Either err msg)))
forall a b. (a -> b) -> a -> b
$ ProtocolClient v err msg -> PClient v err msg
forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ ProtocolClient v err msg
c) IO (NonEmpty (Transmission (Either err msg)))
-> (NonEmpty (Transmission (Either err msg)) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProtocolClient v err msg
-> NonEmpty (Transmission (Either err msg)) -> IO ()
processMsgs ProtocolClient v err msg
c

    processMsgs :: ProtocolClient v err msg -> NonEmpty (Transmission (Either err msg)) -> IO ()
    processMsgs :: ProtocolClient v err msg
-> NonEmpty (Transmission (Either err msg)) -> IO ()
processMsgs ProtocolClient v err msg
c NonEmpty (Transmission (Either err msg))
ts = do
      [(RecipientId, ServerTransmission err msg)]
ts' <- [Maybe (RecipientId, ServerTransmission err msg)]
-> [(RecipientId, ServerTransmission err msg)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (RecipientId, ServerTransmission err msg)]
 -> [(RecipientId, ServerTransmission err msg)])
-> IO [Maybe (RecipientId, ServerTransmission err msg)]
-> IO [(RecipientId, ServerTransmission err msg)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Transmission (Either err msg)
 -> IO (Maybe (RecipientId, ServerTransmission err msg)))
-> [Transmission (Either err msg)]
-> IO [Maybe (RecipientId, ServerTransmission err msg)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ProtocolClient v err msg
-> Transmission (Either err msg)
-> IO (Maybe (RecipientId, ServerTransmission err msg))
processMsg ProtocolClient v err msg
c) (NonEmpty (Transmission (Either err msg))
-> [Transmission (Either err msg)]
forall a. NonEmpty a -> [a]
L.toList NonEmpty (Transmission (Either err msg))
ts)
      Maybe (TBQueue (ServerTransmissionBatch v err msg))
-> (TBQueue (ServerTransmissionBatch v err msg) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (TBQueue (ServerTransmissionBatch v err msg))
msgQ ((TBQueue (ServerTransmissionBatch v err msg) -> IO ()) -> IO ())
-> (TBQueue (ServerTransmissionBatch v err msg) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TBQueue (ServerTransmissionBatch v err msg)
q ->
        (NonEmpty (RecipientId, ServerTransmission err msg) -> IO ())
-> Maybe (NonEmpty (RecipientId, ServerTransmission err msg))
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (NonEmpty (RecipientId, ServerTransmission err msg) -> STM ())
-> NonEmpty (RecipientId, ServerTransmission err msg)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue (ServerTransmissionBatch v err msg)
-> ServerTransmissionBatch v err msg -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (ServerTransmissionBatch v err msg)
q (ServerTransmissionBatch v err msg -> STM ())
-> (NonEmpty (RecipientId, ServerTransmission err msg)
    -> ServerTransmissionBatch v err msg)
-> NonEmpty (RecipientId, ServerTransmission err msg)
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolClient v err msg
-> NonEmpty (RecipientId, ServerTransmission err msg)
-> ServerTransmissionBatch v err msg
forall v err msg.
ProtocolClient v err msg
-> NonEmpty (RecipientId, ServerTransmission err msg)
-> ServerTransmissionBatch v err msg
serverTransmission ProtocolClient v err msg
c) ([(RecipientId, ServerTransmission err msg)]
-> Maybe (NonEmpty (RecipientId, ServerTransmission err msg))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [(RecipientId, ServerTransmission err msg)]
ts')

    processMsg :: ProtocolClient v err msg -> Transmission (Either err msg) -> IO (Maybe (EntityId, ServerTransmission err msg))
    processMsg :: ProtocolClient v err msg
-> Transmission (Either err msg)
-> IO (Maybe (RecipientId, ServerTransmission err msg))
processMsg ProtocolClient {$sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {TMap CorrId (Request err msg)
$sel:sentCommands:PClient :: forall v err msg.
PClient v err msg -> TMap CorrId (Request err msg)
sentCommands :: TMap CorrId (Request err msg)
sentCommands}} (CorrId
corrId, RecipientId
entId, Either err msg
respOrErr)
      | ByteString -> Bool
B.null (ByteString -> Bool) -> ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ CorrId -> ByteString
bs CorrId
corrId = ServerTransmission err msg
-> IO (Maybe (RecipientId, ServerTransmission err msg))
sendMsg (ServerTransmission err msg
 -> IO (Maybe (RecipientId, ServerTransmission err msg)))
-> ServerTransmission err msg
-> IO (Maybe (RecipientId, ServerTransmission err msg))
forall a b. (a -> b) -> a -> b
$ Either (ProtocolClientError err) msg -> ServerTransmission err msg
forall err msg.
Either (ProtocolClientError err) msg -> ServerTransmission err msg
STEvent Either (ProtocolClientError err) msg
clientResp
      | Bool
otherwise =
          CorrId
-> TMap CorrId (Request err msg) -> IO (Maybe (Request err msg))
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
TM.lookupIO CorrId
corrId TMap CorrId (Request err msg)
sentCommands IO (Maybe (Request err msg))
-> (Maybe (Request err msg)
    -> IO (Maybe (RecipientId, ServerTransmission err msg)))
-> IO (Maybe (RecipientId, ServerTransmission err msg))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (Request err msg)
Nothing -> ServerTransmission err msg
-> IO (Maybe (RecipientId, ServerTransmission err msg))
sendMsg (ServerTransmission err msg
 -> IO (Maybe (RecipientId, ServerTransmission err msg)))
-> ServerTransmission err msg
-> IO (Maybe (RecipientId, ServerTransmission err msg))
forall a b. (a -> b) -> a -> b
$ ProtocolClientError err -> ServerTransmission err msg
forall err msg.
ProtocolClientError err -> ServerTransmission err msg
STUnexpectedError ProtocolClientError err
unexpected
            Just Request {RecipientId
$sel:entityId:Request :: forall err msg. Request err msg -> RecipientId
entityId :: RecipientId
entityId, ProtoCommand msg
$sel:command:Request :: forall err msg. Request err msg -> ProtoCommand msg
command :: ProtoCommand msg
command, TVar Bool
$sel:pending:Request :: forall err msg. Request err msg -> TVar Bool
pending :: TVar Bool
pending, TMVar (Either (ProtocolClientError err) msg)
$sel:responseVar:Request :: forall err msg.
Request err msg -> TMVar (Either (ProtocolClientError err) msg)
responseVar :: TMVar (Either (ProtocolClientError err) msg)
responseVar} -> do
              Bool
wasPending <-
                STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
                  CorrId -> TMap CorrId (Request err msg) -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete CorrId
corrId TMap CorrId (Request err msg)
sentCommands
                  STM Bool -> STM Bool -> STM Bool -> STM Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
                    (TVar Bool -> Bool -> STM Bool
forall a. TVar a -> a -> STM a
swapTVar TVar Bool
pending Bool
False)
                    (Bool
True Bool -> STM Bool -> STM Bool
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TMVar (Either (ProtocolClientError err) msg)
-> Either (ProtocolClientError err) msg -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Either (ProtocolClientError err) msg)
responseVar (if RecipientId
entityId RecipientId -> RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== RecipientId
entId then Either (ProtocolClientError err) msg
clientResp else ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. a -> Either a b
Left ProtocolClientError err
unexpected))
                    (Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
              if Bool
wasPending
                then Maybe (RecipientId, ServerTransmission err msg)
-> IO (Maybe (RecipientId, ServerTransmission err msg))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (RecipientId, ServerTransmission err msg)
forall a. Maybe a
Nothing
                else ServerTransmission err msg
-> IO (Maybe (RecipientId, ServerTransmission err msg))
sendMsg (ServerTransmission err msg
 -> IO (Maybe (RecipientId, ServerTransmission err msg)))
-> ServerTransmission err msg
-> IO (Maybe (RecipientId, ServerTransmission err msg))
forall a b. (a -> b) -> a -> b
$ if RecipientId
entityId RecipientId -> RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== RecipientId
entId then ProtoCommand msg
-> Either (ProtocolClientError err) msg
-> ServerTransmission err msg
forall err msg.
ProtoCommand msg
-> Either (ProtocolClientError err) msg
-> ServerTransmission err msg
STResponse ProtoCommand msg
command Either (ProtocolClientError err) msg
clientResp else ProtocolClientError err -> ServerTransmission err msg
forall err msg.
ProtocolClientError err -> ServerTransmission err msg
STUnexpectedError ProtocolClientError err
unexpected
      where
        unexpected :: ProtocolClientError err
unexpected = Either err msg -> ProtocolClientError err
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse Either err msg
respOrErr
        clientResp :: Either (ProtocolClientError err) msg
clientResp = case Either err msg
respOrErr of
          Left err
e -> ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. a -> Either a b
Left (ProtocolClientError err -> Either (ProtocolClientError err) msg)
-> ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. (a -> b) -> a -> b
$ err -> ProtocolClientError err
forall err. err -> ProtocolClientError err
PCEResponseError err
e
          Right msg
r -> case msg -> Maybe err
forall v err msg. Protocol v err msg => msg -> Maybe err
protocolError msg
r of
            Just err
e -> ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. a -> Either a b
Left (ProtocolClientError err -> Either (ProtocolClientError err) msg)
-> ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. (a -> b) -> a -> b
$ err -> ProtocolClientError err
forall err. err -> ProtocolClientError err
PCEProtocolError err
e
            Maybe err
_ -> msg -> Either (ProtocolClientError err) msg
forall a b. b -> Either a b
Right msg
r
        sendMsg :: ServerTransmission err msg -> IO (Maybe (EntityId, ServerTransmission err msg))
        sendMsg :: ServerTransmission err msg
-> IO (Maybe (RecipientId, ServerTransmission err msg))
sendMsg ServerTransmission err msg
t = case Maybe (TBQueue (ServerTransmissionBatch v err msg))
msgQ of
          Just TBQueue (ServerTransmissionBatch v err msg)
_ -> Maybe (RecipientId, ServerTransmission err msg)
-> IO (Maybe (RecipientId, ServerTransmission err msg))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (RecipientId, ServerTransmission err msg)
 -> IO (Maybe (RecipientId, ServerTransmission err msg)))
-> Maybe (RecipientId, ServerTransmission err msg)
-> IO (Maybe (RecipientId, ServerTransmission err msg))
forall a b. (a -> b) -> a -> b
$ (RecipientId, ServerTransmission err msg)
-> Maybe (RecipientId, ServerTransmission err msg)
forall a. a -> Maybe a
Just (RecipientId
entId, ServerTransmission err msg
t)
          Maybe (TBQueue (ServerTransmissionBatch v err msg))
Nothing ->
            Maybe (RecipientId, ServerTransmission err msg)
forall a. Maybe a
Nothing Maybe (RecipientId, ServerTransmission err msg)
-> IO () -> IO (Maybe (RecipientId, ServerTransmission err msg))
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ case Either (ProtocolClientError err) msg
clientResp of
              Left ProtocolClientError err
e -> Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"SMP client error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ProtocolClientError err -> Text
forall a. Show a => a -> Text
tshow ProtocolClientError err
e
              Right msg
_ -> Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn Text
"SMP client unprocessed event"

useWebPort :: NetworkConfig -> [HostName] -> ProtocolServer p -> Bool
useWebPort :: forall (p :: ProtocolType).
NetworkConfig -> [String] -> ProtocolServer p -> Bool
useWebPort NetworkConfig
cfg [String]
presetDomains ProtocolServer {$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host = TransportHost
h :| [TransportHost]
_} = case NetworkConfig -> SMPWebPortServers
smpWebPortServers NetworkConfig
cfg of
  SMPWebPortServers
SWPAll -> Bool
True
  SMPWebPortServers
SWPPreset -> [String] -> TransportHost -> Bool
isPresetDomain [String]
presetDomains TransportHost
h
  SMPWebPortServers
SWPOff -> Bool
False

isPresetDomain :: [HostName] -> TransportHost -> Bool
isPresetDomain :: [String] -> TransportHost -> Bool
isPresetDomain [String]
presetDomains = \case
  THDomainName String
h -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
h) [String]
presetDomains
  TransportHost
_ -> Bool
False

unexpectedResponse :: Show r => r -> ProtocolClientError err
unexpectedResponse :: forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse = ByteString -> ProtocolClientError err
forall err. ByteString -> ProtocolClientError err
PCEUnexpectedResponse (ByteString -> ProtocolClientError err)
-> (r -> ByteString) -> r -> ProtocolClientError err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack (String -> ByteString) -> (r -> String) -> r -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
32 ShowS -> (r -> String) -> r -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> String
forall a. Show a => a -> String
show

-- | Disconnects client from the server and terminates client threads.
closeProtocolClient :: ProtocolClient v err msg -> IO ()
closeProtocolClient :: forall v err msg. ProtocolClient v err msg -> IO ()
closeProtocolClient = (Weak ThreadId -> IO ()) -> Maybe (Weak ThreadId) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak (Weak ThreadId -> IO (Maybe ThreadId))
-> (Maybe ThreadId -> IO ()) -> Weak ThreadId -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ThreadId -> IO ()) -> Maybe ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread) (Maybe (Weak ThreadId) -> IO ())
-> (ProtocolClient v err msg -> Maybe (Weak ThreadId))
-> ProtocolClient v err msg
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolClient v err msg -> Maybe (Weak ThreadId)
forall v err msg. ProtocolClient v err msg -> Maybe (Weak ThreadId)
action
{-# INLINE closeProtocolClient #-}

-- | SMP client error type.
data ProtocolClientError err
  = -- | Correctly parsed SMP server ERR response.
    -- This error is forwarded to the agent client as `ERR SMP err`.
    PCEProtocolError err
  | -- | Invalid server response that failed to parse.
    -- Forwarded to the agent client as `ERR BROKER RESPONSE`.
    PCEResponseError err
  | -- | Different response from what is expected to a certain SMP command,
    -- e.g. server should respond `IDS` or `ERR` to `NEW` command,
    -- other responses would result in this error.
    -- Forwarded to the agent client as `ERR BROKER UNEXPECTED`.
    PCEUnexpectedResponse ByteString
  | -- | Used for TCP connection and command response timeouts.
    -- Forwarded to the agent client as `ERR BROKER TIMEOUT`.
    PCEResponseTimeout
  | -- | Failure to establish TCP connection.
    -- Forwarded to the agent client as `ERR BROKER NETWORK`.
    PCENetworkError NetworkError
  | -- | No host compatible with network configuration
    PCEIncompatibleHost
  | -- | Service is unavailable for command that requires service connection
    PCEServiceUnavailable
  | -- | TCP transport handshake or some other transport error.
    -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
    PCETransportError TransportError
  | -- | Error when cryptographically "signing" the command or when initializing crypto_box.
    PCECryptoError C.CryptoError
  | -- | IO Error
    PCEIOError IOException
  deriving (ProtocolClientError err -> ProtocolClientError err -> Bool
(ProtocolClientError err -> ProtocolClientError err -> Bool)
-> (ProtocolClientError err -> ProtocolClientError err -> Bool)
-> Eq (ProtocolClientError err)
forall err.
Eq err =>
ProtocolClientError err -> ProtocolClientError err -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall err.
Eq err =>
ProtocolClientError err -> ProtocolClientError err -> Bool
== :: ProtocolClientError err -> ProtocolClientError err -> Bool
$c/= :: forall err.
Eq err =>
ProtocolClientError err -> ProtocolClientError err -> Bool
/= :: ProtocolClientError err -> ProtocolClientError err -> Bool
Eq, Int -> ProtocolClientError err -> ShowS
[ProtocolClientError err] -> ShowS
ProtocolClientError err -> String
(Int -> ProtocolClientError err -> ShowS)
-> (ProtocolClientError err -> String)
-> ([ProtocolClientError err] -> ShowS)
-> Show (ProtocolClientError err)
forall err. Show err => Int -> ProtocolClientError err -> ShowS
forall err. Show err => [ProtocolClientError err] -> ShowS
forall err. Show err => ProtocolClientError err -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall err. Show err => Int -> ProtocolClientError err -> ShowS
showsPrec :: Int -> ProtocolClientError err -> ShowS
$cshow :: forall err. Show err => ProtocolClientError err -> String
show :: ProtocolClientError err -> String
$cshowList :: forall err. Show err => [ProtocolClientError err] -> ShowS
showList :: [ProtocolClientError err] -> ShowS
Show, Show (ProtocolClientError err)
Typeable (ProtocolClientError err)
(Typeable (ProtocolClientError err),
 Show (ProtocolClientError err)) =>
(ProtocolClientError err -> SomeException)
-> (SomeException -> Maybe (ProtocolClientError err))
-> (ProtocolClientError err -> String)
-> Exception (ProtocolClientError err)
SomeException -> Maybe (ProtocolClientError err)
ProtocolClientError err -> String
ProtocolClientError err -> SomeException
forall err.
(Typeable err, Show err) =>
Show (ProtocolClientError err)
forall err.
(Typeable err, Show err) =>
Typeable (ProtocolClientError err)
forall err.
(Typeable err, Show err) =>
SomeException -> Maybe (ProtocolClientError err)
forall err.
(Typeable err, Show err) =>
ProtocolClientError err -> String
forall err.
(Typeable err, Show err) =>
ProtocolClientError err -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: forall err.
(Typeable err, Show err) =>
ProtocolClientError err -> SomeException
toException :: ProtocolClientError err -> SomeException
$cfromException :: forall err.
(Typeable err, Show err) =>
SomeException -> Maybe (ProtocolClientError err)
fromException :: SomeException -> Maybe (ProtocolClientError err)
$cdisplayException :: forall err.
(Typeable err, Show err) =>
ProtocolClientError err -> String
displayException :: ProtocolClientError err -> String
Exception)

type SMPClientError = ProtocolClientError ErrorType

temporaryClientError :: ProtocolClientError err -> Bool
temporaryClientError :: forall err. ProtocolClientError err -> Bool
temporaryClientError = \case
  PCENetworkError NetworkError
_ -> Bool
True
  ProtocolClientError err
PCEResponseTimeout -> Bool
True
  PCEIOError IOException
_ -> Bool
True
  ProtocolClientError err
_ -> Bool
False
{-# INLINE temporaryClientError #-}

smpClientServiceError :: SMPClientError -> Bool
smpClientServiceError :: SMPClientError -> Bool
smpClientServiceError = \case
  SMPClientError
PCEServiceUnavailable -> Bool
True
  PCETransportError (TEHandshake HandshakeError
BAD_SERVICE) -> Bool
True -- TODO [certs] this error may be temporary, so we should possibly resubscribe.
  PCEProtocolError ErrorType
SERVICE -> Bool
True
  PCEProtocolError (PROXY (BROKER BrokerErrorType
NO_SERVICE)) -> Bool
True -- for completeness, it cannot happen.
  SMPClientError
_ -> Bool
False

-- converts error of client running on proxy to the error sent to client connected to proxy
smpProxyError :: SMPClientError -> ErrorType
smpProxyError :: SMPClientError -> ErrorType
smpProxyError = \case
  PCEProtocolError ErrorType
e -> ProxyError -> ErrorType
PROXY (ProxyError -> ErrorType) -> ProxyError -> ErrorType
forall a b. (a -> b) -> a -> b
$ ErrorType -> ProxyError
PROTOCOL ErrorType
e
  PCEResponseError ErrorType
e -> ProxyError -> ErrorType
PROXY (ProxyError -> ErrorType) -> ProxyError -> ErrorType
forall a b. (a -> b) -> a -> b
$ BrokerErrorType -> ProxyError
BROKER (BrokerErrorType -> ProxyError) -> BrokerErrorType -> ProxyError
forall a b. (a -> b) -> a -> b
$ String -> BrokerErrorType
RESPONSE (String -> BrokerErrorType) -> String -> BrokerErrorType
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ErrorType -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ErrorType
e
  PCEUnexpectedResponse ByteString
e -> ProxyError -> ErrorType
PROXY (ProxyError -> ErrorType) -> ProxyError -> ErrorType
forall a b. (a -> b) -> a -> b
$ BrokerErrorType -> ProxyError
BROKER (BrokerErrorType -> ProxyError) -> BrokerErrorType -> ProxyError
forall a b. (a -> b) -> a -> b
$ String -> BrokerErrorType
UNEXPECTED (String -> BrokerErrorType) -> String -> BrokerErrorType
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B.unpack ByteString
e
  SMPClientError
PCEResponseTimeout -> ProxyError -> ErrorType
PROXY (ProxyError -> ErrorType) -> ProxyError -> ErrorType
forall a b. (a -> b) -> a -> b
$ BrokerErrorType -> ProxyError
BROKER BrokerErrorType
TIMEOUT
  PCENetworkError NetworkError
e -> ProxyError -> ErrorType
PROXY (ProxyError -> ErrorType) -> ProxyError -> ErrorType
forall a b. (a -> b) -> a -> b
$ BrokerErrorType -> ProxyError
BROKER (BrokerErrorType -> ProxyError) -> BrokerErrorType -> ProxyError
forall a b. (a -> b) -> a -> b
$ NetworkError -> BrokerErrorType
NETWORK NetworkError
e
  SMPClientError
PCEIncompatibleHost -> ProxyError -> ErrorType
PROXY (ProxyError -> ErrorType) -> ProxyError -> ErrorType
forall a b. (a -> b) -> a -> b
$ BrokerErrorType -> ProxyError
BROKER BrokerErrorType
HOST
  SMPClientError
PCEServiceUnavailable -> ProxyError -> ErrorType
PROXY (ProxyError -> ErrorType) -> ProxyError -> ErrorType
forall a b. (a -> b) -> a -> b
$ BrokerErrorType -> ProxyError
BROKER (BrokerErrorType -> ProxyError) -> BrokerErrorType -> ProxyError
forall a b. (a -> b) -> a -> b
$ BrokerErrorType
NO_SERVICE -- for completeness, it cannot happen.
  PCETransportError TransportError
t -> ProxyError -> ErrorType
PROXY (ProxyError -> ErrorType) -> ProxyError -> ErrorType
forall a b. (a -> b) -> a -> b
$ BrokerErrorType -> ProxyError
BROKER (BrokerErrorType -> ProxyError) -> BrokerErrorType -> ProxyError
forall a b. (a -> b) -> a -> b
$ TransportError -> BrokerErrorType
TRANSPORT TransportError
t
  PCECryptoError CryptoError
_ -> ErrorType
CRYPTO
  PCEIOError IOException
_ -> ErrorType
INTERNAL

smpErrorClientNotice :: SMPClientError -> Maybe (Maybe ClientNotice)
smpErrorClientNotice :: SMPClientError -> Maybe (Maybe ClientNotice)
smpErrorClientNotice = \case
  PCEProtocolError (BLOCKED BlockingInfo {Maybe ClientNotice
notice :: Maybe ClientNotice
$sel:notice:BlockingInfo :: BlockingInfo -> Maybe ClientNotice
notice}) -> Maybe ClientNotice -> Maybe (Maybe ClientNotice)
forall a. a -> Maybe a
Just Maybe ClientNotice
notice
  SMPClientError
_ -> Maybe (Maybe ClientNotice)
forall a. Maybe a
Nothing
{-# INLINE smpErrorClientNotice #-}

-- | Create a new SMP queue.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
createSMPQueue ::
  SMPClient ->
  NetworkRequestMode ->
  Maybe C.CbNonce -> -- used as correlation ID to allow deriving SenderId from it for short links
  C.AAuthKeyPair -> -- SMP v6 - signature key pair, SMP v7 - DH key pair
  RcvPublicDhKey ->
  Maybe BasicAuth ->
  SubscriptionMode ->
  QueueReqData ->
  Maybe NewNtfCreds ->
  ExceptT SMPClientError IO QueueIdsKeys
createSMPQueue :: SMPClient
-> NetworkRequestMode
-> Maybe CbNonce
-> AAuthKeyPair
-> PublicKeyX25519
-> Maybe BasicAuth
-> SubscriptionMode
-> QueueReqData
-> Maybe NewNtfCreds
-> ExceptT SMPClientError IO QueueIdsKeys
createSMPQueue SMPClient
c NetworkRequestMode
nm Maybe CbNonce
nonce_ (PublicKeyType SndPrivateAuthKey
rKey, SndPrivateAuthKey
rpKey) PublicKeyX25519
dhKey Maybe BasicAuth
auth SubscriptionMode
subMode QueueReqData
qrd Maybe NewNtfCreds
ntfCreds =
  SMPClient
-> NetworkRequestMode
-> Maybe CbNonce
-> Maybe Int
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand BrokerMsg
-> ExceptT SMPClientError IO BrokerMsg
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe CbNonce
-> Maybe Int
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand msg
-> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand_ SMPClient
c NetworkRequestMode
nm Maybe CbNonce
nonce_ Maybe Int
forall a. Maybe a
Nothing (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
rpKey) RecipientId
NoEntity (SParty 'Creator -> Command 'Creator -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'Creator
SCreator (Command 'Creator -> Cmd) -> Command 'Creator -> Cmd
forall a b. (a -> b) -> a -> b
$ NewQueueReq -> Command 'Creator
NEW (NewQueueReq -> Command 'Creator)
-> NewQueueReq -> Command 'Creator
forall a b. (a -> b) -> a -> b
$ RcvPublicAuthKey
-> PublicKeyX25519
-> Maybe BasicAuth
-> SubscriptionMode
-> Maybe QueueReqData
-> Maybe NewNtfCreds
-> NewQueueReq
NewQueueReq PublicKeyType SndPrivateAuthKey
RcvPublicAuthKey
rKey PublicKeyX25519
dhKey Maybe BasicAuth
auth SubscriptionMode
subMode (QueueReqData -> Maybe QueueReqData
forall a. a -> Maybe a
Just QueueReqData
qrd) Maybe NewNtfCreds
ntfCreds) ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg -> ExceptT SMPClientError IO QueueIdsKeys)
-> ExceptT SMPClientError IO QueueIdsKeys
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    IDS QueueIdsKeys
qik -> QueueIdsKeys -> ExceptT SMPClientError IO QueueIdsKeys
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueueIdsKeys
qik
    BrokerMsg
r -> SMPClientError -> ExceptT SMPClientError IO QueueIdsKeys
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO QueueIdsKeys)
-> SMPClientError -> ExceptT SMPClientError IO QueueIdsKeys
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r

-- | Subscribe to the SMP queue.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
-- This command is always sent in background request mode
subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe ServiceId)
subscribeSMPQueue :: SMPClient
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO (Maybe RecipientId)
subscribeSMPQueue SMPClient
c SndPrivateAuthKey
rpKey RecipientId
rId = do
  IO () -> ExceptT SMPClientError IO ()
forall a. IO a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT SMPClientError IO ())
-> IO () -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ SMPClient -> IO ()
enablePings SMPClient
c
  SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'Recipient
-> ExceptT SMPClientError IO BrokerMsg
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient
c NetworkRequestMode
NRMBackground (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
rpKey) RecipientId
rId Command 'Recipient
SUB ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg
    -> ExceptT
         SMPClientError IO (Either SMPClientError (Maybe RecipientId)))
-> ExceptT
     SMPClientError IO (Either SMPClientError (Maybe RecipientId))
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Either SMPClientError (Maybe RecipientId))
-> ExceptT
     SMPClientError IO (Either SMPClientError (Maybe RecipientId))
forall a. IO a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SMPClientError (Maybe RecipientId))
 -> ExceptT
      SMPClientError IO (Either SMPClientError (Maybe RecipientId)))
-> (BrokerMsg -> IO (Either SMPClientError (Maybe RecipientId)))
-> BrokerMsg
-> ExceptT
     SMPClientError IO (Either SMPClientError (Maybe RecipientId))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPClient
-> RecipientId
-> BrokerMsg
-> IO (Either SMPClientError (Maybe RecipientId))
processSUBResponse_ SMPClient
c RecipientId
rId ExceptT
  SMPClientError IO (Either SMPClientError (Maybe RecipientId))
-> (Either SMPClientError (Maybe RecipientId)
    -> ExceptT SMPClientError IO (Maybe RecipientId))
-> ExceptT SMPClientError IO (Maybe RecipientId)
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SMPClientError (Maybe RecipientId)
-> ExceptT SMPClientError IO (Maybe RecipientId)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except

-- | Subscribe to multiple SMP queues batching commands if supported.
-- This command is always sent in background request mode
subscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId)))
subscribeSMPQueues :: SMPClient
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError (Maybe RecipientId)))
subscribeSMPQueues SMPClient
c NonEmpty (RecipientId, SndPrivateAuthKey)
qs = do
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SMPClient -> IO ()
enablePings SMPClient
c
  SMPClient
-> NetworkRequestMode
-> NonEmpty (ClientCommand BrokerMsg)
-> IO (NonEmpty (Response ErrorType BrokerMsg))
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> NonEmpty (ClientCommand msg)
-> IO (NonEmpty (Response err msg))
sendProtocolCommands SMPClient
c NetworkRequestMode
NRMBackground NonEmpty (ClientCommand BrokerMsg)
NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
cs IO (NonEmpty (Response ErrorType BrokerMsg))
-> (NonEmpty (Response ErrorType BrokerMsg)
    -> IO (NonEmpty (Either SMPClientError (Maybe RecipientId))))
-> IO (NonEmpty (Either SMPClientError (Maybe RecipientId)))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Response ErrorType BrokerMsg
 -> IO (Either SMPClientError (Maybe RecipientId)))
-> NonEmpty (Response ErrorType BrokerMsg)
-> IO (NonEmpty (Either SMPClientError (Maybe RecipientId)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (SMPClient
-> Response ErrorType BrokerMsg
-> IO (Either SMPClientError (Maybe RecipientId))
processSUBResponse SMPClient
c)
  where
    cs :: NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
cs = ((RecipientId, SndPrivateAuthKey)
 -> (RecipientId, Maybe SndPrivateAuthKey, Cmd))
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\(RecipientId
rId, SndPrivateAuthKey
rpKey) -> (RecipientId
rId, SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
rpKey, SParty 'Recipient -> Command 'Recipient -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'Recipient
SRecipient Command 'Recipient
SUB)) NonEmpty (RecipientId, SndPrivateAuthKey)
qs

-- This command is always sent in background request mode
streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> ([(RecipientId, Either SMPClientError (Maybe ServiceId))] -> IO ()) -> IO ()
streamSubscribeSMPQueues :: SMPClient
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> ([(RecipientId, Either SMPClientError (Maybe RecipientId))]
    -> IO ())
-> IO ()
streamSubscribeSMPQueues SMPClient
c NonEmpty (RecipientId, SndPrivateAuthKey)
qs [(RecipientId, Either SMPClientError (Maybe RecipientId))] -> IO ()
cb = SMPClient
-> NetworkRequestMode
-> NonEmpty (ClientCommand BrokerMsg)
-> ([Response ErrorType BrokerMsg] -> IO ())
-> IO ()
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> NonEmpty (ClientCommand msg)
-> ([Response err msg] -> IO ())
-> IO ()
streamProtocolCommands SMPClient
c NetworkRequestMode
NRMBackground NonEmpty (ClientCommand BrokerMsg)
NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
cs (([Response ErrorType BrokerMsg] -> IO ()) -> IO ())
-> ([Response ErrorType BrokerMsg] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Response ErrorType BrokerMsg
 -> IO (RecipientId, Either SMPClientError (Maybe RecipientId)))
-> [Response ErrorType BrokerMsg]
-> IO [(RecipientId, Either SMPClientError (Maybe RecipientId))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Response ErrorType BrokerMsg
-> IO (RecipientId, Either SMPClientError (Maybe RecipientId))
process ([Response ErrorType BrokerMsg]
 -> IO [(RecipientId, Either SMPClientError (Maybe RecipientId))])
-> ([(RecipientId, Either SMPClientError (Maybe RecipientId))]
    -> IO ())
-> [Response ErrorType BrokerMsg]
-> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [(RecipientId, Either SMPClientError (Maybe RecipientId))] -> IO ()
cb
  where
    cs :: NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
cs = ((RecipientId, SndPrivateAuthKey)
 -> (RecipientId, Maybe SndPrivateAuthKey, Cmd))
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\(RecipientId
rId, SndPrivateAuthKey
rpKey) -> (RecipientId
rId, SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
rpKey, SParty 'Recipient -> Command 'Recipient -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'Recipient
SRecipient Command 'Recipient
SUB)) NonEmpty (RecipientId, SndPrivateAuthKey)
qs
    process :: Response ErrorType BrokerMsg
-> IO (RecipientId, Either SMPClientError (Maybe RecipientId))
process r :: Response ErrorType BrokerMsg
r@(Response RecipientId
rId Either SMPClientError BrokerMsg
_) = (RecipientId
rId,) (Either SMPClientError (Maybe RecipientId)
 -> (RecipientId, Either SMPClientError (Maybe RecipientId)))
-> IO (Either SMPClientError (Maybe RecipientId))
-> IO (RecipientId, Either SMPClientError (Maybe RecipientId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPClient
-> Response ErrorType BrokerMsg
-> IO (Either SMPClientError (Maybe RecipientId))
processSUBResponse SMPClient
c Response ErrorType BrokerMsg
r

processSUBResponse :: SMPClient -> Response ErrorType BrokerMsg -> IO (Either SMPClientError (Maybe ServiceId))
processSUBResponse :: SMPClient
-> Response ErrorType BrokerMsg
-> IO (Either SMPClientError (Maybe RecipientId))
processSUBResponse SMPClient
c (Response RecipientId
rId Either SMPClientError BrokerMsg
r) = Either SMPClientError BrokerMsg
-> IO (Either SMPClientError BrokerMsg)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either SMPClientError BrokerMsg
r IO (Either SMPClientError BrokerMsg)
-> (BrokerMsg -> IO (Either SMPClientError (Maybe RecipientId)))
-> IO (Either SMPClientError (Maybe RecipientId))
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= SMPClient
-> RecipientId
-> BrokerMsg
-> IO (Either SMPClientError (Maybe RecipientId))
processSUBResponse_ SMPClient
c RecipientId
rId

processSUBResponse_ :: SMPClient -> RecipientId -> BrokerMsg -> IO (Either SMPClientError (Maybe ServiceId))
processSUBResponse_ :: SMPClient
-> RecipientId
-> BrokerMsg
-> IO (Either SMPClientError (Maybe RecipientId))
processSUBResponse_ SMPClient
c RecipientId
rId = \case
  BrokerMsg
OK -> Either SMPClientError (Maybe RecipientId)
-> IO (Either SMPClientError (Maybe RecipientId))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SMPClientError (Maybe RecipientId)
 -> IO (Either SMPClientError (Maybe RecipientId)))
-> Either SMPClientError (Maybe RecipientId)
-> IO (Either SMPClientError (Maybe RecipientId))
forall a b. (a -> b) -> a -> b
$ Maybe RecipientId -> Either SMPClientError (Maybe RecipientId)
forall a b. b -> Either a b
Right Maybe RecipientId
forall a. Maybe a
Nothing
  SOK Maybe RecipientId
serviceId_ -> Either SMPClientError (Maybe RecipientId)
-> IO (Either SMPClientError (Maybe RecipientId))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SMPClientError (Maybe RecipientId)
 -> IO (Either SMPClientError (Maybe RecipientId)))
-> Either SMPClientError (Maybe RecipientId)
-> IO (Either SMPClientError (Maybe RecipientId))
forall a b. (a -> b) -> a -> b
$ Maybe RecipientId -> Either SMPClientError (Maybe RecipientId)
forall a b. b -> Either a b
Right Maybe RecipientId
serviceId_
  cmd :: BrokerMsg
cmd@MSG {} -> SMPClient -> RecipientId -> BrokerMsg -> IO ()
writeSMPMessage SMPClient
c RecipientId
rId BrokerMsg
cmd IO ()
-> Either SMPClientError (Maybe RecipientId)
-> IO (Either SMPClientError (Maybe RecipientId))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe RecipientId -> Either SMPClientError (Maybe RecipientId)
forall a b. b -> Either a b
Right Maybe RecipientId
forall a. Maybe a
Nothing
  BrokerMsg
r' -> Either SMPClientError (Maybe RecipientId)
-> IO (Either SMPClientError (Maybe RecipientId))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SMPClientError (Maybe RecipientId)
 -> IO (Either SMPClientError (Maybe RecipientId)))
-> (SMPClientError -> Either SMPClientError (Maybe RecipientId))
-> SMPClientError
-> IO (Either SMPClientError (Maybe RecipientId))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPClientError -> Either SMPClientError (Maybe RecipientId)
forall a b. a -> Either a b
Left (SMPClientError -> IO (Either SMPClientError (Maybe RecipientId)))
-> SMPClientError -> IO (Either SMPClientError (Maybe RecipientId))
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r'

writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
writeSMPMessage SMPClient
c RecipientId
rId BrokerMsg
msg = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ (TBQueue
   ((Int64, ProtocolServer 'PSMP, Maybe ByteString),
    Version SMPVersion, ByteString,
    NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg))
 -> STM ())
-> Maybe
     (TBQueue
        ((Int64, ProtocolServer 'PSMP, Maybe ByteString),
         Version SMPVersion, ByteString,
         NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg)))
-> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TBQueue
  ((Int64, ProtocolServer 'PSMP, Maybe ByteString),
   Version SMPVersion, ByteString,
   NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg))
-> ((Int64, ProtocolServer 'PSMP, Maybe ByteString),
    Version SMPVersion, ByteString,
    NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg))
-> STM ()
forall a. TBQueue a -> a -> STM ()
`writeTBQueue` SMPClient
-> NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg)
-> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg
forall v err msg.
ProtocolClient v err msg
-> NonEmpty (RecipientId, ServerTransmission err msg)
-> ServerTransmissionBatch v err msg
serverTransmission SMPClient
c [(RecipientId
rId, Either SMPClientError BrokerMsg
-> ServerTransmission ErrorType BrokerMsg
forall err msg.
Either (ProtocolClientError err) msg -> ServerTransmission err msg
STEvent (BrokerMsg -> Either SMPClientError BrokerMsg
forall a b. b -> Either a b
Right BrokerMsg
msg))]) (PClient SMPVersion ErrorType BrokerMsg
-> Maybe
     (TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg))
forall v err msg.
PClient v err msg
-> Maybe (TBQueue (ServerTransmissionBatch v err msg))
msgQ (PClient SMPVersion ErrorType BrokerMsg
 -> Maybe
      (TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)))
-> PClient SMPVersion ErrorType BrokerMsg
-> Maybe
     (TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg))
forall a b. (a -> b) -> a -> b
$ SMPClient -> PClient SMPVersion ErrorType BrokerMsg
forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ SMPClient
c)

serverTransmission :: ProtocolClient v err msg -> NonEmpty (RecipientId, ServerTransmission err msg) -> ServerTransmissionBatch v err msg
serverTransmission :: forall v err msg.
ProtocolClient v err msg
-> NonEmpty (RecipientId, ServerTransmission err msg)
-> ServerTransmissionBatch v err msg
serverTransmission ProtocolClient {$sel:thParams:ProtocolClient :: forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams = THandleParams {Version v
$sel:thVersion:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Version v
thVersion :: Version v
thVersion, ByteString
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId :: ByteString
sessionId}, $sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {TransportSession msg
$sel:transportSession:PClient :: forall v err msg. PClient v err msg -> TransportSession msg
transportSession :: TransportSession msg
transportSession}} NonEmpty (RecipientId, ServerTransmission err msg)
ts =
  (TransportSession msg
transportSession, Version v
thVersion, ByteString
sessionId, NonEmpty (RecipientId, ServerTransmission err msg)
ts)

-- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
--
-- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue
-- This command is always sent in interactive request mode, as NSE has limited time
getSMPMessage :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage)
getSMPMessage :: SMPClient
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO (Maybe RcvMessage)
getSMPMessage SMPClient
c SndPrivateAuthKey
rpKey RecipientId
rId =
  SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'Recipient
-> ExceptT SMPClientError IO BrokerMsg
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient
c NetworkRequestMode
NRMInteractive (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
rpKey) RecipientId
rId Command 'Recipient
GET ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg -> ExceptT SMPClientError IO (Maybe RcvMessage))
-> ExceptT SMPClientError IO (Maybe RcvMessage)
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    BrokerMsg
OK -> Maybe RcvMessage -> ExceptT SMPClientError IO (Maybe RcvMessage)
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RcvMessage
forall a. Maybe a
Nothing
    cmd :: BrokerMsg
cmd@(MSG RcvMessage
msg) -> IO () -> ExceptT SMPClientError IO ()
forall a. IO a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SMPClient -> RecipientId -> BrokerMsg -> IO ()
writeSMPMessage SMPClient
c RecipientId
rId BrokerMsg
cmd) ExceptT SMPClientError IO ()
-> Maybe RcvMessage -> ExceptT SMPClientError IO (Maybe RcvMessage)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> RcvMessage -> Maybe RcvMessage
forall a. a -> Maybe a
Just RcvMessage
msg
    BrokerMsg
r -> SMPClientError -> ExceptT SMPClientError IO (Maybe RcvMessage)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO (Maybe RcvMessage))
-> SMPClientError -> ExceptT SMPClientError IO (Maybe RcvMessage)
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r
{-# INLINE getSMPMessage #-}

-- | Subscribe to the SMP queue notifications.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
-- This command is always sent in background request mode
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO (Maybe ServiceId)
subscribeSMPQueueNotifications :: SMPClient
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO (Maybe RecipientId)
subscribeSMPQueueNotifications SMPClient
c SndPrivateAuthKey
npKey RecipientId
nId = do
  IO () -> ExceptT SMPClientError IO ()
forall a. IO a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT SMPClientError IO ())
-> IO () -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ SMPClient -> IO ()
enablePings SMPClient
c
  SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'Notifier
-> ExceptT SMPClientError IO BrokerMsg
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient
c NetworkRequestMode
NRMBackground (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
npKey) RecipientId
nId Command 'Notifier
NSUB ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg -> ExceptT SMPClientError IO (Maybe RecipientId))
-> ExceptT SMPClientError IO (Maybe RecipientId)
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SMPClientError (Maybe RecipientId)
-> ExceptT SMPClientError IO (Maybe RecipientId)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either SMPClientError (Maybe RecipientId)
 -> ExceptT SMPClientError IO (Maybe RecipientId))
-> (BrokerMsg -> Either SMPClientError (Maybe RecipientId))
-> BrokerMsg
-> ExceptT SMPClientError IO (Maybe RecipientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BrokerMsg -> Either SMPClientError (Maybe RecipientId)
nsubResponse_

-- | Subscribe to multiple SMP queues notifications batching commands if supported.
-- This command is always sent in background request mode
subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId)))
subscribeSMPQueuesNtfs :: SMPClient
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError (Maybe RecipientId)))
subscribeSMPQueuesNtfs SMPClient
c NonEmpty (RecipientId, SndPrivateAuthKey)
qs = do
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SMPClient -> IO ()
enablePings SMPClient
c
  (Response ErrorType BrokerMsg
 -> Either SMPClientError (Maybe RecipientId))
-> NonEmpty (Response ErrorType BrokerMsg)
-> NonEmpty (Either SMPClientError (Maybe RecipientId))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map Response ErrorType BrokerMsg
-> Either SMPClientError (Maybe RecipientId)
nsubResponse (NonEmpty (Response ErrorType BrokerMsg)
 -> NonEmpty (Either SMPClientError (Maybe RecipientId)))
-> IO (NonEmpty (Response ErrorType BrokerMsg))
-> IO (NonEmpty (Either SMPClientError (Maybe RecipientId)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPClient
-> NetworkRequestMode
-> NonEmpty (ClientCommand BrokerMsg)
-> IO (NonEmpty (Response ErrorType BrokerMsg))
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> NonEmpty (ClientCommand msg)
-> IO (NonEmpty (Response err msg))
sendProtocolCommands SMPClient
c NetworkRequestMode
NRMBackground NonEmpty (ClientCommand BrokerMsg)
NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
cs
  where
    cs :: NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
cs = ((RecipientId, SndPrivateAuthKey)
 -> (RecipientId, Maybe SndPrivateAuthKey, Cmd))
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\(RecipientId
nId, SndPrivateAuthKey
npKey) -> (RecipientId
nId, SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
npKey, SParty 'Notifier -> Command 'Notifier -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'Notifier
SNotifier Command 'Notifier
NSUB)) NonEmpty (RecipientId, SndPrivateAuthKey)
qs

nsubResponse :: Response ErrorType BrokerMsg -> Either SMPClientError (Maybe ServiceId)
nsubResponse :: Response ErrorType BrokerMsg
-> Either SMPClientError (Maybe RecipientId)
nsubResponse (Response RecipientId
_ Either SMPClientError BrokerMsg
r) = Either SMPClientError BrokerMsg
r Either SMPClientError BrokerMsg
-> (BrokerMsg -> Either SMPClientError (Maybe RecipientId))
-> Either SMPClientError (Maybe RecipientId)
forall a b.
Either SMPClientError a
-> (a -> Either SMPClientError b) -> Either SMPClientError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BrokerMsg -> Either SMPClientError (Maybe RecipientId)
nsubResponse_
{-# INLINE nsubResponse #-}

nsubResponse_ :: BrokerMsg -> Either SMPClientError (Maybe ServiceId)
nsubResponse_ :: BrokerMsg -> Either SMPClientError (Maybe RecipientId)
nsubResponse_ = \case
  BrokerMsg
OK -> Maybe RecipientId -> Either SMPClientError (Maybe RecipientId)
forall a b. b -> Either a b
Right Maybe RecipientId
forall a. Maybe a
Nothing
  SOK Maybe RecipientId
serviceId_ -> Maybe RecipientId -> Either SMPClientError (Maybe RecipientId)
forall a b. b -> Either a b
Right Maybe RecipientId
serviceId_
  BrokerMsg
r' -> SMPClientError -> Either SMPClientError (Maybe RecipientId)
forall a b. a -> Either a b
Left (SMPClientError -> Either SMPClientError (Maybe RecipientId))
-> SMPClientError -> Either SMPClientError (Maybe RecipientId)
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r'
{-# INLINE nsubResponse_ #-}

-- This command is always sent in background request mode
subscribeService :: forall p. (PartyI p, ServiceParty p) => SMPClient -> SParty p -> ExceptT SMPClientError IO Int64
subscribeService :: forall (p :: Party).
(PartyI p, ServiceParty p) =>
SMPClient -> SParty p -> ExceptT SMPClientError IO Int64
subscribeService SMPClient
c SParty p
party = case SMPClient -> Maybe THClientService
smpClientService SMPClient
c of
  Just THClientService {RecipientId
serviceId :: RecipientId
$sel:serviceId:THClientService :: forall k. THClientService' k -> RecipientId
serviceId, PrivateKey 'Ed25519
serviceKey :: PrivateKey 'Ed25519
$sel:serviceKey:THClientService :: forall k. THClientService' k -> k
serviceKey} -> do
    IO () -> ExceptT SMPClientError IO ()
forall a. IO a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT SMPClientError IO ())
-> IO () -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ SMPClient -> IO ()
enablePings SMPClient
c
    SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient
c NetworkRequestMode
NRMBackground (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just (SAlgorithm 'Ed25519 -> PrivateKey 'Ed25519 -> SndPrivateAuthKey
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> PrivateKey a -> SndPrivateAuthKey
C.APrivateAuthKey SAlgorithm 'Ed25519
C.SEd25519 PrivateKey 'Ed25519
serviceKey)) RecipientId
serviceId Command p
subCmd ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg -> ExceptT SMPClientError IO Int64)
-> ExceptT SMPClientError IO Int64
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      SOKS Int64
n -> Int64 -> ExceptT SMPClientError IO Int64
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
n
      BrokerMsg
r -> SMPClientError -> ExceptT SMPClientError IO Int64
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO Int64)
-> SMPClientError -> ExceptT SMPClientError IO Int64
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r
    where
      subCmd :: Command p
      subCmd :: Command p
subCmd = case SParty p
party of
        SParty p
SRecipientService -> Command p
Command 'RecipientService
SUBS
        SParty p
SNotifierService -> Command p
Command 'NotifierService
NSUBS
  Maybe THClientService
Nothing -> SMPClientError -> ExceptT SMPClientError IO Int64
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SMPClientError
forall err. ProtocolClientError err
PCEServiceUnavailable

smpClientService :: SMPClient -> Maybe THClientService
smpClientService :: SMPClient -> Maybe THClientService
smpClientService = THandleParams SMPVersion 'TClient -> Maybe (THandleAuth 'TClient)
forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth (THandleParams SMPVersion 'TClient -> Maybe (THandleAuth 'TClient))
-> (SMPClient -> THandleParams SMPVersion 'TClient)
-> SMPClient
-> Maybe (THandleAuth 'TClient)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPClient -> THandleParams SMPVersion 'TClient
forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams (SMPClient -> Maybe (THandleAuth 'TClient))
-> (THandleAuth 'TClient -> Maybe THClientService)
-> SMPClient
-> Maybe THClientService
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> THandleAuth 'TClient -> Maybe THClientService
clientService
{-# INLINE smpClientService #-}

enablePings :: SMPClient -> IO ()
enablePings :: SMPClient -> IO ()
enablePings ProtocolClient {$sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {TVar Bool
$sel:sendPings:PClient :: forall v err msg. PClient v err msg -> TVar Bool
sendPings :: TVar Bool
sendPings}} = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
sendPings Bool
True
{-# INLINE enablePings #-}

-- | Secure the SMP queue by adding a sender public key.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
secureSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
secureSMPQueue :: SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> RcvPublicAuthKey
-> ExceptT SMPClientError IO ()
secureSMPQueue SMPClient
c NetworkRequestMode
nm SndPrivateAuthKey
rpKey RecipientId
rId RcvPublicAuthKey
senderKey = Command 'Recipient
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
forall (p :: Party).
PartyI p =>
Command p
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
okSMPCommand (RcvPublicAuthKey -> Command 'Recipient
KEY RcvPublicAuthKey
senderKey) SMPClient
c NetworkRequestMode
nm SndPrivateAuthKey
rpKey RecipientId
rId
{-# INLINE secureSMPQueue #-}

-- | Secure the SMP queue via sender queue ID.
secureSndSMPQueue :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> SenderId -> ExceptT SMPClientError IO ()
secureSndSMPQueue :: SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
secureSndSMPQueue SMPClient
c NetworkRequestMode
nm SndPrivateAuthKey
spKey RecipientId
sId = Command 'Sender
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
forall (p :: Party).
PartyI p =>
Command p
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
okSMPCommand (RcvPublicAuthKey -> Command 'Sender
SKEY (RcvPublicAuthKey -> Command 'Sender)
-> RcvPublicAuthKey -> Command 'Sender
forall a b. (a -> b) -> a -> b
$ SndPrivateAuthKey -> PublicKeyType SndPrivateAuthKey
forall pk. CryptoPrivateKey pk => pk -> PublicKeyType pk
C.toPublic SndPrivateAuthKey
spKey) SMPClient
c NetworkRequestMode
nm SndPrivateAuthKey
spKey RecipientId
sId
{-# INLINE secureSndSMPQueue #-}

proxySecureSndSMPQueue :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySecureSndSMPQueue :: SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySecureSndSMPQueue SMPClient
c NetworkRequestMode
nm ProxiedRelay
proxiedRelay SndPrivateAuthKey
spKey RecipientId
sId = SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'Sender
-> ExceptT SMPClientError IO (Either ProxyClientError ())
proxyOKSMPCommand SMPClient
c NetworkRequestMode
nm ProxiedRelay
proxiedRelay (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
spKey) RecipientId
sId (RcvPublicAuthKey -> Command 'Sender
SKEY (RcvPublicAuthKey -> Command 'Sender)
-> RcvPublicAuthKey -> Command 'Sender
forall a b. (a -> b) -> a -> b
$ SndPrivateAuthKey -> PublicKeyType SndPrivateAuthKey
forall pk. CryptoPrivateKey pk => pk -> PublicKeyType pk
C.toPublic SndPrivateAuthKey
spKey)
{-# INLINE proxySecureSndSMPQueue #-}

-- | Add or update date for queue link
addSMPQueueLink :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO ()
addSMPQueueLink :: SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> RecipientId
-> QueueLinkData
-> ExceptT SMPClientError IO ()
addSMPQueueLink SMPClient
c NetworkRequestMode
nm SndPrivateAuthKey
rpKey RecipientId
rId RecipientId
lnkId QueueLinkData
d = Command 'Recipient
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
forall (p :: Party).
PartyI p =>
Command p
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
okSMPCommand (RecipientId -> QueueLinkData -> Command 'Recipient
LSET RecipientId
lnkId QueueLinkData
d) SMPClient
c NetworkRequestMode
nm SndPrivateAuthKey
rpKey RecipientId
rId
{-# INLINE addSMPQueueLink #-}

-- | Delete queue link
deleteSMPQueueLink :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
deleteSMPQueueLink :: SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
deleteSMPQueueLink = Command 'Recipient
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
forall (p :: Party).
PartyI p =>
Command p
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
okSMPCommand Command 'Recipient
LDEL
{-# INLINE deleteSMPQueueLink #-}

-- | Get 1-time inviation SMP queue link data and secure the queue via queue link ID.
secureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
secureGetSMPQueueLink :: SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
secureGetSMPQueueLink SMPClient
c NetworkRequestMode
nm SndPrivateAuthKey
spKey RecipientId
lnkId =
  SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'LinkClient
-> ExceptT SMPClientError IO BrokerMsg
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient
c NetworkRequestMode
nm (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
spKey) RecipientId
lnkId (RcvPublicAuthKey -> Command 'LinkClient
LKEY (RcvPublicAuthKey -> Command 'LinkClient)
-> RcvPublicAuthKey -> Command 'LinkClient
forall a b. (a -> b) -> a -> b
$ SndPrivateAuthKey -> PublicKeyType SndPrivateAuthKey
forall pk. CryptoPrivateKey pk => pk -> PublicKeyType pk
C.toPublic SndPrivateAuthKey
spKey) ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg
    -> ExceptT SMPClientError IO (RecipientId, QueueLinkData))
-> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    LNK RecipientId
sId QueueLinkData
d -> (RecipientId, QueueLinkData)
-> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RecipientId
sId, QueueLinkData
d)
    BrokerMsg
r -> SMPClientError
-> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError
 -> ExceptT SMPClientError IO (RecipientId, QueueLinkData))
-> SMPClientError
-> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r

proxySecureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
proxySecureGetSMPQueueLink :: SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
proxySecureGetSMPQueueLink SMPClient
c NetworkRequestMode
nm ProxiedRelay
proxiedRelay SndPrivateAuthKey
spKey RecipientId
lnkId =
  SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'LinkClient
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
proxySMPCommand  SMPClient
c NetworkRequestMode
nm ProxiedRelay
proxiedRelay (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
spKey) RecipientId
lnkId (RcvPublicAuthKey -> Command 'LinkClient
LKEY (RcvPublicAuthKey -> Command 'LinkClient)
-> RcvPublicAuthKey -> Command 'LinkClient
forall a b. (a -> b) -> a -> b
$ SndPrivateAuthKey -> PublicKeyType SndPrivateAuthKey
forall pk. CryptoPrivateKey pk => pk -> PublicKeyType pk
C.toPublic SndPrivateAuthKey
spKey) ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
-> (Either ProxyClientError BrokerMsg
    -> ExceptT
         SMPClientError
         IO
         (Either ProxyClientError (RecipientId, QueueLinkData)))
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right (LNK RecipientId
sId QueueLinkData
d) -> Either ProxyClientError (RecipientId, QueueLinkData)
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProxyClientError (RecipientId, QueueLinkData)
 -> ExceptT
      SMPClientError
      IO
      (Either ProxyClientError (RecipientId, QueueLinkData)))
-> Either ProxyClientError (RecipientId, QueueLinkData)
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall a b. (a -> b) -> a -> b
$ (RecipientId, QueueLinkData)
-> Either ProxyClientError (RecipientId, QueueLinkData)
forall a b. b -> Either a b
Right (RecipientId
sId, QueueLinkData
d)
    Right BrokerMsg
r -> SMPClientError
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError
 -> ExceptT
      SMPClientError
      IO
      (Either ProxyClientError (RecipientId, QueueLinkData)))
-> SMPClientError
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r
    Left ProxyClientError
e -> Either ProxyClientError (RecipientId, QueueLinkData)
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProxyClientError (RecipientId, QueueLinkData)
 -> ExceptT
      SMPClientError
      IO
      (Either ProxyClientError (RecipientId, QueueLinkData)))
-> Either ProxyClientError (RecipientId, QueueLinkData)
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall a b. (a -> b) -> a -> b
$ ProxyClientError
-> Either ProxyClientError (RecipientId, QueueLinkData)
forall a b. a -> Either a b
Left ProxyClientError
e

-- | Get contact address SMP queue link data.
getSMPQueueLink :: SMPClient -> NetworkRequestMode -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
getSMPQueueLink :: SMPClient
-> NetworkRequestMode
-> RecipientId
-> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
getSMPQueueLink SMPClient
c NetworkRequestMode
nm RecipientId
lnkId =
  SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'LinkClient
-> ExceptT SMPClientError IO BrokerMsg
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient
c NetworkRequestMode
nm Maybe SndPrivateAuthKey
forall a. Maybe a
Nothing RecipientId
lnkId Command 'LinkClient
LGET ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg
    -> ExceptT SMPClientError IO (RecipientId, QueueLinkData))
-> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    LNK RecipientId
sId QueueLinkData
d -> (RecipientId, QueueLinkData)
-> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RecipientId
sId, QueueLinkData
d)
    BrokerMsg
r -> SMPClientError
-> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError
 -> ExceptT SMPClientError IO (RecipientId, QueueLinkData))
-> SMPClientError
-> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r

-- LGET command - get short link data
proxyGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
proxyGetSMPQueueLink :: SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> RecipientId
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
proxyGetSMPQueueLink SMPClient
c NetworkRequestMode
nm ProxiedRelay
proxiedRelay RecipientId
lnkId =
  SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'LinkClient
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
proxySMPCommand SMPClient
c NetworkRequestMode
nm ProxiedRelay
proxiedRelay Maybe SndPrivateAuthKey
forall a. Maybe a
Nothing RecipientId
lnkId Command 'LinkClient
LGET ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
-> (Either ProxyClientError BrokerMsg
    -> ExceptT
         SMPClientError
         IO
         (Either ProxyClientError (RecipientId, QueueLinkData)))
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right (LNK RecipientId
sId QueueLinkData
d) -> Either ProxyClientError (RecipientId, QueueLinkData)
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProxyClientError (RecipientId, QueueLinkData)
 -> ExceptT
      SMPClientError
      IO
      (Either ProxyClientError (RecipientId, QueueLinkData)))
-> Either ProxyClientError (RecipientId, QueueLinkData)
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall a b. (a -> b) -> a -> b
$ (RecipientId, QueueLinkData)
-> Either ProxyClientError (RecipientId, QueueLinkData)
forall a b. b -> Either a b
Right (RecipientId
sId, QueueLinkData
d)
    Right BrokerMsg
r -> SMPClientError
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError
 -> ExceptT
      SMPClientError
      IO
      (Either ProxyClientError (RecipientId, QueueLinkData)))
-> SMPClientError
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r
    Left ProxyClientError
e -> Either ProxyClientError (RecipientId, QueueLinkData)
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProxyClientError (RecipientId, QueueLinkData)
 -> ExceptT
      SMPClientError
      IO
      (Either ProxyClientError (RecipientId, QueueLinkData)))
-> Either ProxyClientError (RecipientId, QueueLinkData)
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
forall a b. (a -> b) -> a -> b
$ ProxyClientError
-> Either ProxyClientError (RecipientId, QueueLinkData)
forall a b. a -> Either a b
Left ProxyClientError
e

-- | Enable notifications for the queue for push notifications server.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
enableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey)
enableSMPQueueNotifications :: SMPClient
-> SndPrivateAuthKey
-> RecipientId
-> RcvPublicAuthKey
-> PublicKeyX25519
-> ExceptT SMPClientError IO (RecipientId, PublicKeyX25519)
enableSMPQueueNotifications SMPClient
c SndPrivateAuthKey
rpKey RecipientId
rId RcvPublicAuthKey
notifierKey PublicKeyX25519
rcvNtfPublicDhKey =
  SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'Recipient
-> ExceptT SMPClientError IO BrokerMsg
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient
c NetworkRequestMode
NRMBackground (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
rpKey) RecipientId
rId (RcvPublicAuthKey -> PublicKeyX25519 -> Command 'Recipient
NKEY RcvPublicAuthKey
notifierKey PublicKeyX25519
rcvNtfPublicDhKey) ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg
    -> ExceptT SMPClientError IO (RecipientId, PublicKeyX25519))
-> ExceptT SMPClientError IO (RecipientId, PublicKeyX25519)
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    NID RecipientId
nId PublicKeyX25519
rcvNtfSrvPublicDhKey -> (RecipientId, PublicKeyX25519)
-> ExceptT SMPClientError IO (RecipientId, PublicKeyX25519)
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RecipientId
nId, PublicKeyX25519
rcvNtfSrvPublicDhKey)
    BrokerMsg
r -> SMPClientError
-> ExceptT SMPClientError IO (RecipientId, PublicKeyX25519)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError
 -> ExceptT SMPClientError IO (RecipientId, PublicKeyX25519))
-> SMPClientError
-> ExceptT SMPClientError IO (RecipientId, PublicKeyX25519)
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r

-- | Enable notifications for the multiple queues for push notifications server.
-- This command is always sent in background request mode
enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
enableSMPQueuesNtfs :: SMPClient
-> NonEmpty
     (RecipientId, SndPrivateAuthKey, RcvPublicAuthKey, PublicKeyX25519)
-> IO
     (NonEmpty (Either SMPClientError (RecipientId, PublicKeyX25519)))
enableSMPQueuesNtfs SMPClient
c NonEmpty
  (RecipientId, SndPrivateAuthKey, RcvPublicAuthKey, PublicKeyX25519)
qs = (Response ErrorType BrokerMsg
 -> Either SMPClientError (RecipientId, PublicKeyX25519))
-> NonEmpty (Response ErrorType BrokerMsg)
-> NonEmpty (Either SMPClientError (RecipientId, PublicKeyX25519))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map Response ErrorType BrokerMsg
-> Either SMPClientError (RecipientId, PublicKeyX25519)
forall {err}.
Response err BrokerMsg
-> Either (ProtocolClientError err) (RecipientId, PublicKeyX25519)
process (NonEmpty (Response ErrorType BrokerMsg)
 -> NonEmpty (Either SMPClientError (RecipientId, PublicKeyX25519)))
-> IO (NonEmpty (Response ErrorType BrokerMsg))
-> IO
     (NonEmpty (Either SMPClientError (RecipientId, PublicKeyX25519)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPClient
-> NetworkRequestMode
-> NonEmpty (ClientCommand BrokerMsg)
-> IO (NonEmpty (Response ErrorType BrokerMsg))
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> NonEmpty (ClientCommand msg)
-> IO (NonEmpty (Response err msg))
sendProtocolCommands SMPClient
c NetworkRequestMode
NRMBackground NonEmpty (ClientCommand BrokerMsg)
NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
cs
  where
    cs :: NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
cs = ((RecipientId, SndPrivateAuthKey, RcvPublicAuthKey,
  PublicKeyX25519)
 -> (RecipientId, Maybe SndPrivateAuthKey, Cmd))
-> NonEmpty
     (RecipientId, SndPrivateAuthKey, RcvPublicAuthKey, PublicKeyX25519)
-> NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\(RecipientId
rId, SndPrivateAuthKey
rpKey, RcvPublicAuthKey
notifierKey, PublicKeyX25519
rcvNtfPublicDhKey) -> (RecipientId
rId, SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
rpKey, SParty 'Recipient -> Command 'Recipient -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'Recipient
SRecipient (Command 'Recipient -> Cmd) -> Command 'Recipient -> Cmd
forall a b. (a -> b) -> a -> b
$ RcvPublicAuthKey -> PublicKeyX25519 -> Command 'Recipient
NKEY RcvPublicAuthKey
notifierKey PublicKeyX25519
rcvNtfPublicDhKey)) NonEmpty
  (RecipientId, SndPrivateAuthKey, RcvPublicAuthKey, PublicKeyX25519)
qs
    process :: Response err BrokerMsg
-> Either (ProtocolClientError err) (RecipientId, PublicKeyX25519)
process (Response RecipientId
_ Either (ProtocolClientError err) BrokerMsg
r) = case Either (ProtocolClientError err) BrokerMsg
r of
      Right (NID RecipientId
nId PublicKeyX25519
rcvNtfSrvPublicDhKey) -> (RecipientId, PublicKeyX25519)
-> Either (ProtocolClientError err) (RecipientId, PublicKeyX25519)
forall a b. b -> Either a b
Right (RecipientId
nId, PublicKeyX25519
rcvNtfSrvPublicDhKey)
      Right BrokerMsg
r' -> ProtocolClientError err
-> Either (ProtocolClientError err) (RecipientId, PublicKeyX25519)
forall a b. a -> Either a b
Left (ProtocolClientError err
 -> Either (ProtocolClientError err) (RecipientId, PublicKeyX25519))
-> ProtocolClientError err
-> Either (ProtocolClientError err) (RecipientId, PublicKeyX25519)
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> ProtocolClientError err
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r'
      Left ProtocolClientError err
e -> ProtocolClientError err
-> Either (ProtocolClientError err) (RecipientId, PublicKeyX25519)
forall a b. a -> Either a b
Left ProtocolClientError err
e

-- | Disable notifications for the queue for push notifications server.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
-- This command is always sent in background request mode
disableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
disableSMPQueueNotifications :: SMPClient
-> SndPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
disableSMPQueueNotifications SMPClient
c = Command 'Recipient
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
forall (p :: Party).
PartyI p =>
Command p
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
okSMPCommand Command 'Recipient
NDEL SMPClient
c NetworkRequestMode
NRMBackground
{-# INLINE disableSMPQueueNotifications #-}

-- | Disable notifications for multiple queues for push notifications server.
-- This command is always sent in background request mode
disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
disableSMPQueuesNtfs :: SMPClient
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError ()))
disableSMPQueuesNtfs SMPClient
c = Command 'Recipient
-> SMPClient
-> NetworkRequestMode
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError ()))
forall (p :: Party).
PartyI p =>
Command p
-> SMPClient
-> NetworkRequestMode
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError ()))
okSMPCommands Command 'Recipient
NDEL SMPClient
c NetworkRequestMode
NRMBackground
{-# INLINE disableSMPQueuesNtfs #-}

-- | Send SMP message.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
sendSMPMessage :: SMPClient -> NetworkRequestMode -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
sendSMPMessage :: SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> MsgFlags
-> ByteString
-> ExceptT SMPClientError IO ()
sendSMPMessage SMPClient
c NetworkRequestMode
nm Maybe SndPrivateAuthKey
spKey RecipientId
sId MsgFlags
flags ByteString
msg =
  SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'Sender
-> ExceptT SMPClientError IO BrokerMsg
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient
c NetworkRequestMode
nm Maybe SndPrivateAuthKey
spKey RecipientId
sId (MsgFlags -> ByteString -> Command 'Sender
SEND MsgFlags
flags ByteString
msg) ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg -> ExceptT SMPClientError IO ())
-> ExceptT SMPClientError IO ()
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    BrokerMsg
OK -> () -> ExceptT SMPClientError IO ()
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    BrokerMsg
r -> SMPClientError -> ExceptT SMPClientError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO ())
-> SMPClientError -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r

proxySMPMessage :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySMPMessage :: SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> Maybe SndPrivateAuthKey
-> RecipientId
-> MsgFlags
-> ByteString
-> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySMPMessage SMPClient
c NetworkRequestMode
nm ProxiedRelay
proxiedRelay Maybe SndPrivateAuthKey
spKey RecipientId
sId MsgFlags
flags ByteString
msg = SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'Sender
-> ExceptT SMPClientError IO (Either ProxyClientError ())
proxyOKSMPCommand SMPClient
c NetworkRequestMode
nm ProxiedRelay
proxiedRelay Maybe SndPrivateAuthKey
spKey RecipientId
sId (MsgFlags -> ByteString -> Command 'Sender
SEND MsgFlags
flags ByteString
msg)

-- | Acknowledge message delivery (server deletes the message).
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
-- This command is always sent in background request mode
ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO ()
ackSMPMessage :: SMPClient
-> SndPrivateAuthKey
-> RecipientId
-> ByteString
-> ExceptT SMPClientError IO ()
ackSMPMessage SMPClient
c SndPrivateAuthKey
rpKey RecipientId
rId ByteString
msgId =
  SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'Recipient
-> ExceptT SMPClientError IO BrokerMsg
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient
c NetworkRequestMode
NRMBackground (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
rpKey) RecipientId
rId (ByteString -> Command 'Recipient
ACK ByteString
msgId) ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg -> ExceptT SMPClientError IO ())
-> ExceptT SMPClientError IO ()
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    BrokerMsg
OK -> () -> ExceptT SMPClientError IO ()
forall a. a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    cmd :: BrokerMsg
cmd@MSG {} -> IO () -> ExceptT SMPClientError IO ()
forall a. IO a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT SMPClientError IO ())
-> IO () -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ SMPClient -> RecipientId -> BrokerMsg -> IO ()
writeSMPMessage SMPClient
c RecipientId
rId BrokerMsg
cmd
    BrokerMsg
r -> SMPClientError -> ExceptT SMPClientError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO ())
-> SMPClientError -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r

-- | Irreversibly suspend SMP queue.
-- The existing messages from the queue will still be delivered.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
suspendSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
suspendSMPQueue :: SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
suspendSMPQueue = Command 'Recipient
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
forall (p :: Party).
PartyI p =>
Command p
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
okSMPCommand Command 'Recipient
OFF
{-# INLINE suspendSMPQueue #-}

-- | Irreversibly delete SMP queue and all messages in it.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
deleteSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
deleteSMPQueue :: SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
deleteSMPQueue = Command 'Recipient
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
forall (p :: Party).
PartyI p =>
Command p
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
okSMPCommand Command 'Recipient
DEL
{-# INLINE deleteSMPQueue #-}

-- | Delete multiple SMP queues batching commands if supported.
deleteSMPQueues :: SMPClient -> NetworkRequestMode -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
deleteSMPQueues :: SMPClient
-> NetworkRequestMode
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError ()))
deleteSMPQueues = Command 'Recipient
-> SMPClient
-> NetworkRequestMode
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError ()))
forall (p :: Party).
PartyI p =>
Command p
-> SMPClient
-> NetworkRequestMode
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError ()))
okSMPCommands Command 'Recipient
DEL
{-# INLINE deleteSMPQueues #-}

-- send PRXY :: SMPServer -> Maybe BasicAuth -> Command Sender
-- receives PKEY :: SessionId -> X.CertificateChain -> X.SignedExact X.PubKey -> BrokerMsg
connectSMPProxiedRelay :: SMPClient -> NetworkRequestMode -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
connectSMPProxiedRelay :: SMPClient
-> NetworkRequestMode
-> ProtocolServer 'PSMP
-> Maybe BasicAuth
-> ExceptT SMPClientError IO ProxiedRelay
connectSMPProxiedRelay c :: SMPClient
c@ProtocolClient {$sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {NetworkTimeout
$sel:tcpConnectTimeout:PClient :: forall v err msg. PClient v err msg -> NetworkTimeout
tcpConnectTimeout :: NetworkTimeout
tcpConnectTimeout, NetworkTimeout
$sel:tcpTimeout:PClient :: forall v err msg. PClient v err msg -> NetworkTimeout
tcpTimeout :: NetworkTimeout
tcpTimeout}} NetworkRequestMode
nm relayServ :: ProtocolServer 'PSMP
relayServ@ProtocolServer {$sel:port:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> String
port = String
relayPort, $sel:keyHash:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> KeyHash
keyHash = C.KeyHash ByteString
kh} Maybe BasicAuth
proxyAuth
  | THandleParams SMPVersion 'TClient -> Version SMPVersion
forall v (p :: TransportPeer). THandleParams v p -> Version v
thVersion (SMPClient -> THandleParams SMPVersion 'TClient
forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams SMPClient
c) Version SMPVersion -> Version SMPVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version SMPVersion
sendingProxySMPVersion =
      SMPClient
-> NetworkRequestMode
-> Maybe CbNonce
-> Maybe Int
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand BrokerMsg
-> ExceptT SMPClientError IO BrokerMsg
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe CbNonce
-> Maybe Int
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand msg
-> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand_ SMPClient
c NetworkRequestMode
nm Maybe CbNonce
forall a. Maybe a
Nothing Maybe Int
tOut Maybe SndPrivateAuthKey
forall a. Maybe a
Nothing RecipientId
NoEntity (SParty 'ProxiedClient -> Command 'ProxiedClient -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'ProxiedClient
SProxiedClient (ProtocolServer 'PSMP -> Maybe BasicAuth -> Command 'ProxiedClient
PRXY ProtocolServer 'PSMP
relayServ Maybe BasicAuth
proxyAuth)) ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg -> ExceptT SMPClientError IO ProxiedRelay)
-> ExceptT SMPClientError IO ProxiedRelay
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        PKEY ByteString
sId VersionRangeSMP
vr (CertChainPubKey CertificateChain
chain SignedExact PubKey
key) ->
          case VersionRangeSMP
supportedClientSMPRelayVRange VersionRangeSMP
-> VersionRangeSMP
-> Maybe (Compatible (VersionT SMPVersion VersionRangeSMP))
forall v a.
VersionRangeI v a =>
a -> VersionRange v -> Maybe (Compatible (VersionT v a))
`compatibleVersion` VersionRangeSMP
vr of
            Maybe (Compatible (VersionT SMPVersion VersionRangeSMP))
Nothing -> SMPClientError -> ExceptT SMPClientError IO ProxiedRelay
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO ProxiedRelay)
-> SMPClientError -> ExceptT SMPClientError IO ProxiedRelay
forall a b. (a -> b) -> a -> b
$ TransportError -> SMPClientError
transportErr TransportError
TEVersion
            Just (Compatible Version SMPVersion
v) -> do
              PublicKeyX25519
relayKey <- (String -> SMPClientError)
-> Either String PublicKeyX25519
-> ExceptT SMPClientError IO PublicKeyX25519
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (SMPClientError -> String -> SMPClientError
forall a b. a -> b -> a
const (SMPClientError -> String -> SMPClientError)
-> SMPClientError -> String -> SMPClientError
forall a b. (a -> b) -> a -> b
$ TransportError -> SMPClientError
transportErr (TransportError -> SMPClientError)
-> TransportError -> SMPClientError
forall a b. (a -> b) -> a -> b
$ HandshakeError -> TransportError
TEHandshake HandshakeError
IDENTITY) (Either String PublicKeyX25519
 -> ExceptT SMPClientError IO PublicKeyX25519)
-> ExceptT SMPClientError IO (Either String PublicKeyX25519)
-> ExceptT SMPClientError IO PublicKeyX25519
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either String PublicKeyX25519)
-> ExceptT SMPClientError IO (Either String PublicKeyX25519)
forall a. IO a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExceptT String IO PublicKeyX25519
-> IO (Either String PublicKeyX25519)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO PublicKeyX25519
 -> IO (Either String PublicKeyX25519))
-> ExceptT String IO PublicKeyX25519
-> IO (Either String PublicKeyX25519)
forall a b. (a -> b) -> a -> b
$ CertificateChain
-> SignedExact PubKey -> ExceptT String IO PublicKeyX25519
validateRelay CertificateChain
chain SignedExact PubKey
key)
              ProxiedRelay -> ExceptT SMPClientError IO ProxiedRelay
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProxiedRelay -> ExceptT SMPClientError IO ProxiedRelay)
-> ProxiedRelay -> ExceptT SMPClientError IO ProxiedRelay
forall a b. (a -> b) -> a -> b
$ ByteString
-> Version SMPVersion
-> Maybe BasicAuth
-> PublicKeyX25519
-> ProxiedRelay
ProxiedRelay ByteString
sId Version SMPVersion
v Maybe BasicAuth
proxyAuth PublicKeyX25519
relayKey
        BrokerMsg
r -> SMPClientError -> ExceptT SMPClientError IO ProxiedRelay
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO ProxiedRelay)
-> SMPClientError -> ExceptT SMPClientError IO ProxiedRelay
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r
  | Bool
otherwise = SMPClientError -> ExceptT SMPClientError IO ProxiedRelay
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO ProxiedRelay)
-> SMPClientError -> ExceptT SMPClientError IO ProxiedRelay
forall a b. (a -> b) -> a -> b
$ TransportError -> SMPClientError
forall err. TransportError -> ProtocolClientError err
PCETransportError TransportError
TEVersion
  where
    tOut :: Maybe Int
tOut = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout
tcpConnectTimeout NetworkRequestMode
nm Int -> Int -> Int
forall a. Num a => a -> a -> a
+ NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout
tcpTimeout NetworkRequestMode
nm
    transportErr :: TransportError -> SMPClientError
transportErr = ErrorType -> SMPClientError
forall err. err -> ProtocolClientError err
PCEProtocolError (ErrorType -> SMPClientError)
-> (TransportError -> ErrorType)
-> TransportError
-> SMPClientError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProxyError -> ErrorType
PROXY (ProxyError -> ErrorType)
-> (TransportError -> ProxyError) -> TransportError -> ErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BrokerErrorType -> ProxyError
BROKER (BrokerErrorType -> ProxyError)
-> (TransportError -> BrokerErrorType)
-> TransportError
-> ProxyError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportError -> BrokerErrorType
TRANSPORT
    hostName :: String
hostName = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ TransportHost -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (TransportHost -> ByteString) -> TransportHost -> ByteString
forall a b. (a -> b) -> a -> b
$ SMPClient -> TransportHost
forall v err msg. ProtocolClient v err msg -> TransportHost
transportHost' SMPClient
c
    validateRelay :: X.CertificateChain -> X.SignedExact X.PubKey -> ExceptT String IO C.PublicKeyX25519
    validateRelay :: CertificateChain
-> SignedExact PubKey -> ExceptT String IO PublicKeyX25519
validateRelay CertificateChain
chain SignedExact PubKey
exact = case CertificateChain -> ChainCertificates
chainIdCaCerts CertificateChain
chain of
      CCValid {SignedCertificate
leafCert :: SignedCertificate
leafCert :: ChainCertificates -> SignedCertificate
leafCert, SignedCertificate
idCert :: SignedCertificate
idCert :: ChainCertificates -> SignedCertificate
idCert, SignedCertificate
caCert :: SignedCertificate
caCert :: ChainCertificates -> SignedCertificate
caCert}
        | ByteString -> Fingerprint
XV.Fingerprint ByteString
kh Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== SignedCertificate -> HashALG -> Fingerprint
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> HashALG -> Fingerprint
XV.getFingerprint SignedCertificate
idCert HashALG
X.HashSHA256 -> do
            [FailedReason]
errs <- IO [FailedReason] -> ExceptT String IO [FailedReason]
forall a. IO a -> ExceptT String IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FailedReason] -> ExceptT String IO [FailedReason])
-> IO [FailedReason] -> ExceptT String IO [FailedReason]
forall a b. (a -> b) -> a -> b
$ SignedCertificate
-> (String, ByteString) -> CertificateChain -> IO [FailedReason]
x509validate SignedCertificate
caCert (String
hostName, String -> ByteString
B.pack String
relayPort) CertificateChain
chain
            Bool -> ExceptT String IO () -> ExceptT String IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FailedReason] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FailedReason]
errs) (ExceptT String IO () -> ExceptT String IO ())
-> ExceptT String IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> ExceptT String IO ()
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"bad certificate"
            APublicVerifyKey
serverKey <- Either String APublicVerifyKey
-> ExceptT String IO APublicVerifyKey
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String APublicVerifyKey
 -> ExceptT String IO APublicVerifyKey)
-> Either String APublicVerifyKey
-> ExceptT String IO APublicVerifyKey
forall a b. (a -> b) -> a -> b
$ PubKey -> Either String APublicVerifyKey
forall k. CryptoPublicKey k => PubKey -> Either String k
C.x509ToPublic' (PubKey -> Either String APublicVerifyKey)
-> PubKey -> Either String APublicVerifyKey
forall a b. (a -> b) -> a -> b
$ Certificate -> PubKey
X.certPubKey (Certificate -> PubKey) -> Certificate -> PubKey
forall a b. (a -> b) -> a -> b
$ Signed Certificate -> Certificate
forall a. (Show a, Eq a, ASN1Object a) => Signed a -> a
X.signedObject (Signed Certificate -> Certificate)
-> Signed Certificate -> Certificate
forall a b. (a -> b) -> a -> b
$ SignedCertificate -> Signed Certificate
forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
X.getSigned SignedCertificate
leafCert
            Either String PublicKeyX25519 -> ExceptT String IO PublicKeyX25519
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String PublicKeyX25519
 -> ExceptT String IO PublicKeyX25519)
-> Either String PublicKeyX25519
-> ExceptT String IO PublicKeyX25519
forall a b. (a -> b) -> a -> b
$ PubKey -> Either String PublicKeyX25519
forall k. CryptoPublicKey k => PubKey -> Either String k
C.x509ToPublic' (PubKey -> Either String PublicKeyX25519)
-> Either String PubKey -> Either String PublicKeyX25519
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< APublicVerifyKey -> SignedExact PubKey -> Either String PubKey
forall o.
(ASN1Object o, Eq o, Show o) =>
APublicVerifyKey -> SignedExact o -> Either String o
C.verifyX509 APublicVerifyKey
serverKey SignedExact PubKey
exact
      ChainCertificates
_ -> String -> ExceptT String IO PublicKeyX25519
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"bad certificate"

data ProxiedRelay = ProxiedRelay
  { ProxiedRelay -> ByteString
prSessionId :: SessionId,
    ProxiedRelay -> Version SMPVersion
prVersion :: VersionSMP,
    ProxiedRelay -> Maybe BasicAuth
prBasicAuth :: Maybe BasicAuth, -- auth is included here to allow reconnecting via the same proxy after NO_SESSION error
    ProxiedRelay -> PublicKeyX25519
prServerKey :: C.PublicKeyX25519
  }

data ProxyClientError
  = -- | protocol error response from proxy
    ProxyProtocolError {ProxyClientError -> ErrorType
protocolErr :: ErrorType}
  | -- | unexpexted response
    ProxyUnexpectedResponse {ProxyClientError -> String
responseStr :: String}
  | -- | error between proxy and server
    ProxyResponseError {ProxyClientError -> ErrorType
responseErr :: ErrorType}
  deriving (ProxyClientError -> ProxyClientError -> Bool
(ProxyClientError -> ProxyClientError -> Bool)
-> (ProxyClientError -> ProxyClientError -> Bool)
-> Eq ProxyClientError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProxyClientError -> ProxyClientError -> Bool
== :: ProxyClientError -> ProxyClientError -> Bool
$c/= :: ProxyClientError -> ProxyClientError -> Bool
/= :: ProxyClientError -> ProxyClientError -> Bool
Eq, Int -> ProxyClientError -> ShowS
[ProxyClientError] -> ShowS
ProxyClientError -> String
(Int -> ProxyClientError -> ShowS)
-> (ProxyClientError -> String)
-> ([ProxyClientError] -> ShowS)
-> Show ProxyClientError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProxyClientError -> ShowS
showsPrec :: Int -> ProxyClientError -> ShowS
$cshow :: ProxyClientError -> String
show :: ProxyClientError -> String
$cshowList :: [ProxyClientError] -> ShowS
showList :: [ProxyClientError] -> ShowS
Show, Show ProxyClientError
Typeable ProxyClientError
(Typeable ProxyClientError, Show ProxyClientError) =>
(ProxyClientError -> SomeException)
-> (SomeException -> Maybe ProxyClientError)
-> (ProxyClientError -> String)
-> Exception ProxyClientError
SomeException -> Maybe ProxyClientError
ProxyClientError -> String
ProxyClientError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ProxyClientError -> SomeException
toException :: ProxyClientError -> SomeException
$cfromException :: SomeException -> Maybe ProxyClientError
fromException :: SomeException -> Maybe ProxyClientError
$cdisplayException :: ProxyClientError -> String
displayException :: ProxyClientError -> String
Exception)

instance StrEncoding ProxyClientError where
  strEncode :: ProxyClientError -> ByteString
strEncode = \case
    ProxyProtocolError ErrorType
e -> ByteString
"PROTOCOL " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ErrorType -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ErrorType
e
    ProxyUnexpectedResponse String
s -> ByteString
"UNEXPECTED " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
B.pack String
s
    ProxyResponseError ErrorType
e -> ByteString
"SYNTAX " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ErrorType -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ErrorType
e
  strP :: Parser ProxyClientError
strP =
    (Char -> Bool) -> Parser ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString
-> (ByteString -> Parser ProxyClientError)
-> Parser ProxyClientError
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"PROTOCOL" -> ErrorType -> ProxyClientError
ProxyProtocolError (ErrorType -> ProxyClientError)
-> Parser ByteString ErrorType -> Parser ProxyClientError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ErrorType
forall a. StrEncoding a => Parser a
_strP
      ByteString
"UNEXPECTED" -> String -> ProxyClientError
ProxyUnexpectedResponse (String -> ProxyClientError)
-> (ByteString -> String) -> ByteString -> ProxyClientError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack (ByteString -> ProxyClientError)
-> Parser ByteString -> Parser ProxyClientError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Char
A.space Parser Char -> Parser ByteString -> Parser 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
*> Parser ByteString
A.takeByteString)
      ByteString
"SYNTAX" -> ErrorType -> ProxyClientError
ProxyResponseError (ErrorType -> ProxyClientError)
-> Parser ByteString ErrorType -> Parser ProxyClientError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ErrorType
forall a. StrEncoding a => Parser a
_strP
      ByteString
_ -> String -> Parser ProxyClientError
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad ProxyClientError"

-- consider how to process slow responses - is it handled somehow locally or delegated to the caller
-- this method is used in the client
-- sends PFWD :: C.PublicKeyX25519 -> EncTransmission -> Command Sender
-- receives PRES :: EncResponse -> BrokerMsg -- proxy to client

-- When client sends message via proxy, there may be one successful scenario and 9 error scenarios
-- as shown below (WTF stands for unexpected response, ??? for response that failed to parse).
--    client        proxy   relay   proxy        client
-- 0) PFWD(SEND) -> RFWD -> RRES -> PRES(OK)  -> ok
-- 1) PFWD(SEND) -> RFWD -> RRES -> PRES(ERR) -> PCEProtocolError - business logic error for client
-- 2) PFWD(SEND) -> RFWD -> RRES -> PRES(WTF) -> PCEUnexpectedReponse - relay/client protocol logic error
-- 3) PFWD(SEND) -> RFWD -> RRES -> PRES(???) -> PCEResponseError - relay/client syntax error
-- 4) PFWD(SEND) -> RFWD -> ERR ->  ERR PROXY PROTOCOL -> ProxyProtocolError - proxy/relay business logic error
-- 5) PFWD(SEND) -> RFWD -> WTF ->  ERR PROXY $ BROKER (UNEXPECTED s) -> ProxyProtocolError - proxy/relay protocol logic
-- 6) PFWD(SEND) -> RFWD -> ??? ->  ERR PROXY $ BROKER (RESPONSE s) -> ProxyProtocolError - - proxy/relay syntax
-- 7) PFWD(SEND) -> ERR  -> ProxyProtocolError - client/proxy business logic
-- 8) PFWD(SEND) -> WTF  -> ProxyUnexpectedResponse - client/proxy protocol logic
-- 9) PFWD(SEND) -> ???  -> ProxyResponseError - client/proxy syntax
--
-- We report as proxySMPCommand error (ExceptT error) the errors of two kinds:
-- - protocol errors from the destination relay wrapped in PRES - to simplify processing of AUTH and QUOTA errors, in this case proxy is "transparent" for such errors (PCEProtocolError, PCEUnexpectedResponse, PCEResponseError)
-- - other response/transport/connection errors from the client connected to proxy itself
-- Other errors are reported in the function result as `Either ProxiedRelayError ()`, including
-- - protocol  errors from the client connected to proxy in ProxyClientError (PCEProtocolError, PCEUnexpectedResponse, PCEResponseError)
-- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError

-- This function proxies Sender commands that return OK or ERR
proxyOKSMPCommand :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxyOKSMPCommand :: SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'Sender
-> ExceptT SMPClientError IO (Either ProxyClientError ())
proxyOKSMPCommand SMPClient
c NetworkRequestMode
nm ProxiedRelay
proxiedRelay Maybe SndPrivateAuthKey
spKey RecipientId
sId Command 'Sender
command =
  SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'Sender
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
proxySMPCommand  SMPClient
c NetworkRequestMode
nm ProxiedRelay
proxiedRelay Maybe SndPrivateAuthKey
spKey RecipientId
sId Command 'Sender
command ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
-> (Either ProxyClientError BrokerMsg
    -> ExceptT SMPClientError IO (Either ProxyClientError ()))
-> ExceptT SMPClientError IO (Either ProxyClientError ())
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right BrokerMsg
OK -> Either ProxyClientError ()
-> ExceptT SMPClientError IO (Either ProxyClientError ())
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProxyClientError ()
 -> ExceptT SMPClientError IO (Either ProxyClientError ()))
-> Either ProxyClientError ()
-> ExceptT SMPClientError IO (Either ProxyClientError ())
forall a b. (a -> b) -> a -> b
$ () -> Either ProxyClientError ()
forall a b. b -> Either a b
Right ()
    Right BrokerMsg
r -> SMPClientError
-> ExceptT SMPClientError IO (Either ProxyClientError ())
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError
 -> ExceptT SMPClientError IO (Either ProxyClientError ()))
-> SMPClientError
-> ExceptT SMPClientError IO (Either ProxyClientError ())
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r
    Left ProxyClientError
e -> Either ProxyClientError ()
-> ExceptT SMPClientError IO (Either ProxyClientError ())
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProxyClientError ()
 -> ExceptT SMPClientError IO (Either ProxyClientError ()))
-> Either ProxyClientError ()
-> ExceptT SMPClientError IO (Either ProxyClientError ())
forall a b. (a -> b) -> a -> b
$ ProxyClientError -> Either ProxyClientError ()
forall a b. a -> Either a b
Left ProxyClientError
e

proxySMPCommand ::
  forall p.
  PartyI p =>
  SMPClient ->
  NetworkRequestMode ->
  -- proxy session from PKEY
  ProxiedRelay ->
  -- message to deliver
  Maybe SndPrivateAuthKey ->
  SenderId ->
  Command p ->
  ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
proxySMPCommand :: forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
proxySMPCommand c :: SMPClient
c@ProtocolClient {$sel:thParams:ProtocolClient :: forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams = THandleParams SMPVersion 'TClient
proxyThParams, $sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {$sel:clientCorrId:PClient :: forall v err msg. PClient v err msg -> TVar ChaChaDRG
clientCorrId = TVar ChaChaDRG
g, NetworkTimeout
$sel:tcpTimeout:PClient :: forall v err msg. PClient v err msg -> NetworkTimeout
tcpTimeout :: NetworkTimeout
tcpTimeout}} NetworkRequestMode
nm (ProxiedRelay ByteString
sessionId Version SMPVersion
v Maybe BasicAuth
_ PublicKeyX25519
serverKey) Maybe SndPrivateAuthKey
spKey RecipientId
sId Command p
command = do
  -- prepare params
  let serverThAuth :: Maybe (THandleAuth 'TClient)
serverThAuth = (\THandleAuth 'TClient
ta -> THandleAuth 'TClient
ta {peerServerPubKey = serverKey}) (THandleAuth 'TClient -> THandleAuth 'TClient)
-> Maybe (THandleAuth 'TClient) -> Maybe (THandleAuth 'TClient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> THandleParams SMPVersion 'TClient -> Maybe (THandleAuth 'TClient)
forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth THandleParams SMPVersion 'TClient
proxyThParams
      serverThParams :: THandleParams SMPVersion 'TClient
serverThParams = Version SMPVersion
-> THandleParams SMPVersion 'TClient
-> THandleParams SMPVersion 'TClient
forall (p :: TransportPeer).
Version SMPVersion
-> THandleParams SMPVersion p -> THandleParams SMPVersion p
smpTHParamsSetVersion Version SMPVersion
v THandleParams SMPVersion 'TClient
proxyThParams {sessionId, thAuth = serverThAuth}
  (PublicKeyX25519
cmdPubKey, PrivateKey 'X25519
cmdPrivKey) <- IO (PublicKeyX25519, PrivateKey 'X25519)
-> ExceptT SMPClientError IO (PublicKeyX25519, PrivateKey 'X25519)
forall a. IO a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PublicKeyX25519, PrivateKey 'X25519)
 -> ExceptT SMPClientError IO (PublicKeyX25519, PrivateKey 'X25519))
-> (STM (KeyPair 'X25519)
    -> IO (PublicKeyX25519, PrivateKey 'X25519))
-> STM (KeyPair 'X25519)
-> ExceptT SMPClientError IO (PublicKeyX25519, PrivateKey 'X25519)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (KeyPair 'X25519) -> IO (PublicKeyX25519, PrivateKey 'X25519)
STM (PublicKeyX25519, PrivateKey 'X25519)
-> IO (PublicKeyX25519, PrivateKey 'X25519)
forall a. STM a -> IO a
atomically (STM (KeyPair 'X25519)
 -> ExceptT SMPClientError IO (PublicKeyX25519, PrivateKey 'X25519))
-> STM (KeyPair 'X25519)
-> ExceptT SMPClientError IO (PublicKeyX25519, PrivateKey 'X25519)
forall a b. (a -> b) -> a -> b
$ forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair @'C.X25519 TVar ChaChaDRG
g
  let cmdSecret :: DhSecret 'X25519
cmdSecret = PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecret 'X25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKeyX25519
serverKey PrivateKey 'X25519
cmdPrivKey
  nonce :: CbNonce
nonce@(C.CbNonce ByteString
corrId) <- IO CbNonce -> ExceptT SMPClientError IO CbNonce
forall a. IO a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CbNonce -> ExceptT SMPClientError IO CbNonce)
-> (STM CbNonce -> IO CbNonce)
-> STM CbNonce
-> ExceptT SMPClientError IO CbNonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM CbNonce -> IO CbNonce
forall a. STM a -> IO a
atomically (STM CbNonce -> ExceptT SMPClientError IO CbNonce)
-> STM CbNonce -> ExceptT SMPClientError IO CbNonce
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM CbNonce
C.randomCbNonce TVar ChaChaDRG
g
  -- encode
  let TransmissionForAuth {ByteString
tForAuth :: ByteString
$sel:tForAuth:TransmissionForAuth :: TransmissionForAuth -> ByteString
tForAuth, ByteString
tToSend :: ByteString
$sel:tToSend:TransmissionForAuth :: TransmissionForAuth -> ByteString
tToSend} = THandleParams SMPVersion 'TClient
-> Transmission Cmd -> TransmissionForAuth
forall v e c (p :: TransportPeer).
ProtocolEncoding v e c =>
THandleParams v p -> Transmission c -> TransmissionForAuth
encodeTransmissionForAuth THandleParams SMPVersion 'TClient
serverThParams (ByteString -> CorrId
CorrId ByteString
corrId, RecipientId
sId, SParty p -> Command p -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd (forall (p :: Party). PartyI p => SParty p
sParty @p) Command p
command)
  -- serviceAuth is False here – proxied commands are not used with service certificates
  Maybe TAuthorizations
auth <- (TransportError -> SMPClientError)
-> Either TransportError (Maybe TAuthorizations)
-> ExceptT SMPClientError IO (Maybe TAuthorizations)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith TransportError -> SMPClientError
forall err. TransportError -> ProtocolClientError err
PCETransportError (Either TransportError (Maybe TAuthorizations)
 -> ExceptT SMPClientError IO (Maybe TAuthorizations))
-> Either TransportError (Maybe TAuthorizations)
-> ExceptT SMPClientError IO (Maybe TAuthorizations)
forall a b. (a -> b) -> a -> b
$ Maybe (THandleAuth 'TClient)
-> Bool
-> Maybe SndPrivateAuthKey
-> CbNonce
-> ByteString
-> Either TransportError (Maybe TAuthorizations)
authTransmission Maybe (THandleAuth 'TClient)
serverThAuth Bool
False Maybe SndPrivateAuthKey
spKey CbNonce
nonce ByteString
tForAuth
  ByteString
b <- case THandleParams SMPVersion 'TClient
-> NonEmpty (Either TransportError SentRawTransmission)
-> [TransportBatch ()]
forall v (p :: TransportPeer).
THandleParams v p
-> NonEmpty (Either TransportError SentRawTransmission)
-> [TransportBatch ()]
batchTransmissions THandleParams SMPVersion 'TClient
serverThParams [SentRawTransmission -> Either TransportError SentRawTransmission
forall a b. b -> Either a b
Right (Maybe TAuthorizations
auth, ByteString
tToSend)] of
    [] -> SMPClientError -> ExceptT SMPClientError IO ByteString
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO ByteString)
-> SMPClientError -> ExceptT SMPClientError IO ByteString
forall a b. (a -> b) -> a -> b
$ TransportError -> SMPClientError
forall err. TransportError -> ProtocolClientError err
PCETransportError TransportError
TELargeMsg
    TBError TransportError
e ()
_ : [TransportBatch ()]
_ -> SMPClientError -> ExceptT SMPClientError IO ByteString
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO ByteString)
-> SMPClientError -> ExceptT SMPClientError IO ByteString
forall a b. (a -> b) -> a -> b
$ TransportError -> SMPClientError
forall err. TransportError -> ProtocolClientError err
PCETransportError TransportError
e
    TBTransmission ByteString
s ()
_ : [TransportBatch ()]
_ -> ByteString -> ExceptT SMPClientError IO ByteString
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
s
    TBTransmissions ByteString
s Int
_ [()]
_ : [TransportBatch ()]
_ -> ByteString -> ExceptT SMPClientError IO ByteString
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
s
  EncTransmission
et <- (CryptoError -> SMPClientError)
-> Either CryptoError EncTransmission
-> ExceptT SMPClientError IO EncTransmission
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith CryptoError -> SMPClientError
forall err. CryptoError -> ProtocolClientError err
PCECryptoError (Either CryptoError EncTransmission
 -> ExceptT SMPClientError IO EncTransmission)
-> Either CryptoError EncTransmission
-> ExceptT SMPClientError IO EncTransmission
forall a b. (a -> b) -> a -> b
$ ByteString -> EncTransmission
EncTransmission (ByteString -> EncTransmission)
-> Either CryptoError ByteString
-> Either CryptoError EncTransmission
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DhSecret 'X25519
-> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
C.cbEncrypt DhSecret 'X25519
cmdSecret CbNonce
nonce ByteString
b Int
paddedProxiedTLength
  -- proxy interaction errors are wrapped
  let tOut :: Maybe Int
tOut = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout
tcpTimeout NetworkRequestMode
nm
  ExceptT SMPClientError IO BrokerMsg
-> ExceptT SMPClientError IO (Either SMPClientError BrokerMsg)
forall (m :: * -> *) e a.
Monad m =>
ExceptT e m a -> ExceptT e m (Either e a)
tryE (SMPClient
-> NetworkRequestMode
-> Maybe CbNonce
-> Maybe Int
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand BrokerMsg
-> ExceptT SMPClientError IO BrokerMsg
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe CbNonce
-> Maybe Int
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand msg
-> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand_ SMPClient
c NetworkRequestMode
nm (CbNonce -> Maybe CbNonce
forall a. a -> Maybe a
Just CbNonce
nonce) Maybe Int
tOut Maybe SndPrivateAuthKey
forall a. Maybe a
Nothing (ByteString -> RecipientId
EntityId ByteString
sessionId) (SParty 'ProxiedClient -> Command 'ProxiedClient -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'ProxiedClient
SProxiedClient (Version SMPVersion
-> PublicKeyX25519 -> EncTransmission -> Command 'ProxiedClient
PFWD Version SMPVersion
v PublicKeyX25519
cmdPubKey EncTransmission
et))) ExceptT SMPClientError IO (Either SMPClientError BrokerMsg)
-> (Either SMPClientError BrokerMsg
    -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right BrokerMsg
r -> case BrokerMsg
r of
      PRES (EncResponse ByteString
er) -> do
        -- server interaction errors are thrown directly
        ByteString
t' <- (CryptoError -> SMPClientError)
-> Either CryptoError ByteString
-> ExceptT SMPClientError IO ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith CryptoError -> SMPClientError
forall err. CryptoError -> ProtocolClientError err
PCECryptoError (Either CryptoError ByteString
 -> ExceptT SMPClientError IO ByteString)
-> Either CryptoError ByteString
-> ExceptT SMPClientError IO ByteString
forall a b. (a -> b) -> a -> b
$ DhSecret 'X25519
-> CbNonce -> ByteString -> Either CryptoError ByteString
C.cbDecrypt DhSecret 'X25519
cmdSecret (CbNonce -> CbNonce
C.reverseNonce CbNonce
nonce) ByteString
er
        case THandleParams SMPVersion 'TClient
-> ByteString -> NonEmpty (Either TransportError RawTransmission)
forall v (p :: TransportPeer).
THandleParams v p
-> ByteString -> NonEmpty (Either TransportError RawTransmission)
tParse THandleParams SMPVersion 'TClient
serverThParams ByteString
t' of
          Either TransportError RawTransmission
t'' :| [] -> case THandleParams SMPVersion 'TClient
-> Either TransportError RawTransmission
-> Transmission (Either ErrorType BrokerMsg)
forall v err cmd.
ProtocolEncoding v err cmd =>
THandleParams v 'TClient
-> Either TransportError RawTransmission
-> Transmission (Either err cmd)
tDecodeClient THandleParams SMPVersion 'TClient
serverThParams Either TransportError RawTransmission
t'' of
            (CorrId
_, RecipientId
_, Either ErrorType BrokerMsg
cmd) -> case Either ErrorType BrokerMsg
cmd of
              Right (ERR ErrorType
e) -> SMPClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> SMPClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> SMPClientError
forall err. err -> ProtocolClientError err
PCEProtocolError ErrorType
e -- this is the error from the destination relay
              Right BrokerMsg
r' -> Either ProxyClientError BrokerMsg
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProxyClientError BrokerMsg
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> Either ProxyClientError BrokerMsg
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> Either ProxyClientError BrokerMsg
forall a b. b -> Either a b
Right BrokerMsg
r'
              Left ErrorType
e -> SMPClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> SMPClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> SMPClientError
forall err. err -> ProtocolClientError err
PCEResponseError ErrorType
e
          NonEmpty (Either TransportError RawTransmission)
_ -> SMPClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> SMPClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a b. (a -> b) -> a -> b
$ TransportError -> SMPClientError
forall err. TransportError -> ProtocolClientError err
PCETransportError TransportError
TEBadBlock
      ERR ErrorType
e -> Either ProxyClientError BrokerMsg
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProxyClientError BrokerMsg
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> (ProxyClientError -> Either ProxyClientError BrokerMsg)
-> ProxyClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProxyClientError -> Either ProxyClientError BrokerMsg
forall a b. a -> Either a b
Left (ProxyClientError
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> ProxyClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> ProxyClientError
ProxyProtocolError ErrorType
e -- this will not happen, this error is returned via Left
      BrokerMsg
_ -> Either ProxyClientError BrokerMsg
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProxyClientError BrokerMsg
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> (ProxyClientError -> Either ProxyClientError BrokerMsg)
-> ProxyClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProxyClientError -> Either ProxyClientError BrokerMsg
forall a b. a -> Either a b
Left (ProxyClientError
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> ProxyClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a b. (a -> b) -> a -> b
$ String -> ProxyClientError
ProxyUnexpectedResponse (String -> ProxyClientError) -> String -> ProxyClientError
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
32 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> String
forall a. Show a => a -> String
show BrokerMsg
r
    Left SMPClientError
e -> case SMPClientError
e of
      PCEProtocolError ErrorType
e' -> Either ProxyClientError BrokerMsg
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProxyClientError BrokerMsg
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> (ProxyClientError -> Either ProxyClientError BrokerMsg)
-> ProxyClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProxyClientError -> Either ProxyClientError BrokerMsg
forall a b. a -> Either a b
Left (ProxyClientError
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> ProxyClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> ProxyClientError
ProxyProtocolError ErrorType
e'
      PCEUnexpectedResponse ByteString
e' -> Either ProxyClientError BrokerMsg
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProxyClientError BrokerMsg
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> (ProxyClientError -> Either ProxyClientError BrokerMsg)
-> ProxyClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProxyClientError -> Either ProxyClientError BrokerMsg
forall a b. a -> Either a b
Left (ProxyClientError
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> ProxyClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a b. (a -> b) -> a -> b
$ String -> ProxyClientError
ProxyUnexpectedResponse (String -> ProxyClientError) -> String -> ProxyClientError
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B.unpack ByteString
e'
      PCEResponseError ErrorType
e' -> Either ProxyClientError BrokerMsg
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProxyClientError BrokerMsg
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> (ProxyClientError -> Either ProxyClientError BrokerMsg)
-> ProxyClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProxyClientError -> Either ProxyClientError BrokerMsg
forall a b. a -> Either a b
Left (ProxyClientError
 -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg))
-> ProxyClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> ProxyClientError
ProxyResponseError ErrorType
e'
      SMPClientError
_ -> SMPClientError
-> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SMPClientError
e

-- this method is used in the proxy
-- sends RFWD :: EncFwdTransmission -> Command Sender
-- receives RRES :: EncFwdResponse -> BrokerMsg
-- proxy should send PRES to the client with EncResponse
-- Always uses background timeout mode
forwardSMPTransmission :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO EncResponse
forwardSMPTransmission :: SMPClient
-> CorrId
-> Version SMPVersion
-> PublicKeyX25519
-> EncTransmission
-> ExceptT SMPClientError IO EncResponse
forwardSMPTransmission c :: SMPClient
c@ProtocolClient {THandleParams SMPVersion 'TClient
$sel:thParams:ProtocolClient :: forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams :: THandleParams SMPVersion 'TClient
thParams, $sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {$sel:clientCorrId:PClient :: forall v err msg. PClient v err msg -> TVar ChaChaDRG
clientCorrId = TVar ChaChaDRG
g}} CorrId
fwdCorrId Version SMPVersion
fwdVersion PublicKeyX25519
fwdKey EncTransmission
fwdTransmission = do
  -- prepare params
  DhSecret 'X25519
sessSecret <- case THandleParams SMPVersion 'TClient -> Maybe (THandleAuth 'TClient)
forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth THandleParams SMPVersion 'TClient
thParams of
    Maybe (THandleAuth 'TClient)
Nothing -> SMPClientError -> ExceptT SMPClientError IO (DhSecret 'X25519)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO (DhSecret 'X25519))
-> SMPClientError -> ExceptT SMPClientError IO (DhSecret 'X25519)
forall a b. (a -> b) -> a -> b
$ TransportError -> SMPClientError
forall err. TransportError -> ProtocolClientError err
PCETransportError TransportError
TENoServerAuth
    Just THAuthClient {Maybe (DhSecret 'X25519)
sessSecret :: Maybe (DhSecret 'X25519)
$sel:sessSecret:THAuthClient :: THandleAuth 'TClient -> Maybe (DhSecret 'X25519)
sessSecret} -> ExceptT SMPClientError IO (DhSecret 'X25519)
-> (DhSecret 'X25519
    -> ExceptT SMPClientError IO (DhSecret 'X25519))
-> Maybe (DhSecret 'X25519)
-> ExceptT SMPClientError IO (DhSecret 'X25519)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SMPClientError -> ExceptT SMPClientError IO (DhSecret 'X25519)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO (DhSecret 'X25519))
-> SMPClientError -> ExceptT SMPClientError IO (DhSecret 'X25519)
forall a b. (a -> b) -> a -> b
$ TransportError -> SMPClientError
forall err. TransportError -> ProtocolClientError err
PCETransportError TransportError
TENoServerAuth) DhSecret 'X25519 -> ExceptT SMPClientError IO (DhSecret 'X25519)
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (DhSecret 'X25519)
sessSecret
  CbNonce
nonce <- IO CbNonce -> ExceptT SMPClientError IO CbNonce
forall a. IO a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CbNonce -> ExceptT SMPClientError IO CbNonce)
-> (STM CbNonce -> IO CbNonce)
-> STM CbNonce
-> ExceptT SMPClientError IO CbNonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM CbNonce -> IO CbNonce
forall a. STM a -> IO a
atomically (STM CbNonce -> ExceptT SMPClientError IO CbNonce)
-> STM CbNonce -> ExceptT SMPClientError IO CbNonce
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM CbNonce
C.randomCbNonce TVar ChaChaDRG
g
  -- wrap
  let fwdT :: FwdTransmission
fwdT = FwdTransmission {CorrId
fwdCorrId :: CorrId
$sel:fwdCorrId:FwdTransmission :: CorrId
fwdCorrId, Version SMPVersion
fwdVersion :: Version SMPVersion
$sel:fwdVersion:FwdTransmission :: Version SMPVersion
fwdVersion, PublicKeyX25519
fwdKey :: PublicKeyX25519
$sel:fwdKey:FwdTransmission :: PublicKeyX25519
fwdKey, EncTransmission
fwdTransmission :: EncTransmission
$sel:fwdTransmission:FwdTransmission :: EncTransmission
fwdTransmission}
      eft :: EncFwdTransmission
eft = ByteString -> EncFwdTransmission
EncFwdTransmission (ByteString -> EncFwdTransmission)
-> ByteString -> EncFwdTransmission
forall a b. (a -> b) -> a -> b
$ DhSecret 'X25519 -> CbNonce -> ByteString -> ByteString
C.cbEncryptNoPad DhSecret 'X25519
sessSecret CbNonce
nonce (FwdTransmission -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode FwdTransmission
fwdT)
  -- send
  SMPClient
-> NetworkRequestMode
-> Maybe CbNonce
-> Maybe Int
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand BrokerMsg
-> ExceptT SMPClientError IO BrokerMsg
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe CbNonce
-> Maybe Int
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand msg
-> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand_ SMPClient
c NetworkRequestMode
NRMBackground (CbNonce -> Maybe CbNonce
forall a. a -> Maybe a
Just CbNonce
nonce) Maybe Int
forall a. Maybe a
Nothing Maybe SndPrivateAuthKey
forall a. Maybe a
Nothing RecipientId
NoEntity (SParty 'ProxyService -> Command 'ProxyService -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'ProxyService
SProxyService (EncFwdTransmission -> Command 'ProxyService
RFWD EncFwdTransmission
eft)) ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg -> ExceptT SMPClientError IO EncResponse)
-> ExceptT SMPClientError IO EncResponse
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    RRES (EncFwdResponse ByteString
efr) -> do
      -- unwrap
      ByteString
r' <- (CryptoError -> SMPClientError)
-> Either CryptoError ByteString
-> ExceptT SMPClientError IO ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith CryptoError -> SMPClientError
forall err. CryptoError -> ProtocolClientError err
PCECryptoError (Either CryptoError ByteString
 -> ExceptT SMPClientError IO ByteString)
-> Either CryptoError ByteString
-> ExceptT SMPClientError IO ByteString
forall a b. (a -> b) -> a -> b
$ DhSecret 'X25519
-> CbNonce -> ByteString -> Either CryptoError ByteString
C.cbDecryptNoPad DhSecret 'X25519
sessSecret (CbNonce -> CbNonce
C.reverseNonce CbNonce
nonce) ByteString
efr
      FwdResponse {$sel:fwdCorrId:FwdResponse :: FwdResponse -> CorrId
fwdCorrId = CorrId
_, EncResponse
fwdResponse :: EncResponse
$sel:fwdResponse:FwdResponse :: FwdResponse -> EncResponse
fwdResponse} <- (String -> SMPClientError)
-> Either String FwdResponse
-> ExceptT SMPClientError IO FwdResponse
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (SMPClientError -> String -> SMPClientError
forall a b. a -> b -> a
const (SMPClientError -> String -> SMPClientError)
-> SMPClientError -> String -> SMPClientError
forall a b. (a -> b) -> a -> b
$ ErrorType -> SMPClientError
forall err. err -> ProtocolClientError err
PCEResponseError ErrorType
BLOCK) (Either String FwdResponse
 -> ExceptT SMPClientError IO FwdResponse)
-> Either String FwdResponse
-> ExceptT SMPClientError IO FwdResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String FwdResponse
forall a. Encoding a => ByteString -> Either String a
smpDecode ByteString
r'
      EncResponse -> ExceptT SMPClientError IO EncResponse
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EncResponse
fwdResponse
    BrokerMsg
r -> SMPClientError -> ExceptT SMPClientError IO EncResponse
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO EncResponse)
-> SMPClientError -> ExceptT SMPClientError IO EncResponse
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r

-- get queue information - always sent interactively
getSMPQueueInfo :: SMPClient -> NetworkRequestMode -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo
getSMPQueueInfo :: SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO QueueInfo
getSMPQueueInfo SMPClient
c NetworkRequestMode
nm SndPrivateAuthKey
pKey RecipientId
qId =
  SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command 'Recipient
-> ExceptT SMPClientError IO BrokerMsg
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient
c NetworkRequestMode
nm (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
pKey) RecipientId
qId Command 'Recipient
QUE ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg -> ExceptT SMPClientError IO QueueInfo)
-> ExceptT SMPClientError IO QueueInfo
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    INFO QueueInfo
info -> QueueInfo -> ExceptT SMPClientError IO QueueInfo
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueueInfo
info
    BrokerMsg
r -> SMPClientError -> ExceptT SMPClientError IO QueueInfo
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO QueueInfo)
-> SMPClientError -> ExceptT SMPClientError IO QueueInfo
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r

okSMPCommand :: PartyI p => Command p -> SMPClient -> NetworkRequestMode -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
okSMPCommand :: forall (p :: Party).
PartyI p =>
Command p
-> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
okSMPCommand Command p
cmd SMPClient
c NetworkRequestMode
nm SndPrivateAuthKey
pKey RecipientId
qId =
  SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient
c NetworkRequestMode
nm (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
pKey) RecipientId
qId Command p
cmd ExceptT SMPClientError IO BrokerMsg
-> (BrokerMsg -> ExceptT SMPClientError IO ())
-> ExceptT SMPClientError IO ()
forall a b.
ExceptT SMPClientError IO a
-> (a -> ExceptT SMPClientError IO b)
-> ExceptT SMPClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    BrokerMsg
OK -> () -> ExceptT SMPClientError IO ()
forall a. a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    BrokerMsg
r -> SMPClientError -> ExceptT SMPClientError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO ())
-> SMPClientError -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> SMPClientError
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r

okSMPCommands :: PartyI p => Command p -> SMPClient -> NetworkRequestMode -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
okSMPCommands :: forall (p :: Party).
PartyI p =>
Command p
-> SMPClient
-> NetworkRequestMode
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError ()))
okSMPCommands Command p
cmd SMPClient
c NetworkRequestMode
nm NonEmpty (RecipientId, SndPrivateAuthKey)
qs = (Response ErrorType BrokerMsg -> Either SMPClientError ())
-> NonEmpty (Response ErrorType BrokerMsg)
-> NonEmpty (Either SMPClientError ())
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map Response ErrorType BrokerMsg -> Either SMPClientError ()
forall {err}.
Response err BrokerMsg -> Either (ProtocolClientError err) ()
process (NonEmpty (Response ErrorType BrokerMsg)
 -> NonEmpty (Either SMPClientError ()))
-> IO (NonEmpty (Response ErrorType BrokerMsg))
-> IO (NonEmpty (Either SMPClientError ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPClient
-> NetworkRequestMode
-> NonEmpty (ClientCommand BrokerMsg)
-> IO (NonEmpty (Response ErrorType BrokerMsg))
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> NonEmpty (ClientCommand msg)
-> IO (NonEmpty (Response err msg))
sendProtocolCommands SMPClient
c NetworkRequestMode
nm NonEmpty (ClientCommand BrokerMsg)
NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
cs
  where
    aCmd :: Cmd
aCmd = SParty p -> Command p -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty p
forall (p :: Party). PartyI p => SParty p
sParty Command p
cmd
    cs :: NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
cs = ((RecipientId, SndPrivateAuthKey)
 -> (RecipientId, Maybe SndPrivateAuthKey, Cmd))
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> NonEmpty (RecipientId, Maybe SndPrivateAuthKey, Cmd)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\(RecipientId
qId, SndPrivateAuthKey
pKey) -> (RecipientId
qId, SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
pKey, Cmd
aCmd)) NonEmpty (RecipientId, SndPrivateAuthKey)
qs
    process :: Response err BrokerMsg -> Either (ProtocolClientError err) ()
process (Response RecipientId
_ Either (ProtocolClientError err) BrokerMsg
r) = case Either (ProtocolClientError err) BrokerMsg
r of
      Right BrokerMsg
OK -> () -> Either (ProtocolClientError err) ()
forall a b. b -> Either a b
Right ()
      Right BrokerMsg
r' -> ProtocolClientError err -> Either (ProtocolClientError err) ()
forall a b. a -> Either a b
Left (ProtocolClientError err -> Either (ProtocolClientError err) ())
-> ProtocolClientError err -> Either (ProtocolClientError err) ()
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> ProtocolClientError err
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r'
      Left ProtocolClientError err
e -> ProtocolClientError err -> Either (ProtocolClientError err) ()
forall a b. a -> Either a b
Left ProtocolClientError err
e

-- | Send SMP command
sendSMPCommand :: PartyI p => SMPClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> EntityId -> Command p -> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand :: forall (p :: Party).
PartyI p =>
SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> Command p
-> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient
c NetworkRequestMode
nm Maybe SndPrivateAuthKey
pKey RecipientId
entId Command p
cmd = SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand BrokerMsg
-> ExceptT SMPClientError IO BrokerMsg
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand msg
-> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand SMPClient
c NetworkRequestMode
nm Maybe SndPrivateAuthKey
pKey RecipientId
entId (SParty p -> Command p -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty p
forall (p :: Party). PartyI p => SParty p
sParty Command p
cmd)
{-# INLINE sendSMPCommand #-}

type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg)

-- | Send multiple commands with batching and collect responses
sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
sendProtocolCommands :: forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> NonEmpty (ClientCommand msg)
-> IO (NonEmpty (Response err msg))
sendProtocolCommands c :: ProtocolClient v err msg
c@ProtocolClient {THandleParams v 'TClient
$sel:thParams:ProtocolClient :: forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams :: THandleParams v 'TClient
thParams} NetworkRequestMode
nm NonEmpty (ClientCommand msg)
cs = do
  [TransportBatch (Request err msg)]
bs <- THandleParams v 'TClient
-> NonEmpty
     (Either TransportError SentRawTransmission, Request err msg)
-> [TransportBatch (Request err msg)]
forall v (p :: TransportPeer) r.
THandleParams v p
-> NonEmpty (Either TransportError SentRawTransmission, r)
-> [TransportBatch r]
batchTransmissions' THandleParams v 'TClient
thParams (NonEmpty
   (Either TransportError SentRawTransmission, Request err msg)
 -> [TransportBatch (Request err msg)])
-> IO
     (NonEmpty
        (Either TransportError SentRawTransmission, Request err msg))
-> IO [TransportBatch (Request err msg)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ClientCommand msg
 -> IO (Either TransportError SentRawTransmission, Request err msg))
-> NonEmpty (ClientCommand msg)
-> IO
     (NonEmpty
        (Either TransportError SentRawTransmission, Request err msg))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (ProtocolClient v err msg
-> ClientCommand msg
-> IO (Either TransportError SentRawTransmission, Request err msg)
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> ClientCommand msg -> IO (PCTransmission err msg)
mkTransmission ProtocolClient v err msg
c) NonEmpty (ClientCommand msg)
cs
  [Response err msg] -> IO (NonEmpty (Response err msg))
validate ([Response err msg] -> IO (NonEmpty (Response err msg)))
-> ([[Response err msg]] -> [Response err msg])
-> [[Response err msg]]
-> IO (NonEmpty (Response err msg))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Response err msg]] -> [Response err msg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Response err msg]] -> IO (NonEmpty (Response err msg)))
-> IO [[Response err msg]] -> IO (NonEmpty (Response err msg))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (TransportBatch (Request err msg) -> IO [Response err msg])
-> [TransportBatch (Request err msg)] -> IO [[Response err msg]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ProtocolClient v err msg
-> NetworkRequestMode
-> TransportBatch (Request err msg)
-> IO [Response err msg]
forall v err msg.
ProtocolClient v err msg
-> NetworkRequestMode
-> TransportBatch (Request err msg)
-> IO [Response err msg]
sendBatch ProtocolClient v err msg
c NetworkRequestMode
nm) [TransportBatch (Request err msg)]
bs
  where
    validate :: [Response err msg] -> IO (NonEmpty (Response err msg))
    validate :: [Response err msg] -> IO (NonEmpty (Response err msg))
validate [Response err msg]
rs
      | Int
diff Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = NonEmpty (Response err msg) -> IO (NonEmpty (Response err msg))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (Response err msg) -> IO (NonEmpty (Response err msg)))
-> NonEmpty (Response err msg) -> IO (NonEmpty (Response err msg))
forall a b. (a -> b) -> a -> b
$ [Response err msg] -> NonEmpty (Response err msg)
forall a. (?callStack::CallStack) => [a] -> NonEmpty a
L.fromList [Response err msg]
rs
      | Int
diff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = do
          String -> IO ()
putStrLn String
"send error: fewer responses than expected"
          NonEmpty (Response err msg) -> IO (NonEmpty (Response err msg))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (Response err msg) -> IO (NonEmpty (Response err msg)))
-> NonEmpty (Response err msg) -> IO (NonEmpty (Response err msg))
forall a b. (a -> b) -> a -> b
$ [Response err msg] -> NonEmpty (Response err msg)
forall a. (?callStack::CallStack) => [a] -> NonEmpty a
L.fromList ([Response err msg] -> NonEmpty (Response err msg))
-> [Response err msg] -> NonEmpty (Response err msg)
forall a b. (a -> b) -> a -> b
$ [Response err msg]
rs [Response err msg] -> [Response err msg] -> [Response err msg]
forall a. Semigroup a => a -> a -> a
<> Int -> Response err msg -> [Response err msg]
forall a. Int -> a -> [a]
replicate Int
diff (RecipientId
-> Either (ProtocolClientError err) msg -> Response err msg
forall err msg.
RecipientId
-> Either (ProtocolClientError err) msg -> Response err msg
Response RecipientId
NoEntity (Either (ProtocolClientError err) msg -> Response err msg)
-> Either (ProtocolClientError err) msg -> Response err msg
forall a b. (a -> b) -> a -> b
$ ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. a -> Either a b
Left (ProtocolClientError err -> Either (ProtocolClientError err) msg)
-> ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. (a -> b) -> a -> b
$ TransportError -> ProtocolClientError err
forall err. TransportError -> ProtocolClientError err
PCETransportError TransportError
TEBadBlock)
      | Bool
otherwise = do
          String -> IO ()
putStrLn String
"send error: more responses than expected"
          NonEmpty (Response err msg) -> IO (NonEmpty (Response err msg))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (Response err msg) -> IO (NonEmpty (Response err msg)))
-> NonEmpty (Response err msg) -> IO (NonEmpty (Response err msg))
forall a b. (a -> b) -> a -> b
$ [Response err msg] -> NonEmpty (Response err msg)
forall a. (?callStack::CallStack) => [a] -> NonEmpty a
L.fromList ([Response err msg] -> NonEmpty (Response err msg))
-> [Response err msg] -> NonEmpty (Response err msg)
forall a b. (a -> b) -> a -> b
$ Int -> [Response err msg] -> [Response err msg]
forall a. Int -> [a] -> [a]
take (NonEmpty (ClientCommand msg) -> Int
forall a. NonEmpty a -> Int
L.length NonEmpty (ClientCommand msg)
cs) [Response err msg]
rs
      where
        diff :: Int
diff = NonEmpty (ClientCommand msg) -> Int
forall a. NonEmpty a -> Int
L.length NonEmpty (ClientCommand msg)
cs Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Response err msg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Response err msg]
rs

streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
streamProtocolCommands :: forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> NonEmpty (ClientCommand msg)
-> ([Response err msg] -> IO ())
-> IO ()
streamProtocolCommands c :: ProtocolClient v err msg
c@ProtocolClient {THandleParams v 'TClient
$sel:thParams:ProtocolClient :: forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams :: THandleParams v 'TClient
thParams} NetworkRequestMode
nm NonEmpty (ClientCommand msg)
cs [Response err msg] -> IO ()
cb = do
  [TransportBatch (Request err msg)]
bs <- THandleParams v 'TClient
-> NonEmpty
     (Either TransportError SentRawTransmission, Request err msg)
-> [TransportBatch (Request err msg)]
forall v (p :: TransportPeer) r.
THandleParams v p
-> NonEmpty (Either TransportError SentRawTransmission, r)
-> [TransportBatch r]
batchTransmissions' THandleParams v 'TClient
thParams (NonEmpty
   (Either TransportError SentRawTransmission, Request err msg)
 -> [TransportBatch (Request err msg)])
-> IO
     (NonEmpty
        (Either TransportError SentRawTransmission, Request err msg))
-> IO [TransportBatch (Request err msg)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ClientCommand msg
 -> IO (Either TransportError SentRawTransmission, Request err msg))
-> NonEmpty (ClientCommand msg)
-> IO
     (NonEmpty
        (Either TransportError SentRawTransmission, Request err msg))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (ProtocolClient v err msg
-> ClientCommand msg
-> IO (Either TransportError SentRawTransmission, Request err msg)
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> ClientCommand msg -> IO (PCTransmission err msg)
mkTransmission ProtocolClient v err msg
c) NonEmpty (ClientCommand msg)
cs
  (TransportBatch (Request err msg) -> IO ())
-> [TransportBatch (Request err msg)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Response err msg] -> IO ()
cb ([Response err msg] -> IO ())
-> (TransportBatch (Request err msg) -> IO [Response err msg])
-> TransportBatch (Request err msg)
-> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ProtocolClient v err msg
-> NetworkRequestMode
-> TransportBatch (Request err msg)
-> IO [Response err msg]
forall v err msg.
ProtocolClient v err msg
-> NetworkRequestMode
-> TransportBatch (Request err msg)
-> IO [Response err msg]
sendBatch ProtocolClient v err msg
c NetworkRequestMode
nm) [TransportBatch (Request err msg)]
bs

sendBatch :: ProtocolClient v err msg -> NetworkRequestMode -> TransportBatch (Request err msg) -> IO [Response err msg]
sendBatch :: forall v err msg.
ProtocolClient v err msg
-> NetworkRequestMode
-> TransportBatch (Request err msg)
-> IO [Response err msg]
sendBatch c :: ProtocolClient v err msg
c@ProtocolClient {$sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {TBQueue (Maybe (Request err msg), ByteString)
$sel:sndQ:PClient :: forall v err msg.
PClient v err msg -> TBQueue (Maybe (Request err msg), ByteString)
sndQ :: TBQueue (Maybe (Request err msg), ByteString)
sndQ}} NetworkRequestMode
nm TransportBatch (Request err msg)
b = do
  case TransportBatch (Request err msg)
b of
    TBError TransportError
e Request {RecipientId
$sel:entityId:Request :: forall err msg. Request err msg -> RecipientId
entityId :: RecipientId
entityId} -> do
      String -> IO ()
putStrLn String
"send error: large message"
      [Response err msg] -> IO [Response err msg]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [RecipientId
-> Either (ProtocolClientError err) msg -> Response err msg
forall err msg.
RecipientId
-> Either (ProtocolClientError err) msg -> Response err msg
Response RecipientId
entityId (Either (ProtocolClientError err) msg -> Response err msg)
-> Either (ProtocolClientError err) msg -> Response err msg
forall a b. (a -> b) -> a -> b
$ ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. a -> Either a b
Left (ProtocolClientError err -> Either (ProtocolClientError err) msg)
-> ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. (a -> b) -> a -> b
$ TransportError -> ProtocolClientError err
forall err. TransportError -> ProtocolClientError err
PCETransportError TransportError
e]
    TBTransmissions ByteString
s Int
n [Request err msg]
rs
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
          TBQueue (Maybe (Request err msg), ByteString)
-> (Maybe (Request err msg), ByteString) -> IO ()
forall a. TBQueue a -> a -> IO ()
nonBlockingWriteTBQueue TBQueue (Maybe (Request err msg), ByteString)
sndQ (Maybe (Request err msg)
forall a. Maybe a
Nothing, ByteString
s) -- do not expire batched responses
          (Request err msg -> IO (Response err msg))
-> [Request err msg] -> IO [Response err msg]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe Int
-> Request err msg
-> IO (Response err msg)
forall v err msg.
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe Int
-> Request err msg
-> IO (Response err msg)
getResponse ProtocolClient v err msg
c NetworkRequestMode
nm Maybe Int
forall a. Maybe a
Nothing) [Request err msg]
rs
      | Bool
otherwise -> [Response err msg] -> IO [Response err msg]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    TBTransmission ByteString
s Request err msg
r -> do
      TBQueue (Maybe (Request err msg), ByteString)
-> (Maybe (Request err msg), ByteString) -> IO ()
forall a. TBQueue a -> a -> IO ()
nonBlockingWriteTBQueue TBQueue (Maybe (Request err msg), ByteString)
sndQ (Maybe (Request err msg)
forall a. Maybe a
Nothing, ByteString
s)
      (Response err msg -> [Response err msg] -> [Response err msg]
forall a. a -> [a] -> [a]
: []) (Response err msg -> [Response err msg])
-> IO (Response err msg) -> IO [Response err msg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe Int
-> Request err msg
-> IO (Response err msg)
forall v err msg.
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe Int
-> Request err msg
-> IO (Response err msg)
getResponse ProtocolClient v err msg
c NetworkRequestMode
nm Maybe Int
forall a. Maybe a
Nothing Request err msg
r

-- | Send Protocol command
sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand :: forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand msg
-> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand ProtocolClient v err msg
c NetworkRequestMode
nm = ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe CbNonce
-> Maybe Int
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand msg
-> ExceptT (ProtocolClientError err) IO msg
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe CbNonce
-> Maybe Int
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand msg
-> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand_ ProtocolClient v err msg
c NetworkRequestMode
nm Maybe CbNonce
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing

-- Currently there is coupling - batch commands do not expire, and individually sent commands do.
-- This is to reflect the fact that we send subscriptions only as batches, and also because we do not track a separate timeout for the whole batch, so it is not obvious when should we expire it.
-- We could expire a batch of deletes, for example, either when the first response expires or when the last one does.
-- But a better solution is to process delayed delete responses.
--
-- Please note: if nonce is passed it is also used as a correlation ID
sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand_ :: forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe CbNonce
-> Maybe Int
-> Maybe SndPrivateAuthKey
-> RecipientId
-> ProtoCommand msg
-> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand_ c :: ProtocolClient v err msg
c@ProtocolClient {$sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {TBQueue (Maybe (Request err msg), ByteString)
$sel:sndQ:PClient :: forall v err msg.
PClient v err msg -> TBQueue (Maybe (Request err msg), ByteString)
sndQ :: TBQueue (Maybe (Request err msg), ByteString)
sndQ}, $sel:thParams:ProtocolClient :: forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams = THandleParams {Bool
$sel:batch:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Bool
batch :: Bool
batch, Int
$sel:blockSize:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Int
blockSize :: Int
blockSize, Bool
$sel:serviceAuth:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Bool
serviceAuth :: Bool
serviceAuth}} NetworkRequestMode
nm Maybe CbNonce
nonce_ Maybe Int
tOut Maybe SndPrivateAuthKey
pKey RecipientId
entId ProtoCommand msg
cmd =
  IO (Either (ProtocolClientError err) msg)
-> ExceptT (ProtocolClientError err) IO msg
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either (ProtocolClientError err) msg)
 -> ExceptT (ProtocolClientError err) IO msg)
-> IO (Either (ProtocolClientError err) msg)
-> ExceptT (ProtocolClientError err) IO msg
forall a b. (a -> b) -> a -> b
$ (Either TransportError SentRawTransmission
 -> Request err msg -> IO (Either (ProtocolClientError err) msg))
-> (Either TransportError SentRawTransmission, Request err msg)
-> IO (Either (ProtocolClientError err) msg)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Either TransportError SentRawTransmission
-> Request err msg -> IO (Either (ProtocolClientError err) msg)
sendRecv ((Either TransportError SentRawTransmission, Request err msg)
 -> IO (Either (ProtocolClientError err) msg))
-> IO (Either TransportError SentRawTransmission, Request err msg)
-> IO (Either (ProtocolClientError err) msg)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ProtocolClient v err msg
-> Maybe CbNonce
-> ClientCommand msg
-> IO (Either TransportError SentRawTransmission, Request err msg)
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> Maybe CbNonce
-> ClientCommand msg
-> IO (PCTransmission err msg)
mkTransmission_ ProtocolClient v err msg
c Maybe CbNonce
nonce_ (RecipientId
entId, Maybe SndPrivateAuthKey
pKey, ProtoCommand msg
cmd)
  where
    -- two separate "atomically" needed to avoid blocking
    sendRecv :: Either TransportError SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg)
    sendRecv :: Either TransportError SentRawTransmission
-> Request err msg -> IO (Either (ProtocolClientError err) msg)
sendRecv Either TransportError SentRawTransmission
t_ Request err msg
r = case Either TransportError SentRawTransmission
t_ of
      Left TransportError
e -> Either (ProtocolClientError err) msg
-> IO (Either (ProtocolClientError err) msg)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ProtocolClientError err) msg
 -> IO (Either (ProtocolClientError err) msg))
-> (ProtocolClientError err
    -> Either (ProtocolClientError err) msg)
-> ProtocolClientError err
-> IO (Either (ProtocolClientError err) msg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. a -> Either a b
Left (ProtocolClientError err
 -> IO (Either (ProtocolClientError err) msg))
-> ProtocolClientError err
-> IO (Either (ProtocolClientError err) msg)
forall a b. (a -> b) -> a -> b
$ TransportError -> ProtocolClientError err
forall err. TransportError -> ProtocolClientError err
PCETransportError TransportError
e
      Right SentRawTransmission
t
        | ByteString -> Int
B.length ByteString
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
blockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 -> Either (ProtocolClientError err) msg
-> IO (Either (ProtocolClientError err) msg)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ProtocolClientError err) msg
 -> IO (Either (ProtocolClientError err) msg))
-> (ProtocolClientError err
    -> Either (ProtocolClientError err) msg)
-> ProtocolClientError err
-> IO (Either (ProtocolClientError err) msg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. a -> Either a b
Left (ProtocolClientError err
 -> IO (Either (ProtocolClientError err) msg))
-> ProtocolClientError err
-> IO (Either (ProtocolClientError err) msg)
forall a b. (a -> b) -> a -> b
$ TransportError -> ProtocolClientError err
forall err. TransportError -> ProtocolClientError err
PCETransportError TransportError
TELargeMsg
        | Bool
otherwise -> do
            TBQueue (Maybe (Request err msg), ByteString)
-> (Maybe (Request err msg), ByteString) -> IO ()
forall a. TBQueue a -> a -> IO ()
nonBlockingWriteTBQueue TBQueue (Maybe (Request err msg), ByteString)
sndQ (Request err msg -> Maybe (Request err msg)
forall a. a -> Maybe a
Just Request err msg
r, ByteString
s)
            Response err msg -> Either (ProtocolClientError err) msg
forall err msg.
Response err msg -> Either (ProtocolClientError err) msg
response (Response err msg -> Either (ProtocolClientError err) msg)
-> IO (Response err msg)
-> IO (Either (ProtocolClientError err) msg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe Int
-> Request err msg
-> IO (Response err msg)
forall v err msg.
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe Int
-> Request err msg
-> IO (Response err msg)
getResponse ProtocolClient v err msg
c NetworkRequestMode
nm Maybe Int
tOut Request err msg
r
        where
          s :: ByteString
s
            | Bool
batch = Bool -> SentRawTransmission -> ByteString
tEncodeBatch1 Bool
serviceAuth SentRawTransmission
t
            | Bool
otherwise = Bool -> SentRawTransmission -> ByteString
tEncode Bool
serviceAuth SentRawTransmission
t

nonBlockingWriteTBQueue :: TBQueue a -> a -> IO ()
nonBlockingWriteTBQueue :: forall a. TBQueue a -> a -> IO ()
nonBlockingWriteTBQueue TBQueue a
q a
x = do
  Bool
sent <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TBQueue a -> a -> STM Bool
forall a. TBQueue a -> a -> STM Bool
tryWriteTBQueue TBQueue a
q a
x
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sent (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue a -> a -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue a
q a
x

getResponse :: ProtocolClient v err msg -> NetworkRequestMode -> Maybe Int -> Request err msg -> IO (Response err msg)
getResponse :: forall v err msg.
ProtocolClient v err msg
-> NetworkRequestMode
-> Maybe Int
-> Request err msg
-> IO (Response err msg)
getResponse ProtocolClient {$sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {NetworkTimeout
$sel:tcpTimeout:PClient :: forall v err msg. PClient v err msg -> NetworkTimeout
tcpTimeout :: NetworkTimeout
tcpTimeout, TVar Int
$sel:timeoutErrorCount:PClient :: forall v err msg. PClient v err msg -> TVar Int
timeoutErrorCount :: TVar Int
timeoutErrorCount}} NetworkRequestMode
nm Maybe Int
tOut Request {RecipientId
$sel:entityId:Request :: forall err msg. Request err msg -> RecipientId
entityId :: RecipientId
entityId, TVar Bool
$sel:pending:Request :: forall err msg. Request err msg -> TVar Bool
pending :: TVar Bool
pending, TMVar (Either (ProtocolClientError err) msg)
$sel:responseVar:Request :: forall err msg.
Request err msg -> TMVar (Either (ProtocolClientError err) msg)
responseVar :: TMVar (Either (ProtocolClientError err) msg)
responseVar} = do
  Maybe (Either (ProtocolClientError err) msg)
r <- Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout
tcpTimeout NetworkRequestMode
nm) Maybe Int
tOut Int
-> IO (Either (ProtocolClientError err) msg)
-> IO (Maybe (Either (ProtocolClientError err) msg))
forall a. Int -> IO a -> IO (Maybe a)
`timeout` STM (Either (ProtocolClientError err) msg)
-> IO (Either (ProtocolClientError err) msg)
forall a. STM a -> IO a
atomically (TMVar (Either (ProtocolClientError err) msg)
-> STM (Either (ProtocolClientError err) msg)
forall a. TMVar a -> STM a
takeTMVar TMVar (Either (ProtocolClientError err) msg)
responseVar)
  Either (ProtocolClientError err) msg
response <- STM (Either (ProtocolClientError err) msg)
-> IO (Either (ProtocolClientError err) msg)
forall a. STM a -> IO a
atomically (STM (Either (ProtocolClientError err) msg)
 -> IO (Either (ProtocolClientError err) msg))
-> STM (Either (ProtocolClientError err) msg)
-> IO (Either (ProtocolClientError err) msg)
forall a b. (a -> b) -> a -> b
$ do
    TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
pending Bool
False
    -- Try to read response again in case it arrived after timeout expired
    -- but before `pending` was set to False above.
    -- See `processMsg`.
    ((Maybe (Either (ProtocolClientError err) msg)
r Maybe (Either (ProtocolClientError err) msg)
-> Maybe (Either (ProtocolClientError err) msg)
-> Maybe (Either (ProtocolClientError err) msg)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>) (Maybe (Either (ProtocolClientError err) msg)
 -> Maybe (Either (ProtocolClientError err) msg))
-> STM (Maybe (Either (ProtocolClientError err) msg))
-> STM (Maybe (Either (ProtocolClientError err) msg))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar (Either (ProtocolClientError err) msg)
-> STM (Maybe (Either (ProtocolClientError err) msg))
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar (Either (ProtocolClientError err) msg)
responseVar) STM (Maybe (Either (ProtocolClientError err) msg))
-> (Maybe (Either (ProtocolClientError err) msg)
    -> STM (Either (ProtocolClientError err) msg))
-> STM (Either (ProtocolClientError err) msg)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Either (ProtocolClientError err) msg
r' -> TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
timeoutErrorCount Int
0 STM ()
-> Either (ProtocolClientError err) msg
-> STM (Either (ProtocolClientError err) msg)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Either (ProtocolClientError err) msg
r'
      Maybe (Either (ProtocolClientError err) msg)
Nothing -> TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
timeoutErrorCount (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) STM ()
-> Either (ProtocolClientError err) msg
-> STM (Either (ProtocolClientError err) msg)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ProtocolClientError err -> Either (ProtocolClientError err) msg
forall a b. a -> Either a b
Left ProtocolClientError err
forall err. ProtocolClientError err
PCEResponseTimeout
  Response err msg -> IO (Response err msg)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response {RecipientId
$sel:entityId:Response :: RecipientId
entityId :: RecipientId
entityId, Either (ProtocolClientError err) msg
$sel:response:Response :: Either (ProtocolClientError err) msg
response :: Either (ProtocolClientError err) msg
response}

mkTransmission :: Protocol v err msg => ProtocolClient v err msg ->  ClientCommand msg -> IO (PCTransmission err msg)
mkTransmission :: forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> ClientCommand msg -> IO (PCTransmission err msg)
mkTransmission ProtocolClient v err msg
c = ProtocolClient v err msg
-> Maybe CbNonce
-> (RecipientId, Maybe SndPrivateAuthKey, ProtoCommand msg)
-> IO (Either TransportError SentRawTransmission, Request err msg)
forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> Maybe CbNonce
-> ClientCommand msg
-> IO (PCTransmission err msg)
mkTransmission_ ProtocolClient v err msg
c Maybe CbNonce
forall a. Maybe a
Nothing

mkTransmission_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> ClientCommand msg -> IO (PCTransmission err msg)
mkTransmission_ :: forall v err msg.
Protocol v err msg =>
ProtocolClient v err msg
-> Maybe CbNonce
-> ClientCommand msg
-> IO (PCTransmission err msg)
mkTransmission_ ProtocolClient {THandleParams v 'TClient
$sel:thParams:ProtocolClient :: forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams :: THandleParams v 'TClient
thParams, $sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {TVar ChaChaDRG
$sel:clientCorrId:PClient :: forall v err msg. PClient v err msg -> TVar ChaChaDRG
clientCorrId :: TVar ChaChaDRG
clientCorrId, TMap CorrId (Request err msg)
$sel:sentCommands:PClient :: forall v err msg.
PClient v err msg -> TMap CorrId (Request err msg)
sentCommands :: TMap CorrId (Request err msg)
sentCommands}} Maybe CbNonce
nonce_ (RecipientId
entityId, Maybe SndPrivateAuthKey
pKey_, ProtoCommand msg
command) = do
  nonce :: CbNonce
nonce@(C.CbNonce ByteString
corrId) <- IO CbNonce
-> (CbNonce -> IO CbNonce) -> Maybe CbNonce -> IO CbNonce
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (STM CbNonce -> IO CbNonce
forall a. STM a -> IO a
atomically (STM CbNonce -> IO CbNonce) -> STM CbNonce -> IO CbNonce
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM CbNonce
C.randomCbNonce TVar ChaChaDRG
clientCorrId) CbNonce -> IO CbNonce
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CbNonce
nonce_
  let TransmissionForAuth {ByteString
$sel:tForAuth:TransmissionForAuth :: TransmissionForAuth -> ByteString
tForAuth :: ByteString
tForAuth, ByteString
$sel:tToSend:TransmissionForAuth :: TransmissionForAuth -> ByteString
tToSend :: ByteString
tToSend} = THandleParams v 'TClient
-> Transmission (ProtoCommand msg) -> TransmissionForAuth
forall v e c (p :: TransportPeer).
ProtocolEncoding v e c =>
THandleParams v p -> Transmission c -> TransmissionForAuth
encodeTransmissionForAuth THandleParams v 'TClient
thParams (ByteString -> CorrId
CorrId ByteString
corrId, RecipientId
entityId, ProtoCommand msg
command)
      auth :: Either TransportError (Maybe TAuthorizations)
auth = Maybe (THandleAuth 'TClient)
-> Bool
-> Maybe SndPrivateAuthKey
-> CbNonce
-> ByteString
-> Either TransportError (Maybe TAuthorizations)
authTransmission (THandleParams v 'TClient -> Maybe (THandleAuth 'TClient)
forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth THandleParams v 'TClient
thParams) (ProtoCommand msg -> Bool
forall v err msg. Protocol v err msg => ProtoCommand msg -> Bool
useServiceAuth ProtoCommand msg
command) Maybe SndPrivateAuthKey
pKey_ CbNonce
nonce ByteString
tForAuth
  Request err msg
r <- CorrId -> IO (Request err msg)
mkRequest (ByteString -> CorrId
CorrId ByteString
corrId)
  PCTransmission err msg -> IO (PCTransmission err msg)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((,ByteString
tToSend) (Maybe TAuthorizations -> SentRawTransmission)
-> Either TransportError (Maybe TAuthorizations)
-> Either TransportError SentRawTransmission
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either TransportError (Maybe TAuthorizations)
auth, Request err msg
r)
  where
    mkRequest :: CorrId -> IO (Request err msg)
    mkRequest :: CorrId -> IO (Request err msg)
mkRequest CorrId
corrId = do
      TVar Bool
pending <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
True
      TMVar (Either (ProtocolClientError err) msg)
responseVar <- IO (TMVar (Either (ProtocolClientError err) msg))
forall a. IO (TMVar a)
newEmptyTMVarIO
      let r :: Request err msg
r =
            Request
              { CorrId
$sel:corrId:Request :: CorrId
corrId :: CorrId
corrId,
                RecipientId
$sel:entityId:Request :: RecipientId
entityId :: RecipientId
entityId,
                ProtoCommand msg
$sel:command:Request :: ProtoCommand msg
command :: ProtoCommand msg
command,
                TVar Bool
$sel:pending:Request :: TVar Bool
pending :: TVar Bool
pending,
                TMVar (Either (ProtocolClientError err) msg)
$sel:responseVar:Request :: TMVar (Either (ProtocolClientError err) msg)
responseVar :: TMVar (Either (ProtocolClientError err) msg)
responseVar
              }
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ CorrId
-> Request err msg -> TMap CorrId (Request err msg) -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert CorrId
corrId Request err msg
r TMap CorrId (Request err msg)
sentCommands
      Request err msg -> IO (Request err msg)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request err msg
r

authTransmission :: Maybe (THandleAuth 'TClient) -> Bool -> Maybe C.APrivateAuthKey -> C.CbNonce -> ByteString -> Either TransportError (Maybe TAuthorizations)
authTransmission :: Maybe (THandleAuth 'TClient)
-> Bool
-> Maybe SndPrivateAuthKey
-> CbNonce
-> ByteString
-> Either TransportError (Maybe TAuthorizations)
authTransmission Maybe (THandleAuth 'TClient)
thAuth Bool
serviceAuth Maybe SndPrivateAuthKey
pKey_ CbNonce
nonce ByteString
t = (SndPrivateAuthKey -> Either TransportError TAuthorizations)
-> Maybe SndPrivateAuthKey
-> Either TransportError (Maybe TAuthorizations)
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 SndPrivateAuthKey -> Either TransportError TAuthorizations
authenticate Maybe SndPrivateAuthKey
pKey_
  where
    authenticate :: C.APrivateAuthKey -> Either TransportError TAuthorizations
    authenticate :: SndPrivateAuthKey -> Either TransportError TAuthorizations
authenticate (C.APrivateAuthKey SAlgorithm a
a PrivateKey a
pk) = (,Maybe (Signature 'Ed25519)
serviceSig) (TransmissionAuth -> TAuthorizations)
-> Either TransportError TransmissionAuth
-> Either TransportError TAuthorizations
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case SAlgorithm a
a of
      SAlgorithm a
C.SX25519 -> case Maybe (THandleAuth 'TClient)
thAuth of
        Just THAuthClient {$sel:peerServerPubKey:THAuthClient :: THandleAuth 'TClient -> PublicKeyX25519
peerServerPubKey = PublicKeyX25519
k} -> TransmissionAuth -> Either TransportError TransmissionAuth
forall a b. b -> Either a b
Right (TransmissionAuth -> Either TransportError TransmissionAuth)
-> TransmissionAuth -> Either TransportError TransmissionAuth
forall a b. (a -> b) -> a -> b
$ CbAuthenticator -> TransmissionAuth
TAAuthenticator (CbAuthenticator -> TransmissionAuth)
-> CbAuthenticator -> TransmissionAuth
forall a b. (a -> b) -> a -> b
$ PublicKeyX25519
-> PrivateKey 'X25519 -> CbNonce -> ByteString -> CbAuthenticator
C.cbAuthenticate PublicKeyX25519
k PrivateKey a
PrivateKey 'X25519
pk CbNonce
nonce ByteString
t'
        Maybe (THandleAuth 'TClient)
Nothing -> TransportError -> Either TransportError TransmissionAuth
forall a b. a -> Either a b
Left TransportError
TENoServerAuth
      SAlgorithm a
C.SEd25519 -> PrivateKey a -> Either TransportError TransmissionAuth
forall (a :: Algorithm).
(AlgorithmI a, SignatureAlgorithm a) =>
PrivateKey a -> Either TransportError TransmissionAuth
sign PrivateKey a
pk
      SAlgorithm a
C.SEd448 -> PrivateKey a -> Either TransportError TransmissionAuth
forall (a :: Algorithm).
(AlgorithmI a, SignatureAlgorithm a) =>
PrivateKey a -> Either TransportError TransmissionAuth
sign PrivateKey a
pk
    -- When command is signed by both entity key and service key,
    -- entity key must sign over both transmission and service certificate hash,
    -- to prevent any service substitution via MITM inside TLS.
    (ByteString
t', Maybe (Signature 'Ed25519)
serviceSig) = case THandleAuth 'TClient -> Maybe THClientService
clientService (THandleAuth 'TClient -> Maybe THClientService)
-> Maybe (THandleAuth 'TClient) -> Maybe THClientService
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (THandleAuth 'TClient)
thAuth of
      Just THClientService {$sel:serviceCertHash:THClientService :: forall k. THClientService' k -> Fingerprint
serviceCertHash = XV.Fingerprint ByteString
fp, PrivateKey 'Ed25519
$sel:serviceKey:THClientService :: forall k. THClientService' k -> k
serviceKey :: PrivateKey 'Ed25519
serviceKey} | Bool
serviceAuth ->
        (ByteString
fp ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
t, Signature 'Ed25519 -> Maybe (Signature 'Ed25519)
forall a. a -> Maybe a
Just (Signature 'Ed25519 -> Maybe (Signature 'Ed25519))
-> Signature 'Ed25519 -> Maybe (Signature 'Ed25519)
forall a b. (a -> b) -> a -> b
$ PrivateKey 'Ed25519 -> ByteString -> Signature 'Ed25519
forall (a :: Algorithm).
SignatureAlgorithm a =>
PrivateKey a -> ByteString -> Signature a
C.sign' PrivateKey 'Ed25519
serviceKey ByteString
t) -- service key only needs to sign transmission itself
      Maybe THClientService
_ -> (ByteString
t, Maybe (Signature 'Ed25519)
forall a. Maybe a
Nothing)
    sign :: forall a. (C.AlgorithmI a, C.SignatureAlgorithm a) => C.PrivateKey a -> Either TransportError TransmissionAuth
    sign :: forall (a :: Algorithm).
(AlgorithmI a, SignatureAlgorithm a) =>
PrivateKey a -> Either TransportError TransmissionAuth
sign PrivateKey a
pk = TransmissionAuth -> Either TransportError TransmissionAuth
forall a b. b -> Either a b
Right (TransmissionAuth -> Either TransportError TransmissionAuth)
-> TransmissionAuth -> Either TransportError TransmissionAuth
forall a b. (a -> b) -> a -> b
$ ASignature -> TransmissionAuth
TASignature (ASignature -> TransmissionAuth) -> ASignature -> TransmissionAuth
forall a b. (a -> b) -> a -> b
$ SAlgorithm a -> Signature a -> ASignature
forall (a :: Algorithm).
(AlgorithmI a, SignatureAlgorithm a) =>
SAlgorithm a -> Signature a -> ASignature
C.ASignature (forall (a :: Algorithm). AlgorithmI a => SAlgorithm a
C.sAlgorithm @a) (PrivateKey a -> ByteString -> Signature a
forall (a :: Algorithm).
SignatureAlgorithm a =>
PrivateKey a -> ByteString -> Signature a
C.sign' PrivateKey a
pk ByteString
t')

data TBQueueInfo = TBQueueInfo
  { TBQueueInfo -> Int
qLength :: Int,
    TBQueueInfo -> Bool
qFull :: Bool
  }
  deriving (Int -> TBQueueInfo -> ShowS
[TBQueueInfo] -> ShowS
TBQueueInfo -> String
(Int -> TBQueueInfo -> ShowS)
-> (TBQueueInfo -> String)
-> ([TBQueueInfo] -> ShowS)
-> Show TBQueueInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TBQueueInfo -> ShowS
showsPrec :: Int -> TBQueueInfo -> ShowS
$cshow :: TBQueueInfo -> String
show :: TBQueueInfo -> String
$cshowList :: [TBQueueInfo] -> ShowS
showList :: [TBQueueInfo] -> ShowS
Show)

getTBQueueInfo :: TBQueue a -> STM TBQueueInfo
getTBQueueInfo :: forall a. TBQueue a -> STM TBQueueInfo
getTBQueueInfo TBQueue a
q = do
  Int
qLength <- Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> STM Natural -> STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TBQueue a -> STM Natural
forall a. TBQueue a -> STM Natural
lengthTBQueue TBQueue a
q
  Bool
qFull <- TBQueue a -> STM Bool
forall a. TBQueue a -> STM Bool
isFullTBQueue TBQueue a
q
  TBQueueInfo -> STM TBQueueInfo
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TBQueueInfo {Int
$sel:qLength:TBQueueInfo :: Int
qLength :: Int
qLength, Bool
$sel:qFull:TBQueueInfo :: Bool
qFull :: Bool
qFull}

getProtocolClientQueuesInfo :: ProtocolClient v err msg -> IO (TBQueueInfo, TBQueueInfo)
getProtocolClientQueuesInfo :: forall v err msg.
ProtocolClient v err msg -> IO (TBQueueInfo, TBQueueInfo)
getProtocolClientQueuesInfo ProtocolClient {$sel:client_:ProtocolClient :: forall v err msg. ProtocolClient v err msg -> PClient v err msg
client_ = PClient {TBQueue (Maybe (Request err msg), ByteString)
$sel:sndQ:PClient :: forall v err msg.
PClient v err msg -> TBQueue (Maybe (Request err msg), ByteString)
sndQ :: TBQueue (Maybe (Request err msg), ByteString)
sndQ, TBQueue (NonEmpty (Transmission (Either err msg)))
$sel:rcvQ:PClient :: forall v err msg.
PClient v err msg
-> TBQueue (NonEmpty (Transmission (Either err msg)))
rcvQ :: TBQueue (NonEmpty (Transmission (Either err msg)))
rcvQ}} = do
  TBQueueInfo
sndQInfo <- STM TBQueueInfo -> IO TBQueueInfo
forall a. STM a -> IO a
atomically (STM TBQueueInfo -> IO TBQueueInfo)
-> STM TBQueueInfo -> IO TBQueueInfo
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe (Request err msg), ByteString) -> STM TBQueueInfo
forall a. TBQueue a -> STM TBQueueInfo
getTBQueueInfo TBQueue (Maybe (Request err msg), ByteString)
sndQ
  TBQueueInfo
rcvQInfo <- STM TBQueueInfo -> IO TBQueueInfo
forall a. STM a -> IO a
atomically (STM TBQueueInfo -> IO TBQueueInfo)
-> STM TBQueueInfo -> IO TBQueueInfo
forall a b. (a -> b) -> a -> b
$ TBQueue (NonEmpty (Transmission (Either err msg)))
-> STM TBQueueInfo
forall a. TBQueue a -> STM TBQueueInfo
getTBQueueInfo TBQueue (NonEmpty (Transmission (Either err msg)))
rcvQ
  (TBQueueInfo, TBQueueInfo) -> IO (TBQueueInfo, TBQueueInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TBQueueInfo
sndQInfo, TBQueueInfo
rcvQInfo)

$(J.deriveJSON (enumJSON $ dropPrefix "HM") ''HostMode)

$(J.deriveJSON (enumJSON $ dropPrefix "SM") ''SocksMode)

$(J.deriveJSON (enumJSON $ dropPrefix "TSM") ''TransportSessionMode)

$(J.deriveJSON (enumJSON $ dropPrefix "SPM") ''SMPProxyMode)

$(J.deriveJSON (enumJSON $ dropPrefix "SPF") ''SMPProxyFallback)

$(J.deriveJSON (enumJSON $ dropPrefix "SWP") ''SMPWebPortServers)

$(J.deriveJSON defaultJSON ''NetworkTimeout)

$(J.deriveJSON defaultJSON ''NetworkConfig)

$(J.deriveJSON (sumTypeJSON $ dropPrefix "Proxy") ''ProxyClientError)

$(J.deriveJSON defaultJSON ''TBQueueInfo)