{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}

module Simplex.Messaging.Agent.Client
  ( AgentClient (..),
    ProtocolTestFailure (..),
    ProtocolTestStep (..),
    ClntQueueReqData (..),
    CQRData (..),
    newAgentClient,
    withConnLock,
    withConnLocks,
    withInvLock,
    withLockMap,
    withLocksMap,
    getMapLock,
    ipAddressProtected,
    closeAgentClient,
    closeProtocolServerClients,
    reconnectServerClients,
    reconnectSMPServer,
    closeXFTPServerClient,
    runSMPServerTest,
    runXFTPServerTest,
    runNTFServerTest,
    getXFTPWorkPath,
    newRcvQueue,
    newRcvQueue_,
    subscribeQueues,
    subscribeUserServerQueues,
    processClientNotices,
    getQueueMessage,
    decryptSMPMessage,
    failSubscription,
    addNewQueueSubscription,
    getSubscriptions,
    sendConfirmation,
    sendInvitation,
    temporaryAgentError,
    temporaryOrHostError,
    serverHostError,
    secureQueue,
    secureSndQueue,
    addQueueLink,
    deleteQueueLink,
    secureGetQueueLink,
    getQueueLink,
    enableQueueNotifications,
    EnableQueueNtfReq (..),
    enableQueuesNtfs,
    disableQueueNotifications,
    DisableQueueNtfReq,
    disableQueuesNtfs,
    sendAgentMessage,
    getQueueInfo,
    agentNtfRegisterToken,
    agentNtfVerifyToken,
    agentNtfCheckToken,
    agentNtfReplaceToken,
    agentNtfDeleteToken,
    agentNtfSetCronInterval,
    agentNtfCreateSubscription,
    agentNtfCreateSubscriptions,
    agentNtfCheckSubscription,
    agentNtfCheckSubscriptions,
    agentNtfDeleteSubscription,
    agentXFTPDownloadChunk,
    agentXFTPNewChunk,
    agentXFTPUploadChunk,
    agentXFTPAddRecipients,
    agentXFTPDeleteChunk,
    agentCbDecrypt,
    cryptoError,
    sendAck,
    suspendQueue,
    deleteQueue,
    deleteQueues,
    logServer,
    logSecret,
    logSecret',
    removeSubscription,
    removeSubscriptions,
    hasActiveSubscription,
    hasPendingSubscription,
    hasRemovedSubscription,
    hasGetLock,
    releaseGetLock,
    activeClientSession,
    agentClientStore,
    agentDRG,
    ServerQueueInfo (..),
    AgentServersSummary (..),
    ServerSessions (..),
    SMPServerSubs (..),
    getAgentSubsTotal,
    getAgentServersSummary,
    getAgentSubscriptions,
    slowNetworkConfig,
    protocolClientError,
    Worker (..),
    SessionVar (..),
    SubscriptionsInfo (..),
    SubInfo (..),
    AgentOperation (..),
    AgentOpState (..),
    AgentState (..),
    AgentLocks (..),
    getAgentWorker,
    getAgentWorker',
    cancelWorker,
    waitForWork,
    hasWorkToDo,
    hasWorkToDo',
    withWork,
    withWork_,
    withWorkItems,
    agentOperations,
    agentOperationBracket,
    waitUntilActive,
    UserNetworkInfo (..),
    UserNetworkType (..),
    getFastNetworkConfig,
    waitForUserNetwork,
    isNetworkOnline,
    isOnline,
    throwWhenInactive,
    throwWhenNoDelivery,
    beginAgentOperation,
    endAgentOperation,
    waitUntilForeground,
    waitWhileSuspended,
    suspendSendingAndDatabase,
    suspendOperation,
    notifySuspended,
    whenSuspending,
    withStore,
    withStore',
    withStoreBatch,
    withStoreBatch',
    unsafeWithStore,
    storeError,
    notifySub,
    notifySub',
    userServers,
    pickServer,
    getNextServer,
    withNextSrv,
    incSMPServerStat,
    incSMPServerStat',
    incXFTPServerStat,
    incXFTPServerStat',
    incXFTPServerSizeStat,
    incNtfServerStat,
    incNtfServerStat',
    AgentWorkersDetails (..),
    getAgentWorkersDetails,
    AgentWorkersSummary (..),
    getAgentWorkersSummary,
    AgentQueuesInfo (..),
    getAgentQueuesInfo,
    SMPTransportSession,
    NtfTransportSession,
    XFTPTransportSession,
    ProxiedRelay (..),
    SMPConnectedClient (..),
  )
where

import Control.Applicative ((<|>))
import Control.Concurrent (ThreadId, killThread)
import Control.Concurrent.Async (Async, uninterruptibleCancel)
import Control.Concurrent.STM (retry)
import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..))
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as J
import Data.Bifunctor (bimap, first, second)
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Composition ((.:), (.:.))
import Data.Containers.ListUtils (nubOrd)
import Data.Either (isRight, partitionEithers)
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (find, foldl')
import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import Data.Time.Clock.System (getSystemTime)
import Data.Word (Word16)
import Network.Socket (HostName)
import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError)
import qualified Simplex.FileTransfer.Client as X
import Simplex.FileTransfer.Description (ChunkReplicaId (..), FileDigest (..), kb)
import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse)
import Simplex.FileTransfer.Transport (XFTPErrorType (DIGEST), XFTPRcvChunkSpec (..), XFTPVersion)
import qualified Simplex.FileTransfer.Transport as XFTP
import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..))
import Simplex.FileTransfer.Util (uniqueCombine)
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Stats
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.AgentStore (getClientNotices, updateClientNotices)
import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
import Simplex.Messaging.Agent.Store.DB (SQLError)
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Agent.Store.Entity
import Simplex.Messaging.Agent.TSessionSubs (TSessionSubs)
import qualified Simplex.Messaging.Agent.TSessionSubs as SS
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Client
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Transport (NTFVersion)
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parse, sumTypeJSON)
import Simplex.Messaging.Protocol
  ( AProtocolType (..),
    BrokerMsg,
    EntityId (..),
    ServiceId,
    ErrorType,
    NetworkError (..),
    MsgFlags (..),
    MsgId,
    NtfServer,
    NtfServerWithAuth,
    ProtoServer,
    ProtoServerWithAuth (..),
    Protocol (..),
    ProtocolServer (..),
    ProtocolType (..),
    ProtocolTypeI (..),
    QueueIdsKeys (..),
    ServerNtfCreds (..),
    RcvMessage (..),
    RcvNtfPublicDhKey,
    SMPMsgMeta (..),
    SProtocolType (..),
    SndPublicAuthKey,
    SubscriptionMode (..),
    NewNtfCreds (..),
    QueueReqData (..),
    QueueLinkData,
    UserProtocol,
    VersionRangeSMPC,
    VersionSMPC,
    XFTPServer,
    XFTPServerWithAuth,
    pattern NoEntity,
    senderCanSecure,
  )
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Protocol.Types
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.Session
import Simplex.Messaging.SystemTime
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId, thVersion), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion, newNtfCredsSMPVersion)
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import System.Mem.Weak (Weak, deRefWeak)
import System.Random (randomR)
import UnliftIO (mapConcurrently, timeout)
import UnliftIO.Async (async)
import UnliftIO.Concurrent (forkIO, mkWeakThreadId)
import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, removeFile)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
#if !defined(dbPostgres)
import qualified Database.SQLite.Simple as SQL
#endif

type ClientVar msg = SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))

type SMPClientVar = ClientVar SMP.BrokerMsg

type NtfClientVar = ClientVar NtfResponse

type XFTPClientVar = ClientVar FileResponse

type NtfTransportSession = TransportSession NtfResponse

type XFTPTransportSession = TransportSession FileResponse

data AgentClient = AgentClient
  { AgentClient -> TVar (Maybe (Weak ThreadId))
acThread :: TVar (Maybe (Weak ThreadId)),
    AgentClient -> TVar Bool
active :: TVar Bool,
    AgentClient -> TBQueue ATransmission
subQ :: TBQueue ATransmission,
    AgentClient
-> TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
    AgentClient -> TMap UserId (UserServers 'PSMP)
smpServers :: TMap UserId (UserServers 'PSMP),
    AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients :: TMap SMPTransportSession SMPClientVar,
    -- smpProxiedRelays:
    -- SMPTransportSession defines connection from proxy to relay,
    -- SMPServerWithAuth defines client connected to SMP proxy (with the same userId and entityId in TransportSession)
    AgentClient -> TMap SMPTransportSession SMPServerWithAuth
smpProxiedRelays :: TMap SMPTransportSession SMPServerWithAuth,
    AgentClient -> TVar [ProtocolServer 'PNTF]
ntfServers :: TVar [NtfServer],
    AgentClient -> TMap NtfTransportSession NtfClientVar
ntfClients :: TMap NtfTransportSession NtfClientVar,
    AgentClient -> TMap UserId (UserServers 'PXFTP)
xftpServers :: TMap UserId (UserServers 'PXFTP),
    AgentClient -> TMap XFTPTransportSession XFTPClientVar
xftpClients :: TMap XFTPTransportSession XFTPClientVar,
    AgentClient -> TVar (NetworkConfig, NetworkConfig)
useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks
    AgentClient -> [String]
presetDomains :: [HostName],
    AgentClient -> [ProtocolServer 'PSMP]
presetServers :: [SMPServer],
    AgentClient -> TVar UserNetworkInfo
userNetworkInfo :: TVar UserNetworkInfo,
    AgentClient -> TVar (Maybe UTCTime)
userNetworkUpdated :: TVar (Maybe UTCTime),
    AgentClient -> TVar (Set ByteString)
subscrConns :: TVar (Set ConnId),
    AgentClient -> TSessionSubs
currentSubs :: TSessionSubs,
    AgentClient
-> TMap
     (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
removedSubs :: TMap (UserId, SMPServer) (TMap SMP.RecipientId SMPClientError),
    AgentClient
-> TMap (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
clientNotices :: TMap (Maybe SMPServer) (Maybe SystemSeconds),
    AgentClient -> TMVar ()
clientNoticesLock :: TMVar (),
    AgentClient -> TVar Int
workerSeq :: TVar Int,
    AgentClient -> TMap SndQAddr (Worker, TMVar ())
smpDeliveryWorkers :: TMap SndQAddr (Worker, TMVar ()),
    AgentClient
-> TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
asyncCmdWorkers :: TMap (ConnId, Maybe SMPServer) Worker,
    AgentClient -> TVar AgentOpState
ntfNetworkOp :: TVar AgentOpState,
    AgentClient -> TVar AgentOpState
rcvNetworkOp :: TVar AgentOpState,
    AgentClient -> TVar AgentOpState
msgDeliveryOp :: TVar AgentOpState,
    AgentClient -> TVar AgentOpState
sndNetworkOp :: TVar AgentOpState,
    AgentClient -> TVar AgentOpState
databaseOp :: TVar AgentOpState,
    AgentClient -> TVar AgentState
agentState :: TVar AgentState,
    AgentClient -> TMap SndQAddr (TMVar ())
getMsgLocks :: TMap (SMPServer, SMP.RecipientId) (TMVar ()),
    -- locks to prevent concurrent operations with connection
    AgentClient -> TMap ByteString Lock
connLocks :: TMap ConnId Lock,
    -- locks to prevent concurrent operations with connection request invitations
    AgentClient -> TMap ByteString Lock
invLocks :: TMap ByteString Lock,
    -- lock to prevent concurrency between periodic and async connection deletions
    AgentClient -> Lock
deleteLock :: Lock,
    -- smpSubWorkers for SMP servers sessions
    AgentClient -> TMap SMPTransportSession (SessionVar (Async ()))
smpSubWorkers :: TMap SMPTransportSession (SessionVar (Async ())),
    AgentClient -> Int
clientId :: Int,
    AgentClient -> Env
agentEnv :: Env,
    AgentClient -> TVar UTCTime
proxySessTs :: TVar UTCTime,
    AgentClient
-> TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats,
    AgentClient
-> TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats,
    AgentClient
-> TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
ntfServersStats :: TMap (UserId, NtfServer) AgentNtfServerStats,
    AgentClient -> TVar UTCTime
srvStatsStartedAt :: TVar UTCTime
  }

data SMPConnectedClient = SMPConnectedClient
  { SMPConnectedClient -> SMPClient
connectedClient :: SMPClient,
    SMPConnectedClient -> TMap (ProtocolServer 'PSMP) ProxiedRelayVar
proxiedRelays :: TMap SMPServer ProxiedRelayVar
  }

type ProxiedRelayVar = SessionVar (Either AgentErrorType ProxiedRelay)

getAgentWorker :: (Ord k, Show k, AnyError e, MonadUnliftIO m) => String -> Bool -> AgentClient -> k -> TMap k Worker -> (Worker -> ExceptT e m ()) -> m Worker
getAgentWorker :: forall k e (m :: * -> *).
(Ord k, Show k, AnyError e, MonadUnliftIO m) =>
String
-> Bool
-> AgentClient
-> k
-> TMap k Worker
-> (Worker -> ExceptT e m ())
-> m Worker
getAgentWorker = (Worker -> Worker)
-> (Worker -> STM Worker)
-> String
-> Bool
-> AgentClient
-> k
-> TMap k Worker
-> (Worker -> ExceptT e m ())
-> m Worker
forall a k e (m :: * -> *).
(Ord k, Show k, AnyError e, MonadUnliftIO m) =>
(a -> Worker)
-> (Worker -> STM a)
-> String
-> Bool
-> AgentClient
-> k
-> TMap k a
-> (a -> ExceptT e m ())
-> m a
getAgentWorker' Worker -> Worker
forall a. a -> a
id Worker -> STM Worker
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE getAgentWorker #-}

getAgentWorker' :: forall a k e m. (Ord k, Show k, AnyError e, MonadUnliftIO m) => (a -> Worker) -> (Worker -> STM a) -> String -> Bool -> AgentClient -> k -> TMap k a -> (a -> ExceptT e m ()) -> m a
getAgentWorker' :: forall a k e (m :: * -> *).
(Ord k, Show k, AnyError e, MonadUnliftIO m) =>
(a -> Worker)
-> (Worker -> STM a)
-> String
-> Bool
-> AgentClient
-> k
-> TMap k a
-> (a -> ExceptT e m ())
-> m a
getAgentWorker' a -> Worker
toW Worker -> STM a
fromW String
name Bool
hasWork c :: AgentClient
c@AgentClient {Env
$sel:agentEnv:AgentClient :: AgentClient -> Env
agentEnv :: Env
agentEnv} k
key TMap k a
ws a -> ExceptT e m ()
work = do
  STM a -> m a
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe a)
getWorker STM (Maybe a) -> (Maybe a -> STM a) -> STM a
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM a -> (a -> STM a) -> Maybe a -> STM a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM a
createWorker a -> STM a
whenExists) m a -> (a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
w -> a -> m ()
runWorker a
w m () -> a -> m a
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
w
  where
    getWorker :: STM (Maybe a)
getWorker = k -> TMap k a -> STM (Maybe a)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup k
key TMap k a
ws
    createWorker :: STM a
createWorker = do
      a
w <- Worker -> STM a
fromW (Worker -> STM a) -> STM Worker -> STM a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AgentClient -> STM Worker
newWorker AgentClient
c
      k -> a -> TMap k a -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert k
key a
w TMap k a
ws
      a -> STM a
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
w
    whenExists :: a -> STM a
whenExists a
w
      | Bool
hasWork = Worker -> STM ()
hasWorkToDo (a -> Worker
toW a
w) STM () -> a -> STM a
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
w
      | Bool
otherwise = a -> STM a
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
w
    runWorker :: a -> m ()
runWorker a
w = Worker -> m () -> m ()
forall (m :: * -> *). MonadUnliftIO m => Worker -> m () -> m ()
runWorkerAsync (a -> Worker
toW a
w) m ()
runWork
      where
        runWork :: m ()
        runWork :: m ()
runWork = ExceptT e m () -> m (Either e ())
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (a -> ExceptT e m ()
work a
w) m (Either e ()) -> (Either e () -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either e () -> m ()
restartOrDelete
        restartOrDelete :: Either e () -> m ()
        restartOrDelete :: Either e () -> m ()
restartOrDelete Either e ()
e_ = do
          SystemTime
t <- IO SystemTime -> m SystemTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemTime
getSystemTime
          let maxRestarts :: Int
maxRestarts = AgentConfig -> Int
maxWorkerRestartsPerMin (AgentConfig -> Int) -> AgentConfig -> Int
forall a b. (a -> b) -> a -> b
$ Env -> AgentConfig
config Env
agentEnv
          -- worker may terminate because it was deleted from the map (getWorker returns Nothing), then it won't restart
          Bool
restart <- STM Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> m Bool) -> STM Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ STM (Maybe a)
getWorker STM (Maybe a) -> (Maybe a -> STM Bool) -> STM Bool
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM Bool -> (a -> STM Bool) -> Maybe a -> STM Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (Either e () -> Worker -> SystemTime -> Int -> a -> STM Bool
shouldRestart Either e ()
e_ (a -> Worker
toW a
w) SystemTime
t Int
maxRestarts)
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
restart m ()
runWork
        shouldRestart :: Either e () -> Worker -> SystemTime -> Int -> a -> STM Bool
shouldRestart Either e ()
e_ Worker {$sel:workerId:Worker :: Worker -> Int
workerId = Int
wId, TMVar ()
doWork :: TMVar ()
$sel:doWork:Worker :: Worker -> TMVar ()
doWork, TMVar (Maybe (Weak ThreadId))
action :: TMVar (Maybe (Weak ThreadId))
$sel:action:Worker :: Worker -> TMVar (Maybe (Weak ThreadId))
action, TVar RestartCount
restarts :: TVar RestartCount
$sel:restarts:Worker :: Worker -> TVar RestartCount
restarts} SystemTime
t Int
maxRestarts a
w'
          | Int
wId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Worker -> Int
workerId (a -> Worker
toW a
w') = do
              RestartCount
rc <- TVar RestartCount -> STM RestartCount
forall a. TVar a -> STM a
readTVar TVar RestartCount
restarts
              Bool
isActive <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar (TVar Bool -> STM Bool) -> TVar Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$ AgentClient -> TVar Bool
active AgentClient
c
              Bool -> RestartCount -> STM Bool
checkRestarts Bool
isActive (RestartCount -> STM Bool) -> RestartCount -> STM Bool
forall a b. (a -> b) -> a -> b
$ SystemTime -> RestartCount -> RestartCount
updateRestartCount SystemTime
t RestartCount
rc
          | Bool
otherwise =
              Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False -- there is a new worker in the map, no action
          where
            checkRestarts :: Bool -> RestartCount -> STM Bool
checkRestarts Bool
isActive RestartCount
rc
              | Bool
isActive Bool -> Bool -> Bool
&& RestartCount -> Int
restartCount RestartCount
rc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxRestarts = do
                  TVar RestartCount -> RestartCount -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar RestartCount
restarts RestartCount
rc
                  TMVar () -> STM ()
hasWorkToDo' TMVar ()
doWork
                  STM Bool -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bool -> STM ()) -> STM Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe (Weak ThreadId)) -> Maybe (Weak ThreadId) -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Maybe (Weak ThreadId))
action Maybe (Weak ThreadId)
forall a. Maybe a
Nothing
                  (String -> AgentErrorType) -> STM ()
notifyErr String -> AgentErrorType
INTERNAL
                  Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
              | Bool
otherwise = do
                  k -> TMap k a -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete k
key TMap k a
ws
                  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isActive (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ (String -> AgentErrorType) -> STM ()
notifyErr ((String -> AgentErrorType) -> STM ())
-> (String -> AgentErrorType) -> STM ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> AgentErrorType
CRITICAL Bool
True
                  Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
              where
                notifyErr :: (String -> AgentErrorType) -> STM ()
notifyErr String -> AgentErrorType
err = do
                  let e :: String
e = (e -> String) -> (() -> String) -> Either e () -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((String
", error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (e -> String) -> e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show) (\()
_ -> String
", no error") Either e ()
e_
                      msg :: String
msg = String
"Worker " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> k -> String
forall a. Show a => a -> String
show k
key String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" terminated " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (RestartCount -> Int
restartCount RestartCount
rc) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" times" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e
                  TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ByteString
"", ByteString
"", SAEntity 'AEConn -> AEvent 'AEConn -> AEvt
forall (e :: AEntity). AEntityI e => SAEntity e -> AEvent e -> AEvt
AEvt SAEntity 'AEConn
SAEConn (AEvent 'AEConn -> AEvt) -> AEvent 'AEConn -> AEvt
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> AEvent 'AEConn)
-> AgentErrorType -> AEvent 'AEConn
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
err String
msg)

newWorker :: AgentClient -> STM Worker
newWorker :: AgentClient -> STM Worker
newWorker AgentClient
c = do
  Int
workerId <- TVar Int -> (Int -> (Int, Int)) -> STM Int
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar (AgentClient -> TVar Int
workerSeq AgentClient
c) ((Int -> (Int, Int)) -> STM Int) -> (Int -> (Int, Int)) -> STM Int
forall a b. (a -> b) -> a -> b
$ \Int
next -> (Int
next, Int
next Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  TMVar ()
doWork <- () -> STM (TMVar ())
forall a. a -> STM (TMVar a)
newTMVar () -- new worker is created  with "some work to do" (indicated by () in TMVar)
  TMVar (Maybe (Weak ThreadId))
action <- Maybe (Weak ThreadId) -> STM (TMVar (Maybe (Weak ThreadId)))
forall a. a -> STM (TMVar a)
newTMVar Maybe (Weak ThreadId)
forall a. Maybe a
Nothing
  TVar RestartCount
restarts <- RestartCount -> STM (TVar RestartCount)
forall a. a -> STM (TVar a)
newTVar (RestartCount -> STM (TVar RestartCount))
-> RestartCount -> STM (TVar RestartCount)
forall a b. (a -> b) -> a -> b
$ UserId -> Int -> RestartCount
RestartCount UserId
0 Int
0
  Worker -> STM Worker
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Worker {Int
$sel:workerId:Worker :: Int
workerId :: Int
workerId, TMVar ()
$sel:doWork:Worker :: TMVar ()
doWork :: TMVar ()
doWork, TMVar (Maybe (Weak ThreadId))
$sel:action:Worker :: TMVar (Maybe (Weak ThreadId))
action :: TMVar (Maybe (Weak ThreadId))
action, TVar RestartCount
$sel:restarts:Worker :: TVar RestartCount
restarts :: TVar RestartCount
restarts}

runWorkerAsync :: MonadUnliftIO m => Worker -> m () -> m ()
runWorkerAsync :: forall (m :: * -> *). MonadUnliftIO m => Worker -> m () -> m ()
runWorkerAsync Worker {TMVar (Maybe (Weak ThreadId))
$sel:action:Worker :: Worker -> TMVar (Maybe (Weak ThreadId))
action :: TMVar (Maybe (Weak ThreadId))
action} m ()
work =
  m (Maybe (Weak ThreadId))
-> (Maybe (Weak ThreadId) -> m Bool)
-> (Maybe (Weak ThreadId) -> m ())
-> m ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket
    (STM (Maybe (Weak ThreadId)) -> m (Maybe (Weak ThreadId))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe (Weak ThreadId)) -> m (Maybe (Weak ThreadId)))
-> STM (Maybe (Weak ThreadId)) -> m (Maybe (Weak ThreadId))
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe (Weak ThreadId)) -> STM (Maybe (Weak ThreadId))
forall a. TMVar a -> STM a
takeTMVar TMVar (Maybe (Weak ThreadId))
action) -- get current action, locking to avoid race conditions
    (STM Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> m Bool)
-> (Maybe (Weak ThreadId) -> STM Bool)
-> Maybe (Weak ThreadId)
-> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (Maybe (Weak ThreadId)) -> Maybe (Weak ThreadId) -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Maybe (Weak ThreadId))
action) -- if it was running (or if start crashes), put it back and unlock (don't lock if it was just started)
    (\Maybe (Weak ThreadId)
a -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Weak ThreadId) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Weak ThreadId)
a) m ()
start) -- start worker if it's not running
  where
    start :: m ()
start = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ())
-> (Weak ThreadId -> STM ()) -> Weak ThreadId -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (Maybe (Weak ThreadId)) -> Maybe (Weak ThreadId) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Maybe (Weak ThreadId))
action (Maybe (Weak ThreadId) -> STM ())
-> (Weak ThreadId -> Maybe (Weak ThreadId))
-> Weak ThreadId
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Weak ThreadId -> Maybe (Weak ThreadId)
forall a. a -> Maybe a
Just (Weak ThreadId -> m ()) -> m (Weak ThreadId) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ThreadId -> m (Weak ThreadId)
forall (m :: * -> *). MonadIO m => ThreadId -> m (Weak ThreadId)
mkWeakThreadId (ThreadId -> m (Weak ThreadId)) -> m ThreadId -> m (Weak ThreadId)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m () -> m ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO m ()
work

data AgentOperation = AONtfNetwork | AORcvNetwork | AOMsgDelivery | AOSndNetwork | AODatabase
  deriving (AgentOperation -> AgentOperation -> Bool
(AgentOperation -> AgentOperation -> Bool)
-> (AgentOperation -> AgentOperation -> Bool) -> Eq AgentOperation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AgentOperation -> AgentOperation -> Bool
== :: AgentOperation -> AgentOperation -> Bool
$c/= :: AgentOperation -> AgentOperation -> Bool
/= :: AgentOperation -> AgentOperation -> Bool
Eq, Int -> AgentOperation -> String -> String
[AgentOperation] -> String -> String
AgentOperation -> String
(Int -> AgentOperation -> String -> String)
-> (AgentOperation -> String)
-> ([AgentOperation] -> String -> String)
-> Show AgentOperation
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AgentOperation -> String -> String
showsPrec :: Int -> AgentOperation -> String -> String
$cshow :: AgentOperation -> String
show :: AgentOperation -> String
$cshowList :: [AgentOperation] -> String -> String
showList :: [AgentOperation] -> String -> String
Show)

agentOpSel :: AgentOperation -> (AgentClient -> TVar AgentOpState)
agentOpSel :: AgentOperation -> AgentClient -> TVar AgentOpState
agentOpSel = \case
  AgentOperation
AONtfNetwork -> AgentClient -> TVar AgentOpState
ntfNetworkOp
  AgentOperation
AORcvNetwork -> AgentClient -> TVar AgentOpState
rcvNetworkOp
  AgentOperation
AOMsgDelivery -> AgentClient -> TVar AgentOpState
msgDeliveryOp
  AgentOperation
AOSndNetwork -> AgentClient -> TVar AgentOpState
sndNetworkOp
  AgentOperation
AODatabase -> AgentClient -> TVar AgentOpState
databaseOp

agentOperations :: [AgentClient -> TVar AgentOpState]
agentOperations :: [AgentClient -> TVar AgentOpState]
agentOperations = [Item [AgentClient -> TVar AgentOpState]
AgentClient -> TVar AgentOpState
ntfNetworkOp, Item [AgentClient -> TVar AgentOpState]
AgentClient -> TVar AgentOpState
rcvNetworkOp, Item [AgentClient -> TVar AgentOpState]
AgentClient -> TVar AgentOpState
msgDeliveryOp, Item [AgentClient -> TVar AgentOpState]
AgentClient -> TVar AgentOpState
sndNetworkOp, Item [AgentClient -> TVar AgentOpState]
AgentClient -> TVar AgentOpState
databaseOp]

data AgentOpState = AgentOpState {AgentOpState -> Bool
opSuspended :: !Bool, AgentOpState -> Int
opsInProgress :: !Int}

data AgentState = ASForeground | ASSuspending | ASSuspended
  deriving (AgentState -> AgentState -> Bool
(AgentState -> AgentState -> Bool)
-> (AgentState -> AgentState -> Bool) -> Eq AgentState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AgentState -> AgentState -> Bool
== :: AgentState -> AgentState -> Bool
$c/= :: AgentState -> AgentState -> Bool
/= :: AgentState -> AgentState -> Bool
Eq, Int -> AgentState -> String -> String
[AgentState] -> String -> String
AgentState -> String
(Int -> AgentState -> String -> String)
-> (AgentState -> String)
-> ([AgentState] -> String -> String)
-> Show AgentState
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AgentState -> String -> String
showsPrec :: Int -> AgentState -> String -> String
$cshow :: AgentState -> String
show :: AgentState -> String
$cshowList :: [AgentState] -> String -> String
showList :: [AgentState] -> String -> String
Show)

data AgentLocks = AgentLocks
  { AgentLocks -> Map Text Text
connLocks :: Map Text Text,
    AgentLocks -> Map Text Text
invLocks :: Map Text Text,
    AgentLocks -> Maybe Text
delLock :: Maybe Text
  }
  deriving (Int -> AgentLocks -> String -> String
[AgentLocks] -> String -> String
AgentLocks -> String
(Int -> AgentLocks -> String -> String)
-> (AgentLocks -> String)
-> ([AgentLocks] -> String -> String)
-> Show AgentLocks
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AgentLocks -> String -> String
showsPrec :: Int -> AgentLocks -> String -> String
$cshow :: AgentLocks -> String
show :: AgentLocks -> String
$cshowList :: [AgentLocks] -> String -> String
showList :: [AgentLocks] -> String -> String
Show)

data UserNetworkInfo = UserNetworkInfo
  { UserNetworkInfo -> UserNetworkType
networkType :: UserNetworkType,
    UserNetworkInfo -> Bool
online :: Bool
  }
  deriving (Int -> UserNetworkInfo -> String -> String
[UserNetworkInfo] -> String -> String
UserNetworkInfo -> String
(Int -> UserNetworkInfo -> String -> String)
-> (UserNetworkInfo -> String)
-> ([UserNetworkInfo] -> String -> String)
-> Show UserNetworkInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UserNetworkInfo -> String -> String
showsPrec :: Int -> UserNetworkInfo -> String -> String
$cshow :: UserNetworkInfo -> String
show :: UserNetworkInfo -> String
$cshowList :: [UserNetworkInfo] -> String -> String
showList :: [UserNetworkInfo] -> String -> String
Show)

isNetworkOnline :: AgentClient -> STM Bool
isNetworkOnline :: AgentClient -> STM Bool
isNetworkOnline AgentClient
c = UserNetworkInfo -> Bool
isOnline (UserNetworkInfo -> Bool) -> STM UserNetworkInfo -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar UserNetworkInfo -> STM UserNetworkInfo
forall a. TVar a -> STM a
readTVar (AgentClient -> TVar UserNetworkInfo
userNetworkInfo AgentClient
c)

isOnline :: UserNetworkInfo -> Bool
isOnline :: UserNetworkInfo -> Bool
isOnline UserNetworkInfo {UserNetworkType
$sel:networkType:UserNetworkInfo :: UserNetworkInfo -> UserNetworkType
networkType :: UserNetworkType
networkType, Bool
$sel:online:UserNetworkInfo :: UserNetworkInfo -> Bool
online :: Bool
online} = UserNetworkType
networkType UserNetworkType -> UserNetworkType -> Bool
forall a. Eq a => a -> a -> Bool
/= UserNetworkType
UNNone Bool -> Bool -> Bool
&& Bool
online

data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther
  deriving (UserNetworkType -> UserNetworkType -> Bool
(UserNetworkType -> UserNetworkType -> Bool)
-> (UserNetworkType -> UserNetworkType -> Bool)
-> Eq UserNetworkType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UserNetworkType -> UserNetworkType -> Bool
== :: UserNetworkType -> UserNetworkType -> Bool
$c/= :: UserNetworkType -> UserNetworkType -> Bool
/= :: UserNetworkType -> UserNetworkType -> Bool
Eq, Int -> UserNetworkType -> String -> String
[UserNetworkType] -> String -> String
UserNetworkType -> String
(Int -> UserNetworkType -> String -> String)
-> (UserNetworkType -> String)
-> ([UserNetworkType] -> String -> String)
-> Show UserNetworkType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UserNetworkType -> String -> String
showsPrec :: Int -> UserNetworkType -> String -> String
$cshow :: UserNetworkType -> String
show :: UserNetworkType -> String
$cshowList :: [UserNetworkType] -> String -> String
showList :: [UserNetworkType] -> String -> String
Show)

-- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Map (Maybe SMPServer) (Maybe SystemSeconds) -> Env -> IO AgentClient
newAgentClient :: Int
-> InitialAgentServers
-> UTCTime
-> Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
-> Env
-> IO AgentClient
newAgentClient Int
clientId InitialAgentServers {Map UserId (NonEmpty (ServerCfg 'PSMP))
smp :: Map UserId (NonEmpty (ServerCfg 'PSMP))
$sel:smp:InitialAgentServers :: InitialAgentServers -> Map UserId (NonEmpty (ServerCfg 'PSMP))
smp, [ProtocolServer 'PNTF]
ntf :: [ProtocolServer 'PNTF]
$sel:ntf:InitialAgentServers :: InitialAgentServers -> [ProtocolServer 'PNTF]
ntf, Map UserId (NonEmpty (ServerCfg 'PXFTP))
xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP))
$sel:xftp:InitialAgentServers :: InitialAgentServers -> Map UserId (NonEmpty (ServerCfg 'PXFTP))
xftp, NetworkConfig
netCfg :: NetworkConfig
$sel:netCfg:InitialAgentServers :: InitialAgentServers -> NetworkConfig
netCfg, [String]
presetDomains :: [String]
$sel:presetDomains:InitialAgentServers :: InitialAgentServers -> [String]
presetDomains, [ProtocolServer 'PSMP]
presetServers :: [ProtocolServer 'PSMP]
$sel:presetServers:InitialAgentServers :: InitialAgentServers -> [ProtocolServer 'PSMP]
presetServers} UTCTime
currentTs Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
notices Env
agentEnv = do
  let cfg :: AgentConfig
cfg = Env -> AgentConfig
config Env
agentEnv
      qSize :: Natural
qSize = AgentConfig -> Natural
tbqSize AgentConfig
cfg
  TVar UTCTime
proxySessTs <- UTCTime -> IO (TVar UTCTime)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (UTCTime -> IO (TVar UTCTime)) -> IO UTCTime -> IO (TVar UTCTime)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
  TVar (Maybe (Weak ThreadId))
acThread <- Maybe (Weak ThreadId) -> IO (TVar (Maybe (Weak ThreadId)))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe (Weak ThreadId)
forall a. Maybe a
Nothing
  TVar Bool
active <- Bool -> IO (TVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
True
  TBQueue ATransmission
subQ <- Natural -> IO (TBQueue ATransmission)
forall (m :: * -> *) a. MonadIO m => Natural -> m (TBQueue a)
newTBQueueIO Natural
qSize
  TBQueue
  ((UserId, ProtocolServer 'PSMP, Maybe ByteString),
   Version SMPVersion, ByteString,
   NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg))
msgQ <- Natural
-> IO
     (TBQueue
        ((UserId, ProtocolServer 'PSMP, Maybe ByteString),
         Version SMPVersion, ByteString,
         NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg)))
forall (m :: * -> *) a. MonadIO m => Natural -> m (TBQueue a)
newTBQueueIO Natural
qSize
  TMap UserId (UserServers 'PSMP)
smpServers <- Map UserId (UserServers 'PSMP)
-> IO (TMap UserId (UserServers 'PSMP))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (Map UserId (UserServers 'PSMP)
 -> IO (TMap UserId (UserServers 'PSMP)))
-> Map UserId (UserServers 'PSMP)
-> IO (TMap UserId (UserServers 'PSMP))
forall a b. (a -> b) -> a -> b
$ (NonEmpty (ServerCfg 'PSMP) -> UserServers 'PSMP)
-> Map UserId (NonEmpty (ServerCfg 'PSMP))
-> Map UserId (UserServers 'PSMP)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map NonEmpty (ServerCfg 'PSMP) -> UserServers 'PSMP
forall (p :: ProtocolType). NonEmpty (ServerCfg p) -> UserServers p
mkUserServers Map UserId (NonEmpty (ServerCfg 'PSMP))
smp
  TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
smpClients <- IO
  (TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall k a. IO (TMap k a)
TM.emptyIO
  TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
smpProxiedRelays <- IO
  (TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth)
forall k a. IO (TMap k a)
TM.emptyIO
  TVar [ProtocolServer 'PNTF]
ntfServers <- [ProtocolServer 'PNTF] -> IO (TVar [ProtocolServer 'PNTF])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO [ProtocolServer 'PNTF]
ntf
  TMap
  (UserId, ProtocolServer 'PNTF, Maybe ByteString)
  (SessionVar
     (Either
        (AgentErrorType, Maybe UTCTime)
        (ProtocolClient NTFVersion ErrorType NtfResponse)))
ntfClients <- IO
  (TMap
     (UserId, ProtocolServer 'PNTF, Maybe ByteString)
     (SessionVar
        (Either
           (AgentErrorType, Maybe UTCTime)
           (ProtocolClient NTFVersion ErrorType NtfResponse))))
forall k a. IO (TMap k a)
TM.emptyIO
  TMap UserId (UserServers 'PXFTP)
xftpServers <- Map UserId (UserServers 'PXFTP)
-> IO (TMap UserId (UserServers 'PXFTP))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (Map UserId (UserServers 'PXFTP)
 -> IO (TMap UserId (UserServers 'PXFTP)))
-> Map UserId (UserServers 'PXFTP)
-> IO (TMap UserId (UserServers 'PXFTP))
forall a b. (a -> b) -> a -> b
$ (NonEmpty (ServerCfg 'PXFTP) -> UserServers 'PXFTP)
-> Map UserId (NonEmpty (ServerCfg 'PXFTP))
-> Map UserId (UserServers 'PXFTP)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map NonEmpty (ServerCfg 'PXFTP) -> UserServers 'PXFTP
forall (p :: ProtocolType). NonEmpty (ServerCfg p) -> UserServers p
mkUserServers Map UserId (NonEmpty (ServerCfg 'PXFTP))
xftp
  TMap
  (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
  (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
xftpClients <- IO
  (TMap
     (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
     (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)))
forall k a. IO (TMap k a)
TM.emptyIO
  TVar (NetworkConfig, NetworkConfig)
useNetworkConfig <- (NetworkConfig, NetworkConfig)
-> IO (TVar (NetworkConfig, NetworkConfig))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (NetworkConfig -> NetworkConfig
slowNetworkConfig NetworkConfig
netCfg, NetworkConfig
netCfg)
  TVar UserNetworkInfo
userNetworkInfo <- UserNetworkInfo -> IO (TVar UserNetworkInfo)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (UserNetworkInfo -> IO (TVar UserNetworkInfo))
-> UserNetworkInfo -> IO (TVar UserNetworkInfo)
forall a b. (a -> b) -> a -> b
$ UserNetworkType -> Bool -> UserNetworkInfo
UserNetworkInfo UserNetworkType
UNOther Bool
True
  TVar (Maybe UTCTime)
userNetworkUpdated <- Maybe UTCTime -> IO (TVar (Maybe UTCTime))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe UTCTime
forall a. Maybe a
Nothing
  TVar (Set ByteString)
subscrConns <- Set ByteString -> IO (TVar (Set ByteString))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Set ByteString
forall a. Set a
S.empty
  TSessionSubs
currentSubs <- IO TSessionSubs
SS.emptyIO
  TMap
  (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
removedSubs <- IO
  (TMap
     (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError))
forall k a. IO (TMap k a)
TM.emptyIO
  TMap (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
clientNotices <- Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
-> IO (TMap (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
notices
  TMVar ()
clientNoticesLock <- () -> IO (TMVar ())
forall (m :: * -> *) a. MonadIO m => a -> m (TMVar a)
newTMVarIO ()
  TVar Int
workerSeq <- Int -> IO (TVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int
0
  TMap SndQAddr (Worker, TMVar ())
smpDeliveryWorkers <- IO (TMap SndQAddr (Worker, TMVar ()))
forall k a. IO (TMap k a)
TM.emptyIO
  TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
asyncCmdWorkers <- IO (TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker)
forall k a. IO (TMap k a)
TM.emptyIO
  TVar AgentOpState
ntfNetworkOp <- AgentOpState -> IO (TVar AgentOpState)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (AgentOpState -> IO (TVar AgentOpState))
-> AgentOpState -> IO (TVar AgentOpState)
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> AgentOpState
AgentOpState Bool
False Int
0
  TVar AgentOpState
rcvNetworkOp <- AgentOpState -> IO (TVar AgentOpState)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (AgentOpState -> IO (TVar AgentOpState))
-> AgentOpState -> IO (TVar AgentOpState)
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> AgentOpState
AgentOpState Bool
False Int
0
  TVar AgentOpState
msgDeliveryOp <- AgentOpState -> IO (TVar AgentOpState)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (AgentOpState -> IO (TVar AgentOpState))
-> AgentOpState -> IO (TVar AgentOpState)
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> AgentOpState
AgentOpState Bool
False Int
0
  TVar AgentOpState
sndNetworkOp <- AgentOpState -> IO (TVar AgentOpState)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (AgentOpState -> IO (TVar AgentOpState))
-> AgentOpState -> IO (TVar AgentOpState)
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> AgentOpState
AgentOpState Bool
False Int
0
  TVar AgentOpState
databaseOp <- AgentOpState -> IO (TVar AgentOpState)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (AgentOpState -> IO (TVar AgentOpState))
-> AgentOpState -> IO (TVar AgentOpState)
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> AgentOpState
AgentOpState Bool
False Int
0
  TVar AgentState
agentState <- AgentState -> IO (TVar AgentState)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO AgentState
ASForeground
  TMap SndQAddr (TMVar ())
getMsgLocks <- IO (TMap SndQAddr (TMVar ()))
forall k a. IO (TMap k a)
TM.emptyIO
  TMap ByteString Lock
connLocks <- IO (TMap ByteString Lock)
forall k a. IO (TMap k a)
TM.emptyIO
  TMap ByteString Lock
invLocks <- IO (TMap ByteString Lock)
forall k a. IO (TMap k a)
TM.emptyIO
  Lock
deleteLock <- IO Lock
createLockIO
  TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
smpSubWorkers <- IO
  (TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar (Async ())))
forall k a. IO (TMap k a)
TM.emptyIO
  TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
smpServersStats <- IO (TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats)
forall k a. IO (TMap k a)
TM.emptyIO
  TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
xftpServersStats <- IO (TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats)
forall k a. IO (TMap k a)
TM.emptyIO
  TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
ntfServersStats <- IO (TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats)
forall k a. IO (TMap k a)
TM.emptyIO
  TVar UTCTime
srvStatsStartedAt <- UTCTime -> IO (TVar UTCTime)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO UTCTime
currentTs
  AgentClient -> IO AgentClient
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    AgentClient
      { TVar (Maybe (Weak ThreadId))
$sel:acThread:AgentClient :: TVar (Maybe (Weak ThreadId))
acThread :: TVar (Maybe (Weak ThreadId))
acThread,
        TVar Bool
$sel:active:AgentClient :: TVar Bool
active :: TVar Bool
active,
        TBQueue ATransmission
$sel:subQ:AgentClient :: TBQueue ATransmission
subQ :: TBQueue ATransmission
subQ,
        TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
TBQueue
  ((UserId, ProtocolServer 'PSMP, Maybe ByteString),
   Version SMPVersion, ByteString,
   NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg))
$sel:msgQ:AgentClient :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
msgQ :: TBQueue
  ((UserId, ProtocolServer 'PSMP, Maybe ByteString),
   Version SMPVersion, ByteString,
   NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg))
msgQ,
        TMap UserId (UserServers 'PSMP)
$sel:smpServers:AgentClient :: TMap UserId (UserServers 'PSMP)
smpServers :: TMap UserId (UserServers 'PSMP)
smpServers,
        TMap SMPTransportSession SMPClientVar
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
$sel:smpClients:AgentClient :: TMap SMPTransportSession SMPClientVar
smpClients :: TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
smpClients,
        TMap SMPTransportSession SMPServerWithAuth
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
$sel:smpProxiedRelays:AgentClient :: TMap SMPTransportSession SMPServerWithAuth
smpProxiedRelays :: TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
smpProxiedRelays,
        TVar [ProtocolServer 'PNTF]
$sel:ntfServers:AgentClient :: TVar [ProtocolServer 'PNTF]
ntfServers :: TVar [ProtocolServer 'PNTF]
ntfServers,
        TMap NtfTransportSession NtfClientVar
TMap
  (UserId, ProtocolServer 'PNTF, Maybe ByteString)
  (SessionVar
     (Either
        (AgentErrorType, Maybe UTCTime)
        (ProtocolClient NTFVersion ErrorType NtfResponse)))
$sel:ntfClients:AgentClient :: TMap NtfTransportSession NtfClientVar
ntfClients :: TMap
  (UserId, ProtocolServer 'PNTF, Maybe ByteString)
  (SessionVar
     (Either
        (AgentErrorType, Maybe UTCTime)
        (ProtocolClient NTFVersion ErrorType NtfResponse)))
ntfClients,
        TMap UserId (UserServers 'PXFTP)
$sel:xftpServers:AgentClient :: TMap UserId (UserServers 'PXFTP)
xftpServers :: TMap UserId (UserServers 'PXFTP)
xftpServers,
        TMap XFTPTransportSession XFTPClientVar
TMap
  (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
  (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
$sel:xftpClients:AgentClient :: TMap XFTPTransportSession XFTPClientVar
xftpClients :: TMap
  (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
  (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
xftpClients,
        TVar (NetworkConfig, NetworkConfig)
$sel:useNetworkConfig:AgentClient :: TVar (NetworkConfig, NetworkConfig)
useNetworkConfig :: TVar (NetworkConfig, NetworkConfig)
useNetworkConfig,
        [String]
$sel:presetDomains:AgentClient :: [String]
presetDomains :: [String]
presetDomains,
        [ProtocolServer 'PSMP]
$sel:presetServers:AgentClient :: [ProtocolServer 'PSMP]
presetServers :: [ProtocolServer 'PSMP]
presetServers,
        TVar UserNetworkInfo
$sel:userNetworkInfo:AgentClient :: TVar UserNetworkInfo
userNetworkInfo :: TVar UserNetworkInfo
userNetworkInfo,
        TVar (Maybe UTCTime)
$sel:userNetworkUpdated:AgentClient :: TVar (Maybe UTCTime)
userNetworkUpdated :: TVar (Maybe UTCTime)
userNetworkUpdated,
        TVar (Set ByteString)
$sel:subscrConns:AgentClient :: TVar (Set ByteString)
subscrConns :: TVar (Set ByteString)
subscrConns,
        TSessionSubs
$sel:currentSubs:AgentClient :: TSessionSubs
currentSubs :: TSessionSubs
currentSubs,
        TMap
  (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
$sel:removedSubs:AgentClient :: TMap
  (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
removedSubs :: TMap
  (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
removedSubs,
        TMap (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
$sel:clientNotices:AgentClient :: TMap (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
clientNotices :: TMap (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
clientNotices,
        TMVar ()
$sel:clientNoticesLock:AgentClient :: TMVar ()
clientNoticesLock :: TMVar ()
clientNoticesLock,
        TVar Int
$sel:workerSeq:AgentClient :: TVar Int
workerSeq :: TVar Int
workerSeq,
        TMap SndQAddr (Worker, TMVar ())
$sel:smpDeliveryWorkers:AgentClient :: TMap SndQAddr (Worker, TMVar ())
smpDeliveryWorkers :: TMap SndQAddr (Worker, TMVar ())
smpDeliveryWorkers,
        TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
$sel:asyncCmdWorkers:AgentClient :: TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
asyncCmdWorkers :: TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
asyncCmdWorkers,
        TVar AgentOpState
$sel:ntfNetworkOp:AgentClient :: TVar AgentOpState
ntfNetworkOp :: TVar AgentOpState
ntfNetworkOp,
        TVar AgentOpState
$sel:rcvNetworkOp:AgentClient :: TVar AgentOpState
rcvNetworkOp :: TVar AgentOpState
rcvNetworkOp,
        TVar AgentOpState
$sel:msgDeliveryOp:AgentClient :: TVar AgentOpState
msgDeliveryOp :: TVar AgentOpState
msgDeliveryOp,
        TVar AgentOpState
$sel:sndNetworkOp:AgentClient :: TVar AgentOpState
sndNetworkOp :: TVar AgentOpState
sndNetworkOp,
        TVar AgentOpState
$sel:databaseOp:AgentClient :: TVar AgentOpState
databaseOp :: TVar AgentOpState
databaseOp,
        TVar AgentState
$sel:agentState:AgentClient :: TVar AgentState
agentState :: TVar AgentState
agentState,
        TMap SndQAddr (TMVar ())
$sel:getMsgLocks:AgentClient :: TMap SndQAddr (TMVar ())
getMsgLocks :: TMap SndQAddr (TMVar ())
getMsgLocks,
        TMap ByteString Lock
$sel:connLocks:AgentClient :: TMap ByteString Lock
connLocks :: TMap ByteString Lock
connLocks,
        TMap ByteString Lock
$sel:invLocks:AgentClient :: TMap ByteString Lock
invLocks :: TMap ByteString Lock
invLocks,
        Lock
$sel:deleteLock:AgentClient :: Lock
deleteLock :: Lock
deleteLock,
        TMap SMPTransportSession (SessionVar (Async ()))
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
$sel:smpSubWorkers:AgentClient :: TMap SMPTransportSession (SessionVar (Async ()))
smpSubWorkers :: TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
smpSubWorkers,
        Int
$sel:clientId:AgentClient :: Int
clientId :: Int
clientId,
        Env
$sel:agentEnv:AgentClient :: Env
agentEnv :: Env
agentEnv,
        TVar UTCTime
$sel:proxySessTs:AgentClient :: TVar UTCTime
proxySessTs :: TVar UTCTime
proxySessTs,
        TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
$sel:smpServersStats:AgentClient :: TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
smpServersStats :: TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
smpServersStats,
        TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
$sel:xftpServersStats:AgentClient :: TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
xftpServersStats :: TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
xftpServersStats,
        TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
$sel:ntfServersStats:AgentClient :: TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
ntfServersStats :: TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
ntfServersStats,
        TVar UTCTime
$sel:srvStatsStartedAt:AgentClient :: TVar UTCTime
srvStatsStartedAt :: TVar UTCTime
srvStatsStartedAt
      }

slowNetworkConfig :: NetworkConfig -> NetworkConfig
slowNetworkConfig :: NetworkConfig -> NetworkConfig
slowNetworkConfig cfg :: NetworkConfig
cfg@NetworkConfig {NetworkTimeout
tcpConnectTimeout :: NetworkTimeout
$sel:tcpConnectTimeout:NetworkConfig :: NetworkConfig -> NetworkTimeout
tcpConnectTimeout, NetworkTimeout
tcpTimeout :: NetworkTimeout
$sel:tcpTimeout:NetworkConfig :: NetworkConfig -> NetworkTimeout
tcpTimeout, UserId
tcpTimeoutPerKb :: UserId
$sel:tcpTimeoutPerKb:NetworkConfig :: NetworkConfig -> UserId
tcpTimeoutPerKb} =
  NetworkConfig
cfg {tcpConnectTimeout = slowTimeout tcpConnectTimeout, tcpTimeout = slowTimeout tcpTimeout, tcpTimeoutPerKb = slow tcpTimeoutPerKb}
  where
    slowTimeout :: NetworkTimeout -> NetworkTimeout
slowTimeout (NetworkTimeout Int
t1 Int
t2) =  Int -> Int -> NetworkTimeout
NetworkTimeout (Int -> Int
forall a. Integral a => a -> a
slow Int
t1) (Int -> Int
forall a. Integral a => a -> a
slow Int
t2)
    slow :: Integral a => a -> a
    slow :: forall a. Integral a => a -> a
slow a
t = (a
t a -> a -> a
forall a. Num a => a -> a -> a
* a
3) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
2

agentClientStore :: AgentClient -> DBStore
agentClientStore :: AgentClient -> DBStore
agentClientStore AgentClient {$sel:agentEnv:AgentClient :: AgentClient -> Env
agentEnv = Env {DBStore
store :: DBStore
$sel:store:Env :: Env -> DBStore
store}} = DBStore
store
{-# INLINE agentClientStore #-}

agentDRG :: AgentClient -> TVar ChaChaDRG
agentDRG :: AgentClient -> TVar ChaChaDRG
agentDRG AgentClient {$sel:agentEnv:AgentClient :: AgentClient -> Env
agentEnv = Env {TVar ChaChaDRG
random :: TVar ChaChaDRG
$sel:random:Env :: Env -> TVar ChaChaDRG
random}} = TVar ChaChaDRG
random
{-# INLINE agentDRG #-}

class (Encoding err, Show err) => ProtocolServerClient v err msg | msg -> v, msg -> err where
  type Client msg = c | c -> msg
  getProtocolServerClient :: AgentClient -> NetworkRequestMode -> TransportSession msg -> AM (Client msg)
  type ProtoClient msg = c | c -> msg
  protocolClient :: Client msg -> ProtoClient msg
  clientProtocolError :: HostName -> err -> AgentErrorType
  closeProtocolServerClient :: ProtoClient msg -> IO ()
  clientServer :: ProtoClient msg -> String
  clientTransportHost :: ProtoClient msg -> TransportHost

instance ProtocolServerClient SMPVersion ErrorType BrokerMsg where
  type Client BrokerMsg = SMPConnectedClient
  getProtocolServerClient :: AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> AM (Client BrokerMsg)
getProtocolServerClient = AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> AM (Client BrokerMsg)
AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> AM SMPConnectedClient
getSMPServerClient
  type ProtoClient BrokerMsg = ProtocolClient SMPVersion ErrorType BrokerMsg
  protocolClient :: Client BrokerMsg -> ProtoClient BrokerMsg
protocolClient = Client BrokerMsg -> ProtoClient BrokerMsg
SMPConnectedClient -> SMPClient
connectedClient
  clientProtocolError :: String -> ErrorType -> AgentErrorType
clientProtocolError = String -> ErrorType -> AgentErrorType
SMP
  closeProtocolServerClient :: ProtoClient BrokerMsg -> IO ()
closeProtocolServerClient = SMPClient -> IO ()
ProtoClient BrokerMsg -> IO ()
forall v err msg. ProtocolClient v err msg -> IO ()
closeProtocolClient
  clientServer :: ProtoClient BrokerMsg -> String
clientServer = SMPClient -> String
ProtoClient BrokerMsg -> String
forall msg v err.
ProtocolTypeI (ProtoType msg) =>
ProtocolClient v err msg -> String
protocolClientServer
  clientTransportHost :: ProtoClient BrokerMsg -> TransportHost
clientTransportHost = SMPClient -> TransportHost
ProtoClient BrokerMsg -> TransportHost
forall v err msg. ProtocolClient v err msg -> TransportHost
transportHost'

instance ProtocolServerClient NTFVersion ErrorType NtfResponse where
  type Client NtfResponse = ProtocolClient NTFVersion ErrorType NtfResponse
  getProtocolServerClient :: AgentClient
-> NetworkRequestMode
-> NtfTransportSession
-> AM (Client NtfResponse)
getProtocolServerClient = AgentClient
-> NetworkRequestMode
-> NtfTransportSession
-> AM (ProtocolClient NTFVersion ErrorType NtfResponse)
AgentClient
-> NetworkRequestMode
-> NtfTransportSession
-> AM (Client NtfResponse)
getNtfServerClient
  type ProtoClient NtfResponse = ProtocolClient NTFVersion ErrorType NtfResponse
  protocolClient :: Client NtfResponse -> ProtoClient NtfResponse
protocolClient = ProtocolClient NTFVersion ErrorType NtfResponse
-> ProtocolClient NTFVersion ErrorType NtfResponse
Client NtfResponse -> ProtoClient NtfResponse
forall a. a -> a
id
  clientProtocolError :: String -> ErrorType -> AgentErrorType
clientProtocolError = String -> ErrorType -> AgentErrorType
NTF
  closeProtocolServerClient :: ProtoClient NtfResponse -> IO ()
closeProtocolServerClient = ProtocolClient NTFVersion ErrorType NtfResponse -> IO ()
ProtoClient NtfResponse -> IO ()
forall v err msg. ProtocolClient v err msg -> IO ()
closeProtocolClient
  clientServer :: ProtoClient NtfResponse -> String
clientServer = ProtocolClient NTFVersion ErrorType NtfResponse -> String
ProtoClient NtfResponse -> String
forall msg v err.
ProtocolTypeI (ProtoType msg) =>
ProtocolClient v err msg -> String
protocolClientServer
  clientTransportHost :: ProtoClient NtfResponse -> TransportHost
clientTransportHost = ProtocolClient NTFVersion ErrorType NtfResponse -> TransportHost
ProtoClient NtfResponse -> TransportHost
forall v err msg. ProtocolClient v err msg -> TransportHost
transportHost'

instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where
  type Client FileResponse = XFTPClient
  getProtocolServerClient :: AgentClient
-> NetworkRequestMode
-> XFTPTransportSession
-> AM (Client FileResponse)
getProtocolServerClient AgentClient
c NetworkRequestMode
_ = AgentClient -> XFTPTransportSession -> AM XFTPClient
getXFTPServerClient AgentClient
c
  type ProtoClient FileResponse = XFTPClient
  protocolClient :: Client FileResponse -> ProtoClient FileResponse
protocolClient = XFTPClient -> XFTPClient
Client FileResponse -> ProtoClient FileResponse
forall a. a -> a
id
  clientProtocolError :: String -> XFTPErrorType -> AgentErrorType
clientProtocolError = String -> XFTPErrorType -> AgentErrorType
XFTP
  closeProtocolServerClient :: ProtoClient FileResponse -> IO ()
closeProtocolServerClient = XFTPClient -> IO ()
ProtoClient FileResponse -> IO ()
X.closeXFTPClient
  clientServer :: ProtoClient FileResponse -> String
clientServer = XFTPClient -> String
ProtoClient FileResponse -> String
X.xftpClientServer
  clientTransportHost :: ProtoClient FileResponse -> TransportHost
clientTransportHost = XFTPClient -> TransportHost
ProtoClient FileResponse -> TransportHost
X.xftpTransportHost

getSMPServerClient :: AgentClient -> NetworkRequestMode -> SMPTransportSession -> AM SMPConnectedClient
getSMPServerClient :: AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> AM SMPConnectedClient
getSMPServerClient c :: AgentClient
c@AgentClient {TVar Bool
$sel:active:AgentClient :: AgentClient -> TVar Bool
active :: TVar Bool
active, TMap SMPTransportSession SMPClientVar
$sel:smpClients:AgentClient :: AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients :: TMap SMPTransportSession SMPClientVar
smpClients, TVar Int
$sel:workerSeq:AgentClient :: AgentClient -> TVar Int
workerSeq :: TVar Int
workerSeq} NetworkRequestMode
nm SMPTransportSession
tSess = do
  ExceptT AgentErrorType (ReaderT Env IO) Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (TVar Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
active) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
INACTIVE
  UTCTime
ts <- IO UTCTime -> ExceptT AgentErrorType (ReaderT Env IO) UTCTime
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  STM
  (Either
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar Int
-> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> UTCTime
-> STM
     (Either
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall k a.
Ord k =>
TVar Int
-> k
-> TMap k (SessionVar a)
-> UTCTime
-> STM (Either (SessionVar a) (SessionVar a))
getSessVar TVar Int
workerSeq SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess TMap SMPTransportSession SMPClientVar
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
smpClients UTCTime
ts)
    ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Either
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> (Either
      (SessionVar
         (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
      (SessionVar
         (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
    -> AM SMPConnectedClient)
-> AM SMPConnectedClient
forall a b.
ExceptT AgentErrorType (ReaderT Env IO) a
-> (a -> ExceptT AgentErrorType (ReaderT Env IO) b)
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SessionVar
   (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
 -> AM SMPConnectedClient)
-> (SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
    -> AM SMPConnectedClient)
-> Either
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> AM SMPConnectedClient
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SessionVar
  (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> AM SMPConnectedClient
newClient (AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> TMap SMPTransportSession SMPClientVar
-> SMPClientVar
-> AM (Client BrokerMsg)
forall msg v err.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> TMap (TransportSession msg) (ClientVar msg)
-> ClientVar msg
-> AM (Client msg)
waitForProtocolClient AgentClient
c NetworkRequestMode
nm SMPTransportSession
tSess TMap SMPTransportSession SMPClientVar
smpClients)
  where
    newClient :: SessionVar
  (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> AM SMPConnectedClient
newClient SessionVar
  (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
v = do
      TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs <- IO (TMap (ProtocolServer 'PSMP) ProxiedRelayVar)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (TMap (ProtocolServer 'PSMP) ProxiedRelayVar)
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TMap (ProtocolServer 'PSMP) ProxiedRelayVar)
forall k a. IO (TMap k a)
TM.emptyIO
      AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> TMap (ProtocolServer 'PSMP) ProxiedRelayVar
-> SMPClientVar
-> AM SMPConnectedClient
smpConnectClient AgentClient
c NetworkRequestMode
nm SMPTransportSession
tSess TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs SMPClientVar
SessionVar
  (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
v

getSMPProxyClient :: AgentClient -> NetworkRequestMode -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
getSMPProxyClient :: AgentClient
-> NetworkRequestMode
-> Maybe SMPServerWithAuth
-> SMPTransportSession
-> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
getSMPProxyClient c :: AgentClient
c@AgentClient {TVar Bool
$sel:active:AgentClient :: AgentClient -> TVar Bool
active :: TVar Bool
active, TMap SMPTransportSession SMPClientVar
$sel:smpClients:AgentClient :: AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients :: TMap SMPTransportSession SMPClientVar
smpClients, TMap SMPTransportSession SMPServerWithAuth
$sel:smpProxiedRelays:AgentClient :: AgentClient -> TMap SMPTransportSession SMPServerWithAuth
smpProxiedRelays :: TMap SMPTransportSession SMPServerWithAuth
smpProxiedRelays, TVar Int
$sel:workerSeq:AgentClient :: AgentClient -> TVar Int
workerSeq :: TVar Int
workerSeq} NetworkRequestMode
nm Maybe SMPServerWithAuth
proxySrv_ destSess :: SMPTransportSession
destSess@(UserId
userId, ProtoServer BrokerMsg
destSrv, Maybe ByteString
qId) = do
  ExceptT AgentErrorType (ReaderT Env IO) Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (TVar Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
active) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
INACTIVE
  SMPServerWithAuth
proxySrv <- ExceptT AgentErrorType (ReaderT Env IO) SMPServerWithAuth
-> (SMPServerWithAuth
    -> ExceptT AgentErrorType (ReaderT Env IO) SMPServerWithAuth)
-> Maybe SMPServerWithAuth
-> ExceptT AgentErrorType (ReaderT Env IO) SMPServerWithAuth
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AgentClient
-> UserId
-> (UserServers 'PSMP
    -> NonEmpty (Maybe UserId, SMPServerWithAuth))
-> [ProtocolServer 'PSMP]
-> ExceptT AgentErrorType (ReaderT Env IO) SMPServerWithAuth
forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
AgentClient
-> UserId
-> (UserServers p
    -> NonEmpty (Maybe UserId, ProtoServerWithAuth p))
-> [ProtocolServer p]
-> AM (ProtoServerWithAuth p)
getNextServer AgentClient
c UserId
userId UserServers 'PSMP -> NonEmpty (Maybe UserId, SMPServerWithAuth)
forall (p :: ProtocolType).
UserServers p -> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
proxySrvs [Item [ProtocolServer 'PSMP]
ProtoServer BrokerMsg
destSrv]) SMPServerWithAuth
-> ExceptT AgentErrorType (ReaderT Env IO) SMPServerWithAuth
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SMPServerWithAuth
proxySrv_
  UTCTime
ts <- IO UTCTime -> ExceptT AgentErrorType (ReaderT Env IO) UTCTime
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  STM
  ((UserId, ProtocolServer 'PSMP, Maybe ByteString), Maybe BasicAuth,
   Either
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     ((UserId, ProtocolServer 'PSMP, Maybe ByteString), Maybe BasicAuth,
      Either
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (SMPServerWithAuth
-> UTCTime
-> STM
     (SMPTransportSession, Maybe BasicAuth,
      Either SMPClientVar SMPClientVar)
getClientVar SMPServerWithAuth
proxySrv UTCTime
ts) ExceptT
  AgentErrorType
  (ReaderT Env IO)
  ((UserId, ProtocolServer 'PSMP, Maybe ByteString), Maybe BasicAuth,
   Either
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> (((UserId, ProtocolServer 'PSMP, Maybe ByteString),
     Maybe BasicAuth,
     Either
       (SessionVar
          (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
       (SessionVar
          (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
    -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay))
-> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
forall a b.
ExceptT AgentErrorType (ReaderT Env IO) a
-> (a -> ExceptT AgentErrorType (ReaderT Env IO) b)
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \((UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess, Maybe BasicAuth
auth, Either
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
v) ->
    (SessionVar
   (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
 -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay))
-> (SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
    -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay))
-> Either
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (SMPTransportSession
-> Maybe BasicAuth
-> UTCTime
-> SMPClientVar
-> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
newProxyClient SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess Maybe BasicAuth
auth UTCTime
ts) (SMPTransportSession
-> Maybe BasicAuth
-> SMPClientVar
-> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
waitForProxyClient SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess Maybe BasicAuth
auth) Either
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
v
  where
    getClientVar :: SMPServerWithAuth -> UTCTime -> STM (SMPTransportSession, Maybe SMP.BasicAuth, Either SMPClientVar SMPClientVar)
    getClientVar :: SMPServerWithAuth
-> UTCTime
-> STM
     (SMPTransportSession, Maybe BasicAuth,
      Either SMPClientVar SMPClientVar)
getClientVar SMPServerWithAuth
proxySrv UTCTime
ts = do
      ProtoServerWithAuth ProtocolServer 'PSMP
srv Maybe BasicAuth
auth <- (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
-> STM (Maybe SMPServerWithAuth)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
destSess TMap SMPTransportSession SMPServerWithAuth
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
smpProxiedRelays STM (Maybe SMPServerWithAuth)
-> (Maybe SMPServerWithAuth -> STM SMPServerWithAuth)
-> STM SMPServerWithAuth
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM SMPServerWithAuth
-> (SMPServerWithAuth -> STM SMPServerWithAuth)
-> Maybe SMPServerWithAuth
-> STM SMPServerWithAuth
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> SMPServerWithAuth
-> TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
-> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
destSess SMPServerWithAuth
proxySrv TMap SMPTransportSession SMPServerWithAuth
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
smpProxiedRelays STM () -> SMPServerWithAuth -> STM SMPServerWithAuth
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SMPServerWithAuth
proxySrv) SMPServerWithAuth -> STM SMPServerWithAuth
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      let tSess :: (UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess = (UserId
userId, ProtocolServer 'PSMP
srv, Maybe ByteString
qId)
      ((UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess,Maybe BasicAuth
auth,) (Either
   (SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
   (SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
 -> ((UserId, ProtocolServer 'PSMP, Maybe ByteString),
     Maybe BasicAuth,
     Either
       (SessionVar
          (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
       (SessionVar
          (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))))
-> STM
     (Either
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> STM
     ((UserId, ProtocolServer 'PSMP, Maybe ByteString), Maybe BasicAuth,
      Either
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Int
-> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> UTCTime
-> STM
     (Either
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall k a.
Ord k =>
TVar Int
-> k
-> TMap k (SessionVar a)
-> UTCTime
-> STM (Either (SessionVar a) (SessionVar a))
getSessVar TVar Int
workerSeq (UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess TMap SMPTransportSession SMPClientVar
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
smpClients UTCTime
ts
    newProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> UTCTime -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
    newProxyClient :: SMPTransportSession
-> Maybe BasicAuth
-> UTCTime
-> SMPClientVar
-> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
newProxyClient SMPTransportSession
tSess Maybe BasicAuth
auth UTCTime
ts SMPClientVar
v = do
      TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs <- IO (TMap (ProtocolServer 'PSMP) ProxiedRelayVar)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (TMap (ProtocolServer 'PSMP) ProxiedRelayVar)
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TMap (ProtocolServer 'PSMP) ProxiedRelayVar)
forall k a. IO (TMap k a)
TM.emptyIO
      -- we do not need to check if it is a new proxied relay session,
      -- as the client is just created and there are no sessions yet
      ProxiedRelayVar
rv <- STM ProxiedRelayVar
-> ExceptT AgentErrorType (ReaderT Env IO) ProxiedRelayVar
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ProxiedRelayVar
 -> ExceptT AgentErrorType (ReaderT Env IO) ProxiedRelayVar)
-> STM ProxiedRelayVar
-> ExceptT AgentErrorType (ReaderT Env IO) ProxiedRelayVar
forall a b. (a -> b) -> a -> b
$ (ProxiedRelayVar -> ProxiedRelayVar)
-> (ProxiedRelayVar -> ProxiedRelayVar)
-> Either ProxiedRelayVar ProxiedRelayVar
-> ProxiedRelayVar
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProxiedRelayVar -> ProxiedRelayVar
forall a. a -> a
id ProxiedRelayVar -> ProxiedRelayVar
forall a. a -> a
id (Either ProxiedRelayVar ProxiedRelayVar -> ProxiedRelayVar)
-> STM (Either ProxiedRelayVar ProxiedRelayVar)
-> STM ProxiedRelayVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Int
-> ProtocolServer 'PSMP
-> TMap (ProtocolServer 'PSMP) ProxiedRelayVar
-> UTCTime
-> STM (Either ProxiedRelayVar ProxiedRelayVar)
forall k a.
Ord k =>
TVar Int
-> k
-> TMap k (SessionVar a)
-> UTCTime
-> STM (Either (SessionVar a) (SessionVar a))
getSessVar TVar Int
workerSeq ProtoServer BrokerMsg
ProtocolServer 'PSMP
destSrv TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs UTCTime
ts
      SMPConnectedClient
clnt <- AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> TMap (ProtocolServer 'PSMP) ProxiedRelayVar
-> SMPClientVar
-> AM SMPConnectedClient
smpConnectClient AgentClient
c NetworkRequestMode
nm SMPTransportSession
tSess TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs SMPClientVar
v
      (SMPConnectedClient
clnt,) (Either AgentErrorType ProxiedRelay
 -> (SMPConnectedClient, Either AgentErrorType ProxiedRelay))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
-> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPConnectedClient
-> Maybe BasicAuth
-> ProxiedRelayVar
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
newProxiedRelay SMPConnectedClient
clnt Maybe BasicAuth
auth ProxiedRelayVar
rv
    waitForProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
    waitForProxyClient :: SMPTransportSession
-> Maybe BasicAuth
-> SMPClientVar
-> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
waitForProxyClient SMPTransportSession
tSess Maybe BasicAuth
auth SMPClientVar
v = do
      clnt :: SMPConnectedClient
clnt@(SMPConnectedClient SMPClient
_ TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs) <- AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> TMap SMPTransportSession SMPClientVar
-> SMPClientVar
-> AM (Client BrokerMsg)
forall msg v err.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> TMap (TransportSession msg) (ClientVar msg)
-> ClientVar msg
-> AM (Client msg)
waitForProtocolClient AgentClient
c NetworkRequestMode
nm SMPTransportSession
tSess TMap SMPTransportSession SMPClientVar
smpClients SMPClientVar
v
      UTCTime
ts <- IO UTCTime -> ExceptT AgentErrorType (ReaderT Env IO) UTCTime
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      Either AgentErrorType ProxiedRelay
sess <-
        STM (Either ProxiedRelayVar ProxiedRelayVar)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either ProxiedRelayVar ProxiedRelayVar)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar Int
-> ProtocolServer 'PSMP
-> TMap (ProtocolServer 'PSMP) ProxiedRelayVar
-> UTCTime
-> STM (Either ProxiedRelayVar ProxiedRelayVar)
forall k a.
Ord k =>
TVar Int
-> k
-> TMap k (SessionVar a)
-> UTCTime
-> STM (Either (SessionVar a) (SessionVar a))
getSessVar TVar Int
workerSeq ProtoServer BrokerMsg
ProtocolServer 'PSMP
destSrv TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs UTCTime
ts)
          ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Either ProxiedRelayVar ProxiedRelayVar)
-> (Either ProxiedRelayVar ProxiedRelayVar
    -> ExceptT
         AgentErrorType
         (ReaderT Env IO)
         (Either AgentErrorType ProxiedRelay))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
forall a b.
ExceptT AgentErrorType (ReaderT Env IO) a
-> (a -> ExceptT AgentErrorType (ReaderT Env IO) b)
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ProxiedRelayVar
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (Either AgentErrorType ProxiedRelay))
-> (ProxiedRelayVar
    -> ExceptT
         AgentErrorType
         (ReaderT Env IO)
         (Either AgentErrorType ProxiedRelay))
-> Either ProxiedRelayVar ProxiedRelayVar
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (SMPConnectedClient
-> Maybe BasicAuth
-> ProxiedRelayVar
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
newProxiedRelay SMPConnectedClient
clnt Maybe BasicAuth
auth) (SMPTransportSession
-> ProxiedRelayVar
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
waitForProxiedRelay SMPTransportSession
tSess)
      (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
-> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SMPConnectedClient
clnt, Either AgentErrorType ProxiedRelay
sess)
    newProxiedRelay :: SMPConnectedClient -> Maybe SMP.BasicAuth -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay)
    newProxiedRelay :: SMPConnectedClient
-> Maybe BasicAuth
-> ProxiedRelayVar
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
newProxiedRelay (SMPConnectedClient SMPClient
smp TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs) Maybe BasicAuth
proxyAuth ProxiedRelayVar
rv =
      ExceptT AgentErrorType (ReaderT Env IO) ProxiedRelay
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors ((String -> ErrorType -> AgentErrorType)
-> String
-> ExceptT SMPClientError IO ProxiedRelay
-> ExceptT AgentErrorType (ReaderT Env IO) ProxiedRelay
forall err a.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ExceptT (ProtocolClientError err) IO a -> AM a
liftClient String -> ErrorType -> AgentErrorType
SMP (ProtoClient BrokerMsg -> String
forall v err msg.
ProtocolServerClient v err msg =>
ProtoClient msg -> String
clientServer SMPClient
ProtoClient BrokerMsg
smp) (ExceptT SMPClientError IO ProxiedRelay
 -> ExceptT AgentErrorType (ReaderT Env IO) ProxiedRelay)
-> ExceptT SMPClientError IO ProxiedRelay
-> ExceptT AgentErrorType (ReaderT Env IO) ProxiedRelay
forall a b. (a -> b) -> a -> b
$ SMPClient
-> NetworkRequestMode
-> ProtocolServer 'PSMP
-> Maybe BasicAuth
-> ExceptT SMPClientError IO ProxiedRelay
connectSMPProxiedRelay SMPClient
smp NetworkRequestMode
nm ProtoServer BrokerMsg
ProtocolServer 'PSMP
destSrv Maybe BasicAuth
proxyAuth) ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Either AgentErrorType ProxiedRelay)
-> (Either AgentErrorType ProxiedRelay
    -> ExceptT
         AgentErrorType
         (ReaderT Env IO)
         (Either AgentErrorType ProxiedRelay))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
forall a b.
ExceptT AgentErrorType (ReaderT Env IO) a
-> (a -> ExceptT AgentErrorType (ReaderT Env IO) b)
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right ProxiedRelay
sess -> do
          STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ TMVar (Either AgentErrorType ProxiedRelay)
-> Either AgentErrorType ProxiedRelay -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (ProxiedRelayVar -> TMVar (Either AgentErrorType ProxiedRelay)
forall a. SessionVar a -> TMVar a
sessionVar ProxiedRelayVar
rv) (ProxiedRelay -> Either AgentErrorType ProxiedRelay
forall a b. b -> Either a b
Right ProxiedRelay
sess)
          Either AgentErrorType ProxiedRelay
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either AgentErrorType ProxiedRelay
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (Either AgentErrorType ProxiedRelay))
-> Either AgentErrorType ProxiedRelay
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
forall a b. (a -> b) -> a -> b
$ ProxiedRelay -> Either AgentErrorType ProxiedRelay
forall a b. b -> Either a b
Right ProxiedRelay
sess
        Left AgentErrorType
e -> do
          STM (Either AgentErrorType ProxiedRelay)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either AgentErrorType ProxiedRelay)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (Either AgentErrorType ProxiedRelay))
-> STM (Either AgentErrorType ProxiedRelay)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
forall a b. (a -> b) -> a -> b
$ do
            Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AgentErrorType -> Bool
serverHostError AgentErrorType
e) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
              ProxiedRelayVar
-> ProtocolServer 'PSMP
-> TMap (ProtocolServer 'PSMP) ProxiedRelayVar
-> STM ()
forall k a.
Ord k =>
SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
removeSessVar ProxiedRelayVar
rv ProtoServer BrokerMsg
ProtocolServer 'PSMP
destSrv TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs
              (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
-> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
destSess TMap SMPTransportSession SMPServerWithAuth
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
smpProxiedRelays
            TMVar (Either AgentErrorType ProxiedRelay)
-> Either AgentErrorType ProxiedRelay -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (ProxiedRelayVar -> TMVar (Either AgentErrorType ProxiedRelay)
forall a. SessionVar a -> TMVar a
sessionVar ProxiedRelayVar
rv) (AgentErrorType -> Either AgentErrorType ProxiedRelay
forall a b. a -> Either a b
Left AgentErrorType
e)
            Either AgentErrorType ProxiedRelay
-> STM (Either AgentErrorType ProxiedRelay)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either AgentErrorType ProxiedRelay
 -> STM (Either AgentErrorType ProxiedRelay))
-> Either AgentErrorType ProxiedRelay
-> STM (Either AgentErrorType ProxiedRelay)
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> Either AgentErrorType ProxiedRelay
forall a b. a -> Either a b
Left AgentErrorType
e
    waitForProxiedRelay :: SMPTransportSession -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay)
    waitForProxiedRelay :: SMPTransportSession
-> ProxiedRelayVar
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
waitForProxiedRelay (UserId
_, ProtoServer BrokerMsg
srv, Maybe ByteString
_) ProxiedRelayVar
rv = do
      NetworkConfig {NetworkTimeout
$sel:tcpConnectTimeout:NetworkConfig :: NetworkConfig -> NetworkTimeout
tcpConnectTimeout :: NetworkTimeout
tcpConnectTimeout} <- AgentClient
-> ExceptT AgentErrorType (ReaderT Env IO) NetworkConfig
forall (m :: * -> *). MonadIO m => AgentClient -> m NetworkConfig
getNetworkConfig AgentClient
c
      Maybe (Either AgentErrorType ProxiedRelay)
sess_ <- IO (Maybe (Either AgentErrorType ProxiedRelay))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (Either AgentErrorType ProxiedRelay))
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Either AgentErrorType ProxiedRelay))
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (Maybe (Either AgentErrorType ProxiedRelay)))
-> IO (Maybe (Either AgentErrorType ProxiedRelay))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (Either AgentErrorType ProxiedRelay))
forall a b. (a -> b) -> a -> b
$ NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout
tcpConnectTimeout NetworkRequestMode
nm Int
-> IO (Either AgentErrorType ProxiedRelay)
-> IO (Maybe (Either AgentErrorType ProxiedRelay))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
`timeout` STM (Either AgentErrorType ProxiedRelay)
-> IO (Either AgentErrorType ProxiedRelay)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Either AgentErrorType ProxiedRelay)
-> STM (Either AgentErrorType ProxiedRelay)
forall a. TMVar a -> STM a
readTMVar (TMVar (Either AgentErrorType ProxiedRelay)
 -> STM (Either AgentErrorType ProxiedRelay))
-> TMVar (Either AgentErrorType ProxiedRelay)
-> STM (Either AgentErrorType ProxiedRelay)
forall a b. (a -> b) -> a -> b
$ ProxiedRelayVar -> TMVar (Either AgentErrorType ProxiedRelay)
forall a. SessionVar a -> TMVar a
sessionVar ProxiedRelayVar
rv)
      Either AgentErrorType ProxiedRelay
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either AgentErrorType ProxiedRelay
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (Either AgentErrorType ProxiedRelay))
-> Either AgentErrorType ProxiedRelay
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType ProxiedRelay)
forall a b. (a -> b) -> a -> b
$ case Maybe (Either AgentErrorType ProxiedRelay)
sess_ of
        Just (Right ProxiedRelay
sess) -> ProxiedRelay -> Either AgentErrorType ProxiedRelay
forall a b. b -> Either a b
Right ProxiedRelay
sess
        Just (Left AgentErrorType
e) -> AgentErrorType -> Either AgentErrorType ProxiedRelay
forall a b. a -> Either a b
Left AgentErrorType
e
        Maybe (Either AgentErrorType ProxiedRelay)
Nothing -> AgentErrorType -> Either AgentErrorType ProxiedRelay
forall a b. a -> Either a b
Left (AgentErrorType -> Either AgentErrorType ProxiedRelay)
-> AgentErrorType -> Either AgentErrorType ProxiedRelay
forall a b. (a -> b) -> a -> b
$ String -> BrokerErrorType -> AgentErrorType
BROKER (ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv) BrokerErrorType
TIMEOUT

smpConnectClient :: AgentClient -> NetworkRequestMode -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient
smpConnectClient :: AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> TMap (ProtocolServer 'PSMP) ProxiedRelayVar
-> SMPClientVar
-> AM SMPConnectedClient
smpConnectClient c :: AgentClient
c@AgentClient {TMap SMPTransportSession SMPClientVar
$sel:smpClients:AgentClient :: AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients :: TMap SMPTransportSession SMPClientVar
smpClients, TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
$sel:msgQ:AgentClient :: AgentClient
-> TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
msgQ, TVar UTCTime
$sel:proxySessTs:AgentClient :: AgentClient -> TVar UTCTime
proxySessTs :: TVar UTCTime
proxySessTs, [String]
$sel:presetDomains:AgentClient :: AgentClient -> [String]
presetDomains :: [String]
presetDomains} NetworkRequestMode
nm tSess :: SMPTransportSession
tSess@(UserId
_, ProtoServer BrokerMsg
srv, Maybe ByteString
_) TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs SMPClientVar
v =
  AgentClient
-> SMPTransportSession
-> TMap SMPTransportSession SMPClientVar
-> (SMPClientVar -> AM (Client BrokerMsg))
-> SMPClientVar
-> AM (Client BrokerMsg)
forall v err msg.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
AgentClient
-> TransportSession msg
-> TMap (TransportSession msg) (ClientVar msg)
-> (ClientVar msg -> AM (Client msg))
-> ClientVar msg
-> AM (Client msg)
newProtocolClient AgentClient
c SMPTransportSession
tSess TMap SMPTransportSession SMPClientVar
smpClients SMPClientVar -> AM (Client BrokerMsg)
SMPClientVar -> AM SMPConnectedClient
connectClient SMPClientVar
v
    AM SMPConnectedClient
-> (AgentErrorType -> AM SMPConnectedClient)
-> AM SMPConnectedClient
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \AgentErrorType
e -> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT AgentErrorType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (AgentClient -> SMPTransportSession -> ReaderT Env IO ()
resubscribeSMPSession AgentClient
c SMPTransportSession
tSess) ExceptT AgentErrorType (ReaderT Env IO) ()
-> AM SMPConnectedClient -> AM SMPConnectedClient
forall a b.
ExceptT AgentErrorType (ReaderT Env IO) a
-> ExceptT AgentErrorType (ReaderT Env IO) b
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AgentErrorType -> AM SMPConnectedClient
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e
  where
    connectClient :: SMPClientVar -> AM SMPConnectedClient
    connectClient :: SMPClientVar -> AM SMPConnectedClient
connectClient SMPClientVar
v' = do
      ProtocolClientConfig SMPVersion
cfg <- ReaderT Env IO (ProtocolClientConfig SMPVersion)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (ProtocolClientConfig SMPVersion)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT AgentErrorType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT Env IO (ProtocolClientConfig SMPVersion)
 -> ExceptT
      AgentErrorType (ReaderT Env IO) (ProtocolClientConfig SMPVersion))
-> ReaderT Env IO (ProtocolClientConfig SMPVersion)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (ProtocolClientConfig SMPVersion)
forall a b. (a -> b) -> a -> b
$ AgentClient
-> (AgentConfig -> ProtocolClientConfig SMPVersion)
-> ReaderT Env IO (ProtocolClientConfig SMPVersion)
forall v.
AgentClient
-> (AgentConfig -> ProtocolClientConfig v)
-> AM' (ProtocolClientConfig v)
getClientConfig AgentClient
c AgentConfig -> ProtocolClientConfig SMPVersion
smpCfg
      TVar ChaChaDRG
g <- (Env -> TVar ChaChaDRG)
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
random
      Env
env <- ExceptT AgentErrorType (ReaderT Env IO) Env
forall r (m :: * -> *). MonadReader r m => m r
ask
      (SMPClientError -> AgentErrorType)
-> ExceptT SMPClientError IO SMPConnectedClient
-> AM SMPConnectedClient
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError ((String -> ErrorType -> AgentErrorType)
-> String -> SMPClientError -> AgentErrorType
forall err.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
protocolClientError String -> ErrorType -> AgentErrorType
SMP (String -> SMPClientError -> AgentErrorType)
-> String -> SMPClientError -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv) (ExceptT SMPClientError IO SMPConnectedClient
 -> AM SMPConnectedClient)
-> ExceptT SMPClientError IO SMPConnectedClient
-> AM SMPConnectedClient
forall a b. (a -> b) -> a -> b
$ do
        UTCTime
ts <- TVar UTCTime -> ExceptT SMPClientError IO UTCTime
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar UTCTime
proxySessTs
        SMPClient
smp <- IO (Either SMPClientError SMPClient)
-> ExceptT SMPClientError IO SMPClient
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either SMPClientError SMPClient)
 -> ExceptT SMPClientError IO SMPClient)
-> IO (Either SMPClientError SMPClient)
-> ExceptT SMPClientError IO SMPClient
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> NetworkRequestMode
-> SMPTransportSession
-> ProtocolClientConfig SMPVersion
-> [String]
-> Maybe
     (TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg))
-> UTCTime
-> (SMPClient -> IO ())
-> IO (Either SMPClientError SMPClient)
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 SMPTransportSession
tSess ProtocolClientConfig SMPVersion
cfg [String]
presetDomains (TBQueue
  ((UserId, ProtocolServer 'PSMP, Maybe ByteString),
   Version SMPVersion, ByteString,
   NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg))
-> Maybe
     (TBQueue
        ((UserId, ProtocolServer 'PSMP, Maybe ByteString),
         Version SMPVersion, ByteString,
         NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg)))
forall a. a -> Maybe a
Just TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
TBQueue
  ((UserId, ProtocolServer 'PSMP, Maybe ByteString),
   Version SMPVersion, ByteString,
   NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg))
msgQ) UTCTime
ts ((SMPClient -> IO ()) -> IO (Either SMPClientError SMPClient))
-> (SMPClient -> IO ()) -> IO (Either SMPClientError SMPClient)
forall a b. (a -> b) -> a -> b
$ AgentClient
-> SMPTransportSession
-> Env
-> SMPClientVar
-> TMap (ProtocolServer 'PSMP) ProxiedRelayVar
-> SMPClient
-> IO ()
smpClientDisconnected AgentClient
c SMPTransportSession
tSess Env
env SMPClientVar
v' TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs
        STM () -> ExceptT SMPClientError IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT SMPClientError IO ())
-> STM () -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ SMPTransportSession -> ByteString -> TSessionSubs -> STM ()
SS.setSessionId SMPTransportSession
tSess (THandleParams SMPVersion 'TClient -> ByteString
forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId (THandleParams SMPVersion 'TClient -> ByteString)
-> THandleParams SMPVersion 'TClient -> ByteString
forall a b. (a -> b) -> a -> b
$ SMPClient -> THandleParams SMPVersion 'TClient
forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams SMPClient
smp) (TSessionSubs -> STM ()) -> TSessionSubs -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
        SMPConnectedClient -> ExceptT SMPClientError IO SMPConnectedClient
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPConnectedClient {$sel:connectedClient:SMPConnectedClient :: SMPClient
connectedClient = SMPClient
smp, $sel:proxiedRelays:SMPConnectedClient :: TMap (ProtocolServer 'PSMP) ProxiedRelayVar
proxiedRelays = TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs}

smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO ()
smpClientDisconnected :: AgentClient
-> SMPTransportSession
-> Env
-> SMPClientVar
-> TMap (ProtocolServer 'PSMP) ProxiedRelayVar
-> SMPClient
-> IO ()
smpClientDisconnected c :: AgentClient
c@AgentClient {TVar Bool
$sel:active:AgentClient :: AgentClient -> TVar Bool
active :: TVar Bool
active, TMap SMPTransportSession SMPClientVar
$sel:smpClients:AgentClient :: AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients :: TMap SMPTransportSession SMPClientVar
smpClients, TMap SMPTransportSession SMPServerWithAuth
$sel:smpProxiedRelays:AgentClient :: AgentClient -> TMap SMPTransportSession SMPServerWithAuth
smpProxiedRelays :: TMap SMPTransportSession SMPServerWithAuth
smpProxiedRelays} tSess :: SMPTransportSession
tSess@(UserId
userId, ProtoServer BrokerMsg
srv, Maybe ByteString
cId) Env
env SMPClientVar
v TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs SMPClient
client = do
  IO ([RcvQueueSub], [ByteString])
removeClientAndSubs IO ([RcvQueueSub], [ByteString])
-> (([RcvQueueSub], [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
>>= ([RcvQueueSub], [ByteString]) -> IO ()
serverDown
  Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> IO ()) -> (ByteString -> Text) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Agent disconnected from " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ProtocolServer 'PSMP -> ByteString
forall (s :: ProtocolType). ProtocolServer s -> ByteString
showServer ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv
  where
    -- we make active subscriptions pending only if the client for tSess was current (in the map) and active,
    -- because we can have a race condition when a new current client could have already
    -- made subscriptions active, and the old client would be processing diconnection later.
    removeClientAndSubs :: IO ([RcvQueueSub], [ConnId])
    removeClientAndSubs :: IO ([RcvQueueSub], [ByteString])
removeClientAndSubs = STM ([RcvQueueSub], [ByteString])
-> IO ([RcvQueueSub], [ByteString])
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ([RcvQueueSub], [ByteString])
 -> IO ([RcvQueueSub], [ByteString]))
-> STM ([RcvQueueSub], [ByteString])
-> IO ([RcvQueueSub], [ByteString])
forall a b. (a -> b) -> a -> b
$ do
      SessionVar
  (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> STM ()
forall k a.
Ord k =>
SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
removeSessVar SMPClientVar
SessionVar
  (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
v SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess TMap SMPTransportSession SMPClientVar
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
smpClients
      STM Bool
-> STM ([RcvQueueSub], [ByteString])
-> STM ([RcvQueueSub], [ByteString])
-> STM ([RcvQueueSub], [ByteString])
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
active) STM ([RcvQueueSub], [ByteString])
removeSubs (([RcvQueueSub], [ByteString]) -> STM ([RcvQueueSub], [ByteString])
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], []))
      where
        sessId :: ByteString
sessId = THandleParams SMPVersion 'TClient -> ByteString
forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId (THandleParams SMPVersion 'TClient -> ByteString)
-> THandleParams SMPVersion 'TClient -> ByteString
forall a b. (a -> b) -> a -> b
$ SMPClient -> THandleParams SMPVersion 'TClient
forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams SMPClient
client
        removeSubs :: STM ([RcvQueueSub], [ByteString])
removeSubs = do
          TransportSessionMode
mode <- AgentClient -> STM TransportSessionMode
getSessionMode AgentClient
c
          Map RecipientId RcvQueueSub
subs <- TransportSessionMode
-> SMPTransportSession
-> ByteString
-> TSessionSubs
-> STM (Map RecipientId RcvQueueSub)
SS.setSubsPending TransportSessionMode
mode SMPTransportSession
tSess ByteString
sessId (TSessionSubs -> STM (Map RecipientId RcvQueueSub))
-> TSessionSubs -> STM (Map RecipientId RcvQueueSub)
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
          let qs :: [RcvQueueSub]
qs = Map RecipientId RcvQueueSub -> [RcvQueueSub]
forall k a. Map k a -> [a]
M.elems Map RecipientId RcvQueueSub
subs
              cs :: [ByteString]
cs = [ByteString] -> [ByteString]
forall a. Ord a => [a] -> [a]
nubOrd ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ (RcvQueueSub -> ByteString) -> [RcvQueueSub] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map RcvQueueSub -> ByteString
forall q. SMPQueueRec q => q -> ByteString
qConnId [RcvQueueSub]
qs
          -- this removes proxied relays that this client created sessions to
          [ProtocolServer 'PSMP]
destSrvs <- Map (ProtocolServer 'PSMP) ProxiedRelayVar
-> [ProtocolServer 'PSMP]
forall k a. Map k a -> [k]
M.keys (Map (ProtocolServer 'PSMP) ProxiedRelayVar
 -> [ProtocolServer 'PSMP])
-> STM (Map (ProtocolServer 'PSMP) ProxiedRelayVar)
-> STM [ProtocolServer 'PSMP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap (ProtocolServer 'PSMP) ProxiedRelayVar
-> STM (Map (ProtocolServer 'PSMP) ProxiedRelayVar)
forall a. TVar a -> STM a
readTVar TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs
          [ProtocolServer 'PSMP]
-> (ProtocolServer 'PSMP -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ProtocolServer 'PSMP]
destSrvs ((ProtocolServer 'PSMP -> STM ()) -> STM ())
-> (ProtocolServer 'PSMP -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ProtocolServer 'PSMP
destSrv -> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
-> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete (UserId
userId, ProtocolServer 'PSMP
destSrv, Maybe ByteString
cId) TMap SMPTransportSession SMPServerWithAuth
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
smpProxiedRelays
          ([RcvQueueSub], [ByteString]) -> STM ([RcvQueueSub], [ByteString])
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([RcvQueueSub]
qs, [ByteString]
cs)

    serverDown :: ([RcvQueueSub], [ConnId]) -> IO ()
    serverDown :: ([RcvQueueSub], [ByteString]) -> IO ()
serverDown ([RcvQueueSub]
qs, [ByteString]
conns) = IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (TVar Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
active) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      AgentClient -> AEvent 'AENone -> IO ()
forall (m :: * -> *).
MonadIO m =>
AgentClient -> AEvent 'AENone -> m ()
notifySub AgentClient
c (AEvent 'AENone -> IO ()) -> AEvent 'AENone -> IO ()
forall a b. (a -> b) -> a -> b
$ (AProtocolType -> TransportHost -> AEvent 'AENone)
-> ProtoClient BrokerMsg -> AEvent 'AENone
forall v err msg.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
(AProtocolType -> TransportHost -> AEvent 'AENone)
-> ProtoClient msg -> AEvent 'AENone
hostEvent' AProtocolType -> TransportHost -> AEvent 'AENone
DISCONNECT SMPClient
ProtoClient BrokerMsg
client
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
conns) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> AEvent 'AENone -> IO ()
forall (m :: * -> *).
MonadIO m =>
AgentClient -> AEvent 'AENone -> m ()
notifySub AgentClient
c (AEvent 'AENone -> IO ()) -> AEvent 'AENone -> IO ()
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP -> [ByteString] -> AEvent 'AENone
DOWN ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv [ByteString]
conns
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([RcvQueueSub] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RcvQueueSub]
qs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        AgentClient -> [RcvQueueSub] -> IO ()
forall q. SomeRcvQueue q => AgentClient -> [q] -> IO ()
releaseGetLocksIO AgentClient
c [RcvQueueSub]
qs
        TransportSessionMode
mode <- AgentClient -> IO TransportSessionMode
forall (m :: * -> *).
MonadIO m =>
AgentClient -> m TransportSessionMode
getSessionModeIO AgentClient
c
        let resubscribe :: ReaderT Env IO ()
resubscribe
              | (TransportSessionMode
mode TransportSessionMode -> TransportSessionMode -> Bool
forall a. Eq a => a -> a -> Bool
== TransportSessionMode
TSMEntity) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
cId = AgentClient -> SMPTransportSession -> ReaderT Env IO ()
resubscribeSMPSession AgentClient
c SMPTransportSession
tSess
              | Bool
otherwise = ReaderT
  Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
-> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT
   Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
 -> ReaderT Env IO ())
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
-> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> Bool
-> [RcvQueueSub]
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
subscribeQueues AgentClient
c Bool
True [RcvQueueSub]
qs
        ReaderT Env IO () -> Env -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Env IO ()
resubscribe Env
env

resubscribeSMPSession :: AgentClient -> SMPTransportSession -> AM' ()
resubscribeSMPSession :: AgentClient -> SMPTransportSession -> ReaderT Env IO ()
resubscribeSMPSession c :: AgentClient
c@AgentClient {TMap SMPTransportSession (SessionVar (Async ()))
$sel:smpSubWorkers:AgentClient :: AgentClient -> TMap SMPTransportSession (SessionVar (Async ()))
smpSubWorkers :: TMap SMPTransportSession (SessionVar (Async ()))
smpSubWorkers, TVar Int
$sel:workerSeq:AgentClient :: AgentClient -> TVar Int
workerSeq :: TVar Int
workerSeq} SMPTransportSession
tSess = do
  UTCTime
ts <- IO UTCTime -> ReaderT Env IO UTCTime
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  STM
  (Maybe (Either (SessionVar (Async ())) (SessionVar (Async ()))))
-> ReaderT
     Env
     IO
     (Maybe (Either (SessionVar (Async ())) (SessionVar (Async ()))))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (UTCTime
-> STM
     (Maybe (Either (SessionVar (Async ())) (SessionVar (Async ()))))
getWorkerVar UTCTime
ts) ReaderT
  Env
  IO
  (Maybe (Either (SessionVar (Async ())) (SessionVar (Async ()))))
-> (Maybe (Either (SessionVar (Async ())) (SessionVar (Async ())))
    -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall a b.
ReaderT Env IO a -> (a -> ReaderT Env IO b) -> ReaderT Env IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either (SessionVar (Async ())) (SessionVar (Async ()))
 -> ReaderT Env IO ())
-> Maybe (Either (SessionVar (Async ())) (SessionVar (Async ())))
-> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((SessionVar (Async ()) -> ReaderT Env IO ())
-> (SessionVar (Async ()) -> ReaderT Env IO ())
-> Either (SessionVar (Async ())) (SessionVar (Async ()))
-> ReaderT Env IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SessionVar (Async ()) -> ReaderT Env IO ()
newSubWorker (\SessionVar (Async ())
_ -> () -> ReaderT Env IO ()
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
  where
    getWorkerVar :: UTCTime
-> STM
     (Maybe (Either (SessionVar (Async ())) (SessionVar (Async ()))))
getWorkerVar UTCTime
ts =
      STM Bool
-> STM
     (Maybe (Either (SessionVar (Async ())) (SessionVar (Async ()))))
-> STM
     (Maybe (Either (SessionVar (Async ())) (SessionVar (Async ()))))
-> STM
     (Maybe (Either (SessionVar (Async ())) (SessionVar (Async ()))))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
        (Bool -> Bool
not (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPTransportSession -> TSessionSubs -> STM Bool
SS.hasPendingSubs SMPTransportSession
tSess (AgentClient -> TSessionSubs
currentSubs AgentClient
c))
        (Maybe (Either (SessionVar (Async ())) (SessionVar (Async ())))
-> STM
     (Maybe (Either (SessionVar (Async ())) (SessionVar (Async ()))))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either (SessionVar (Async ())) (SessionVar (Async ())))
forall a. Maybe a
Nothing) -- prevent race with cleanup and adding pending queues in another call
        (Either (SessionVar (Async ())) (SessionVar (Async ()))
-> Maybe (Either (SessionVar (Async ())) (SessionVar (Async ())))
forall a. a -> Maybe a
Just (Either (SessionVar (Async ())) (SessionVar (Async ()))
 -> Maybe (Either (SessionVar (Async ())) (SessionVar (Async ()))))
-> STM (Either (SessionVar (Async ())) (SessionVar (Async ())))
-> STM
     (Maybe (Either (SessionVar (Async ())) (SessionVar (Async ()))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Int
-> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar (Async ()))
-> UTCTime
-> STM (Either (SessionVar (Async ())) (SessionVar (Async ())))
forall k a.
Ord k =>
TVar Int
-> k
-> TMap k (SessionVar a)
-> UTCTime
-> STM (Either (SessionVar a) (SessionVar a))
getSessVar TVar Int
workerSeq SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess TMap SMPTransportSession (SessionVar (Async ()))
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
smpSubWorkers UTCTime
ts)
    newSubWorker :: SessionVar (Async ()) -> ReaderT Env IO ()
newSubWorker SessionVar (Async ())
v = do
      Async ()
a <- ReaderT Env IO () -> ReaderT Env IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (ReaderT Env IO () -> ReaderT Env IO (Async ()))
-> ReaderT Env IO () -> ReaderT Env IO (Async ())
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO (Either SomeException ()) -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Env IO (Either SomeException ()) -> ReaderT Env IO ())
-> ReaderT Env IO (Either SomeException ()) -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO () -> ReaderT Env IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
E.tryAny (ReaderT Env IO () -> ReaderT Env IO (Either SomeException ()))
-> ReaderT Env IO () -> ReaderT Env IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ SessionVar (Async ()) -> ReaderT Env IO ()
runSubWorker SessionVar (Async ())
v
      STM () -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Env IO ()) -> STM () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Async ()) -> Async () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (SessionVar (Async ()) -> TMVar (Async ())
forall a. SessionVar a -> TMVar a
sessionVar SessionVar (Async ())
v) Async ()
a
    runSubWorker :: SessionVar (Async ()) -> ReaderT Env IO ()
runSubWorker SessionVar (Async ())
v = do
      RetryInterval
ri <- (Env -> RetryInterval) -> ReaderT Env IO RetryInterval
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> RetryInterval) -> ReaderT Env IO RetryInterval)
-> (Env -> RetryInterval) -> ReaderT Env IO RetryInterval
forall a b. (a -> b) -> a -> b
$ AgentConfig -> RetryInterval
reconnectInterval (AgentConfig -> RetryInterval)
-> (Env -> AgentConfig) -> Env -> RetryInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
      RetryInterval
-> STM Bool
-> STM Bool
-> (UserId -> ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall (m :: * -> *) a.
MonadIO m =>
RetryInterval
-> STM Bool -> STM Bool -> (UserId -> m a -> m a) -> m a
withRetryForeground RetryInterval
ri STM Bool
isForeground (AgentClient -> STM Bool
isNetworkOnline AgentClient
c) ((UserId -> ReaderT Env IO () -> ReaderT Env IO ())
 -> ReaderT Env IO ())
-> (UserId -> ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ \UserId
_ ReaderT Env IO ()
loop -> do
        Map RecipientId RcvQueueSub
pending <- STM (Map RecipientId RcvQueueSub)
-> ReaderT Env IO (Map RecipientId RcvQueueSub)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Map RecipientId RcvQueueSub)
 -> ReaderT Env IO (Map RecipientId RcvQueueSub))
-> STM (Map RecipientId RcvQueueSub)
-> ReaderT Env IO (Map RecipientId RcvQueueSub)
forall a b. (a -> b) -> a -> b
$ do
          Map RecipientId RcvQueueSub
qs <- SMPTransportSession
-> TSessionSubs -> STM (Map RecipientId RcvQueueSub)
SS.getPendingSubs SMPTransportSession
tSess (TSessionSubs -> STM (Map RecipientId RcvQueueSub))
-> TSessionSubs -> STM (Map RecipientId RcvQueueSub)
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
          Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map RecipientId RcvQueueSub -> Bool
forall k a. Map k a -> Bool
M.null Map RecipientId RcvQueueSub
qs) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ SessionVar (Async ()) -> STM ()
cleanup SessionVar (Async ())
v
          Map RecipientId RcvQueueSub -> STM (Map RecipientId RcvQueueSub)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map RecipientId RcvQueueSub
qs
        Bool -> ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Map RecipientId RcvQueueSub -> Bool
forall k a. Map k a -> Bool
M.null Map RecipientId RcvQueueSub
pending) (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ do
          IO () -> ReaderT Env IO ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Env IO ()) -> IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> IO ()
waitUntilForeground AgentClient
c
          IO () -> ReaderT Env IO ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Env IO ()) -> IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> IO ()
waitForUserNetwork AgentClient
c
          ReaderT Env IO () -> ReaderT Env IO ()
handleNotify (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> SMPTransportSession -> [RcvQueueSub] -> ReaderT Env IO ()
resubscribeSessQueues AgentClient
c SMPTransportSession
tSess ([RcvQueueSub] -> ReaderT Env IO ())
-> [RcvQueueSub] -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ Map RecipientId RcvQueueSub -> [RcvQueueSub]
forall k a. Map k a -> [a]
M.elems Map RecipientId RcvQueueSub
pending
          ReaderT Env IO ()
loop
    isForeground :: STM Bool
isForeground = (AgentState
ASForeground AgentState -> AgentState -> Bool
forall a. Eq a => a -> a -> Bool
==) (AgentState -> Bool) -> STM AgentState -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar AgentState -> STM AgentState
forall a. TVar a -> STM a
readTVar (AgentClient -> TVar AgentState
agentState AgentClient
c)
    cleanup :: SessionVar (Async ()) -> STM ()
    cleanup :: SessionVar (Async ()) -> STM ()
cleanup SessionVar (Async ())
v = do
      -- Here we wait until TMVar is not empty to prevent worker cleanup happening before worker is added to TMVar.
      -- Not waiting may result in terminated worker remaining in the map.
      STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (TMVar (Async ()) -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar (TMVar (Async ()) -> STM Bool) -> TMVar (Async ()) -> STM Bool
forall a b. (a -> b) -> a -> b
$ SessionVar (Async ()) -> TMVar (Async ())
forall a. SessionVar a -> TMVar a
sessionVar SessionVar (Async ())
v) STM ()
forall a. STM a
retry
      SessionVar (Async ())
-> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar (Async ()))
-> STM ()
forall k a.
Ord k =>
SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
removeSessVar SessionVar (Async ())
v SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess TMap SMPTransportSession (SessionVar (Async ()))
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
smpSubWorkers
    handleNotify :: AM' () -> AM' ()
    handleNotify :: ReaderT Env IO () -> ReaderT Env IO ()
handleNotify = (SomeException -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
E.handleAny ((SomeException -> ReaderT Env IO ())
 -> ReaderT Env IO () -> ReaderT Env IO ())
-> (SomeException -> ReaderT Env IO ())
-> ReaderT Env IO ()
-> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> ByteString -> AEvent 'AEConn -> ReaderT Env IO ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AgentClient -> ByteString -> AEvent e -> m ()
notifySub' AgentClient
c ByteString
"" (AEvent 'AEConn -> ReaderT Env IO ())
-> (SomeException -> AEvent 'AEConn)
-> SomeException
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> AEvent 'AEConn)
-> (SomeException -> AgentErrorType)
-> SomeException
-> AEvent 'AEConn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AgentErrorType
INTERNAL (String -> AgentErrorType)
-> (SomeException -> String) -> SomeException -> AgentErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show

notifySub' :: forall e m. (AEntityI e, MonadIO m) => AgentClient -> ConnId -> AEvent e -> m ()
notifySub' :: forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AgentClient -> ByteString -> AEvent e -> m ()
notifySub' AgentClient
c ByteString
connId AEvent e
cmd = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ TBQueue ATransmission -> ATransmission -> IO ()
forall a. TBQueue a -> a -> IO ()
nonBlockingWriteTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ByteString
B.empty, ByteString
connId, SAEntity e -> AEvent e -> AEvt
forall (e :: AEntity). AEntityI e => SAEntity e -> AEvent e -> AEvt
AEvt (forall (e :: AEntity). AEntityI e => SAEntity e
sAEntity @e) AEvent e
cmd)
{-# INLINE notifySub' #-}

notifySub :: MonadIO m => AgentClient -> AEvent 'AENone -> m ()
notifySub :: forall (m :: * -> *).
MonadIO m =>
AgentClient -> AEvent 'AENone -> m ()
notifySub AgentClient
c = AgentClient -> ByteString -> AEvent 'AENone -> m ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AgentClient -> ByteString -> AEvent e -> m ()
notifySub' AgentClient
c ByteString
""
{-# INLINE notifySub #-}

getNtfServerClient :: AgentClient -> NetworkRequestMode -> NtfTransportSession -> AM NtfClient
getNtfServerClient :: AgentClient
-> NetworkRequestMode
-> NtfTransportSession
-> AM (ProtocolClient NTFVersion ErrorType NtfResponse)
getNtfServerClient c :: AgentClient
c@AgentClient {TVar Bool
$sel:active:AgentClient :: AgentClient -> TVar Bool
active :: TVar Bool
active, TMap NtfTransportSession NtfClientVar
$sel:ntfClients:AgentClient :: AgentClient -> TMap NtfTransportSession NtfClientVar
ntfClients :: TMap NtfTransportSession NtfClientVar
ntfClients, TVar Int
$sel:workerSeq:AgentClient :: AgentClient -> TVar Int
workerSeq :: TVar Int
workerSeq, TVar UTCTime
$sel:proxySessTs:AgentClient :: AgentClient -> TVar UTCTime
proxySessTs :: TVar UTCTime
proxySessTs, [String]
$sel:presetDomains:AgentClient :: AgentClient -> [String]
presetDomains :: [String]
presetDomains} NetworkRequestMode
nm tSess :: NtfTransportSession
tSess@(UserId
_, ProtoServer NtfResponse
srv, Maybe ByteString
_) = do
  ExceptT AgentErrorType (ReaderT Env IO) Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (TVar Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
active) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
INACTIVE
  UTCTime
ts <- IO UTCTime -> ExceptT AgentErrorType (ReaderT Env IO) UTCTime
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  STM
  (Either
     (SessionVar
        (Either
           (AgentErrorType, Maybe UTCTime)
           (ProtocolClient NTFVersion ErrorType NtfResponse)))
     (SessionVar
        (Either
           (AgentErrorType, Maybe UTCTime)
           (ProtocolClient NTFVersion ErrorType NtfResponse))))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either
        (SessionVar
           (Either
              (AgentErrorType, Maybe UTCTime)
              (ProtocolClient NTFVersion ErrorType NtfResponse)))
        (SessionVar
           (Either
              (AgentErrorType, Maybe UTCTime)
              (ProtocolClient NTFVersion ErrorType NtfResponse))))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar Int
-> (UserId, ProtocolServer 'PNTF, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PNTF, Maybe ByteString)
     (SessionVar
        (Either
           (AgentErrorType, Maybe UTCTime)
           (ProtocolClient NTFVersion ErrorType NtfResponse)))
-> UTCTime
-> STM
     (Either
        (SessionVar
           (Either
              (AgentErrorType, Maybe UTCTime)
              (ProtocolClient NTFVersion ErrorType NtfResponse)))
        (SessionVar
           (Either
              (AgentErrorType, Maybe UTCTime)
              (ProtocolClient NTFVersion ErrorType NtfResponse))))
forall k a.
Ord k =>
TVar Int
-> k
-> TMap k (SessionVar a)
-> UTCTime
-> STM (Either (SessionVar a) (SessionVar a))
getSessVar TVar Int
workerSeq NtfTransportSession
(UserId, ProtocolServer 'PNTF, Maybe ByteString)
tSess TMap NtfTransportSession NtfClientVar
TMap
  (UserId, ProtocolServer 'PNTF, Maybe ByteString)
  (SessionVar
     (Either
        (AgentErrorType, Maybe UTCTime)
        (ProtocolClient NTFVersion ErrorType NtfResponse)))
ntfClients UTCTime
ts)
    ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Either
     (SessionVar
        (Either
           (AgentErrorType, Maybe UTCTime)
           (ProtocolClient NTFVersion ErrorType NtfResponse)))
     (SessionVar
        (Either
           (AgentErrorType, Maybe UTCTime)
           (ProtocolClient NTFVersion ErrorType NtfResponse))))
-> (Either
      (SessionVar
         (Either
            (AgentErrorType, Maybe UTCTime)
            (ProtocolClient NTFVersion ErrorType NtfResponse)))
      (SessionVar
         (Either
            (AgentErrorType, Maybe UTCTime)
            (ProtocolClient NTFVersion ErrorType NtfResponse)))
    -> AM (ProtocolClient NTFVersion ErrorType NtfResponse))
-> AM (ProtocolClient NTFVersion ErrorType NtfResponse)
forall a b.
ExceptT AgentErrorType (ReaderT Env IO) a
-> (a -> ExceptT AgentErrorType (ReaderT Env IO) b)
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SessionVar
   (Either
      (AgentErrorType, Maybe UTCTime)
      (ProtocolClient NTFVersion ErrorType NtfResponse))
 -> AM (ProtocolClient NTFVersion ErrorType NtfResponse))
-> (SessionVar
      (Either
         (AgentErrorType, Maybe UTCTime)
         (ProtocolClient NTFVersion ErrorType NtfResponse))
    -> AM (ProtocolClient NTFVersion ErrorType NtfResponse))
-> Either
     (SessionVar
        (Either
           (AgentErrorType, Maybe UTCTime)
           (ProtocolClient NTFVersion ErrorType NtfResponse)))
     (SessionVar
        (Either
           (AgentErrorType, Maybe UTCTime)
           (ProtocolClient NTFVersion ErrorType NtfResponse)))
-> AM (ProtocolClient NTFVersion ErrorType NtfResponse)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (AgentClient
-> NtfTransportSession
-> TMap NtfTransportSession NtfClientVar
-> (NtfClientVar -> AM (Client NtfResponse))
-> NtfClientVar
-> AM (Client NtfResponse)
forall v err msg.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
AgentClient
-> TransportSession msg
-> TMap (TransportSession msg) (ClientVar msg)
-> (ClientVar msg -> AM (Client msg))
-> ClientVar msg
-> AM (Client msg)
newProtocolClient AgentClient
c NtfTransportSession
tSess TMap NtfTransportSession NtfClientVar
ntfClients NtfClientVar
-> AM (ProtocolClient NTFVersion ErrorType NtfResponse)
NtfClientVar -> AM (Client NtfResponse)
connectClient)
      (AgentClient
-> NetworkRequestMode
-> NtfTransportSession
-> TMap NtfTransportSession NtfClientVar
-> NtfClientVar
-> AM (Client NtfResponse)
forall msg v err.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> TMap (TransportSession msg) (ClientVar msg)
-> ClientVar msg
-> AM (Client msg)
waitForProtocolClient AgentClient
c NetworkRequestMode
nm NtfTransportSession
tSess TMap NtfTransportSession NtfClientVar
ntfClients)
  where
    connectClient :: NtfClientVar -> AM NtfClient
    connectClient :: NtfClientVar
-> AM (ProtocolClient NTFVersion ErrorType NtfResponse)
connectClient NtfClientVar
v = do
      ProtocolClientConfig NTFVersion
cfg <- ReaderT Env IO (ProtocolClientConfig NTFVersion)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (ProtocolClientConfig NTFVersion)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT AgentErrorType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT Env IO (ProtocolClientConfig NTFVersion)
 -> ExceptT
      AgentErrorType (ReaderT Env IO) (ProtocolClientConfig NTFVersion))
-> ReaderT Env IO (ProtocolClientConfig NTFVersion)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (ProtocolClientConfig NTFVersion)
forall a b. (a -> b) -> a -> b
$ AgentClient
-> (AgentConfig -> ProtocolClientConfig NTFVersion)
-> ReaderT Env IO (ProtocolClientConfig NTFVersion)
forall v.
AgentClient
-> (AgentConfig -> ProtocolClientConfig v)
-> AM' (ProtocolClientConfig v)
getClientConfig AgentClient
c AgentConfig -> ProtocolClientConfig NTFVersion
ntfCfg
      TVar ChaChaDRG
g <- (Env -> TVar ChaChaDRG)
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
random
      UTCTime
ts <- TVar UTCTime -> ExceptT AgentErrorType (ReaderT Env IO) UTCTime
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar UTCTime
proxySessTs
      (SMPClientError -> AgentErrorType)
-> IO
     (Either
        SMPClientError (ProtocolClient NTFVersion ErrorType NtfResponse))
-> AM (ProtocolClient NTFVersion ErrorType NtfResponse)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> IO (Either e a) -> ExceptT e' m a
liftError' ((String -> ErrorType -> AgentErrorType)
-> String -> SMPClientError -> AgentErrorType
forall err.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
protocolClientError String -> ErrorType -> AgentErrorType
NTF (String -> SMPClientError -> AgentErrorType)
-> String -> SMPClientError -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PNTF -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtoServer NtfResponse
ProtocolServer 'PNTF
srv) (IO
   (Either
      SMPClientError (ProtocolClient NTFVersion ErrorType NtfResponse))
 -> AM (ProtocolClient NTFVersion ErrorType NtfResponse))
-> IO
     (Either
        SMPClientError (ProtocolClient NTFVersion ErrorType NtfResponse))
-> AM (ProtocolClient NTFVersion ErrorType NtfResponse)
forall a b. (a -> b) -> a -> b
$
        TVar ChaChaDRG
-> NetworkRequestMode
-> NtfTransportSession
-> ProtocolClientConfig NTFVersion
-> [String]
-> Maybe
     (TBQueue
        (ServerTransmissionBatch NTFVersion ErrorType NtfResponse))
-> UTCTime
-> (ProtocolClient NTFVersion ErrorType NtfResponse -> IO ())
-> IO
     (Either
        SMPClientError (ProtocolClient NTFVersion ErrorType NtfResponse))
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 NtfTransportSession
tSess ProtocolClientConfig NTFVersion
cfg [String]
presetDomains Maybe
  (TBQueue
     (ServerTransmissionBatch NTFVersion ErrorType NtfResponse))
Maybe
  (TBQueue
     ((UserId, ProtocolServer 'PNTF, Maybe ByteString),
      Version NTFVersion, ByteString,
      NonEmpty (RecipientId, ServerTransmission ErrorType NtfResponse)))
forall a. Maybe a
Nothing UTCTime
ts ((ProtocolClient NTFVersion ErrorType NtfResponse -> IO ())
 -> IO
      (Either
         SMPClientError (ProtocolClient NTFVersion ErrorType NtfResponse)))
-> (ProtocolClient NTFVersion ErrorType NtfResponse -> IO ())
-> IO
     (Either
        SMPClientError (ProtocolClient NTFVersion ErrorType NtfResponse))
forall a b. (a -> b) -> a -> b
$
          NtfClientVar
-> ProtocolClient NTFVersion ErrorType NtfResponse -> IO ()
clientDisconnected NtfClientVar
v

    clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
    clientDisconnected :: NtfClientVar
-> ProtocolClient NTFVersion ErrorType NtfResponse -> IO ()
clientDisconnected NtfClientVar
v ProtocolClient NTFVersion ErrorType NtfResponse
client = do
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ SessionVar
  (Either
     (AgentErrorType, Maybe UTCTime)
     (ProtocolClient NTFVersion ErrorType NtfResponse))
-> (UserId, ProtocolServer 'PNTF, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PNTF, Maybe ByteString)
     (SessionVar
        (Either
           (AgentErrorType, Maybe UTCTime)
           (ProtocolClient NTFVersion ErrorType NtfResponse)))
-> STM ()
forall k a.
Ord k =>
SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
removeSessVar SessionVar
  (Either
     (AgentErrorType, Maybe UTCTime)
     (ProtocolClient NTFVersion ErrorType NtfResponse))
NtfClientVar
v NtfTransportSession
(UserId, ProtocolServer 'PNTF, Maybe ByteString)
tSess TMap NtfTransportSession NtfClientVar
TMap
  (UserId, ProtocolServer 'PNTF, Maybe ByteString)
  (SessionVar
     (Either
        (AgentErrorType, Maybe UTCTime)
        (ProtocolClient NTFVersion ErrorType NtfResponse)))
ntfClients
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ByteString
"", ByteString
"", SAEntity 'AENone -> AEvent 'AENone -> AEvt
forall (e :: AEntity). AEntityI e => SAEntity e -> AEvent e -> AEvt
AEvt SAEntity 'AENone
SAENone (AEvent 'AENone -> AEvt) -> AEvent 'AENone -> AEvt
forall a b. (a -> b) -> a -> b
$ (AProtocolType -> TransportHost -> AEvent 'AENone)
-> Client NtfResponse -> AEvent 'AENone
forall v err msg.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
(AProtocolType -> TransportHost -> AEvent 'AENone)
-> Client msg -> AEvent 'AENone
hostEvent AProtocolType -> TransportHost -> AEvent 'AENone
DISCONNECT ProtocolClient NTFVersion ErrorType NtfResponse
Client NtfResponse
client)
      Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> IO ()) -> (ByteString -> Text) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Agent disconnected from " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ProtocolServer 'PNTF -> ByteString
forall (s :: ProtocolType). ProtocolServer s -> ByteString
showServer ProtoServer NtfResponse
ProtocolServer 'PNTF
srv

getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
getXFTPServerClient c :: AgentClient
c@AgentClient {TVar Bool
$sel:active:AgentClient :: AgentClient -> TVar Bool
active :: TVar Bool
active, TMap XFTPTransportSession XFTPClientVar
$sel:xftpClients:AgentClient :: AgentClient -> TMap XFTPTransportSession XFTPClientVar
xftpClients :: TMap XFTPTransportSession XFTPClientVar
xftpClients, TVar Int
$sel:workerSeq:AgentClient :: AgentClient -> TVar Int
workerSeq :: TVar Int
workerSeq, TVar UTCTime
$sel:proxySessTs:AgentClient :: AgentClient -> TVar UTCTime
proxySessTs :: TVar UTCTime
proxySessTs, [String]
$sel:presetDomains:AgentClient :: AgentClient -> [String]
presetDomains :: [String]
presetDomains} tSess :: XFTPTransportSession
tSess@(UserId
_, ProtoServer FileResponse
srv, Maybe ByteString
_) = do
  ExceptT AgentErrorType (ReaderT Env IO) Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (TVar Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
active) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
INACTIVE
  UTCTime
ts <- IO UTCTime -> ExceptT AgentErrorType (ReaderT Env IO) UTCTime
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  STM
  (Either
     (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
     (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either
        (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
        (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar Int
-> (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
     (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
-> UTCTime
-> STM
     (Either
        (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
        (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)))
forall k a.
Ord k =>
TVar Int
-> k
-> TMap k (SessionVar a)
-> UTCTime
-> STM (Either (SessionVar a) (SessionVar a))
getSessVar TVar Int
workerSeq XFTPTransportSession
(UserId, ProtocolServer 'PXFTP, Maybe ByteString)
tSess TMap XFTPTransportSession XFTPClientVar
TMap
  (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
  (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
xftpClients UTCTime
ts)
    ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Either
     (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
     (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)))
-> (Either
      (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
      (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
    -> AM XFTPClient)
-> AM XFTPClient
forall a b.
ExceptT AgentErrorType (ReaderT Env IO) a
-> (a -> ExceptT AgentErrorType (ReaderT Env IO) b)
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)
 -> AM XFTPClient)
-> (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)
    -> AM XFTPClient)
-> Either
     (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
     (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
-> AM XFTPClient
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (AgentClient
-> XFTPTransportSession
-> TMap XFTPTransportSession XFTPClientVar
-> (XFTPClientVar -> AM (Client FileResponse))
-> XFTPClientVar
-> AM (Client FileResponse)
forall v err msg.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
AgentClient
-> TransportSession msg
-> TMap (TransportSession msg) (ClientVar msg)
-> (ClientVar msg -> AM (Client msg))
-> ClientVar msg
-> AM (Client msg)
newProtocolClient AgentClient
c XFTPTransportSession
tSess TMap XFTPTransportSession XFTPClientVar
xftpClients XFTPClientVar -> AM XFTPClient
XFTPClientVar -> AM (Client FileResponse)
connectClient)
      (AgentClient
-> NetworkRequestMode
-> XFTPTransportSession
-> TMap XFTPTransportSession XFTPClientVar
-> XFTPClientVar
-> AM (Client FileResponse)
forall msg v err.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> TMap (TransportSession msg) (ClientVar msg)
-> ClientVar msg
-> AM (Client msg)
waitForProtocolClient AgentClient
c NetworkRequestMode
NRMBackground XFTPTransportSession
tSess TMap XFTPTransportSession XFTPClientVar
xftpClients)
  where
    connectClient :: XFTPClientVar -> AM XFTPClient
    connectClient :: XFTPClientVar -> AM XFTPClient
connectClient XFTPClientVar
v = do
      XFTPClientConfig
cfg <- (Env -> XFTPClientConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) XFTPClientConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> XFTPClientConfig)
 -> ExceptT AgentErrorType (ReaderT Env IO) XFTPClientConfig)
-> (Env -> XFTPClientConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) XFTPClientConfig
forall a b. (a -> b) -> a -> b
$ AgentConfig -> XFTPClientConfig
xftpCfg (AgentConfig -> XFTPClientConfig)
-> (Env -> AgentConfig) -> Env -> XFTPClientConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
      NetworkConfig
xftpNetworkConfig <- AgentClient
-> ExceptT AgentErrorType (ReaderT Env IO) NetworkConfig
forall (m :: * -> *). MonadIO m => AgentClient -> m NetworkConfig
getNetworkConfig AgentClient
c
      UTCTime
ts <- TVar UTCTime -> ExceptT AgentErrorType (ReaderT Env IO) UTCTime
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar UTCTime
proxySessTs
      (ProtocolClientError XFTPErrorType -> AgentErrorType)
-> IO (Either (ProtocolClientError XFTPErrorType) XFTPClient)
-> AM XFTPClient
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> IO (Either e a) -> ExceptT e' m a
liftError' ((String -> XFTPErrorType -> AgentErrorType)
-> String -> ProtocolClientError XFTPErrorType -> AgentErrorType
forall err.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
protocolClientError String -> XFTPErrorType -> AgentErrorType
XFTP (String -> ProtocolClientError XFTPErrorType -> AgentErrorType)
-> String -> ProtocolClientError XFTPErrorType -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PXFTP -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtoServer FileResponse
ProtocolServer 'PXFTP
srv) (IO (Either (ProtocolClientError XFTPErrorType) XFTPClient)
 -> AM XFTPClient)
-> IO (Either (ProtocolClientError XFTPErrorType) XFTPClient)
-> AM XFTPClient
forall a b. (a -> b) -> a -> b
$
        XFTPTransportSession
-> XFTPClientConfig
-> [String]
-> UTCTime
-> (XFTPClient -> IO ())
-> IO (Either (ProtocolClientError XFTPErrorType) XFTPClient)
X.getXFTPClient XFTPTransportSession
tSess XFTPClientConfig
cfg {xftpNetworkConfig} [String]
presetDomains UTCTime
ts ((XFTPClient -> IO ())
 -> IO (Either (ProtocolClientError XFTPErrorType) XFTPClient))
-> (XFTPClient -> IO ())
-> IO (Either (ProtocolClientError XFTPErrorType) XFTPClient)
forall a b. (a -> b) -> a -> b
$
          XFTPClientVar -> XFTPClient -> IO ()
clientDisconnected XFTPClientVar
v

    clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
    clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
clientDisconnected XFTPClientVar
v XFTPClient
client = do
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)
-> (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
     (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
-> STM ()
forall k a.
Ord k =>
SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
removeSessVar SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)
XFTPClientVar
v XFTPTransportSession
(UserId, ProtocolServer 'PXFTP, Maybe ByteString)
tSess TMap XFTPTransportSession XFTPClientVar
TMap
  (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
  (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
xftpClients
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ByteString
"", ByteString
"", SAEntity 'AENone -> AEvent 'AENone -> AEvt
forall (e :: AEntity). AEntityI e => SAEntity e -> AEvent e -> AEvt
AEvt SAEntity 'AENone
SAENone (AEvent 'AENone -> AEvt) -> AEvent 'AENone -> AEvt
forall a b. (a -> b) -> a -> b
$ (AProtocolType -> TransportHost -> AEvent 'AENone)
-> Client FileResponse -> AEvent 'AENone
forall v err msg.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
(AProtocolType -> TransportHost -> AEvent 'AENone)
-> Client msg -> AEvent 'AENone
hostEvent AProtocolType -> TransportHost -> AEvent 'AENone
DISCONNECT XFTPClient
Client FileResponse
client)
      Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> IO ()) -> (ByteString -> Text) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Agent disconnected from " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ProtocolServer 'PXFTP -> ByteString
forall (s :: ProtocolType). ProtocolServer s -> ByteString
showServer ProtoServer FileResponse
ProtocolServer 'PXFTP
srv

waitForProtocolClient ::
  (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
  AgentClient ->
  NetworkRequestMode ->
  TransportSession msg ->
  TMap (TransportSession msg) (ClientVar msg) ->
  ClientVar msg ->
  AM (Client msg)
waitForProtocolClient :: forall msg v err.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> TMap (TransportSession msg) (ClientVar msg)
-> ClientVar msg
-> AM (Client msg)
waitForProtocolClient AgentClient
c NetworkRequestMode
nm tSess :: (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
tSess@(UserId
_, ProtocolServer (ProtoType msg)
srv, Maybe ByteString
_) TMap
  (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
  (ClientVar msg)
clients ClientVar msg
v = do
  NetworkConfig {NetworkTimeout
$sel:tcpConnectTimeout:NetworkConfig :: NetworkConfig -> NetworkTimeout
tcpConnectTimeout :: NetworkTimeout
tcpConnectTimeout} <- AgentClient
-> ExceptT AgentErrorType (ReaderT Env IO) NetworkConfig
forall (m :: * -> *). MonadIO m => AgentClient -> m NetworkConfig
getNetworkConfig AgentClient
c
  Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg))
client_ <- IO (Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg))))
-> IO (Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
forall a b. (a -> b) -> a -> b
$ NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout
tcpConnectTimeout NetworkRequestMode
nm Int
-> IO (Either (AgentErrorType, Maybe UTCTime) (Client msg))
-> IO (Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
`timeout` STM (Either (AgentErrorType, Maybe UTCTime) (Client msg))
-> IO (Either (AgentErrorType, Maybe UTCTime) (Client msg))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
-> STM (Either (AgentErrorType, Maybe UTCTime) (Client msg))
forall a. TMVar a -> STM a
readTMVar (TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
 -> STM (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
-> TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
-> STM (Either (AgentErrorType, Maybe UTCTime) (Client msg))
forall a b. (a -> b) -> a -> b
$ ClientVar msg
-> TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
forall a. SessionVar a -> TMVar a
sessionVar ClientVar msg
v)
  case Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg))
client_ of
    Just (Right Client msg
smpClient) -> Client msg -> AM (Client msg)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client msg
smpClient
    Just (Left (AgentErrorType
e, Maybe UTCTime
ts_)) -> case Maybe UTCTime
ts_ of
      Maybe UTCTime
Nothing -> AgentErrorType -> AM (Client msg)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e
      Just UTCTime
ts ->
        ExceptT AgentErrorType (ReaderT Env IO) Bool
-> AM (Client msg) -> AM (Client msg) -> AM (Client msg)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
          ((UTCTime
ts UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<) (UTCTime -> Bool)
-> ExceptT AgentErrorType (ReaderT Env IO) UTCTime
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> ExceptT AgentErrorType (ReaderT Env IO) UTCTime
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime)
          (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (ClientVar msg
-> (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
-> TMap
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
-> STM ()
forall k a.
Ord k =>
SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
removeSessVar ClientVar msg
v (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
tSess TMap
  (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
  (ClientVar msg)
clients) ExceptT AgentErrorType (ReaderT Env IO) ()
-> AM (Client msg) -> AM (Client msg)
forall a b.
ExceptT AgentErrorType (ReaderT Env IO) a
-> ExceptT AgentErrorType (ReaderT Env IO) b
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AgentClient
-> NetworkRequestMode
-> (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
-> AM (Client msg)
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode -> TransportSession msg -> AM (Client msg)
getProtocolServerClient AgentClient
c NetworkRequestMode
nm (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
tSess)
          (AgentErrorType -> AM (Client msg)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e)
    Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg))
Nothing -> AgentErrorType -> AM (Client msg)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (Client msg))
-> AgentErrorType -> AM (Client msg)
forall a b. (a -> b) -> a -> b
$ String -> BrokerErrorType -> AgentErrorType
BROKER (ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer (ProtoType msg) -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtocolServer (ProtoType msg)
srv) BrokerErrorType
TIMEOUT

-- clientConnected arg is only passed for SMP server
newProtocolClient ::
  forall v err msg.
  (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
  AgentClient ->
  TransportSession msg ->
  TMap (TransportSession msg) (ClientVar msg) ->
  (ClientVar msg -> AM (Client msg)) ->
  ClientVar msg ->
  AM (Client msg)
newProtocolClient :: forall v err msg.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
AgentClient
-> TransportSession msg
-> TMap (TransportSession msg) (ClientVar msg)
-> (ClientVar msg -> AM (Client msg))
-> ClientVar msg
-> AM (Client msg)
newProtocolClient AgentClient
c tSess :: (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
tSess@(UserId
userId, ProtocolServer (ProtoType msg)
srv, Maybe ByteString
entityId_) TMap
  (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
  (ClientVar msg)
clients ClientVar msg -> AM (Client msg)
connectClient ClientVar msg
v =
  AM (Client msg)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType (Client msg))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors (ClientVar msg -> AM (Client msg)
connectClient ClientVar msg
v) ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Either AgentErrorType (Client msg))
-> (Either AgentErrorType (Client msg) -> AM (Client msg))
-> AM (Client msg)
forall a b.
ExceptT AgentErrorType (ReaderT Env IO) a
-> (a -> ExceptT AgentErrorType (ReaderT Env IO) b)
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right Client msg
client -> do
      Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ByteString -> Text)
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ByteString -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Agent connected to " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ProtocolServer (ProtoType msg) -> ByteString
forall (s :: ProtocolType). ProtocolServer s -> ByteString
showServer ProtocolServer (ProtoType msg)
srv ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" (user " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> UserId -> ByteString
forall a. Show a => a -> ByteString
bshow UserId
userId 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
" for entity " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) Maybe ByteString
entityId_ ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
")"
      STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
-> Either (AgentErrorType, Maybe UTCTime) (Client msg) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (ClientVar msg
-> TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
forall a. SessionVar a -> TMVar a
sessionVar ClientVar msg
v) (Client msg -> Either (AgentErrorType, Maybe UTCTime) (Client msg)
forall a b. b -> Either a b
Right Client msg
client)
      IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ TBQueue ATransmission -> ATransmission -> IO ()
forall a. TBQueue a -> a -> IO ()
nonBlockingWriteTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ByteString
"", ByteString
"", SAEntity 'AENone -> AEvent 'AENone -> AEvt
forall (e :: AEntity). AEntityI e => SAEntity e -> AEvent e -> AEvt
AEvt SAEntity 'AENone
SAENone (AEvent 'AENone -> AEvt) -> AEvent 'AENone -> AEvt
forall a b. (a -> b) -> a -> b
$ (AProtocolType -> TransportHost -> AEvent 'AENone)
-> Client msg -> AEvent 'AENone
forall v err msg.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
(AProtocolType -> TransportHost -> AEvent 'AENone)
-> Client msg -> AEvent 'AENone
hostEvent AProtocolType -> TransportHost -> AEvent 'AENone
CONNECT Client msg
client)
      Client msg -> AM (Client msg)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client msg
client
    Left AgentErrorType
e -> do
      NominalDiffTime
ei <- (Env -> NominalDiffTime)
-> ExceptT AgentErrorType (ReaderT Env IO) NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> NominalDiffTime)
 -> ExceptT AgentErrorType (ReaderT Env IO) NominalDiffTime)
-> (Env -> NominalDiffTime)
-> ExceptT AgentErrorType (ReaderT Env IO) NominalDiffTime
forall a b. (a -> b) -> a -> b
$ AgentConfig -> NominalDiffTime
persistErrorInterval (AgentConfig -> NominalDiffTime)
-> (Env -> AgentConfig) -> Env -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
      if NominalDiffTime
ei NominalDiffTime -> NominalDiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== NominalDiffTime
0
        then STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ do
          ClientVar msg
-> (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
-> TMap
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
-> STM ()
forall k a.
Ord k =>
SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
removeSessVar ClientVar msg
v (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
tSess TMap
  (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
  (ClientVar msg)
clients
          TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
-> Either (AgentErrorType, Maybe UTCTime) (Client msg) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (ClientVar msg
-> TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
forall a. SessionVar a -> TMVar a
sessionVar ClientVar msg
v) ((AgentErrorType, Maybe UTCTime)
-> Either (AgentErrorType, Maybe UTCTime) (Client msg)
forall a b. a -> Either a b
Left (AgentErrorType
e, Maybe UTCTime
forall a. Maybe a
Nothing))
        else do
          UTCTime
ts <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
ei (UTCTime -> UTCTime)
-> ExceptT AgentErrorType (ReaderT Env IO) UTCTime
-> ExceptT AgentErrorType (ReaderT Env IO) UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> ExceptT AgentErrorType (ReaderT Env IO) UTCTime
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
          STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
-> Either (AgentErrorType, Maybe UTCTime) (Client msg) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (ClientVar msg
-> TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
forall a. SessionVar a -> TMVar a
sessionVar ClientVar msg
v) ((AgentErrorType, Maybe UTCTime)
-> Either (AgentErrorType, Maybe UTCTime) (Client msg)
forall a b. a -> Either a b
Left (AgentErrorType
e, UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
ts))
      AgentErrorType -> AM (Client msg)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e -- signal error to caller

hostEvent :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> AEvent 'AENone) -> Client msg -> AEvent 'AENone
hostEvent :: forall v err msg.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
(AProtocolType -> TransportHost -> AEvent 'AENone)
-> Client msg -> AEvent 'AENone
hostEvent AProtocolType -> TransportHost -> AEvent 'AENone
event = (AProtocolType -> TransportHost -> AEvent 'AENone)
-> ProtoClient msg -> AEvent 'AENone
forall v err msg.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
(AProtocolType -> TransportHost -> AEvent 'AENone)
-> ProtoClient msg -> AEvent 'AENone
hostEvent' AProtocolType -> TransportHost -> AEvent 'AENone
event (ProtoClient msg -> AEvent 'AENone)
-> (Client msg -> ProtoClient msg) -> Client msg -> AEvent 'AENone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client msg -> ProtoClient msg
forall v err msg.
ProtocolServerClient v err msg =>
Client msg -> ProtoClient msg
protocolClient
{-# INLINE hostEvent #-}

hostEvent' :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> AEvent 'AENone) -> ProtoClient msg -> AEvent 'AENone
hostEvent' :: forall v err msg.
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
(AProtocolType -> TransportHost -> AEvent 'AENone)
-> ProtoClient msg -> AEvent 'AENone
hostEvent' AProtocolType -> TransportHost -> AEvent 'AENone
event = AProtocolType -> TransportHost -> AEvent 'AENone
event (SProtocolType (ProtoType msg) -> AProtocolType
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p -> AProtocolType
AProtocolType (SProtocolType (ProtoType msg) -> AProtocolType)
-> SProtocolType (ProtoType msg) -> AProtocolType
forall a b. (a -> b) -> a -> b
$ forall (p :: ProtocolType). ProtocolTypeI p => SProtocolType p
protocolTypeI @(ProtoType msg)) (TransportHost -> AEvent 'AENone)
-> (ProtoClient msg -> TransportHost)
-> ProtoClient msg
-> AEvent 'AENone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtoClient msg -> TransportHost
forall v err msg.
ProtocolServerClient v err msg =>
ProtoClient msg -> TransportHost
clientTransportHost

getClientConfig :: AgentClient -> (AgentConfig -> ProtocolClientConfig v) -> AM' (ProtocolClientConfig v)
getClientConfig :: forall v.
AgentClient
-> (AgentConfig -> ProtocolClientConfig v)
-> AM' (ProtocolClientConfig v)
getClientConfig AgentClient
c AgentConfig -> ProtocolClientConfig v
cfgSel = do
  ProtocolClientConfig v
cfg <- (Env -> ProtocolClientConfig v) -> AM' (ProtocolClientConfig v)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> ProtocolClientConfig v) -> AM' (ProtocolClientConfig v))
-> (Env -> ProtocolClientConfig v) -> AM' (ProtocolClientConfig v)
forall a b. (a -> b) -> a -> b
$ AgentConfig -> ProtocolClientConfig v
cfgSel (AgentConfig -> ProtocolClientConfig v)
-> (Env -> AgentConfig) -> Env -> ProtocolClientConfig v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  NetworkConfig
networkConfig <- AgentClient -> ReaderT Env IO NetworkConfig
forall (m :: * -> *). MonadIO m => AgentClient -> m NetworkConfig
getNetworkConfig AgentClient
c
  ProtocolClientConfig v -> AM' (ProtocolClientConfig v)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProtocolClientConfig v
cfg {networkConfig}

getNetworkConfig :: MonadIO m => AgentClient -> m NetworkConfig
getNetworkConfig :: forall (m :: * -> *). MonadIO m => AgentClient -> m NetworkConfig
getNetworkConfig AgentClient
c = do
  (NetworkConfig
slowCfg, NetworkConfig
fastCfg) <- TVar (NetworkConfig, NetworkConfig)
-> m (NetworkConfig, NetworkConfig)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (NetworkConfig, NetworkConfig)
 -> m (NetworkConfig, NetworkConfig))
-> TVar (NetworkConfig, NetworkConfig)
-> m (NetworkConfig, NetworkConfig)
forall a b. (a -> b) -> a -> b
$ AgentClient -> TVar (NetworkConfig, NetworkConfig)
useNetworkConfig AgentClient
c
  UserNetworkInfo {UserNetworkType
$sel:networkType:UserNetworkInfo :: UserNetworkInfo -> UserNetworkType
networkType :: UserNetworkType
networkType} <- TVar UserNetworkInfo -> m UserNetworkInfo
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar UserNetworkInfo -> m UserNetworkInfo)
-> TVar UserNetworkInfo -> m UserNetworkInfo
forall a b. (a -> b) -> a -> b
$ AgentClient -> TVar UserNetworkInfo
userNetworkInfo AgentClient
c
  NetworkConfig -> m NetworkConfig
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NetworkConfig -> m NetworkConfig)
-> NetworkConfig -> m NetworkConfig
forall a b. (a -> b) -> a -> b
$ case UserNetworkType
networkType of
    UserNetworkType
UNCellular -> NetworkConfig
slowCfg
    UserNetworkType
UNNone -> NetworkConfig
slowCfg
    UserNetworkType
_ -> NetworkConfig
fastCfg

-- returns fast network config
getFastNetworkConfig :: AgentClient -> IO NetworkConfig
getFastNetworkConfig :: AgentClient -> IO NetworkConfig
getFastNetworkConfig = ((NetworkConfig, NetworkConfig) -> NetworkConfig)
-> IO (NetworkConfig, NetworkConfig) -> IO NetworkConfig
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NetworkConfig, NetworkConfig) -> NetworkConfig
forall a b. (a, b) -> b
snd (IO (NetworkConfig, NetworkConfig) -> IO NetworkConfig)
-> (AgentClient -> IO (NetworkConfig, NetworkConfig))
-> AgentClient
-> IO NetworkConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (NetworkConfig, NetworkConfig)
-> IO (NetworkConfig, NetworkConfig)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (NetworkConfig, NetworkConfig)
 -> IO (NetworkConfig, NetworkConfig))
-> (AgentClient -> TVar (NetworkConfig, NetworkConfig))
-> AgentClient
-> IO (NetworkConfig, NetworkConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> TVar (NetworkConfig, NetworkConfig)
useNetworkConfig
{-# INLINE getFastNetworkConfig #-}

waitForUserNetwork :: AgentClient -> IO ()
waitForUserNetwork :: AgentClient -> IO ()
waitForUserNetwork AgentClient
c =
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (UserNetworkInfo -> Bool
isOnline (UserNetworkInfo -> Bool) -> IO UserNetworkInfo -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar UserNetworkInfo -> IO UserNetworkInfo
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (AgentClient -> TVar UserNetworkInfo
userNetworkInfo AgentClient
c)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    TVar Bool
delay <- Int -> IO (TVar Bool)
forall (m :: * -> *). MonadIO m => Int -> m (TVar Bool)
registerDelay (Int -> IO (TVar Bool)) -> Int -> IO (TVar Bool)
forall a b. (a -> b) -> a -> b
$ AgentConfig -> Int
userNetworkInterval (AgentConfig -> Int) -> AgentConfig -> Int
forall a b. (a -> b) -> a -> b
$ Env -> AgentConfig
config (Env -> AgentConfig) -> Env -> AgentConfig
forall a b. (a -> b) -> a -> b
$ AgentClient -> Env
agentEnv AgentClient
c
    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (AgentClient -> STM Bool
isNetworkOnline AgentClient
c) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
delay) STM ()
forall a. STM a
retry

closeAgentClient :: AgentClient -> IO ()
closeAgentClient :: AgentClient -> IO ()
closeAgentClient AgentClient
c = do
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (AgentClient -> TVar Bool
active AgentClient
c) Bool
False
  AgentClient
-> (AgentClient -> TMap SMPTransportSession SMPClientVar) -> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> (AgentClient -> TMap (TransportSession msg) (ClientVar msg))
-> IO ()
closeProtocolServerClients AgentClient
c AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients
  AgentClient
-> (AgentClient -> TMap NtfTransportSession NtfClientVar) -> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> (AgentClient -> TMap (TransportSession msg) (ClientVar msg))
-> IO ()
closeProtocolServerClients AgentClient
c AgentClient -> TMap NtfTransportSession NtfClientVar
ntfClients
  AgentClient
-> (AgentClient -> TMap XFTPTransportSession XFTPClientVar)
-> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> (AgentClient -> TMap (TransportSession msg) (ClientVar msg))
-> IO ()
closeProtocolServerClients AgentClient
c AgentClient -> TMap XFTPTransportSession XFTPClientVar
xftpClients
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
-> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (AgentClient -> TMap SMPTransportSession SMPServerWithAuth
smpProxiedRelays AgentClient
c) Map
  (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
forall k a. Map k a
M.empty
  STM
  (Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar (Async ())))
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar (Async ())))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar (Async ()))
-> STM
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar (Async ())))
forall a. TVar a -> a -> STM a
swapTVar (AgentClient -> TMap SMPTransportSession (SessionVar (Async ()))
smpSubWorkers AgentClient
c) Map
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
forall k a. Map k a
M.empty) IO
  (Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar (Async ())))
-> (Map
      (UserId, ProtocolServer 'PSMP, Maybe ByteString)
      (SessionVar (Async ()))
    -> 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
>>= (SessionVar (Async ()) -> IO ())
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar (Async ()))
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SessionVar (Async ()) -> IO ()
cancelReconnect
  (AgentClient -> TMap SndQAddr (Worker, TMVar ()))
-> IO (Map SndQAddr (Worker, TMVar ()))
forall k a. Ord k => (AgentClient -> TMap k a) -> IO (Map k a)
clearWorkers AgentClient -> TMap SndQAddr (Worker, TMVar ())
smpDeliveryWorkers IO (Map SndQAddr (Worker, TMVar ()))
-> (Map SndQAddr (Worker, TMVar ()) -> 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
>>= ((Worker, TMVar ()) -> IO ())
-> Map SndQAddr (Worker, TMVar ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Worker -> IO ()
cancelWorker (Worker -> IO ())
-> ((Worker, TMVar ()) -> Worker) -> (Worker, TMVar ()) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Worker, TMVar ()) -> Worker
forall a b. (a, b) -> a
fst)
  (AgentClient
 -> TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker)
-> IO (Map (ByteString, Maybe (ProtocolServer 'PSMP)) Worker)
forall k a. Ord k => (AgentClient -> TMap k a) -> IO (Map k a)
clearWorkers AgentClient
-> TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
asyncCmdWorkers IO (Map (ByteString, Maybe (ProtocolServer 'PSMP)) Worker)
-> (Map (ByteString, Maybe (ProtocolServer 'PSMP)) Worker -> 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
>>= (Worker -> IO ())
-> Map (ByteString, Maybe (ProtocolServer 'PSMP)) Worker -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Worker -> IO ()
cancelWorker
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TSessionSubs -> STM ()
SS.clear (TSessionSubs -> STM ()) -> TSessionSubs -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
  (AgentClient -> TVar (Set ByteString)) -> IO ()
forall m. Monoid m => (AgentClient -> TVar m) -> IO ()
clear AgentClient -> TVar (Set ByteString)
subscrConns
  (AgentClient -> TMap SndQAddr (TMVar ())) -> IO ()
forall m. Monoid m => (AgentClient -> TVar m) -> IO ()
clear AgentClient -> TMap SndQAddr (TMVar ())
getMsgLocks
  where
    clearWorkers :: Ord k => (AgentClient -> TMap k a) -> IO (Map k a)
    clearWorkers :: forall k a. Ord k => (AgentClient -> TMap k a) -> IO (Map k a)
clearWorkers AgentClient -> TMap k a
workers = STM (Map k a) -> IO (Map k a)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Map k a) -> IO (Map k a)) -> STM (Map k a) -> IO (Map k a)
forall a b. (a -> b) -> a -> b
$ TMap k a -> Map k a -> STM (Map k a)
forall a. TVar a -> a -> STM a
swapTVar (AgentClient -> TMap k a
workers AgentClient
c) Map k a
forall a. Monoid a => a
mempty
    clear :: Monoid m => (AgentClient -> TVar m) -> IO ()
    clear :: forall m. Monoid m => (AgentClient -> TVar m) -> IO ()
clear AgentClient -> TVar m
sel = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar m -> m -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (AgentClient -> TVar m
sel AgentClient
c) m
forall a. Monoid a => a
mempty
    cancelReconnect :: SessionVar (Async ()) -> IO ()
    cancelReconnect :: SessionVar (Async ()) -> IO ()
cancelReconnect SessionVar (Async ())
v = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (Async ()) -> IO (Async ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Async ()) -> STM (Async ())
forall a. TMVar a -> STM a
readTMVar (TMVar (Async ()) -> STM (Async ()))
-> TMVar (Async ()) -> STM (Async ())
forall a b. (a -> b) -> a -> b
$ SessionVar (Async ()) -> TMVar (Async ())
forall a. SessionVar a -> TMVar a
sessionVar SessionVar (Async ())
v) IO (Async ()) -> (Async () -> 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
>>= Async () -> IO ()
forall a. Async a -> IO ()
uninterruptibleCancel

cancelWorker :: Worker -> IO ()
cancelWorker :: Worker -> IO ()
cancelWorker Worker {TMVar ()
$sel:doWork:Worker :: Worker -> TMVar ()
doWork :: TMVar ()
doWork, TMVar (Maybe (Weak ThreadId))
$sel:action:Worker :: Worker -> TMVar (Maybe (Weak ThreadId))
action :: TMVar (Maybe (Weak ThreadId))
action} = do
  TMVar () -> IO ()
noWorkToDo TMVar ()
doWork
  STM (Maybe (Maybe (Weak ThreadId)))
-> IO (Maybe (Maybe (Weak ThreadId)))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Maybe (Weak ThreadId))
-> STM (Maybe (Maybe (Weak ThreadId)))
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar (Maybe (Weak ThreadId))
action) IO (Maybe (Maybe (Weak ThreadId)))
-> (Maybe (Maybe (Weak ThreadId)) -> 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 (Weak ThreadId) -> IO ())
-> Maybe (Maybe (Weak ThreadId)) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((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 (Weak ThreadId) -> IO ())
-> (Weak ThreadId -> IO ()) -> Maybe (Weak ThreadId) -> IO ()
forall a b. (a -> b) -> a -> b
$ 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)

waitUntilActive :: AgentClient -> IO ()
waitUntilActive :: AgentClient -> IO ()
waitUntilActive AgentClient {TVar Bool
$sel:active:AgentClient :: AgentClient -> TVar Bool
active :: TVar Bool
active} = IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (TVar Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
active) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
active) STM ()
forall a. STM a
retry

throwWhenInactive :: AgentClient -> IO ()
throwWhenInactive :: AgentClient -> IO ()
throwWhenInactive AgentClient
c = IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (TVar Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar Bool -> IO Bool) -> TVar Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ AgentClient -> TVar Bool
active AgentClient
c) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AsyncException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO AsyncException
ThreadKilled
{-# INLINE throwWhenInactive #-}

-- this function is used to remove workers once delivery is complete, not when it is removed from the map
throwWhenNoDelivery :: AgentClient -> SndQueue -> IO ()
throwWhenNoDelivery :: AgentClient -> SndQueue -> IO ()
throwWhenNoDelivery AgentClient
c SndQueue
sq =
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (SndQAddr -> TMap SndQAddr (Worker, TMVar ()) -> IO Bool
forall k a. Ord k => k -> TMap k a -> IO Bool
TM.memberIO (SndQueue -> SndQAddr
forall q. SMPQueue q => q -> SndQAddr
qAddress SndQueue
sq) (TMap SndQAddr (Worker, TMVar ()) -> IO Bool)
-> TMap SndQAddr (Worker, TMVar ()) -> IO Bool
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMap SndQAddr (Worker, TMVar ())
smpDeliveryWorkers AgentClient
c) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    AsyncException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO AsyncException
ThreadKilled

closeProtocolServerClients :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
closeProtocolServerClients :: forall v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> (AgentClient -> TMap (TransportSession msg) (ClientVar msg))
-> IO ()
closeProtocolServerClients AgentClient
c AgentClient
-> TMap
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
clientsSel =
  STM
  (Map
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg))
-> IO
     (Map
        (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
        (ClientVar msg))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (AgentClient
-> TMap
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
clientsSel AgentClient
c TMap
  (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
  (ClientVar msg)
-> Map
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
-> STM
     (Map
        (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
        (ClientVar msg))
forall a. TVar a -> a -> STM a
`swapTVar` Map
  (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
  (ClientVar msg)
forall k a. Map k a
M.empty) IO
  (Map
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg))
-> (Map
      (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
      (ClientVar 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
>>= (ClientVar msg -> IO ThreadId)
-> Map
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (IO () -> IO ThreadId)
-> (ClientVar msg -> IO ()) -> ClientVar msg -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ClientVar msg -> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient -> ClientVar msg -> IO ()
closeClient_ AgentClient
c)

reconnectServerClients :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
reconnectServerClients :: forall v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> (AgentClient -> TMap (TransportSession msg) (ClientVar msg))
-> IO ()
reconnectServerClients AgentClient
c AgentClient
-> TMap
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
clientsSel =
  TMap
  (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
  (ClientVar msg)
-> IO
     (Map
        (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
        (ClientVar msg))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (AgentClient
-> TMap
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
clientsSel AgentClient
c) IO
  (Map
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg))
-> (Map
      (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
      (ClientVar 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
>>= (ClientVar msg -> IO ThreadId)
-> Map
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (IO () -> IO ThreadId)
-> (ClientVar msg -> IO ()) -> ClientVar msg -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ClientVar msg -> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient -> ClientVar msg -> IO ()
closeClient_ AgentClient
c)

reconnectSMPServer :: AgentClient -> UserId -> SMPServer -> IO ()
reconnectSMPServer :: AgentClient -> UserId -> ProtocolServer 'PSMP -> IO ()
reconnectSMPServer AgentClient
c UserId
userId ProtocolServer 'PSMP
srv = do
  Map
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
cs <- TMap SMPTransportSession SMPClientVar
-> IO (Map SMPTransportSession SMPClientVar)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TMap SMPTransportSession SMPClientVar
 -> IO (Map SMPTransportSession SMPClientVar))
-> TMap SMPTransportSession SMPClientVar
-> IO (Map SMPTransportSession SMPClientVar)
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients AgentClient
c
  let vs :: [SessionVar
   (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
vs = ((UserId, ProtocolServer 'PSMP, Maybe ByteString)
 -> SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
 -> [SessionVar
       (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
 -> [SessionVar
       (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)])
-> [SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> [SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> [SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
-> [SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
srvClient [] Map
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
cs
  (SessionVar
   (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
 -> IO ThreadId)
-> [SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (IO () -> IO ThreadId)
-> (SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
    -> IO ())
-> SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> SMPClientVar -> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient -> ClientVar msg -> IO ()
closeClient_ AgentClient
c) [SessionVar
   (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
vs
  where
    srvClient :: (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> [SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
-> [SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
srvClient (UserId
userId', ProtocolServer 'PSMP
srv', Maybe ByteString
_) SessionVar
  (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
v
      | UserId
userId UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== UserId
userId' Bool -> Bool -> Bool
&& ProtocolServer 'PSMP
srv ProtocolServer 'PSMP -> ProtocolServer 'PSMP -> Bool
forall a. Eq a => a -> a -> Bool
== ProtocolServer 'PSMP
srv' = (SessionVar
  (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
v SessionVar
  (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> [SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
-> [SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
forall a. a -> [a] -> [a]
:)
      | Bool
otherwise = [SessionVar
   (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
-> [SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)]
forall a. a -> a
id

closeClient :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO ()
closeClient :: forall v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> (AgentClient -> TMap (TransportSession msg) (ClientVar msg))
-> TransportSession msg
-> IO ()
closeClient AgentClient
c AgentClient
-> TMap
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
clientSel (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
tSess =
  STM (Maybe (ClientVar msg)) -> IO (Maybe (ClientVar msg))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically ((UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
-> TMap
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
-> STM (Maybe (ClientVar msg))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookupDelete (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
tSess (TMap
   (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
   (ClientVar msg)
 -> STM (Maybe (ClientVar msg)))
-> TMap
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
-> STM (Maybe (ClientVar msg))
forall a b. (a -> b) -> a -> b
$ AgentClient
-> TMap
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (ClientVar msg)
clientSel AgentClient
c) IO (Maybe (ClientVar msg))
-> (Maybe (ClientVar 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
>>= (ClientVar msg -> IO ()) -> Maybe (ClientVar msg) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient -> ClientVar msg -> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient -> ClientVar msg -> IO ()
closeClient_ AgentClient
c)

closeClient_ :: ProtocolServerClient v err msg => AgentClient -> ClientVar msg -> IO ()
closeClient_ :: forall v err msg.
ProtocolServerClient v err msg =>
AgentClient -> ClientVar msg -> IO ()
closeClient_ AgentClient
c ClientVar msg
v = do
  NetworkConfig {NetworkTimeout
$sel:tcpConnectTimeout:NetworkConfig :: NetworkConfig -> NetworkTimeout
tcpConnectTimeout :: NetworkTimeout
tcpConnectTimeout} <- AgentClient -> IO NetworkConfig
forall (m :: * -> *). MonadIO m => AgentClient -> m NetworkConfig
getNetworkConfig AgentClient
c
  (BlockedIndefinitelyOnSTM -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
E.handle (\BlockedIndefinitelyOnSTM
BlockedIndefinitelyOnSTM -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout
tcpConnectTimeout NetworkRequestMode
NRMBackground Int
-> IO (Either (AgentErrorType, Maybe UTCTime) (Client msg))
-> IO (Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
`timeout` STM (Either (AgentErrorType, Maybe UTCTime) (Client msg))
-> IO (Either (AgentErrorType, Maybe UTCTime) (Client msg))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
-> STM (Either (AgentErrorType, Maybe UTCTime) (Client msg))
forall a. TMVar a -> STM a
readTMVar (TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
 -> STM (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
-> TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
-> STM (Either (AgentErrorType, Maybe UTCTime) (Client msg))
forall a b. (a -> b) -> a -> b
$ ClientVar msg
-> TMVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
forall a. SessionVar a -> TMVar a
sessionVar ClientVar msg
v) IO (Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
-> (Maybe (Either (AgentErrorType, Maybe UTCTime) (Client 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
>>= \case
      Just (Right Client msg
client) -> ProtoClient msg -> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
ProtoClient msg -> IO ()
closeProtocolServerClient (Client msg -> ProtoClient msg
forall v err msg.
ProtocolServerClient v err msg =>
Client msg -> ProtoClient msg
protocolClient Client msg
client) IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchAll_` () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Maybe (Either (AgentErrorType, Maybe UTCTime) (Client msg))
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

closeXFTPServerClient :: AgentClient -> UserId -> XFTPServer -> FileDigest -> IO ()
closeXFTPServerClient :: AgentClient
-> UserId -> ProtocolServer 'PXFTP -> FileDigest -> IO ()
closeXFTPServerClient AgentClient
c UserId
userId ProtocolServer 'PXFTP
server (FileDigest ByteString
chunkDigest) =
  AgentClient
-> UserId
-> ProtoServer FileResponse
-> ByteString
-> IO XFTPTransportSession
forall (m :: * -> *) msg.
MonadIO m =>
AgentClient
-> UserId
-> ProtoServer msg
-> ByteString
-> m (TransportSession msg)
mkTransportSession AgentClient
c UserId
userId ProtoServer FileResponse
ProtocolServer 'PXFTP
server ByteString
chunkDigest IO XFTPTransportSession -> (XFTPTransportSession -> 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
>>= AgentClient
-> (AgentClient -> TMap XFTPTransportSession XFTPClientVar)
-> XFTPTransportSession
-> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> (AgentClient -> TMap (TransportSession msg) (ClientVar msg))
-> TransportSession msg
-> IO ()
closeClient AgentClient
c AgentClient -> TMap XFTPTransportSession XFTPClientVar
xftpClients

withConnLock :: AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock :: forall a. AgentClient -> ByteString -> Text -> AM a -> AM a
withConnLock AgentClient
c ByteString
connId Text
name = ReaderT Env IO (Either AgentErrorType a)
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT Env IO (Either AgentErrorType a)
 -> ExceptT AgentErrorType (ReaderT Env IO) a)
-> (ExceptT AgentErrorType (ReaderT Env IO) a
    -> ReaderT Env IO (Either AgentErrorType a))
-> ExceptT AgentErrorType (ReaderT Env IO) a
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> ByteString
-> Text
-> ReaderT Env IO (Either AgentErrorType a)
-> ReaderT Env IO (Either AgentErrorType a)
forall a. AgentClient -> ByteString -> Text -> AM' a -> AM' a
withConnLock' AgentClient
c ByteString
connId Text
name (ReaderT Env IO (Either AgentErrorType a)
 -> ReaderT Env IO (Either AgentErrorType a))
-> (ExceptT AgentErrorType (ReaderT Env IO) a
    -> ReaderT Env IO (Either AgentErrorType a))
-> ExceptT AgentErrorType (ReaderT Env IO) a
-> ReaderT Env IO (Either AgentErrorType a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT AgentErrorType (ReaderT Env IO) a
-> ReaderT Env IO (Either AgentErrorType a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
{-# INLINE withConnLock #-}

withConnLock' :: AgentClient -> ConnId -> Text -> AM' a -> AM' a
withConnLock' :: forall a. AgentClient -> ByteString -> Text -> AM' a -> AM' a
withConnLock' AgentClient
_ ByteString
"" Text
_ = AM' a -> AM' a
forall a. a -> a
id
withConnLock' AgentClient {TMap ByteString Lock
$sel:connLocks:AgentClient :: AgentClient -> TMap ByteString Lock
connLocks :: TMap ByteString Lock
connLocks} ByteString
connId Text
name = TMap ByteString Lock -> ByteString -> Text -> AM' a -> AM' a
forall k (m :: * -> *) a.
(Ord k, MonadUnliftIO m) =>
TMap k Lock -> k -> Text -> m a -> m a
withLockMap TMap ByteString Lock
connLocks ByteString
connId Text
name
{-# INLINE withConnLock' #-}

withInvLock :: AgentClient -> ByteString -> Text -> AM a -> AM a
withInvLock :: forall a. AgentClient -> ByteString -> Text -> AM a -> AM a
withInvLock AgentClient
c ByteString
key Text
name = ReaderT Env IO (Either AgentErrorType a)
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT Env IO (Either AgentErrorType a)
 -> ExceptT AgentErrorType (ReaderT Env IO) a)
-> (ExceptT AgentErrorType (ReaderT Env IO) a
    -> ReaderT Env IO (Either AgentErrorType a))
-> ExceptT AgentErrorType (ReaderT Env IO) a
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> ByteString
-> Text
-> ReaderT Env IO (Either AgentErrorType a)
-> ReaderT Env IO (Either AgentErrorType a)
forall a. AgentClient -> ByteString -> Text -> AM' a -> AM' a
withInvLock' AgentClient
c ByteString
key Text
name (ReaderT Env IO (Either AgentErrorType a)
 -> ReaderT Env IO (Either AgentErrorType a))
-> (ExceptT AgentErrorType (ReaderT Env IO) a
    -> ReaderT Env IO (Either AgentErrorType a))
-> ExceptT AgentErrorType (ReaderT Env IO) a
-> ReaderT Env IO (Either AgentErrorType a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT AgentErrorType (ReaderT Env IO) a
-> ReaderT Env IO (Either AgentErrorType a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
{-# INLINE withInvLock #-}

withInvLock' :: AgentClient -> ByteString -> Text -> AM' a -> AM' a
withInvLock' :: forall a. AgentClient -> ByteString -> Text -> AM' a -> AM' a
withInvLock' AgentClient {TMap ByteString Lock
$sel:invLocks:AgentClient :: AgentClient -> TMap ByteString Lock
invLocks :: TMap ByteString Lock
invLocks} = TMap ByteString Lock
-> ByteString -> Text -> ReaderT Env IO a -> ReaderT Env IO a
forall k (m :: * -> *) a.
(Ord k, MonadUnliftIO m) =>
TMap k Lock -> k -> Text -> m a -> m a
withLockMap TMap ByteString Lock
invLocks
{-# INLINE withInvLock' #-}

withConnLocks :: AgentClient -> Set ConnId -> Text -> AM' a -> AM' a
withConnLocks :: forall a. AgentClient -> Set ByteString -> Text -> AM' a -> AM' a
withConnLocks AgentClient {TMap ByteString Lock
$sel:connLocks:AgentClient :: AgentClient -> TMap ByteString Lock
connLocks :: TMap ByteString Lock
connLocks} = TMap ByteString Lock
-> Set ByteString -> Text -> ReaderT Env IO a -> ReaderT Env IO a
forall k (m :: * -> *) a.
(Ord k, MonadUnliftIO m) =>
TMap k Lock -> Set k -> Text -> m a -> m a
withLocksMap TMap ByteString Lock
connLocks
{-# INLINE withConnLocks #-}

withLockMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> Text -> m a -> m a
withLockMap :: forall k (m :: * -> *) a.
(Ord k, MonadUnliftIO m) =>
TMap k Lock -> k -> Text -> m a -> m a
withLockMap = (k -> STM Lock) -> k -> Text -> m a -> m a
forall (m :: * -> *) k a.
MonadUnliftIO m =>
(k -> STM Lock) -> k -> Text -> m a -> m a
withGetLock ((k -> STM Lock) -> k -> Text -> m a -> m a)
-> (TMap k Lock -> k -> STM Lock)
-> TMap k Lock
-> k
-> Text
-> m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMap k Lock -> k -> STM Lock
forall k. Ord k => TMap k Lock -> k -> STM Lock
getMapLock
{-# INLINE withLockMap #-}

withLocksMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> Set k -> Text -> m a -> m a
withLocksMap :: forall k (m :: * -> *) a.
(Ord k, MonadUnliftIO m) =>
TMap k Lock -> Set k -> Text -> m a -> m a
withLocksMap = (k -> STM Lock) -> Set k -> Text -> m a -> m a
forall (m :: * -> *) k a.
MonadUnliftIO m =>
(k -> STM Lock) -> Set k -> Text -> m a -> m a
withGetLocks ((k -> STM Lock) -> Set k -> Text -> m a -> m a)
-> (TMap k Lock -> k -> STM Lock)
-> TMap k Lock
-> Set k
-> Text
-> m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMap k Lock -> k -> STM Lock
forall k. Ord k => TMap k Lock -> k -> STM Lock
getMapLock
{-# INLINE withLocksMap #-}

getMapLock :: Ord k => TMap k Lock -> k -> STM Lock
getMapLock :: forall k. Ord k => TMap k Lock -> k -> STM Lock
getMapLock TMap k Lock
locks k
key = k -> TMap k Lock -> STM (Maybe Lock)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup k
key TMap k Lock
locks STM (Maybe Lock) -> (Maybe Lock -> STM Lock) -> STM Lock
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM Lock -> (Lock -> STM Lock) -> Maybe Lock -> STM Lock
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM Lock
newLock Lock -> STM Lock
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    newLock :: STM Lock
newLock = STM Lock
createLock STM Lock -> (Lock -> STM Lock) -> STM Lock
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Lock
l -> k -> Lock -> TMap k Lock -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert k
key Lock
l TMap k Lock
locks STM () -> Lock -> STM Lock
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Lock
l

withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> (Client msg -> AM a) -> AM a
withClient_ :: forall a v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> (Client msg -> AM a)
-> AM a
withClient_ AgentClient
c NetworkRequestMode
nm tSess :: TransportSession msg
tSess@(UserId
_, ProtoServer msg
srv, Maybe ByteString
_) Client msg -> AM a
action = do
  Client msg
cl <- AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> ExceptT AgentErrorType (ReaderT Env IO) (Client msg)
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode -> TransportSession msg -> AM (Client msg)
getProtocolServerClient AgentClient
c NetworkRequestMode
nm TransportSession msg
tSess
  Client msg -> AM a
action Client msg
cl AM a -> (AgentErrorType -> AM a) -> AM a
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` AgentErrorType -> AM a
logServerError
  where
    logServerError :: AgentErrorType -> AM a
    logServerError :: AgentErrorType -> AM a
logServerError AgentErrorType
e = do
      ByteString
-> AgentClient
-> ProtoServer msg
-> RecipientId
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> RecipientId
-> ByteString
-> m ()
logServer ByteString
"<--" AgentClient
c ProtoServer msg
srv RecipientId
NoEntity (ByteString -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ByteString -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> ByteString
forall a. Show a => a -> ByteString
bshow AgentErrorType
e
      AgentErrorType -> AM a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e

withProxySession :: AgentClient -> NetworkRequestMode -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a
withProxySession :: forall a.
AgentClient
-> NetworkRequestMode
-> Maybe SMPServerWithAuth
-> SMPTransportSession
-> RecipientId
-> ByteString
-> ((SMPConnectedClient, ProxiedRelay) -> AM a)
-> AM a
withProxySession AgentClient
c NetworkRequestMode
nm Maybe SMPServerWithAuth
proxySrv_ destSess :: SMPTransportSession
destSess@(UserId
_, ProtoServer BrokerMsg
destSrv, Maybe ByteString
_) RecipientId
entId ByteString
cmdStr (SMPConnectedClient, ProxiedRelay) -> AM a
action = do
  (SMPConnectedClient
cl, Either AgentErrorType ProxiedRelay
sess_) <- AgentClient
-> NetworkRequestMode
-> Maybe SMPServerWithAuth
-> SMPTransportSession
-> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
getSMPProxyClient AgentClient
c NetworkRequestMode
nm Maybe SMPServerWithAuth
proxySrv_ SMPTransportSession
destSess
  ByteString
-> AgentClient
-> ProtocolServer 'PSMP
-> RecipientId
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> RecipientId
-> ByteString
-> m ()
logServer (ByteString
"--> " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Client BrokerMsg -> ByteString
proxySrv Client BrokerMsg
SMPConnectedClient
cl ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" >") AgentClient
c ProtoServer BrokerMsg
ProtocolServer 'PSMP
destSrv RecipientId
entId ByteString
cmdStr
  case Either AgentErrorType ProxiedRelay
sess_ of
    Right ProxiedRelay
sess -> do
      a
r <- (SMPConnectedClient, ProxiedRelay) -> AM a
action (SMPConnectedClient
cl, ProxiedRelay
sess) AM a -> (AgentErrorType -> AM a) -> AM a
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` SMPConnectedClient -> AgentErrorType -> AM a
forall a. SMPConnectedClient -> AgentErrorType -> AM a
logServerError SMPConnectedClient
cl
      ByteString
-> AgentClient
-> ProtocolServer 'PSMP
-> RecipientId
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> RecipientId
-> ByteString
-> m ()
logServer (ByteString
"<-- " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Client BrokerMsg -> ByteString
proxySrv Client BrokerMsg
SMPConnectedClient
cl ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" <") AgentClient
c ProtoServer BrokerMsg
ProtocolServer 'PSMP
destSrv RecipientId
entId ByteString
"OK"
      a -> AM a
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
    Left AgentErrorType
e -> SMPConnectedClient -> AgentErrorType -> AM a
forall a. SMPConnectedClient -> AgentErrorType -> AM a
logServerError SMPConnectedClient
cl AgentErrorType
e
  where
    proxySrv :: Client BrokerMsg -> ByteString
proxySrv = ProtoServer BrokerMsg -> ByteString
forall (s :: ProtocolType). ProtocolServer s -> ByteString
showServer (ProtoServer BrokerMsg -> ByteString)
-> (Client BrokerMsg -> ProtoServer BrokerMsg)
-> Client BrokerMsg
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPClient -> ProtoServer BrokerMsg
forall v err msg. ProtocolClient v err msg -> ProtoServer msg
protocolClientServer' (SMPClient -> ProtoServer BrokerMsg)
-> (Client BrokerMsg -> SMPClient)
-> Client BrokerMsg
-> ProtoServer BrokerMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client BrokerMsg -> SMPClient
Client BrokerMsg -> ProtoClient BrokerMsg
forall v err msg.
ProtocolServerClient v err msg =>
Client msg -> ProtoClient msg
protocolClient
    logServerError :: SMPConnectedClient -> AgentErrorType -> AM a
    logServerError :: forall a. SMPConnectedClient -> AgentErrorType -> AM a
logServerError SMPConnectedClient
cl AgentErrorType
e = do
      ByteString
-> AgentClient
-> ProtocolServer 'PSMP
-> RecipientId
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> RecipientId
-> ByteString
-> m ()
logServer (ByteString
"<-- " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Client BrokerMsg -> ByteString
proxySrv Client BrokerMsg
SMPConnectedClient
cl ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" <") AgentClient
c ProtoServer BrokerMsg
ProtocolServer 'PSMP
destSrv RecipientId
NoEntity (ByteString -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ByteString -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> ByteString
forall a. Show a => a -> ByteString
bshow AgentErrorType
e
      AgentErrorType -> AM a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e

withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> AM a) -> AM a
withLogClient_ :: forall v err msg a.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> ByteString
-> ByteString
-> (Client msg -> AM a)
-> AM a
withLogClient_ AgentClient
c NetworkRequestMode
nm tSess :: TransportSession msg
tSess@(UserId
_, ProtoServer msg
srv, Maybe ByteString
_) ByteString
entId ByteString
cmdStr Client msg -> AM a
action = do
  ByteString
-> AgentClient
-> ProtoServer msg
-> ByteString
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> ByteString
-> ByteString
-> m ()
logServer' ByteString
"-->" AgentClient
c ProtoServer msg
srv ByteString
entId ByteString
cmdStr
  a
res <- AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> (Client msg -> AM a)
-> AM a
forall a v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> (Client msg -> AM a)
-> AM a
withClient_ AgentClient
c NetworkRequestMode
nm TransportSession msg
tSess Client msg -> AM a
action
  ByteString
-> AgentClient
-> ProtoServer msg
-> ByteString
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> ByteString
-> ByteString
-> m ()
logServer' ByteString
"<--" AgentClient
c ProtoServer msg
srv ByteString
entId ByteString
"OK"
  a -> AM a
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
withClient :: forall v err msg a.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> (Client msg -> ExceptT (ProtocolClientError err) IO a)
-> AM a
withClient AgentClient
c NetworkRequestMode
nm TransportSession msg
tSess Client msg -> ExceptT (ProtocolClientError err) IO a
action = AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> (Client msg -> AM a)
-> AM a
forall a v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> (Client msg -> AM a)
-> AM a
withClient_ AgentClient
c NetworkRequestMode
nm TransportSession msg
tSess ((Client msg -> AM a) -> AM a) -> (Client msg -> AM a) -> AM a
forall a b. (a -> b) -> a -> b
$ \Client msg
client -> (String -> err -> AgentErrorType)
-> String -> ExceptT (ProtocolClientError err) IO a -> AM a
forall err a.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ExceptT (ProtocolClientError err) IO a -> AM a
liftClient (forall v err msg.
ProtocolServerClient v err msg =>
String -> err -> AgentErrorType
clientProtocolError @v @err @msg) (ProtoClient msg -> String
forall v err msg.
ProtocolServerClient v err msg =>
ProtoClient msg -> String
clientServer (ProtoClient msg -> String) -> ProtoClient msg -> String
forall a b. (a -> b) -> a -> b
$ Client msg -> ProtoClient msg
forall v err msg.
ProtocolServerClient v err msg =>
Client msg -> ProtoClient msg
protocolClient Client msg
client) (ExceptT (ProtocolClientError err) IO a -> AM a)
-> ExceptT (ProtocolClientError err) IO a -> AM a
forall a b. (a -> b) -> a -> b
$ Client msg -> ExceptT (ProtocolClientError err) IO a
action Client msg
client
{-# INLINE withClient #-}

withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
withLogClient :: forall v err msg a.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> ByteString
-> ByteString
-> (Client msg -> ExceptT (ProtocolClientError err) IO a)
-> AM a
withLogClient AgentClient
c NetworkRequestMode
nm TransportSession msg
tSess ByteString
entId ByteString
cmdStr Client msg -> ExceptT (ProtocolClientError err) IO a
action = AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> ByteString
-> ByteString
-> (Client msg -> AM a)
-> AM a
forall v err msg a.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> ByteString
-> ByteString
-> (Client msg -> AM a)
-> AM a
withLogClient_ AgentClient
c NetworkRequestMode
nm TransportSession msg
tSess ByteString
entId ByteString
cmdStr ((Client msg -> AM a) -> AM a) -> (Client msg -> AM a) -> AM a
forall a b. (a -> b) -> a -> b
$ \Client msg
client -> (String -> err -> AgentErrorType)
-> String -> ExceptT (ProtocolClientError err) IO a -> AM a
forall err a.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ExceptT (ProtocolClientError err) IO a -> AM a
liftClient (forall v err msg.
ProtocolServerClient v err msg =>
String -> err -> AgentErrorType
clientProtocolError @v @err @msg) (ProtoClient msg -> String
forall v err msg.
ProtocolServerClient v err msg =>
ProtoClient msg -> String
clientServer (ProtoClient msg -> String) -> ProtoClient msg -> String
forall a b. (a -> b) -> a -> b
$ Client msg -> ProtoClient msg
forall v err msg.
ProtocolServerClient v err msg =>
Client msg -> ProtoClient msg
protocolClient Client msg
client) (ExceptT (ProtocolClientError err) IO a -> AM a)
-> ExceptT (ProtocolClientError err) IO a -> AM a
forall a b. (a -> b) -> a -> b
$ Client msg -> ExceptT (ProtocolClientError err) IO a
action Client msg
client
{-# INLINE withLogClient #-}

withSMPClient :: SMPQueueRec q => AgentClient -> NetworkRequestMode -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a
withSMPClient :: forall q a.
SMPQueueRec q =>
AgentClient
-> NetworkRequestMode
-> q
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM a
withSMPClient AgentClient
c NetworkRequestMode
nm q
q ByteString
cmdStr SMPClient -> ExceptT SMPClientError IO a
action = do
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess <- AgentClient
-> q -> ExceptT AgentErrorType (ReaderT Env IO) SMPTransportSession
forall q (m :: * -> *).
(SMPQueueRec q, MonadIO m) =>
AgentClient -> q -> m SMPTransportSession
mkSMPTransportSessionIO AgentClient
c q
q
  AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> ByteString
-> ByteString
-> (Client BrokerMsg -> ExceptT SMPClientError IO a)
-> AM a
forall v err msg a.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> ByteString
-> ByteString
-> (Client msg -> ExceptT (ProtocolClientError err) IO a)
-> AM a
withLogClient AgentClient
c NetworkRequestMode
nm SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess (RecipientId -> ByteString
unEntityId (RecipientId -> ByteString) -> RecipientId -> ByteString
forall a b. (a -> b) -> a -> b
$ q -> RecipientId
forall q. SMPQueue q => q -> RecipientId
queueId q
q) ByteString
cmdStr ((Client BrokerMsg -> ExceptT SMPClientError IO a) -> AM a)
-> (Client BrokerMsg -> ExceptT SMPClientError IO a) -> AM a
forall a b. (a -> b) -> a -> b
$ SMPClient -> ExceptT SMPClientError IO a
action (SMPClient -> ExceptT SMPClientError IO a)
-> (SMPConnectedClient -> SMPClient)
-> SMPConnectedClient
-> ExceptT SMPClientError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPConnectedClient -> SMPClient
connectedClient

sendOrProxySMPMessage :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> ConnId -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer)
sendOrProxySMPMessage :: AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> Maybe SndPrivateAuthKey
-> RecipientId
-> MsgFlags
-> ByteString
-> AM (Maybe (ProtocolServer 'PSMP))
sendOrProxySMPMessage AgentClient
c NetworkRequestMode
nm UserId
userId ProtocolServer 'PSMP
destSrv ByteString
connId ByteString
cmdStr Maybe SndPrivateAuthKey
spKey_ RecipientId
senderId MsgFlags
msgFlags ByteString
msg =
  (Maybe (ProtocolServer 'PSMP), ()) -> Maybe (ProtocolServer 'PSMP)
forall a b. (a, b) -> a
fst ((Maybe (ProtocolServer 'PSMP), ())
 -> Maybe (ProtocolServer 'PSMP))
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Maybe (ProtocolServer 'PSMP), ())
-> AM (Maybe (ProtocolServer 'PSMP))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> RecipientId
-> (SMPClient
    -> ProxiedRelay
    -> ExceptT SMPClientError IO (Either ProxyClientError ()))
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Maybe (ProtocolServer 'PSMP), ())
forall a.
AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> RecipientId
-> (SMPClient
    -> ProxiedRelay
    -> ExceptT SMPClientError IO (Either ProxyClientError a))
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM (Maybe (ProtocolServer 'PSMP), a)
sendOrProxySMPCommand AgentClient
c NetworkRequestMode
nm UserId
userId ProtocolServer 'PSMP
destSrv ByteString
connId ByteString
cmdStr RecipientId
senderId SMPClient
-> ProxiedRelay
-> ExceptT SMPClientError IO (Either ProxyClientError ())
sendViaProxy SMPClient -> ExceptT SMPClientError IO ()
sendDirectly
  where
    sendViaProxy :: SMPClient
-> ProxiedRelay
-> ExceptT SMPClientError IO (Either ProxyClientError ())
sendViaProxy SMPClient
smp ProxiedRelay
proxySess = do
      STM () -> ExceptT SMPClientError IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT SMPClientError IO ())
-> STM () -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtocolServer 'PSMP
destSrv AgentSMPServerStats -> TVar Int
sentViaProxyAttempts
      STM () -> ExceptT SMPClientError IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT SMPClientError IO ())
-> STM () -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId (SMPClient -> ProtoServer BrokerMsg
forall v err msg. ProtocolClient v err msg -> ProtoServer msg
protocolClientServer' SMPClient
smp) AgentSMPServerStats -> TVar Int
sentProxiedAttempts
      SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> Maybe SndPrivateAuthKey
-> RecipientId
-> MsgFlags
-> ByteString
-> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySMPMessage SMPClient
smp NetworkRequestMode
nm ProxiedRelay
proxySess Maybe SndPrivateAuthKey
spKey_ RecipientId
senderId MsgFlags
msgFlags ByteString
msg
    sendDirectly :: SMPClient -> ExceptT SMPClientError IO ()
sendDirectly SMPClient
smp = do
      STM () -> ExceptT SMPClientError IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT SMPClientError IO ())
-> STM () -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtocolServer 'PSMP
destSrv AgentSMPServerStats -> TVar Int
sentDirectAttempts
      SMPClient
-> NetworkRequestMode
-> Maybe SndPrivateAuthKey
-> RecipientId
-> MsgFlags
-> ByteString
-> ExceptT SMPClientError IO ()
sendSMPMessage SMPClient
smp NetworkRequestMode
nm Maybe SndPrivateAuthKey
spKey_ RecipientId
senderId MsgFlags
msgFlags ByteString
msg

sendOrProxySMPCommand ::
  forall a.
  AgentClient ->
  NetworkRequestMode ->
  UserId ->
  SMPServer ->
  ConnId -> -- session entity ID, for short links LinkId is used
  ByteString ->
  SMP.EntityId -> -- sender or link ID
  (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError a)) ->
  (SMPClient -> ExceptT SMPClientError IO a) ->
  AM (Maybe SMPServer, a)
sendOrProxySMPCommand :: forall a.
AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> RecipientId
-> (SMPClient
    -> ProxiedRelay
    -> ExceptT SMPClientError IO (Either ProxyClientError a))
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM (Maybe (ProtocolServer 'PSMP), a)
sendOrProxySMPCommand AgentClient
c NetworkRequestMode
nm UserId
userId destSrv :: ProtocolServer 'PSMP
destSrv@ProtocolServer {$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host = NonEmpty TransportHost
destHosts} ByteString
connId ByteString
cmdStr RecipientId
entId SMPClient
-> ProxiedRelay
-> ExceptT SMPClientError IO (Either ProxyClientError a)
sendCmdViaProxy SMPClient -> ExceptT SMPClientError IO a
sendCmdDirectly = do
  SMPTransportSession
tSess <- AgentClient
-> UserId
-> ProtoServer BrokerMsg
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) SMPTransportSession
forall (m :: * -> *) msg.
MonadIO m =>
AgentClient
-> UserId
-> ProtoServer msg
-> ByteString
-> m (TransportSession msg)
mkTransportSession AgentClient
c UserId
userId ProtoServer BrokerMsg
ProtocolServer 'PSMP
destSrv ByteString
connId
  ExceptT AgentErrorType (ReaderT Env IO) Bool
-> AM (Maybe (ProtocolServer 'PSMP), a)
-> AM (Maybe (ProtocolServer 'PSMP), a)
-> AM (Maybe (ProtocolServer 'PSMP), a)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ExceptT AgentErrorType (ReaderT Env IO) Bool
shouldUseProxy (Maybe SMPServerWithAuth
-> SMPTransportSession -> AM (Maybe (ProtocolServer 'PSMP), a)
sendViaProxy Maybe SMPServerWithAuth
forall a. Maybe a
Nothing SMPTransportSession
tSess) ((Maybe (ProtocolServer 'PSMP)
forall a. Maybe a
Nothing,) (a -> (Maybe (ProtocolServer 'PSMP), a))
-> ExceptT AgentErrorType (ReaderT Env IO) a
-> AM (Maybe (ProtocolServer 'PSMP), a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPTransportSession -> ExceptT AgentErrorType (ReaderT Env IO) a
sendDirectly SMPTransportSession
tSess)
  where
    shouldUseProxy :: ExceptT AgentErrorType (ReaderT Env IO) Bool
shouldUseProxy = do
      NetworkConfig
cfg <- AgentClient
-> ExceptT AgentErrorType (ReaderT Env IO) NetworkConfig
forall (m :: * -> *). MonadIO m => AgentClient -> m NetworkConfig
getNetworkConfig AgentClient
c
      case NetworkConfig -> SMPProxyMode
smpProxyMode NetworkConfig
cfg of
        SMPProxyMode
SPMAlways -> Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        SMPProxyMode
SPMUnknown -> ExceptT AgentErrorType (ReaderT Env IO) Bool
unknownServer
        SMPProxyMode
SPMUnprotected
          | NetworkConfig -> ProtocolServer 'PSMP -> Bool
forall (p :: ProtocolType).
NetworkConfig -> ProtocolServer p -> Bool
ipAddressProtected NetworkConfig
cfg ProtocolServer 'PSMP
destSrv -> Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          | Bool
otherwise -> ExceptT AgentErrorType (ReaderT Env IO) Bool
unknownServer
        SMPProxyMode
SPMNever -> Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    directAllowed :: ExceptT AgentErrorType (ReaderT Env IO) Bool
directAllowed = do
      NetworkConfig
cfg <- AgentClient
-> ExceptT AgentErrorType (ReaderT Env IO) NetworkConfig
forall (m :: * -> *). MonadIO m => AgentClient -> m NetworkConfig
getNetworkConfig AgentClient
c
      Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a b. (a -> b) -> a -> b
$ case NetworkConfig -> SMPProxyFallback
smpProxyFallback NetworkConfig
cfg of
        SMPProxyFallback
SPFAllow -> Bool
True
        SMPProxyFallback
SPFAllowProtected -> NetworkConfig -> ProtocolServer 'PSMP -> Bool
forall (p :: ProtocolType).
NetworkConfig -> ProtocolServer p -> Bool
ipAddressProtected NetworkConfig
cfg ProtocolServer 'PSMP
destSrv
        SMPProxyFallback
SPFProhibit -> Bool
False
    unknownServer :: ExceptT AgentErrorType (ReaderT Env IO) Bool
unknownServer = IO Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> IO Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a b. (a -> b) -> a -> b
$ Bool
-> (UserServers 'PSMP -> Bool) -> Maybe (UserServers 'PSMP) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\UserServers 'PSMP
srvs -> (TransportHost -> Bool) -> NonEmpty TransportHost -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TransportHost -> Set TransportHost -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` UserServers 'PSMP -> Set TransportHost
forall (p :: ProtocolType). UserServers p -> Set TransportHost
knownHosts UserServers 'PSMP
srvs) NonEmpty TransportHost
destHosts) (Maybe (UserServers 'PSMP) -> Bool)
-> IO (Maybe (UserServers 'PSMP)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserId
-> TMap UserId (UserServers 'PSMP)
-> IO (Maybe (UserServers 'PSMP))
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
TM.lookupIO UserId
userId (AgentClient -> TMap UserId (UserServers 'PSMP)
smpServers AgentClient
c)
    sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer, a)
    sendViaProxy :: Maybe SMPServerWithAuth
-> SMPTransportSession -> AM (Maybe (ProtocolServer 'PSMP), a)
sendViaProxy Maybe SMPServerWithAuth
proxySrv_ destSess :: SMPTransportSession
destSess@(UserId
_, ProtoServer BrokerMsg
_, Maybe ByteString
connId_) = do
      Either AgentErrorType (Maybe (ProtocolServer 'PSMP), a)
r <- AM (Maybe (ProtocolServer 'PSMP), a)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType (Maybe (ProtocolServer 'PSMP), a))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors (AM (Maybe (ProtocolServer 'PSMP), a)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (Either AgentErrorType (Maybe (ProtocolServer 'PSMP), a)))
-> (((SMPConnectedClient, ProxiedRelay)
     -> AM (Maybe (ProtocolServer 'PSMP), a))
    -> AM (Maybe (ProtocolServer 'PSMP), a))
-> ((SMPConnectedClient, ProxiedRelay)
    -> AM (Maybe (ProtocolServer 'PSMP), a))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType (Maybe (ProtocolServer 'PSMP), a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> NetworkRequestMode
-> Maybe SMPServerWithAuth
-> SMPTransportSession
-> RecipientId
-> ByteString
-> ((SMPConnectedClient, ProxiedRelay)
    -> AM (Maybe (ProtocolServer 'PSMP), a))
-> AM (Maybe (ProtocolServer 'PSMP), a)
forall a.
AgentClient
-> NetworkRequestMode
-> Maybe SMPServerWithAuth
-> SMPTransportSession
-> RecipientId
-> ByteString
-> ((SMPConnectedClient, ProxiedRelay) -> AM a)
-> AM a
withProxySession AgentClient
c NetworkRequestMode
nm Maybe SMPServerWithAuth
proxySrv_ SMPTransportSession
destSess RecipientId
entId (ByteString
"PFWD " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
cmdStr) (((SMPConnectedClient, ProxiedRelay)
  -> AM (Maybe (ProtocolServer 'PSMP), a))
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (Either AgentErrorType (Maybe (ProtocolServer 'PSMP), a)))
-> ((SMPConnectedClient, ProxiedRelay)
    -> AM (Maybe (ProtocolServer 'PSMP), a))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType (Maybe (ProtocolServer 'PSMP), a))
forall a b. (a -> b) -> a -> b
$ \(SMPConnectedClient SMPClient
smp TMap (ProtocolServer 'PSMP) ProxiedRelayVar
_, proxySess :: ProxiedRelay
proxySess@ProxiedRelay {Maybe BasicAuth
prBasicAuth :: Maybe BasicAuth
$sel:prBasicAuth:ProxiedRelay :: ProxiedRelay -> Maybe BasicAuth
prBasicAuth}) -> do
        Either ProxyClientError a
r' <- (String -> ErrorType -> AgentErrorType)
-> String
-> ExceptT SMPClientError IO (Either ProxyClientError a)
-> AM (Either ProxyClientError a)
forall err a.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ExceptT (ProtocolClientError err) IO a -> AM a
liftClient String -> ErrorType -> AgentErrorType
SMP (ProtoClient BrokerMsg -> String
forall v err msg.
ProtocolServerClient v err msg =>
ProtoClient msg -> String
clientServer SMPClient
ProtoClient BrokerMsg
smp) (ExceptT SMPClientError IO (Either ProxyClientError a)
 -> AM (Either ProxyClientError a))
-> ExceptT SMPClientError IO (Either ProxyClientError a)
-> AM (Either ProxyClientError a)
forall a b. (a -> b) -> a -> b
$ SMPClient
-> ProxiedRelay
-> ExceptT SMPClientError IO (Either ProxyClientError a)
sendCmdViaProxy SMPClient
smp ProxiedRelay
proxySess
        let proxySrv :: ProtoServer BrokerMsg
proxySrv = SMPClient -> ProtoServer BrokerMsg
forall v err msg. ProtocolClient v err msg -> ProtoServer msg
protocolClientServer' SMPClient
smp
        case Either ProxyClientError a
r' of
          Right a
r -> (Maybe (ProtocolServer 'PSMP), a)
-> AM (Maybe (ProtocolServer 'PSMP), a)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProtocolServer 'PSMP -> Maybe (ProtocolServer 'PSMP)
forall a. a -> Maybe a
Just ProtoServer BrokerMsg
ProtocolServer 'PSMP
proxySrv, a
r)
          Left ProxyClientError
proxyErr -> do
            case ProxyClientError
proxyErr of
              ProxyProtocolError (SMP.PROXY ProxyError
SMP.NO_SESSION) -> do
                STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM ()
deleteRelaySession
                case Maybe SMPServerWithAuth
proxySrv_ of
                  Just SMPServerWithAuth
_ -> AM (Maybe (ProtocolServer 'PSMP), a)
proxyError
                  -- sendViaProxy is called recursively here to re-create the session via the same server
                  -- to avoid failure in interactive calls that don't retry after the session disconnection.
                  Maybe SMPServerWithAuth
Nothing -> Maybe SMPServerWithAuth
-> SMPTransportSession -> AM (Maybe (ProtocolServer 'PSMP), a)
sendViaProxy (SMPServerWithAuth -> Maybe SMPServerWithAuth
forall a. a -> Maybe a
Just (SMPServerWithAuth -> Maybe SMPServerWithAuth)
-> SMPServerWithAuth -> Maybe SMPServerWithAuth
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP -> Maybe BasicAuth -> SMPServerWithAuth
forall (p :: ProtocolType).
ProtocolServer p -> Maybe BasicAuth -> ProtoServerWithAuth p
ProtoServerWithAuth ProtoServer BrokerMsg
ProtocolServer 'PSMP
proxySrv Maybe BasicAuth
prBasicAuth) SMPTransportSession
destSess
              ProxyClientError
_ -> AM (Maybe (ProtocolServer 'PSMP), a)
proxyError
            where
              proxyError :: AM (Maybe (ProtocolServer 'PSMP), a)
proxyError =
                AgentErrorType -> AM (Maybe (ProtocolServer 'PSMP), a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
                  PROXY
                    { $sel:proxyServer:CMD :: String
proxyServer = SMPClient -> String
forall msg v err.
ProtocolTypeI (ProtoType msg) =>
ProtocolClient v err msg -> String
protocolClientServer SMPClient
smp,
                      $sel:relayServer:CMD :: String
relayServer = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtocolServer 'PSMP
destSrv,
                      ProxyClientError
proxyErr :: ProxyClientError
$sel:proxyErr:CMD :: ProxyClientError
proxyErr
                    }
              -- checks that the current proxied relay session is the same one that was used to send the message and removes it
              deleteRelaySession :: STM ()
deleteRelaySession =
                ( (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) SMPServerWithAuth
-> STM (Maybe SMPServerWithAuth)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
destSess (AgentClient -> TMap SMPTransportSession SMPServerWithAuth
smpProxiedRelays AgentClient
c)
                    STM (Maybe SMPServerWithAuth)
-> (SMPServerWithAuth
    -> STM
         (Maybe
            (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> STM
     (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= \(ProtoServerWithAuth ProtocolServer 'PSMP
srv Maybe BasicAuth
_) -> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> STM
     (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
forall k a. Ord k => k -> TMap k (SessionVar a) -> STM (Maybe a)
tryReadSessVar (UserId
userId, ProtocolServer 'PSMP
srv, Maybe ByteString
connId_) (AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients AgentClient
c)
                )
                  STM
  (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> (Maybe
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
    -> STM ())
-> STM ()
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 (Right (SMPConnectedClient SMPClient
smp' TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs))
                      | SMPClient -> Bool
sameClient SMPClient
smp' ->
                          ProtocolServer 'PSMP
-> TMap (ProtocolServer 'PSMP) ProxiedRelayVar
-> STM (Maybe (Either AgentErrorType ProxiedRelay))
forall k a. Ord k => k -> TMap k (SessionVar a) -> STM (Maybe a)
tryReadSessVar ProtocolServer 'PSMP
destSrv TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs STM (Maybe (Either AgentErrorType ProxiedRelay))
-> (Maybe (Either AgentErrorType ProxiedRelay) -> STM ()) -> STM ()
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 (Right ProxiedRelay
proxySess') | ProxiedRelay -> Bool
sameProxiedRelay ProxiedRelay
proxySess' -> ProtocolServer 'PSMP
-> TMap (ProtocolServer 'PSMP) ProxiedRelayVar -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete ProtocolServer 'PSMP
destSrv TMap (ProtocolServer 'PSMP) ProxiedRelayVar
prs
                            Maybe (Either AgentErrorType ProxiedRelay)
_ -> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
_ -> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              sameClient :: SMPClient -> Bool
sameClient SMPClient
smp' = THandleParams SMPVersion 'TClient -> ByteString
forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId (SMPClient -> THandleParams SMPVersion 'TClient
forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams SMPClient
smp) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== THandleParams SMPVersion 'TClient -> ByteString
forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId (SMPClient -> THandleParams SMPVersion 'TClient
forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams SMPClient
smp')
              sameProxiedRelay :: ProxiedRelay -> Bool
sameProxiedRelay ProxiedRelay
proxySess' = ProxiedRelay -> ByteString
prSessionId ProxiedRelay
proxySess ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ProxiedRelay -> ByteString
prSessionId ProxiedRelay
proxySess'
      case Either AgentErrorType (Maybe (ProtocolServer 'PSMP), a)
r of
        Right r' :: (Maybe (ProtocolServer 'PSMP), a)
r'@(Maybe (ProtocolServer 'PSMP)
srv_, a
_) -> do
          STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtocolServer 'PSMP
destSrv AgentSMPServerStats -> TVar Int
sentViaProxy
          Maybe (ProtocolServer 'PSMP)
-> (ProtocolServer 'PSMP
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (ProtocolServer 'PSMP)
srv_ ((ProtocolServer 'PSMP
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ProtocolServer 'PSMP
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \ProtocolServer 'PSMP
proxySrv -> STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtocolServer 'PSMP
proxySrv AgentSMPServerStats -> TVar Int
sentProxied
          (Maybe (ProtocolServer 'PSMP), a)
-> AM (Maybe (ProtocolServer 'PSMP), a)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ProtocolServer 'PSMP), a)
r'
        Left AgentErrorType
e
          | AgentErrorType -> Bool
serverHostError AgentErrorType
e -> ExceptT AgentErrorType (ReaderT Env IO) Bool
-> AM (Maybe (ProtocolServer 'PSMP), a)
-> AM (Maybe (ProtocolServer 'PSMP), a)
-> AM (Maybe (ProtocolServer 'PSMP), a)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ExceptT AgentErrorType (ReaderT Env IO) Bool
directAllowed ((Maybe (ProtocolServer 'PSMP)
forall a. Maybe a
Nothing,) (a -> (Maybe (ProtocolServer 'PSMP), a))
-> ExceptT AgentErrorType (ReaderT Env IO) a
-> AM (Maybe (ProtocolServer 'PSMP), a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPTransportSession -> ExceptT AgentErrorType (ReaderT Env IO) a
sendDirectly SMPTransportSession
destSess) (AgentErrorType -> AM (Maybe (ProtocolServer 'PSMP), a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e)
          | Bool
otherwise -> AgentErrorType -> AM (Maybe (ProtocolServer 'PSMP), a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e
    sendDirectly :: SMPTransportSession -> ExceptT AgentErrorType (ReaderT Env IO) a
sendDirectly SMPTransportSession
tSess =
      AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> ByteString
-> ByteString
-> (Client BrokerMsg -> ExceptT AgentErrorType (ReaderT Env IO) a)
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall v err msg a.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> ByteString
-> ByteString
-> (Client msg -> AM a)
-> AM a
withLogClient_ AgentClient
c NetworkRequestMode
nm SMPTransportSession
tSess (RecipientId -> ByteString
unEntityId RecipientId
entId) (ByteString
"SEND " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
cmdStr) ((Client BrokerMsg -> ExceptT AgentErrorType (ReaderT Env IO) a)
 -> ExceptT AgentErrorType (ReaderT Env IO) a)
-> (Client BrokerMsg -> ExceptT AgentErrorType (ReaderT Env IO) a)
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall a b. (a -> b) -> a -> b
$ \(SMPConnectedClient SMPClient
smp TMap (ProtocolServer 'PSMP) ProxiedRelayVar
_) -> do
        ExceptT AgentErrorType (ReaderT Env IO) a
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Either AgentErrorType a)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors ((String -> ErrorType -> AgentErrorType)
-> String
-> ExceptT SMPClientError IO a
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall err a.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ExceptT (ProtocolClientError err) IO a -> AM a
liftClient String -> ErrorType -> AgentErrorType
SMP (ProtoClient BrokerMsg -> String
forall v err msg.
ProtocolServerClient v err msg =>
ProtoClient msg -> String
clientServer SMPClient
ProtoClient BrokerMsg
smp) (ExceptT SMPClientError IO a
 -> ExceptT AgentErrorType (ReaderT Env IO) a)
-> ExceptT SMPClientError IO a
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall a b. (a -> b) -> a -> b
$ SMPClient -> ExceptT SMPClientError IO a
sendCmdDirectly SMPClient
smp) ExceptT AgentErrorType (ReaderT Env IO) (Either AgentErrorType a)
-> (Either AgentErrorType a
    -> ExceptT AgentErrorType (ReaderT Env IO) a)
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall a b.
ExceptT AgentErrorType (ReaderT Env IO) a
-> (a -> ExceptT AgentErrorType (ReaderT Env IO) b)
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Right a
r -> a
r a
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall a b.
a
-> ExceptT AgentErrorType (ReaderT Env IO) b
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtocolServer 'PSMP
destSrv AgentSMPServerStats -> TVar Int
sentDirect)
          Left AgentErrorType
e -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e

ipAddressProtected :: NetworkConfig -> ProtocolServer p -> Bool
ipAddressProtected :: forall (p :: ProtocolType).
NetworkConfig -> ProtocolServer p -> Bool
ipAddressProtected NetworkConfig {Maybe SocksProxyWithAuth
socksProxy :: Maybe SocksProxyWithAuth
$sel:socksProxy:NetworkConfig :: NetworkConfig -> Maybe SocksProxyWithAuth
socksProxy, HostMode
hostMode :: HostMode
$sel:hostMode:NetworkConfig :: NetworkConfig -> HostMode
hostMode} (ProtocolServer SProtocolType p
_ NonEmpty TransportHost
hosts String
_ KeyHash
_) = do
  Maybe SocksProxyWithAuth -> Bool
forall a. Maybe a -> Bool
isJust Maybe SocksProxyWithAuth
socksProxy Bool -> Bool -> Bool
|| (HostMode
hostMode HostMode -> HostMode -> Bool
forall a. Eq a => a -> a -> Bool
== HostMode
HMOnion Bool -> Bool -> Bool
&& (TransportHost -> Bool) -> NonEmpty TransportHost -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TransportHost -> Bool
isOnionHost NonEmpty TransportHost
hosts)
  where
    isOnionHost :: TransportHost -> Bool
isOnionHost = \case THOnionHost ByteString
_ -> Bool
True; TransportHost
_ -> Bool
False

withNtfClient :: AgentClient -> NetworkRequestMode -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a
withNtfClient :: forall a.
AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO a)
-> AM a
withNtfClient AgentClient
c NetworkRequestMode
nm ProtocolServer 'PNTF
srv (EntityId ByteString
entId) = AgentClient
-> NetworkRequestMode
-> NtfTransportSession
-> ByteString
-> ByteString
-> (Client NtfResponse -> ExceptT SMPClientError IO a)
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall v err msg a.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> ByteString
-> ByteString
-> (Client msg -> ExceptT (ProtocolClientError err) IO a)
-> AM a
withLogClient AgentClient
c NetworkRequestMode
nm (UserId
0, ProtoServer NtfResponse
ProtocolServer 'PNTF
srv, Maybe ByteString
forall a. Maybe a
Nothing) ByteString
entId

withXFTPClient ::
  ProtocolServerClient v err msg =>
  AgentClient ->
  (UserId, ProtoServer msg, ByteString) ->
  ByteString ->
  (Client msg -> ExceptT (ProtocolClientError err) IO b) ->
  AM b
withXFTPClient :: forall v err msg b.
ProtocolServerClient v err msg =>
AgentClient
-> (UserId, ProtoServer msg, ByteString)
-> ByteString
-> (Client msg -> ExceptT (ProtocolClientError err) IO b)
-> AM b
withXFTPClient AgentClient
c (UserId
userId, ProtoServer msg
srv, ByteString
sessEntId) ByteString
cmdStr Client msg -> ExceptT (ProtocolClientError err) IO b
action = do
  (UserId, ProtoServer msg, Maybe ByteString)
tSess <- AgentClient
-> UserId
-> ProtoServer msg
-> ByteString
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (UserId, ProtoServer msg, Maybe ByteString)
forall (m :: * -> *) msg.
MonadIO m =>
AgentClient
-> UserId
-> ProtoServer msg
-> ByteString
-> m (TransportSession msg)
mkTransportSession AgentClient
c UserId
userId ProtoServer msg
srv ByteString
sessEntId
  AgentClient
-> NetworkRequestMode
-> (UserId, ProtoServer msg, Maybe ByteString)
-> ByteString
-> ByteString
-> (Client msg -> ExceptT (ProtocolClientError err) IO b)
-> AM b
forall v err msg a.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> ByteString
-> ByteString
-> (Client msg -> ExceptT (ProtocolClientError err) IO a)
-> AM a
withLogClient AgentClient
c NetworkRequestMode
NRMBackground (UserId, ProtoServer msg, Maybe ByteString)
tSess ByteString
sessEntId ByteString
cmdStr Client msg -> ExceptT (ProtocolClientError err) IO b
action

liftClient :: (Show err, Encoding err) => (HostName -> err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> AM a
liftClient :: forall err a.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ExceptT (ProtocolClientError err) IO a -> AM a
liftClient String -> err -> AgentErrorType
protocolError_ = (ProtocolClientError err -> AgentErrorType)
-> ExceptT (ProtocolClientError err) IO a
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError ((ProtocolClientError err -> AgentErrorType)
 -> ExceptT (ProtocolClientError err) IO a
 -> ExceptT AgentErrorType (ReaderT Env IO) a)
-> (String -> ProtocolClientError err -> AgentErrorType)
-> String
-> ExceptT (ProtocolClientError err) IO a
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
forall err.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
protocolClientError String -> err -> AgentErrorType
protocolError_
{-# INLINE liftClient #-}

protocolClientError :: (Show err, Encoding err) => (HostName -> err -> AgentErrorType) -> HostName -> ProtocolClientError err -> AgentErrorType
protocolClientError :: forall err.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
protocolClientError String -> err -> AgentErrorType
protocolError_ String
host = \case
  PCEProtocolError err
e -> String -> err -> AgentErrorType
protocolError_ String
host err
e
  PCEResponseError err
e -> String -> BrokerErrorType -> AgentErrorType
BROKER String
host (BrokerErrorType -> AgentErrorType)
-> BrokerErrorType -> AgentErrorType
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
$ err -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode err
e
  PCEUnexpectedResponse ByteString
e -> String -> BrokerErrorType -> AgentErrorType
BROKER String
host (BrokerErrorType -> AgentErrorType)
-> BrokerErrorType -> AgentErrorType
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
  ProtocolClientError err
PCEResponseTimeout -> String -> BrokerErrorType -> AgentErrorType
BROKER String
host BrokerErrorType
TIMEOUT
  PCENetworkError NetworkError
e -> String -> BrokerErrorType -> AgentErrorType
BROKER String
host (BrokerErrorType -> AgentErrorType)
-> BrokerErrorType -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ NetworkError -> BrokerErrorType
NETWORK NetworkError
e
  ProtocolClientError err
PCEIncompatibleHost -> String -> BrokerErrorType -> AgentErrorType
BROKER String
host BrokerErrorType
HOST
  PCETransportError TransportError
e -> String -> BrokerErrorType -> AgentErrorType
BROKER String
host (BrokerErrorType -> AgentErrorType)
-> BrokerErrorType -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ TransportError -> BrokerErrorType
TRANSPORT TransportError
e
  e :: ProtocolClientError err
e@PCECryptoError {} -> String -> AgentErrorType
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ ProtocolClientError err -> String
forall a. Show a => a -> String
show ProtocolClientError err
e
  PCEServiceUnavailable {} -> String -> BrokerErrorType -> AgentErrorType
BROKER String
host BrokerErrorType
NO_SERVICE
  PCEIOError IOException
e -> String -> BrokerErrorType -> AgentErrorType
BROKER String
host (BrokerErrorType -> AgentErrorType)
-> BrokerErrorType -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ NetworkError -> BrokerErrorType
NETWORK (NetworkError -> BrokerErrorType)
-> NetworkError -> BrokerErrorType
forall a b. (a -> b) -> a -> b
$ String -> NetworkError
NEConnectError (String -> NetworkError) -> String -> NetworkError
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall e. Exception e => e -> String
E.displayException IOException
e

data ProtocolTestStep
  = TSConnect
  | TSDisconnect
  | TSCreateQueue
  | TSSecureQueue
  | TSDeleteQueue
  | TSCreateFile
  | TSUploadFile
  | TSDownloadFile
  | TSCompareFile
  | TSDeleteFile
  | TSCreateNtfToken
  | TSDeleteNtfToken
  deriving (ProtocolTestStep -> ProtocolTestStep -> Bool
(ProtocolTestStep -> ProtocolTestStep -> Bool)
-> (ProtocolTestStep -> ProtocolTestStep -> Bool)
-> Eq ProtocolTestStep
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProtocolTestStep -> ProtocolTestStep -> Bool
== :: ProtocolTestStep -> ProtocolTestStep -> Bool
$c/= :: ProtocolTestStep -> ProtocolTestStep -> Bool
/= :: ProtocolTestStep -> ProtocolTestStep -> Bool
Eq, Int -> ProtocolTestStep -> String -> String
[ProtocolTestStep] -> String -> String
ProtocolTestStep -> String
(Int -> ProtocolTestStep -> String -> String)
-> (ProtocolTestStep -> String)
-> ([ProtocolTestStep] -> String -> String)
-> Show ProtocolTestStep
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ProtocolTestStep -> String -> String
showsPrec :: Int -> ProtocolTestStep -> String -> String
$cshow :: ProtocolTestStep -> String
show :: ProtocolTestStep -> String
$cshowList :: [ProtocolTestStep] -> String -> String
showList :: [ProtocolTestStep] -> String -> String
Show)

data ProtocolTestFailure = ProtocolTestFailure
  { ProtocolTestFailure -> ProtocolTestStep
testStep :: ProtocolTestStep,
    ProtocolTestFailure -> AgentErrorType
testError :: AgentErrorType
  }
  deriving (ProtocolTestFailure -> ProtocolTestFailure -> Bool
(ProtocolTestFailure -> ProtocolTestFailure -> Bool)
-> (ProtocolTestFailure -> ProtocolTestFailure -> Bool)
-> Eq ProtocolTestFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProtocolTestFailure -> ProtocolTestFailure -> Bool
== :: ProtocolTestFailure -> ProtocolTestFailure -> Bool
$c/= :: ProtocolTestFailure -> ProtocolTestFailure -> Bool
/= :: ProtocolTestFailure -> ProtocolTestFailure -> Bool
Eq, Int -> ProtocolTestFailure -> String -> String
[ProtocolTestFailure] -> String -> String
ProtocolTestFailure -> String
(Int -> ProtocolTestFailure -> String -> String)
-> (ProtocolTestFailure -> String)
-> ([ProtocolTestFailure] -> String -> String)
-> Show ProtocolTestFailure
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ProtocolTestFailure -> String -> String
showsPrec :: Int -> ProtocolTestFailure -> String -> String
$cshow :: ProtocolTestFailure -> String
show :: ProtocolTestFailure -> String
$cshowList :: [ProtocolTestFailure] -> String -> String
showList :: [ProtocolTestFailure] -> String -> String
Show)

runSMPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> SMPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
runSMPServerTest :: AgentClient
-> NetworkRequestMode
-> UserId
-> SMPServerWithAuth
-> AM' (Maybe ProtocolTestFailure)
runSMPServerTest c :: AgentClient
c@AgentClient {[String]
$sel:presetDomains:AgentClient :: AgentClient -> [String]
presetDomains :: [String]
presetDomains} NetworkRequestMode
nm UserId
userId (ProtoServerWithAuth ProtocolServer 'PSMP
srv Maybe BasicAuth
auth) = do
  ProtocolClientConfig SMPVersion
cfg <- AgentClient
-> (AgentConfig -> ProtocolClientConfig SMPVersion)
-> ReaderT Env IO (ProtocolClientConfig SMPVersion)
forall v.
AgentClient
-> (AgentConfig -> ProtocolClientConfig v)
-> AM' (ProtocolClientConfig v)
getClientConfig AgentClient
c AgentConfig -> ProtocolClientConfig SMPVersion
smpCfg
  C.AuthAlg SAlgorithm a
ra <- (Env -> AuthAlg) -> ReaderT Env IO AuthAlg
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> AuthAlg) -> ReaderT Env IO AuthAlg)
-> (Env -> AuthAlg) -> ReaderT Env IO AuthAlg
forall a b. (a -> b) -> a -> b
$ AgentConfig -> AuthAlg
rcvAuthAlg (AgentConfig -> AuthAlg) -> (Env -> AgentConfig) -> Env -> AuthAlg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  C.AuthAlg SAlgorithm a
sa <- (Env -> AuthAlg) -> ReaderT Env IO AuthAlg
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> AuthAlg) -> ReaderT Env IO AuthAlg)
-> (Env -> AuthAlg) -> ReaderT Env IO AuthAlg
forall a b. (a -> b) -> a -> b
$ AgentConfig -> AuthAlg
sndAuthAlg (AgentConfig -> AuthAlg) -> (Env -> AgentConfig) -> Env -> AuthAlg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  TVar ChaChaDRG
g <- (Env -> TVar ChaChaDRG) -> ReaderT Env IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
random
  IO (Maybe ProtocolTestFailure) -> AM' (Maybe ProtocolTestFailure)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ProtocolTestFailure) -> AM' (Maybe ProtocolTestFailure))
-> IO (Maybe ProtocolTestFailure)
-> AM' (Maybe ProtocolTestFailure)
forall a b. (a -> b) -> a -> b
$ do
    let tSess :: (UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess = (UserId
userId, ProtocolServer 'PSMP
srv, Maybe ByteString
forall a. Maybe a
Nothing)
    UTCTime
ts <- TVar UTCTime -> IO UTCTime
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar UTCTime -> IO UTCTime) -> TVar UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ AgentClient -> TVar UTCTime
proxySessTs AgentClient
c
    TVar ChaChaDRG
-> NetworkRequestMode
-> SMPTransportSession
-> ProtocolClientConfig SMPVersion
-> [String]
-> Maybe
     (TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg))
-> UTCTime
-> (SMPClient -> IO ())
-> IO (Either SMPClientError SMPClient)
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 SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess ProtocolClientConfig SMPVersion
cfg [String]
presetDomains Maybe
  (TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg))
Maybe
  (TBQueue
     ((UserId, ProtocolServer 'PSMP, Maybe ByteString),
      Version SMPVersion, ByteString,
      NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg)))
forall a. Maybe a
Nothing UTCTime
ts (\SMPClient
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) IO (Either SMPClientError SMPClient)
-> (Either SMPClientError SMPClient
    -> IO (Maybe ProtocolTestFailure))
-> IO (Maybe ProtocolTestFailure)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right SMPClient
smp -> do
        rKeys :: (APublicAuthKey, SndPrivateAuthKey)
rKeys@(APublicAuthKey
_, SndPrivateAuthKey
rpKey) <- STM AAuthKeyPair -> IO AAuthKeyPair
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AAuthKeyPair -> IO AAuthKeyPair)
-> STM AAuthKeyPair -> IO AAuthKeyPair
forall a b. (a -> b) -> a -> b
$ SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
C.generateAuthKeyPair SAlgorithm a
ra TVar ChaChaDRG
g
        (APublicAuthKey
sKey, SndPrivateAuthKey
spKey) <- STM AAuthKeyPair -> IO AAuthKeyPair
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AAuthKeyPair -> IO AAuthKeyPair)
-> STM AAuthKeyPair -> IO AAuthKeyPair
forall a b. (a -> b) -> a -> b
$ SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
C.generateAuthKeyPair SAlgorithm a
sa TVar ChaChaDRG
g
        (RcvPublicDhKey
dhKey, PrivateKey 'X25519
_) <- STM (RcvPublicDhKey, PrivateKey 'X25519)
-> IO (RcvPublicDhKey, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (RcvPublicDhKey, PrivateKey 'X25519)
 -> IO (RcvPublicDhKey, PrivateKey 'X25519))
-> STM (RcvPublicDhKey, PrivateKey 'X25519)
-> IO (RcvPublicDhKey, PrivateKey 'X25519)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
g
        Either ProtocolTestFailure ()
r <- ExceptT ProtocolTestFailure IO ()
-> IO (Either ProtocolTestFailure ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ProtocolTestFailure IO ()
 -> IO (Either ProtocolTestFailure ()))
-> ExceptT ProtocolTestFailure IO ()
-> IO (Either ProtocolTestFailure ())
forall a b. (a -> b) -> a -> b
$ do
          SMP.QIK {RecipientId
rcvId :: RecipientId
$sel:rcvId:QIK :: QueueIdsKeys -> RecipientId
rcvId, RecipientId
sndId :: RecipientId
$sel:sndId:QIK :: QueueIdsKeys -> RecipientId
sndId, Maybe QueueMode
queueMode :: Maybe QueueMode
$sel:queueMode:QIK :: QueueIdsKeys -> Maybe QueueMode
queueMode} <- (SMPClientError -> ProtocolTestFailure)
-> ExceptT SMPClientError IO QueueIdsKeys
-> ExceptT ProtocolTestFailure IO QueueIdsKeys
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
testErr ProtocolTestStep
TSCreateQueue) (ExceptT SMPClientError IO QueueIdsKeys
 -> ExceptT ProtocolTestFailure IO QueueIdsKeys)
-> ExceptT SMPClientError IO QueueIdsKeys
-> ExceptT ProtocolTestFailure IO QueueIdsKeys
forall a b. (a -> b) -> a -> b
$ SMPClient
-> NetworkRequestMode
-> Maybe CbNonce
-> AAuthKeyPair
-> RcvPublicDhKey
-> Maybe BasicAuth
-> SubscriptionMode
-> QueueReqData
-> Maybe NewNtfCreds
-> ExceptT SMPClientError IO QueueIdsKeys
createSMPQueue SMPClient
smp NetworkRequestMode
nm Maybe CbNonce
forall a. Maybe a
Nothing AAuthKeyPair
(APublicAuthKey, SndPrivateAuthKey)
rKeys RcvPublicDhKey
dhKey Maybe BasicAuth
auth SubscriptionMode
SMSubscribe (Maybe (RecipientId, QueueLinkData) -> QueueReqData
QRMessaging Maybe (RecipientId, QueueLinkData)
forall a. Maybe a
Nothing) Maybe NewNtfCreds
forall a. Maybe a
Nothing
          (SMPClientError -> ProtocolTestFailure)
-> ExceptT SMPClientError IO ()
-> ExceptT ProtocolTestFailure IO ()
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
testErr ProtocolTestStep
TSSecureQueue) (ExceptT SMPClientError IO () -> ExceptT ProtocolTestFailure IO ())
-> ExceptT SMPClientError IO ()
-> ExceptT ProtocolTestFailure IO ()
forall a b. (a -> b) -> a -> b
$
            case Maybe QueueMode
queueMode of
              Just QueueMode
QMMessaging -> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
secureSndSMPQueue SMPClient
smp NetworkRequestMode
nm SndPrivateAuthKey
spKey RecipientId
sndId
              Maybe QueueMode
_ -> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> APublicAuthKey
-> ExceptT SMPClientError IO ()
secureSMPQueue SMPClient
smp NetworkRequestMode
nm SndPrivateAuthKey
rpKey RecipientId
rcvId APublicAuthKey
sKey
          (SMPClientError -> ProtocolTestFailure)
-> ExceptT SMPClientError IO ()
-> ExceptT ProtocolTestFailure IO ()
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
testErr ProtocolTestStep
TSDeleteQueue) (ExceptT SMPClientError IO () -> ExceptT ProtocolTestFailure IO ())
-> ExceptT SMPClientError IO ()
-> ExceptT ProtocolTestFailure IO ()
forall a b. (a -> b) -> a -> b
$ SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
deleteSMPQueue SMPClient
smp NetworkRequestMode
nm SndPrivateAuthKey
rpKey RecipientId
rcvId
        Maybe ()
ok <- NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt (NetworkConfig -> NetworkTimeout
tcpTimeout (NetworkConfig -> NetworkTimeout)
-> NetworkConfig -> NetworkTimeout
forall a b. (a -> b) -> a -> b
$ ProtocolClientConfig SMPVersion -> NetworkConfig
forall v. ProtocolClientConfig v -> NetworkConfig
networkConfig ProtocolClientConfig SMPVersion
cfg) NetworkRequestMode
nm Int -> IO () -> IO (Maybe ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
`timeout` SMPClient -> IO ()
forall v err msg. ProtocolClient v err msg -> IO ()
closeProtocolClient SMPClient
smp
        Maybe ProtocolTestFailure -> IO (Maybe ProtocolTestFailure)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ProtocolTestFailure -> IO (Maybe ProtocolTestFailure))
-> Maybe ProtocolTestFailure -> IO (Maybe ProtocolTestFailure)
forall a b. (a -> b) -> a -> b
$ (ProtocolTestFailure -> Maybe ProtocolTestFailure)
-> (() -> Maybe ProtocolTestFailure)
-> Either ProtocolTestFailure ()
-> Maybe ProtocolTestFailure
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a. a -> Maybe a
Just (Maybe ProtocolTestFailure -> () -> Maybe ProtocolTestFailure
forall a b. a -> b -> a
const Maybe ProtocolTestFailure
forall a. Maybe a
Nothing) Either ProtocolTestFailure ()
r Maybe ProtocolTestFailure
-> Maybe ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ProtocolTestFailure
-> (() -> Maybe ProtocolTestFailure)
-> Maybe ()
-> Maybe ProtocolTestFailure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a. a -> Maybe a
Just (ProtocolTestStep -> AgentErrorType -> ProtocolTestFailure
ProtocolTestFailure ProtocolTestStep
TSDisconnect (AgentErrorType -> ProtocolTestFailure)
-> AgentErrorType -> ProtocolTestFailure
forall a b. (a -> b) -> a -> b
$ String -> BrokerErrorType -> AgentErrorType
BROKER String
addr BrokerErrorType
TIMEOUT)) (Maybe ProtocolTestFailure -> () -> Maybe ProtocolTestFailure
forall a b. a -> b -> a
const Maybe ProtocolTestFailure
forall a. Maybe a
Nothing) Maybe ()
ok
      Left SMPClientError
e -> Maybe ProtocolTestFailure -> IO (Maybe ProtocolTestFailure)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a. a -> Maybe a
Just (ProtocolTestFailure -> Maybe ProtocolTestFailure)
-> ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a b. (a -> b) -> a -> b
$ ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
testErr ProtocolTestStep
TSConnect SMPClientError
e)
  where
    addr :: String
addr = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtocolServer 'PSMP
srv
    testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
    testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
testErr ProtocolTestStep
step = ProtocolTestStep -> AgentErrorType -> ProtocolTestFailure
ProtocolTestFailure ProtocolTestStep
step (AgentErrorType -> ProtocolTestFailure)
-> (SMPClientError -> AgentErrorType)
-> SMPClientError
-> ProtocolTestFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ErrorType -> AgentErrorType)
-> String -> SMPClientError -> AgentErrorType
forall err.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
protocolClientError String -> ErrorType -> AgentErrorType
SMP String
addr

runXFTPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> XFTPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
runXFTPServerTest :: AgentClient
-> NetworkRequestMode
-> UserId
-> XFTPServerWithAuth
-> AM' (Maybe ProtocolTestFailure)
runXFTPServerTest c :: AgentClient
c@AgentClient {[String]
$sel:presetDomains:AgentClient :: AgentClient -> [String]
presetDomains :: [String]
presetDomains} NetworkRequestMode
nm UserId
userId (ProtoServerWithAuth ProtocolServer 'PXFTP
srv Maybe BasicAuth
auth) = do
  XFTPClientConfig
cfg <- (Env -> XFTPClientConfig) -> ReaderT Env IO XFTPClientConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> XFTPClientConfig) -> ReaderT Env IO XFTPClientConfig)
-> (Env -> XFTPClientConfig) -> ReaderT Env IO XFTPClientConfig
forall a b. (a -> b) -> a -> b
$ AgentConfig -> XFTPClientConfig
xftpCfg (AgentConfig -> XFTPClientConfig)
-> (Env -> AgentConfig) -> Env -> XFTPClientConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  TVar ChaChaDRG
g <- (Env -> TVar ChaChaDRG) -> ReaderT Env IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
random
  NetworkConfig
xftpNetworkConfig <- AgentClient -> ReaderT Env IO NetworkConfig
forall (m :: * -> *). MonadIO m => AgentClient -> m NetworkConfig
getNetworkConfig AgentClient
c
  String
workDir <- AM' String
getXFTPWorkPath
  String
filePath <- String -> AM' String
getTempFilePath String
workDir
  String
rcvPath <- String -> AM' String
getTempFilePath String
workDir
  IO (Maybe ProtocolTestFailure) -> AM' (Maybe ProtocolTestFailure)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ProtocolTestFailure) -> AM' (Maybe ProtocolTestFailure))
-> IO (Maybe ProtocolTestFailure)
-> AM' (Maybe ProtocolTestFailure)
forall a b. (a -> b) -> a -> b
$ do
    let tSess :: (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
tSess = (UserId
userId, ProtocolServer 'PXFTP
srv, Maybe ByteString
forall a. Maybe a
Nothing)
    UTCTime
ts <- TVar UTCTime -> IO UTCTime
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar UTCTime -> IO UTCTime) -> TVar UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ AgentClient -> TVar UTCTime
proxySessTs AgentClient
c
    XFTPTransportSession
-> XFTPClientConfig
-> [String]
-> UTCTime
-> (XFTPClient -> IO ())
-> IO (Either (ProtocolClientError XFTPErrorType) XFTPClient)
X.getXFTPClient XFTPTransportSession
(UserId, ProtocolServer 'PXFTP, Maybe ByteString)
tSess XFTPClientConfig
cfg {xftpNetworkConfig} [String]
presetDomains UTCTime
ts (\XFTPClient
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) IO (Either (ProtocolClientError XFTPErrorType) XFTPClient)
-> (Either (ProtocolClientError XFTPErrorType) XFTPClient
    -> IO (Maybe ProtocolTestFailure))
-> IO (Maybe ProtocolTestFailure)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right XFTPClient
xftp -> String
-> IO (Maybe ProtocolTestFailure) -> IO (Maybe ProtocolTestFailure)
forall a. String -> IO a -> IO a
withTestChunk String
filePath (IO (Maybe ProtocolTestFailure) -> IO (Maybe ProtocolTestFailure))
-> IO (Maybe ProtocolTestFailure) -> IO (Maybe ProtocolTestFailure)
forall a b. (a -> b) -> a -> b
$ do
        (APublicAuthKey
sndKey, SndPrivateAuthKey
spKey) <- STM AAuthKeyPair -> IO AAuthKeyPair
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AAuthKeyPair -> IO AAuthKeyPair)
-> STM AAuthKeyPair -> IO AAuthKeyPair
forall a b. (a -> b) -> a -> b
$ SAlgorithm 'Ed25519 -> TVar ChaChaDRG -> STM AAuthKeyPair
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
C.generateAuthKeyPair SAlgorithm 'Ed25519
C.SEd25519 TVar ChaChaDRG
g
        (APublicAuthKey
rcvKey, SndPrivateAuthKey
rpKey) <- STM AAuthKeyPair -> IO AAuthKeyPair
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AAuthKeyPair -> IO AAuthKeyPair)
-> STM AAuthKeyPair -> IO AAuthKeyPair
forall a b. (a -> b) -> a -> b
$ SAlgorithm 'Ed25519 -> TVar ChaChaDRG -> STM AAuthKeyPair
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
C.generateAuthKeyPair SAlgorithm 'Ed25519
C.SEd25519 TVar ChaChaDRG
g
        ByteString
digest <- IO ByteString -> IO ByteString
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
C.sha256Hash (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
filePath
        let file :: FileInfo
file = FileInfo {APublicAuthKey
sndKey :: APublicAuthKey
sndKey :: APublicAuthKey
sndKey, size :: Word32
size = Word32
forall a. Integral a => a
chSize, ByteString
digest :: ByteString
digest :: ByteString
digest}
            chunkSpec :: XFTPChunkSpec
chunkSpec = X.XFTPChunkSpec {String
filePath :: String
$sel:filePath:XFTPChunkSpec :: String
filePath, $sel:chunkOffset:XFTPChunkSpec :: UserId
chunkOffset = UserId
0, $sel:chunkSize:XFTPChunkSpec :: Word32
chunkSize = Word32
forall a. Integral a => a
chSize}
        Either ProtocolTestFailure ()
r <- ExceptT ProtocolTestFailure IO ()
-> IO (Either ProtocolTestFailure ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ProtocolTestFailure IO ()
 -> IO (Either ProtocolTestFailure ()))
-> ExceptT ProtocolTestFailure IO ()
-> IO (Either ProtocolTestFailure ())
forall a b. (a -> b) -> a -> b
$ do
          (RecipientId
sId, [Item (NonEmpty RecipientId)
rId]) <- (ProtocolClientError XFTPErrorType -> ProtocolTestFailure)
-> ExceptT
     (ProtocolClientError XFTPErrorType)
     IO
     (RecipientId, NonEmpty RecipientId)
-> ExceptT
     ProtocolTestFailure IO (RecipientId, NonEmpty RecipientId)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (ProtocolTestStep
-> ProtocolClientError XFTPErrorType -> ProtocolTestFailure
testErr ProtocolTestStep
TSCreateFile) (ExceptT
   (ProtocolClientError XFTPErrorType)
   IO
   (RecipientId, NonEmpty RecipientId)
 -> ExceptT
      ProtocolTestFailure IO (RecipientId, NonEmpty RecipientId))
-> ExceptT
     (ProtocolClientError XFTPErrorType)
     IO
     (RecipientId, NonEmpty RecipientId)
-> ExceptT
     ProtocolTestFailure IO (RecipientId, NonEmpty RecipientId)
forall a b. (a -> b) -> a -> b
$ XFTPClient
-> SndPrivateAuthKey
-> FileInfo
-> NonEmpty APublicAuthKey
-> Maybe BasicAuth
-> ExceptT
     (ProtocolClientError XFTPErrorType)
     IO
     (RecipientId, NonEmpty RecipientId)
X.createXFTPChunk XFTPClient
xftp SndPrivateAuthKey
spKey FileInfo
file [Item (NonEmpty APublicAuthKey)
APublicAuthKey
rcvKey] Maybe BasicAuth
auth
          (ProtocolClientError XFTPErrorType -> ProtocolTestFailure)
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
-> ExceptT ProtocolTestFailure IO ()
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (ProtocolTestStep
-> ProtocolClientError XFTPErrorType -> ProtocolTestFailure
testErr ProtocolTestStep
TSUploadFile) (ExceptT (ProtocolClientError XFTPErrorType) IO ()
 -> ExceptT ProtocolTestFailure IO ())
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
-> ExceptT ProtocolTestFailure IO ()
forall a b. (a -> b) -> a -> b
$ XFTPClient
-> SndPrivateAuthKey
-> RecipientId
-> XFTPChunkSpec
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
X.uploadXFTPChunk XFTPClient
xftp SndPrivateAuthKey
spKey RecipientId
sId XFTPChunkSpec
chunkSpec
          (ProtocolClientError XFTPErrorType -> ProtocolTestFailure)
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
-> ExceptT ProtocolTestFailure IO ()
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (ProtocolTestStep
-> ProtocolClientError XFTPErrorType -> ProtocolTestFailure
testErr ProtocolTestStep
TSDownloadFile) (ExceptT (ProtocolClientError XFTPErrorType) IO ()
 -> ExceptT ProtocolTestFailure IO ())
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
-> ExceptT ProtocolTestFailure IO ()
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> XFTPClient
-> SndPrivateAuthKey
-> RecipientId
-> XFTPRcvChunkSpec
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
X.downloadXFTPChunk TVar ChaChaDRG
g XFTPClient
xftp SndPrivateAuthKey
rpKey Item (NonEmpty RecipientId)
RecipientId
rId (XFTPRcvChunkSpec
 -> ExceptT (ProtocolClientError XFTPErrorType) IO ())
-> XFTPRcvChunkSpec
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
forall a b. (a -> b) -> a -> b
$ String -> Word32 -> ByteString -> XFTPRcvChunkSpec
XFTPRcvChunkSpec String
rcvPath Word32
forall a. Integral a => a
chSize ByteString
digest
          ByteString
rcvDigest <- IO ByteString -> ExceptT ProtocolTestFailure IO ByteString
forall a. IO a -> ExceptT ProtocolTestFailure IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT ProtocolTestFailure IO ByteString)
-> IO ByteString -> ExceptT ProtocolTestFailure IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
C.sha256Hash (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
rcvPath
          Bool
-> ExceptT ProtocolTestFailure IO ()
-> ExceptT ProtocolTestFailure IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
digest ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
rcvDigest) (ExceptT ProtocolTestFailure IO ()
 -> ExceptT ProtocolTestFailure IO ())
-> ExceptT ProtocolTestFailure IO ()
-> ExceptT ProtocolTestFailure IO ()
forall a b. (a -> b) -> a -> b
$ ProtocolTestFailure -> ExceptT ProtocolTestFailure IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ProtocolTestFailure -> ExceptT ProtocolTestFailure IO ())
-> ProtocolTestFailure -> ExceptT ProtocolTestFailure IO ()
forall a b. (a -> b) -> a -> b
$ ProtocolTestStep -> AgentErrorType -> ProtocolTestFailure
ProtocolTestFailure ProtocolTestStep
TSCompareFile (AgentErrorType -> ProtocolTestFailure)
-> AgentErrorType -> ProtocolTestFailure
forall a b. (a -> b) -> a -> b
$ String -> XFTPErrorType -> AgentErrorType
XFTP (ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PXFTP -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtocolServer 'PXFTP
srv) XFTPErrorType
DIGEST
          (ProtocolClientError XFTPErrorType -> ProtocolTestFailure)
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
-> ExceptT ProtocolTestFailure IO ()
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (ProtocolTestStep
-> ProtocolClientError XFTPErrorType -> ProtocolTestFailure
testErr ProtocolTestStep
TSDeleteFile) (ExceptT (ProtocolClientError XFTPErrorType) IO ()
 -> ExceptT ProtocolTestFailure IO ())
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
-> ExceptT ProtocolTestFailure IO ()
forall a b. (a -> b) -> a -> b
$ XFTPClient
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
X.deleteXFTPChunk XFTPClient
xftp SndPrivateAuthKey
spKey RecipientId
sId
        Maybe ()
ok <- NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt (NetworkConfig -> NetworkTimeout
tcpTimeout NetworkConfig
xftpNetworkConfig) NetworkRequestMode
nm Int -> IO () -> IO (Maybe ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
`timeout` XFTPClient -> IO ()
X.closeXFTPClient XFTPClient
xftp
        Maybe ProtocolTestFailure -> IO (Maybe ProtocolTestFailure)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ProtocolTestFailure -> IO (Maybe ProtocolTestFailure))
-> Maybe ProtocolTestFailure -> IO (Maybe ProtocolTestFailure)
forall a b. (a -> b) -> a -> b
$ (ProtocolTestFailure -> Maybe ProtocolTestFailure)
-> (() -> Maybe ProtocolTestFailure)
-> Either ProtocolTestFailure ()
-> Maybe ProtocolTestFailure
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a. a -> Maybe a
Just (Maybe ProtocolTestFailure -> () -> Maybe ProtocolTestFailure
forall a b. a -> b -> a
const Maybe ProtocolTestFailure
forall a. Maybe a
Nothing) Either ProtocolTestFailure ()
r Maybe ProtocolTestFailure
-> Maybe ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ProtocolTestFailure
-> (() -> Maybe ProtocolTestFailure)
-> Maybe ()
-> Maybe ProtocolTestFailure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a. a -> Maybe a
Just (ProtocolTestStep -> AgentErrorType -> ProtocolTestFailure
ProtocolTestFailure ProtocolTestStep
TSDisconnect (AgentErrorType -> ProtocolTestFailure)
-> AgentErrorType -> ProtocolTestFailure
forall a b. (a -> b) -> a -> b
$ String -> BrokerErrorType -> AgentErrorType
BROKER String
addr BrokerErrorType
TIMEOUT)) (Maybe ProtocolTestFailure -> () -> Maybe ProtocolTestFailure
forall a b. a -> b -> a
const Maybe ProtocolTestFailure
forall a. Maybe a
Nothing) Maybe ()
ok
      Left ProtocolClientError XFTPErrorType
e -> Maybe ProtocolTestFailure -> IO (Maybe ProtocolTestFailure)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a. a -> Maybe a
Just (ProtocolTestFailure -> Maybe ProtocolTestFailure)
-> ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a b. (a -> b) -> a -> b
$ ProtocolTestStep
-> ProtocolClientError XFTPErrorType -> ProtocolTestFailure
testErr ProtocolTestStep
TSConnect ProtocolClientError XFTPErrorType
e)
  where
    addr :: String
addr = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PXFTP -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtocolServer 'PXFTP
srv
    testErr :: ProtocolTestStep -> XFTPClientError -> ProtocolTestFailure
    testErr :: ProtocolTestStep
-> ProtocolClientError XFTPErrorType -> ProtocolTestFailure
testErr ProtocolTestStep
step = ProtocolTestStep -> AgentErrorType -> ProtocolTestFailure
ProtocolTestFailure ProtocolTestStep
step (AgentErrorType -> ProtocolTestFailure)
-> (ProtocolClientError XFTPErrorType -> AgentErrorType)
-> ProtocolClientError XFTPErrorType
-> ProtocolTestFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> XFTPErrorType -> AgentErrorType)
-> String -> ProtocolClientError XFTPErrorType -> AgentErrorType
forall err.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
protocolClientError String -> XFTPErrorType -> AgentErrorType
XFTP String
addr
    chSize :: Integral a => a
    chSize :: forall a. Integral a => a
chSize = a -> a
forall a. Integral a => a -> a
kb a
64
    getTempFilePath :: FilePath -> AM' FilePath
    getTempFilePath :: String -> AM' String
getTempFilePath String
workPath = do
      UTCTime
ts <- IO UTCTime -> ReaderT Env IO UTCTime
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      let isoTime :: String
isoTime = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H%M%S.%6q" UTCTime
ts
      String -> String -> AM' String
forall (m :: * -> *). MonadIO m => String -> String -> m String
uniqueCombine String
workPath String
isoTime
    withTestChunk :: FilePath -> IO a -> IO a
    withTestChunk :: forall a. String -> IO a -> IO a
withTestChunk String
fp =
      IO () -> IO () -> IO a -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
E.bracket_
        (String -> IO ()
createTestChunk String
fp)
        (IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
fp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
fp IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchAll_` () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    -- this creates a new DRG on purpose to avoid blocking the one used in the agent
    createTestChunk :: FilePath -> IO ()
    createTestChunk :: String -> IO ()
createTestChunk String
fp = String -> ByteString -> IO ()
B.writeFile String
fp (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ByteString -> IO ByteString)
-> (TVar ChaChaDRG -> STM ByteString)
-> TVar ChaChaDRG
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TVar ChaChaDRG -> STM ByteString
C.randomBytes Int
forall a. Integral a => a
chSize (TVar ChaChaDRG -> IO ByteString)
-> IO (TVar ChaChaDRG) -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (TVar ChaChaDRG)
C.newRandom

runNTFServerTest :: AgentClient -> NetworkRequestMode -> UserId -> NtfServerWithAuth -> AM' (Maybe ProtocolTestFailure)
runNTFServerTest :: AgentClient
-> NetworkRequestMode
-> UserId
-> NtfServerWithAuth
-> AM' (Maybe ProtocolTestFailure)
runNTFServerTest c :: AgentClient
c@AgentClient {[String]
$sel:presetDomains:AgentClient :: AgentClient -> [String]
presetDomains :: [String]
presetDomains} NetworkRequestMode
nm UserId
userId (ProtoServerWithAuth ProtocolServer 'PNTF
srv Maybe BasicAuth
_) = do
  ProtocolClientConfig NTFVersion
cfg <- AgentClient
-> (AgentConfig -> ProtocolClientConfig NTFVersion)
-> ReaderT Env IO (ProtocolClientConfig NTFVersion)
forall v.
AgentClient
-> (AgentConfig -> ProtocolClientConfig v)
-> AM' (ProtocolClientConfig v)
getClientConfig AgentClient
c AgentConfig -> ProtocolClientConfig NTFVersion
ntfCfg
  C.AuthAlg SAlgorithm a
a <- (Env -> AuthAlg) -> ReaderT Env IO AuthAlg
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> AuthAlg) -> ReaderT Env IO AuthAlg)
-> (Env -> AuthAlg) -> ReaderT Env IO AuthAlg
forall a b. (a -> b) -> a -> b
$ AgentConfig -> AuthAlg
rcvAuthAlg (AgentConfig -> AuthAlg) -> (Env -> AgentConfig) -> Env -> AuthAlg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  TVar ChaChaDRG
g <- (Env -> TVar ChaChaDRG) -> ReaderT Env IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
random
  IO (Maybe ProtocolTestFailure) -> AM' (Maybe ProtocolTestFailure)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ProtocolTestFailure) -> AM' (Maybe ProtocolTestFailure))
-> IO (Maybe ProtocolTestFailure)
-> AM' (Maybe ProtocolTestFailure)
forall a b. (a -> b) -> a -> b
$ do
    let tSess :: (UserId, ProtocolServer 'PNTF, Maybe ByteString)
tSess = (UserId
userId, ProtocolServer 'PNTF
srv, Maybe ByteString
forall a. Maybe a
Nothing)
    UTCTime
ts <- TVar UTCTime -> IO UTCTime
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar UTCTime -> IO UTCTime) -> TVar UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ AgentClient -> TVar UTCTime
proxySessTs AgentClient
c
    TVar ChaChaDRG
-> NetworkRequestMode
-> NtfTransportSession
-> ProtocolClientConfig NTFVersion
-> [String]
-> Maybe
     (TBQueue
        (ServerTransmissionBatch NTFVersion ErrorType NtfResponse))
-> UTCTime
-> (ProtocolClient NTFVersion ErrorType NtfResponse -> IO ())
-> IO
     (Either
        SMPClientError (ProtocolClient NTFVersion ErrorType NtfResponse))
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 NtfTransportSession
(UserId, ProtocolServer 'PNTF, Maybe ByteString)
tSess ProtocolClientConfig NTFVersion
cfg [String]
presetDomains Maybe
  (TBQueue
     (ServerTransmissionBatch NTFVersion ErrorType NtfResponse))
Maybe
  (TBQueue
     ((UserId, ProtocolServer 'PNTF, Maybe ByteString),
      Version NTFVersion, ByteString,
      NonEmpty (RecipientId, ServerTransmission ErrorType NtfResponse)))
forall a. Maybe a
Nothing UTCTime
ts (\ProtocolClient NTFVersion ErrorType NtfResponse
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) IO
  (Either
     SMPClientError (ProtocolClient NTFVersion ErrorType NtfResponse))
-> (Either
      SMPClientError (ProtocolClient NTFVersion ErrorType NtfResponse)
    -> IO (Maybe ProtocolTestFailure))
-> IO (Maybe ProtocolTestFailure)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right ProtocolClient NTFVersion ErrorType NtfResponse
ntf -> do
        (APublicAuthKey
nKey, SndPrivateAuthKey
npKey) <- STM AAuthKeyPair -> IO AAuthKeyPair
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AAuthKeyPair -> IO AAuthKeyPair)
-> STM AAuthKeyPair -> IO AAuthKeyPair
forall a b. (a -> b) -> a -> b
$ SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
C.generateAuthKeyPair SAlgorithm a
a TVar ChaChaDRG
g
        (RcvPublicDhKey
dhKey, PrivateKey 'X25519
_) <- STM (RcvPublicDhKey, PrivateKey 'X25519)
-> IO (RcvPublicDhKey, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (RcvPublicDhKey, PrivateKey 'X25519)
 -> IO (RcvPublicDhKey, PrivateKey 'X25519))
-> STM (RcvPublicDhKey, PrivateKey 'X25519)
-> IO (RcvPublicDhKey, PrivateKey 'X25519)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
g
        Either ProtocolTestFailure ()
r <- ExceptT ProtocolTestFailure IO ()
-> IO (Either ProtocolTestFailure ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ProtocolTestFailure IO ()
 -> IO (Either ProtocolTestFailure ()))
-> ExceptT ProtocolTestFailure IO ()
-> IO (Either ProtocolTestFailure ())
forall a b. (a -> b) -> a -> b
$ do
          let deviceToken :: DeviceToken
deviceToken = PushProvider -> ByteString -> DeviceToken
DeviceToken PushProvider
PPApnsNull ByteString
"test_ntf_token"
          (RecipientId
tknId, RcvPublicDhKey
_) <- (SMPClientError -> ProtocolTestFailure)
-> ExceptT SMPClientError IO (RecipientId, RcvPublicDhKey)
-> ExceptT ProtocolTestFailure IO (RecipientId, RcvPublicDhKey)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
testErr ProtocolTestStep
TSCreateNtfToken) (ExceptT SMPClientError IO (RecipientId, RcvPublicDhKey)
 -> ExceptT ProtocolTestFailure IO (RecipientId, RcvPublicDhKey))
-> ExceptT SMPClientError IO (RecipientId, RcvPublicDhKey)
-> ExceptT ProtocolTestFailure IO (RecipientId, RcvPublicDhKey)
forall a b. (a -> b) -> a -> b
$ ProtocolClient NTFVersion ErrorType NtfResponse
-> NetworkRequestMode
-> SndPrivateAuthKey
-> NewNtfEntity 'Token
-> ExceptT SMPClientError IO (RecipientId, RcvPublicDhKey)
ntfRegisterToken ProtocolClient NTFVersion ErrorType NtfResponse
ntf NetworkRequestMode
nm SndPrivateAuthKey
npKey (DeviceToken
-> APublicAuthKey -> RcvPublicDhKey -> NewNtfEntity 'Token
NewNtfTkn DeviceToken
deviceToken APublicAuthKey
nKey RcvPublicDhKey
dhKey)
          (SMPClientError -> ProtocolTestFailure)
-> ExceptT SMPClientError IO ()
-> ExceptT ProtocolTestFailure IO ()
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
testErr ProtocolTestStep
TSDeleteNtfToken) (ExceptT SMPClientError IO () -> ExceptT ProtocolTestFailure IO ())
-> ExceptT SMPClientError IO ()
-> ExceptT ProtocolTestFailure IO ()
forall a b. (a -> b) -> a -> b
$ ProtocolClient NTFVersion ErrorType NtfResponse
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
ntfDeleteToken ProtocolClient NTFVersion ErrorType NtfResponse
ntf NetworkRequestMode
nm SndPrivateAuthKey
npKey RecipientId
tknId
        Maybe ()
ok <- NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt (NetworkConfig -> NetworkTimeout
tcpTimeout (NetworkConfig -> NetworkTimeout)
-> NetworkConfig -> NetworkTimeout
forall a b. (a -> b) -> a -> b
$ ProtocolClientConfig NTFVersion -> NetworkConfig
forall v. ProtocolClientConfig v -> NetworkConfig
networkConfig ProtocolClientConfig NTFVersion
cfg) NetworkRequestMode
nm Int -> IO () -> IO (Maybe ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
`timeout` ProtocolClient NTFVersion ErrorType NtfResponse -> IO ()
forall v err msg. ProtocolClient v err msg -> IO ()
closeProtocolClient ProtocolClient NTFVersion ErrorType NtfResponse
ntf
        Maybe ProtocolTestFailure -> IO (Maybe ProtocolTestFailure)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ProtocolTestFailure -> IO (Maybe ProtocolTestFailure))
-> Maybe ProtocolTestFailure -> IO (Maybe ProtocolTestFailure)
forall a b. (a -> b) -> a -> b
$ (ProtocolTestFailure -> Maybe ProtocolTestFailure)
-> (() -> Maybe ProtocolTestFailure)
-> Either ProtocolTestFailure ()
-> Maybe ProtocolTestFailure
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a. a -> Maybe a
Just (Maybe ProtocolTestFailure -> () -> Maybe ProtocolTestFailure
forall a b. a -> b -> a
const Maybe ProtocolTestFailure
forall a. Maybe a
Nothing) Either ProtocolTestFailure ()
r Maybe ProtocolTestFailure
-> Maybe ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ProtocolTestFailure
-> (() -> Maybe ProtocolTestFailure)
-> Maybe ()
-> Maybe ProtocolTestFailure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a. a -> Maybe a
Just (ProtocolTestStep -> AgentErrorType -> ProtocolTestFailure
ProtocolTestFailure ProtocolTestStep
TSDisconnect (AgentErrorType -> ProtocolTestFailure)
-> AgentErrorType -> ProtocolTestFailure
forall a b. (a -> b) -> a -> b
$ String -> BrokerErrorType -> AgentErrorType
BROKER String
addr BrokerErrorType
TIMEOUT)) (Maybe ProtocolTestFailure -> () -> Maybe ProtocolTestFailure
forall a b. a -> b -> a
const Maybe ProtocolTestFailure
forall a. Maybe a
Nothing) Maybe ()
ok
      Left SMPClientError
e -> Maybe ProtocolTestFailure -> IO (Maybe ProtocolTestFailure)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a. a -> Maybe a
Just (ProtocolTestFailure -> Maybe ProtocolTestFailure)
-> ProtocolTestFailure -> Maybe ProtocolTestFailure
forall a b. (a -> b) -> a -> b
$ ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
testErr ProtocolTestStep
TSConnect SMPClientError
e)
  where
    addr :: String
addr = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PNTF -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtocolServer 'PNTF
srv
    testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
    testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
testErr ProtocolTestStep
step = ProtocolTestStep -> AgentErrorType -> ProtocolTestFailure
ProtocolTestFailure ProtocolTestStep
step (AgentErrorType -> ProtocolTestFailure)
-> (SMPClientError -> AgentErrorType)
-> SMPClientError
-> ProtocolTestFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ErrorType -> AgentErrorType)
-> String -> SMPClientError -> AgentErrorType
forall err.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
protocolClientError String -> ErrorType -> AgentErrorType
NTF String
addr

getXFTPWorkPath :: AM' FilePath
getXFTPWorkPath :: AM' String
getXFTPWorkPath = do
  Maybe String
workDir <- TVar (Maybe String) -> ReaderT Env IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (Maybe String) -> ReaderT Env IO (Maybe String))
-> ReaderT Env IO (TVar (Maybe String))
-> ReaderT Env IO (Maybe String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env -> TVar (Maybe String))
-> ReaderT Env IO (TVar (Maybe String))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XFTPAgent -> TVar (Maybe String)
xftpWorkDir (XFTPAgent -> TVar (Maybe String))
-> (Env -> XFTPAgent) -> Env -> TVar (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> XFTPAgent
xftpAgent)
  AM' String -> (String -> AM' String) -> Maybe String -> AM' String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AM' String
forall (m :: * -> *). MonadIO m => m String
getTemporaryDirectory String -> AM' String
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
workDir

mkTransportSession :: MonadIO m => AgentClient -> UserId -> ProtoServer msg -> ByteString -> m (TransportSession msg)
mkTransportSession :: forall (m :: * -> *) msg.
MonadIO m =>
AgentClient
-> UserId
-> ProtoServer msg
-> ByteString
-> m (TransportSession msg)
mkTransportSession AgentClient
c UserId
userId ProtoServer msg
srv ByteString
sessEntId = UserId
-> ProtoServer msg
-> ByteString
-> TransportSessionMode
-> (UserId, ProtoServer msg, Maybe ByteString)
forall msg.
UserId
-> ProtoServer msg
-> ByteString
-> TransportSessionMode
-> TransportSession msg
mkTSession UserId
userId ProtoServer msg
srv ByteString
sessEntId (TransportSessionMode
 -> (UserId, ProtoServer msg, Maybe ByteString))
-> m TransportSessionMode
-> m (UserId, ProtoServer msg, Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient -> m TransportSessionMode
forall (m :: * -> *).
MonadIO m =>
AgentClient -> m TransportSessionMode
getSessionModeIO AgentClient
c
{-# INLINE mkTransportSession #-}

mkTSession :: UserId -> ProtoServer msg -> ByteString -> TransportSessionMode -> TransportSession msg
mkTSession :: forall msg.
UserId
-> ProtoServer msg
-> ByteString
-> TransportSessionMode
-> TransportSession msg
mkTSession UserId
userId ProtoServer msg
srv ByteString
sessEntId TransportSessionMode
mode = (UserId
userId, ProtoServer msg
srv, if TransportSessionMode
mode TransportSessionMode -> TransportSessionMode -> Bool
forall a. Eq a => a -> a -> Bool
== TransportSessionMode
TSMEntity then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
sessEntId else Maybe ByteString
forall a. Maybe a
Nothing)
{-# INLINE mkTSession #-}

mkSMPTransportSessionIO :: (SMPQueueRec q, MonadIO m) => AgentClient -> q -> m SMPTransportSession
mkSMPTransportSessionIO :: forall q (m :: * -> *).
(SMPQueueRec q, MonadIO m) =>
AgentClient -> q -> m SMPTransportSession
mkSMPTransportSessionIO AgentClient
c q
q = q -> TransportSessionMode -> SMPTransportSession
forall q.
SMPQueueRec q =>
q -> TransportSessionMode -> SMPTransportSession
mkSMPTSession q
q (TransportSessionMode
 -> (UserId, ProtocolServer 'PSMP, Maybe ByteString))
-> m TransportSessionMode
-> m (UserId, ProtocolServer 'PSMP, Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient -> m TransportSessionMode
forall (m :: * -> *).
MonadIO m =>
AgentClient -> m TransportSessionMode
getSessionModeIO AgentClient
c
{-# INLINE mkSMPTransportSessionIO #-}

mkSMPTransportSession :: SMPQueueRec q => AgentClient -> q -> STM SMPTransportSession
mkSMPTransportSession :: forall q.
SMPQueueRec q =>
AgentClient -> q -> STM SMPTransportSession
mkSMPTransportSession AgentClient
c q
q = q -> TransportSessionMode -> SMPTransportSession
forall q.
SMPQueueRec q =>
q -> TransportSessionMode -> SMPTransportSession
mkSMPTSession q
q (TransportSessionMode
 -> (UserId, ProtocolServer 'PSMP, Maybe ByteString))
-> STM TransportSessionMode
-> STM (UserId, ProtocolServer 'PSMP, Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient -> STM TransportSessionMode
getSessionMode AgentClient
c
{-# INLINE mkSMPTransportSession #-}

mkSMPTSession :: SMPQueueRec q => q -> TransportSessionMode -> SMPTransportSession
mkSMPTSession :: forall q.
SMPQueueRec q =>
q -> TransportSessionMode -> SMPTransportSession
mkSMPTSession q
q = UserId
-> ProtoServer BrokerMsg
-> ByteString
-> TransportSessionMode
-> SMPTransportSession
forall msg.
UserId
-> ProtoServer msg
-> ByteString
-> TransportSessionMode
-> TransportSession msg
mkTSession (q -> UserId
forall q. SMPQueueRec q => q -> UserId
qUserId q
q) (q -> ProtocolServer 'PSMP
forall q. SMPQueue q => q -> ProtocolServer 'PSMP
qServer q
q) (q -> ByteString
forall q. SMPQueueRec q => q -> ByteString
qConnId q
q)
{-# INLINE mkSMPTSession #-}

getSessionModeIO :: MonadIO m => AgentClient -> m TransportSessionMode
getSessionModeIO :: forall (m :: * -> *).
MonadIO m =>
AgentClient -> m TransportSessionMode
getSessionModeIO = ((NetworkConfig, NetworkConfig) -> TransportSessionMode)
-> m (NetworkConfig, NetworkConfig) -> m TransportSessionMode
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NetworkConfig -> TransportSessionMode
sessionMode (NetworkConfig -> TransportSessionMode)
-> ((NetworkConfig, NetworkConfig) -> NetworkConfig)
-> (NetworkConfig, NetworkConfig)
-> TransportSessionMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NetworkConfig, NetworkConfig) -> NetworkConfig
forall a b. (a, b) -> b
snd) (m (NetworkConfig, NetworkConfig) -> m TransportSessionMode)
-> (AgentClient -> m (NetworkConfig, NetworkConfig))
-> AgentClient
-> m TransportSessionMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (NetworkConfig, NetworkConfig)
-> m (NetworkConfig, NetworkConfig)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (NetworkConfig, NetworkConfig)
 -> m (NetworkConfig, NetworkConfig))
-> (AgentClient -> TVar (NetworkConfig, NetworkConfig))
-> AgentClient
-> m (NetworkConfig, NetworkConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> TVar (NetworkConfig, NetworkConfig)
useNetworkConfig
{-# INLINE getSessionModeIO #-}

getSessionMode :: AgentClient -> STM TransportSessionMode
getSessionMode :: AgentClient -> STM TransportSessionMode
getSessionMode = ((NetworkConfig, NetworkConfig) -> TransportSessionMode)
-> STM (NetworkConfig, NetworkConfig) -> STM TransportSessionMode
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NetworkConfig -> TransportSessionMode
sessionMode (NetworkConfig -> TransportSessionMode)
-> ((NetworkConfig, NetworkConfig) -> NetworkConfig)
-> (NetworkConfig, NetworkConfig)
-> TransportSessionMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NetworkConfig, NetworkConfig) -> NetworkConfig
forall a b. (a, b) -> b
snd) (STM (NetworkConfig, NetworkConfig) -> STM TransportSessionMode)
-> (AgentClient -> STM (NetworkConfig, NetworkConfig))
-> AgentClient
-> STM TransportSessionMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (NetworkConfig, NetworkConfig)
-> STM (NetworkConfig, NetworkConfig)
forall a. TVar a -> STM a
readTVar (TVar (NetworkConfig, NetworkConfig)
 -> STM (NetworkConfig, NetworkConfig))
-> (AgentClient -> TVar (NetworkConfig, NetworkConfig))
-> AgentClient
-> STM (NetworkConfig, NetworkConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> TVar (NetworkConfig, NetworkConfig)
useNetworkConfig
{-# INLINE getSessionMode #-}

newRcvQueue :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> Bool -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
newRcvQueue :: forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ByteString
-> SMPServerWithAuth
-> VersionRangeSMPC
-> SConnectionMode c
-> Bool
-> SubscriptionMode
-> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, ByteString)
newRcvQueue AgentClient
c NetworkRequestMode
nm UserId
userId ByteString
connId SMPServerWithAuth
srv VersionRangeSMPC
vRange SConnectionMode c
cMode Bool
enableNtfs SubscriptionMode
subMode = do
  let qrd :: ClntQueueReqData
qrd = case SConnectionMode c
cMode of SConnectionMode c
SCMInvitation -> Maybe (CQRData (RecipientId, QueueLinkData)) -> ClntQueueReqData
CQRMessaging Maybe (CQRData (RecipientId, QueueLinkData))
forall a. Maybe a
Nothing; SConnectionMode c
SCMContact -> Maybe (CQRData (RecipientId, (RecipientId, QueueLinkData)))
-> ClntQueueReqData
CQRContact Maybe (CQRData (RecipientId, (RecipientId, QueueLinkData)))
forall a. Maybe a
Nothing
  (RcvPublicDhKey, PrivateKey 'X25519)
e2eKeys <- STM (RcvPublicDhKey, PrivateKey 'X25519)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RcvPublicDhKey, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (RcvPublicDhKey, PrivateKey 'X25519)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (RcvPublicDhKey, PrivateKey 'X25519))
-> (TVar ChaChaDRG -> STM (RcvPublicDhKey, PrivateKey 'X25519))
-> TVar ChaChaDRG
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RcvPublicDhKey, PrivateKey 'X25519)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChaChaDRG -> STM (KeyPair 'X25519)
TVar ChaChaDRG -> STM (RcvPublicDhKey, PrivateKey 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair (TVar ChaChaDRG
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (RcvPublicDhKey, PrivateKey 'X25519))
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RcvPublicDhKey, PrivateKey 'X25519)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env -> TVar ChaChaDRG)
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
random
  AgentClient
-> NetworkRequestMode
-> UserId
-> ByteString
-> SMPServerWithAuth
-> VersionRangeSMPC
-> ClntQueueReqData
-> Bool
-> SubscriptionMode
-> Maybe CbNonce
-> KeyPair 'X25519
-> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, ByteString)
newRcvQueue_ AgentClient
c NetworkRequestMode
nm UserId
userId ByteString
connId SMPServerWithAuth
srv VersionRangeSMPC
vRange ClntQueueReqData
qrd Bool
enableNtfs SubscriptionMode
subMode Maybe CbNonce
forall a. Maybe a
Nothing KeyPair 'X25519
(RcvPublicDhKey, PrivateKey 'X25519)
e2eKeys

data ClntQueueReqData
  = CQRMessaging (Maybe (CQRData (SMP.SenderId, QueueLinkData)))
  | CQRContact (Maybe (CQRData (SMP.LinkId, (SMP.SenderId, QueueLinkData))))

data CQRData r = CQRData
  { forall r. CQRData r -> LinkKey
linkKey :: LinkKey,
    forall r. CQRData r -> PrivateKeyEd25519
privSigKey :: C.PrivateKeyEd25519,
    forall r. CQRData r -> r
srvReq :: r
  }

queueReqData :: ClntQueueReqData -> QueueReqData
queueReqData :: ClntQueueReqData -> QueueReqData
queueReqData = \case
  CQRMessaging Maybe (CQRData (RecipientId, QueueLinkData))
d -> Maybe (RecipientId, QueueLinkData) -> QueueReqData
QRMessaging (Maybe (RecipientId, QueueLinkData) -> QueueReqData)
-> Maybe (RecipientId, QueueLinkData) -> QueueReqData
forall a b. (a -> b) -> a -> b
$ CQRData (RecipientId, QueueLinkData)
-> (RecipientId, QueueLinkData)
forall r. CQRData r -> r
srvReq (CQRData (RecipientId, QueueLinkData)
 -> (RecipientId, QueueLinkData))
-> Maybe (CQRData (RecipientId, QueueLinkData))
-> Maybe (RecipientId, QueueLinkData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CQRData (RecipientId, QueueLinkData))
d
  CQRContact Maybe (CQRData (RecipientId, (RecipientId, QueueLinkData)))
d -> Maybe (RecipientId, (RecipientId, QueueLinkData)) -> QueueReqData
QRContact (Maybe (RecipientId, (RecipientId, QueueLinkData)) -> QueueReqData)
-> Maybe (RecipientId, (RecipientId, QueueLinkData))
-> QueueReqData
forall a b. (a -> b) -> a -> b
$ CQRData (RecipientId, (RecipientId, QueueLinkData))
-> (RecipientId, (RecipientId, QueueLinkData))
forall r. CQRData r -> r
srvReq (CQRData (RecipientId, (RecipientId, QueueLinkData))
 -> (RecipientId, (RecipientId, QueueLinkData)))
-> Maybe (CQRData (RecipientId, (RecipientId, QueueLinkData)))
-> Maybe (RecipientId, (RecipientId, QueueLinkData))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CQRData (RecipientId, (RecipientId, QueueLinkData)))
d

newRcvQueue_ :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> Bool -> SubscriptionMode -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
newRcvQueue_ :: AgentClient
-> NetworkRequestMode
-> UserId
-> ByteString
-> SMPServerWithAuth
-> VersionRangeSMPC
-> ClntQueueReqData
-> Bool
-> SubscriptionMode
-> Maybe CbNonce
-> KeyPair 'X25519
-> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, ByteString)
newRcvQueue_ AgentClient
c NetworkRequestMode
nm UserId
userId ByteString
connId (ProtoServerWithAuth ProtocolServer 'PSMP
srv Maybe BasicAuth
auth) VersionRangeSMPC
vRange ClntQueueReqData
cqrd Bool
enableNtfs SubscriptionMode
subMode Maybe CbNonce
nonce_ (PublicKeyType (PrivateKey 'X25519)
e2eDhKey, PrivateKey 'X25519
e2ePrivKey) = do
  C.AuthAlg SAlgorithm a
a <- (Env -> AuthAlg) -> ExceptT AgentErrorType (ReaderT Env IO) AuthAlg
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (AgentConfig -> AuthAlg
rcvAuthAlg (AgentConfig -> AuthAlg) -> (Env -> AgentConfig) -> Env -> AuthAlg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config)
  TVar ChaChaDRG
g <- (Env -> TVar ChaChaDRG)
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
random
  rKeys :: (APublicAuthKey, SndPrivateAuthKey)
rKeys@(APublicAuthKey
_, SndPrivateAuthKey
rcvPrivateKey) <- STM AAuthKeyPair
-> ExceptT AgentErrorType (ReaderT Env IO) AAuthKeyPair
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AAuthKeyPair
 -> ExceptT AgentErrorType (ReaderT Env IO) AAuthKeyPair)
-> STM AAuthKeyPair
-> ExceptT AgentErrorType (ReaderT Env IO) AAuthKeyPair
forall a b. (a -> b) -> a -> b
$ SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
C.generateAuthKeyPair SAlgorithm a
a TVar ChaChaDRG
g
  (RcvPublicDhKey
dhKey, PrivateKey 'X25519
privDhKey) <- STM (RcvPublicDhKey, PrivateKey 'X25519)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RcvPublicDhKey, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (RcvPublicDhKey, PrivateKey 'X25519)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (RcvPublicDhKey, PrivateKey 'X25519))
-> STM (RcvPublicDhKey, PrivateKey 'X25519)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RcvPublicDhKey, PrivateKey 'X25519)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
g
  ByteString
-> AgentClient
-> ProtocolServer 'PSMP
-> RecipientId
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> RecipientId
-> ByteString
-> m ()
logServer ByteString
"-->" AgentClient
c ProtocolServer 'PSMP
srv RecipientId
NoEntity ByteString
"NEW"
  SMPTransportSession
tSess <- AgentClient
-> UserId
-> ProtoServer BrokerMsg
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) SMPTransportSession
forall (m :: * -> *) msg.
MonadIO m =>
AgentClient
-> UserId
-> ProtoServer msg
-> ByteString
-> m (TransportSession msg)
mkTransportSession AgentClient
c UserId
userId ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv ByteString
connId
  (THandleParams SMPVersion 'TClient
thParams', Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519)
ntfKeys, qik :: QueueIdsKeys
qik@QIK {RecipientId
$sel:rcvId:QIK :: QueueIdsKeys -> RecipientId
rcvId :: RecipientId
rcvId, RecipientId
$sel:sndId:QIK :: QueueIdsKeys -> RecipientId
sndId :: RecipientId
sndId, RcvPublicDhKey
rcvPublicDhKey :: RcvPublicDhKey
$sel:rcvPublicDhKey:QIK :: QueueIdsKeys -> RcvPublicDhKey
rcvPublicDhKey, Maybe QueueMode
$sel:queueMode:QIK :: QueueIdsKeys -> Maybe QueueMode
queueMode :: Maybe QueueMode
queueMode, Maybe RecipientId
serviceId :: Maybe RecipientId
$sel:serviceId:QIK :: QueueIdsKeys -> Maybe RecipientId
serviceId, Maybe ServerNtfCreds
serverNtfCreds :: Maybe ServerNtfCreds
$sel:serverNtfCreds:QIK :: QueueIdsKeys -> Maybe ServerNtfCreds
serverNtfCreds}) <-
    AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> (Client BrokerMsg
    -> ExceptT
         SMPClientError
         IO
         (THandleParams SMPVersion 'TClient,
          Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
          QueueIdsKeys))
-> AM
     (THandleParams SMPVersion 'TClient,
      Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
      QueueIdsKeys)
forall v err msg a.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> (Client msg -> ExceptT (ProtocolClientError err) IO a)
-> AM a
withClient AgentClient
c NetworkRequestMode
nm SMPTransportSession
tSess ((Client BrokerMsg
  -> ExceptT
       SMPClientError
       IO
       (THandleParams SMPVersion 'TClient,
        Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
        QueueIdsKeys))
 -> AM
      (THandleParams SMPVersion 'TClient,
       Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
       QueueIdsKeys))
-> (Client BrokerMsg
    -> ExceptT
         SMPClientError
         IO
         (THandleParams SMPVersion 'TClient,
          Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
          QueueIdsKeys))
-> AM
     (THandleParams SMPVersion 'TClient,
      Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
      QueueIdsKeys)
forall a b. (a -> b) -> a -> b
$ \(SMPConnectedClient SMPClient
smp TMap (ProtocolServer 'PSMP) ProxiedRelayVar
_) -> do
      (Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519)
ntfKeys, Maybe NewNtfCreds
ntfCreds) <- IO (Maybe (AAuthKeyPair, PrivateKey 'X25519), Maybe NewNtfCreds)
-> ExceptT
     SMPClientError
     IO
     (Maybe (AAuthKeyPair, PrivateKey 'X25519), Maybe NewNtfCreds)
forall a. IO a -> ExceptT SMPClientError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (AAuthKeyPair, PrivateKey 'X25519), Maybe NewNtfCreds)
 -> ExceptT
      SMPClientError
      IO
      (Maybe (AAuthKeyPair, PrivateKey 'X25519), Maybe NewNtfCreds))
-> IO (Maybe (AAuthKeyPair, PrivateKey 'X25519), Maybe NewNtfCreds)
-> ExceptT
     SMPClientError
     IO
     (Maybe (AAuthKeyPair, PrivateKey 'X25519), Maybe NewNtfCreds)
forall a b. (a -> b) -> a -> b
$ SAlgorithm a
-> TVar ChaChaDRG
-> SMPClient
-> IO (Maybe (AAuthKeyPair, PrivateKey 'X25519), Maybe NewNtfCreds)
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a
-> TVar ChaChaDRG
-> SMPClient
-> IO (Maybe (AAuthKeyPair, PrivateKey 'X25519), Maybe NewNtfCreds)
mkNtfCreds SAlgorithm a
a TVar ChaChaDRG
g SMPClient
smp
      (SMPClient -> THandleParams SMPVersion 'TClient
forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams SMPClient
smp,Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519)
ntfKeys,) (QueueIdsKeys
 -> (THandleParams SMPVersion 'TClient,
     Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
     QueueIdsKeys))
-> ExceptT SMPClientError IO QueueIdsKeys
-> ExceptT
     SMPClientError
     IO
     (THandleParams SMPVersion 'TClient,
      Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
      QueueIdsKeys)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPClient
-> NetworkRequestMode
-> Maybe CbNonce
-> AAuthKeyPair
-> RcvPublicDhKey
-> Maybe BasicAuth
-> SubscriptionMode
-> QueueReqData
-> Maybe NewNtfCreds
-> ExceptT SMPClientError IO QueueIdsKeys
createSMPQueue SMPClient
smp NetworkRequestMode
nm Maybe CbNonce
nonce_ AAuthKeyPair
(APublicAuthKey, SndPrivateAuthKey)
rKeys RcvPublicDhKey
dhKey Maybe BasicAuth
auth SubscriptionMode
subMode (ClntQueueReqData -> QueueReqData
queueReqData ClntQueueReqData
cqrd) Maybe NewNtfCreds
ntfCreds
  -- TODO [certs rcv] validate that serviceId is the same as in the client session
  IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ByteString -> IO ())
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> AgentClient
-> ProtocolServer 'PSMP
-> RecipientId
-> ByteString
-> IO ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> RecipientId
-> ByteString
-> m ()
logServer ByteString
"<--" AgentClient
c ProtocolServer 'PSMP
srv RecipientId
NoEntity (ByteString -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ByteString -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.unwords [ByteString
Item [ByteString]
"IDS", RecipientId -> ByteString
logSecret RecipientId
rcvId, RecipientId -> ByteString
logSecret RecipientId
sndId]
  Maybe ShortLinkCreds
shortLink <- THandleParams SMPVersion 'TClient
-> QueueIdsKeys -> AM (Maybe ShortLinkCreds)
mkShortLinkCreds THandleParams SMPVersion 'TClient
thParams' QueueIdsKeys
qik
  let rq :: NewRcvQueue
rq =
        RcvQueue
          { UserId
userId :: UserId
$sel:userId:RcvQueue :: UserId
userId,
            ByteString
connId :: ByteString
$sel:connId:RcvQueue :: ByteString
connId,
            $sel:server:RcvQueue :: ProtocolServer 'PSMP
server = ProtocolServer 'PSMP
srv,
            RecipientId
rcvId :: RecipientId
$sel:rcvId:RcvQueue :: RecipientId
rcvId,
            SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: SndPrivateAuthKey
rcvPrivateKey,
            $sel:rcvDhSecret:RcvQueue :: RcvDhSecret
rcvDhSecret = RcvPublicDhKey -> PrivateKey 'X25519 -> RcvDhSecret
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' RcvPublicDhKey
rcvPublicDhKey PrivateKey 'X25519
privDhKey,
            PrivateKey 'X25519
e2ePrivKey :: PrivateKey 'X25519
$sel:e2ePrivKey:RcvQueue :: PrivateKey 'X25519
e2ePrivKey,
            $sel:e2eDhSecret:RcvQueue :: Maybe RcvDhSecret
e2eDhSecret = Maybe RcvDhSecret
forall a. Maybe a
Nothing,
            RecipientId
sndId :: RecipientId
$sel:sndId:RcvQueue :: RecipientId
sndId,
            Maybe QueueMode
queueMode :: Maybe QueueMode
$sel:queueMode:RcvQueue :: Maybe QueueMode
queueMode,
            Maybe ShortLinkCreds
shortLink :: Maybe ShortLinkCreds
$sel:shortLink:RcvQueue :: Maybe ShortLinkCreds
shortLink,
            $sel:clientService:RcvQueue :: Maybe (StoredClientService 'DBNew)
clientService = DBEntityId' 'DBNew -> RecipientId -> StoredClientService 'DBNew
forall (s :: DBStored).
DBEntityId' s -> RecipientId -> StoredClientService s
ClientService DBEntityId' 'DBNew
DBNewEntity (RecipientId -> StoredClientService 'DBNew)
-> Maybe RecipientId -> Maybe (StoredClientService 'DBNew)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RecipientId
serviceId,
            $sel:status:RcvQueue :: QueueStatus
status = QueueStatus
New,
            Bool
enableNtfs :: Bool
$sel:enableNtfs:RcvQueue :: Bool
enableNtfs,
            $sel:clientNoticeId:RcvQueue :: Maybe UserId
clientNoticeId = Maybe UserId
forall a. Maybe a
Nothing,
            $sel:dbQueueId:RcvQueue :: DBEntityId' 'DBNew
dbQueueId = DBEntityId' 'DBNew
DBNewEntity,
            $sel:primary:RcvQueue :: Bool
primary = Bool
True,
            $sel:dbReplaceQueueId:RcvQueue :: Maybe UserId
dbReplaceQueueId = Maybe UserId
forall a. Maybe a
Nothing,
            $sel:rcvSwchStatus:RcvQueue :: Maybe RcvSwitchStatus
rcvSwchStatus = Maybe RcvSwitchStatus
forall a. Maybe a
Nothing,
            $sel:smpClientVersion:RcvQueue :: VersionSMPC
smpClientVersion = VersionRangeSMPC -> VersionSMPC
forall v. VersionRange v -> Version v
maxVersion VersionRangeSMPC
vRange,
            $sel:clientNtfCreds:RcvQueue :: Maybe ClientNtfCreds
clientNtfCreds = Maybe (AAuthKeyPair, PrivateKey 'X25519)
-> Maybe ServerNtfCreds -> Maybe ClientNtfCreds
mkClientNtfCreds Maybe (AAuthKeyPair, PrivateKey 'X25519)
Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519)
ntfKeys Maybe ServerNtfCreds
serverNtfCreds,
            $sel:deleteErrors:RcvQueue :: Int
deleteErrors = Int
0
          }
      qUri :: SMPQueueUri
qUri = VersionRangeSMPC -> SMPQueueAddress -> SMPQueueUri
SMPQueueUri VersionRangeSMPC
vRange (SMPQueueAddress -> SMPQueueUri) -> SMPQueueAddress -> SMPQueueUri
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP
-> RecipientId
-> RcvPublicDhKey
-> Maybe QueueMode
-> SMPQueueAddress
SMPQueueAddress ProtocolServer 'PSMP
srv RecipientId
sndId PublicKeyType (PrivateKey 'X25519)
RcvPublicDhKey
e2eDhKey Maybe QueueMode
queueMode
  (NewRcvQueue, SMPQueueUri,
 (UserId, ProtocolServer 'PSMP, Maybe ByteString), ByteString)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (NewRcvQueue, SMPQueueUri,
      (UserId, ProtocolServer 'PSMP, Maybe ByteString), ByteString)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewRcvQueue
rq, SMPQueueUri
qUri, SMPTransportSession
tSess, THandleParams SMPVersion 'TClient -> ByteString
forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId THandleParams SMPVersion 'TClient
thParams')
  where
    mkNtfCreds :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> TVar ChaChaDRG -> SMPClient -> IO (Maybe (C.AAuthKeyPair, C.PrivateKeyX25519), Maybe NewNtfCreds)
    mkNtfCreds :: forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a
-> TVar ChaChaDRG
-> SMPClient
-> IO (Maybe (AAuthKeyPair, PrivateKey 'X25519), Maybe NewNtfCreds)
mkNtfCreds SAlgorithm a
a TVar ChaChaDRG
g SMPClient
smp
      | Bool
enableNtfs Bool -> Bool -> Bool
&& 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
smp) Version SMPVersion -> Version SMPVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version SMPVersion
newNtfCredsSMPVersion = do
          authKeys :: (APublicAuthKey, SndPrivateAuthKey)
authKeys@(APublicAuthKey
k, SndPrivateAuthKey
_) <- STM AAuthKeyPair -> IO AAuthKeyPair
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AAuthKeyPair -> IO AAuthKeyPair)
-> STM AAuthKeyPair -> IO AAuthKeyPair
forall a b. (a -> b) -> a -> b
$ SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
C.generateAuthKeyPair SAlgorithm a
a TVar ChaChaDRG
g
          (RcvPublicDhKey
dhk, PrivateKey 'X25519
dhpk) <- STM (RcvPublicDhKey, PrivateKey 'X25519)
-> IO (RcvPublicDhKey, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (RcvPublicDhKey, PrivateKey 'X25519)
 -> IO (RcvPublicDhKey, PrivateKey 'X25519))
-> STM (RcvPublicDhKey, PrivateKey 'X25519)
-> IO (RcvPublicDhKey, PrivateKey 'X25519)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
g
          (Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
 Maybe NewNtfCreds)
-> IO
     (Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
      Maybe NewNtfCreds)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519)
-> Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519)
forall a. a -> Maybe a
Just ((APublicAuthKey, SndPrivateAuthKey)
authKeys, PrivateKey 'X25519
dhpk), NewNtfCreds -> Maybe NewNtfCreds
forall a. a -> Maybe a
Just (NewNtfCreds -> Maybe NewNtfCreds)
-> NewNtfCreds -> Maybe NewNtfCreds
forall a b. (a -> b) -> a -> b
$ APublicAuthKey -> RcvPublicDhKey -> NewNtfCreds
NewNtfCreds APublicAuthKey
k RcvPublicDhKey
dhk)
      | Bool
otherwise = (Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
 Maybe NewNtfCreds)
-> IO
     (Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
      Maybe NewNtfCreds)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519)
forall a. Maybe a
Nothing, Maybe NewNtfCreds
forall a. Maybe a
Nothing)
    mkClientNtfCreds :: Maybe (C.AAuthKeyPair, C.PrivateKeyX25519) -> Maybe ServerNtfCreds -> Maybe ClientNtfCreds
    mkClientNtfCreds :: Maybe (AAuthKeyPair, PrivateKey 'X25519)
-> Maybe ServerNtfCreds -> Maybe ClientNtfCreds
mkClientNtfCreds Maybe (AAuthKeyPair, PrivateKey 'X25519)
ntfKeys Maybe ServerNtfCreds
serverNtfCreds = case (Maybe (AAuthKeyPair, PrivateKey 'X25519)
Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519)
ntfKeys, Maybe ServerNtfCreds
serverNtfCreds) of
      (Just ((APublicAuthKey
ntfPublicKey, SndPrivateAuthKey
ntfPrivateKey), PrivateKey 'X25519
dhpk), Just (ServerNtfCreds RecipientId
notifierId RcvPublicDhKey
dhk')) ->
        ClientNtfCreds -> Maybe ClientNtfCreds
forall a. a -> Maybe a
Just ClientNtfCreds {APublicAuthKey
ntfPublicKey :: APublicAuthKey
$sel:ntfPublicKey:ClientNtfCreds :: APublicAuthKey
ntfPublicKey, SndPrivateAuthKey
ntfPrivateKey :: SndPrivateAuthKey
$sel:ntfPrivateKey:ClientNtfCreds :: SndPrivateAuthKey
ntfPrivateKey, RecipientId
notifierId :: RecipientId
$sel:notifierId:ClientNtfCreds :: RecipientId
notifierId, $sel:rcvNtfDhSecret:ClientNtfCreds :: RcvDhSecret
rcvNtfDhSecret = RcvPublicDhKey -> PrivateKey 'X25519 -> RcvDhSecret
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' RcvPublicDhKey
dhk' PrivateKey 'X25519
dhpk}
      (Maybe ((APublicAuthKey, SndPrivateAuthKey), PrivateKey 'X25519),
 Maybe ServerNtfCreds)
_ -> Maybe ClientNtfCreds
forall a. Maybe a
Nothing
    mkShortLinkCreds :: THandleParams SMPVersion 'TClient -> QueueIdsKeys -> AM (Maybe ShortLinkCreds)
    mkShortLinkCreds :: THandleParams SMPVersion 'TClient
-> QueueIdsKeys -> AM (Maybe ShortLinkCreds)
mkShortLinkCreds THandleParams SMPVersion 'TClient
thParams' QIK {RecipientId
$sel:sndId:QIK :: QueueIdsKeys -> RecipientId
sndId :: RecipientId
sndId, Maybe QueueMode
$sel:queueMode:QIK :: QueueIdsKeys -> Maybe QueueMode
queueMode :: Maybe QueueMode
queueMode, Maybe RecipientId
linkId :: Maybe RecipientId
$sel:linkId:QIK :: QueueIdsKeys -> Maybe RecipientId
linkId} = case (ClntQueueReqData
cqrd, Maybe QueueMode
queueMode) of
      (CQRMessaging Maybe (CQRData (RecipientId, QueueLinkData))
ld, Just QueueMode
QMMessaging) ->
        Maybe (CQRData (RecipientId, QueueLinkData))
-> (RecipientId
    -> CQRData (RecipientId, QueueLinkData)
    -> AM (Maybe ShortLinkCreds))
-> AM (Maybe ShortLinkCreds)
forall d.
Maybe d
-> (RecipientId -> d -> AM (Maybe ShortLinkCreds))
-> AM (Maybe ShortLinkCreds)
withLinkData Maybe (CQRData (RecipientId, QueueLinkData))
ld ((RecipientId
  -> CQRData (RecipientId, QueueLinkData)
  -> AM (Maybe ShortLinkCreds))
 -> AM (Maybe ShortLinkCreds))
-> (RecipientId
    -> CQRData (RecipientId, QueueLinkData)
    -> AM (Maybe ShortLinkCreds))
-> AM (Maybe ShortLinkCreds)
forall a b. (a -> b) -> a -> b
$ \RecipientId
lnkId CQRData {LinkKey
$sel:linkKey:CQRData :: forall r. CQRData r -> LinkKey
linkKey :: LinkKey
linkKey, PrivateKeyEd25519
$sel:privSigKey:CQRData :: forall r. CQRData r -> PrivateKeyEd25519
privSigKey :: PrivateKeyEd25519
privSigKey, $sel:srvReq:CQRData :: forall r. CQRData r -> r
srvReq = (RecipientId
sndId', QueueLinkData
d)} ->
          if RecipientId
sndId RecipientId -> RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== RecipientId
sndId'
            then Maybe ShortLinkCreds -> AM (Maybe ShortLinkCreds)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ShortLinkCreds -> AM (Maybe ShortLinkCreds))
-> Maybe ShortLinkCreds -> AM (Maybe ShortLinkCreds)
forall a b. (a -> b) -> a -> b
$ ShortLinkCreds -> Maybe ShortLinkCreds
forall a. a -> Maybe a
Just (ShortLinkCreds -> Maybe ShortLinkCreds)
-> ShortLinkCreds -> Maybe ShortLinkCreds
forall a b. (a -> b) -> a -> b
$ RecipientId
-> LinkKey
-> PrivateKeyEd25519
-> Maybe PublicKeyEd25519
-> EncFixedDataBytes
-> ShortLinkCreds
ShortLinkCreds RecipientId
lnkId LinkKey
linkKey PrivateKeyEd25519
privSigKey Maybe PublicKeyEd25519
forall a. Maybe a
Nothing (QueueLinkData -> EncFixedDataBytes
forall a b. (a, b) -> a
fst QueueLinkData
d)
            else String -> AM (Maybe ShortLinkCreds)
newErr String
"different sender ID"
      (CQRContact Maybe (CQRData (RecipientId, (RecipientId, QueueLinkData)))
ld, Just QueueMode
QMContact) ->
        Maybe (CQRData (RecipientId, (RecipientId, QueueLinkData)))
-> (RecipientId
    -> CQRData (RecipientId, (RecipientId, QueueLinkData))
    -> AM (Maybe ShortLinkCreds))
-> AM (Maybe ShortLinkCreds)
forall d.
Maybe d
-> (RecipientId -> d -> AM (Maybe ShortLinkCreds))
-> AM (Maybe ShortLinkCreds)
withLinkData Maybe (CQRData (RecipientId, (RecipientId, QueueLinkData)))
ld ((RecipientId
  -> CQRData (RecipientId, (RecipientId, QueueLinkData))
  -> AM (Maybe ShortLinkCreds))
 -> AM (Maybe ShortLinkCreds))
-> (RecipientId
    -> CQRData (RecipientId, (RecipientId, QueueLinkData))
    -> AM (Maybe ShortLinkCreds))
-> AM (Maybe ShortLinkCreds)
forall a b. (a -> b) -> a -> b
$ \RecipientId
lnkId CQRData {LinkKey
$sel:linkKey:CQRData :: forall r. CQRData r -> LinkKey
linkKey :: LinkKey
linkKey, PrivateKeyEd25519
$sel:privSigKey:CQRData :: forall r. CQRData r -> PrivateKeyEd25519
privSigKey :: PrivateKeyEd25519
privSigKey, $sel:srvReq:CQRData :: forall r. CQRData r -> r
srvReq = (RecipientId
lnkId', (RecipientId
sndId', QueueLinkData
d))} ->
          if RecipientId
sndId RecipientId -> RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== RecipientId
sndId' Bool -> Bool -> Bool
&& RecipientId
lnkId RecipientId -> RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== RecipientId
lnkId'
            then Maybe ShortLinkCreds -> AM (Maybe ShortLinkCreds)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ShortLinkCreds -> AM (Maybe ShortLinkCreds))
-> Maybe ShortLinkCreds -> AM (Maybe ShortLinkCreds)
forall a b. (a -> b) -> a -> b
$ ShortLinkCreds -> Maybe ShortLinkCreds
forall a. a -> Maybe a
Just (ShortLinkCreds -> Maybe ShortLinkCreds)
-> ShortLinkCreds -> Maybe ShortLinkCreds
forall a b. (a -> b) -> a -> b
$ RecipientId
-> LinkKey
-> PrivateKeyEd25519
-> Maybe PublicKeyEd25519
-> EncFixedDataBytes
-> ShortLinkCreds
ShortLinkCreds RecipientId
lnkId LinkKey
linkKey PrivateKeyEd25519
privSigKey Maybe PublicKeyEd25519
forall a. Maybe a
Nothing (QueueLinkData -> EncFixedDataBytes
forall a b. (a, b) -> a
fst QueueLinkData
d)
            else String -> AM (Maybe ShortLinkCreds)
newErr String
"different sender or link IDs"
      (ClntQueueReqData
_, Maybe QueueMode
Nothing) -> case Maybe RecipientId
linkId of
        Maybe RecipientId
Nothing | Version SMPVersion
v Version SMPVersion -> Version SMPVersion -> Bool
forall a. Ord a => a -> a -> Bool
< Version SMPVersion
sndAuthKeySMPVersion -> Maybe ShortLinkCreds -> AM (Maybe ShortLinkCreds)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ShortLinkCreds
forall a. Maybe a
Nothing
        Maybe RecipientId
_ -> String -> AM (Maybe ShortLinkCreds)
newErr String
"unexpected link ID"
      (ClntQueueReqData, Maybe QueueMode)
_ -> String -> AM (Maybe ShortLinkCreds)
newErr String
"unexpected queue mode"
      where
        v :: Version SMPVersion
v = THandleParams SMPVersion 'TClient -> Version SMPVersion
forall v (p :: TransportPeer). THandleParams v p -> Version v
thVersion THandleParams SMPVersion 'TClient
thParams'
        withLinkData :: Maybe d -> (SMP.LinkId -> d -> AM (Maybe ShortLinkCreds)) -> AM (Maybe ShortLinkCreds)
        withLinkData :: forall d.
Maybe d
-> (RecipientId -> d -> AM (Maybe ShortLinkCreds))
-> AM (Maybe ShortLinkCreds)
withLinkData Maybe d
ld_ RecipientId -> d -> AM (Maybe ShortLinkCreds)
mkLink = case (Maybe d
ld_, Maybe RecipientId
linkId) of
          (Just d
ld, Just RecipientId
lnkId) -> RecipientId -> d -> AM (Maybe ShortLinkCreds)
mkLink RecipientId
lnkId d
ld
          (Just d
_, Maybe RecipientId
Nothing) | Version SMPVersion
v Version SMPVersion -> Version SMPVersion -> Bool
forall a. Ord a => a -> a -> Bool
< Version SMPVersion
shortLinksSMPVersion -> Maybe ShortLinkCreds -> AM (Maybe ShortLinkCreds)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ShortLinkCreds
forall a. Maybe a
Nothing
          (Maybe d
Nothing, Maybe RecipientId
Nothing) -> Maybe ShortLinkCreds -> AM (Maybe ShortLinkCreds)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ShortLinkCreds
forall a. Maybe a
Nothing
          (Maybe d, Maybe RecipientId)
_ -> String -> AM (Maybe ShortLinkCreds)
newErr String
"unexpected or absent link ID"
        newErr :: String -> AM (Maybe ShortLinkCreds)
        newErr :: String -> AM (Maybe ShortLinkCreds)
newErr = AgentErrorType -> AM (Maybe ShortLinkCreds)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (Maybe ShortLinkCreds))
-> (String -> AgentErrorType)
-> String
-> AM (Maybe ShortLinkCreds)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> BrokerErrorType -> AgentErrorType
BROKER (ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtocolServer 'PSMP
srv) (BrokerErrorType -> AgentErrorType)
-> (String -> BrokerErrorType) -> String -> AgentErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> BrokerErrorType
UNEXPECTED (String -> BrokerErrorType)
-> (String -> String) -> String -> BrokerErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Create queue: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)

processSubResults :: AgentClient -> SMPTransportSession -> SessionId -> NonEmpty (RcvQueueSub, Either SMPClientError (Maybe ServiceId)) -> STM [(RcvQueueSub, Maybe ClientNotice)]
processSubResults :: AgentClient
-> SMPTransportSession
-> ByteString
-> NonEmpty
     (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
-> STM [(RcvQueueSub, Maybe ClientNotice)]
processSubResults AgentClient
c tSess :: SMPTransportSession
tSess@(UserId
userId, ProtoServer BrokerMsg
srv, Maybe ByteString
_) ByteString
sessId NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
rs = do
  Map RecipientId RcvQueueSub
pendingSubs <- SMPTransportSession
-> TSessionSubs -> STM (Map RecipientId RcvQueueSub)
SS.getPendingSubs SMPTransportSession
tSess (TSessionSubs -> STM (Map RecipientId RcvQueueSub))
-> TSessionSubs -> STM (Map RecipientId RcvQueueSub)
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
  let (Map RecipientId SMPClientError
failed, [RcvQueueSub]
subscribed, [(RcvQueueSub, Maybe ClientNotice)]
notices, Int
ignored) = ((RcvQueueSub, Either SMPClientError (Maybe RecipientId))
 -> (Map RecipientId SMPClientError, [RcvQueueSub],
     [(RcvQueueSub, Maybe ClientNotice)], Int)
 -> (Map RecipientId SMPClientError, [RcvQueueSub],
     [(RcvQueueSub, Maybe ClientNotice)], Int))
-> (Map RecipientId SMPClientError, [RcvQueueSub],
    [(RcvQueueSub, Maybe ClientNotice)], Int)
-> NonEmpty
     (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
-> (Map RecipientId SMPClientError, [RcvQueueSub],
    [(RcvQueueSub, Maybe ClientNotice)], Int)
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Map RecipientId RcvQueueSub
-> (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
-> (Map RecipientId SMPClientError, [RcvQueueSub],
    [(RcvQueueSub, Maybe ClientNotice)], Int)
-> (Map RecipientId SMPClientError, [RcvQueueSub],
    [(RcvQueueSub, Maybe ClientNotice)], Int)
partitionResults Map RecipientId RcvQueueSub
pendingSubs) (Map RecipientId SMPClientError
forall k a. Map k a
M.empty, [], [], Int
0) NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
rs
  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Map RecipientId SMPClientError -> Bool
forall k a. Map k a -> Bool
M.null Map RecipientId SMPClientError
failed) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
    AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> Int
-> STM ()
incSMPServerStat' AgentClient
c UserId
userId ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv AgentSMPServerStats -> TVar Int
connSubErrs (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$ Map RecipientId SMPClientError -> Int
forall k a. Map k a -> Int
M.size Map RecipientId SMPClientError
failed
    AgentClient
-> SMPTransportSession -> Map RecipientId SMPClientError -> STM ()
failSubscriptions AgentClient
c SMPTransportSession
tSess Map RecipientId SMPClientError
failed
  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([RcvQueueSub] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RcvQueueSub]
subscribed) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
    AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> Int
-> STM ()
incSMPServerStat' AgentClient
c UserId
userId ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv AgentSMPServerStats -> TVar Int
connSubscribed (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$ [RcvQueueSub] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RcvQueueSub]
subscribed
    SMPTransportSession
-> ByteString -> [RcvQueueSub] -> TSessionSubs -> STM ()
SS.batchAddActiveSubs SMPTransportSession
tSess ByteString
sessId [RcvQueueSub]
subscribed (TSessionSubs -> STM ()) -> TSessionSubs -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
ignored Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> Int
-> STM ()
incSMPServerStat' AgentClient
c UserId
userId ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv AgentSMPServerStats -> TVar Int
connSubIgnored Int
ignored
  [(RcvQueueSub, Maybe ClientNotice)]
-> STM [(RcvQueueSub, Maybe ClientNotice)]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(RcvQueueSub, Maybe ClientNotice)]
notices
  where
    partitionResults ::
      Map SMP.RecipientId RcvQueueSub ->
      (RcvQueueSub, Either SMPClientError (Maybe ServiceId)) ->
      (Map SMP.RecipientId SMPClientError, [RcvQueueSub], [(RcvQueueSub, Maybe ClientNotice)], Int) ->
      (Map SMP.RecipientId SMPClientError, [RcvQueueSub], [(RcvQueueSub, Maybe ClientNotice)], Int)
    partitionResults :: Map RecipientId RcvQueueSub
-> (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
-> (Map RecipientId SMPClientError, [RcvQueueSub],
    [(RcvQueueSub, Maybe ClientNotice)], Int)
-> (Map RecipientId SMPClientError, [RcvQueueSub],
    [(RcvQueueSub, Maybe ClientNotice)], Int)
partitionResults Map RecipientId RcvQueueSub
pendingSubs (rq :: RcvQueueSub
rq@RcvQueueSub {RecipientId
rcvId :: RecipientId
$sel:rcvId:RcvQueueSub :: RcvQueueSub -> RecipientId
rcvId, Maybe UserId
clientNoticeId :: Maybe UserId
$sel:clientNoticeId:RcvQueueSub :: RcvQueueSub -> Maybe UserId
clientNoticeId}, Either SMPClientError (Maybe RecipientId)
r) acc :: (Map RecipientId SMPClientError, [RcvQueueSub],
 [(RcvQueueSub, Maybe ClientNotice)], Int)
acc@(Map RecipientId SMPClientError
failed, [RcvQueueSub]
subscribed, [(RcvQueueSub, Maybe ClientNotice)]
notices, Int
ignored) = case Either SMPClientError (Maybe RecipientId)
r of
      Left SMPClientError
e -> case SMPClientError -> Maybe (Maybe ClientNotice)
smpErrorClientNotice SMPClientError
e of
        Just Maybe ClientNotice
notice_ -> (Map RecipientId SMPClientError
failed', [RcvQueueSub]
subscribed, (RcvQueueSub
rq, Maybe ClientNotice
notice_) (RcvQueueSub, Maybe ClientNotice)
-> [(RcvQueueSub, Maybe ClientNotice)]
-> [(RcvQueueSub, Maybe ClientNotice)]
forall a. a -> [a] -> [a]
: [(RcvQueueSub, Maybe ClientNotice)]
notices, Int
ignored)
          where
            notices' :: [(RcvQueueSub, Maybe ClientNotice)]
notices' = if Maybe ClientNotice -> Bool
forall a. Maybe a -> Bool
isJust Maybe ClientNotice
notice_ Bool -> Bool -> Bool
|| Maybe UserId -> Bool
forall a. Maybe a -> Bool
isJust Maybe UserId
clientNoticeId then (RcvQueueSub
rq, Maybe ClientNotice
notice_) (RcvQueueSub, Maybe ClientNotice)
-> [(RcvQueueSub, Maybe ClientNotice)]
-> [(RcvQueueSub, Maybe ClientNotice)]
forall a. a -> [a] -> [a]
: [(RcvQueueSub, Maybe ClientNotice)]
notices else [(RcvQueueSub, Maybe ClientNotice)]
notices
        Maybe (Maybe ClientNotice)
Nothing
          | SMPClientError -> Bool
forall err. ProtocolClientError err -> Bool
temporaryClientError SMPClientError
e -> (Map RecipientId SMPClientError, [RcvQueueSub],
 [(RcvQueueSub, Maybe ClientNotice)], Int)
acc
          | Bool
otherwise -> (Map RecipientId SMPClientError
failed', [RcvQueueSub]
subscribed, [(RcvQueueSub, Maybe ClientNotice)]
notices, Int
ignored)
        where
          failed' :: Map RecipientId SMPClientError
failed' = RecipientId
-> SMPClientError
-> Map RecipientId SMPClientError
-> Map RecipientId SMPClientError
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert RecipientId
rcvId SMPClientError
e Map RecipientId SMPClientError
failed
      Right Maybe RecipientId
_serviceId -- TODO [certs rcv] store association with the service
        | RecipientId
rcvId RecipientId -> Map RecipientId RcvQueueSub -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map RecipientId RcvQueueSub
pendingSubs -> (Map RecipientId SMPClientError
failed, RcvQueueSub
rq RcvQueueSub -> [RcvQueueSub] -> [RcvQueueSub]
forall a. a -> [a] -> [a]
: [RcvQueueSub]
subscribed, [(RcvQueueSub, Maybe ClientNotice)]
notices', Int
ignored)
        | Bool
otherwise -> (Map RecipientId SMPClientError
failed, [RcvQueueSub]
subscribed, [(RcvQueueSub, Maybe ClientNotice)]
notices', Int
ignored Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        where
          notices' :: [(RcvQueueSub, Maybe ClientNotice)]
notices' = if Maybe UserId -> Bool
forall a. Maybe a -> Bool
isJust Maybe UserId
clientNoticeId then (RcvQueueSub
rq, Maybe ClientNotice
forall a. Maybe a
Nothing) (RcvQueueSub, Maybe ClientNotice)
-> [(RcvQueueSub, Maybe ClientNotice)]
-> [(RcvQueueSub, Maybe ClientNotice)]
forall a. a -> [a] -> [a]
: [(RcvQueueSub, Maybe ClientNotice)]
notices else [(RcvQueueSub, Maybe ClientNotice)]
notices

temporaryAgentError :: AgentErrorType -> Bool
temporaryAgentError :: AgentErrorType -> Bool
temporaryAgentError = \case
  BROKER String
_ BrokerErrorType
e -> BrokerErrorType -> Bool
tempBrokerError BrokerErrorType
e
  SMP String
_ (SMP.PROXY (SMP.BROKER BrokerErrorType
e)) -> BrokerErrorType -> Bool
tempBrokerError BrokerErrorType
e
  XFTP String
_ XFTPErrorType
XFTP.TIMEOUT -> Bool
True
  PROXY String
_ String
_ (ProxyProtocolError (SMP.PROXY (SMP.BROKER BrokerErrorType
e))) -> BrokerErrorType -> Bool
tempBrokerError BrokerErrorType
e
  PROXY String
_ String
_ (ProxyProtocolError (SMP.PROXY ProxyError
SMP.NO_SESSION)) -> Bool
True
  AgentErrorType
INACTIVE -> Bool
True
  CRITICAL Bool
True String
_ -> Bool
True -- critical errors that do not show restart button are likely to be permanent
  AgentErrorType
_ -> Bool
False
  where
    tempBrokerError :: BrokerErrorType -> Bool
tempBrokerError = \case
      NETWORK NetworkError
_ -> Bool
True
      BrokerErrorType
TIMEOUT -> Bool
True
      BrokerErrorType
_ -> Bool
False

temporaryOrHostError :: AgentErrorType -> Bool
temporaryOrHostError :: AgentErrorType -> Bool
temporaryOrHostError AgentErrorType
e = AgentErrorType -> Bool
temporaryAgentError AgentErrorType
e Bool -> Bool -> Bool
|| AgentErrorType -> Bool
serverHostError AgentErrorType
e
{-# INLINE temporaryOrHostError #-}

serverHostError :: AgentErrorType -> Bool
serverHostError :: AgentErrorType -> Bool
serverHostError = \case
  BROKER String
_ BrokerErrorType
e -> BrokerErrorType -> Bool
brokerHostError BrokerErrorType
e
  SMP String
_ (SMP.PROXY (SMP.BROKER BrokerErrorType
e)) -> BrokerErrorType -> Bool
brokerHostError BrokerErrorType
e
  PROXY String
_ String
_ (ProxyProtocolError (SMP.PROXY (SMP.BROKER BrokerErrorType
e))) -> BrokerErrorType -> Bool
brokerHostError BrokerErrorType
e
  AgentErrorType
_ -> Bool
False
  where
    brokerHostError :: BrokerErrorType -> Bool
brokerHostError = \case
      BrokerErrorType
HOST -> Bool
True
      SMP.TRANSPORT TransportError
TEVersion -> Bool
True
      BrokerErrorType
_ -> Bool
False

-- | Batch by transport session and subscribe queues. The list of results can have a different order.
subscribeQueues :: AgentClient -> Bool -> [RcvQueueSub] -> AM' [(RcvQueueSub, Either AgentErrorType (Maybe ServiceId))]
subscribeQueues :: AgentClient
-> Bool
-> [RcvQueueSub]
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
subscribeQueues AgentClient
c Bool
withEvents [RcvQueueSub]
qs = do
  ([(RcvQueueSub, AgentErrorType)]
errs, [RcvQueueSub]
qs') <- AgentClient
-> [RcvQueueSub]
-> AM' ([(RcvQueueSub, AgentErrorType)], [RcvQueueSub])
checkQueues AgentClient
c [RcvQueueSub]
qs
  STM () -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Env IO ()) -> STM () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Set ByteString)
-> (Set ByteString -> Set ByteString) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (AgentClient -> TVar (Set ByteString)
subscrConns AgentClient
c) (Set ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => Set a -> Set a -> Set a
`S.union` [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
S.fromList ((RcvQueueSub -> ByteString) -> [RcvQueueSub] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map RcvQueueSub -> ByteString
forall q. SMPQueueRec q => q -> ByteString
qConnId [RcvQueueSub]
qs'))
  [((UserId, ProtocolServer 'PSMP, Maybe ByteString),
  NonEmpty RcvQueueSub)]
qss <- (RcvQueueSub -> TransportSessionMode -> SMPTransportSession)
-> [RcvQueueSub]
-> TransportSessionMode
-> [(SMPTransportSession, NonEmpty RcvQueueSub)]
forall q.
(q -> TransportSessionMode -> SMPTransportSession)
-> [q]
-> TransportSessionMode
-> [(SMPTransportSession, NonEmpty q)]
batchQueues RcvQueueSub -> TransportSessionMode -> SMPTransportSession
forall q.
SMPQueueRec q =>
q -> TransportSessionMode -> SMPTransportSession
mkSMPTSession [RcvQueueSub]
qs' (TransportSessionMode
 -> [((UserId, ProtocolServer 'PSMP, Maybe ByteString),
      NonEmpty RcvQueueSub)])
-> ReaderT Env IO TransportSessionMode
-> ReaderT
     Env
     IO
     [((UserId, ProtocolServer 'PSMP, Maybe ByteString),
       NonEmpty RcvQueueSub)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient -> ReaderT Env IO TransportSessionMode
forall (m :: * -> *).
MonadIO m =>
AgentClient -> m TransportSessionMode
getSessionModeIO AgentClient
c
  (((UserId, ProtocolServer 'PSMP, Maybe ByteString),
  NonEmpty RcvQueueSub)
 -> ReaderT Env IO ())
-> [((UserId, ProtocolServer 'PSMP, Maybe ByteString),
     NonEmpty RcvQueueSub)]
-> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient
-> (SMPTransportSession, NonEmpty RcvQueueSub) -> ReaderT Env IO ()
addPendingSubs AgentClient
c) [((UserId, ProtocolServer 'PSMP, Maybe ByteString),
  NonEmpty RcvQueueSub)]
qss
  [BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)]
rs <- (((UserId, ProtocolServer 'PSMP, Maybe ByteString),
  NonEmpty RcvQueueSub)
 -> ReaderT
      Env
      IO
      (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)))
-> [((UserId, ProtocolServer 'PSMP, Maybe ByteString),
     NonEmpty RcvQueueSub)]
-> ReaderT
     Env
     IO
     [BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
(a -> m b) -> t a -> m (t b)
mapConcurrently (AgentClient
-> Bool
-> (SMPTransportSession, NonEmpty RcvQueueSub)
-> ReaderT
     Env
     IO
     (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId))
subscribeQueues_ AgentClient
c Bool
withEvents) [((UserId, ProtocolServer 'PSMP, Maybe ByteString),
  NonEmpty RcvQueueSub)]
qss
  Bool -> ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
withEvents (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (NonEmpty (RcvQueueSub, AgentErrorType))
-> (NonEmpty (RcvQueueSub, AgentErrorType) -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(RcvQueueSub, AgentErrorType)]
-> Maybe (NonEmpty (RcvQueueSub, AgentErrorType))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [(RcvQueueSub, AgentErrorType)]
errs) ((NonEmpty (RcvQueueSub, AgentErrorType) -> ReaderT Env IO ())
 -> ReaderT Env IO ())
-> (NonEmpty (RcvQueueSub, AgentErrorType) -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> AEvent 'AENone -> ReaderT Env IO ()
forall (m :: * -> *).
MonadIO m =>
AgentClient -> AEvent 'AENone -> m ()
notifySub AgentClient
c (AEvent 'AENone -> ReaderT Env IO ())
-> (NonEmpty (RcvQueueSub, AgentErrorType) -> AEvent 'AENone)
-> NonEmpty (RcvQueueSub, AgentErrorType)
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ByteString, AgentErrorType) -> AEvent 'AENone
ERRS (NonEmpty (ByteString, AgentErrorType) -> AEvent 'AENone)
-> (NonEmpty (RcvQueueSub, AgentErrorType)
    -> NonEmpty (ByteString, AgentErrorType))
-> NonEmpty (RcvQueueSub, AgentErrorType)
-> AEvent 'AENone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RcvQueueSub, AgentErrorType) -> (ByteString, AgentErrorType))
-> NonEmpty (RcvQueueSub, AgentErrorType)
-> NonEmpty (ByteString, AgentErrorType)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map ((RcvQueueSub -> ByteString)
-> (RcvQueueSub, AgentErrorType) -> (ByteString, AgentErrorType)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first RcvQueueSub -> ByteString
forall q. SMPQueueRec q => q -> ByteString
qConnId)
  [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
 -> ReaderT
      Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))])
-> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
forall a b. (a -> b) -> a -> b
$ ((RcvQueueSub, AgentErrorType)
 -> (RcvQueueSub, Either AgentErrorType (Maybe RecipientId)))
-> [(RcvQueueSub, AgentErrorType)]
-> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
forall a b. (a -> b) -> [a] -> [b]
map ((AgentErrorType -> Either AgentErrorType (Maybe RecipientId))
-> (RcvQueueSub, AgentErrorType)
-> (RcvQueueSub, Either AgentErrorType (Maybe RecipientId))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second AgentErrorType -> Either AgentErrorType (Maybe RecipientId)
forall a b. a -> Either a b
Left) [(RcvQueueSub, AgentErrorType)]
errs [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
-> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
-> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
forall a. Semigroup a => a -> a -> a
<> (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
 -> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))])
-> [BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)]
-> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
-> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
forall a. NonEmpty a -> [a]
L.toList [BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)]
rs

addPendingSubs :: AgentClient -> (SMPTransportSession, NonEmpty RcvQueueSub) -> AM' ()
addPendingSubs :: AgentClient
-> (SMPTransportSession, NonEmpty RcvQueueSub) -> ReaderT Env IO ()
addPendingSubs AgentClient
c (SMPTransportSession
tSess, NonEmpty RcvQueueSub
qs') = STM () -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Env IO ()) -> STM () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ SMPTransportSession -> [RcvQueueSub] -> TSessionSubs -> STM ()
SS.batchAddPendingSubs SMPTransportSession
tSess (NonEmpty RcvQueueSub -> [RcvQueueSub]
forall a. NonEmpty a -> [a]
L.toList NonEmpty RcvQueueSub
qs') (TSessionSubs -> STM ()) -> TSessionSubs -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c

subscribeQueues_ :: AgentClient -> Bool -> (SMPTransportSession, NonEmpty RcvQueueSub) -> AM' (BatchResponses RcvQueueSub AgentErrorType (Maybe ServiceId))
subscribeQueues_ :: AgentClient
-> Bool
-> (SMPTransportSession, NonEmpty RcvQueueSub)
-> ReaderT
     Env
     IO
     (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId))
subscribeQueues_ AgentClient
c Bool
withEvents qs' :: (SMPTransportSession, NonEmpty RcvQueueSub)
qs'@(tSess :: SMPTransportSession
tSess@(UserId
_, ProtoServer BrokerMsg
srv, Maybe ByteString
_), NonEmpty RcvQueueSub
_) = do
  (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
rs, Bool
active) <- AgentClient
-> Bool
-> (SMPTransportSession, NonEmpty RcvQueueSub)
-> AM'
     (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId),
      Bool)
subscribeSessQueues_ AgentClient
c Bool
withEvents (SMPTransportSession, NonEmpty RcvQueueSub)
qs'
  if Bool
active
    then Bool -> ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
-> Bool
forall {a} {b}. NonEmpty (a, Either AgentErrorType b) -> Bool
hasTempErrors BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
rs) ReaderT Env IO ()
resubscribe ReaderT Env IO ()
-> BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
-> ReaderT
     Env
     IO
     (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
rs
    else do
      Text -> ReaderT Env IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn Text
"subcription batch result for replaced SMP client, resubscribing"
      -- we use BROKER NETWORK error here instead of the original error, so it becomes temporary.
      ReaderT Env IO ()
resubscribe ReaderT Env IO ()
-> BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
-> ReaderT
     Env
     IO
     (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ((RcvQueueSub, Either AgentErrorType (Maybe RecipientId))
 -> (RcvQueueSub, Either AgentErrorType (Maybe RecipientId)))
-> BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
-> BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map ((Either AgentErrorType (Maybe RecipientId)
 -> Either AgentErrorType (Maybe RecipientId))
-> (RcvQueueSub, Either AgentErrorType (Maybe RecipientId))
-> (RcvQueueSub, Either AgentErrorType (Maybe RecipientId))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Either AgentErrorType (Maybe RecipientId)
  -> Either AgentErrorType (Maybe RecipientId))
 -> (RcvQueueSub, Either AgentErrorType (Maybe RecipientId))
 -> (RcvQueueSub, Either AgentErrorType (Maybe RecipientId)))
-> (Either AgentErrorType (Maybe RecipientId)
    -> Either AgentErrorType (Maybe RecipientId))
-> (RcvQueueSub, Either AgentErrorType (Maybe RecipientId))
-> (RcvQueueSub, Either AgentErrorType (Maybe RecipientId))
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> Either AgentErrorType (Maybe RecipientId)
forall a b. a -> Either a b
Left (AgentErrorType -> Either AgentErrorType (Maybe RecipientId))
-> (Either AgentErrorType (Maybe RecipientId) -> AgentErrorType)
-> Either AgentErrorType (Maybe RecipientId)
-> Either AgentErrorType (Maybe RecipientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either AgentErrorType (Maybe RecipientId) -> AgentErrorType
toNESubscribeError) BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
rs
  where
    -- treating host errors as temporary here as well
    hasTempErrors :: NonEmpty (a, Either AgentErrorType b) -> Bool
hasTempErrors = ((a, Either AgentErrorType b) -> Bool)
-> NonEmpty (a, Either AgentErrorType b) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((AgentErrorType -> Bool)
-> (b -> Bool) -> Either AgentErrorType b -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either AgentErrorType -> Bool
temporaryOrHostError (Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
False) (Either AgentErrorType b -> Bool)
-> ((a, Either AgentErrorType b) -> Either AgentErrorType b)
-> (a, Either AgentErrorType b)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Either AgentErrorType b) -> Either AgentErrorType b
forall a b. (a, b) -> b
snd)
    toNESubscribeError :: Either AgentErrorType (Maybe RecipientId) -> AgentErrorType
toNESubscribeError = String -> BrokerErrorType -> AgentErrorType
BROKER (ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv) (BrokerErrorType -> AgentErrorType)
-> (Either AgentErrorType (Maybe RecipientId) -> BrokerErrorType)
-> Either AgentErrorType (Maybe RecipientId)
-> AgentErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkError -> BrokerErrorType
NETWORK (NetworkError -> BrokerErrorType)
-> (Either AgentErrorType (Maybe RecipientId) -> NetworkError)
-> Either AgentErrorType (Maybe RecipientId)
-> BrokerErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NetworkError
NESubscribeError (String -> NetworkError)
-> (Either AgentErrorType (Maybe RecipientId) -> String)
-> Either AgentErrorType (Maybe RecipientId)
-> NetworkError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either AgentErrorType (Maybe RecipientId) -> String
forall a. Show a => a -> String
show
    resubscribe :: ReaderT Env IO ()
resubscribe = AgentClient -> SMPTransportSession -> ReaderT Env IO ()
resubscribeSMPSession AgentClient
c SMPTransportSession
tSess

subscribeUserServerQueues :: AgentClient -> UserId -> SMPServer -> [RcvQueueSub] -> AM' [(RcvQueueSub, Either AgentErrorType (Maybe ServiceId))]
subscribeUserServerQueues :: AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> [RcvQueueSub]
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
subscribeUserServerQueues AgentClient
c UserId
userId ProtocolServer 'PSMP
srv [RcvQueueSub]
qs = do
  TransportSessionMode
mode <- AgentClient -> ReaderT Env IO TransportSessionMode
forall (m :: * -> *).
MonadIO m =>
AgentClient -> m TransportSessionMode
getSessionModeIO AgentClient
c
  if TransportSessionMode
mode TransportSessionMode -> TransportSessionMode -> Bool
forall a. Eq a => a -> a -> Bool
== TransportSessionMode
TSMEntity
    then AgentClient
-> Bool
-> [RcvQueueSub]
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
subscribeQueues AgentClient
c Bool
True [RcvQueueSub]
qs
    else do
      let tSess :: (UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess = (UserId
userId, ProtocolServer 'PSMP
srv, Maybe ByteString
forall a. Maybe a
Nothing)
      ([(RcvQueueSub, AgentErrorType)]
errs, [RcvQueueSub]
qs_) <- AgentClient
-> [RcvQueueSub]
-> AM' ([(RcvQueueSub, AgentErrorType)], [RcvQueueSub])
checkQueues AgentClient
c [RcvQueueSub]
qs
      Maybe (NonEmpty (RcvQueueSub, AgentErrorType))
-> (NonEmpty (RcvQueueSub, AgentErrorType) -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(RcvQueueSub, AgentErrorType)]
-> Maybe (NonEmpty (RcvQueueSub, AgentErrorType))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [(RcvQueueSub, AgentErrorType)]
errs) ((NonEmpty (RcvQueueSub, AgentErrorType) -> ReaderT Env IO ())
 -> ReaderT Env IO ())
-> (NonEmpty (RcvQueueSub, AgentErrorType) -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> AEvent 'AENone -> ReaderT Env IO ()
forall (m :: * -> *).
MonadIO m =>
AgentClient -> AEvent 'AENone -> m ()
notifySub AgentClient
c (AEvent 'AENone -> ReaderT Env IO ())
-> (NonEmpty (RcvQueueSub, AgentErrorType) -> AEvent 'AENone)
-> NonEmpty (RcvQueueSub, AgentErrorType)
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ByteString, AgentErrorType) -> AEvent 'AENone
ERRS (NonEmpty (ByteString, AgentErrorType) -> AEvent 'AENone)
-> (NonEmpty (RcvQueueSub, AgentErrorType)
    -> NonEmpty (ByteString, AgentErrorType))
-> NonEmpty (RcvQueueSub, AgentErrorType)
-> AEvent 'AENone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RcvQueueSub, AgentErrorType) -> (ByteString, AgentErrorType))
-> NonEmpty (RcvQueueSub, AgentErrorType)
-> NonEmpty (ByteString, AgentErrorType)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map ((RcvQueueSub -> ByteString)
-> (RcvQueueSub, AgentErrorType) -> (ByteString, AgentErrorType)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first RcvQueueSub -> ByteString
forall q. SMPQueueRec q => q -> ByteString
qConnId)
      let errs' :: [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
errs' = ((RcvQueueSub, AgentErrorType)
 -> (RcvQueueSub, Either AgentErrorType (Maybe RecipientId)))
-> [(RcvQueueSub, AgentErrorType)]
-> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
forall a b. (a -> b) -> [a] -> [b]
map ((AgentErrorType -> Either AgentErrorType (Maybe RecipientId))
-> (RcvQueueSub, AgentErrorType)
-> (RcvQueueSub, Either AgentErrorType (Maybe RecipientId))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second AgentErrorType -> Either AgentErrorType (Maybe RecipientId)
forall a b. a -> Either a b
Left) [(RcvQueueSub, AgentErrorType)]
errs
      case [RcvQueueSub] -> Maybe (NonEmpty RcvQueueSub)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [RcvQueueSub]
qs_ of
        Just NonEmpty RcvQueueSub
qs' -> do
          STM () -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Env IO ()) -> STM () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Set ByteString)
-> (Set ByteString -> Set ByteString) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (AgentClient -> TVar (Set ByteString)
subscrConns AgentClient
c) (Set ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => Set a -> Set a -> Set a
`S.union` [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
S.fromList ((RcvQueueSub -> ByteString) -> [RcvQueueSub] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map RcvQueueSub -> ByteString
forall q. SMPQueueRec q => q -> ByteString
qConnId ([RcvQueueSub] -> [ByteString]) -> [RcvQueueSub] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ NonEmpty RcvQueueSub -> [RcvQueueSub]
forall a. NonEmpty a -> [a]
L.toList NonEmpty RcvQueueSub
qs'))
          AgentClient
-> (SMPTransportSession, NonEmpty RcvQueueSub) -> ReaderT Env IO ()
addPendingSubs AgentClient
c (SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess, NonEmpty RcvQueueSub
qs')
          BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
rs <- AgentClient
-> Bool
-> (SMPTransportSession, NonEmpty RcvQueueSub)
-> ReaderT
     Env
     IO
     (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId))
subscribeQueues_ AgentClient
c Bool
True (SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess, NonEmpty RcvQueueSub
qs')
          [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
 -> ReaderT
      Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))])
-> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
forall a b. (a -> b) -> a -> b
$ [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
errs' [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
-> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
-> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
forall a. Semigroup a => a -> a -> a
<> BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
-> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
forall a. NonEmpty a -> [a]
L.toList BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
rs
        Maybe (NonEmpty RcvQueueSub)
Nothing -> [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(RcvQueueSub, Either AgentErrorType (Maybe RecipientId))]
errs'

-- only "checked" queues are subscribed
checkQueues :: AgentClient -> [RcvQueueSub] -> AM' ([(RcvQueueSub, AgentErrorType)], [RcvQueueSub])
checkQueues :: AgentClient
-> [RcvQueueSub]
-> AM' ([(RcvQueueSub, AgentErrorType)], [RcvQueueSub])
checkQueues AgentClient
c = ([Either (RcvQueueSub, AgentErrorType) RcvQueueSub]
 -> ([(RcvQueueSub, AgentErrorType)], [RcvQueueSub]))
-> ReaderT
     Env IO [Either (RcvQueueSub, AgentErrorType) RcvQueueSub]
-> AM' ([(RcvQueueSub, AgentErrorType)], [RcvQueueSub])
forall a b. (a -> b) -> ReaderT Env IO a -> ReaderT Env IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either (RcvQueueSub, AgentErrorType) RcvQueueSub]
-> ([(RcvQueueSub, AgentErrorType)], [RcvQueueSub])
forall a b. [Either a b] -> ([a], [b])
partitionEithers (ReaderT Env IO [Either (RcvQueueSub, AgentErrorType) RcvQueueSub]
 -> AM' ([(RcvQueueSub, AgentErrorType)], [RcvQueueSub]))
-> ([RcvQueueSub]
    -> ReaderT
         Env IO [Either (RcvQueueSub, AgentErrorType) RcvQueueSub])
-> [RcvQueueSub]
-> AM' ([(RcvQueueSub, AgentErrorType)], [RcvQueueSub])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RcvQueueSub
 -> ReaderT
      Env IO (Either (RcvQueueSub, AgentErrorType) RcvQueueSub))
-> [RcvQueueSub]
-> ReaderT
     Env IO [Either (RcvQueueSub, AgentErrorType) RcvQueueSub]
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 RcvQueueSub
-> ReaderT
     Env IO (Either (RcvQueueSub, AgentErrorType) RcvQueueSub)
checkQueue
  where
    checkQueue :: RcvQueueSub
-> ReaderT
     Env IO (Either (RcvQueueSub, AgentErrorType) RcvQueueSub)
checkQueue RcvQueueSub
rq = do
      Bool
prohibited <- IO Bool -> ReaderT Env IO Bool
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ReaderT Env IO Bool) -> IO Bool -> ReaderT Env IO Bool
forall a b. (a -> b) -> a -> b
$ AgentClient -> RcvQueueSub -> IO Bool
forall q. SomeRcvQueue q => AgentClient -> q -> IO Bool
hasGetLock AgentClient
c RcvQueueSub
rq
      Either (RcvQueueSub, AgentErrorType) RcvQueueSub
-> ReaderT
     Env IO (Either (RcvQueueSub, AgentErrorType) RcvQueueSub)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (RcvQueueSub, AgentErrorType) RcvQueueSub
 -> ReaderT
      Env IO (Either (RcvQueueSub, AgentErrorType) RcvQueueSub))
-> Either (RcvQueueSub, AgentErrorType) RcvQueueSub
-> ReaderT
     Env IO (Either (RcvQueueSub, AgentErrorType) RcvQueueSub)
forall a b. (a -> b) -> a -> b
$ if Bool
prohibited then (RcvQueueSub, AgentErrorType)
-> Either (RcvQueueSub, AgentErrorType) RcvQueueSub
forall a b. a -> Either a b
Left (RcvQueueSub
rq, CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"checkQueues") else RcvQueueSub -> Either (RcvQueueSub, AgentErrorType) RcvQueueSub
forall a b. b -> Either a b
Right RcvQueueSub
rq

-- This function expects that all queues belong to one transport session,
-- and that they are already added to pending subscriptions.
resubscribeSessQueues :: AgentClient -> SMPTransportSession -> [RcvQueueSub] -> AM' ()
resubscribeSessQueues :: AgentClient
-> SMPTransportSession -> [RcvQueueSub] -> ReaderT Env IO ()
resubscribeSessQueues AgentClient
c SMPTransportSession
tSess [RcvQueueSub]
qs = do
  Int
batchSize <- (Env -> Int) -> ReaderT Env IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> Int) -> ReaderT Env IO Int)
-> (Env -> Int) -> ReaderT Env IO Int
forall a b. (a -> b) -> a -> b
$ AgentConfig -> Int
subsBatchSize (AgentConfig -> Int) -> (Env -> AgentConfig) -> Env -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  ([(RcvQueueSub, AgentErrorType)]
errs, [RcvQueueSub]
qs_) <- AgentClient
-> [RcvQueueSub]
-> AM' ([(RcvQueueSub, AgentErrorType)], [RcvQueueSub])
checkQueues AgentClient
c [RcvQueueSub]
qs
  [NonEmpty RcvQueueSub] -> ReaderT Env IO ()
subscribeChunks ([NonEmpty RcvQueueSub] -> ReaderT Env IO ())
-> [NonEmpty RcvQueueSub] -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ Int -> [RcvQueueSub] -> [NonEmpty RcvQueueSub]
forall a. Int -> [a] -> [NonEmpty a]
toChunks Int
batchSize [RcvQueueSub]
qs_
  Maybe (NonEmpty (RcvQueueSub, AgentErrorType))
-> (NonEmpty (RcvQueueSub, AgentErrorType) -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(RcvQueueSub, AgentErrorType)]
-> Maybe (NonEmpty (RcvQueueSub, AgentErrorType))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [(RcvQueueSub, AgentErrorType)]
errs) ((NonEmpty (RcvQueueSub, AgentErrorType) -> ReaderT Env IO ())
 -> ReaderT Env IO ())
-> (NonEmpty (RcvQueueSub, AgentErrorType) -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> AEvent 'AENone -> ReaderT Env IO ()
forall (m :: * -> *).
MonadIO m =>
AgentClient -> AEvent 'AENone -> m ()
notifySub AgentClient
c (AEvent 'AENone -> ReaderT Env IO ())
-> (NonEmpty (RcvQueueSub, AgentErrorType) -> AEvent 'AENone)
-> NonEmpty (RcvQueueSub, AgentErrorType)
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ByteString, AgentErrorType) -> AEvent 'AENone
ERRS (NonEmpty (ByteString, AgentErrorType) -> AEvent 'AENone)
-> (NonEmpty (RcvQueueSub, AgentErrorType)
    -> NonEmpty (ByteString, AgentErrorType))
-> NonEmpty (RcvQueueSub, AgentErrorType)
-> AEvent 'AENone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RcvQueueSub, AgentErrorType) -> (ByteString, AgentErrorType))
-> NonEmpty (RcvQueueSub, AgentErrorType)
-> NonEmpty (ByteString, AgentErrorType)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map ((RcvQueueSub -> ByteString)
-> (RcvQueueSub, AgentErrorType) -> (ByteString, AgentErrorType)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first RcvQueueSub -> ByteString
forall q. SMPQueueRec q => q -> ByteString
qConnId)
  where
    subscribeChunks :: [NonEmpty RcvQueueSub] -> ReaderT Env IO ()
subscribeChunks [] = () -> ReaderT Env IO ()
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    subscribeChunks (NonEmpty RcvQueueSub
qs' : [NonEmpty RcvQueueSub]
rest) = do
      (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId)
_, Bool
active) <- AgentClient
-> Bool
-> (SMPTransportSession, NonEmpty RcvQueueSub)
-> AM'
     (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId),
      Bool)
subscribeSessQueues_ AgentClient
c Bool
True (SMPTransportSession
tSess, NonEmpty RcvQueueSub
qs')
      Bool -> ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
active (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ [NonEmpty RcvQueueSub] -> ReaderT Env IO ()
subscribeChunks [NonEmpty RcvQueueSub]
rest

subscribeSessQueues_ :: AgentClient -> Bool -> (SMPTransportSession, NonEmpty RcvQueueSub) -> AM' (BatchResponses RcvQueueSub AgentErrorType (Maybe ServiceId), Bool)
subscribeSessQueues_ :: AgentClient
-> Bool
-> (SMPTransportSession, NonEmpty RcvQueueSub)
-> AM'
     (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId),
      Bool)
subscribeSessQueues_ AgentClient
c Bool
withEvents (SMPTransportSession, NonEmpty RcvQueueSub)
qs = ByteString
-> Bool
-> (SMPClient
    -> NonEmpty RcvQueueSub
    -> IO
         (NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId)),
          Bool))
-> AgentClient
-> NetworkRequestMode
-> (SMPTransportSession, NonEmpty RcvQueueSub)
-> AM'
     (BatchResponses RcvQueueSub AgentErrorType (Maybe RecipientId),
      Bool)
forall res q r.
ByteString
-> res
-> (SMPClient
    -> NonEmpty q -> IO (BatchResponses q SMPClientError r, res))
-> AgentClient
-> NetworkRequestMode
-> (SMPTransportSession, NonEmpty q)
-> AM' (BatchResponses q AgentErrorType r, res)
sendClientBatch_ ByteString
"SUB" Bool
False SMPClient
-> NonEmpty RcvQueueSub
-> IO
     (NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId)),
      Bool)
subscribe_ AgentClient
c NetworkRequestMode
NRMBackground (SMPTransportSession, NonEmpty RcvQueueSub)
qs
  where
    subscribe_ :: SMPClient -> NonEmpty RcvQueueSub -> IO (BatchResponses RcvQueueSub SMPClientError (Maybe ServiceId), Bool)
    subscribe_ :: SMPClient
-> NonEmpty RcvQueueSub
-> IO
     (NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId)),
      Bool)
subscribe_ SMPClient
smp NonEmpty RcvQueueSub
qs' = do
      let (UserId
userId, ProtoServer BrokerMsg
srv, Maybe ByteString
_) = SMPTransportSession
tSess
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> Int
-> STM ()
incSMPServerStat' AgentClient
c UserId
userId ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv AgentSMPServerStats -> TVar Int
connSubAttempts (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$ NonEmpty RcvQueueSub -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty RcvQueueSub
qs'
      NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
rs <- (SMPClient
 -> NetworkRequestMode
 -> NonEmpty (RecipientId, SndPrivateAuthKey)
 -> IO (NonEmpty (Either SMPClientError (Maybe RecipientId))))
-> SMPClient
-> NetworkRequestMode
-> NonEmpty RcvQueueSub
-> IO
     (NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId)))
forall q a.
SomeRcvQueue q =>
(SMPClient
 -> NetworkRequestMode
 -> NonEmpty (RecipientId, SndPrivateAuthKey)
 -> IO (NonEmpty (Either SMPClientError a)))
-> SMPClient
-> NetworkRequestMode
-> NonEmpty q
-> IO (BatchResponses q SMPClientError a)
sendBatch (\SMPClient
smp' NetworkRequestMode
_ -> SMPClient
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError (Maybe RecipientId)))
subscribeSMPQueues SMPClient
smp') SMPClient
smp NetworkRequestMode
NRMBackground NonEmpty RcvQueueSub
qs'
      Maybe (Set ByteString)
cs_ <-
        if Bool
withEvents
          then Set ByteString -> Maybe (Set ByteString)
forall a. a -> Maybe a
Just (Set ByteString -> Maybe (Set ByteString))
-> (Map RecipientId RcvQueueSub -> Set ByteString)
-> Map RecipientId RcvQueueSub
-> Maybe (Set ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
S.fromList ([ByteString] -> Set ByteString)
-> (Map RecipientId RcvQueueSub -> [ByteString])
-> Map RecipientId RcvQueueSub
-> Set ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RcvQueueSub -> ByteString) -> [RcvQueueSub] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map RcvQueueSub -> ByteString
forall q. SMPQueueRec q => q -> ByteString
qConnId ([RcvQueueSub] -> [ByteString])
-> (Map RecipientId RcvQueueSub -> [RcvQueueSub])
-> Map RecipientId RcvQueueSub
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RecipientId RcvQueueSub -> [RcvQueueSub]
forall k a. Map k a -> [a]
M.elems (Map RecipientId RcvQueueSub -> Maybe (Set ByteString))
-> IO (Map RecipientId RcvQueueSub) -> IO (Maybe (Set ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Map RecipientId RcvQueueSub)
-> IO (Map RecipientId RcvQueueSub)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (SMPTransportSession
-> TSessionSubs -> STM (Map RecipientId RcvQueueSub)
SS.getActiveSubs SMPTransportSession
tSess (TSessionSubs -> STM (Map RecipientId RcvQueueSub))
-> TSessionSubs -> STM (Map RecipientId RcvQueueSub)
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c)
          else Maybe (Set ByteString) -> IO (Maybe (Set ByteString))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Set ByteString)
forall a. Maybe a
Nothing
      Bool
active <- IO Bool -> IO Bool
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
E.uninterruptibleMask_ (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
        (Bool
active, [(RcvQueueSub, Maybe ClientNotice)]
notices) <- STM (Bool, [(RcvQueueSub, Maybe ClientNotice)])
-> IO (Bool, [(RcvQueueSub, Maybe ClientNotice)])
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Bool, [(RcvQueueSub, Maybe ClientNotice)])
 -> IO (Bool, [(RcvQueueSub, Maybe ClientNotice)]))
-> STM (Bool, [(RcvQueueSub, Maybe ClientNotice)])
-> IO (Bool, [(RcvQueueSub, Maybe ClientNotice)])
forall a b. (a -> b) -> a -> b
$ do
          r :: (Bool, [(RcvQueueSub, Maybe ClientNotice)])
r@(Bool
_, [(RcvQueueSub, Maybe ClientNotice)]
notices) <- STM Bool
-> STM (Bool, [(RcvQueueSub, Maybe ClientNotice)])
-> STM (Bool, [(RcvQueueSub, Maybe ClientNotice)])
-> STM (Bool, [(RcvQueueSub, Maybe ClientNotice)])
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
            (AgentClient -> SMPTransportSession -> ByteString -> STM Bool
activeClientSession AgentClient
c SMPTransportSession
tSess ByteString
sessId)
            ((Bool
True,) ([(RcvQueueSub, Maybe ClientNotice)]
 -> (Bool, [(RcvQueueSub, Maybe ClientNotice)]))
-> STM [(RcvQueueSub, Maybe ClientNotice)]
-> STM (Bool, [(RcvQueueSub, Maybe ClientNotice)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> SMPTransportSession
-> ByteString
-> NonEmpty
     (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
-> STM [(RcvQueueSub, Maybe ClientNotice)]
processSubResults AgentClient
c SMPTransportSession
tSess ByteString
sessId NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
rs)
            ((Bool
False, []) (Bool, [(RcvQueueSub, Maybe ClientNotice)])
-> STM () -> STM (Bool, [(RcvQueueSub, Maybe ClientNotice)])
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> Int
-> STM ()
incSMPServerStat' AgentClient
c UserId
userId ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv AgentSMPServerStats -> TVar Int
connSubIgnored (NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
-> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
rs))
          Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(RcvQueueSub, Maybe ClientNotice)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RcvQueueSub, Maybe ClientNotice)]
notices) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar (TMVar () -> STM ()) -> TMVar () -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMVar ()
clientNoticesLock AgentClient
c
          (Bool, [(RcvQueueSub, Maybe ClientNotice)])
-> STM (Bool, [(RcvQueueSub, Maybe ClientNotice)])
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool, [(RcvQueueSub, Maybe ClientNotice)])
r
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(RcvQueueSub, Maybe ClientNotice)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RcvQueueSub, Maybe ClientNotice)]
notices) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          (AgentClient
-> SMPTransportSession
-> [(RcvQueueSub, Maybe ClientNotice)]
-> ReaderT Env IO ()
processClientNotices AgentClient
c SMPTransportSession
tSess [(RcvQueueSub, Maybe ClientNotice)]
notices ReaderT Env IO () -> Env -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` AgentClient -> Env
agentEnv AgentClient
c)
            IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`E.finally` STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (AgentClient -> TMVar ()
clientNoticesLock AgentClient
c) ())
        Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
active
      Maybe (Set ByteString) -> (Set ByteString -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Set ByteString)
cs_ ((Set ByteString -> IO ()) -> IO ())
-> (Set ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Set ByteString
cs -> do
        let ([(ByteString, SMPClientError)]
errs, [ByteString]
okConns) = [Either (ByteString, SMPClientError) ByteString]
-> ([(ByteString, SMPClientError)], [ByteString])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (ByteString, SMPClientError) ByteString]
 -> ([(ByteString, SMPClientError)], [ByteString]))
-> [Either (ByteString, SMPClientError) ByteString]
-> ([(ByteString, SMPClientError)], [ByteString])
forall a b. (a -> b) -> a -> b
$ ((RcvQueueSub, Either SMPClientError (Maybe RecipientId))
 -> Either (ByteString, SMPClientError) ByteString)
-> [(RcvQueueSub, Either SMPClientError (Maybe RecipientId))]
-> [Either (ByteString, SMPClientError) ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\(RcvQueueSub {ByteString
connId :: ByteString
$sel:connId:RcvQueueSub :: RcvQueueSub -> ByteString
connId}, Either SMPClientError (Maybe RecipientId)
r) -> (SMPClientError -> (ByteString, SMPClientError))
-> (Maybe RecipientId -> ByteString)
-> Either SMPClientError (Maybe RecipientId)
-> Either (ByteString, SMPClientError) ByteString
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ByteString
connId,) (ByteString -> Maybe RecipientId -> ByteString
forall a b. a -> b -> a
const ByteString
connId) Either SMPClientError (Maybe RecipientId)
r) ([(RcvQueueSub, Either SMPClientError (Maybe RecipientId))]
 -> [Either (ByteString, SMPClientError) ByteString])
-> [(RcvQueueSub, Either SMPClientError (Maybe RecipientId))]
-> [Either (ByteString, SMPClientError) ByteString]
forall a b. (a -> b) -> a -> b
$ NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
-> [(RcvQueueSub, Either SMPClientError (Maybe RecipientId))]
forall a. NonEmpty a -> [a]
L.toList NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
rs
            conns :: [ByteString]
conns = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString -> Set ByteString -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set ByteString
cs) [ByteString]
okConns
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
conns) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> AEvent 'AENone -> IO ()
forall (m :: * -> *).
MonadIO m =>
AgentClient -> AEvent 'AENone -> m ()
notifySub AgentClient
c (AEvent 'AENone -> IO ()) -> AEvent 'AENone -> IO ()
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP -> [ByteString] -> AEvent 'AENone
UP ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv [ByteString]
conns
        Maybe (NonEmpty (ByteString, SMPClientError))
-> (NonEmpty (ByteString, SMPClientError) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(ByteString, SMPClientError)]
-> Maybe (NonEmpty (ByteString, SMPClientError))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [(ByteString, SMPClientError)]
errs) ((NonEmpty (ByteString, SMPClientError) -> IO ()) -> IO ())
-> (NonEmpty (ByteString, SMPClientError) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty (ByteString, SMPClientError)
errs' -> do
          let noFinalErrs :: Bool
noFinalErrs = ((ByteString, SMPClientError) -> Bool)
-> NonEmpty (ByteString, SMPClientError) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (SMPClientError -> Bool
forall err. ProtocolClientError err -> Bool
temporaryClientError (SMPClientError -> Bool)
-> ((ByteString, SMPClientError) -> SMPClientError)
-> (ByteString, SMPClientError)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, SMPClientError) -> SMPClientError
forall a b. (a, b) -> b
snd) NonEmpty (ByteString, SMPClientError)
errs'
              addr :: String
addr = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ProtocolServer 'PSMP -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv
          AgentClient -> AEvent 'AENone -> IO ()
forall (m :: * -> *).
MonadIO m =>
AgentClient -> AEvent 'AENone -> m ()
notifySub AgentClient
c (AEvent 'AENone -> IO ()) -> AEvent 'AENone -> IO ()
forall a b. (a -> b) -> a -> b
$ NonEmpty (ByteString, AgentErrorType) -> AEvent 'AENone
ERRS (NonEmpty (ByteString, AgentErrorType) -> AEvent 'AENone)
-> NonEmpty (ByteString, AgentErrorType) -> AEvent 'AENone
forall a b. (a -> b) -> a -> b
$ ((ByteString, SMPClientError) -> (ByteString, AgentErrorType))
-> NonEmpty (ByteString, SMPClientError)
-> NonEmpty (ByteString, AgentErrorType)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map ((SMPClientError -> AgentErrorType)
-> (ByteString, SMPClientError) -> (ByteString, AgentErrorType)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((SMPClientError -> AgentErrorType)
 -> (ByteString, SMPClientError) -> (ByteString, AgentErrorType))
-> (SMPClientError -> AgentErrorType)
-> (ByteString, SMPClientError)
-> (ByteString, AgentErrorType)
forall a b. (a -> b) -> a -> b
$ (String -> ErrorType -> AgentErrorType)
-> String -> SMPClientError -> AgentErrorType
forall err.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
protocolClientError String -> ErrorType -> AgentErrorType
SMP String
addr) NonEmpty (ByteString, SMPClientError)
errs'
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
okConns Bool -> Bool -> Bool
&& Set ByteString -> Bool
forall a. Set a -> Bool
S.null Set ByteString
cs Bool -> Bool -> Bool
&& Bool
noFinalErrs Bool -> Bool -> Bool
&& Bool
active) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ do
            -- We only close the client session that was used to subscribe.
            Maybe
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
v_ <- STM
  (Maybe
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> IO
     (Maybe
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM
   (Maybe
      (SessionVar
         (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
 -> IO
      (Maybe
         (SessionVar
            (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))))
-> STM
     (Maybe
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> IO
     (Maybe
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall a b. (a -> b) -> a -> b
$ STM Bool
-> STM
     (Maybe
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> STM
     (Maybe
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> STM
     (Maybe
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (AgentClient -> SMPTransportSession -> ByteString -> STM Bool
activeClientSession AgentClient
c SMPTransportSession
tSess ByteString
sessId) (SMPTransportSession
-> TMap SMPTransportSession SMPClientVar
-> STM (Maybe SMPClientVar)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookupDelete SMPTransportSession
tSess (TMap SMPTransportSession SMPClientVar -> STM (Maybe SMPClientVar))
-> TMap SMPTransportSession SMPClientVar
-> STM (Maybe SMPClientVar)
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients AgentClient
c) (Maybe
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> STM
     (Maybe
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
forall a. Maybe a
Nothing)
            (SessionVar
   (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
 -> IO ())
-> Maybe
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient -> SMPClientVar -> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient -> ClientVar msg -> IO ()
closeClient_ AgentClient
c) Maybe
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
v_
      (NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId)),
 Bool)
-> IO
     (NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId)),
      Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (RcvQueueSub, Either SMPClientError (Maybe RecipientId))
rs, Bool
active)
      where
        tSess :: SMPTransportSession
tSess = SMPClient -> SMPTransportSession
forall v err msg. ProtocolClient v err msg -> TransportSession msg
transportSession' SMPClient
smp
        sessId :: ByteString
sessId = THandleParams SMPVersion 'TClient -> ByteString
forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId (THandleParams SMPVersion 'TClient -> ByteString)
-> THandleParams SMPVersion 'TClient -> ByteString
forall a b. (a -> b) -> a -> b
$ SMPClient -> THandleParams SMPVersion 'TClient
forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams SMPClient
smp

processClientNotices :: AgentClient -> SMPTransportSession -> [(RcvQueueSub, Maybe ClientNotice)] -> AM' ()
processClientNotices :: AgentClient
-> SMPTransportSession
-> [(RcvQueueSub, Maybe ClientNotice)]
-> ReaderT Env IO ()
processClientNotices c :: AgentClient
c@AgentClient {[ProtocolServer 'PSMP]
$sel:presetServers:AgentClient :: AgentClient -> [ProtocolServer 'PSMP]
presetServers :: [ProtocolServer 'PSMP]
presetServers} SMPTransportSession
tSess [(RcvQueueSub, Maybe ClientNotice)]
notices = do
  SystemSeconds
now <- IO SystemSeconds -> ReaderT Env IO SystemSeconds
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemSeconds
getSystemSeconds
  ExceptT
  AgentErrorType
  (ReaderT Env IO)
  ([(RecipientId, Maybe UserId)],
   Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds))
-> ReaderT
     Env
     IO
     (Either
        AgentErrorType
        ([(RecipientId, Maybe UserId)],
         Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (AgentClient
-> (Connection
    -> IO
         ([(RecipientId, Maybe UserId)],
          Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     ([(RecipientId, Maybe UserId)],
      Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds))
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection
  -> IO
       ([(RecipientId, Maybe UserId)],
        Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)))
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      ([(RecipientId, Maybe UserId)],
       Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)))
-> (Connection
    -> IO
         ([(RecipientId, Maybe UserId)],
          Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     ([(RecipientId, Maybe UserId)],
      Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> (,) ([(RecipientId, Maybe UserId)]
 -> Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
 -> ([(RecipientId, Maybe UserId)],
     Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)))
-> IO [(RecipientId, Maybe UserId)]
-> IO
     (Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
      -> ([(RecipientId, Maybe UserId)],
          Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> SMPTransportSession
-> SystemSeconds
-> [(RcvQueueSub, Maybe ClientNotice)]
-> IO [(RecipientId, Maybe UserId)]
updateClientNotices Connection
db SMPTransportSession
tSess SystemSeconds
now [(RcvQueueSub, Maybe ClientNotice)]
notices IO
  (Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
   -> ([(RecipientId, Maybe UserId)],
       Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)))
-> IO (Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds))
-> IO
     ([(RecipientId, Maybe UserId)],
      Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Connection
-> [ProtocolServer 'PSMP]
-> IO (Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds))
getClientNotices Connection
db [ProtocolServer 'PSMP]
presetServers) ReaderT
  Env
  IO
  (Either
     AgentErrorType
     ([(RecipientId, Maybe UserId)],
      Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)))
-> (Either
      AgentErrorType
      ([(RecipientId, Maybe UserId)],
       Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds))
    -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall a b.
ReaderT Env IO a -> (a -> ReaderT Env IO b) -> ReaderT Env IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right ([(RecipientId, Maybe UserId)]
noticeIds, Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
clntNotices) -> STM () -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Env IO ()) -> STM () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ do
      SMPTransportSession
-> [(RecipientId, Maybe UserId)] -> TSessionSubs -> STM ()
SS.updateClientNotices SMPTransportSession
tSess [(RecipientId, Maybe UserId)]
noticeIds (TSessionSubs -> STM ()) -> TSessionSubs -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
      TMap (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
-> Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
-> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (AgentClient
-> TMap (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
clientNotices AgentClient
c) Map (Maybe (ProtocolServer 'PSMP)) (Maybe SystemSeconds)
clntNotices
    Left AgentErrorType
e -> do
      Text -> ReaderT Env IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> ReaderT Env IO ()) -> Text -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ Text
"processClientNotices error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AgentErrorType -> Text
forall a. Show a => a -> Text
tshow AgentErrorType
e
      AgentClient -> ByteString -> AEvent 'AEConn -> ReaderT Env IO ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AgentClient -> ByteString -> AEvent e -> m ()
notifySub' AgentClient
c ByteString
"" (AEvent 'AEConn -> ReaderT Env IO ())
-> AEvent 'AEConn -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> AEvent 'AEConn
ERR AgentErrorType
e

activeClientSession :: AgentClient -> SMPTransportSession -> SessionId -> STM Bool
activeClientSession :: AgentClient -> SMPTransportSession -> ByteString -> STM Bool
activeClientSession AgentClient
c SMPTransportSession
tSess ByteString
sessId = Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> Bool
sameSess (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
 -> Bool)
-> STM
     (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> TMap
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> STM
     (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
forall k a. Ord k => k -> TMap k (SessionVar a) -> STM (Maybe a)
tryReadSessVar SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess (AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients AgentClient
c)
  where
    sameSess :: Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> Bool
sameSess = \case
      Just (Right (SMPConnectedClient SMPClient
smp TMap (ProtocolServer 'PSMP) ProxiedRelayVar
_)) -> ByteString
sessId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== THandleParams SMPVersion 'TClient -> ByteString
forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId (SMPClient -> THandleParams SMPVersion 'TClient
forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams SMPClient
smp)
      Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
_ -> Bool
False

type BatchResponses q e r = NonEmpty (q, Either e r)

-- Please note: this function does not preserve order of results to be the same as the order of arguments,
-- it includes arguments in the results instead.
sendTSessionBatches :: forall q r. ByteString -> (q -> TransportSessionMode -> SMPTransportSession) -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> NetworkRequestMode -> [q] -> AM' [(q, Either AgentErrorType r)]
sendTSessionBatches :: forall q r.
ByteString
-> (q -> TransportSessionMode -> SMPTransportSession)
-> (SMPClient
    -> NonEmpty q -> IO (BatchResponses q SMPClientError r))
-> AgentClient
-> NetworkRequestMode
-> [q]
-> AM' [(q, Either AgentErrorType r)]
sendTSessionBatches ByteString
statCmd q -> TransportSessionMode -> SMPTransportSession
mkSession SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)
action AgentClient
c NetworkRequestMode
nm [q]
qs = do
  [((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)]
qs' <- (q -> TransportSessionMode -> SMPTransportSession)
-> [q]
-> TransportSessionMode
-> [(SMPTransportSession, NonEmpty q)]
forall q.
(q -> TransportSessionMode -> SMPTransportSession)
-> [q]
-> TransportSessionMode
-> [(SMPTransportSession, NonEmpty q)]
batchQueues q -> TransportSessionMode -> SMPTransportSession
mkSession [q]
qs (TransportSessionMode
 -> [((UserId, ProtocolServer 'PSMP, Maybe ByteString),
      NonEmpty q)])
-> ReaderT Env IO TransportSessionMode
-> ReaderT
     Env
     IO
     [((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient -> ReaderT Env IO TransportSessionMode
forall (m :: * -> *).
MonadIO m =>
AgentClient -> m TransportSessionMode
getSessionModeIO AgentClient
c
  (NonEmpty (q, Either AgentErrorType r)
 -> [(q, Either AgentErrorType r)])
-> [NonEmpty (q, Either AgentErrorType r)]
-> [(q, Either AgentErrorType r)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty (q, Either AgentErrorType r)
-> [(q, Either AgentErrorType r)]
forall a. NonEmpty a -> [a]
L.toList ([NonEmpty (q, Either AgentErrorType r)]
 -> [(q, Either AgentErrorType r)])
-> ReaderT Env IO [NonEmpty (q, Either AgentErrorType r)]
-> AM' [(q, Either AgentErrorType r)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)
 -> ReaderT Env IO (NonEmpty (q, Either AgentErrorType r)))
-> [((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)]
-> ReaderT Env IO [NonEmpty (q, Either AgentErrorType r)]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
(a -> m b) -> t a -> m (t b)
mapConcurrently (ByteString
-> (SMPClient
    -> NonEmpty q -> IO (BatchResponses q SMPClientError r))
-> AgentClient
-> NetworkRequestMode
-> (SMPTransportSession, NonEmpty q)
-> ReaderT Env IO (NonEmpty (q, Either AgentErrorType r))
forall q r.
ByteString
-> (SMPClient
    -> NonEmpty q -> IO (BatchResponses q SMPClientError r))
-> AgentClient
-> NetworkRequestMode
-> (SMPTransportSession, NonEmpty q)
-> AM' (BatchResponses q AgentErrorType r)
sendClientBatch ByteString
statCmd SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)
action AgentClient
c NetworkRequestMode
nm) [((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)]
qs'

batchQueues :: (q -> TransportSessionMode -> SMPTransportSession) -> [q] -> TransportSessionMode -> [(SMPTransportSession, NonEmpty q)]
batchQueues :: forall q.
(q -> TransportSessionMode -> SMPTransportSession)
-> [q]
-> TransportSessionMode
-> [(SMPTransportSession, NonEmpty q)]
batchQueues q -> TransportSessionMode -> SMPTransportSession
mkSession [q]
qs TransportSessionMode
mode = Map SMPTransportSession (NonEmpty q)
-> [(SMPTransportSession, NonEmpty q)]
forall k a. Map k a -> [(k, a)]
M.assocs (Map SMPTransportSession (NonEmpty q)
 -> [(SMPTransportSession, NonEmpty q)])
-> Map SMPTransportSession (NonEmpty q)
-> [(SMPTransportSession, NonEmpty q)]
forall a b. (a -> b) -> a -> b
$ (q
 -> Map
      (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q)
 -> Map
      (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q))
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q)
-> [q]
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr q
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q)
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q)
batch Map (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q)
forall k a. Map k a
M.empty [q]
qs
  where
    batch :: q
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q)
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q)
batch q
q Map (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q)
m =
      let tSess :: SMPTransportSession
tSess = q -> TransportSessionMode -> SMPTransportSession
mkSession q
q TransportSessionMode
mode
       in (Maybe (NonEmpty q) -> Maybe (NonEmpty q))
-> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q)
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (NonEmpty q -> Maybe (NonEmpty q)
forall a. a -> Maybe a
Just (NonEmpty q -> Maybe (NonEmpty q))
-> (Maybe (NonEmpty q) -> NonEmpty q)
-> Maybe (NonEmpty q)
-> Maybe (NonEmpty q)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty q
-> (NonEmpty q -> NonEmpty q) -> Maybe (NonEmpty q) -> NonEmpty q
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [q
Item (NonEmpty q)
q] (q
q q -> NonEmpty q -> NonEmpty q
forall a. a -> NonEmpty a -> NonEmpty a
<|)) SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess Map (UserId, ProtocolServer 'PSMP, Maybe ByteString) (NonEmpty q)
m

sendClientBatch :: ByteString -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> NetworkRequestMode -> (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses q AgentErrorType r)
sendClientBatch :: forall q r.
ByteString
-> (SMPClient
    -> NonEmpty q -> IO (BatchResponses q SMPClientError r))
-> AgentClient
-> NetworkRequestMode
-> (SMPTransportSession, NonEmpty q)
-> AM' (BatchResponses q AgentErrorType r)
sendClientBatch ByteString
statCmd SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)
action = ((BatchResponses q AgentErrorType r, ())
 -> BatchResponses q AgentErrorType r)
-> ReaderT Env IO (BatchResponses q AgentErrorType r, ())
-> AM' (BatchResponses q AgentErrorType r)
forall a b. (a -> b) -> ReaderT Env IO a -> ReaderT Env IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BatchResponses q AgentErrorType r, ())
-> BatchResponses q AgentErrorType r
forall a b. (a, b) -> a
fst (ReaderT Env IO (BatchResponses q AgentErrorType r, ())
 -> AM' (BatchResponses q AgentErrorType r))
-> (AgentClient
    -> NetworkRequestMode
    -> ((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)
    -> ReaderT Env IO (BatchResponses q AgentErrorType r, ()))
-> AgentClient
-> NetworkRequestMode
-> ((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)
-> AM' (BatchResponses q AgentErrorType r)
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. ByteString
-> ()
-> (SMPClient
    -> NonEmpty q -> IO (BatchResponses q SMPClientError r, ()))
-> AgentClient
-> NetworkRequestMode
-> (SMPTransportSession, NonEmpty q)
-> ReaderT Env IO (BatchResponses q AgentErrorType r, ())
forall res q r.
ByteString
-> res
-> (SMPClient
    -> NonEmpty q -> IO (BatchResponses q SMPClientError r, res))
-> AgentClient
-> NetworkRequestMode
-> (SMPTransportSession, NonEmpty q)
-> AM' (BatchResponses q AgentErrorType r, res)
sendClientBatch_ ByteString
statCmd () ((BatchResponses q SMPClientError r
 -> (BatchResponses q SMPClientError r, ()))
-> IO (BatchResponses q SMPClientError r)
-> IO (BatchResponses q SMPClientError r, ())
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,()) (IO (BatchResponses q SMPClientError r)
 -> IO (BatchResponses q SMPClientError r, ()))
-> (SMPClient
    -> NonEmpty q -> IO (BatchResponses q SMPClientError r))
-> SMPClient
-> NonEmpty q
-> IO (BatchResponses q SMPClientError r, ())
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)
action)
{-# INLINE sendClientBatch #-}

sendClientBatch_ :: ByteString -> res -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r, res)) -> AgentClient -> NetworkRequestMode -> (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses q AgentErrorType r, res)
sendClientBatch_ :: forall res q r.
ByteString
-> res
-> (SMPClient
    -> NonEmpty q -> IO (BatchResponses q SMPClientError r, res))
-> AgentClient
-> NetworkRequestMode
-> (SMPTransportSession, NonEmpty q)
-> AM' (BatchResponses q AgentErrorType r, res)
sendClientBatch_ ByteString
statCmd res
errRes SMPClient
-> NonEmpty q -> IO (BatchResponses q SMPClientError r, res)
action AgentClient
c NetworkRequestMode
nm (tSess :: SMPTransportSession
tSess@(UserId
_, ProtoServer BrokerMsg
srv, Maybe ByteString
_), NonEmpty q
qs') =
  AM SMPConnectedClient
-> ReaderT Env IO (Either AgentErrorType SMPConnectedClient)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (AgentClient
-> NetworkRequestMode
-> SMPTransportSession
-> AM SMPConnectedClient
getSMPServerClient AgentClient
c NetworkRequestMode
nm SMPTransportSession
tSess) ReaderT Env IO (Either AgentErrorType SMPConnectedClient)
-> (Either AgentErrorType SMPConnectedClient
    -> ReaderT Env IO (BatchResponses q AgentErrorType r, res))
-> ReaderT Env IO (BatchResponses q AgentErrorType r, res)
forall a b.
ReaderT Env IO a -> (a -> ReaderT Env IO b) -> ReaderT Env IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left AgentErrorType
e -> (BatchResponses q AgentErrorType r, res)
-> ReaderT Env IO (BatchResponses q AgentErrorType r, res)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((q -> (q, Either AgentErrorType r))
-> NonEmpty q -> BatchResponses q AgentErrorType r
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (,AgentErrorType -> Either AgentErrorType r
forall a b. a -> Either a b
Left AgentErrorType
e) NonEmpty q
qs', res
errRes)
    Right (SMPConnectedClient SMPClient
smp TMap (ProtocolServer 'PSMP) ProxiedRelayVar
_) -> IO (BatchResponses q AgentErrorType r, res)
-> ReaderT Env IO (BatchResponses q AgentErrorType r, res)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (BatchResponses q AgentErrorType r, res)
 -> ReaderT Env IO (BatchResponses q AgentErrorType r, res))
-> IO (BatchResponses q AgentErrorType r, res)
-> ReaderT Env IO (BatchResponses q AgentErrorType r, res)
forall a b. (a -> b) -> a -> b
$ do
      ByteString
-> AgentClient
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> IO ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> ByteString
-> ByteString
-> m ()
logServer' ByteString
"-->" AgentClient
c ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv (Int -> ByteString
forall a. Show a => a -> ByteString
bshow (NonEmpty q -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty q
qs') ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" queues") ByteString
statCmd
      (BatchResponses q SMPClientError r
 -> BatchResponses q AgentErrorType r)
-> (BatchResponses q SMPClientError r, res)
-> (BatchResponses q AgentErrorType r, res)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (((q, Either SMPClientError r) -> (q, Either AgentErrorType r))
-> BatchResponses q SMPClientError r
-> BatchResponses q AgentErrorType r
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (q, Either SMPClientError r) -> (q, Either AgentErrorType r)
agentError) ((BatchResponses q SMPClientError r, res)
 -> (BatchResponses q AgentErrorType r, res))
-> IO (BatchResponses q SMPClientError r, res)
-> IO (BatchResponses q AgentErrorType r, res)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPClient
-> NonEmpty q -> IO (BatchResponses q SMPClientError r, res)
action SMPClient
smp NonEmpty q
qs'
      where
        agentError :: (q, Either SMPClientError r) -> (q, Either AgentErrorType r)
agentError = (Either SMPClientError r -> Either AgentErrorType r)
-> (q, Either SMPClientError r) -> (q, Either AgentErrorType r)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Either SMPClientError r -> Either AgentErrorType r)
 -> (q, Either SMPClientError r) -> (q, Either AgentErrorType r))
-> ((SMPClientError -> AgentErrorType)
    -> Either SMPClientError r -> Either AgentErrorType r)
-> (SMPClientError -> AgentErrorType)
-> (q, Either SMPClientError r)
-> (q, Either AgentErrorType r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SMPClientError -> AgentErrorType)
-> Either SMPClientError r -> Either AgentErrorType r
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((SMPClientError -> AgentErrorType)
 -> (q, Either SMPClientError r) -> (q, Either AgentErrorType r))
-> (SMPClientError -> AgentErrorType)
-> (q, Either SMPClientError r)
-> (q, Either AgentErrorType r)
forall a b. (a -> b) -> a -> b
$ (String -> ErrorType -> AgentErrorType)
-> String -> SMPClientError -> AgentErrorType
forall err.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
protocolClientError String -> ErrorType -> AgentErrorType
SMP (String -> SMPClientError -> AgentErrorType)
-> String -> SMPClientError -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B.unpack (ProtocolServer 'PSMP -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv)

sendBatch :: SomeRcvQueue q => (SMPClient -> NetworkRequestMode -> NonEmpty (SMP.RecipientId, SMP.RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError a))) -> SMPClient -> NetworkRequestMode -> NonEmpty q -> IO (BatchResponses q SMPClientError a)
sendBatch :: forall q a.
SomeRcvQueue q =>
(SMPClient
 -> NetworkRequestMode
 -> NonEmpty (RecipientId, SndPrivateAuthKey)
 -> IO (NonEmpty (Either SMPClientError a)))
-> SMPClient
-> NetworkRequestMode
-> NonEmpty q
-> IO (BatchResponses q SMPClientError a)
sendBatch SMPClient
-> NetworkRequestMode
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError a))
smpCmdFunc SMPClient
smp NetworkRequestMode
nm NonEmpty q
qs = NonEmpty q
-> NonEmpty (Either SMPClientError a)
-> NonEmpty (q, Either SMPClientError a)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
L.zip NonEmpty q
qs (NonEmpty (Either SMPClientError a)
 -> NonEmpty (q, Either SMPClientError a))
-> IO (NonEmpty (Either SMPClientError a))
-> IO (NonEmpty (q, Either SMPClientError a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPClient
-> NetworkRequestMode
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError a))
smpCmdFunc SMPClient
smp NetworkRequestMode
nm ((q -> (RecipientId, SndPrivateAuthKey))
-> NonEmpty q -> NonEmpty (RecipientId, SndPrivateAuthKey)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map q -> (RecipientId, SndPrivateAuthKey)
forall {q}. SomeRcvQueue q => q -> (RecipientId, SndPrivateAuthKey)
queueCreds NonEmpty q
qs)
  where
    queueCreds :: q -> (RecipientId, SndPrivateAuthKey)
queueCreds q
q = (q -> RecipientId
forall q. SMPQueue q => q -> RecipientId
queueId q
q, q -> SndPrivateAuthKey
forall q. SomeRcvQueue q => q -> SndPrivateAuthKey
rcvAuthKey q
q)

failSubscription :: SomeRcvQueue q => AgentClient -> SMPTransportSession -> q -> SMPClientError -> STM ()
failSubscription :: forall q.
SomeRcvQueue q =>
AgentClient -> SMPTransportSession -> q -> SMPClientError -> STM ()
failSubscription AgentClient
c SMPTransportSession
tSess q
rq SMPClientError
e = do
  let rId :: RecipientId
rId = q -> RecipientId
forall q. SMPQueue q => q -> RecipientId
queueId q
rq
  RecipientId
-> SMPClientError -> TMap RecipientId SMPClientError -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RecipientId
rId SMPClientError
e (TMap RecipientId SMPClientError -> STM ())
-> STM (TMap RecipientId SMPClientError) -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AgentClient
-> (UserId, ProtocolServer 'PSMP)
-> STM (TMap RecipientId SMPClientError)
getRemovedSubs AgentClient
c (q -> UserId
forall q. SMPQueueRec q => q -> UserId
qUserId q
rq, q -> ProtocolServer 'PSMP
forall q. SMPQueue q => q -> ProtocolServer 'PSMP
qServer q
rq)
  SMPTransportSession -> RecipientId -> TSessionSubs -> STM ()
SS.deletePendingSub SMPTransportSession
tSess RecipientId
rId (TSessionSubs -> STM ()) -> TSessionSubs -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c

failSubscriptions :: AgentClient -> SMPTransportSession -> Map SMP.RecipientId SMPClientError -> STM ()
failSubscriptions :: AgentClient
-> SMPTransportSession -> Map RecipientId SMPClientError -> STM ()
failSubscriptions AgentClient
c tSess :: SMPTransportSession
tSess@(UserId
uId, ProtoServer BrokerMsg
srv, Maybe ByteString
_) Map RecipientId SMPClientError
qs = do
  Map RecipientId SMPClientError
-> TMap RecipientId SMPClientError -> STM ()
forall k a. Ord k => Map k a -> TMap k a -> STM ()
TM.union Map RecipientId SMPClientError
qs (TMap RecipientId SMPClientError -> STM ())
-> STM (TMap RecipientId SMPClientError) -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AgentClient
-> (UserId, ProtocolServer 'PSMP)
-> STM (TMap RecipientId SMPClientError)
getRemovedSubs AgentClient
c (UserId
uId, ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv)
  SMPTransportSession -> Set RecipientId -> TSessionSubs -> STM ()
SS.batchDeletePendingSubs SMPTransportSession
tSess (Map RecipientId SMPClientError -> Set RecipientId
forall k a. Map k a -> Set k
M.keysSet Map RecipientId SMPClientError
qs) (TSessionSubs -> STM ()) -> TSessionSubs -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c

getRemovedSubs :: AgentClient -> (UserId, SMPServer) -> STM (TMap SMP.RecipientId SMPClientError)
getRemovedSubs :: AgentClient
-> (UserId, ProtocolServer 'PSMP)
-> STM (TMap RecipientId SMPClientError)
getRemovedSubs AgentClient {TMap
  (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
$sel:removedSubs:AgentClient :: AgentClient
-> TMap
     (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
removedSubs :: TMap
  (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
removedSubs} (UserId, ProtocolServer 'PSMP)
k = (UserId, ProtocolServer 'PSMP)
-> TMap
     (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
-> STM (Maybe (TMap RecipientId SMPClientError))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup (UserId, ProtocolServer 'PSMP)
k TMap
  (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
removedSubs STM (Maybe (TMap RecipientId SMPClientError))
-> (Maybe (TMap RecipientId SMPClientError)
    -> STM (TMap RecipientId SMPClientError))
-> STM (TMap RecipientId SMPClientError)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM (TMap RecipientId SMPClientError)
-> (TMap RecipientId SMPClientError
    -> STM (TMap RecipientId SMPClientError))
-> Maybe (TMap RecipientId SMPClientError)
-> STM (TMap RecipientId SMPClientError)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM (TMap RecipientId SMPClientError)
new TMap RecipientId SMPClientError
-> STM (TMap RecipientId SMPClientError)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    new :: STM (TMap RecipientId SMPClientError)
new = do
      TMap RecipientId SMPClientError
s <- Map RecipientId SMPClientError
-> STM (TMap RecipientId SMPClientError)
forall a. a -> STM (TVar a)
newTVar Map RecipientId SMPClientError
forall k a. Map k a
M.empty
      (UserId, ProtocolServer 'PSMP)
-> TMap RecipientId SMPClientError
-> TMap
     (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
-> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert (UserId, ProtocolServer 'PSMP)
k TMap RecipientId SMPClientError
s TMap
  (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
removedSubs
      TMap RecipientId SMPClientError
-> STM (TMap RecipientId SMPClientError)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMap RecipientId SMPClientError
s

addNewQueueSubscription :: AgentClient -> RcvQueue -> SMPTransportSession -> SessionId -> AM' ()
addNewQueueSubscription :: AgentClient
-> RcvQueue
-> SMPTransportSession
-> ByteString
-> ReaderT Env IO ()
addNewQueueSubscription AgentClient
c RcvQueue
rq' SMPTransportSession
tSess ByteString
sessId = do
  let rq :: RcvQueueSub
rq = RcvQueue -> RcvQueueSub
rcvQueueSub RcvQueue
rq'
  Bool
same <- STM Bool -> ReaderT Env IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ReaderT Env IO Bool)
-> STM Bool -> ReaderT Env IO Bool
forall a b. (a -> b) -> a -> b
$ do
    TVar (Set ByteString)
-> (Set ByteString -> Set ByteString) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (AgentClient -> TVar (Set ByteString)
subscrConns AgentClient
c) ((Set ByteString -> Set ByteString) -> STM ())
-> (Set ByteString -> Set ByteString) -> STM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => a -> Set a -> Set a
S.insert (ByteString -> Set ByteString -> Set ByteString)
-> ByteString -> Set ByteString -> Set ByteString
forall a b. (a -> b) -> a -> b
$ RcvQueueSub -> ByteString
forall q. SMPQueueRec q => q -> ByteString
qConnId RcvQueueSub
rq
    Bool
active <- AgentClient -> SMPTransportSession -> ByteString -> STM Bool
activeClientSession AgentClient
c SMPTransportSession
tSess ByteString
sessId
    if Bool
active
      then SMPTransportSession
-> ByteString -> RcvQueueSub -> TSessionSubs -> STM ()
SS.addActiveSub SMPTransportSession
tSess ByteString
sessId RcvQueueSub
rq (TSessionSubs -> STM ()) -> TSessionSubs -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
      else SMPTransportSession -> RcvQueueSub -> TSessionSubs -> STM ()
SS.addPendingSub SMPTransportSession
tSess RcvQueueSub
rq (TSessionSubs -> STM ()) -> TSessionSubs -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
    Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
active
  Bool -> ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
same (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> SMPTransportSession -> ReaderT Env IO ()
resubscribeSMPSession AgentClient
c SMPTransportSession
tSess

hasActiveSubscription :: SomeRcvQueue q => AgentClient -> q -> STM Bool
hasActiveSubscription :: forall q. SomeRcvQueue q => AgentClient -> q -> STM Bool
hasActiveSubscription AgentClient
c q
rq = do
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess <- AgentClient -> q -> STM SMPTransportSession
forall q.
SMPQueueRec q =>
AgentClient -> q -> STM SMPTransportSession
mkSMPTransportSession AgentClient
c q
rq
  SMPTransportSession -> RecipientId -> TSessionSubs -> STM Bool
SS.hasActiveSub SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess (q -> RecipientId
forall q. SMPQueue q => q -> RecipientId
queueId q
rq) (TSessionSubs -> STM Bool) -> TSessionSubs -> STM Bool
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
{-# INLINE hasActiveSubscription #-}

hasPendingSubscription :: SomeRcvQueue q => AgentClient -> q -> STM Bool
hasPendingSubscription :: forall q. SomeRcvQueue q => AgentClient -> q -> STM Bool
hasPendingSubscription AgentClient
c q
rq = do
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess <- AgentClient -> q -> STM SMPTransportSession
forall q.
SMPQueueRec q =>
AgentClient -> q -> STM SMPTransportSession
mkSMPTransportSession AgentClient
c q
rq
  SMPTransportSession -> RecipientId -> TSessionSubs -> STM Bool
SS.hasPendingSub SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess (q -> RecipientId
forall q. SMPQueue q => q -> RecipientId
queueId q
rq) (TSessionSubs -> STM Bool) -> TSessionSubs -> STM Bool
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
{-# INLINE hasPendingSubscription #-}

hasRemovedSubscription :: SomeRcvQueue q => AgentClient -> q -> STM (Maybe SMPClientError)
hasRemovedSubscription :: forall q.
SomeRcvQueue q =>
AgentClient -> q -> STM (Maybe SMPClientError)
hasRemovedSubscription AgentClient
c q
rq = do
  (UserId, ProtocolServer 'PSMP)
-> TMap
     (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
-> STM (Maybe (TMap RecipientId SMPClientError))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup (q -> UserId
forall q. SMPQueueRec q => q -> UserId
qUserId q
rq, q -> ProtocolServer 'PSMP
forall q. SMPQueue q => q -> ProtocolServer 'PSMP
qServer q
rq) (AgentClient
-> TMap
     (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
removedSubs AgentClient
c) STM (Maybe (TMap RecipientId SMPClientError))
-> (TMap RecipientId SMPClientError -> STM (Maybe SMPClientError))
-> STM (Maybe SMPClientError)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= RecipientId
-> TMap RecipientId SMPClientError -> STM (Maybe SMPClientError)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup (q -> RecipientId
forall q. SMPQueue q => q -> RecipientId
queueId q
rq)

removeSubscription :: SomeRcvQueue q => AgentClient -> SMPTransportSession -> ConnId -> q -> STM ()
removeSubscription :: forall q.
SomeRcvQueue q =>
AgentClient -> SMPTransportSession -> ByteString -> q -> STM ()
removeSubscription AgentClient
c SMPTransportSession
tSess ByteString
connId q
rq = do
  TVar (Set ByteString)
-> (Set ByteString -> Set ByteString) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (AgentClient -> TVar (Set ByteString)
subscrConns AgentClient
c) ((Set ByteString -> Set ByteString) -> STM ())
-> (Set ByteString -> Set ByteString) -> STM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => a -> Set a -> Set a
S.delete ByteString
connId
  SMPTransportSession -> RecipientId -> TSessionSubs -> STM ()
SS.deleteSub SMPTransportSession
tSess (q -> RecipientId
forall q. SMPQueue q => q -> RecipientId
queueId q
rq) (TSessionSubs -> STM ()) -> TSessionSubs -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c

removeSubscriptions :: SomeRcvQueue q => AgentClient -> [ConnId] -> [q] -> STM ()
removeSubscriptions :: forall q.
SomeRcvQueue q =>
AgentClient -> [ByteString] -> [q] -> STM ()
removeSubscriptions AgentClient
c [ByteString]
connIds [q]
qs = do
  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
connIds) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TVar (Set ByteString)
-> (Set ByteString -> Set ByteString) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (AgentClient -> TVar (Set ByteString)
subscrConns AgentClient
c) (Set ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` ([ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
S.fromList [ByteString]
connIds))
  [((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)]
qss <- (q -> TransportSessionMode -> SMPTransportSession)
-> [q]
-> TransportSessionMode
-> [(SMPTransportSession, NonEmpty q)]
forall q.
(q -> TransportSessionMode -> SMPTransportSession)
-> [q]
-> TransportSessionMode
-> [(SMPTransportSession, NonEmpty q)]
batchQueues q -> TransportSessionMode -> SMPTransportSession
forall q.
SMPQueueRec q =>
q -> TransportSessionMode -> SMPTransportSession
mkSMPTSession [q]
qs (TransportSessionMode
 -> [((UserId, ProtocolServer 'PSMP, Maybe ByteString),
      NonEmpty q)])
-> STM TransportSessionMode
-> STM
     [((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient -> STM TransportSessionMode
getSessionMode AgentClient
c
  [((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)]
-> (((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)
    -> STM ())
-> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)]
qss ((((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)
  -> STM ())
 -> STM ())
-> (((UserId, ProtocolServer 'PSMP, Maybe ByteString), NonEmpty q)
    -> STM ())
-> STM ()
forall a b. (a -> b) -> a -> b
$ \((UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess, NonEmpty q
qs') -> SMPTransportSession -> [q] -> TSessionSubs -> STM ()
forall q.
SomeRcvQueue q =>
SMPTransportSession -> [q] -> TSessionSubs -> STM ()
SS.batchDeleteSubs SMPTransportSession
(UserId, ProtocolServer 'PSMP, Maybe ByteString)
tSess (NonEmpty q -> [q]
forall a. NonEmpty a -> [a]
L.toList NonEmpty q
qs') (TSessionSubs -> STM ()) -> TSessionSubs -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c

getSubscriptions :: AgentClient -> IO (Set ConnId)
getSubscriptions :: AgentClient -> IO (Set ByteString)
getSubscriptions = TVar (Set ByteString) -> IO (Set ByteString)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (Set ByteString) -> IO (Set ByteString))
-> (AgentClient -> TVar (Set ByteString))
-> AgentClient
-> IO (Set ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> TVar (Set ByteString)
subscrConns
{-# INLINE getSubscriptions #-}

logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> EntityId -> ByteString -> m ()
logServer :: forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> RecipientId
-> ByteString
-> m ()
logServer ByteString
dir AgentClient
c ProtocolServer s
srv = ByteString
-> AgentClient
-> ProtocolServer s
-> ByteString
-> ByteString
-> m ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> ByteString
-> ByteString
-> m ()
logServer' ByteString
dir AgentClient
c ProtocolServer s
srv (ByteString -> ByteString -> m ())
-> (RecipientId -> ByteString) -> RecipientId -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientId -> ByteString
unEntityId
{-# INLINE logServer #-}

logServer' :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> ByteString -> ByteString -> m ()
logServer' :: forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> ByteString
-> ByteString
-> m ()
logServer' ByteString
dir AgentClient {Int
$sel:clientId:AgentClient :: AgentClient -> Int
clientId :: Int
clientId} ProtocolServer s
srv ByteString
qStr ByteString
cmdStr =
  Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> m ()) -> (ByteString -> Text) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.unwords [ByteString
Item [ByteString]
"A", ByteString
"(" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString
forall a. Show a => a -> ByteString
bshow Int
clientId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
")", ByteString
Item [ByteString]
dir, ProtocolServer s -> ByteString
forall (s :: ProtocolType). ProtocolServer s -> ByteString
showServer ProtocolServer s
srv, ByteString
Item [ByteString]
":", ByteString -> ByteString
logSecret' ByteString
qStr, ByteString
Item [ByteString]
cmdStr]

showServer :: ProtocolServer s -> ByteString
showServer :: forall (s :: ProtocolType). ProtocolServer s -> ByteString
showServer ProtocolServer {NonEmpty TransportHost
$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host :: NonEmpty TransportHost
host, String
port :: String
$sel:port:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> String
port} =
  NonEmpty TransportHost -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode NonEmpty TransportHost
host ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
B.pack (if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
port then String
"" else Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: String
port)
{-# INLINE showServer #-}

logSecret :: EntityId -> ByteString
logSecret :: RecipientId -> ByteString
logSecret = ByteString -> ByteString
logSecret' (ByteString -> ByteString)
-> (RecipientId -> ByteString) -> RecipientId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientId -> ByteString
unEntityId
{-# INLINE logSecret #-}

logSecret' :: ByteString -> ByteString
logSecret' :: ByteString -> ByteString
logSecret' = ByteString -> ByteString
B64.encode (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
B.take Int
3
{-# INLINE logSecret' #-}

sendConfirmation :: AgentClient -> NetworkRequestMode -> SndQueue -> ByteString -> AM (Maybe SMPServer)
sendConfirmation :: AgentClient
-> NetworkRequestMode
-> SndQueue
-> ByteString
-> AM (Maybe (ProtocolServer 'PSMP))
sendConfirmation AgentClient
c NetworkRequestMode
nm sq :: SndQueue
sq@SndQueue {UserId
userId :: UserId
$sel:userId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> UserId
userId, ProtocolServer 'PSMP
server :: ProtocolServer 'PSMP
$sel:server:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> ProtocolServer 'PSMP
server, ByteString
connId :: ByteString
$sel:connId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> ByteString
connId, RecipientId
sndId :: RecipientId
$sel:sndId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> RecipientId
sndId, Maybe QueueMode
queueMode :: Maybe QueueMode
$sel:queueMode:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> Maybe QueueMode
queueMode, SndPrivateAuthKey
sndPrivateKey :: SndPrivateAuthKey
$sel:sndPrivateKey:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> SndPrivateAuthKey
sndPrivateKey, $sel:e2ePubKey:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> Maybe RcvPublicDhKey
e2ePubKey = e2ePubKey :: Maybe RcvPublicDhKey
e2ePubKey@Just {}} ByteString
agentConfirmation = do
  let (PrivHeader
privHdr, Maybe SndPrivateAuthKey
spKey) = if Maybe QueueMode -> Bool
senderCanSecure Maybe QueueMode
queueMode then (PrivHeader
SMP.PHEmpty, SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
sndPrivateKey) else (APublicAuthKey -> PrivHeader
SMP.PHConfirmation (SndPrivateAuthKey -> PublicKeyType SndPrivateAuthKey
forall pk. CryptoPrivateKey pk => pk -> PublicKeyType pk
C.toPublic SndPrivateAuthKey
sndPrivateKey), Maybe SndPrivateAuthKey
forall a. Maybe a
Nothing)
      clientMsg :: ClientMessage
clientMsg = PrivHeader -> ByteString -> ClientMessage
SMP.ClientMessage PrivHeader
privHdr ByteString
agentConfirmation
  ByteString
msg <- SndQueue -> Maybe RcvPublicDhKey -> ByteString -> AM ByteString
agentCbEncrypt SndQueue
sq Maybe RcvPublicDhKey
e2ePubKey (ByteString -> AM ByteString) -> ByteString -> AM ByteString
forall a b. (a -> b) -> a -> b
$ ClientMessage -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode ClientMessage
clientMsg
  AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> Maybe SndPrivateAuthKey
-> RecipientId
-> MsgFlags
-> ByteString
-> AM (Maybe (ProtocolServer 'PSMP))
sendOrProxySMPMessage AgentClient
c NetworkRequestMode
nm UserId
userId ProtocolServer 'PSMP
server ByteString
connId ByteString
"<CONF>" Maybe SndPrivateAuthKey
spKey RecipientId
sndId (MsgFlags {$sel:notification:MsgFlags :: Bool
notification = Bool
True}) ByteString
msg
sendConfirmation AgentClient
_ NetworkRequestMode
_ SndQueue
_ ByteString
_ = AgentErrorType -> AM (Maybe (ProtocolServer 'PSMP))
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (Maybe (ProtocolServer 'PSMP)))
-> AgentErrorType -> AM (Maybe (ProtocolServer 'PSMP))
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"sendConfirmation called without snd_queue public key(s) in the database"

sendInvitation :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer)
sendInvitation :: AgentClient
-> NetworkRequestMode
-> UserId
-> ByteString
-> Compatible SMPQueueInfo
-> Compatible VersionSMPA
-> ConnectionRequestUri 'CMInvitation
-> ByteString
-> AM (Maybe (ProtocolServer 'PSMP))
sendInvitation AgentClient
c NetworkRequestMode
nm UserId
userId ByteString
connId (Compatible (SMPQueueInfo VersionSMPC
v SMPQueueAddress {ProtocolServer 'PSMP
smpServer :: ProtocolServer 'PSMP
$sel:smpServer:SMPQueueAddress :: SMPQueueAddress -> ProtocolServer 'PSMP
smpServer, RecipientId
senderId :: RecipientId
$sel:senderId:SMPQueueAddress :: SMPQueueAddress -> RecipientId
senderId, RcvPublicDhKey
dhPublicKey :: RcvPublicDhKey
$sel:dhPublicKey:SMPQueueAddress :: SMPQueueAddress -> RcvPublicDhKey
dhPublicKey})) (Compatible VersionSMPA
agentVersion) ConnectionRequestUri 'CMInvitation
connReq ByteString
connInfo = do
  ByteString
msg <- AM ByteString
mkInvitation
  AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> Maybe SndPrivateAuthKey
-> RecipientId
-> MsgFlags
-> ByteString
-> AM (Maybe (ProtocolServer 'PSMP))
sendOrProxySMPMessage AgentClient
c NetworkRequestMode
nm UserId
userId ProtocolServer 'PSMP
smpServer ByteString
connId ByteString
"<INV>" Maybe SndPrivateAuthKey
forall a. Maybe a
Nothing RecipientId
senderId (MsgFlags {$sel:notification:MsgFlags :: Bool
notification = Bool
True}) ByteString
msg
  where
    mkInvitation :: AM ByteString
    -- this is only encrypted with per-queue E2E, not with double ratchet
    mkInvitation :: AM ByteString
mkInvitation = do
      let agentEnvelope :: AgentMsgEnvelope
agentEnvelope = AgentInvitation {VersionSMPA
agentVersion :: VersionSMPA
$sel:agentVersion:AgentConfirmation :: VersionSMPA
agentVersion, ConnectionRequestUri 'CMInvitation
connReq :: ConnectionRequestUri 'CMInvitation
$sel:connReq:AgentConfirmation :: ConnectionRequestUri 'CMInvitation
connReq, ByteString
connInfo :: ByteString
$sel:connInfo:AgentConfirmation :: ByteString
connInfo}
      VersionSMPC -> RcvPublicDhKey -> ByteString -> AM ByteString
agentCbEncryptOnce VersionSMPC
v RcvPublicDhKey
dhPublicKey (ByteString -> AM ByteString)
-> (ClientMessage -> ByteString) -> ClientMessage -> AM ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientMessage -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (ClientMessage -> AM ByteString) -> ClientMessage -> AM ByteString
forall a b. (a -> b) -> a -> b
$
        PrivHeader -> ByteString -> ClientMessage
SMP.ClientMessage PrivHeader
SMP.PHEmpty (AgentMsgEnvelope -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode AgentMsgEnvelope
agentEnvelope)

getQueueMessage :: AgentClient -> RcvQueue -> AM (Maybe SMPMsgMeta)
getQueueMessage :: AgentClient -> RcvQueue -> AM (Maybe SMPMsgMeta)
getQueueMessage AgentClient
c rq :: RcvQueue
rq@RcvQueue {ProtocolServer 'PSMP
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> ProtocolServer 'PSMP
server :: ProtocolServer 'PSMP
server, RecipientId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
rcvId :: RecipientId
rcvId, SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
rcvPrivateKey} = do
  STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM ()
createTakeGetLock
  Maybe RcvMessage
msg_ <- AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO (Maybe RcvMessage))
-> AM (Maybe RcvMessage)
forall q a.
SMPQueueRec q =>
AgentClient
-> NetworkRequestMode
-> q
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM a
withSMPClient AgentClient
c NetworkRequestMode
NRMInteractive RcvQueue
rq ByteString
"GET" ((SMPClient -> ExceptT SMPClientError IO (Maybe RcvMessage))
 -> AM (Maybe RcvMessage))
-> (SMPClient -> ExceptT SMPClientError IO (Maybe RcvMessage))
-> AM (Maybe RcvMessage)
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp ->
    SMPClient
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO (Maybe RcvMessage)
getSMPMessage SMPClient
smp SndPrivateAuthKey
rcvPrivateKey RecipientId
rcvId
  (RcvMessage -> ExceptT AgentErrorType (ReaderT Env IO) SMPMsgMeta)
-> Maybe RcvMessage -> AM (Maybe SMPMsgMeta)
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 RcvMessage -> ExceptT AgentErrorType (ReaderT Env IO) SMPMsgMeta
decryptMeta Maybe RcvMessage
msg_
  where
    decryptMeta :: RcvMessage -> ExceptT AgentErrorType (ReaderT Env IO) SMPMsgMeta
decryptMeta msg :: RcvMessage
msg@SMP.RcvMessage {ByteString
msgId :: ByteString
$sel:msgId:RcvMessage :: RcvMessage -> ByteString
msgId} = ByteString -> ClientRcvMsgBody -> SMPMsgMeta
SMP.rcvMessageMeta ByteString
msgId (ClientRcvMsgBody -> SMPMsgMeta)
-> ExceptT AgentErrorType (ReaderT Env IO) ClientRcvMsgBody
-> ExceptT AgentErrorType (ReaderT Env IO) SMPMsgMeta
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RcvQueue
-> RcvMessage
-> ExceptT AgentErrorType (ReaderT Env IO) ClientRcvMsgBody
decryptSMPMessage RcvQueue
rq RcvMessage
msg
    createTakeGetLock :: STM ()
createTakeGetLock = (Maybe (TMVar ()) -> STM (Maybe (TMVar ())))
-> SndQAddr -> TMap SndQAddr (TMVar ()) -> STM ()
forall k a.
Ord k =>
(Maybe a -> STM (Maybe a)) -> k -> TMap k a -> STM ()
TM.alterF Maybe (TMVar ()) -> STM (Maybe (TMVar ()))
takeLock (ProtocolServer 'PSMP
server, RecipientId
rcvId) (TMap SndQAddr (TMVar ()) -> STM ())
-> TMap SndQAddr (TMVar ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMap SndQAddr (TMVar ())
getMsgLocks AgentClient
c
      where
        takeLock :: Maybe (TMVar ()) -> STM (Maybe (TMVar ()))
takeLock Maybe (TMVar ())
l_ = do
          TMVar ()
l <- STM (TMVar ())
-> (TMVar () -> STM (TMVar ()))
-> Maybe (TMVar ())
-> STM (TMVar ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> STM (TMVar ())
forall a. a -> STM (TMVar a)
newTMVar ()) TMVar () -> STM (TMVar ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TMVar ())
l_
          TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
l
          Maybe (TMVar ()) -> STM (Maybe (TMVar ()))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TMVar ()) -> STM (Maybe (TMVar ())))
-> Maybe (TMVar ()) -> STM (Maybe (TMVar ()))
forall a b. (a -> b) -> a -> b
$ TMVar () -> Maybe (TMVar ())
forall a. a -> Maybe a
Just TMVar ()
l
{-# INLINE getQueueMessage #-}

decryptSMPMessage :: RcvQueue -> SMP.RcvMessage -> AM SMP.ClientRcvMsgBody
decryptSMPMessage :: RcvQueue
-> RcvMessage
-> ExceptT AgentErrorType (ReaderT Env IO) ClientRcvMsgBody
decryptSMPMessage RcvQueue
rq SMP.RcvMessage {ByteString
$sel:msgId:RcvMessage :: RcvMessage -> ByteString
msgId :: ByteString
msgId, $sel:msgBody:RcvMessage :: RcvMessage -> EncRcvMsgBody
msgBody = SMP.EncRcvMsgBody ByteString
body} =
  Either AgentErrorType ClientRcvMsgBody
-> ExceptT AgentErrorType (ReaderT Env IO) ClientRcvMsgBody
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either AgentErrorType ClientRcvMsgBody
 -> ExceptT AgentErrorType (ReaderT Env IO) ClientRcvMsgBody)
-> Either AgentErrorType ClientRcvMsgBody
-> ExceptT AgentErrorType (ReaderT Env IO) ClientRcvMsgBody
forall a b. (a -> b) -> a -> b
$ Parser ClientRcvMsgBody
-> AgentErrorType
-> ByteString
-> Either AgentErrorType ClientRcvMsgBody
forall a e. Parser a -> e -> ByteString -> Either e a
parse Parser ClientRcvMsgBody
SMP.clientRcvMsgBodyP (SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_MESSAGE) (ByteString -> Either AgentErrorType ClientRcvMsgBody)
-> Either AgentErrorType ByteString
-> Either AgentErrorType ClientRcvMsgBody
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> Either AgentErrorType ByteString
decrypt ByteString
body
  where
    decrypt :: ByteString -> Either AgentErrorType ByteString
decrypt = RcvDhSecret
-> CbNonce -> ByteString -> Either AgentErrorType ByteString
agentCbDecrypt (RcvQueue -> RcvDhSecret
forall (q :: DBStored). StoredRcvQueue q -> RcvDhSecret
rcvDhSecret RcvQueue
rq) (ByteString -> CbNonce
C.cbNonce ByteString
msgId)

secureQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> SndPublicAuthKey -> AM ()
secureQueue :: AgentClient
-> NetworkRequestMode
-> RcvQueue
-> APublicAuthKey
-> ExceptT AgentErrorType (ReaderT Env IO) ()
secureQueue AgentClient
c NetworkRequestMode
nm rq :: RcvQueue
rq@RcvQueue {RecipientId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
rcvId :: RecipientId
rcvId, SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
rcvPrivateKey} APublicAuthKey
senderKey =
  AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall q a.
SMPQueueRec q =>
AgentClient
-> NetworkRequestMode
-> q
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM a
withSMPClient AgentClient
c NetworkRequestMode
nm RcvQueue
rq ByteString
"KEY <key>" ((SMPClient -> ExceptT SMPClientError IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp ->
    SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> APublicAuthKey
-> ExceptT SMPClientError IO ()
secureSMPQueue SMPClient
smp NetworkRequestMode
nm SndPrivateAuthKey
rcvPrivateKey RecipientId
rcvId APublicAuthKey
senderKey

secureSndQueue :: AgentClient -> NetworkRequestMode -> SndQueue -> AM ()
secureSndQueue :: AgentClient
-> NetworkRequestMode
-> SndQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
secureSndQueue AgentClient
c NetworkRequestMode
nm SndQueue {UserId
$sel:userId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> UserId
userId :: UserId
userId, ByteString
$sel:connId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> ByteString
connId :: ByteString
connId, ProtocolServer 'PSMP
$sel:server:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> ProtocolServer 'PSMP
server :: ProtocolServer 'PSMP
server, RecipientId
$sel:sndId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> RecipientId
sndId :: RecipientId
sndId, SndPrivateAuthKey
$sel:sndPrivateKey:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> SndPrivateAuthKey
sndPrivateKey :: SndPrivateAuthKey
sndPrivateKey} =
  ExceptT
  AgentErrorType (ReaderT Env IO) (Maybe (ProtocolServer 'PSMP), ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   AgentErrorType (ReaderT Env IO) (Maybe (ProtocolServer 'PSMP), ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Maybe (ProtocolServer 'PSMP), ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> RecipientId
-> (SMPClient
    -> ProxiedRelay
    -> ExceptT SMPClientError IO (Either ProxyClientError ()))
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Maybe (ProtocolServer 'PSMP), ())
forall a.
AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> RecipientId
-> (SMPClient
    -> ProxiedRelay
    -> ExceptT SMPClientError IO (Either ProxyClientError a))
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM (Maybe (ProtocolServer 'PSMP), a)
sendOrProxySMPCommand AgentClient
c NetworkRequestMode
nm UserId
userId ProtocolServer 'PSMP
server ByteString
connId ByteString
"SKEY <key>" RecipientId
sndId SMPClient
-> ProxiedRelay
-> ExceptT SMPClientError IO (Either ProxyClientError ())
secureViaProxy SMPClient -> ExceptT SMPClientError IO ()
secureDirectly
  where
    -- TODO track statistics
    secureViaProxy :: SMPClient
-> ProxiedRelay
-> ExceptT SMPClientError IO (Either ProxyClientError ())
secureViaProxy SMPClient
smp ProxiedRelay
proxySess = SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySecureSndSMPQueue SMPClient
smp NetworkRequestMode
nm ProxiedRelay
proxySess SndPrivateAuthKey
sndPrivateKey RecipientId
sndId
    secureDirectly :: SMPClient -> ExceptT SMPClientError IO ()
secureDirectly SMPClient
smp = SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
secureSndSMPQueue SMPClient
smp NetworkRequestMode
nm SndPrivateAuthKey
sndPrivateKey RecipientId
sndId

addQueueLink :: AgentClient -> NetworkRequestMode -> RcvQueue -> SMP.LinkId -> QueueLinkData -> AM ()
addQueueLink :: AgentClient
-> NetworkRequestMode
-> RcvQueue
-> RecipientId
-> QueueLinkData
-> ExceptT AgentErrorType (ReaderT Env IO) ()
addQueueLink AgentClient
c NetworkRequestMode
nm rq :: RcvQueue
rq@RcvQueue {RecipientId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
rcvId :: RecipientId
rcvId, SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
rcvPrivateKey} RecipientId
lnkId QueueLinkData
d =
  AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall q a.
SMPQueueRec q =>
AgentClient
-> NetworkRequestMode
-> q
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM a
withSMPClient AgentClient
c NetworkRequestMode
nm RcvQueue
rq ByteString
"LSET" ((SMPClient -> ExceptT SMPClientError IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp -> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> RecipientId
-> QueueLinkData
-> ExceptT SMPClientError IO ()
addSMPQueueLink SMPClient
smp NetworkRequestMode
nm SndPrivateAuthKey
rcvPrivateKey RecipientId
rcvId RecipientId
lnkId QueueLinkData
d

deleteQueueLink :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ()
deleteQueueLink :: AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteQueueLink AgentClient
c NetworkRequestMode
nm rq :: RcvQueue
rq@RcvQueue {RecipientId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
rcvId :: RecipientId
rcvId, SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
rcvPrivateKey} =
  AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall q a.
SMPQueueRec q =>
AgentClient
-> NetworkRequestMode
-> q
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM a
withSMPClient AgentClient
c NetworkRequestMode
nm RcvQueue
rq ByteString
"LDEL" ((SMPClient -> ExceptT SMPClientError IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp -> SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
deleteSMPQueueLink SMPClient
smp NetworkRequestMode
nm SndPrivateAuthKey
rcvPrivateKey RecipientId
rcvId

secureGetQueueLink :: AgentClient -> NetworkRequestMode -> UserId -> InvShortLink -> AM (SMP.SenderId, QueueLinkData)
secureGetQueueLink :: AgentClient
-> NetworkRequestMode
-> UserId
-> InvShortLink
-> AM (RecipientId, QueueLinkData)
secureGetQueueLink AgentClient
c NetworkRequestMode
nm UserId
userId InvShortLink {ProtocolServer 'PSMP
server :: ProtocolServer 'PSMP
$sel:server:InvShortLink :: InvShortLink -> ProtocolServer 'PSMP
server, RecipientId
linkId :: RecipientId
$sel:linkId:InvShortLink :: InvShortLink -> RecipientId
linkId, SndPrivateAuthKey
sndPrivateKey :: SndPrivateAuthKey
$sel:sndPrivateKey:InvShortLink :: InvShortLink -> SndPrivateAuthKey
sndPrivateKey} =
  (Maybe (ProtocolServer 'PSMP), (RecipientId, QueueLinkData))
-> (RecipientId, QueueLinkData)
forall a b. (a, b) -> b
snd ((Maybe (ProtocolServer 'PSMP), (RecipientId, QueueLinkData))
 -> (RecipientId, QueueLinkData))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (ProtocolServer 'PSMP), (RecipientId, QueueLinkData))
-> AM (RecipientId, QueueLinkData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> RecipientId
-> (SMPClient
    -> ProxiedRelay
    -> ExceptT
         SMPClientError
         IO
         (Either ProxyClientError (RecipientId, QueueLinkData)))
-> (SMPClient
    -> ExceptT SMPClientError IO (RecipientId, QueueLinkData))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (ProtocolServer 'PSMP), (RecipientId, QueueLinkData))
forall a.
AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> RecipientId
-> (SMPClient
    -> ProxiedRelay
    -> ExceptT SMPClientError IO (Either ProxyClientError a))
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM (Maybe (ProtocolServer 'PSMP), a)
sendOrProxySMPCommand AgentClient
c NetworkRequestMode
nm UserId
userId ProtocolServer 'PSMP
server (RecipientId -> ByteString
unEntityId RecipientId
linkId) ByteString
"LKEY <key>" RecipientId
linkId SMPClient
-> ProxiedRelay
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
secureGetViaProxy SMPClient -> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
secureGetDirectly
  where
    secureGetViaProxy :: SMPClient
-> ProxiedRelay
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
secureGetViaProxy SMPClient
smp ProxiedRelay
proxySess = SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
proxySecureGetSMPQueueLink SMPClient
smp NetworkRequestMode
nm ProxiedRelay
proxySess SndPrivateAuthKey
sndPrivateKey RecipientId
linkId
    secureGetDirectly :: SMPClient -> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
secureGetDirectly SMPClient
smp = SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
secureGetSMPQueueLink SMPClient
smp NetworkRequestMode
nm SndPrivateAuthKey
sndPrivateKey RecipientId
linkId

getQueueLink :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SMP.LinkId -> AM (SMP.SenderId, QueueLinkData)
getQueueLink :: AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> RecipientId
-> AM (RecipientId, QueueLinkData)
getQueueLink AgentClient
c NetworkRequestMode
nm UserId
userId ProtocolServer 'PSMP
server RecipientId
lnkId =
  (Maybe (ProtocolServer 'PSMP), (RecipientId, QueueLinkData))
-> (RecipientId, QueueLinkData)
forall a b. (a, b) -> b
snd ((Maybe (ProtocolServer 'PSMP), (RecipientId, QueueLinkData))
 -> (RecipientId, QueueLinkData))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (ProtocolServer 'PSMP), (RecipientId, QueueLinkData))
-> AM (RecipientId, QueueLinkData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> RecipientId
-> (SMPClient
    -> ProxiedRelay
    -> ExceptT
         SMPClientError
         IO
         (Either ProxyClientError (RecipientId, QueueLinkData)))
-> (SMPClient
    -> ExceptT SMPClientError IO (RecipientId, QueueLinkData))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (ProtocolServer 'PSMP), (RecipientId, QueueLinkData))
forall a.
AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> RecipientId
-> (SMPClient
    -> ProxiedRelay
    -> ExceptT SMPClientError IO (Either ProxyClientError a))
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM (Maybe (ProtocolServer 'PSMP), a)
sendOrProxySMPCommand AgentClient
c NetworkRequestMode
nm UserId
userId ProtocolServer 'PSMP
server (RecipientId -> ByteString
unEntityId RecipientId
lnkId) ByteString
"LGET" RecipientId
lnkId SMPClient
-> ProxiedRelay
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
getViaProxy SMPClient -> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
getDirectly
  where
    getViaProxy :: SMPClient
-> ProxiedRelay
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
getViaProxy SMPClient
smp ProxiedRelay
proxySess = SMPClient
-> NetworkRequestMode
-> ProxiedRelay
-> RecipientId
-> ExceptT
     SMPClientError
     IO
     (Either ProxyClientError (RecipientId, QueueLinkData))
proxyGetSMPQueueLink SMPClient
smp NetworkRequestMode
nm ProxiedRelay
proxySess RecipientId
lnkId
    getDirectly :: SMPClient -> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
getDirectly SMPClient
smp = SMPClient
-> NetworkRequestMode
-> RecipientId
-> ExceptT SMPClientError IO (RecipientId, QueueLinkData)
getSMPQueueLink SMPClient
smp NetworkRequestMode
nm RecipientId
lnkId

enableQueueNotifications :: AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> AM (SMP.NotifierId, SMP.RcvNtfPublicDhKey)
enableQueueNotifications :: AgentClient
-> RcvQueue
-> APublicAuthKey
-> RcvPublicDhKey
-> AM (RecipientId, RcvPublicDhKey)
enableQueueNotifications AgentClient
c rq :: RcvQueue
rq@RcvQueue {RecipientId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
rcvId :: RecipientId
rcvId, SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
rcvPrivateKey} APublicAuthKey
notifierKey RcvPublicDhKey
rcvNtfPublicDhKey =
  AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ByteString
-> (SMPClient
    -> ExceptT SMPClientError IO (RecipientId, RcvPublicDhKey))
-> AM (RecipientId, RcvPublicDhKey)
forall q a.
SMPQueueRec q =>
AgentClient
-> NetworkRequestMode
-> q
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM a
withSMPClient AgentClient
c NetworkRequestMode
NRMBackground RcvQueue
rq ByteString
"NKEY <nkey>" ((SMPClient
  -> ExceptT SMPClientError IO (RecipientId, RcvPublicDhKey))
 -> AM (RecipientId, RcvPublicDhKey))
-> (SMPClient
    -> ExceptT SMPClientError IO (RecipientId, RcvPublicDhKey))
-> AM (RecipientId, RcvPublicDhKey)
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp ->
    SMPClient
-> SndPrivateAuthKey
-> RecipientId
-> APublicAuthKey
-> RcvPublicDhKey
-> ExceptT SMPClientError IO (RecipientId, RcvPublicDhKey)
enableSMPQueueNotifications SMPClient
smp SndPrivateAuthKey
rcvPrivateKey RecipientId
rcvId APublicAuthKey
notifierKey RcvPublicDhKey
rcvNtfPublicDhKey

data EnableQueueNtfReq = EnableQueueNtfReq
  { EnableQueueNtfReq -> NtfSubscription
eqnrNtfSub :: NtfSubscription,
    EnableQueueNtfReq -> RcvQueue
eqnrRq :: RcvQueue,
    EnableQueueNtfReq -> AAuthKeyPair
eqnrAuthKeyPair :: C.AAuthKeyPair,
    EnableQueueNtfReq -> KeyPair 'X25519
eqnrRcvKeyPair :: C.KeyPairX25519
  }

enableQueuesNtfs :: AgentClient -> [EnableQueueNtfReq] -> AM' [(EnableQueueNtfReq, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
enableQueuesNtfs :: AgentClient
-> [EnableQueueNtfReq]
-> AM'
     [(EnableQueueNtfReq,
       Either AgentErrorType (RecipientId, RcvPublicDhKey))]
enableQueuesNtfs AgentClient
c = ByteString
-> (EnableQueueNtfReq
    -> TransportSessionMode -> SMPTransportSession)
-> (SMPClient
    -> NonEmpty EnableQueueNtfReq
    -> IO
         (BatchResponses
            EnableQueueNtfReq SMPClientError (RecipientId, RcvPublicDhKey)))
-> AgentClient
-> NetworkRequestMode
-> [EnableQueueNtfReq]
-> AM'
     [(EnableQueueNtfReq,
       Either AgentErrorType (RecipientId, RcvPublicDhKey))]
forall q r.
ByteString
-> (q -> TransportSessionMode -> SMPTransportSession)
-> (SMPClient
    -> NonEmpty q -> IO (BatchResponses q SMPClientError r))
-> AgentClient
-> NetworkRequestMode
-> [q]
-> AM' [(q, Either AgentErrorType r)]
sendTSessionBatches ByteString
"NKEY" (RcvQueue -> TransportSessionMode -> SMPTransportSession
RcvQueue
-> TransportSessionMode
-> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
forall q.
SMPQueueRec q =>
q -> TransportSessionMode -> SMPTransportSession
mkSMPTSession (RcvQueue
 -> TransportSessionMode
 -> (UserId, ProtocolServer 'PSMP, Maybe ByteString))
-> (EnableQueueNtfReq -> RcvQueue)
-> EnableQueueNtfReq
-> TransportSessionMode
-> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnableQueueNtfReq -> RcvQueue
eqnrRq) SMPClient
-> NonEmpty EnableQueueNtfReq
-> IO
     (BatchResponses
        EnableQueueNtfReq SMPClientError (RecipientId, RcvPublicDhKey))
enableQueues_ AgentClient
c NetworkRequestMode
NRMBackground
  where
    enableQueues_ :: SMPClient -> NonEmpty EnableQueueNtfReq -> IO (NonEmpty (EnableQueueNtfReq, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
    enableQueues_ :: SMPClient
-> NonEmpty EnableQueueNtfReq
-> IO
     (BatchResponses
        EnableQueueNtfReq SMPClientError (RecipientId, RcvPublicDhKey))
enableQueues_ SMPClient
smp NonEmpty EnableQueueNtfReq
qs' = NonEmpty EnableQueueNtfReq
-> NonEmpty (Either SMPClientError (RecipientId, RcvPublicDhKey))
-> BatchResponses
     EnableQueueNtfReq SMPClientError (RecipientId, RcvPublicDhKey)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
L.zip NonEmpty EnableQueueNtfReq
qs' (NonEmpty (Either SMPClientError (RecipientId, RcvPublicDhKey))
 -> BatchResponses
      EnableQueueNtfReq SMPClientError (RecipientId, RcvPublicDhKey))
-> IO
     (NonEmpty (Either SMPClientError (RecipientId, RcvPublicDhKey)))
-> IO
     (BatchResponses
        EnableQueueNtfReq SMPClientError (RecipientId, RcvPublicDhKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPClient
-> NonEmpty
     (RecipientId, SndPrivateAuthKey, APublicAuthKey, RcvPublicDhKey)
-> IO
     (NonEmpty (Either SMPClientError (RecipientId, RcvPublicDhKey)))
enableSMPQueuesNtfs SMPClient
smp ((EnableQueueNtfReq
 -> (RecipientId, SndPrivateAuthKey, APublicAuthKey,
     RcvPublicDhKey))
-> NonEmpty EnableQueueNtfReq
-> NonEmpty
     (RecipientId, SndPrivateAuthKey, APublicAuthKey, RcvPublicDhKey)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map EnableQueueNtfReq
-> (RecipientId, SndPrivateAuthKey, APublicAuthKey, RcvPublicDhKey)
queueCreds NonEmpty EnableQueueNtfReq
qs')
    queueCreds :: EnableQueueNtfReq -> (SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)
    queueCreds :: EnableQueueNtfReq
-> (RecipientId, SndPrivateAuthKey, APublicAuthKey, RcvPublicDhKey)
queueCreds EnableQueueNtfReq {RcvQueue
$sel:eqnrRq:EnableQueueNtfReq :: EnableQueueNtfReq -> RcvQueue
eqnrRq :: RcvQueue
eqnrRq, AAuthKeyPair
$sel:eqnrAuthKeyPair:EnableQueueNtfReq :: EnableQueueNtfReq -> AAuthKeyPair
eqnrAuthKeyPair :: AAuthKeyPair
eqnrAuthKeyPair, KeyPair 'X25519
$sel:eqnrRcvKeyPair:EnableQueueNtfReq :: EnableQueueNtfReq -> KeyPair 'X25519
eqnrRcvKeyPair :: KeyPair 'X25519
eqnrRcvKeyPair} =
      let RcvQueue {SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
rcvPrivateKey, RecipientId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
rcvId :: RecipientId
rcvId} = RcvQueue
eqnrRq
          (PublicKeyType SndPrivateAuthKey
ntfPublicKey, SndPrivateAuthKey
_) = AAuthKeyPair
eqnrAuthKeyPair
          (PublicKeyType (PrivateKey 'X25519)
rcvNtfPubDhKey, PrivateKey 'X25519
_) = KeyPair 'X25519
eqnrRcvKeyPair
       in (RecipientId
rcvId, SndPrivateAuthKey
rcvPrivateKey, PublicKeyType SndPrivateAuthKey
APublicAuthKey
ntfPublicKey, PublicKeyType (PrivateKey 'X25519)
RcvPublicDhKey
rcvNtfPubDhKey)

disableQueueNotifications :: AgentClient -> RcvQueue -> AM ()
disableQueueNotifications :: AgentClient
-> RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) ()
disableQueueNotifications AgentClient
c rq :: RcvQueue
rq@RcvQueue {RecipientId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
rcvId :: RecipientId
rcvId, SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
rcvPrivateKey} =
  AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall q a.
SMPQueueRec q =>
AgentClient
-> NetworkRequestMode
-> q
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM a
withSMPClient AgentClient
c NetworkRequestMode
NRMBackground RcvQueue
rq ByteString
"NDEL" ((SMPClient -> ExceptT SMPClientError IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp ->
    SMPClient
-> SndPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
disableSMPQueueNotifications SMPClient
smp SndPrivateAuthKey
rcvPrivateKey RecipientId
rcvId

type DisableQueueNtfReq = (NtfSubscription, RcvQueue)

disableQueuesNtfs :: AgentClient -> [DisableQueueNtfReq] -> AM' [(DisableQueueNtfReq, Either AgentErrorType ())]
disableQueuesNtfs :: AgentClient
-> [DisableQueueNtfReq]
-> AM' [(DisableQueueNtfReq, Either AgentErrorType ())]
disableQueuesNtfs AgentClient
c = ByteString
-> (DisableQueueNtfReq
    -> TransportSessionMode -> SMPTransportSession)
-> (SMPClient
    -> NonEmpty DisableQueueNtfReq
    -> IO (BatchResponses DisableQueueNtfReq SMPClientError ()))
-> AgentClient
-> NetworkRequestMode
-> [DisableQueueNtfReq]
-> AM' [(DisableQueueNtfReq, Either AgentErrorType ())]
forall q r.
ByteString
-> (q -> TransportSessionMode -> SMPTransportSession)
-> (SMPClient
    -> NonEmpty q -> IO (BatchResponses q SMPClientError r))
-> AgentClient
-> NetworkRequestMode
-> [q]
-> AM' [(q, Either AgentErrorType r)]
sendTSessionBatches ByteString
"NDEL" (RcvQueue -> TransportSessionMode -> SMPTransportSession
RcvQueue
-> TransportSessionMode
-> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
forall q.
SMPQueueRec q =>
q -> TransportSessionMode -> SMPTransportSession
mkSMPTSession (RcvQueue
 -> TransportSessionMode
 -> (UserId, ProtocolServer 'PSMP, Maybe ByteString))
-> (DisableQueueNtfReq -> RcvQueue)
-> DisableQueueNtfReq
-> TransportSessionMode
-> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DisableQueueNtfReq -> RcvQueue
forall a b. (a, b) -> b
snd) SMPClient
-> NonEmpty DisableQueueNtfReq
-> IO (BatchResponses DisableQueueNtfReq SMPClientError ())
disableQueues_ AgentClient
c NetworkRequestMode
NRMBackground
  where
    disableQueues_ :: SMPClient -> NonEmpty DisableQueueNtfReq -> IO (NonEmpty (DisableQueueNtfReq, Either (ProtocolClientError ErrorType) ()))
    disableQueues_ :: SMPClient
-> NonEmpty DisableQueueNtfReq
-> IO (BatchResponses DisableQueueNtfReq SMPClientError ())
disableQueues_ SMPClient
smp NonEmpty DisableQueueNtfReq
qs' = NonEmpty DisableQueueNtfReq
-> NonEmpty (Either SMPClientError ())
-> BatchResponses DisableQueueNtfReq SMPClientError ()
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
L.zip NonEmpty DisableQueueNtfReq
qs' (NonEmpty (Either SMPClientError ())
 -> BatchResponses DisableQueueNtfReq SMPClientError ())
-> IO (NonEmpty (Either SMPClientError ()))
-> IO (BatchResponses DisableQueueNtfReq SMPClientError ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPClient
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError ()))
disableSMPQueuesNtfs SMPClient
smp ((DisableQueueNtfReq -> (RecipientId, SndPrivateAuthKey))
-> NonEmpty DisableQueueNtfReq
-> NonEmpty (RecipientId, SndPrivateAuthKey)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map DisableQueueNtfReq -> (RecipientId, SndPrivateAuthKey)
queueCreds NonEmpty DisableQueueNtfReq
qs')
    queueCreds :: DisableQueueNtfReq -> (SMP.RecipientId, SMP.RcvPrivateAuthKey)
    queueCreds :: DisableQueueNtfReq -> (RecipientId, SndPrivateAuthKey)
queueCreds (NtfSubscription
_, RcvQueue {SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
rcvPrivateKey, RecipientId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
rcvId :: RecipientId
rcvId}) = (RecipientId
rcvId, SndPrivateAuthKey
rcvPrivateKey)

sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
sendAck :: AgentClient
-> RcvQueue
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) ()
sendAck AgentClient
c rq :: RcvQueue
rq@RcvQueue {RecipientId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
rcvId :: RecipientId
rcvId, SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
rcvPrivateKey} ByteString
msgId =
  AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall q a.
SMPQueueRec q =>
AgentClient
-> NetworkRequestMode
-> q
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM a
withSMPClient AgentClient
c NetworkRequestMode
NRMBackground RcvQueue
rq (ByteString
"ACK:" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
logSecret' ByteString
msgId) ((SMPClient -> ExceptT SMPClientError IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp ->
    SMPClient
-> SndPrivateAuthKey
-> RecipientId
-> ByteString
-> ExceptT SMPClientError IO ()
ackSMPMessage SMPClient
smp SndPrivateAuthKey
rcvPrivateKey RecipientId
rcvId ByteString
msgId

hasGetLock :: SomeRcvQueue q => AgentClient -> q -> IO Bool
hasGetLock :: forall q. SomeRcvQueue q => AgentClient -> q -> IO Bool
hasGetLock AgentClient
c q
rq =
  SndQAddr -> TMap SndQAddr (TMVar ()) -> IO Bool
forall k a. Ord k => k -> TMap k a -> IO Bool
TM.memberIO (q -> ProtocolServer 'PSMP
forall q. SMPQueue q => q -> ProtocolServer 'PSMP
qServer q
rq, q -> RecipientId
forall q. SMPQueue q => q -> RecipientId
queueId q
rq) (TMap SndQAddr (TMVar ()) -> IO Bool)
-> TMap SndQAddr (TMVar ()) -> IO Bool
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMap SndQAddr (TMVar ())
getMsgLocks AgentClient
c
{-# INLINE hasGetLock #-}

releaseGetLock :: SomeRcvQueue q => AgentClient -> q -> STM ()
releaseGetLock :: forall q. SomeRcvQueue q => AgentClient -> q -> STM ()
releaseGetLock AgentClient
c q
rq =
  SndQAddr -> TMap SndQAddr (TMVar ()) -> STM (Maybe (TMVar ()))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup (q -> ProtocolServer 'PSMP
forall q. SMPQueue q => q -> ProtocolServer 'PSMP
qServer q
rq, q -> RecipientId
forall q. SMPQueue q => q -> RecipientId
queueId q
rq) (AgentClient -> TMap SndQAddr (TMVar ())
getMsgLocks AgentClient
c) STM (Maybe (TMVar ())) -> (Maybe (TMVar ()) -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TMVar () -> STM Bool) -> Maybe (TMVar ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
`tryPutTMVar` ())
{-# INLINE releaseGetLock #-}

releaseGetLocksIO :: SomeRcvQueue q => AgentClient -> [q] -> IO ()
releaseGetLocksIO :: forall q. SomeRcvQueue q => AgentClient -> [q] -> IO ()
releaseGetLocksIO AgentClient
c [q]
rqs = do
  Map SndQAddr (TMVar ())
locks <- TMap SndQAddr (TMVar ()) -> IO (Map SndQAddr (TMVar ()))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TMap SndQAddr (TMVar ()) -> IO (Map SndQAddr (TMVar ())))
-> TMap SndQAddr (TMVar ()) -> IO (Map SndQAddr (TMVar ()))
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMap SndQAddr (TMVar ())
getMsgLocks AgentClient
c
  [q] -> (q -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [q]
rqs ((q -> IO ()) -> IO ()) -> (q -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \q
rq ->
    Maybe (TMVar ()) -> (TMVar () -> IO Bool) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (SndQAddr -> Map SndQAddr (TMVar ()) -> Maybe (TMVar ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ((q -> ProtocolServer 'PSMP
forall q. SMPQueue q => q -> ProtocolServer 'PSMP
qServer q
rq, q -> RecipientId
forall q. SMPQueue q => q -> RecipientId
queueId q
rq)) Map SndQAddr (TMVar ())
locks) ((TMVar () -> IO Bool) -> IO ()) -> (TMVar () -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TMVar ()
lock ->
      STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
lock ()

suspendQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ()
suspendQueue :: AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
suspendQueue AgentClient
c NetworkRequestMode
nm rq :: RcvQueue
rq@RcvQueue {RecipientId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
rcvId :: RecipientId
rcvId, SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
rcvPrivateKey} =
  AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall q a.
SMPQueueRec q =>
AgentClient
-> NetworkRequestMode
-> q
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM a
withSMPClient AgentClient
c NetworkRequestMode
nm RcvQueue
rq ByteString
"OFF" ((SMPClient -> ExceptT SMPClientError IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp ->
    SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
suspendSMPQueue SMPClient
smp NetworkRequestMode
nm SndPrivateAuthKey
rcvPrivateKey RecipientId
rcvId

deleteQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ()
deleteQueue :: AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteQueue AgentClient
c NetworkRequestMode
nm rq :: RcvQueue
rq@RcvQueue {RecipientId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
rcvId :: RecipientId
rcvId, SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
rcvPrivateKey} = do
  AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall q a.
SMPQueueRec q =>
AgentClient
-> NetworkRequestMode
-> q
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM a
withSMPClient AgentClient
c NetworkRequestMode
nm RcvQueue
rq ByteString
"DEL" ((SMPClient -> ExceptT SMPClientError IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPClient -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp ->
    SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
deleteSMPQueue SMPClient
smp NetworkRequestMode
nm SndPrivateAuthKey
rcvPrivateKey RecipientId
rcvId

deleteQueues :: AgentClient -> NetworkRequestMode -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())]
deleteQueues :: AgentClient
-> NetworkRequestMode
-> [RcvQueue]
-> AM' [(RcvQueue, Either AgentErrorType ())]
deleteQueues AgentClient
c NetworkRequestMode
nm = ByteString
-> (RcvQueue -> TransportSessionMode -> SMPTransportSession)
-> (SMPClient
    -> NonEmpty RcvQueue
    -> IO (BatchResponses RcvQueue SMPClientError ()))
-> AgentClient
-> NetworkRequestMode
-> [RcvQueue]
-> AM' [(RcvQueue, Either AgentErrorType ())]
forall q r.
ByteString
-> (q -> TransportSessionMode -> SMPTransportSession)
-> (SMPClient
    -> NonEmpty q -> IO (BatchResponses q SMPClientError r))
-> AgentClient
-> NetworkRequestMode
-> [q]
-> AM' [(q, Either AgentErrorType r)]
sendTSessionBatches ByteString
"DEL" RcvQueue -> TransportSessionMode -> SMPTransportSession
forall q.
SMPQueueRec q =>
q -> TransportSessionMode -> SMPTransportSession
mkSMPTSession SMPClient
-> NonEmpty RcvQueue
-> IO (BatchResponses RcvQueue SMPClientError ())
deleteQueues_ AgentClient
c NetworkRequestMode
nm
  where
    deleteQueues_ :: SMPClient
-> NonEmpty RcvQueue
-> IO (BatchResponses RcvQueue SMPClientError ())
deleteQueues_ SMPClient
smp NonEmpty RcvQueue
rqs = do
      let (UserId
userId, ProtoServer BrokerMsg
srv, Maybe ByteString
_) = SMPClient -> SMPTransportSession
forall v err msg. ProtocolClient v err msg -> TransportSession msg
transportSession' SMPClient
smp
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> Int
-> STM ()
incSMPServerStat' AgentClient
c UserId
userId ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv AgentSMPServerStats -> TVar Int
connDelAttempts (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$ NonEmpty RcvQueue -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty RcvQueue
rqs
      BatchResponses RcvQueue SMPClientError ()
rs <- (SMPClient
 -> NetworkRequestMode
 -> NonEmpty (RecipientId, SndPrivateAuthKey)
 -> IO (NonEmpty (Either SMPClientError ())))
-> SMPClient
-> NetworkRequestMode
-> NonEmpty RcvQueue
-> IO (BatchResponses RcvQueue SMPClientError ())
forall q a.
SomeRcvQueue q =>
(SMPClient
 -> NetworkRequestMode
 -> NonEmpty (RecipientId, SndPrivateAuthKey)
 -> IO (NonEmpty (Either SMPClientError a)))
-> SMPClient
-> NetworkRequestMode
-> NonEmpty q
-> IO (BatchResponses q SMPClientError a)
sendBatch SMPClient
-> NetworkRequestMode
-> NonEmpty (RecipientId, SndPrivateAuthKey)
-> IO (NonEmpty (Either SMPClientError ()))
deleteSMPQueues SMPClient
smp NetworkRequestMode
nm NonEmpty RcvQueue
rqs
      let successes :: Int
successes = (Int -> (RcvQueue, Either SMPClientError ()) -> Int)
-> Int -> BatchResponses RcvQueue SMPClientError () -> Int
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
n (RcvQueue
_, Either SMPClientError ()
r) -> if Either SMPClientError () -> Bool
forall a b. Either a b -> Bool
isRight Either SMPClientError ()
r then Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
n) Int
0 BatchResponses RcvQueue SMPClientError ()
rs
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> Int
-> STM ()
incSMPServerStat' AgentClient
c UserId
userId ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv AgentSMPServerStats -> TVar Int
connDeleted Int
successes
      BatchResponses RcvQueue SMPClientError ()
-> IO (BatchResponses RcvQueue SMPClientError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BatchResponses RcvQueue SMPClientError ()
rs

-- This is only used in background
sendAgentMessage :: AgentClient -> SndQueue -> MsgFlags -> ByteString -> AM (Maybe SMPServer)
sendAgentMessage :: AgentClient
-> SndQueue
-> MsgFlags
-> ByteString
-> AM (Maybe (ProtocolServer 'PSMP))
sendAgentMessage AgentClient
c sq :: SndQueue
sq@SndQueue {UserId
$sel:userId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> UserId
userId :: UserId
userId, ProtocolServer 'PSMP
$sel:server:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> ProtocolServer 'PSMP
server :: ProtocolServer 'PSMP
server, ByteString
$sel:connId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> ByteString
connId :: ByteString
connId, RecipientId
$sel:sndId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> RecipientId
sndId :: RecipientId
sndId, SndPrivateAuthKey
$sel:sndPrivateKey:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> SndPrivateAuthKey
sndPrivateKey :: SndPrivateAuthKey
sndPrivateKey} MsgFlags
msgFlags ByteString
agentMsg = do
  let clientMsg :: ClientMessage
clientMsg = PrivHeader -> ByteString -> ClientMessage
SMP.ClientMessage PrivHeader
SMP.PHEmpty ByteString
agentMsg
  ByteString
msg <- SndQueue -> Maybe RcvPublicDhKey -> ByteString -> AM ByteString
agentCbEncrypt SndQueue
sq Maybe RcvPublicDhKey
forall a. Maybe a
Nothing (ByteString -> AM ByteString) -> ByteString -> AM ByteString
forall a b. (a -> b) -> a -> b
$ ClientMessage -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode ClientMessage
clientMsg
  AgentClient
-> NetworkRequestMode
-> UserId
-> ProtocolServer 'PSMP
-> ByteString
-> ByteString
-> Maybe SndPrivateAuthKey
-> RecipientId
-> MsgFlags
-> ByteString
-> AM (Maybe (ProtocolServer 'PSMP))
sendOrProxySMPMessage AgentClient
c NetworkRequestMode
NRMBackground UserId
userId ProtocolServer 'PSMP
server ByteString
connId ByteString
"<MSG>" (SndPrivateAuthKey -> Maybe SndPrivateAuthKey
forall a. a -> Maybe a
Just SndPrivateAuthKey
sndPrivateKey) RecipientId
sndId MsgFlags
msgFlags ByteString
msg

data ServerQueueInfo = ServerQueueInfo
  { ServerQueueInfo -> ProtocolServer 'PSMP
server :: SMPServer,
    ServerQueueInfo -> Text
rcvId :: Text,
    ServerQueueInfo -> Text
sndId :: Text,
    ServerQueueInfo -> Maybe Text
ntfId :: Maybe Text,
    ServerQueueInfo -> Text
status :: Text,
    ServerQueueInfo -> QueueInfo
info :: QueueInfo
  }
  deriving (Int -> ServerQueueInfo -> String -> String
[ServerQueueInfo] -> String -> String
ServerQueueInfo -> String
(Int -> ServerQueueInfo -> String -> String)
-> (ServerQueueInfo -> String)
-> ([ServerQueueInfo] -> String -> String)
-> Show ServerQueueInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ServerQueueInfo -> String -> String
showsPrec :: Int -> ServerQueueInfo -> String -> String
$cshow :: ServerQueueInfo -> String
show :: ServerQueueInfo -> String
$cshowList :: [ServerQueueInfo] -> String -> String
showList :: [ServerQueueInfo] -> String -> String
Show)

getQueueInfo :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ServerQueueInfo
getQueueInfo :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ServerQueueInfo
getQueueInfo AgentClient
c NetworkRequestMode
nm rq :: RcvQueue
rq@RcvQueue {ProtocolServer 'PSMP
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> ProtocolServer 'PSMP
server :: ProtocolServer 'PSMP
server, RecipientId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
rcvId :: RecipientId
rcvId, SndPrivateAuthKey
$sel:rcvPrivateKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SndPrivateAuthKey
rcvPrivateKey :: SndPrivateAuthKey
rcvPrivateKey, RecipientId
$sel:sndId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> RecipientId
sndId :: RecipientId
sndId, QueueStatus
$sel:status:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueStatus
status :: QueueStatus
status, Maybe ClientNtfCreds
$sel:clientNtfCreds:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Maybe ClientNtfCreds
clientNtfCreds :: Maybe ClientNtfCreds
clientNtfCreds} =
  AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO ServerQueueInfo)
-> AM ServerQueueInfo
forall q a.
SMPQueueRec q =>
AgentClient
-> NetworkRequestMode
-> q
-> ByteString
-> (SMPClient -> ExceptT SMPClientError IO a)
-> AM a
withSMPClient AgentClient
c NetworkRequestMode
nm RcvQueue
rq ByteString
"QUE" ((SMPClient -> ExceptT SMPClientError IO ServerQueueInfo)
 -> AM ServerQueueInfo)
-> (SMPClient -> ExceptT SMPClientError IO ServerQueueInfo)
-> AM ServerQueueInfo
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp -> do
    QueueInfo
info <- SMPClient
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO QueueInfo
getSMPQueueInfo SMPClient
smp NetworkRequestMode
nm SndPrivateAuthKey
rcvPrivateKey RecipientId
rcvId
    let ntfId :: Maybe Text
ntfId = RecipientId -> Text
enc (RecipientId -> Text)
-> (ClientNtfCreds -> RecipientId) -> ClientNtfCreds -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ClientNtfCreds {RecipientId
$sel:notifierId:ClientNtfCreds :: ClientNtfCreds -> RecipientId
notifierId :: RecipientId
notifierId} -> RecipientId
notifierId) (ClientNtfCreds -> Text) -> Maybe ClientNtfCreds -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ClientNtfCreds
clientNtfCreds
    ServerQueueInfo -> ExceptT SMPClientError IO ServerQueueInfo
forall a. a -> ExceptT SMPClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerQueueInfo {ProtocolServer 'PSMP
$sel:server:ServerQueueInfo :: ProtocolServer 'PSMP
server :: ProtocolServer 'PSMP
server, $sel:rcvId:ServerQueueInfo :: Text
rcvId = RecipientId -> Text
enc RecipientId
rcvId, $sel:sndId:ServerQueueInfo :: Text
sndId = RecipientId -> Text
enc RecipientId
sndId, Maybe Text
$sel:ntfId:ServerQueueInfo :: Maybe Text
ntfId :: Maybe Text
ntfId, $sel:status:ServerQueueInfo :: Text
status = QueueStatus -> Text
serializeQueueStatus QueueStatus
status, QueueInfo
$sel:info:ServerQueueInfo :: QueueInfo
info :: QueueInfo
info}
  where
    enc :: RecipientId -> Text
enc = ByteString -> Text
decodeLatin1 (ByteString -> Text)
-> (RecipientId -> ByteString) -> RecipientId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64.encode (ByteString -> ByteString)
-> (RecipientId -> ByteString) -> RecipientId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientId -> ByteString
unEntityId

agentNtfRegisterToken :: AgentClient -> NetworkRequestMode -> NtfToken -> SMP.NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519)
agentNtfRegisterToken :: AgentClient
-> NetworkRequestMode
-> NtfToken
-> APublicAuthKey
-> RcvPublicDhKey
-> AM (RecipientId, RcvPublicDhKey)
agentNtfRegisterToken AgentClient
c NetworkRequestMode
nm NtfToken {DeviceToken
deviceToken :: DeviceToken
$sel:deviceToken:NtfToken :: NtfToken -> DeviceToken
deviceToken, ProtocolServer 'PNTF
ntfServer :: ProtocolServer 'PNTF
$sel:ntfServer:NtfToken :: NtfToken -> ProtocolServer 'PNTF
ntfServer, SndPrivateAuthKey
ntfPrivKey :: SndPrivateAuthKey
$sel:ntfPrivKey:NtfToken :: NtfToken -> SndPrivateAuthKey
ntfPrivKey} APublicAuthKey
ntfPubKey RcvPublicDhKey
pubDhKey =
  AgentClient
-> NetworkRequestMode
-> NtfTransportSession
-> (Client NtfResponse
    -> ExceptT SMPClientError IO (RecipientId, RcvPublicDhKey))
-> AM (RecipientId, RcvPublicDhKey)
forall v err msg a.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> (Client msg -> ExceptT (ProtocolClientError err) IO a)
-> AM a
withClient AgentClient
c NetworkRequestMode
nm (UserId
0, ProtoServer NtfResponse
ProtocolServer 'PNTF
ntfServer, Maybe ByteString
forall a. Maybe a
Nothing) ((Client NtfResponse
  -> ExceptT SMPClientError IO (RecipientId, RcvPublicDhKey))
 -> AM (RecipientId, RcvPublicDhKey))
-> (Client NtfResponse
    -> ExceptT SMPClientError IO (RecipientId, RcvPublicDhKey))
-> AM (RecipientId, RcvPublicDhKey)
forall a b. (a -> b) -> a -> b
$ \Client NtfResponse
ntf -> ProtocolClient NTFVersion ErrorType NtfResponse
-> NetworkRequestMode
-> SndPrivateAuthKey
-> NewNtfEntity 'Token
-> ExceptT SMPClientError IO (RecipientId, RcvPublicDhKey)
ntfRegisterToken ProtocolClient NTFVersion ErrorType NtfResponse
Client NtfResponse
ntf NetworkRequestMode
nm SndPrivateAuthKey
ntfPrivKey (DeviceToken
-> APublicAuthKey -> RcvPublicDhKey -> NewNtfEntity 'Token
NewNtfTkn DeviceToken
deviceToken APublicAuthKey
ntfPubKey RcvPublicDhKey
pubDhKey)

agentNtfVerifyToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> NtfRegCode -> AM ()
agentNtfVerifyToken :: AgentClient
-> NetworkRequestMode
-> RecipientId
-> NtfToken
-> NtfRegCode
-> ExceptT AgentErrorType (ReaderT Env IO) ()
agentNtfVerifyToken AgentClient
c NetworkRequestMode
nm RecipientId
tknId NtfToken {ProtocolServer 'PNTF
$sel:ntfServer:NtfToken :: NtfToken -> ProtocolServer 'PNTF
ntfServer :: ProtocolServer 'PNTF
ntfServer, SndPrivateAuthKey
$sel:ntfPrivKey:NtfToken :: NtfToken -> SndPrivateAuthKey
ntfPrivKey :: SndPrivateAuthKey
ntfPrivKey} NtfRegCode
code =
  AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a.
AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO a)
-> AM a
withNtfClient AgentClient
c NetworkRequestMode
nm ProtocolServer 'PNTF
ntfServer RecipientId
tknId ByteString
"TVFY" ((ProtocolClient NTFVersion ErrorType NtfResponse
  -> ExceptT SMPClientError IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \ProtocolClient NTFVersion ErrorType NtfResponse
ntf -> ProtocolClient NTFVersion ErrorType NtfResponse
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> NtfRegCode
-> ExceptT SMPClientError IO ()
ntfVerifyToken ProtocolClient NTFVersion ErrorType NtfResponse
ntf NetworkRequestMode
nm SndPrivateAuthKey
ntfPrivKey RecipientId
tknId NtfRegCode
code

agentNtfCheckToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> AM NtfTknStatus
agentNtfCheckToken :: AgentClient
-> NetworkRequestMode -> RecipientId -> NtfToken -> AM NtfTknStatus
agentNtfCheckToken AgentClient
c NetworkRequestMode
nm RecipientId
tknId NtfToken {ProtocolServer 'PNTF
$sel:ntfServer:NtfToken :: NtfToken -> ProtocolServer 'PNTF
ntfServer :: ProtocolServer 'PNTF
ntfServer, SndPrivateAuthKey
$sel:ntfPrivKey:NtfToken :: NtfToken -> SndPrivateAuthKey
ntfPrivKey :: SndPrivateAuthKey
ntfPrivKey} =
  AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO NtfTknStatus)
-> AM NtfTknStatus
forall a.
AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO a)
-> AM a
withNtfClient AgentClient
c NetworkRequestMode
nm ProtocolServer 'PNTF
ntfServer RecipientId
tknId ByteString
"TCHK" ((ProtocolClient NTFVersion ErrorType NtfResponse
  -> ExceptT SMPClientError IO NtfTknStatus)
 -> AM NtfTknStatus)
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO NtfTknStatus)
-> AM NtfTknStatus
forall a b. (a -> b) -> a -> b
$ \ProtocolClient NTFVersion ErrorType NtfResponse
ntf -> ProtocolClient NTFVersion ErrorType NtfResponse
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO NtfTknStatus
ntfCheckToken ProtocolClient NTFVersion ErrorType NtfResponse
ntf NetworkRequestMode
nm SndPrivateAuthKey
ntfPrivKey RecipientId
tknId

agentNtfReplaceToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> DeviceToken -> AM ()
agentNtfReplaceToken :: AgentClient
-> NetworkRequestMode
-> RecipientId
-> NtfToken
-> DeviceToken
-> ExceptT AgentErrorType (ReaderT Env IO) ()
agentNtfReplaceToken AgentClient
c NetworkRequestMode
nm RecipientId
tknId NtfToken {ProtocolServer 'PNTF
$sel:ntfServer:NtfToken :: NtfToken -> ProtocolServer 'PNTF
ntfServer :: ProtocolServer 'PNTF
ntfServer, SndPrivateAuthKey
$sel:ntfPrivKey:NtfToken :: NtfToken -> SndPrivateAuthKey
ntfPrivKey :: SndPrivateAuthKey
ntfPrivKey} DeviceToken
token =
  AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a.
AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO a)
-> AM a
withNtfClient AgentClient
c NetworkRequestMode
nm ProtocolServer 'PNTF
ntfServer RecipientId
tknId ByteString
"TRPL" ((ProtocolClient NTFVersion ErrorType NtfResponse
  -> ExceptT SMPClientError IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \ProtocolClient NTFVersion ErrorType NtfResponse
ntf -> ProtocolClient NTFVersion ErrorType NtfResponse
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> DeviceToken
-> ExceptT SMPClientError IO ()
ntfReplaceToken ProtocolClient NTFVersion ErrorType NtfResponse
ntf NetworkRequestMode
nm SndPrivateAuthKey
ntfPrivKey RecipientId
tknId DeviceToken
token

agentNtfDeleteToken :: AgentClient -> NetworkRequestMode -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> AM ()
agentNtfDeleteToken :: AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
agentNtfDeleteToken AgentClient
c NetworkRequestMode
nm ProtocolServer 'PNTF
ntfServer SndPrivateAuthKey
ntfPrivKey RecipientId
tknId =
  AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a.
AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO a)
-> AM a
withNtfClient AgentClient
c NetworkRequestMode
nm ProtocolServer 'PNTF
ntfServer RecipientId
tknId ByteString
"TDEL" ((ProtocolClient NTFVersion ErrorType NtfResponse
  -> ExceptT SMPClientError IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \ProtocolClient NTFVersion ErrorType NtfResponse
ntf -> ProtocolClient NTFVersion ErrorType NtfResponse
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO ()
ntfDeleteToken ProtocolClient NTFVersion ErrorType NtfResponse
ntf NetworkRequestMode
nm SndPrivateAuthKey
ntfPrivKey RecipientId
tknId

-- set to 0 to disable
agentNtfSetCronInterval :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> Word16 -> AM ()
agentNtfSetCronInterval :: AgentClient
-> NetworkRequestMode
-> RecipientId
-> NtfToken
-> Word16
-> ExceptT AgentErrorType (ReaderT Env IO) ()
agentNtfSetCronInterval AgentClient
c NetworkRequestMode
nm RecipientId
tknId NtfToken {ProtocolServer 'PNTF
$sel:ntfServer:NtfToken :: NtfToken -> ProtocolServer 'PNTF
ntfServer :: ProtocolServer 'PNTF
ntfServer, SndPrivateAuthKey
$sel:ntfPrivKey:NtfToken :: NtfToken -> SndPrivateAuthKey
ntfPrivKey :: SndPrivateAuthKey
ntfPrivKey} Word16
interval =
  AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a.
AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO a)
-> AM a
withNtfClient AgentClient
c NetworkRequestMode
nm ProtocolServer 'PNTF
ntfServer RecipientId
tknId ByteString
"TCRN" ((ProtocolClient NTFVersion ErrorType NtfResponse
  -> ExceptT SMPClientError IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \ProtocolClient NTFVersion ErrorType NtfResponse
ntf -> ProtocolClient NTFVersion ErrorType NtfResponse
-> NetworkRequestMode
-> SndPrivateAuthKey
-> RecipientId
-> Word16
-> ExceptT SMPClientError IO ()
ntfSetCronInterval ProtocolClient NTFVersion ErrorType NtfResponse
ntf NetworkRequestMode
nm SndPrivateAuthKey
ntfPrivKey RecipientId
tknId Word16
interval

agentNtfCreateSubscription :: AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateAuthKey -> AM NtfSubscriptionId
agentNtfCreateSubscription :: AgentClient
-> RecipientId
-> NtfToken
-> SMPQueueNtf
-> SndPrivateAuthKey
-> AM RecipientId
agentNtfCreateSubscription AgentClient
c RecipientId
tknId NtfToken {ProtocolServer 'PNTF
$sel:ntfServer:NtfToken :: NtfToken -> ProtocolServer 'PNTF
ntfServer :: ProtocolServer 'PNTF
ntfServer, SndPrivateAuthKey
$sel:ntfPrivKey:NtfToken :: NtfToken -> SndPrivateAuthKey
ntfPrivKey :: SndPrivateAuthKey
ntfPrivKey} SMPQueueNtf
smpQueue SndPrivateAuthKey
nKey =
  AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO RecipientId)
-> AM RecipientId
forall a.
AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO a)
-> AM a
withNtfClient AgentClient
c NetworkRequestMode
NRMBackground ProtocolServer 'PNTF
ntfServer RecipientId
tknId ByteString
"SNEW" ((ProtocolClient NTFVersion ErrorType NtfResponse
  -> ExceptT SMPClientError IO RecipientId)
 -> AM RecipientId)
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO RecipientId)
-> AM RecipientId
forall a b. (a -> b) -> a -> b
$ \ProtocolClient NTFVersion ErrorType NtfResponse
ntf -> ProtocolClient NTFVersion ErrorType NtfResponse
-> SndPrivateAuthKey
-> NewNtfEntity 'Subscription
-> ExceptT SMPClientError IO RecipientId
ntfCreateSubscription ProtocolClient NTFVersion ErrorType NtfResponse
ntf SndPrivateAuthKey
ntfPrivKey (RecipientId
-> SMPQueueNtf -> SndPrivateAuthKey -> NewNtfEntity 'Subscription
NewNtfSub RecipientId
tknId SMPQueueNtf
smpQueue SndPrivateAuthKey
nKey)

agentNtfCreateSubscriptions :: AgentClient -> NtfToken -> NonEmpty (NewNtfEntity 'Subscription) -> AM' (NonEmpty (Either AgentErrorType NtfSubscriptionId))
agentNtfCreateSubscriptions :: AgentClient
-> NtfToken
-> NonEmpty (NewNtfEntity 'Subscription)
-> AM' (NonEmpty (Either AgentErrorType RecipientId))
agentNtfCreateSubscriptions = ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> SndPrivateAuthKey
    -> NonEmpty (NewNtfEntity 'Subscription)
    -> IO (NonEmpty (Either SMPClientError RecipientId)))
-> AgentClient
-> NtfToken
-> NonEmpty (NewNtfEntity 'Subscription)
-> AM' (NonEmpty (Either AgentErrorType RecipientId))
forall a r.
ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> SndPrivateAuthKey
    -> NonEmpty a
    -> IO (NonEmpty (Either SMPClientError r)))
-> AgentClient
-> NtfToken
-> NonEmpty a
-> AM' (NonEmpty (Either AgentErrorType r))
withNtfBatch ByteString
"SNEW" ProtocolClient NTFVersion ErrorType NtfResponse
-> SndPrivateAuthKey
-> NonEmpty (NewNtfEntity 'Subscription)
-> IO (NonEmpty (Either SMPClientError RecipientId))
ntfCreateSubscriptions

agentNtfCheckSubscription :: AgentClient -> NtfToken -> NtfSubscriptionId -> AM NtfSubStatus
agentNtfCheckSubscription :: AgentClient -> NtfToken -> RecipientId -> AM NtfSubStatus
agentNtfCheckSubscription AgentClient
c NtfToken {ProtocolServer 'PNTF
$sel:ntfServer:NtfToken :: NtfToken -> ProtocolServer 'PNTF
ntfServer :: ProtocolServer 'PNTF
ntfServer, SndPrivateAuthKey
$sel:ntfPrivKey:NtfToken :: NtfToken -> SndPrivateAuthKey
ntfPrivKey :: SndPrivateAuthKey
ntfPrivKey} RecipientId
subId =
  AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO NtfSubStatus)
-> AM NtfSubStatus
forall a.
AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO a)
-> AM a
withNtfClient AgentClient
c NetworkRequestMode
NRMBackground ProtocolServer 'PNTF
ntfServer RecipientId
subId ByteString
"SCHK" ((ProtocolClient NTFVersion ErrorType NtfResponse
  -> ExceptT SMPClientError IO NtfSubStatus)
 -> AM NtfSubStatus)
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO NtfSubStatus)
-> AM NtfSubStatus
forall a b. (a -> b) -> a -> b
$ \ProtocolClient NTFVersion ErrorType NtfResponse
ntf -> ProtocolClient NTFVersion ErrorType NtfResponse
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT SMPClientError IO NtfSubStatus
ntfCheckSubscription ProtocolClient NTFVersion ErrorType NtfResponse
ntf SndPrivateAuthKey
ntfPrivKey RecipientId
subId

agentNtfCheckSubscriptions :: AgentClient -> NtfToken -> NonEmpty NtfSubscriptionId -> AM' (NonEmpty (Either AgentErrorType NtfSubStatus))
agentNtfCheckSubscriptions :: AgentClient
-> NtfToken
-> NonEmpty RecipientId
-> AM' (NonEmpty (Either AgentErrorType NtfSubStatus))
agentNtfCheckSubscriptions = ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> SndPrivateAuthKey
    -> NonEmpty RecipientId
    -> IO (NonEmpty (Either SMPClientError NtfSubStatus)))
-> AgentClient
-> NtfToken
-> NonEmpty RecipientId
-> AM' (NonEmpty (Either AgentErrorType NtfSubStatus))
forall a r.
ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> SndPrivateAuthKey
    -> NonEmpty a
    -> IO (NonEmpty (Either SMPClientError r)))
-> AgentClient
-> NtfToken
-> NonEmpty a
-> AM' (NonEmpty (Either AgentErrorType r))
withNtfBatch ByteString
"SCHK" ProtocolClient NTFVersion ErrorType NtfResponse
-> SndPrivateAuthKey
-> NonEmpty RecipientId
-> IO (NonEmpty (Either SMPClientError NtfSubStatus))
ntfCheckSubscriptions

-- This batch sends all commands to one ntf server (client can only use one server at a time)
withNtfBatch ::
  ByteString ->
  (NtfClient -> C.APrivateAuthKey -> NonEmpty a -> IO (NonEmpty (Either NtfClientError r))) ->
  AgentClient ->
  NtfToken ->
  NonEmpty a ->
  AM' (NonEmpty (Either AgentErrorType r))
withNtfBatch :: forall a r.
ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> SndPrivateAuthKey
    -> NonEmpty a
    -> IO (NonEmpty (Either SMPClientError r)))
-> AgentClient
-> NtfToken
-> NonEmpty a
-> AM' (NonEmpty (Either AgentErrorType r))
withNtfBatch ByteString
cmdStr ProtocolClient NTFVersion ErrorType NtfResponse
-> SndPrivateAuthKey
-> NonEmpty a
-> IO (NonEmpty (Either SMPClientError r))
action AgentClient
c NtfToken {ProtocolServer 'PNTF
$sel:ntfServer:NtfToken :: NtfToken -> ProtocolServer 'PNTF
ntfServer :: ProtocolServer 'PNTF
ntfServer, SndPrivateAuthKey
$sel:ntfPrivKey:NtfToken :: NtfToken -> SndPrivateAuthKey
ntfPrivKey :: SndPrivateAuthKey
ntfPrivKey} NonEmpty a
subs = do
  let tSess :: (UserId, ProtocolServer 'PNTF, Maybe ByteString)
tSess = (UserId
0, ProtocolServer 'PNTF
ntfServer, Maybe ByteString
forall a. Maybe a
Nothing)
  AM (ProtocolClient NTFVersion ErrorType NtfResponse)
-> ReaderT
     Env
     IO
     (Either
        AgentErrorType (ProtocolClient NTFVersion ErrorType NtfResponse))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (AgentClient
-> NetworkRequestMode
-> NtfTransportSession
-> AM (ProtocolClient NTFVersion ErrorType NtfResponse)
getNtfServerClient AgentClient
c NetworkRequestMode
NRMBackground NtfTransportSession
(UserId, ProtocolServer 'PNTF, Maybe ByteString)
tSess) ReaderT
  Env
  IO
  (Either
     AgentErrorType (ProtocolClient NTFVersion ErrorType NtfResponse))
-> (Either
      AgentErrorType (ProtocolClient NTFVersion ErrorType NtfResponse)
    -> AM' (NonEmpty (Either AgentErrorType r)))
-> AM' (NonEmpty (Either AgentErrorType r))
forall a b.
ReaderT Env IO a -> (a -> ReaderT Env IO b) -> ReaderT Env IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left AgentErrorType
e -> NonEmpty (Either AgentErrorType r)
-> AM' (NonEmpty (Either AgentErrorType r))
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (Either AgentErrorType r)
 -> AM' (NonEmpty (Either AgentErrorType r)))
-> NonEmpty (Either AgentErrorType r)
-> AM' (NonEmpty (Either AgentErrorType r))
forall a b. (a -> b) -> a -> b
$ (a -> Either AgentErrorType r)
-> NonEmpty a -> NonEmpty (Either AgentErrorType r)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\a
_ -> AgentErrorType -> Either AgentErrorType r
forall a b. a -> Either a b
Left AgentErrorType
e) NonEmpty a
subs
    Right ProtocolClient NTFVersion ErrorType NtfResponse
ntf -> IO (NonEmpty (Either AgentErrorType r))
-> AM' (NonEmpty (Either AgentErrorType r))
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (NonEmpty (Either AgentErrorType r))
 -> AM' (NonEmpty (Either AgentErrorType r)))
-> IO (NonEmpty (Either AgentErrorType r))
-> AM' (NonEmpty (Either AgentErrorType r))
forall a b. (a -> b) -> a -> b
$ do
      ByteString
-> AgentClient
-> ProtocolServer 'PNTF
-> ByteString
-> ByteString
-> IO ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> ByteString
-> ByteString
-> m ()
logServer' ByteString
"-->" AgentClient
c ProtocolServer 'PNTF
ntfServer (Int -> ByteString
forall a. Show a => a -> ByteString
bshow (NonEmpty a -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty a
subs) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" subscriptions") ByteString
cmdStr
      (Either SMPClientError r -> Either AgentErrorType r)
-> NonEmpty (Either SMPClientError r)
-> NonEmpty (Either AgentErrorType r)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map Either SMPClientError r -> Either AgentErrorType r
agentError (NonEmpty (Either SMPClientError r)
 -> NonEmpty (Either AgentErrorType r))
-> IO (NonEmpty (Either SMPClientError r))
-> IO (NonEmpty (Either AgentErrorType r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolClient NTFVersion ErrorType NtfResponse
-> SndPrivateAuthKey
-> NonEmpty a
-> IO (NonEmpty (Either SMPClientError r))
action ProtocolClient NTFVersion ErrorType NtfResponse
ntf SndPrivateAuthKey
ntfPrivKey NonEmpty a
subs
      where
        agentError :: Either SMPClientError r -> Either AgentErrorType r
agentError = (SMPClientError -> AgentErrorType)
-> Either SMPClientError r -> Either AgentErrorType r
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((SMPClientError -> AgentErrorType)
 -> Either SMPClientError r -> Either AgentErrorType r)
-> (SMPClientError -> AgentErrorType)
-> Either SMPClientError r
-> Either AgentErrorType r
forall a b. (a -> b) -> a -> b
$ (String -> ErrorType -> AgentErrorType)
-> String -> SMPClientError -> AgentErrorType
forall err.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
protocolClientError String -> ErrorType -> AgentErrorType
NTF (String -> SMPClientError -> AgentErrorType)
-> String -> SMPClientError -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B.unpack (ProtocolServer 'PNTF -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtocolServer 'PNTF
ntfServer)

agentNtfDeleteSubscription :: AgentClient -> NtfSubscriptionId -> NtfToken -> AM ()
agentNtfDeleteSubscription :: AgentClient
-> RecipientId
-> NtfToken
-> ExceptT AgentErrorType (ReaderT Env IO) ()
agentNtfDeleteSubscription AgentClient
c RecipientId
subId NtfToken {ProtocolServer 'PNTF
$sel:ntfServer:NtfToken :: NtfToken -> ProtocolServer 'PNTF
ntfServer :: ProtocolServer 'PNTF
ntfServer, SndPrivateAuthKey
$sel:ntfPrivKey:NtfToken :: NtfToken -> SndPrivateAuthKey
ntfPrivKey :: SndPrivateAuthKey
ntfPrivKey} =
  AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a.
AgentClient
-> NetworkRequestMode
-> ProtocolServer 'PNTF
-> RecipientId
-> ByteString
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO a)
-> AM a
withNtfClient AgentClient
c NetworkRequestMode
NRMBackground ProtocolServer 'PNTF
ntfServer RecipientId
subId ByteString
"SDEL" ((ProtocolClient NTFVersion ErrorType NtfResponse
  -> ExceptT SMPClientError IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ProtocolClient NTFVersion ErrorType NtfResponse
    -> ExceptT SMPClientError IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \ProtocolClient NTFVersion ErrorType NtfResponse
ntf -> ProtocolClient NTFVersion ErrorType NtfResponse
-> SndPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
ntfDeleteSubscription ProtocolClient NTFVersion ErrorType NtfResponse
ntf SndPrivateAuthKey
ntfPrivKey RecipientId
subId

agentXFTPDownloadChunk :: AgentClient -> UserId -> FileDigest -> RcvFileChunkReplica -> XFTPRcvChunkSpec -> AM ()
agentXFTPDownloadChunk :: AgentClient
-> UserId
-> FileDigest
-> RcvFileChunkReplica
-> XFTPRcvChunkSpec
-> ExceptT AgentErrorType (ReaderT Env IO) ()
agentXFTPDownloadChunk AgentClient
c UserId
userId (FileDigest ByteString
chunkDigest) RcvFileChunkReplica {ProtocolServer 'PXFTP
server :: ProtocolServer 'PXFTP
$sel:server:RcvFileChunkReplica :: RcvFileChunkReplica -> ProtocolServer 'PXFTP
server, $sel:replicaId:RcvFileChunkReplica :: RcvFileChunkReplica -> ChunkReplicaId
replicaId = ChunkReplicaId RecipientId
fId, SndPrivateAuthKey
replicaKey :: SndPrivateAuthKey
$sel:replicaKey:RcvFileChunkReplica :: RcvFileChunkReplica -> SndPrivateAuthKey
replicaKey} XFTPRcvChunkSpec
chunkSpec = do
  TVar ChaChaDRG
g <- (Env -> TVar ChaChaDRG)
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
random
  AgentClient
-> (UserId, ProtoServer FileResponse, ByteString)
-> ByteString
-> (Client FileResponse
    -> ExceptT (ProtocolClientError XFTPErrorType) IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall v err msg b.
ProtocolServerClient v err msg =>
AgentClient
-> (UserId, ProtoServer msg, ByteString)
-> ByteString
-> (Client msg -> ExceptT (ProtocolClientError err) IO b)
-> AM b
withXFTPClient AgentClient
c (UserId
userId, ProtoServer FileResponse
ProtocolServer 'PXFTP
server, ByteString
chunkDigest) ByteString
"FGET" ((Client FileResponse
  -> ExceptT (ProtocolClientError XFTPErrorType) IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Client FileResponse
    -> ExceptT (ProtocolClientError XFTPErrorType) IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Client FileResponse
xftp -> TVar ChaChaDRG
-> XFTPClient
-> SndPrivateAuthKey
-> RecipientId
-> XFTPRcvChunkSpec
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
X.downloadXFTPChunk TVar ChaChaDRG
g XFTPClient
Client FileResponse
xftp SndPrivateAuthKey
replicaKey RecipientId
fId XFTPRcvChunkSpec
chunkSpec

agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> AM NewSndChunkReplica
agentXFTPNewChunk :: AgentClient
-> SndFileChunk
-> Int
-> XFTPServerWithAuth
-> AM NewSndChunkReplica
agentXFTPNewChunk AgentClient
c SndFileChunk {UserId
userId :: UserId
$sel:userId:SndFileChunk :: SndFileChunk -> UserId
userId, $sel:chunkSpec:SndFileChunk :: SndFileChunk -> XFTPChunkSpec
chunkSpec = XFTPChunkSpec {Word32
$sel:chunkSize:XFTPChunkSpec :: XFTPChunkSpec -> Word32
chunkSize :: Word32
chunkSize}, $sel:digest:SndFileChunk :: SndFileChunk -> FileDigest
digest = FileDigest ByteString
chunkDigest} Int
n (ProtoServerWithAuth ProtocolServer 'PXFTP
srv Maybe BasicAuth
auth) = do
  NonEmpty (APublicAuthKey, SndPrivateAuthKey)
rKeys <- Int -> AM (NonEmpty AAuthKeyPair)
xftpRcvKeys Int
n
  (APublicAuthKey
sndKey, SndPrivateAuthKey
replicaKey) <- STM (APublicAuthKey, SndPrivateAuthKey)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (APublicAuthKey, SndPrivateAuthKey)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (APublicAuthKey, SndPrivateAuthKey)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (APublicAuthKey, SndPrivateAuthKey))
-> (TVar ChaChaDRG -> STM (APublicAuthKey, SndPrivateAuthKey))
-> TVar ChaChaDRG
-> ExceptT
     AgentErrorType (ReaderT Env IO) (APublicAuthKey, SndPrivateAuthKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SAlgorithm 'Ed25519 -> TVar ChaChaDRG -> STM AAuthKeyPair
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
C.generateAuthKeyPair SAlgorithm 'Ed25519
C.SEd25519 (TVar ChaChaDRG
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (APublicAuthKey, SndPrivateAuthKey))
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (APublicAuthKey, SndPrivateAuthKey)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env -> TVar ChaChaDRG)
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
random
  let fileInfo :: FileInfo
fileInfo = FileInfo {APublicAuthKey
sndKey :: APublicAuthKey
sndKey :: APublicAuthKey
sndKey, size :: Word32
size = Word32
chunkSize, digest :: ByteString
digest = ByteString
chunkDigest}
  ByteString
-> AgentClient
-> ProtocolServer 'PXFTP
-> RecipientId
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> RecipientId
-> ByteString
-> m ()
logServer ByteString
"-->" AgentClient
c ProtocolServer 'PXFTP
srv RecipientId
NoEntity ByteString
"FNEW"
  XFTPTransportSession
tSess <- AgentClient
-> UserId
-> ProtoServer FileResponse
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) XFTPTransportSession
forall (m :: * -> *) msg.
MonadIO m =>
AgentClient
-> UserId
-> ProtoServer msg
-> ByteString
-> m (TransportSession msg)
mkTransportSession AgentClient
c UserId
userId ProtoServer FileResponse
ProtocolServer 'PXFTP
srv ByteString
chunkDigest
  (RecipientId
sndId, NonEmpty RecipientId
rIds) <- AgentClient
-> NetworkRequestMode
-> XFTPTransportSession
-> (Client FileResponse
    -> ExceptT
         (ProtocolClientError XFTPErrorType)
         IO
         (RecipientId, NonEmpty RecipientId))
-> AM (RecipientId, NonEmpty RecipientId)
forall v err msg a.
ProtocolServerClient v err msg =>
AgentClient
-> NetworkRequestMode
-> TransportSession msg
-> (Client msg -> ExceptT (ProtocolClientError err) IO a)
-> AM a
withClient AgentClient
c NetworkRequestMode
NRMBackground XFTPTransportSession
tSess ((Client FileResponse
  -> ExceptT
       (ProtocolClientError XFTPErrorType)
       IO
       (RecipientId, NonEmpty RecipientId))
 -> AM (RecipientId, NonEmpty RecipientId))
-> (Client FileResponse
    -> ExceptT
         (ProtocolClientError XFTPErrorType)
         IO
         (RecipientId, NonEmpty RecipientId))
-> AM (RecipientId, NonEmpty RecipientId)
forall a b. (a -> b) -> a -> b
$ \Client FileResponse
xftp -> XFTPClient
-> SndPrivateAuthKey
-> FileInfo
-> NonEmpty APublicAuthKey
-> Maybe BasicAuth
-> ExceptT
     (ProtocolClientError XFTPErrorType)
     IO
     (RecipientId, NonEmpty RecipientId)
X.createXFTPChunk XFTPClient
Client FileResponse
xftp SndPrivateAuthKey
replicaKey FileInfo
fileInfo (((APublicAuthKey, SndPrivateAuthKey) -> APublicAuthKey)
-> NonEmpty (APublicAuthKey, SndPrivateAuthKey)
-> NonEmpty APublicAuthKey
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (APublicAuthKey, SndPrivateAuthKey) -> APublicAuthKey
forall a b. (a, b) -> a
fst NonEmpty (APublicAuthKey, SndPrivateAuthKey)
rKeys) Maybe BasicAuth
auth
  ByteString
-> AgentClient
-> ProtocolServer 'PXFTP
-> RecipientId
-> ByteString
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ByteString
-> AgentClient
-> ProtocolServer s
-> RecipientId
-> ByteString
-> m ()
logServer ByteString
"<--" AgentClient
c ProtocolServer 'PXFTP
srv RecipientId
NoEntity (ByteString -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ByteString -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.unwords [ByteString
Item [ByteString]
"SIDS", RecipientId -> ByteString
logSecret RecipientId
sndId]
  NewSndChunkReplica -> AM NewSndChunkReplica
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NewSndChunkReplica {$sel:server:NewSndChunkReplica :: ProtocolServer 'PXFTP
server = ProtocolServer 'PXFTP
srv, $sel:replicaId:NewSndChunkReplica :: ChunkReplicaId
replicaId = RecipientId -> ChunkReplicaId
ChunkReplicaId RecipientId
sndId, SndPrivateAuthKey
replicaKey :: SndPrivateAuthKey
$sel:replicaKey:NewSndChunkReplica :: SndPrivateAuthKey
replicaKey, $sel:rcvIdsKeys:NewSndChunkReplica :: [(ChunkReplicaId, SndPrivateAuthKey)]
rcvIdsKeys = NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
-> [(ChunkReplicaId, SndPrivateAuthKey)]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
 -> [(ChunkReplicaId, SndPrivateAuthKey)])
-> NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
-> [(ChunkReplicaId, SndPrivateAuthKey)]
forall a b. (a -> b) -> a -> b
$ NonEmpty RecipientId
-> NonEmpty AAuthKeyPair
-> NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
xftpRcvIdsKeys NonEmpty RecipientId
rIds NonEmpty AAuthKeyPair
NonEmpty (APublicAuthKey, SndPrivateAuthKey)
rKeys}

agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM ()
agentXFTPUploadChunk :: AgentClient
-> UserId
-> FileDigest
-> SndFileChunkReplica
-> XFTPChunkSpec
-> ExceptT AgentErrorType (ReaderT Env IO) ()
agentXFTPUploadChunk AgentClient
c UserId
userId (FileDigest ByteString
chunkDigest) SndFileChunkReplica {ProtocolServer 'PXFTP
server :: ProtocolServer 'PXFTP
$sel:server:SndFileChunkReplica :: SndFileChunkReplica -> ProtocolServer 'PXFTP
server, $sel:replicaId:SndFileChunkReplica :: SndFileChunkReplica -> ChunkReplicaId
replicaId = ChunkReplicaId RecipientId
fId, SndPrivateAuthKey
replicaKey :: SndPrivateAuthKey
$sel:replicaKey:SndFileChunkReplica :: SndFileChunkReplica -> SndPrivateAuthKey
replicaKey} XFTPChunkSpec
chunkSpec =
  AgentClient
-> (UserId, ProtoServer FileResponse, ByteString)
-> ByteString
-> (Client FileResponse
    -> ExceptT (ProtocolClientError XFTPErrorType) IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall v err msg b.
ProtocolServerClient v err msg =>
AgentClient
-> (UserId, ProtoServer msg, ByteString)
-> ByteString
-> (Client msg -> ExceptT (ProtocolClientError err) IO b)
-> AM b
withXFTPClient AgentClient
c (UserId
userId, ProtoServer FileResponse
ProtocolServer 'PXFTP
server, ByteString
chunkDigest) ByteString
"FPUT" ((Client FileResponse
  -> ExceptT (ProtocolClientError XFTPErrorType) IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Client FileResponse
    -> ExceptT (ProtocolClientError XFTPErrorType) IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Client FileResponse
xftp -> XFTPClient
-> SndPrivateAuthKey
-> RecipientId
-> XFTPChunkSpec
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
X.uploadXFTPChunk XFTPClient
Client FileResponse
xftp SndPrivateAuthKey
replicaKey RecipientId
fId XFTPChunkSpec
chunkSpec

agentXFTPAddRecipients :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> Int -> AM (NonEmpty (ChunkReplicaId, C.APrivateAuthKey))
agentXFTPAddRecipients :: AgentClient
-> UserId
-> FileDigest
-> SndFileChunkReplica
-> Int
-> AM (NonEmpty (ChunkReplicaId, SndPrivateAuthKey))
agentXFTPAddRecipients AgentClient
c UserId
userId (FileDigest ByteString
chunkDigest) SndFileChunkReplica {ProtocolServer 'PXFTP
$sel:server:SndFileChunkReplica :: SndFileChunkReplica -> ProtocolServer 'PXFTP
server :: ProtocolServer 'PXFTP
server, $sel:replicaId:SndFileChunkReplica :: SndFileChunkReplica -> ChunkReplicaId
replicaId = ChunkReplicaId RecipientId
fId, SndPrivateAuthKey
$sel:replicaKey:SndFileChunkReplica :: SndFileChunkReplica -> SndPrivateAuthKey
replicaKey :: SndPrivateAuthKey
replicaKey} Int
n = do
  NonEmpty (APublicAuthKey, SndPrivateAuthKey)
rKeys <- Int -> AM (NonEmpty AAuthKeyPair)
xftpRcvKeys Int
n
  NonEmpty RecipientId
rIds <- AgentClient
-> (UserId, ProtoServer FileResponse, ByteString)
-> ByteString
-> (Client FileResponse
    -> ExceptT
         (ProtocolClientError XFTPErrorType) IO (NonEmpty RecipientId))
-> AM (NonEmpty RecipientId)
forall v err msg b.
ProtocolServerClient v err msg =>
AgentClient
-> (UserId, ProtoServer msg, ByteString)
-> ByteString
-> (Client msg -> ExceptT (ProtocolClientError err) IO b)
-> AM b
withXFTPClient AgentClient
c (UserId
userId, ProtoServer FileResponse
ProtocolServer 'PXFTP
server, ByteString
chunkDigest) ByteString
"FADD" ((Client FileResponse
  -> ExceptT
       (ProtocolClientError XFTPErrorType) IO (NonEmpty RecipientId))
 -> AM (NonEmpty RecipientId))
-> (Client FileResponse
    -> ExceptT
         (ProtocolClientError XFTPErrorType) IO (NonEmpty RecipientId))
-> AM (NonEmpty RecipientId)
forall a b. (a -> b) -> a -> b
$ \Client FileResponse
xftp -> XFTPClient
-> SndPrivateAuthKey
-> RecipientId
-> NonEmpty APublicAuthKey
-> ExceptT
     (ProtocolClientError XFTPErrorType) IO (NonEmpty RecipientId)
X.addXFTPRecipients XFTPClient
Client FileResponse
xftp SndPrivateAuthKey
replicaKey RecipientId
fId (((APublicAuthKey, SndPrivateAuthKey) -> APublicAuthKey)
-> NonEmpty (APublicAuthKey, SndPrivateAuthKey)
-> NonEmpty APublicAuthKey
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (APublicAuthKey, SndPrivateAuthKey) -> APublicAuthKey
forall a b. (a, b) -> a
fst NonEmpty (APublicAuthKey, SndPrivateAuthKey)
rKeys)
  NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
-> AM (NonEmpty (ChunkReplicaId, SndPrivateAuthKey))
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
 -> AM (NonEmpty (ChunkReplicaId, SndPrivateAuthKey)))
-> NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
-> AM (NonEmpty (ChunkReplicaId, SndPrivateAuthKey))
forall a b. (a -> b) -> a -> b
$ NonEmpty RecipientId
-> NonEmpty AAuthKeyPair
-> NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
xftpRcvIdsKeys NonEmpty RecipientId
rIds NonEmpty AAuthKeyPair
NonEmpty (APublicAuthKey, SndPrivateAuthKey)
rKeys

agentXFTPDeleteChunk :: AgentClient -> UserId -> DeletedSndChunkReplica -> AM ()
agentXFTPDeleteChunk :: AgentClient
-> UserId
-> DeletedSndChunkReplica
-> ExceptT AgentErrorType (ReaderT Env IO) ()
agentXFTPDeleteChunk AgentClient
c UserId
userId DeletedSndChunkReplica {ProtocolServer 'PXFTP
server :: ProtocolServer 'PXFTP
$sel:server:DeletedSndChunkReplica :: DeletedSndChunkReplica -> ProtocolServer 'PXFTP
server, $sel:replicaId:DeletedSndChunkReplica :: DeletedSndChunkReplica -> ChunkReplicaId
replicaId = ChunkReplicaId RecipientId
fId, SndPrivateAuthKey
replicaKey :: SndPrivateAuthKey
$sel:replicaKey:DeletedSndChunkReplica :: DeletedSndChunkReplica -> SndPrivateAuthKey
replicaKey, $sel:chunkDigest:DeletedSndChunkReplica :: DeletedSndChunkReplica -> FileDigest
chunkDigest = FileDigest ByteString
chunkDigest} =
  AgentClient
-> (UserId, ProtoServer FileResponse, ByteString)
-> ByteString
-> (Client FileResponse
    -> ExceptT (ProtocolClientError XFTPErrorType) IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall v err msg b.
ProtocolServerClient v err msg =>
AgentClient
-> (UserId, ProtoServer msg, ByteString)
-> ByteString
-> (Client msg -> ExceptT (ProtocolClientError err) IO b)
-> AM b
withXFTPClient AgentClient
c (UserId
userId, ProtoServer FileResponse
ProtocolServer 'PXFTP
server, ByteString
chunkDigest) ByteString
"FDEL" ((Client FileResponse
  -> ExceptT (ProtocolClientError XFTPErrorType) IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Client FileResponse
    -> ExceptT (ProtocolClientError XFTPErrorType) IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Client FileResponse
xftp -> XFTPClient
-> SndPrivateAuthKey
-> RecipientId
-> ExceptT (ProtocolClientError XFTPErrorType) IO ()
X.deleteXFTPChunk XFTPClient
Client FileResponse
xftp SndPrivateAuthKey
replicaKey RecipientId
fId

xftpRcvKeys :: Int -> AM (NonEmpty C.AAuthKeyPair)
xftpRcvKeys :: Int -> AM (NonEmpty AAuthKeyPair)
xftpRcvKeys Int
n = do
  [(APublicAuthKey, SndPrivateAuthKey)]
rKeys <- STM [(APublicAuthKey, SndPrivateAuthKey)]
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     [(APublicAuthKey, SndPrivateAuthKey)]
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM [(APublicAuthKey, SndPrivateAuthKey)]
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      [(APublicAuthKey, SndPrivateAuthKey)])
-> (TVar ChaChaDRG -> STM [(APublicAuthKey, SndPrivateAuthKey)])
-> TVar ChaChaDRG
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     [(APublicAuthKey, SndPrivateAuthKey)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> STM (APublicAuthKey, SndPrivateAuthKey)
-> STM [(APublicAuthKey, SndPrivateAuthKey)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (STM (APublicAuthKey, SndPrivateAuthKey)
 -> STM [(APublicAuthKey, SndPrivateAuthKey)])
-> (TVar ChaChaDRG -> STM (APublicAuthKey, SndPrivateAuthKey))
-> TVar ChaChaDRG
-> STM [(APublicAuthKey, SndPrivateAuthKey)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SAlgorithm 'Ed25519 -> TVar ChaChaDRG -> STM AAuthKeyPair
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
C.generateAuthKeyPair SAlgorithm 'Ed25519
C.SEd25519 (TVar ChaChaDRG
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      [(APublicAuthKey, SndPrivateAuthKey)])
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     [(APublicAuthKey, SndPrivateAuthKey)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env -> TVar ChaChaDRG)
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
random
  case [(APublicAuthKey, SndPrivateAuthKey)]
-> Maybe (NonEmpty (APublicAuthKey, SndPrivateAuthKey))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [(APublicAuthKey, SndPrivateAuthKey)]
rKeys of
    Just NonEmpty (APublicAuthKey, SndPrivateAuthKey)
rKeys' -> NonEmpty (APublicAuthKey, SndPrivateAuthKey)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (NonEmpty (APublicAuthKey, SndPrivateAuthKey))
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty (APublicAuthKey, SndPrivateAuthKey)
rKeys'
    Maybe (NonEmpty (APublicAuthKey, SndPrivateAuthKey))
_ -> AgentErrorType
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (NonEmpty (APublicAuthKey, SndPrivateAuthKey))
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (NonEmpty (APublicAuthKey, SndPrivateAuthKey)))
-> AgentErrorType
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (NonEmpty (APublicAuthKey, SndPrivateAuthKey))
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"non-positive number of recipients"

xftpRcvIdsKeys :: NonEmpty EntityId -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey)
xftpRcvIdsKeys :: NonEmpty RecipientId
-> NonEmpty AAuthKeyPair
-> NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
xftpRcvIdsKeys NonEmpty RecipientId
rIds NonEmpty AAuthKeyPair
rKeys = (RecipientId -> ChunkReplicaId)
-> NonEmpty RecipientId -> NonEmpty ChunkReplicaId
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map RecipientId -> ChunkReplicaId
ChunkReplicaId NonEmpty RecipientId
rIds NonEmpty ChunkReplicaId
-> NonEmpty SndPrivateAuthKey
-> NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
`L.zip` ((APublicAuthKey, SndPrivateAuthKey) -> SndPrivateAuthKey)
-> NonEmpty (APublicAuthKey, SndPrivateAuthKey)
-> NonEmpty SndPrivateAuthKey
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (APublicAuthKey, SndPrivateAuthKey) -> SndPrivateAuthKey
forall a b. (a, b) -> b
snd NonEmpty AAuthKeyPair
NonEmpty (APublicAuthKey, SndPrivateAuthKey)
rKeys

agentCbEncrypt :: SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> AM ByteString
agentCbEncrypt :: SndQueue -> Maybe RcvPublicDhKey -> ByteString -> AM ByteString
agentCbEncrypt SndQueue {RcvDhSecret
e2eDhSecret :: RcvDhSecret
$sel:e2eDhSecret:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> RcvDhSecret
e2eDhSecret, VersionSMPC
smpClientVersion :: VersionSMPC
$sel:smpClientVersion:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> VersionSMPC
smpClientVersion} Maybe RcvPublicDhKey
e2ePubKey ByteString
msg = do
  CbNonce
cmNonce <- STM CbNonce -> ExceptT AgentErrorType (ReaderT Env IO) CbNonce
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM CbNonce -> ExceptT AgentErrorType (ReaderT Env IO) CbNonce)
-> (TVar ChaChaDRG -> STM CbNonce)
-> TVar ChaChaDRG
-> ExceptT AgentErrorType (ReaderT Env IO) CbNonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChaChaDRG -> STM CbNonce
C.randomCbNonce (TVar ChaChaDRG -> ExceptT AgentErrorType (ReaderT Env IO) CbNonce)
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
-> ExceptT AgentErrorType (ReaderT Env IO) CbNonce
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env -> TVar ChaChaDRG)
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
random
  let paddedLen :: Int
paddedLen = Int -> (RcvPublicDhKey -> Int) -> Maybe RcvPublicDhKey -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
SMP.e2eEncMessageLength (Int -> RcvPublicDhKey -> Int
forall a b. a -> b -> a
const Int
SMP.e2eEncConfirmationLength) Maybe RcvPublicDhKey
e2ePubKey
  ByteString
cmEncBody <-
    Either AgentErrorType ByteString -> AM ByteString
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either AgentErrorType ByteString -> AM ByteString)
-> (Either CryptoError ByteString
    -> Either AgentErrorType ByteString)
-> Either CryptoError ByteString
-> AM ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CryptoError -> AgentErrorType)
-> Either CryptoError ByteString
-> Either AgentErrorType ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CryptoError -> AgentErrorType
cryptoError (Either CryptoError ByteString -> AM ByteString)
-> Either CryptoError ByteString -> AM ByteString
forall a b. (a -> b) -> a -> b
$
      RcvDhSecret
-> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
C.cbEncrypt RcvDhSecret
e2eDhSecret CbNonce
cmNonce ByteString
msg Int
paddedLen
  let cmHeader :: PubHeader
cmHeader = VersionSMPC -> Maybe RcvPublicDhKey -> PubHeader
SMP.PubHeader VersionSMPC
smpClientVersion Maybe RcvPublicDhKey
e2ePubKey
  ByteString -> AM ByteString
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> AM ByteString) -> ByteString -> AM ByteString
forall a b. (a -> b) -> a -> b
$ ClientMsgEnvelope -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode SMP.ClientMsgEnvelope {PubHeader
cmHeader :: PubHeader
$sel:cmHeader:ClientMsgEnvelope :: PubHeader
cmHeader, CbNonce
cmNonce :: CbNonce
$sel:cmNonce:ClientMsgEnvelope :: CbNonce
cmNonce, ByteString
cmEncBody :: ByteString
$sel:cmEncBody:ClientMsgEnvelope :: ByteString
cmEncBody}

-- add encoding as AgentInvitation'?
agentCbEncryptOnce :: VersionSMPC -> C.PublicKeyX25519 -> ByteString -> AM ByteString
agentCbEncryptOnce :: VersionSMPC -> RcvPublicDhKey -> ByteString -> AM ByteString
agentCbEncryptOnce VersionSMPC
clientVersion RcvPublicDhKey
dhRcvPubKey ByteString
msg = do
  TVar ChaChaDRG
g <- (Env -> TVar ChaChaDRG)
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
random
  (RcvPublicDhKey
dhSndPubKey, PrivateKey 'X25519
dhSndPrivKey) <- STM (RcvPublicDhKey, PrivateKey 'X25519)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RcvPublicDhKey, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (RcvPublicDhKey, PrivateKey 'X25519)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (RcvPublicDhKey, PrivateKey 'X25519))
-> STM (RcvPublicDhKey, PrivateKey 'X25519)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RcvPublicDhKey, PrivateKey 'X25519)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
g
  let e2eDhSecret :: RcvDhSecret
e2eDhSecret = RcvPublicDhKey -> PrivateKey 'X25519 -> RcvDhSecret
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' RcvPublicDhKey
dhRcvPubKey PrivateKey 'X25519
dhSndPrivKey
  CbNonce
cmNonce <- STM CbNonce -> ExceptT AgentErrorType (ReaderT Env IO) CbNonce
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM CbNonce -> ExceptT AgentErrorType (ReaderT Env IO) CbNonce)
-> STM CbNonce -> ExceptT AgentErrorType (ReaderT Env IO) CbNonce
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM CbNonce
C.randomCbNonce TVar ChaChaDRG
g
  ByteString
cmEncBody <-
    Either AgentErrorType ByteString -> AM ByteString
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either AgentErrorType ByteString -> AM ByteString)
-> (Either CryptoError ByteString
    -> Either AgentErrorType ByteString)
-> Either CryptoError ByteString
-> AM ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CryptoError -> AgentErrorType)
-> Either CryptoError ByteString
-> Either AgentErrorType ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CryptoError -> AgentErrorType
cryptoError (Either CryptoError ByteString -> AM ByteString)
-> Either CryptoError ByteString -> AM ByteString
forall a b. (a -> b) -> a -> b
$
      RcvDhSecret
-> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
C.cbEncrypt RcvDhSecret
e2eDhSecret CbNonce
cmNonce ByteString
msg Int
SMP.e2eEncConfirmationLength
  let cmHeader :: PubHeader
cmHeader = VersionSMPC -> Maybe RcvPublicDhKey -> PubHeader
SMP.PubHeader VersionSMPC
clientVersion (RcvPublicDhKey -> Maybe RcvPublicDhKey
forall a. a -> Maybe a
Just RcvPublicDhKey
dhSndPubKey)
  ByteString -> AM ByteString
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> AM ByteString) -> ByteString -> AM ByteString
forall a b. (a -> b) -> a -> b
$ ClientMsgEnvelope -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode SMP.ClientMsgEnvelope {PubHeader
$sel:cmHeader:ClientMsgEnvelope :: PubHeader
cmHeader :: PubHeader
cmHeader, CbNonce
$sel:cmNonce:ClientMsgEnvelope :: CbNonce
cmNonce :: CbNonce
cmNonce, ByteString
$sel:cmEncBody:ClientMsgEnvelope :: ByteString
cmEncBody :: ByteString
cmEncBody}

-- | NaCl crypto-box decrypt - both for messages received from the server
-- and per-queue E2E encrypted messages from the sender that were inside.
agentCbDecrypt :: C.DhSecretX25519 -> C.CbNonce -> ByteString -> Either AgentErrorType ByteString
agentCbDecrypt :: RcvDhSecret
-> CbNonce -> ByteString -> Either AgentErrorType ByteString
agentCbDecrypt RcvDhSecret
dhSecret CbNonce
nonce ByteString
msg =
  (CryptoError -> AgentErrorType)
-> Either CryptoError ByteString
-> Either AgentErrorType ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CryptoError -> AgentErrorType
cryptoError (Either CryptoError ByteString -> Either AgentErrorType ByteString)
-> Either CryptoError ByteString
-> Either AgentErrorType ByteString
forall a b. (a -> b) -> a -> b
$
    RcvDhSecret
-> CbNonce -> ByteString -> Either CryptoError ByteString
C.cbDecrypt RcvDhSecret
dhSecret CbNonce
nonce ByteString
msg

cryptoError :: C.CryptoError -> AgentErrorType
cryptoError :: CryptoError -> AgentErrorType
cryptoError = \case
  CryptoError
C.CryptoLargeMsgError -> CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
LARGE String
"CryptoLargeMsgError"
  C.CryptoHeaderError String
_ -> SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_MESSAGE -- parsing error
  CryptoError
C.CERatchetDuplicateMessage -> SMPAgentError -> AgentErrorType
AGENT (SMPAgentError -> AgentErrorType)
-> SMPAgentError -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ Maybe DroppedMsg -> SMPAgentError
A_DUPLICATE Maybe DroppedMsg
forall a. Maybe a
Nothing
  CryptoError
C.AESDecryptError -> AgentCryptoError -> AgentErrorType
c AgentCryptoError
DECRYPT_AES
  CryptoError
C.CBDecryptError -> AgentCryptoError -> AgentErrorType
c AgentCryptoError
DECRYPT_CB
  CryptoError
C.CERatchetHeader -> AgentCryptoError -> AgentErrorType
c AgentCryptoError
RATCHET_HEADER
  C.CERatchetTooManySkipped Word32
n -> AgentCryptoError -> AgentErrorType
c (AgentCryptoError -> AgentErrorType)
-> AgentCryptoError -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ Word32 -> AgentCryptoError
RATCHET_SKIPPED Word32
n
  C.CERatchetEarlierMessage Word32
n -> AgentCryptoError -> AgentErrorType
c (AgentCryptoError -> AgentErrorType)
-> AgentCryptoError -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ Word32 -> AgentCryptoError
RATCHET_EARLIER Word32
n
  CryptoError
e -> String -> AgentErrorType
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ CryptoError -> String
forall a. Show a => a -> String
show CryptoError
e
  where
    c :: AgentCryptoError -> AgentErrorType
c = SMPAgentError -> AgentErrorType
AGENT (SMPAgentError -> AgentErrorType)
-> (AgentCryptoError -> SMPAgentError)
-> AgentCryptoError
-> AgentErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentCryptoError -> SMPAgentError
A_CRYPTO

waitForWork :: MonadIO m => TMVar () -> m ()
waitForWork :: forall (m :: * -> *). MonadIO m => TMVar () -> m ()
waitForWork = m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> (TMVar () -> m ()) -> TMVar () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> (TMVar () -> STM ()) -> TMVar () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar () -> STM ()
forall a. TMVar a -> STM a
readTMVar
{-# INLINE waitForWork #-}

withWork :: AgentClient -> TMVar () -> (DB.Connection -> IO (Either StoreError (Maybe a))) -> (a -> AM ()) -> AM ()
withWork :: forall a.
AgentClient
-> TMVar ()
-> (Connection -> IO (Either StoreError (Maybe a)))
-> (a -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withWork AgentClient
c TMVar ()
doWork = AgentClient
-> TMVar ()
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Either StoreError (Maybe a))
-> (a -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall e' (m :: * -> *) e a.
(AnyStoreError e', MonadIO m) =>
AgentClient
-> TMVar ()
-> ExceptT e m (Either e' (Maybe a))
-> (a -> ExceptT e m ())
-> ExceptT e m ()
withWork_ AgentClient
c TMVar ()
doWork (ExceptT
   AgentErrorType (ReaderT Env IO) (Either StoreError (Maybe a))
 -> (a -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((Connection -> IO (Either StoreError (Maybe a)))
    -> ExceptT
         AgentErrorType (ReaderT Env IO) (Either StoreError (Maybe a)))
-> (Connection -> IO (Either StoreError (Maybe a)))
-> (a -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> (Connection -> IO (Either StoreError (Maybe a)))
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Either StoreError (Maybe a))
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c
{-# INLINE withWork #-}

-- setting doWork flag to "no work" before getWork rather than after prevents race condition when flag is set to "has work" by another thread after getWork call.
withWork_ :: (AnyStoreError e', MonadIO m) => AgentClient -> TMVar () -> ExceptT e m (Either e' (Maybe a)) -> (a -> ExceptT e m ()) -> ExceptT e m ()
withWork_ :: forall e' (m :: * -> *) e a.
(AnyStoreError e', MonadIO m) =>
AgentClient
-> TMVar ()
-> ExceptT e m (Either e' (Maybe a))
-> (a -> ExceptT e m ())
-> ExceptT e m ()
withWork_ AgentClient
c TMVar ()
doWork ExceptT e m (Either e' (Maybe a))
getWork a -> ExceptT e m ()
action =
  ExceptT e m ()
noWork ExceptT e m ()
-> ExceptT e m (Either e' (Maybe a))
-> ExceptT e m (Either e' (Maybe a))
forall a b. ExceptT e m a -> ExceptT e m b -> ExceptT e m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExceptT e m (Either e' (Maybe a))
getWork ExceptT e m (Either e' (Maybe a))
-> (Either e' (Maybe a) -> ExceptT e m ()) -> ExceptT e m ()
forall a b. ExceptT e m a -> (a -> ExceptT e m b) -> ExceptT e m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right (Just a
r) -> ExceptT e m ()
hasWork ExceptT e m () -> ExceptT e m () -> ExceptT e m ()
forall a b. ExceptT e m a -> ExceptT e m b -> ExceptT e m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> ExceptT e m ()
action a
r
    Right Maybe a
Nothing -> () -> ExceptT e m ()
forall a. a -> ExceptT e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Left e'
e
      | e' -> Bool
forall e. AnyStoreError e => e -> Bool
isWorkItemError e'
e -> (String -> AgentErrorType) -> e' -> ExceptT e m ()
notifyErr (Bool -> String -> AgentErrorType
CRITICAL Bool
False) e'
e -- worker remains stopped here because the next iteration is likely to produce the same result
      | Bool
otherwise -> ExceptT e m ()
hasWork ExceptT e m () -> ExceptT e m () -> ExceptT e m ()
forall a b. ExceptT e m a -> ExceptT e m b -> ExceptT e m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (String -> AgentErrorType) -> e' -> ExceptT e m ()
notifyErr String -> AgentErrorType
INTERNAL e'
e
  where
    hasWork :: ExceptT e m ()
hasWork = STM () -> ExceptT e m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT e m ()) -> STM () -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
hasWorkToDo' TMVar ()
doWork
    noWork :: ExceptT e m ()
noWork = IO () -> ExceptT e m ()
forall a. IO a -> ExceptT e m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT e m ()) -> IO () -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> IO ()
noWorkToDo TMVar ()
doWork
    notifyErr :: (String -> AgentErrorType) -> e' -> ExceptT e m ()
notifyErr String -> AgentErrorType
err e'
e = do
      Text -> ExceptT e m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> ExceptT e m ()) -> Text -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ Text
"withWork_ error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> e' -> Text
forall a. Show a => a -> Text
tshow e'
e
      STM () -> ExceptT e m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT e m ()) -> STM () -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ByteString
"", ByteString
"", SAEntity 'AEConn -> AEvent 'AEConn -> AEvt
forall (e :: AEntity). AEntityI e => SAEntity e -> AEvent e -> AEvt
AEvt SAEntity 'AEConn
SAEConn (AEvent 'AEConn -> AEvt) -> AEvent 'AEConn -> AEvt
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> AEvent 'AEConn)
-> AgentErrorType -> AEvent 'AEConn
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
err (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ e' -> String
forall a. Show a => a -> String
show e'
e)

withWorkItems :: (AnyStoreError e', MonadIO m) => AgentClient -> TMVar () -> ExceptT e m (Either e' [Either e' a]) -> (NonEmpty a -> ExceptT e m ()) -> ExceptT e m ()
withWorkItems :: forall e' (m :: * -> *) e a.
(AnyStoreError e', MonadIO m) =>
AgentClient
-> TMVar ()
-> ExceptT e m (Either e' [Either e' a])
-> (NonEmpty a -> ExceptT e m ())
-> ExceptT e m ()
withWorkItems AgentClient
c TMVar ()
doWork ExceptT e m (Either e' [Either e' a])
getWork NonEmpty a -> ExceptT e m ()
action = do
  ExceptT e m ()
noWork ExceptT e m ()
-> ExceptT e m (Either e' [Either e' a])
-> ExceptT e m (Either e' [Either e' a])
forall a b. ExceptT e m a -> ExceptT e m b -> ExceptT e m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExceptT e m (Either e' [Either e' a])
getWork ExceptT e m (Either e' [Either e' a])
-> (Either e' [Either e' a] -> ExceptT e m ()) -> ExceptT e m ()
forall a b. ExceptT e m a -> (a -> ExceptT e m b) -> ExceptT e m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right [] -> () -> ExceptT e m ()
forall a. a -> ExceptT e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Right [Either e' a]
rs -> do
      let ([e']
errs, [a]
items) = [Either e' a] -> ([e'], [a])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either e' a]
rs
      case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [a]
items of
        Just NonEmpty a
items' -> ExceptT e m ()
hasWork ExceptT e m () -> ExceptT e m () -> ExceptT e m ()
forall a b. ExceptT e m a -> ExceptT e m b -> ExceptT e m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> NonEmpty a -> ExceptT e m ()
action NonEmpty a
items'
        Maybe (NonEmpty a)
Nothing -> do
          case (e' -> Bool) -> [e'] -> Maybe e'
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find e' -> Bool
forall e. AnyStoreError e => e -> Bool
isWorkItemError [e']
errs of
            Maybe e'
Nothing -> ExceptT e m ()
hasWork
            Just e'
err -> do
              (String -> AgentErrorType) -> e' -> ExceptT e m ()
notifyErr (Bool -> String -> AgentErrorType
CRITICAL Bool
False) e'
err
              Bool -> ExceptT e m () -> ExceptT e m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((e' -> Bool) -> [e'] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all e' -> Bool
forall e. AnyStoreError e => e -> Bool
isWorkItemError [e']
errs) ExceptT e m ()
hasWork
      Maybe (NonEmpty e')
-> (NonEmpty e' -> ExceptT e m ()) -> ExceptT e m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([e'] -> Maybe (NonEmpty e')
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [e']
errs) ((NonEmpty e' -> ExceptT e m ()) -> ExceptT e m ())
-> (NonEmpty e' -> ExceptT e m ()) -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> AEvent 'AENone -> ExceptT e m ()
forall (m :: * -> *).
MonadIO m =>
AgentClient -> AEvent 'AENone -> m ()
notifySub AgentClient
c (AEvent 'AENone -> ExceptT e m ())
-> (NonEmpty e' -> AEvent 'AENone) -> NonEmpty e' -> ExceptT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ByteString, AgentErrorType) -> AEvent 'AENone
ERRS (NonEmpty (ByteString, AgentErrorType) -> AEvent 'AENone)
-> (NonEmpty e' -> NonEmpty (ByteString, AgentErrorType))
-> NonEmpty e'
-> AEvent 'AENone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e' -> (ByteString, AgentErrorType))
-> NonEmpty e' -> NonEmpty (ByteString, AgentErrorType)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\e'
e -> (ByteString
"", String -> AgentErrorType
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ e' -> String
forall a. Show a => a -> String
show e'
e))
    Left e'
e
      | e' -> Bool
forall e. AnyStoreError e => e -> Bool
isWorkItemError e'
e -> (String -> AgentErrorType) -> e' -> ExceptT e m ()
notifyErr (Bool -> String -> AgentErrorType
CRITICAL Bool
False) e'
e
      | Bool
otherwise -> ExceptT e m ()
hasWork ExceptT e m () -> ExceptT e m () -> ExceptT e m ()
forall a b. ExceptT e m a -> ExceptT e m b -> ExceptT e m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (String -> AgentErrorType) -> e' -> ExceptT e m ()
notifyErr String -> AgentErrorType
INTERNAL e'
e
  where
    hasWork :: ExceptT e m ()
hasWork = STM () -> ExceptT e m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT e m ()) -> STM () -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
hasWorkToDo' TMVar ()
doWork
    noWork :: ExceptT e m ()
noWork = IO () -> ExceptT e m ()
forall a. IO a -> ExceptT e m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT e m ()) -> IO () -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> IO ()
noWorkToDo TMVar ()
doWork
    notifyErr :: (String -> AgentErrorType) -> e' -> ExceptT e m ()
notifyErr String -> AgentErrorType
err e'
e = do
      Text -> ExceptT e m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> ExceptT e m ()) -> Text -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ Text
"withWorkItems error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> e' -> Text
forall a. Show a => a -> Text
tshow e'
e
      STM () -> ExceptT e m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT e m ()) -> STM () -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ByteString
"", ByteString
"", SAEntity 'AEConn -> AEvent 'AEConn -> AEvt
forall (e :: AEntity). AEntityI e => SAEntity e -> AEvent e -> AEvt
AEvt SAEntity 'AEConn
SAEConn (AEvent 'AEConn -> AEvt) -> AEvent 'AEConn -> AEvt
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> AEvent 'AEConn)
-> AgentErrorType -> AEvent 'AEConn
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
err (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ e' -> String
forall a. Show a => a -> String
show e'
e)

noWorkToDo :: TMVar () -> IO ()
noWorkToDo :: TMVar () -> IO ()
noWorkToDo = IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ())
-> (TMVar () -> IO (Maybe ())) -> TMVar () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe ()) -> IO (Maybe ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe ()) -> IO (Maybe ()))
-> (TMVar () -> STM (Maybe ())) -> TMVar () -> IO (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar () -> STM (Maybe ())
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar
{-# INLINE noWorkToDo #-}

hasWorkToDo :: Worker -> STM ()
hasWorkToDo :: Worker -> STM ()
hasWorkToDo = TMVar () -> STM ()
hasWorkToDo' (TMVar () -> STM ()) -> (Worker -> TMVar ()) -> Worker -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Worker -> TMVar ()
doWork
{-# INLINE hasWorkToDo #-}

hasWorkToDo' :: TMVar () -> STM ()
hasWorkToDo' :: TMVar () -> STM ()
hasWorkToDo' = STM Bool -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bool -> STM ())
-> (TMVar () -> STM Bool) -> TMVar () -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
`tryPutTMVar` ())
{-# INLINE hasWorkToDo' #-}

endAgentOperation :: AgentClient -> AgentOperation -> STM ()
endAgentOperation :: AgentClient -> AgentOperation -> STM ()
endAgentOperation AgentClient
c AgentOperation
op = AgentClient -> AgentOperation -> STM () -> STM ()
endOperation AgentClient
c AgentOperation
op (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ case AgentOperation
op of
  AgentOperation
AONtfNetwork -> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  AgentOperation
AORcvNetwork ->
    AgentClient -> AgentOperation -> STM () -> STM ()
suspendOperation AgentClient
c AgentOperation
AOMsgDelivery (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
      AgentClient -> STM ()
suspendSendingAndDatabase AgentClient
c
  AgentOperation
AOMsgDelivery ->
    AgentClient -> STM ()
suspendSendingAndDatabase AgentClient
c
  AgentOperation
AOSndNetwork ->
    AgentClient -> AgentOperation -> STM () -> STM ()
suspendOperation AgentClient
c AgentOperation
AODatabase (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
      AgentClient -> STM ()
notifySuspended AgentClient
c
  AgentOperation
AODatabase ->
    AgentClient -> STM ()
notifySuspended AgentClient
c

suspendSendingAndDatabase :: AgentClient -> STM ()
suspendSendingAndDatabase :: AgentClient -> STM ()
suspendSendingAndDatabase AgentClient
c =
  AgentClient -> AgentOperation -> STM () -> STM ()
suspendOperation AgentClient
c AgentOperation
AOSndNetwork (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
    AgentClient -> AgentOperation -> STM () -> STM ()
suspendOperation AgentClient
c AgentOperation
AODatabase (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
      AgentClient -> STM ()
notifySuspended AgentClient
c

suspendOperation :: AgentClient -> AgentOperation -> STM () -> STM ()
suspendOperation :: AgentClient -> AgentOperation -> STM () -> STM ()
suspendOperation AgentClient
c AgentOperation
op STM ()
endedAction = do
  Int
n <- TVar AgentOpState
-> (AgentOpState -> (Int, AgentOpState)) -> STM Int
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar (AgentOperation -> AgentClient -> TVar AgentOpState
agentOpSel AgentOperation
op AgentClient
c) ((AgentOpState -> (Int, AgentOpState)) -> STM Int)
-> (AgentOpState -> (Int, AgentOpState)) -> STM Int
forall a b. (a -> b) -> a -> b
$ \AgentOpState
s -> (AgentOpState -> Int
opsInProgress AgentOpState
s, AgentOpState
s {opSuspended = True})
  -- unsafeIOToSTM $ putStrLn $ "suspendOperation_ " <> show op <> " " <> show n
  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> STM () -> STM ()
whenSuspending AgentClient
c STM ()
endedAction

notifySuspended :: AgentClient -> STM ()
notifySuspended :: AgentClient -> STM ()
notifySuspended AgentClient
c = do
  -- unsafeIOToSTM $ putStrLn "notifySuspended"
  TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ByteString
"", ByteString
"", SAEntity 'AENone -> AEvent 'AENone -> AEvt
forall (e :: AEntity). AEntityI e => SAEntity e -> AEvent e -> AEvt
AEvt SAEntity 'AENone
SAENone AEvent 'AENone
SUSPENDED)
  TVar AgentState -> AgentState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (AgentClient -> TVar AgentState
agentState AgentClient
c) AgentState
ASSuspended

endOperation :: AgentClient -> AgentOperation -> STM () -> STM ()
endOperation :: AgentClient -> AgentOperation -> STM () -> STM ()
endOperation AgentClient
c AgentOperation
op STM ()
endedAction = do
  (Bool
suspended, Int
n) <- TVar AgentOpState
-> (AgentOpState -> ((Bool, Int), AgentOpState)) -> STM (Bool, Int)
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar (AgentOperation -> AgentClient -> TVar AgentOpState
agentOpSel AgentOperation
op AgentClient
c) ((AgentOpState -> ((Bool, Int), AgentOpState)) -> STM (Bool, Int))
-> (AgentOpState -> ((Bool, Int), AgentOpState)) -> STM (Bool, Int)
forall a b. (a -> b) -> a -> b
$ \AgentOpState
s ->
    let n :: Int
n = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (AgentOpState -> Int
opsInProgress AgentOpState
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
     in ((AgentOpState -> Bool
opSuspended AgentOpState
s, Int
n), AgentOpState
s {opsInProgress = n})
  -- unsafeIOToSTM $ putStrLn $ "endOperation: " <> show op <> " " <> show suspended <> " " <> show n
  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
suspended Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> STM () -> STM ()
whenSuspending AgentClient
c STM ()
endedAction

whenSuspending :: AgentClient -> STM () -> STM ()
whenSuspending :: AgentClient -> STM () -> STM ()
whenSuspending AgentClient
c = STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((AgentState -> AgentState -> Bool
forall a. Eq a => a -> a -> Bool
== AgentState
ASSuspending) (AgentState -> Bool) -> STM AgentState -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar AgentState -> STM AgentState
forall a. TVar a -> STM a
readTVar (AgentClient -> TVar AgentState
agentState AgentClient
c))
{-# INLINE whenSuspending #-}

beginAgentOperation :: AgentClient -> AgentOperation -> STM ()
beginAgentOperation :: AgentClient -> AgentOperation -> STM ()
beginAgentOperation AgentClient
c AgentOperation
op = do
  let opVar :: TVar AgentOpState
opVar = AgentOperation -> AgentClient -> TVar AgentOpState
agentOpSel AgentOperation
op AgentClient
c
  AgentOpState
s <- TVar AgentOpState -> STM AgentOpState
forall a. TVar a -> STM a
readTVar TVar AgentOpState
opVar
  -- unsafeIOToSTM $ putStrLn $ "beginOperation? " <> show op <> " " <> show (opsInProgress s)
  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AgentOpState -> Bool
opSuspended AgentOpState
s) STM ()
forall a. STM a
retry
  -- unsafeIOToSTM $ putStrLn $ "beginOperation! " <> show op <> " " <> show (opsInProgress s + 1)
  TVar AgentOpState -> AgentOpState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar AgentOpState
opVar (AgentOpState -> STM ()) -> AgentOpState -> STM ()
forall a b. (a -> b) -> a -> b
$! AgentOpState
s {opsInProgress = opsInProgress s + 1}

agentOperationBracket :: MonadUnliftIO m => AgentClient -> AgentOperation -> (AgentClient -> IO ()) -> m a -> m a
agentOperationBracket :: forall (m :: * -> *) a.
MonadUnliftIO m =>
AgentClient
-> AgentOperation -> (AgentClient -> IO ()) -> m a -> m a
agentOperationBracket AgentClient
c AgentOperation
op AgentClient -> IO ()
check m a
action =
  m () -> (() -> m ()) -> (() -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket
    (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (AgentClient -> IO ()
check AgentClient
c) m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (AgentClient -> AgentOperation -> STM ()
beginAgentOperation AgentClient
c AgentOperation
op))
    (\()
_ -> STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> AgentOperation -> STM ()
endAgentOperation AgentClient
c AgentOperation
op)
    (m a -> () -> m a
forall a b. a -> b -> a
const m a
action)

waitUntilForeground :: AgentClient -> IO ()
waitUntilForeground :: AgentClient -> IO ()
waitUntilForeground AgentClient
c =
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((TVar AgentState -> IO AgentState) -> IO Bool
forall (m :: * -> *).
Monad m =>
(TVar AgentState -> m AgentState) -> m Bool
foreground TVar AgentState -> IO AgentState
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((TVar AgentState -> STM AgentState) -> STM Bool
forall (m :: * -> *).
Monad m =>
(TVar AgentState -> m AgentState) -> m Bool
foreground TVar AgentState -> STM AgentState
forall a. TVar a -> STM a
readTVar) STM ()
forall a. STM a
retry
  where
    foreground :: Monad m => (TVar AgentState -> m AgentState) -> m Bool
    foreground :: forall (m :: * -> *).
Monad m =>
(TVar AgentState -> m AgentState) -> m Bool
foreground TVar AgentState -> m AgentState
rd = (AgentState
ASForeground AgentState -> AgentState -> Bool
forall a. Eq a => a -> a -> Bool
==) (AgentState -> Bool) -> m AgentState -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar AgentState -> m AgentState
rd (AgentClient -> TVar AgentState
agentState AgentClient
c)

-- This function waits while agent is suspended, but will proceed while it is suspending,
-- to allow completing in-flight operations.
waitWhileSuspended :: AgentClient -> IO ()
waitWhileSuspended :: AgentClient -> IO ()
waitWhileSuspended AgentClient
c =
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((TVar AgentState -> IO AgentState) -> IO Bool
forall (m :: * -> *).
Monad m =>
(TVar AgentState -> m AgentState) -> m Bool
suspended TVar AgentState -> IO AgentState
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((TVar AgentState -> STM AgentState) -> STM Bool
forall (m :: * -> *).
Monad m =>
(TVar AgentState -> m AgentState) -> m Bool
suspended TVar AgentState -> STM AgentState
forall a. TVar a -> STM a
readTVar) STM ()
forall a. STM a
retry
  where
    suspended :: Monad m => (TVar AgentState -> m AgentState) -> m Bool
    suspended :: forall (m :: * -> *).
Monad m =>
(TVar AgentState -> m AgentState) -> m Bool
suspended TVar AgentState -> m AgentState
rd = (AgentState
ASSuspended AgentState -> AgentState -> Bool
forall a. Eq a => a -> a -> Bool
==) (AgentState -> Bool) -> m AgentState -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar AgentState -> m AgentState
rd (AgentClient -> TVar AgentState
agentState AgentClient
c)

withStore' :: AgentClient -> (DB.Connection -> IO a) -> AM a
withStore' :: forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO a
action = AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError a)) -> AM a)
-> (Connection -> IO (Either StoreError a)) -> AM a
forall a b. (a -> b) -> a -> b
$ (a -> Either StoreError a) -> IO a -> IO (Either StoreError a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either StoreError a
forall a b. b -> Either a b
Right (IO a -> IO (Either StoreError a))
-> (Connection -> IO a) -> Connection -> IO (Either StoreError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO a
action
{-# INLINE withStore' #-}

withStore :: AgentClient -> (DB.Connection -> IO (Either StoreError a)) -> AM a
withStore :: forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c Connection -> IO (Either StoreError a)
action = do
  DBStore
st <- (Env -> DBStore) -> ExceptT AgentErrorType (ReaderT Env IO) DBStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> DBStore
store
  (StoreError -> AgentErrorType)
-> ExceptT StoreError (ReaderT Env IO) a -> AM a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT StoreError -> AgentErrorType
storeError (ExceptT StoreError (ReaderT Env IO) a -> AM a)
-> (IO (Either StoreError a)
    -> ExceptT StoreError (ReaderT Env IO) a)
-> IO (Either StoreError a)
-> AM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Env IO (Either StoreError a)
-> ExceptT StoreError (ReaderT Env IO) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT Env IO (Either StoreError a)
 -> ExceptT StoreError (ReaderT Env IO) a)
-> (IO (Either StoreError a)
    -> ReaderT Env IO (Either StoreError a))
-> IO (Either StoreError a)
-> ExceptT StoreError (ReaderT Env IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either StoreError a) -> ReaderT Env IO (Either StoreError a)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either StoreError a) -> ReaderT Env IO (Either StoreError a))
-> (IO (Either StoreError a) -> IO (Either StoreError a))
-> IO (Either StoreError a)
-> ReaderT Env IO (Either StoreError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> AgentOperation
-> (AgentClient -> IO ())
-> IO (Either StoreError a)
-> IO (Either StoreError a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
AgentClient
-> AgentOperation -> (AgentClient -> IO ()) -> m a -> m a
agentOperationBracket AgentClient
c AgentOperation
AODatabase (\AgentClient
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO (Either StoreError a) -> AM a)
-> IO (Either StoreError a) -> AM a
forall a b. (a -> b) -> a -> b
$
    DBStore
-> (Connection -> IO (Either StoreError a))
-> IO (Either StoreError a)
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction DBStore
st Connection -> IO (Either StoreError a)
action IO (Either StoreError a)
-> (SomeException -> IO (Either StoreError a))
-> IO (Either StoreError a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` SomeException -> IO (Either StoreError a)
forall a. SomeException -> IO (Either StoreError a)
handleDBErrors
  where
    handleDBErrors :: E.SomeException -> IO (Either StoreError a)
    handleDBErrors :: forall a. SomeException -> IO (Either StoreError a)
handleDBErrors SomeException
e = Either StoreError a -> IO (Either StoreError a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError a -> IO (Either StoreError a))
-> Either StoreError a -> IO (Either StoreError a)
forall a b. (a -> b) -> a -> b
$ StoreError -> Either StoreError a
forall a b. a -> Either a b
Left (StoreError -> Either StoreError a)
-> StoreError -> Either StoreError a
forall a b. (a -> b) -> a -> b
$ case SomeException -> Maybe SQLError
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e of
      Just (SQLError
e' :: SQLError) ->
#if defined(dbPostgres)
        SEInternal $ bshow e'
#else
        let se :: Error
se = SQLError -> Error
SQL.sqlError SQLError
e'
            busy :: Bool
busy = Error
se Error -> Error -> Bool
forall a. Eq a => a -> a -> Bool
== Error
SQL.ErrorBusy Bool -> Bool -> Bool
|| Error
se Error -> Error -> Bool
forall a. Eq a => a -> a -> Bool
== Error
SQL.ErrorLocked
         in (if Bool
busy then ByteString -> StoreError
SEDatabaseBusy else ByteString -> StoreError
SEInternal) (ByteString -> StoreError) -> ByteString -> StoreError
forall a b. (a -> b) -> a -> b
$ SQLError -> ByteString
forall a. Show a => a -> ByteString
bshow SQLError
e'
#endif
      Maybe SQLError
Nothing -> ByteString -> StoreError
SEInternal (ByteString -> StoreError) -> ByteString -> StoreError
forall a b. (a -> b) -> a -> b
$ SomeException -> ByteString
forall a. Show a => a -> ByteString
bshow SomeException
e

unsafeWithStore :: AgentClient -> (DB.Connection -> IO a) -> AM' a
unsafeWithStore :: forall a. AgentClient -> (Connection -> IO a) -> AM' a
unsafeWithStore AgentClient
c Connection -> IO a
action = do
  DBStore
st <- (Env -> DBStore) -> ReaderT Env IO DBStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> DBStore
store
  IO a -> AM' a
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> AM' a) -> IO a -> AM' a
forall a b. (a -> b) -> a -> b
$ AgentClient
-> AgentOperation -> (AgentClient -> IO ()) -> IO a -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
AgentClient
-> AgentOperation -> (AgentClient -> IO ()) -> m a -> m a
agentOperationBracket AgentClient
c AgentOperation
AODatabase (\AgentClient
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ DBStore -> (Connection -> IO a) -> IO a
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction DBStore
st Connection -> IO a
action

withStoreBatch :: Traversable t => AgentClient -> (DB.Connection -> t (IO (Either AgentErrorType a))) -> AM' (t (Either AgentErrorType a))
withStoreBatch :: forall (t :: * -> *) a.
Traversable t =>
AgentClient
-> (Connection -> t (IO (Either AgentErrorType a)))
-> AM' (t (Either AgentErrorType a))
withStoreBatch AgentClient
c Connection -> t (IO (Either AgentErrorType a))
actions = do
  DBStore
st <- (Env -> DBStore) -> ReaderT Env IO DBStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> DBStore
store
  IO (t (Either AgentErrorType a))
-> AM' (t (Either AgentErrorType a))
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (t (Either AgentErrorType a))
 -> AM' (t (Either AgentErrorType a)))
-> (IO (t (Either AgentErrorType a))
    -> IO (t (Either AgentErrorType a)))
-> IO (t (Either AgentErrorType a))
-> AM' (t (Either AgentErrorType a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> AgentOperation
-> (AgentClient -> IO ())
-> IO (t (Either AgentErrorType a))
-> IO (t (Either AgentErrorType a))
forall (m :: * -> *) a.
MonadUnliftIO m =>
AgentClient
-> AgentOperation -> (AgentClient -> IO ()) -> m a -> m a
agentOperationBracket AgentClient
c AgentOperation
AODatabase (\AgentClient
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO (t (Either AgentErrorType a))
 -> AM' (t (Either AgentErrorType a)))
-> IO (t (Either AgentErrorType a))
-> AM' (t (Either AgentErrorType a))
forall a b. (a -> b) -> a -> b
$
    DBStore
-> (Connection -> IO (t (Either AgentErrorType a)))
-> IO (t (Either AgentErrorType a))
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction DBStore
st ((Connection -> IO (t (Either AgentErrorType a)))
 -> IO (t (Either AgentErrorType a)))
-> (Connection -> IO (t (Either AgentErrorType a)))
-> IO (t (Either AgentErrorType a))
forall a b. (a -> b) -> a -> b
$
      (IO (Either AgentErrorType a) -> IO (Either AgentErrorType a))
-> t (IO (Either AgentErrorType a))
-> IO (t (Either AgentErrorType a))
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) -> t a -> m (t b)
mapM (IO (Either AgentErrorType a)
-> (SomeException -> IO (Either AgentErrorType a))
-> IO (Either AgentErrorType a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` SomeException -> IO (Either AgentErrorType a)
forall a. SomeException -> IO (Either AgentErrorType a)
handleInternal) (t (IO (Either AgentErrorType a))
 -> IO (t (Either AgentErrorType a)))
-> (Connection -> t (IO (Either AgentErrorType a)))
-> Connection
-> IO (t (Either AgentErrorType a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> t (IO (Either AgentErrorType a))
actions
  where
    handleInternal :: E.SomeException -> IO (Either AgentErrorType a)
    handleInternal :: forall a. SomeException -> IO (Either AgentErrorType a)
handleInternal = Either AgentErrorType a -> IO (Either AgentErrorType a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either AgentErrorType a -> IO (Either AgentErrorType a))
-> (SomeException -> Either AgentErrorType a)
-> SomeException
-> IO (Either AgentErrorType a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> Either AgentErrorType a
forall a b. a -> Either a b
Left (AgentErrorType -> Either AgentErrorType a)
-> (SomeException -> AgentErrorType)
-> SomeException
-> Either AgentErrorType a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AgentErrorType
INTERNAL (String -> AgentErrorType)
-> (SomeException -> String) -> SomeException -> AgentErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show

withStoreBatch' :: Traversable t => AgentClient -> (DB.Connection -> t (IO a)) -> AM' (t (Either AgentErrorType a))
withStoreBatch' :: forall (t :: * -> *) a.
Traversable t =>
AgentClient
-> (Connection -> t (IO a)) -> AM' (t (Either AgentErrorType a))
withStoreBatch' AgentClient
c Connection -> t (IO a)
actions = AgentClient
-> (Connection -> t (IO (Either AgentErrorType a)))
-> AM' (t (Either AgentErrorType a))
forall (t :: * -> *) a.
Traversable t =>
AgentClient
-> (Connection -> t (IO (Either AgentErrorType a)))
-> AM' (t (Either AgentErrorType a))
withStoreBatch AgentClient
c ((IO a -> IO (Either AgentErrorType a))
-> t (IO a) -> t (IO (Either AgentErrorType a))
forall a b. (a -> b) -> t a -> t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Either AgentErrorType a)
-> IO a -> IO (Either AgentErrorType a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either AgentErrorType a
forall a b. b -> Either a b
Right) (t (IO a) -> t (IO (Either AgentErrorType a)))
-> (Connection -> t (IO a))
-> Connection
-> t (IO (Either AgentErrorType a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> t (IO a)
actions)
{-# INLINE withStoreBatch' #-}

storeError :: StoreError -> AgentErrorType
storeError :: StoreError -> AgentErrorType
storeError = \case
  StoreError
SEConnNotFound -> ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
NOT_FOUND String
""
  StoreError
SEUserNotFound -> AgentErrorType
NO_USER
  StoreError
SERatchetNotFound -> ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
NOT_FOUND String
""
  StoreError
SEConnDuplicate -> ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
DUPLICATE String
""
  SEBadConnType String
cxt ConnType
CRcv -> ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX String
cxt
  SEBadConnType String
cxt ConnType
CSnd -> ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX String
cxt
  SEInvitationNotFound String
cxt ByteString
invId -> CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"SEInvitationNotFound " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cxt String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", invitationId = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
invId
  -- this error is never reported as store error,
  -- it is used to wrap agent operations when "transaction-like" store access is needed
  -- NOTE: network IO should NOT be used inside AgentStoreMonad
  SEAgentError AgentErrorType
e -> AgentErrorType
e
  SEDatabaseBusy ByteString
e -> Bool -> String -> AgentErrorType
CRITICAL Bool
True (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B.unpack ByteString
e
  StoreError
e -> String -> AgentErrorType
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ StoreError -> String
forall a. Show a => a -> String
show StoreError
e

userServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> TMap UserId (UserServers p)
userServers :: forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
AgentClient -> TMap UserId (UserServers p)
userServers AgentClient
c = case forall (p :: ProtocolType). ProtocolTypeI p => SProtocolType p
protocolTypeI @p of
  SProtocolType p
SPSMP -> AgentClient -> TMap UserId (UserServers 'PSMP)
smpServers AgentClient
c
  SProtocolType p
SPXFTP -> AgentClient -> TMap UserId (UserServers 'PXFTP)
xftpServers AgentClient
c
{-# INLINE userServers #-}

pickServer :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) -> AM (ProtoServerWithAuth p)
pickServer :: forall (p :: ProtocolType).
NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> AM (ProtoServerWithAuth p)
pickServer = \case
  (Maybe UserId
_, ProtoServerWithAuth p
srv) :| [] -> ProtoServerWithAuth p -> AM (ProtoServerWithAuth p)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProtoServerWithAuth p
srv
  NonEmpty (Maybe UserId, ProtoServerWithAuth p)
servers -> do
    TVar StdGen
gen <- (Env -> TVar StdGen)
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar StdGen)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar StdGen
randomServer
    STM (ProtoServerWithAuth p) -> AM (ProtoServerWithAuth p)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (ProtoServerWithAuth p) -> AM (ProtoServerWithAuth p))
-> STM (ProtoServerWithAuth p) -> AM (ProtoServerWithAuth p)
forall a b. (a -> b) -> a -> b
$ (Maybe UserId, ProtoServerWithAuth p) -> ProtoServerWithAuth p
forall a b. (a, b) -> b
snd ((Maybe UserId, ProtoServerWithAuth p) -> ProtoServerWithAuth p)
-> (Int -> (Maybe UserId, ProtoServerWithAuth p))
-> Int
-> ProtoServerWithAuth p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (Maybe UserId, ProtoServerWithAuth p)
servers NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> Int -> (Maybe UserId, ProtoServerWithAuth p)
forall a. (?callStack::CallStack) => NonEmpty a -> Int -> a
L.!!) (Int -> ProtoServerWithAuth p)
-> STM Int -> STM (ProtoServerWithAuth p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar StdGen -> (StdGen -> (Int, StdGen)) -> STM Int
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar StdGen
gen ((Int, Int) -> StdGen -> (Int, StdGen)
forall g. RandomGen g => (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, NonEmpty (Maybe UserId, ProtoServerWithAuth p) -> Int
forall a. NonEmpty a -> Int
L.length NonEmpty (Maybe UserId, ProtoServerWithAuth p)
servers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

getNextServer ::
  (ProtocolTypeI p, UserProtocol p) =>
  AgentClient ->
  UserId ->
  (UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) ->
  [ProtocolServer p] ->
  AM (ProtoServerWithAuth p)
getNextServer :: forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
AgentClient
-> UserId
-> (UserServers p
    -> NonEmpty (Maybe UserId, ProtoServerWithAuth p))
-> [ProtocolServer p]
-> AM (ProtoServerWithAuth p)
getNextServer AgentClient
c UserId
userId UserServers p -> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvsSel [ProtocolServer p]
usedSrvs = do
  NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvs <- AgentClient
-> UserId
-> (UserServers p
    -> NonEmpty (Maybe UserId, ProtoServerWithAuth p))
-> AM (NonEmpty (Maybe UserId, ProtoServerWithAuth p))
forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
AgentClient
-> UserId
-> (UserServers p
    -> NonEmpty (Maybe UserId, ProtoServerWithAuth p))
-> AM (NonEmpty (Maybe UserId, ProtoServerWithAuth p))
getUserServers_ AgentClient
c UserId
userId UserServers p -> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvsSel
  (NonEmpty (Maybe UserId, ProtoServerWithAuth p),
 ProtoServerWithAuth p)
-> ProtoServerWithAuth p
forall a b. (a, b) -> b
snd ((NonEmpty (Maybe UserId, ProtoServerWithAuth p),
  ProtoServerWithAuth p)
 -> ProtoServerWithAuth p)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (NonEmpty (Maybe UserId, ProtoServerWithAuth p),
      ProtoServerWithAuth p)
-> AM (ProtoServerWithAuth p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> (Set (Maybe UserId), Set TransportHost)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (NonEmpty (Maybe UserId, ProtoServerWithAuth p),
      ProtoServerWithAuth p)
forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> (Set (Maybe UserId), Set TransportHost)
-> AM
     (NonEmpty (Maybe UserId, ProtoServerWithAuth p),
      ProtoServerWithAuth p)
getNextServer_ NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvs (NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> [ProtocolServer p] -> (Set (Maybe UserId), Set TransportHost)
forall (p :: ProtocolType).
NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> [ProtocolServer p] -> (Set (Maybe UserId), Set TransportHost)
usedOperatorsHosts NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvs [ProtocolServer p]
usedSrvs)

usedOperatorsHosts :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) -> [ProtocolServer p] -> (Set (Maybe OperatorId), Set TransportHost)
usedOperatorsHosts :: forall (p :: ProtocolType).
NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> [ProtocolServer p] -> (Set (Maybe UserId), Set TransportHost)
usedOperatorsHosts NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvs [ProtocolServer p]
usedSrvs = (Set (Maybe UserId)
usedOperators, Set TransportHost
usedHosts)
  where
    usedHosts :: Set TransportHost
usedHosts = [Set TransportHost] -> Set TransportHost
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set TransportHost] -> Set TransportHost)
-> [Set TransportHost] -> Set TransportHost
forall a b. (a -> b) -> a -> b
$ (ProtocolServer p -> Set TransportHost)
-> [ProtocolServer p] -> [Set TransportHost]
forall a b. (a -> b) -> [a] -> [b]
map ProtocolServer p -> Set TransportHost
forall (p :: ProtocolType). ProtocolServer p -> Set TransportHost
serverHosts [ProtocolServer p]
usedSrvs
    usedOperators :: Set (Maybe UserId)
usedOperators = [Maybe UserId] -> Set (Maybe UserId)
forall a. Ord a => [a] -> Set a
S.fromList ([Maybe UserId] -> Set (Maybe UserId))
-> [Maybe UserId] -> Set (Maybe UserId)
forall a b. (a -> b) -> a -> b
$ ((Maybe UserId, ProtoServerWithAuth p) -> Maybe (Maybe UserId))
-> [(Maybe UserId, ProtoServerWithAuth p)] -> [Maybe UserId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe UserId, ProtoServerWithAuth p) -> Maybe (Maybe UserId)
usedOp ([(Maybe UserId, ProtoServerWithAuth p)] -> [Maybe UserId])
-> [(Maybe UserId, ProtoServerWithAuth p)] -> [Maybe UserId]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> [(Maybe UserId, ProtoServerWithAuth p)]
forall a. NonEmpty a -> [a]
L.toList NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvs
    usedOp :: (Maybe UserId, ProtoServerWithAuth p) -> Maybe (Maybe UserId)
usedOp (Maybe UserId
op, ProtoServerWithAuth p
srv) = if ProtoServerWithAuth p -> Bool
hasUsedHost ProtoServerWithAuth p
srv then Maybe UserId -> Maybe (Maybe UserId)
forall a. a -> Maybe a
Just Maybe UserId
op else Maybe (Maybe UserId)
forall a. Maybe a
Nothing
    hasUsedHost :: ProtoServerWithAuth p -> Bool
hasUsedHost (ProtoServerWithAuth ProtocolServer p
srv Maybe BasicAuth
_) = (TransportHost -> Bool) -> Set TransportHost -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TransportHost -> Set TransportHost -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set TransportHost
usedHosts) (Set TransportHost -> Bool) -> Set TransportHost -> Bool
forall a b. (a -> b) -> a -> b
$ ProtocolServer p -> Set TransportHost
forall (p :: ProtocolType). ProtocolServer p -> Set TransportHost
serverHosts ProtocolServer p
srv

getNextServer_ ::
  (ProtocolTypeI p, UserProtocol p) =>
  NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) ->
  (Set (Maybe OperatorId), Set TransportHost) ->
  AM (NonEmpty (Maybe OperatorId, ProtoServerWithAuth p), ProtoServerWithAuth p)
getNextServer_ :: forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> (Set (Maybe UserId), Set TransportHost)
-> AM
     (NonEmpty (Maybe UserId, ProtoServerWithAuth p),
      ProtoServerWithAuth p)
getNextServer_ NonEmpty (Maybe UserId, ProtoServerWithAuth p)
servers (Set (Maybe UserId)
usedOperators, Set TransportHost
usedHosts) = do
  -- choose from servers of unused operators, when possible
  let otherOpsSrvs :: NonEmpty (Maybe UserId, ProtoServerWithAuth p)
otherOpsSrvs = ((Maybe UserId, ProtoServerWithAuth p) -> Bool)
-> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
forall {a}. (a -> Bool) -> NonEmpty a -> NonEmpty a
filterOrAll ((Maybe UserId -> Set (Maybe UserId) -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set (Maybe UserId)
usedOperators) (Maybe UserId -> Bool)
-> ((Maybe UserId, ProtoServerWithAuth p) -> Maybe UserId)
-> (Maybe UserId, ProtoServerWithAuth p)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe UserId, ProtoServerWithAuth p) -> Maybe UserId
forall a b. (a, b) -> a
fst) NonEmpty (Maybe UserId, ProtoServerWithAuth p)
servers
      -- choose from servers with unused hosts when possible
      unusedSrvs :: NonEmpty (Maybe UserId, ProtoServerWithAuth p)
unusedSrvs = ((Maybe UserId, ProtoServerWithAuth p) -> Bool)
-> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
forall {a}. (a -> Bool) -> NonEmpty a -> NonEmpty a
filterOrAll (Set TransportHost -> (Maybe UserId, ProtoServerWithAuth p) -> Bool
forall (p :: ProtocolType).
Set TransportHost -> (Maybe UserId, ProtoServerWithAuth p) -> Bool
isUnusedServer Set TransportHost
usedHosts) NonEmpty (Maybe UserId, ProtoServerWithAuth p)
otherOpsSrvs
  (NonEmpty (Maybe UserId, ProtoServerWithAuth p)
otherOpsSrvs,) (ProtoServerWithAuth p
 -> (NonEmpty (Maybe UserId, ProtoServerWithAuth p),
     ProtoServerWithAuth p))
-> ExceptT AgentErrorType (ReaderT Env IO) (ProtoServerWithAuth p)
-> AM
     (NonEmpty (Maybe UserId, ProtoServerWithAuth p),
      ProtoServerWithAuth p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> ExceptT AgentErrorType (ReaderT Env IO) (ProtoServerWithAuth p)
forall (p :: ProtocolType).
NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> AM (ProtoServerWithAuth p)
pickServer NonEmpty (Maybe UserId, ProtoServerWithAuth p)
unusedSrvs
  where
    filterOrAll :: (a -> Bool) -> NonEmpty a -> NonEmpty a
filterOrAll a -> Bool
p NonEmpty a
srvs = NonEmpty a -> Maybe (NonEmpty a) -> NonEmpty a
forall a. a -> Maybe a -> a
fromMaybe NonEmpty a
srvs (Maybe (NonEmpty a) -> NonEmpty a)
-> Maybe (NonEmpty a) -> NonEmpty a
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ([a] -> Maybe (NonEmpty a)) -> [a] -> Maybe (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> NonEmpty a -> [a]
forall a. (a -> Bool) -> NonEmpty a -> [a]
L.filter a -> Bool
p NonEmpty a
srvs

isUnusedServer :: Set TransportHost -> (Maybe OperatorId, ProtoServerWithAuth p) -> Bool
isUnusedServer :: forall (p :: ProtocolType).
Set TransportHost -> (Maybe UserId, ProtoServerWithAuth p) -> Bool
isUnusedServer Set TransportHost
usedHosts (Maybe UserId
_, ProtoServerWithAuth ProtocolServer {NonEmpty TransportHost
$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host :: NonEmpty TransportHost
host} Maybe BasicAuth
_) = (TransportHost -> Bool) -> NonEmpty TransportHost -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TransportHost -> Set TransportHost -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set TransportHost
usedHosts) NonEmpty TransportHost
host

getUserServers_ ::
  (ProtocolTypeI p, UserProtocol p) =>
  AgentClient ->
  UserId ->
  (UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) ->
  AM (NonEmpty (Maybe OperatorId, ProtoServerWithAuth p))
getUserServers_ :: forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
AgentClient
-> UserId
-> (UserServers p
    -> NonEmpty (Maybe UserId, ProtoServerWithAuth p))
-> AM (NonEmpty (Maybe UserId, ProtoServerWithAuth p))
getUserServers_ AgentClient
c UserId
userId UserServers p -> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvsSel =
  IO (Maybe (UserServers p))
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe (UserServers p))
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (UserId -> TMap UserId (UserServers p) -> IO (Maybe (UserServers p))
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
TM.lookupIO UserId
userId (TMap UserId (UserServers p) -> IO (Maybe (UserServers p)))
-> TMap UserId (UserServers p) -> IO (Maybe (UserServers p))
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMap UserId (UserServers p)
forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
AgentClient -> TMap UserId (UserServers p)
userServers AgentClient
c) ExceptT AgentErrorType (ReaderT Env IO) (Maybe (UserServers p))
-> (Maybe (UserServers p)
    -> ExceptT
         AgentErrorType
         (ReaderT Env IO)
         (NonEmpty (Maybe UserId, ProtoServerWithAuth p)))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (NonEmpty (Maybe UserId, ProtoServerWithAuth p))
forall a b.
ExceptT AgentErrorType (ReaderT Env IO) a
-> (a -> ExceptT AgentErrorType (ReaderT Env IO) b)
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just UserServers p
srvs -> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (NonEmpty (Maybe UserId, ProtoServerWithAuth p))
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (Maybe UserId, ProtoServerWithAuth p)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (NonEmpty (Maybe UserId, ProtoServerWithAuth p)))
-> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (NonEmpty (Maybe UserId, ProtoServerWithAuth p))
forall a b. (a -> b) -> a -> b
$ UserServers p -> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvsSel UserServers p
srvs
    Maybe (UserServers p)
_ -> AgentErrorType
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (NonEmpty (Maybe UserId, ProtoServerWithAuth p))
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (NonEmpty (Maybe UserId, ProtoServerWithAuth p)))
-> AgentErrorType
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (NonEmpty (Maybe UserId, ProtoServerWithAuth p))
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"unknown userId - no user servers"

-- This function checks used servers and operators every time to allow
-- changing configuration while retry look is executing.
-- This function is not thread safe.
withNextSrv ::
  (ProtocolTypeI p, UserProtocol p) =>
  AgentClient ->
  UserId ->
  (UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) ->
  TVar (Set TransportHost) ->
  [ProtocolServer p] ->
  (ProtoServerWithAuth p -> AM a) ->
  AM a
withNextSrv :: forall (p :: ProtocolType) a.
(ProtocolTypeI p, UserProtocol p) =>
AgentClient
-> UserId
-> (UserServers p
    -> NonEmpty (Maybe UserId, ProtoServerWithAuth p))
-> TVar (Set TransportHost)
-> [ProtocolServer p]
-> (ProtoServerWithAuth p -> AM a)
-> AM a
withNextSrv AgentClient
c UserId
userId UserServers p -> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvsSel TVar (Set TransportHost)
triedHosts [ProtocolServer p]
usedSrvs ProtoServerWithAuth p -> AM a
action = do
  NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvs <- AgentClient
-> UserId
-> (UserServers p
    -> NonEmpty (Maybe UserId, ProtoServerWithAuth p))
-> AM (NonEmpty (Maybe UserId, ProtoServerWithAuth p))
forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
AgentClient
-> UserId
-> (UserServers p
    -> NonEmpty (Maybe UserId, ProtoServerWithAuth p))
-> AM (NonEmpty (Maybe UserId, ProtoServerWithAuth p))
getUserServers_ AgentClient
c UserId
userId UserServers p -> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvsSel
  let (Set (Maybe UserId)
usedOperators, Set TransportHost
usedHosts) = NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> [ProtocolServer p] -> (Set (Maybe UserId), Set TransportHost)
forall (p :: ProtocolType).
NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> [ProtocolServer p] -> (Set (Maybe UserId), Set TransportHost)
usedOperatorsHosts NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvs [ProtocolServer p]
usedSrvs
  Set TransportHost
tried <- TVar (Set TransportHost)
-> ExceptT AgentErrorType (ReaderT Env IO) (Set TransportHost)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Set TransportHost)
triedHosts
  let triedOrUsed :: Set TransportHost
triedOrUsed = Set TransportHost -> Set TransportHost -> Set TransportHost
forall a. Ord a => Set a -> Set a -> Set a
S.union Set TransportHost
tried Set TransportHost
usedHosts
  (NonEmpty (Maybe UserId, ProtoServerWithAuth p)
otherOpsSrvs, srvAuth :: ProtoServerWithAuth p
srvAuth@(ProtoServerWithAuth ProtocolServer p
srv Maybe BasicAuth
_)) <- NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> (Set (Maybe UserId), Set TransportHost)
-> AM
     (NonEmpty (Maybe UserId, ProtoServerWithAuth p),
      ProtoServerWithAuth p)
forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> (Set (Maybe UserId), Set TransportHost)
-> AM
     (NonEmpty (Maybe UserId, ProtoServerWithAuth p),
      ProtoServerWithAuth p)
getNextServer_ NonEmpty (Maybe UserId, ProtoServerWithAuth p)
srvs (Set (Maybe UserId)
usedOperators, Set TransportHost
triedOrUsed)
  let newHosts :: Set TransportHost
newHosts = ProtocolServer p -> Set TransportHost
forall (p :: ProtocolType). ProtocolServer p -> Set TransportHost
serverHosts ProtocolServer p
srv
      unusedSrvs :: [(Maybe UserId, ProtoServerWithAuth p)]
unusedSrvs = ((Maybe UserId, ProtoServerWithAuth p) -> Bool)
-> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
-> [(Maybe UserId, ProtoServerWithAuth p)]
forall a. (a -> Bool) -> NonEmpty a -> [a]
L.filter (Set TransportHost -> (Maybe UserId, ProtoServerWithAuth p) -> Bool
forall (p :: ProtocolType).
Set TransportHost -> (Maybe UserId, ProtoServerWithAuth p) -> Bool
isUnusedServer (Set TransportHost
 -> (Maybe UserId, ProtoServerWithAuth p) -> Bool)
-> Set TransportHost
-> (Maybe UserId, ProtoServerWithAuth p)
-> Bool
forall a b. (a -> b) -> a -> b
$ Set TransportHost -> Set TransportHost -> Set TransportHost
forall a. Ord a => Set a -> Set a -> Set a
S.union Set TransportHost
triedOrUsed Set TransportHost
newHosts) NonEmpty (Maybe UserId, ProtoServerWithAuth p)
otherOpsSrvs
      !tried' :: Set TransportHost
tried' = if [(Maybe UserId, ProtoServerWithAuth p)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe UserId, ProtoServerWithAuth p)]
unusedSrvs then Set TransportHost
forall a. Set a
S.empty else Set TransportHost -> Set TransportHost -> Set TransportHost
forall a. Ord a => Set a -> Set a -> Set a
S.union Set TransportHost
tried Set TransportHost
newHosts
  STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ TVar (Set TransportHost) -> Set TransportHost -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Set TransportHost)
triedHosts Set TransportHost
tried'
  ProtoServerWithAuth p -> AM a
action ProtoServerWithAuth p
srvAuth

incSMPServerStat :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> STM ()
incSMPServerStat :: AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtocolServer 'PSMP
srv AgentSMPServerStats -> TVar Int
sel = AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> Int
-> STM ()
incSMPServerStat' AgentClient
c UserId
userId ProtocolServer 'PSMP
srv AgentSMPServerStats -> TVar Int
sel Int
1

incSMPServerStat' :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> Int -> STM ()
incSMPServerStat' :: AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> Int
-> STM ()
incSMPServerStat' = (AgentClient
 -> TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats)
-> STM AgentSMPServerStats
-> AgentClient
-> UserId
-> ProtocolServer 'PSMP
-> (AgentSMPServerStats -> TVar Int)
-> Int
-> STM ()
forall n (p :: ProtocolType) s.
Num n =>
(AgentClient -> TMap (UserId, ProtocolServer p) s)
-> STM s
-> AgentClient
-> UserId
-> ProtocolServer p
-> (s -> TVar n)
-> n
-> STM ()
incServerStat (\AgentClient {$sel:smpServersStats:AgentClient :: AgentClient
-> TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
smpServersStats = TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
s} -> TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
s) STM AgentSMPServerStats
newAgentSMPServerStats

incXFTPServerStat :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> STM ()
incXFTPServerStat :: AgentClient
-> UserId
-> ProtocolServer 'PXFTP
-> (AgentXFTPServerStats -> TVar Int)
-> STM ()
incXFTPServerStat AgentClient
c UserId
userId ProtocolServer 'PXFTP
srv AgentXFTPServerStats -> TVar Int
sel = AgentClient
-> UserId
-> ProtocolServer 'PXFTP
-> (AgentXFTPServerStats -> TVar Int)
-> Int
-> STM ()
forall n.
Num n =>
AgentClient
-> UserId
-> ProtocolServer 'PXFTP
-> (AgentXFTPServerStats -> TVar n)
-> n
-> STM ()
incXFTPServerStat_ AgentClient
c UserId
userId ProtocolServer 'PXFTP
srv AgentXFTPServerStats -> TVar Int
sel Int
1
{-# INLINE incXFTPServerStat #-}

incXFTPServerStat' :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> Int -> STM ()
incXFTPServerStat' :: AgentClient
-> UserId
-> ProtocolServer 'PXFTP
-> (AgentXFTPServerStats -> TVar Int)
-> Int
-> STM ()
incXFTPServerStat' = AgentClient
-> UserId
-> ProtocolServer 'PXFTP
-> (AgentXFTPServerStats -> TVar Int)
-> Int
-> STM ()
forall n.
Num n =>
AgentClient
-> UserId
-> ProtocolServer 'PXFTP
-> (AgentXFTPServerStats -> TVar n)
-> n
-> STM ()
incXFTPServerStat_
{-# INLINE incXFTPServerStat' #-}

incXFTPServerSizeStat :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int64) -> Int64 -> STM ()
incXFTPServerSizeStat :: AgentClient
-> UserId
-> ProtocolServer 'PXFTP
-> (AgentXFTPServerStats -> TVar UserId)
-> UserId
-> STM ()
incXFTPServerSizeStat = AgentClient
-> UserId
-> ProtocolServer 'PXFTP
-> (AgentXFTPServerStats -> TVar UserId)
-> UserId
-> STM ()
forall n.
Num n =>
AgentClient
-> UserId
-> ProtocolServer 'PXFTP
-> (AgentXFTPServerStats -> TVar n)
-> n
-> STM ()
incXFTPServerStat_
{-# INLINE incXFTPServerSizeStat #-}

incXFTPServerStat_ :: Num n => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar n) -> n -> STM ()
incXFTPServerStat_ :: forall n.
Num n =>
AgentClient
-> UserId
-> ProtocolServer 'PXFTP
-> (AgentXFTPServerStats -> TVar n)
-> n
-> STM ()
incXFTPServerStat_ = (AgentClient
 -> TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats)
-> STM AgentXFTPServerStats
-> AgentClient
-> UserId
-> ProtocolServer 'PXFTP
-> (AgentXFTPServerStats -> TVar n)
-> n
-> STM ()
forall n (p :: ProtocolType) s.
Num n =>
(AgentClient -> TMap (UserId, ProtocolServer p) s)
-> STM s
-> AgentClient
-> UserId
-> ProtocolServer p
-> (s -> TVar n)
-> n
-> STM ()
incServerStat (\AgentClient {$sel:xftpServersStats:AgentClient :: AgentClient
-> TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
xftpServersStats = TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
s} -> TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
s) STM AgentXFTPServerStats
newAgentXFTPServerStats
{-# INLINE incXFTPServerStat_ #-}

incNtfServerStat :: AgentClient -> UserId -> NtfServer -> (AgentNtfServerStats -> TVar Int) -> STM ()
incNtfServerStat :: AgentClient
-> UserId
-> ProtocolServer 'PNTF
-> (AgentNtfServerStats -> TVar Int)
-> STM ()
incNtfServerStat AgentClient
c UserId
userId ProtocolServer 'PNTF
srv AgentNtfServerStats -> TVar Int
sel = AgentClient
-> UserId
-> ProtocolServer 'PNTF
-> (AgentNtfServerStats -> TVar Int)
-> Int
-> STM ()
incNtfServerStat' AgentClient
c UserId
userId ProtocolServer 'PNTF
srv AgentNtfServerStats -> TVar Int
sel Int
1
{-# INLINE incNtfServerStat #-}

incNtfServerStat' :: AgentClient -> UserId -> NtfServer -> (AgentNtfServerStats -> TVar Int) -> Int -> STM ()
incNtfServerStat' :: AgentClient
-> UserId
-> ProtocolServer 'PNTF
-> (AgentNtfServerStats -> TVar Int)
-> Int
-> STM ()
incNtfServerStat' = (AgentClient
 -> TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats)
-> STM AgentNtfServerStats
-> AgentClient
-> UserId
-> ProtocolServer 'PNTF
-> (AgentNtfServerStats -> TVar Int)
-> Int
-> STM ()
forall n (p :: ProtocolType) s.
Num n =>
(AgentClient -> TMap (UserId, ProtocolServer p) s)
-> STM s
-> AgentClient
-> UserId
-> ProtocolServer p
-> (s -> TVar n)
-> n
-> STM ()
incServerStat (\AgentClient {$sel:ntfServersStats:AgentClient :: AgentClient
-> TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
ntfServersStats = TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
s} -> TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
s) STM AgentNtfServerStats
newAgentNtfServerStats
{-# INLINE incNtfServerStat' #-}

incServerStat :: Num n => (AgentClient -> TMap (UserId, ProtocolServer p) s) -> STM s -> AgentClient -> UserId -> ProtocolServer p -> (s -> TVar n) -> n -> STM ()
incServerStat :: forall n (p :: ProtocolType) s.
Num n =>
(AgentClient -> TMap (UserId, ProtocolServer p) s)
-> STM s
-> AgentClient
-> UserId
-> ProtocolServer p
-> (s -> TVar n)
-> n
-> STM ()
incServerStat AgentClient -> TMap (UserId, ProtocolServer p) s
statsSel STM s
mkNewStats AgentClient
c UserId
userId ProtocolServer p
srv s -> TVar n
sel n
n = do
  (UserId, ProtocolServer p)
-> TMap (UserId, ProtocolServer p) s -> STM (Maybe s)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup (UserId
userId, ProtocolServer p
srv) (AgentClient -> TMap (UserId, ProtocolServer p) s
statsSel AgentClient
c) STM (Maybe s) -> (Maybe s -> STM ()) -> STM ()
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 s
v -> TVar n -> (n -> n) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (s -> TVar n
sel s
v) (n -> n -> n
forall a. Num a => a -> a -> a
+ n
n)
    Maybe s
Nothing -> do
      s
newStats <- STM s
mkNewStats
      TVar n -> (n -> n) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (s -> TVar n
sel s
newStats) (n -> n -> n
forall a. Num a => a -> a -> a
+ n
n)
      (UserId, ProtocolServer p)
-> s -> TMap (UserId, ProtocolServer p) s -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert (UserId
userId, ProtocolServer p
srv) s
newStats (AgentClient -> TMap (UserId, ProtocolServer p) s
statsSel AgentClient
c)

data AgentServersSummary = AgentServersSummary
  { AgentServersSummary
-> Map (UserId, ProtocolServer 'PSMP) AgentSMPServerStatsData
smpServersStats :: Map (UserId, SMPServer) AgentSMPServerStatsData,
    AgentServersSummary
-> Map (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStatsData
xftpServersStats :: Map (UserId, XFTPServer) AgentXFTPServerStatsData,
    AgentServersSummary
-> Map (UserId, ProtocolServer 'PNTF) AgentNtfServerStatsData
ntfServersStats :: Map (UserId, NtfServer) AgentNtfServerStatsData,
    AgentServersSummary -> UTCTime
statsStartedAt :: UTCTime,
    AgentServersSummary
-> Map (UserId, ProtocolServer 'PSMP) ServerSessions
smpServersSessions :: Map (UserId, SMPServer) ServerSessions,
    AgentServersSummary
-> Map (UserId, ProtocolServer 'PSMP) SMPServerSubs
smpServersSubs :: Map (UserId, SMPServer) SMPServerSubs,
    AgentServersSummary
-> Map (UserId, ProtocolServer 'PXFTP) ServerSessions
xftpServersSessions :: Map (UserId, XFTPServer) ServerSessions,
    AgentServersSummary -> [ProtocolServer 'PXFTP]
xftpRcvInProgress :: [XFTPServer],
    AgentServersSummary -> [ProtocolServer 'PXFTP]
xftpSndInProgress :: [XFTPServer],
    AgentServersSummary -> [ProtocolServer 'PXFTP]
xftpDelInProgress :: [XFTPServer],
    AgentServersSummary
-> Map (UserId, ProtocolServer 'PNTF) ServerSessions
ntfServersSessions :: Map (UserId, NtfServer) ServerSessions
  }
  deriving (Int -> AgentServersSummary -> String -> String
[AgentServersSummary] -> String -> String
AgentServersSummary -> String
(Int -> AgentServersSummary -> String -> String)
-> (AgentServersSummary -> String)
-> ([AgentServersSummary] -> String -> String)
-> Show AgentServersSummary
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AgentServersSummary -> String -> String
showsPrec :: Int -> AgentServersSummary -> String -> String
$cshow :: AgentServersSummary -> String
show :: AgentServersSummary -> String
$cshowList :: [AgentServersSummary] -> String -> String
showList :: [AgentServersSummary] -> String -> String
Show)

data SMPServerSubs = SMPServerSubs
  { SMPServerSubs -> Int
ssActive :: Int, -- based on activeSubs
    SMPServerSubs -> Int
ssPending :: Int -- based on pendingSubs
  }
  deriving (Int -> SMPServerSubs -> String -> String
[SMPServerSubs] -> String -> String
SMPServerSubs -> String
(Int -> SMPServerSubs -> String -> String)
-> (SMPServerSubs -> String)
-> ([SMPServerSubs] -> String -> String)
-> Show SMPServerSubs
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SMPServerSubs -> String -> String
showsPrec :: Int -> SMPServerSubs -> String -> String
$cshow :: SMPServerSubs -> String
show :: SMPServerSubs -> String
$cshowList :: [SMPServerSubs] -> String -> String
showList :: [SMPServerSubs] -> String -> String
Show)

data ServerSessions = ServerSessions
  { ServerSessions -> Int
ssConnected :: Int,
    ServerSessions -> Int
ssErrors :: Int,
    ServerSessions -> Int
ssConnecting :: Int
  }
  deriving (Int -> ServerSessions -> String -> String
[ServerSessions] -> String -> String
ServerSessions -> String
(Int -> ServerSessions -> String -> String)
-> (ServerSessions -> String)
-> ([ServerSessions] -> String -> String)
-> Show ServerSessions
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ServerSessions -> String -> String
showsPrec :: Int -> ServerSessions -> String -> String
$cshow :: ServerSessions -> String
show :: ServerSessions -> String
$cshowList :: [ServerSessions] -> String -> String
showList :: [ServerSessions] -> String -> String
Show)

getAgentSubsTotal :: AgentClient -> [UserId] -> IO (SMPServerSubs, Bool)
getAgentSubsTotal :: AgentClient -> [UserId] -> IO (SMPServerSubs, Bool)
getAgentSubsTotal AgentClient
c [UserId]
userIds = do
  (Int
ssActive, Int
ssPending) <- ((Int, Int) -> (SMPTransportSession, SessSubs) -> IO (Int, Int))
-> (Int, Int) -> TSessionSubs -> IO (Int, Int)
forall a.
(a -> (SMPTransportSession, SessSubs) -> IO a)
-> a -> TSessionSubs -> IO a
SS.foldSessionSubs (Int, Int) -> (SMPTransportSession, SessSubs) -> IO (Int, Int)
addSub (Int
0, Int
0) (TSessionSubs -> IO (Int, Int)) -> TSessionSubs -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
  Bool
sess <- [(SMPTransportSession, SMPClientVar)] -> IO Bool
[((UserId, ProtocolServer 'PSMP, Maybe ByteString),
  SessionVar
    (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))]
-> IO Bool
hasSession ([((UserId, ProtocolServer 'PSMP, Maybe ByteString),
   SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))]
 -> IO Bool)
-> (Map
      (UserId, ProtocolServer 'PSMP, Maybe ByteString)
      (SessionVar
         (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
    -> [((UserId, ProtocolServer 'PSMP, Maybe ByteString),
         SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))])
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> [((UserId, ProtocolServer 'PSMP, Maybe ByteString),
     SessionVar
       (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))]
forall k a. Map k a -> [(k, a)]
M.toList (Map
   (UserId, ProtocolServer 'PSMP, Maybe ByteString)
   (SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
 -> IO Bool)
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients AgentClient
c)
  (SMPServerSubs, Bool) -> IO (SMPServerSubs, Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SMPServerSubs {Int
$sel:ssActive:SMPServerSubs :: Int
ssActive :: Int
ssActive, Int
$sel:ssPending:SMPServerSubs :: Int
ssPending :: Int
ssPending}, Bool
sess)
  where
    addSub :: (Int, Int) -> (SMPTransportSession, SS.SessSubs) -> IO (Int, Int)
    addSub :: (Int, Int) -> (SMPTransportSession, SessSubs) -> IO (Int, Int)
addSub acc :: (Int, Int)
acc@(!Int
ssActive, !Int
ssPending) ((UserId
userId, ProtoServer BrokerMsg
_, Maybe ByteString
_), SessSubs
s)
      | UserId
userId UserId -> [UserId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UserId]
userIds = do
          (Int
active, Int
pending) <- (Map RecipientId RcvQueueSub -> Int) -> SessSubs -> IO (Int, Int)
forall a.
(Map RecipientId RcvQueueSub -> a) -> SessSubs -> IO (a, a)
SS.mapSubs Map RecipientId RcvQueueSub -> Int
forall k a. Map k a -> Int
M.size SessSubs
s
          (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ssActive Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
active, Int
ssPending Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pending)
      | Bool
otherwise = (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int, Int)
acc
    hasSession :: [(SMPTransportSession, SMPClientVar)] -> IO Bool
    hasSession :: [(SMPTransportSession, SMPClientVar)] -> IO Bool
hasSession = \case
      [] -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      ((SMPTransportSession, SMPClientVar)
s : [(SMPTransportSession, SMPClientVar)]
ss) -> IO Bool -> IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (((UserId, ProtocolServer 'PSMP, Maybe ByteString),
 SessionVar
   (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> IO Bool
isConnected (SMPTransportSession, SMPClientVar)
((UserId, ProtocolServer 'PSMP, Maybe ByteString),
 SessionVar
   (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
s) (Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) ([(SMPTransportSession, SMPClientVar)] -> IO Bool
hasSession [(SMPTransportSession, SMPClientVar)]
ss)
    isConnected :: ((UserId, ProtocolServer 'PSMP, Maybe ByteString),
 SessionVar
   (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> IO Bool
isConnected ((UserId
userId, ProtocolServer 'PSMP
_, Maybe ByteString
_), SessionVar {TMVar (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
sessionVar :: forall a. SessionVar a -> TMVar a
sessionVar :: TMVar (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
sessionVar})
      | UserId
userId UserId -> [UserId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UserId]
userIds = STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
-> (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient
    -> Bool)
-> Maybe
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient -> Bool
forall a b. Either a b -> Bool
isRight (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
 -> Bool)
-> STM
     (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> STM
     (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
sessionVar
      | Bool
otherwise = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

getAgentServersSummary :: AgentClient -> IO AgentServersSummary
getAgentServersSummary :: AgentClient -> IO AgentServersSummary
getAgentServersSummary c :: AgentClient
c@AgentClient {TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
$sel:smpServersStats:AgentClient :: AgentClient
-> TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
smpServersStats :: TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
smpServersStats, TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
$sel:xftpServersStats:AgentClient :: AgentClient
-> TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
xftpServersStats :: TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
xftpServersStats, TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
$sel:ntfServersStats:AgentClient :: AgentClient
-> TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
ntfServersStats :: TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
ntfServersStats, TVar UTCTime
$sel:srvStatsStartedAt:AgentClient :: AgentClient -> TVar UTCTime
srvStatsStartedAt :: TVar UTCTime
srvStatsStartedAt, Env
$sel:agentEnv:AgentClient :: AgentClient -> Env
agentEnv :: Env
agentEnv} = do
  Map (UserId, ProtocolServer 'PSMP) AgentSMPServerStatsData
sss <- (AgentSMPServerStats -> IO AgentSMPServerStatsData)
-> Map (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
-> IO (Map (UserId, ProtocolServer 'PSMP) AgentSMPServerStatsData)
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)
-> Map (UserId, ProtocolServer 'PSMP) a
-> m (Map (UserId, ProtocolServer 'PSMP) b)
mapM AgentSMPServerStats -> IO AgentSMPServerStatsData
getAgentSMPServerStats (Map (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
 -> IO (Map (UserId, ProtocolServer 'PSMP) AgentSMPServerStatsData))
-> IO (Map (UserId, ProtocolServer 'PSMP) AgentSMPServerStats)
-> IO (Map (UserId, ProtocolServer 'PSMP) AgentSMPServerStatsData)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
-> IO (Map (UserId, ProtocolServer 'PSMP) AgentSMPServerStats)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap (UserId, ProtocolServer 'PSMP) AgentSMPServerStats
smpServersStats
  Map (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStatsData
xss <- (AgentXFTPServerStats -> IO AgentXFTPServerStatsData)
-> Map (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
-> IO
     (Map (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStatsData)
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)
-> Map (UserId, ProtocolServer 'PXFTP) a
-> m (Map (UserId, ProtocolServer 'PXFTP) b)
mapM AgentXFTPServerStats -> IO AgentXFTPServerStatsData
getAgentXFTPServerStats (Map (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
 -> IO
      (Map (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStatsData))
-> IO (Map (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats)
-> IO
     (Map (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStatsData)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
-> IO (Map (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStats
xftpServersStats
  Map (UserId, ProtocolServer 'PNTF) AgentNtfServerStatsData
nss <- (AgentNtfServerStats -> IO AgentNtfServerStatsData)
-> Map (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
-> IO (Map (UserId, ProtocolServer 'PNTF) AgentNtfServerStatsData)
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)
-> Map (UserId, ProtocolServer 'PNTF) a
-> m (Map (UserId, ProtocolServer 'PNTF) b)
mapM AgentNtfServerStats -> IO AgentNtfServerStatsData
getAgentNtfServerStats (Map (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
 -> IO (Map (UserId, ProtocolServer 'PNTF) AgentNtfServerStatsData))
-> IO (Map (UserId, ProtocolServer 'PNTF) AgentNtfServerStats)
-> IO (Map (UserId, ProtocolServer 'PNTF) AgentNtfServerStatsData)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
-> IO (Map (UserId, ProtocolServer 'PNTF) AgentNtfServerStats)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap (UserId, ProtocolServer 'PNTF) AgentNtfServerStats
ntfServersStats
  UTCTime
statsStartedAt <- TVar UTCTime -> IO UTCTime
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar UTCTime
srvStatsStartedAt
  Map (UserId, ProtocolServer 'PSMP) ServerSessions
smpServersSessions <- Map SMPTransportSession SMPClientVar
-> IO (Map (UserId, ProtoServer BrokerMsg) ServerSessions)
Map SMPTransportSession SMPClientVar
-> IO (Map (UserId, ProtocolServer 'PSMP) ServerSessions)
forall msg.
Map (TransportSession msg) (ClientVar msg)
-> IO (Map (UserId, ProtoServer msg) ServerSessions)
countSessions (Map SMPTransportSession SMPClientVar
 -> IO (Map (UserId, ProtocolServer 'PSMP) ServerSessions))
-> IO (Map SMPTransportSession SMPClientVar)
-> IO (Map (UserId, ProtocolServer 'PSMP) ServerSessions)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap SMPTransportSession SMPClientVar
-> IO (Map SMPTransportSession SMPClientVar)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients AgentClient
c)
  Map (UserId, ProtocolServer 'PSMP) SMPServerSubs
smpServersSubs <- IO (Map (UserId, ProtocolServer 'PSMP) SMPServerSubs)
getServerSubs
  Map (UserId, ProtocolServer 'PXFTP) ServerSessions
xftpServersSessions <- Map XFTPTransportSession XFTPClientVar
-> IO (Map (UserId, ProtoServer FileResponse) ServerSessions)
Map XFTPTransportSession XFTPClientVar
-> IO (Map (UserId, ProtocolServer 'PXFTP) ServerSessions)
forall msg.
Map (TransportSession msg) (ClientVar msg)
-> IO (Map (UserId, ProtoServer msg) ServerSessions)
countSessions (Map XFTPTransportSession XFTPClientVar
 -> IO (Map (UserId, ProtocolServer 'PXFTP) ServerSessions))
-> IO (Map XFTPTransportSession XFTPClientVar)
-> IO (Map (UserId, ProtocolServer 'PXFTP) ServerSessions)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap XFTPTransportSession XFTPClientVar
-> IO (Map XFTPTransportSession XFTPClientVar)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (AgentClient -> TMap XFTPTransportSession XFTPClientVar
xftpClients AgentClient
c)
  [ProtocolServer 'PXFTP]
xftpRcvInProgress <- [Maybe (ProtocolServer 'PXFTP)] -> [ProtocolServer 'PXFTP]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ProtocolServer 'PXFTP)] -> [ProtocolServer 'PXFTP])
-> IO [Maybe (ProtocolServer 'PXFTP)] -> IO [ProtocolServer 'PXFTP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
-> IO [Maybe (ProtocolServer 'PXFTP)]
forall {m :: * -> *} {a}. MonadIO m => TVar (Map a Worker) -> m [a]
getXFTPWorkerSrvs TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpRcvWorkers
  [ProtocolServer 'PXFTP]
xftpSndInProgress <- [Maybe (ProtocolServer 'PXFTP)] -> [ProtocolServer 'PXFTP]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ProtocolServer 'PXFTP)] -> [ProtocolServer 'PXFTP])
-> IO [Maybe (ProtocolServer 'PXFTP)] -> IO [ProtocolServer 'PXFTP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
-> IO [Maybe (ProtocolServer 'PXFTP)]
forall {m :: * -> *} {a}. MonadIO m => TVar (Map a Worker) -> m [a]
getXFTPWorkerSrvs TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpSndWorkers
  [ProtocolServer 'PXFTP]
xftpDelInProgress <- TVar (Map (ProtocolServer 'PXFTP) Worker)
-> IO [ProtocolServer 'PXFTP]
forall {m :: * -> *} {a}. MonadIO m => TVar (Map a Worker) -> m [a]
getXFTPWorkerSrvs TVar (Map (ProtocolServer 'PXFTP) Worker)
xftpDelWorkers
  Map (UserId, ProtocolServer 'PNTF) ServerSessions
ntfServersSessions <- Map NtfTransportSession NtfClientVar
-> IO (Map (UserId, ProtoServer NtfResponse) ServerSessions)
Map NtfTransportSession NtfClientVar
-> IO (Map (UserId, ProtocolServer 'PNTF) ServerSessions)
forall msg.
Map (TransportSession msg) (ClientVar msg)
-> IO (Map (UserId, ProtoServer msg) ServerSessions)
countSessions (Map NtfTransportSession NtfClientVar
 -> IO (Map (UserId, ProtocolServer 'PNTF) ServerSessions))
-> IO (Map NtfTransportSession NtfClientVar)
-> IO (Map (UserId, ProtocolServer 'PNTF) ServerSessions)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap NtfTransportSession NtfClientVar
-> IO (Map NtfTransportSession NtfClientVar)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (AgentClient -> TMap NtfTransportSession NtfClientVar
ntfClients AgentClient
c)
  AgentServersSummary -> IO AgentServersSummary
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    AgentServersSummary
      { $sel:smpServersStats:AgentServersSummary :: Map (UserId, ProtocolServer 'PSMP) AgentSMPServerStatsData
smpServersStats = Map (UserId, ProtocolServer 'PSMP) AgentSMPServerStatsData
sss,
        $sel:xftpServersStats:AgentServersSummary :: Map (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStatsData
xftpServersStats = Map (UserId, ProtocolServer 'PXFTP) AgentXFTPServerStatsData
xss,
        $sel:ntfServersStats:AgentServersSummary :: Map (UserId, ProtocolServer 'PNTF) AgentNtfServerStatsData
ntfServersStats = Map (UserId, ProtocolServer 'PNTF) AgentNtfServerStatsData
nss,
        UTCTime
$sel:statsStartedAt:AgentServersSummary :: UTCTime
statsStartedAt :: UTCTime
statsStartedAt,
        Map (UserId, ProtocolServer 'PSMP) ServerSessions
$sel:smpServersSessions:AgentServersSummary :: Map (UserId, ProtocolServer 'PSMP) ServerSessions
smpServersSessions :: Map (UserId, ProtocolServer 'PSMP) ServerSessions
smpServersSessions,
        Map (UserId, ProtocolServer 'PSMP) SMPServerSubs
$sel:smpServersSubs:AgentServersSummary :: Map (UserId, ProtocolServer 'PSMP) SMPServerSubs
smpServersSubs :: Map (UserId, ProtocolServer 'PSMP) SMPServerSubs
smpServersSubs,
        Map (UserId, ProtocolServer 'PXFTP) ServerSessions
$sel:xftpServersSessions:AgentServersSummary :: Map (UserId, ProtocolServer 'PXFTP) ServerSessions
xftpServersSessions :: Map (UserId, ProtocolServer 'PXFTP) ServerSessions
xftpServersSessions,
        [ProtocolServer 'PXFTP]
$sel:xftpRcvInProgress:AgentServersSummary :: [ProtocolServer 'PXFTP]
xftpRcvInProgress :: [ProtocolServer 'PXFTP]
xftpRcvInProgress,
        [ProtocolServer 'PXFTP]
$sel:xftpSndInProgress:AgentServersSummary :: [ProtocolServer 'PXFTP]
xftpSndInProgress :: [ProtocolServer 'PXFTP]
xftpSndInProgress,
        [ProtocolServer 'PXFTP]
$sel:xftpDelInProgress:AgentServersSummary :: [ProtocolServer 'PXFTP]
xftpDelInProgress :: [ProtocolServer 'PXFTP]
xftpDelInProgress,
        Map (UserId, ProtocolServer 'PNTF) ServerSessions
$sel:ntfServersSessions:AgentServersSummary :: Map (UserId, ProtocolServer 'PNTF) ServerSessions
ntfServersSessions :: Map (UserId, ProtocolServer 'PNTF) ServerSessions
ntfServersSessions
      }
  where
    getServerSubs :: IO (Map (UserId, ProtocolServer 'PSMP) SMPServerSubs)
getServerSubs = (Map (UserId, ProtocolServer 'PSMP) SMPServerSubs
 -> (SMPTransportSession, SessSubs)
 -> IO (Map (UserId, ProtocolServer 'PSMP) SMPServerSubs))
-> Map (UserId, ProtocolServer 'PSMP) SMPServerSubs
-> TSessionSubs
-> IO (Map (UserId, ProtocolServer 'PSMP) SMPServerSubs)
forall a.
(a -> (SMPTransportSession, SessSubs) -> IO a)
-> a -> TSessionSubs -> IO a
SS.foldSessionSubs Map (UserId, ProtocolServer 'PSMP) SMPServerSubs
-> (SMPTransportSession, SessSubs)
-> IO (Map (UserId, ProtocolServer 'PSMP) SMPServerSubs)
Map (UserId, ProtocolServer 'PSMP) SMPServerSubs
-> ((UserId, ProtocolServer 'PSMP, Maybe ByteString), SessSubs)
-> IO (Map (UserId, ProtocolServer 'PSMP) SMPServerSubs)
forall {a} {b} {c}.
(Ord a, Ord b) =>
Map (a, b) SMPServerSubs
-> ((a, b, c), SessSubs) -> IO (Map (a, b) SMPServerSubs)
addSub Map (UserId, ProtocolServer 'PSMP) SMPServerSubs
forall k a. Map k a
M.empty (TSessionSubs
 -> IO (Map (UserId, ProtocolServer 'PSMP) SMPServerSubs))
-> TSessionSubs
-> IO (Map (UserId, ProtocolServer 'PSMP) SMPServerSubs)
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
      where
        addSub :: Map (a, b) SMPServerSubs
-> ((a, b, c), SessSubs) -> IO (Map (a, b) SMPServerSubs)
addSub Map (a, b) SMPServerSubs
subs ((a
userId, b
srv, c
_), SessSubs
s) = do
          (Int
active, Int
pending) <- (Map RecipientId RcvQueueSub -> Int) -> SessSubs -> IO (Int, Int)
forall a.
(Map RecipientId RcvQueueSub -> a) -> SessSubs -> IO (a, a)
SS.mapSubs Map RecipientId RcvQueueSub -> Int
forall k a. Map k a -> Int
M.size SessSubs
s
          let add :: SMPServerSubs -> SMPServerSubs
add SMPServerSubs
ss = SMPServerSubs
ss {ssActive = ssActive ss + active, ssPending = ssPending ss + pending}
          Map (a, b) SMPServerSubs -> IO (Map (a, b) SMPServerSubs)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (a, b) SMPServerSubs -> IO (Map (a, b) SMPServerSubs))
-> Map (a, b) SMPServerSubs -> IO (Map (a, b) SMPServerSubs)
forall a b. (a -> b) -> a -> b
$ (Maybe SMPServerSubs -> Maybe SMPServerSubs)
-> (a, b) -> Map (a, b) SMPServerSubs -> Map (a, b) SMPServerSubs
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (SMPServerSubs -> Maybe SMPServerSubs
forall a. a -> Maybe a
Just (SMPServerSubs -> Maybe SMPServerSubs)
-> (Maybe SMPServerSubs -> SMPServerSubs)
-> Maybe SMPServerSubs
-> Maybe SMPServerSubs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPServerSubs -> SMPServerSubs
add (SMPServerSubs -> SMPServerSubs)
-> (Maybe SMPServerSubs -> SMPServerSubs)
-> Maybe SMPServerSubs
-> SMPServerSubs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPServerSubs -> Maybe SMPServerSubs -> SMPServerSubs
forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> SMPServerSubs
SMPServerSubs Int
0 Int
0)) (a
userId, b
srv) Map (a, b) SMPServerSubs
subs
    Env {$sel:xftpAgent:Env :: Env -> XFTPAgent
xftpAgent = XFTPAgent {TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpRcvWorkers :: TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
$sel:xftpRcvWorkers:XFTPAgent :: XFTPAgent -> TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpRcvWorkers, TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpSndWorkers :: TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
$sel:xftpSndWorkers:XFTPAgent :: XFTPAgent -> TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpSndWorkers, TVar (Map (ProtocolServer 'PXFTP) Worker)
xftpDelWorkers :: TVar (Map (ProtocolServer 'PXFTP) Worker)
$sel:xftpDelWorkers:XFTPAgent :: XFTPAgent -> TVar (Map (ProtocolServer 'PXFTP) Worker)
xftpDelWorkers}} = Env
agentEnv
    getXFTPWorkerSrvs :: TVar (Map a Worker) -> m [a]
getXFTPWorkerSrvs TVar (Map a Worker)
workers = ([a] -> (a, Worker) -> m [a]) -> [a] -> [(a, Worker)] -> m [a]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [a] -> (a, Worker) -> m [a]
forall {m :: * -> *} {a}. MonadIO m => [a] -> (a, Worker) -> m [a]
addSrv [] ([(a, Worker)] -> m [a])
-> (Map a Worker -> [(a, Worker)]) -> Map a Worker -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a Worker -> [(a, Worker)]
forall k a. Map k a -> [(k, a)]
M.toList (Map a Worker -> m [a]) -> m (Map a Worker) -> m [a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar (Map a Worker) -> m (Map a Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map a Worker)
workers
      where
        addSrv :: [a] -> (a, Worker) -> m [a]
addSrv [a]
acc (a
srv, Worker {TMVar ()
$sel:doWork:Worker :: Worker -> TMVar ()
doWork :: TMVar ()
doWork}) = do
          Bool
hasWork <- STM Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> m Bool) -> STM Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar () -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar ()
doWork
          [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ if Bool
hasWork then a
srv a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc else [a]
acc
    countSessions :: Map (TransportSession msg) (ClientVar msg) -> IO (Map (UserId, ProtoServer msg) ServerSessions)
    countSessions :: forall msg.
Map (TransportSession msg) (ClientVar msg)
-> IO (Map (UserId, ProtoServer msg) ServerSessions)
countSessions = (Map (UserId, ProtocolServer (ProtoType msg)) ServerSessions
 -> ((UserId, ProtocolServer (ProtoType msg), Maybe ByteString),
     SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
 -> IO
      (Map (UserId, ProtocolServer (ProtoType msg)) ServerSessions))
-> Map (UserId, ProtocolServer (ProtoType msg)) ServerSessions
-> [((UserId, ProtocolServer (ProtoType msg), Maybe ByteString),
     SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg)))]
-> IO (Map (UserId, ProtocolServer (ProtoType msg)) ServerSessions)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map (UserId, ProtocolServer (ProtoType msg)) ServerSessions
-> ((UserId, ProtocolServer (ProtoType msg), Maybe ByteString),
    SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
-> IO (Map (UserId, ProtocolServer (ProtoType msg)) ServerSessions)
forall {m :: * -> *} {a} {b} {c} {a} {b}.
(MonadIO m, Ord a, Ord b) =>
Map (a, b) ServerSessions
-> ((a, b, c), SessionVar (Either a b))
-> m (Map (a, b) ServerSessions)
addClient Map (UserId, ProtocolServer (ProtoType msg)) ServerSessions
forall k a. Map k a
M.empty ([((UserId, ProtocolServer (ProtoType msg), Maybe ByteString),
   SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg)))]
 -> IO
      (Map (UserId, ProtocolServer (ProtoType msg)) ServerSessions))
-> (Map
      (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
      (SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
    -> [((UserId, ProtocolServer (ProtoType msg), Maybe ByteString),
         SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg)))])
-> Map
     (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
     (SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
-> IO (Map (UserId, ProtocolServer (ProtoType msg)) ServerSessions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map
  (UserId, ProtocolServer (ProtoType msg), Maybe ByteString)
  (SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg)))
-> [((UserId, ProtocolServer (ProtoType msg), Maybe ByteString),
     SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg)))]
forall k a. Map k a -> [(k, a)]
M.toList
      where
        addClient :: Map (a, b) ServerSessions
-> ((a, b, c), SessionVar (Either a b))
-> m (Map (a, b) ServerSessions)
addClient !Map (a, b) ServerSessions
acc ((a
userId, b
srv, c
_), SessionVar {TMVar (Either a b)
sessionVar :: forall a. SessionVar a -> TMVar a
sessionVar :: TMVar (Either a b)
sessionVar}) = do
          Maybe (Either a b)
c_ <- STM (Maybe (Either a b)) -> m (Maybe (Either a b))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe (Either a b)) -> m (Maybe (Either a b)))
-> STM (Maybe (Either a b)) -> m (Maybe (Either a b))
forall a b. (a -> b) -> a -> b
$ TMVar (Either a b) -> STM (Maybe (Either a b))
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar (Either a b)
sessionVar
          Map (a, b) ServerSessions -> m (Map (a, b) ServerSessions)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (a, b) ServerSessions -> m (Map (a, b) ServerSessions))
-> Map (a, b) ServerSessions -> m (Map (a, b) ServerSessions)
forall a b. (a -> b) -> a -> b
$ (Maybe ServerSessions -> Maybe ServerSessions)
-> (a, b) -> Map (a, b) ServerSessions -> Map (a, b) ServerSessions
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (ServerSessions -> Maybe ServerSessions
forall a. a -> Maybe a
Just (ServerSessions -> Maybe ServerSessions)
-> (Maybe ServerSessions -> ServerSessions)
-> Maybe ServerSessions
-> Maybe ServerSessions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Either a b) -> Maybe ServerSessions -> ServerSessions
forall {a} {b}.
Maybe (Either a b) -> Maybe ServerSessions -> ServerSessions
add Maybe (Either a b)
c_) (a
userId, b
srv) Map (a, b) ServerSessions
acc
          where
            add :: Maybe (Either a b) -> Maybe ServerSessions -> ServerSessions
add Maybe (Either a b)
c_ = Maybe (Either a b) -> ServerSessions -> ServerSessions
forall {a} {b}.
Maybe (Either a b) -> ServerSessions -> ServerSessions
modifySessions Maybe (Either a b)
c_ (ServerSessions -> ServerSessions)
-> (Maybe ServerSessions -> ServerSessions)
-> Maybe ServerSessions
-> ServerSessions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerSessions -> Maybe ServerSessions -> ServerSessions
forall a. a -> Maybe a -> a
fromMaybe ServerSessions {$sel:ssConnected:ServerSessions :: Int
ssConnected = Int
0, $sel:ssErrors:ServerSessions :: Int
ssErrors = Int
0, $sel:ssConnecting:ServerSessions :: Int
ssConnecting = Int
0}
            modifySessions :: Maybe (Either a b) -> ServerSessions -> ServerSessions
modifySessions Maybe (Either a b)
c_ ServerSessions
ss = case Maybe (Either a b)
c_ of
              Just (Right b
_) -> ServerSessions
ss {ssConnected = ssConnected ss + 1}
              Just (Left a
_) -> ServerSessions
ss {ssErrors = ssErrors ss + 1}
              Maybe (Either a b)
Nothing -> ServerSessions
ss {ssConnecting = ssConnecting ss + 1}

data SubInfo = SubInfo {SubInfo -> UserId
userId :: UserId, SubInfo -> Text
server :: Text, SubInfo -> Text
rcvId :: Text, SubInfo -> Maybe String
subError :: Maybe String}
  deriving (Int -> SubInfo -> String -> String
[SubInfo] -> String -> String
SubInfo -> String
(Int -> SubInfo -> String -> String)
-> (SubInfo -> String)
-> ([SubInfo] -> String -> String)
-> Show SubInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SubInfo -> String -> String
showsPrec :: Int -> SubInfo -> String -> String
$cshow :: SubInfo -> String
show :: SubInfo -> String
$cshowList :: [SubInfo] -> String -> String
showList :: [SubInfo] -> String -> String
Show)

data SubscriptionsInfo = SubscriptionsInfo
  { SubscriptionsInfo -> [SubInfo]
activeSubscriptions :: [SubInfo],
    SubscriptionsInfo -> [SubInfo]
pendingSubscriptions :: [SubInfo],
    SubscriptionsInfo -> [SubInfo]
removedSubscriptions :: [SubInfo]
  }
  deriving (Int -> SubscriptionsInfo -> String -> String
[SubscriptionsInfo] -> String -> String
SubscriptionsInfo -> String
(Int -> SubscriptionsInfo -> String -> String)
-> (SubscriptionsInfo -> String)
-> ([SubscriptionsInfo] -> String -> String)
-> Show SubscriptionsInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SubscriptionsInfo -> String -> String
showsPrec :: Int -> SubscriptionsInfo -> String -> String
$cshow :: SubscriptionsInfo -> String
show :: SubscriptionsInfo -> String
$cshowList :: [SubscriptionsInfo] -> String -> String
showList :: [SubscriptionsInfo] -> String -> String
Show)

getAgentSubscriptions :: AgentClient -> IO SubscriptionsInfo
getAgentSubscriptions :: AgentClient -> IO SubscriptionsInfo
getAgentSubscriptions AgentClient
c = do
  ([SubInfo]
activeSubscriptions, [SubInfo]
pendingSubscriptions) <- (([SubInfo], [SubInfo])
 -> (SMPTransportSession, SessSubs) -> IO ([SubInfo], [SubInfo]))
-> ([SubInfo], [SubInfo])
-> TSessionSubs
-> IO ([SubInfo], [SubInfo])
forall a.
(a -> (SMPTransportSession, SessSubs) -> IO a)
-> a -> TSessionSubs -> IO a
SS.foldSessionSubs ([SubInfo], [SubInfo])
-> (SMPTransportSession, SessSubs) -> IO ([SubInfo], [SubInfo])
addSubs ([], []) (TSessionSubs -> IO ([SubInfo], [SubInfo]))
-> TSessionSubs -> IO ([SubInfo], [SubInfo])
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
  [SubInfo]
removedSubscriptions <- IO [SubInfo]
getRemoved
  SubscriptionsInfo -> IO SubscriptionsInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SubscriptionsInfo -> IO SubscriptionsInfo)
-> SubscriptionsInfo -> IO SubscriptionsInfo
forall a b. (a -> b) -> a -> b
$ SubscriptionsInfo {[SubInfo]
$sel:activeSubscriptions:SubscriptionsInfo :: [SubInfo]
activeSubscriptions :: [SubInfo]
activeSubscriptions, [SubInfo]
$sel:pendingSubscriptions:SubscriptionsInfo :: [SubInfo]
pendingSubscriptions :: [SubInfo]
pendingSubscriptions, [SubInfo]
$sel:removedSubscriptions:SubscriptionsInfo :: [SubInfo]
removedSubscriptions :: [SubInfo]
removedSubscriptions}
  where
    addSubs :: ([SubInfo], [SubInfo]) -> (SMPTransportSession, SS.SessSubs) -> IO ([SubInfo], [SubInfo])
    addSubs :: ([SubInfo], [SubInfo])
-> (SMPTransportSession, SessSubs) -> IO ([SubInfo], [SubInfo])
addSubs ([SubInfo]
active, [SubInfo]
pending) ((UserId
userId, ProtoServer BrokerMsg
srv, Maybe ByteString
_), SessSubs
s) = do
      ([SubInfo]
active', [SubInfo]
pending') <- (Map RecipientId RcvQueueSub -> [SubInfo])
-> SessSubs -> IO ([SubInfo], [SubInfo])
forall a.
(Map RecipientId RcvQueueSub -> a) -> SessSubs -> IO (a, a)
SS.mapSubs ((RecipientId -> SubInfo) -> [RecipientId] -> [SubInfo]
forall a b. (a -> b) -> [a] -> [b]
map (\RecipientId
rId -> (UserId, ProtocolServer 'PSMP, RecipientId)
-> Maybe SMPClientError -> SubInfo
subInfo (UserId
userId, ProtoServer BrokerMsg
ProtocolServer 'PSMP
srv, RecipientId
rId) Maybe SMPClientError
forall a. Maybe a
Nothing) ([RecipientId] -> [SubInfo])
-> (Map RecipientId RcvQueueSub -> [RecipientId])
-> Map RecipientId RcvQueueSub
-> [SubInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RecipientId RcvQueueSub -> [RecipientId]
forall k a. Map k a -> [k]
M.keys) SessSubs
s
      ([SubInfo], [SubInfo]) -> IO ([SubInfo], [SubInfo])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SubInfo]
active' [SubInfo] -> [SubInfo] -> [SubInfo]
forall a. [a] -> [a] -> [a]
++ [SubInfo]
active, [SubInfo]
pending' [SubInfo] -> [SubInfo] -> [SubInfo]
forall a. [a] -> [a] -> [a]
++ [SubInfo]
pending)
    getRemoved :: IO [SubInfo]
    getRemoved :: IO [SubInfo]
getRemoved = ([SubInfo]
 -> ((UserId, ProtocolServer 'PSMP),
     TMap RecipientId SMPClientError)
 -> IO [SubInfo])
-> [SubInfo]
-> [((UserId, ProtocolServer 'PSMP),
     TMap RecipientId SMPClientError)]
-> IO [SubInfo]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [SubInfo]
-> ((UserId, ProtocolServer 'PSMP),
    TMap RecipientId SMPClientError)
-> IO [SubInfo]
addSubInfo [] ([((UserId, ProtocolServer 'PSMP),
   TMap RecipientId SMPClientError)]
 -> IO [SubInfo])
-> (Map
      (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
    -> [((UserId, ProtocolServer 'PSMP),
         TMap RecipientId SMPClientError)])
-> Map
     (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
-> IO [SubInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map
  (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
-> [((UserId, ProtocolServer 'PSMP),
     TMap RecipientId SMPClientError)]
forall k a. Map k a -> [(k, a)]
M.assocs (Map
   (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
 -> IO [SubInfo])
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError))
-> IO [SubInfo]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap
  (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (AgentClient
-> TMap
     (UserId, ProtocolServer 'PSMP) (TMap RecipientId SMPClientError)
removedSubs AgentClient
c)
      where
        addSubInfo :: [SubInfo] -> ((UserId, SMPServer), TMap SMP.RecipientId SMPClientError) -> IO [SubInfo]
        addSubInfo :: [SubInfo]
-> ((UserId, ProtocolServer 'PSMP),
    TMap RecipientId SMPClientError)
-> IO [SubInfo]
addSubInfo [SubInfo]
ss ((UserId
uId, ProtocolServer 'PSMP
srv), TMap RecipientId SMPClientError
errs) = do
          [SubInfo]
ss' <- ((RecipientId, SMPClientError) -> SubInfo)
-> [(RecipientId, SMPClientError)] -> [SubInfo]
forall a b. (a -> b) -> [a] -> [b]
map (\(RecipientId
rId, SMPClientError
e) -> (UserId, ProtocolServer 'PSMP, RecipientId)
-> Maybe SMPClientError -> SubInfo
subInfo (UserId
uId, ProtocolServer 'PSMP
srv, RecipientId
rId) (SMPClientError -> Maybe SMPClientError
forall a. a -> Maybe a
Just SMPClientError
e)) ([(RecipientId, SMPClientError)] -> [SubInfo])
-> (Map RecipientId SMPClientError
    -> [(RecipientId, SMPClientError)])
-> Map RecipientId SMPClientError
-> [SubInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RecipientId SMPClientError -> [(RecipientId, SMPClientError)]
forall k a. Map k a -> [(k, a)]
M.assocs (Map RecipientId SMPClientError -> [SubInfo])
-> IO (Map RecipientId SMPClientError) -> IO [SubInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap RecipientId SMPClientError
-> IO (Map RecipientId SMPClientError)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap RecipientId SMPClientError
errs
          [SubInfo] -> IO [SubInfo]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SubInfo] -> IO [SubInfo]) -> [SubInfo] -> IO [SubInfo]
forall a b. (a -> b) -> a -> b
$ [SubInfo]
ss' [SubInfo] -> [SubInfo] -> [SubInfo]
forall a. [a] -> [a] -> [a]
++ [SubInfo]
ss
    subInfo :: (UserId, SMPServer, SMP.RecipientId) -> Maybe SMPClientError -> SubInfo
    subInfo :: (UserId, ProtocolServer 'PSMP, RecipientId)
-> Maybe SMPClientError -> SubInfo
subInfo (UserId
uId, ProtocolServer 'PSMP
srv, RecipientId
rId) Maybe SMPClientError
err = SubInfo {$sel:userId:SubInfo :: UserId
userId = UserId
uId, $sel:server:SubInfo :: Text
server = ProtocolServer 'PSMP -> Text
forall a. StrEncoding a => a -> Text
enc ProtocolServer 'PSMP
srv, $sel:rcvId:SubInfo :: Text
rcvId = RecipientId -> Text
forall a. StrEncoding a => a -> Text
enc RecipientId
rId, $sel:subError:SubInfo :: Maybe String
subError = SMPClientError -> String
forall a. Show a => a -> String
show (SMPClientError -> String) -> Maybe SMPClientError -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SMPClientError
err}
    enc :: StrEncoding a => a -> Text
    enc :: forall a. StrEncoding a => a -> Text
enc = ByteString -> Text
decodeLatin1 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode

data AgentWorkersDetails = AgentWorkersDetails
  { AgentWorkersDetails -> [Text]
smpClients_ :: [Text],
    AgentWorkersDetails -> [Text]
ntfClients_ :: [Text],
    AgentWorkersDetails -> [Text]
xftpClients_ :: [Text],
    AgentWorkersDetails -> Map Text WorkersDetails
smpDeliveryWorkers_ :: Map Text WorkersDetails,
    AgentWorkersDetails -> Map Text WorkersDetails
asyncCmdWorkers_ :: Map Text WorkersDetails,
    AgentWorkersDetails -> [Text]
smpSubWorkers_ :: [Text],
    AgentWorkersDetails -> Map Text WorkersDetails
ntfWorkers_ :: Map Text WorkersDetails,
    AgentWorkersDetails -> Map Text WorkersDetails
ntfSMPWorkers_ :: Map Text WorkersDetails,
    AgentWorkersDetails -> Map Text WorkersDetails
xftpRcvWorkers_ :: Map Text WorkersDetails,
    AgentWorkersDetails -> Map Text WorkersDetails
xftpSndWorkers_ :: Map Text WorkersDetails,
    AgentWorkersDetails -> Map Text WorkersDetails
xftpDelWorkers_ :: Map Text WorkersDetails
  }
  deriving (Int -> AgentWorkersDetails -> String -> String
[AgentWorkersDetails] -> String -> String
AgentWorkersDetails -> String
(Int -> AgentWorkersDetails -> String -> String)
-> (AgentWorkersDetails -> String)
-> ([AgentWorkersDetails] -> String -> String)
-> Show AgentWorkersDetails
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AgentWorkersDetails -> String -> String
showsPrec :: Int -> AgentWorkersDetails -> String -> String
$cshow :: AgentWorkersDetails -> String
show :: AgentWorkersDetails -> String
$cshowList :: [AgentWorkersDetails] -> String -> String
showList :: [AgentWorkersDetails] -> String -> String
Show)

data WorkersDetails = WorkersDetails
  { WorkersDetails -> Int
restarts :: Int,
    WorkersDetails -> Bool
hasWork :: Bool,
    WorkersDetails -> Bool
hasAction :: Bool
  }
  deriving (Int -> WorkersDetails -> String -> String
[WorkersDetails] -> String -> String
WorkersDetails -> String
(Int -> WorkersDetails -> String -> String)
-> (WorkersDetails -> String)
-> ([WorkersDetails] -> String -> String)
-> Show WorkersDetails
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> WorkersDetails -> String -> String
showsPrec :: Int -> WorkersDetails -> String -> String
$cshow :: WorkersDetails -> String
show :: WorkersDetails -> String
$cshowList :: [WorkersDetails] -> String -> String
showList :: [WorkersDetails] -> String -> String
Show)

getAgentWorkersDetails :: AgentClient -> IO AgentWorkersDetails
getAgentWorkersDetails :: AgentClient -> IO AgentWorkersDetails
getAgentWorkersDetails AgentClient {TMap SMPTransportSession SMPClientVar
$sel:smpClients:AgentClient :: AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients :: TMap SMPTransportSession SMPClientVar
smpClients, TMap NtfTransportSession NtfClientVar
$sel:ntfClients:AgentClient :: AgentClient -> TMap NtfTransportSession NtfClientVar
ntfClients :: TMap NtfTransportSession NtfClientVar
ntfClients, TMap XFTPTransportSession XFTPClientVar
$sel:xftpClients:AgentClient :: AgentClient -> TMap XFTPTransportSession XFTPClientVar
xftpClients :: TMap XFTPTransportSession XFTPClientVar
xftpClients, TMap SndQAddr (Worker, TMVar ())
$sel:smpDeliveryWorkers:AgentClient :: AgentClient -> TMap SndQAddr (Worker, TMVar ())
smpDeliveryWorkers :: TMap SndQAddr (Worker, TMVar ())
smpDeliveryWorkers, TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
$sel:asyncCmdWorkers:AgentClient :: AgentClient
-> TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
asyncCmdWorkers :: TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
asyncCmdWorkers, TMap SMPTransportSession (SessionVar (Async ()))
$sel:smpSubWorkers:AgentClient :: AgentClient -> TMap SMPTransportSession (SessionVar (Async ()))
smpSubWorkers :: TMap SMPTransportSession (SessionVar (Async ()))
smpSubWorkers, Env
$sel:agentEnv:AgentClient :: AgentClient -> Env
agentEnv :: Env
agentEnv} = do
  [Text]
smpClients_ <- Map
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> [Text]
forall k v. StrEncoding k => Map k v -> [Text]
textKeys (Map
   (UserId, ProtocolServer 'PSMP, Maybe ByteString)
   (SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
 -> [Text])
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap SMPTransportSession SMPClientVar
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
smpClients
  [Text]
ntfClients_ <- Map
  (UserId, ProtocolServer 'PNTF, Maybe ByteString)
  (SessionVar
     (Either
        (AgentErrorType, Maybe UTCTime)
        (ProtocolClient NTFVersion ErrorType NtfResponse)))
-> [Text]
forall k v. StrEncoding k => Map k v -> [Text]
textKeys (Map
   (UserId, ProtocolServer 'PNTF, Maybe ByteString)
   (SessionVar
      (Either
         (AgentErrorType, Maybe UTCTime)
         (ProtocolClient NTFVersion ErrorType NtfResponse)))
 -> [Text])
-> IO
     (Map
        (UserId, ProtocolServer 'PNTF, Maybe ByteString)
        (SessionVar
           (Either
              (AgentErrorType, Maybe UTCTime)
              (ProtocolClient NTFVersion ErrorType NtfResponse))))
-> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap
  (UserId, ProtocolServer 'PNTF, Maybe ByteString)
  (SessionVar
     (Either
        (AgentErrorType, Maybe UTCTime)
        (ProtocolClient NTFVersion ErrorType NtfResponse)))
-> IO
     (Map
        (UserId, ProtocolServer 'PNTF, Maybe ByteString)
        (SessionVar
           (Either
              (AgentErrorType, Maybe UTCTime)
              (ProtocolClient NTFVersion ErrorType NtfResponse))))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap NtfTransportSession NtfClientVar
TMap
  (UserId, ProtocolServer 'PNTF, Maybe ByteString)
  (SessionVar
     (Either
        (AgentErrorType, Maybe UTCTime)
        (ProtocolClient NTFVersion ErrorType NtfResponse)))
ntfClients
  [Text]
xftpClients_ <- Map
  (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
  (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
-> [Text]
forall k v. StrEncoding k => Map k v -> [Text]
textKeys (Map
   (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
   (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
 -> [Text])
-> IO
     (Map
        (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
        (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)))
-> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap
  (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
  (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
-> IO
     (Map
        (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
        (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap XFTPTransportSession XFTPClientVar
TMap
  (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
  (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
xftpClients
  Map Text WorkersDetails
smpDeliveryWorkers_ <- Map SndQAddr Worker -> IO (Map Text WorkersDetails)
forall k.
StrEncoding k =>
Map k Worker -> IO (Map Text WorkersDetails)
workerStats (Map SndQAddr Worker -> IO (Map Text WorkersDetails))
-> (Map SndQAddr (Worker, TMVar ()) -> Map SndQAddr Worker)
-> Map SndQAddr (Worker, TMVar ())
-> IO (Map Text WorkersDetails)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Worker, TMVar ()) -> Worker)
-> Map SndQAddr (Worker, TMVar ()) -> Map SndQAddr Worker
forall a b. (a -> b) -> Map SndQAddr a -> Map SndQAddr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Worker, TMVar ()) -> Worker
forall a b. (a, b) -> a
fst (Map SndQAddr (Worker, TMVar ()) -> IO (Map Text WorkersDetails))
-> IO (Map SndQAddr (Worker, TMVar ()))
-> IO (Map Text WorkersDetails)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap SndQAddr (Worker, TMVar ())
-> IO (Map SndQAddr (Worker, TMVar ()))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap SndQAddr (Worker, TMVar ())
smpDeliveryWorkers
  Map Text WorkersDetails
asyncCmdWorkers_ <- Map (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
-> IO (Map Text WorkersDetails)
forall k.
StrEncoding k =>
Map k Worker -> IO (Map Text WorkersDetails)
workerStats (Map (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
 -> IO (Map Text WorkersDetails))
-> IO (Map (ByteString, Maybe (ProtocolServer 'PSMP)) Worker)
-> IO (Map Text WorkersDetails)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
-> IO (Map (ByteString, Maybe (ProtocolServer 'PSMP)) Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
asyncCmdWorkers
  [Text]
smpSubWorkers_ <- Map
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
-> [Text]
forall k v. StrEncoding k => Map k v -> [Text]
textKeys (Map
   (UserId, ProtocolServer 'PSMP, Maybe ByteString)
   (SessionVar (Async ()))
 -> [Text])
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar (Async ())))
-> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar (Async ())))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap SMPTransportSession (SessionVar (Async ()))
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
smpSubWorkers
  Map Text WorkersDetails
ntfWorkers_ <- Map (ProtocolServer 'PNTF) Worker -> IO (Map Text WorkersDetails)
forall k.
StrEncoding k =>
Map k Worker -> IO (Map Text WorkersDetails)
workerStats (Map (ProtocolServer 'PNTF) Worker -> IO (Map Text WorkersDetails))
-> IO (Map (ProtocolServer 'PNTF) Worker)
-> IO (Map Text WorkersDetails)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar (Map (ProtocolServer 'PNTF) Worker)
-> IO (Map (ProtocolServer 'PNTF) Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map (ProtocolServer 'PNTF) Worker)
ntfWorkers
  Map Text WorkersDetails
ntfSMPWorkers_ <- Map (ProtocolServer 'PSMP) Worker -> IO (Map Text WorkersDetails)
forall k.
StrEncoding k =>
Map k Worker -> IO (Map Text WorkersDetails)
workerStats (Map (ProtocolServer 'PSMP) Worker -> IO (Map Text WorkersDetails))
-> IO (Map (ProtocolServer 'PSMP) Worker)
-> IO (Map Text WorkersDetails)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar (Map (ProtocolServer 'PSMP) Worker)
-> IO (Map (ProtocolServer 'PSMP) Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map (ProtocolServer 'PSMP) Worker)
ntfSMPWorkers
  Map Text WorkersDetails
xftpRcvWorkers_ <- Map (Maybe (ProtocolServer 'PXFTP)) Worker
-> IO (Map Text WorkersDetails)
forall k.
StrEncoding k =>
Map k Worker -> IO (Map Text WorkersDetails)
workerStats (Map (Maybe (ProtocolServer 'PXFTP)) Worker
 -> IO (Map Text WorkersDetails))
-> IO (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
-> IO (Map Text WorkersDetails)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
-> IO (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpRcvWorkers
  Map Text WorkersDetails
xftpSndWorkers_ <- Map (Maybe (ProtocolServer 'PXFTP)) Worker
-> IO (Map Text WorkersDetails)
forall k.
StrEncoding k =>
Map k Worker -> IO (Map Text WorkersDetails)
workerStats (Map (Maybe (ProtocolServer 'PXFTP)) Worker
 -> IO (Map Text WorkersDetails))
-> IO (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
-> IO (Map Text WorkersDetails)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
-> IO (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpSndWorkers
  Map Text WorkersDetails
xftpDelWorkers_ <- Map (ProtocolServer 'PXFTP) Worker -> IO (Map Text WorkersDetails)
forall k.
StrEncoding k =>
Map k Worker -> IO (Map Text WorkersDetails)
workerStats (Map (ProtocolServer 'PXFTP) Worker
 -> IO (Map Text WorkersDetails))
-> IO (Map (ProtocolServer 'PXFTP) Worker)
-> IO (Map Text WorkersDetails)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar (Map (ProtocolServer 'PXFTP) Worker)
-> IO (Map (ProtocolServer 'PXFTP) Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map (ProtocolServer 'PXFTP) Worker)
xftpDelWorkers
  AgentWorkersDetails -> IO AgentWorkersDetails
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    AgentWorkersDetails
      { [Text]
$sel:smpClients_:AgentWorkersDetails :: [Text]
smpClients_ :: [Text]
smpClients_,
        [Text]
$sel:ntfClients_:AgentWorkersDetails :: [Text]
ntfClients_ :: [Text]
ntfClients_,
        [Text]
$sel:xftpClients_:AgentWorkersDetails :: [Text]
xftpClients_ :: [Text]
xftpClients_,
        Map Text WorkersDetails
$sel:smpDeliveryWorkers_:AgentWorkersDetails :: Map Text WorkersDetails
smpDeliveryWorkers_ :: Map Text WorkersDetails
smpDeliveryWorkers_,
        Map Text WorkersDetails
$sel:asyncCmdWorkers_:AgentWorkersDetails :: Map Text WorkersDetails
asyncCmdWorkers_ :: Map Text WorkersDetails
asyncCmdWorkers_,
        [Text]
$sel:smpSubWorkers_:AgentWorkersDetails :: [Text]
smpSubWorkers_ :: [Text]
smpSubWorkers_,
        Map Text WorkersDetails
$sel:ntfWorkers_:AgentWorkersDetails :: Map Text WorkersDetails
ntfWorkers_ :: Map Text WorkersDetails
ntfWorkers_,
        Map Text WorkersDetails
$sel:ntfSMPWorkers_:AgentWorkersDetails :: Map Text WorkersDetails
ntfSMPWorkers_ :: Map Text WorkersDetails
ntfSMPWorkers_,
        Map Text WorkersDetails
$sel:xftpRcvWorkers_:AgentWorkersDetails :: Map Text WorkersDetails
xftpRcvWorkers_ :: Map Text WorkersDetails
xftpRcvWorkers_,
        Map Text WorkersDetails
$sel:xftpSndWorkers_:AgentWorkersDetails :: Map Text WorkersDetails
xftpSndWorkers_ :: Map Text WorkersDetails
xftpSndWorkers_,
        Map Text WorkersDetails
$sel:xftpDelWorkers_:AgentWorkersDetails :: Map Text WorkersDetails
xftpDelWorkers_ :: Map Text WorkersDetails
xftpDelWorkers_
      }
  where
    textKeys :: StrEncoding k => Map k v -> [Text]
    textKeys :: forall k v. StrEncoding k => Map k v -> [Text]
textKeys = (k -> Text) -> [k] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map k -> Text
forall a. StrEncoding a => a -> Text
textKey ([k] -> [Text]) -> (Map k v -> [k]) -> Map k v -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> [k]
forall k a. Map k a -> [k]
M.keys
    textKey :: StrEncoding k => k -> Text
    textKey :: forall a. StrEncoding a => a -> Text
textKey = ByteString -> Text
decodeASCII (ByteString -> Text) -> (k -> ByteString) -> k -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode
    workerStats :: StrEncoding k => Map k Worker -> IO (Map Text WorkersDetails)
    workerStats :: forall k.
StrEncoding k =>
Map k Worker -> IO (Map Text WorkersDetails)
workerStats Map k Worker
ws = ([(Text, WorkersDetails)] -> Map Text WorkersDetails)
-> IO [(Text, WorkersDetails)] -> IO (Map Text WorkersDetails)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Text, WorkersDetails)] -> Map Text WorkersDetails
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (IO [(Text, WorkersDetails)] -> IO (Map Text WorkersDetails))
-> (((k, Worker) -> IO (Text, WorkersDetails))
    -> IO [(Text, WorkersDetails)])
-> ((k, Worker) -> IO (Text, WorkersDetails))
-> IO (Map Text WorkersDetails)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(k, Worker)]
-> ((k, Worker) -> IO (Text, WorkersDetails))
-> IO [(Text, WorkersDetails)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map k Worker -> [(k, Worker)]
forall k a. Map k a -> [(k, a)]
M.toList Map k Worker
ws) (((k, Worker) -> IO (Text, WorkersDetails))
 -> IO (Map Text WorkersDetails))
-> ((k, Worker) -> IO (Text, WorkersDetails))
-> IO (Map Text WorkersDetails)
forall a b. (a -> b) -> a -> b
$ \(k
qa, Worker {TVar RestartCount
$sel:restarts:Worker :: Worker -> TVar RestartCount
restarts :: TVar RestartCount
restarts, TMVar ()
$sel:doWork:Worker :: Worker -> TMVar ()
doWork :: TMVar ()
doWork, TMVar (Maybe (Weak ThreadId))
$sel:action:Worker :: Worker -> TMVar (Maybe (Weak ThreadId))
action :: TMVar (Maybe (Weak ThreadId))
action}) -> do
      RestartCount {Int
$sel:restartCount:RestartCount :: RestartCount -> Int
restartCount :: Int
restartCount} <- TVar RestartCount -> IO RestartCount
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar RestartCount
restarts
      Bool
hasWork <- STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar () -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar ()
doWork
      Bool
hasAction <- STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar (Maybe (Weak ThreadId)) -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar (Maybe (Weak ThreadId))
action
      (Text, WorkersDetails) -> IO (Text, WorkersDetails)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (k -> Text
forall a. StrEncoding a => a -> Text
textKey k
qa, WorkersDetails {$sel:restarts:WorkersDetails :: Int
restarts = Int
restartCount, Bool
$sel:hasWork:WorkersDetails :: Bool
hasWork :: Bool
hasWork, Bool
$sel:hasAction:WorkersDetails :: Bool
hasAction :: Bool
hasAction})
    Env {NtfSupervisor
ntfSupervisor :: NtfSupervisor
$sel:ntfSupervisor:Env :: Env -> NtfSupervisor
ntfSupervisor, XFTPAgent
$sel:xftpAgent:Env :: Env -> XFTPAgent
xftpAgent :: XFTPAgent
xftpAgent} = Env
agentEnv
    NtfSupervisor {TVar (Map (ProtocolServer 'PNTF) Worker)
ntfWorkers :: TVar (Map (ProtocolServer 'PNTF) Worker)
$sel:ntfWorkers:NtfSupervisor :: NtfSupervisor -> TVar (Map (ProtocolServer 'PNTF) Worker)
ntfWorkers, TVar (Map (ProtocolServer 'PSMP) Worker)
ntfSMPWorkers :: TVar (Map (ProtocolServer 'PSMP) Worker)
$sel:ntfSMPWorkers:NtfSupervisor :: NtfSupervisor -> TVar (Map (ProtocolServer 'PSMP) Worker)
ntfSMPWorkers} = NtfSupervisor
ntfSupervisor
    XFTPAgent {TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
$sel:xftpRcvWorkers:XFTPAgent :: XFTPAgent -> TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpRcvWorkers :: TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpRcvWorkers, TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
$sel:xftpSndWorkers:XFTPAgent :: XFTPAgent -> TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpSndWorkers :: TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpSndWorkers, TVar (Map (ProtocolServer 'PXFTP) Worker)
$sel:xftpDelWorkers:XFTPAgent :: XFTPAgent -> TVar (Map (ProtocolServer 'PXFTP) Worker)
xftpDelWorkers :: TVar (Map (ProtocolServer 'PXFTP) Worker)
xftpDelWorkers} = XFTPAgent
xftpAgent

data AgentWorkersSummary = AgentWorkersSummary
  { AgentWorkersSummary -> Int
smpClientsCount :: Int,
    AgentWorkersSummary -> Int
ntfClientsCount :: Int,
    AgentWorkersSummary -> Int
xftpClientsCount :: Int,
    AgentWorkersSummary -> WorkersSummary
smpDeliveryWorkersCount :: WorkersSummary,
    AgentWorkersSummary -> WorkersSummary
asyncCmdWorkersCount :: WorkersSummary,
    AgentWorkersSummary -> Int
smpSubWorkersCount :: Int,
    AgentWorkersSummary -> WorkersSummary
ntfWorkersCount :: WorkersSummary,
    AgentWorkersSummary -> WorkersSummary
ntfSMPWorkersCount :: WorkersSummary,
    AgentWorkersSummary -> WorkersSummary
xftpRcvWorkersCount :: WorkersSummary,
    AgentWorkersSummary -> WorkersSummary
xftpSndWorkersCount :: WorkersSummary,
    AgentWorkersSummary -> WorkersSummary
xftpDelWorkersCount :: WorkersSummary
  }
  deriving (Int -> AgentWorkersSummary -> String -> String
[AgentWorkersSummary] -> String -> String
AgentWorkersSummary -> String
(Int -> AgentWorkersSummary -> String -> String)
-> (AgentWorkersSummary -> String)
-> ([AgentWorkersSummary] -> String -> String)
-> Show AgentWorkersSummary
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AgentWorkersSummary -> String -> String
showsPrec :: Int -> AgentWorkersSummary -> String -> String
$cshow :: AgentWorkersSummary -> String
show :: AgentWorkersSummary -> String
$cshowList :: [AgentWorkersSummary] -> String -> String
showList :: [AgentWorkersSummary] -> String -> String
Show)

data WorkersSummary = WorkersSummary
  { WorkersSummary -> Int
numActive :: Int,
    WorkersSummary -> Int
numIdle :: Int,
    WorkersSummary -> Int
totalRestarts :: Int
  }
  deriving (Int -> WorkersSummary -> String -> String
[WorkersSummary] -> String -> String
WorkersSummary -> String
(Int -> WorkersSummary -> String -> String)
-> (WorkersSummary -> String)
-> ([WorkersSummary] -> String -> String)
-> Show WorkersSummary
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> WorkersSummary -> String -> String
showsPrec :: Int -> WorkersSummary -> String -> String
$cshow :: WorkersSummary -> String
show :: WorkersSummary -> String
$cshowList :: [WorkersSummary] -> String -> String
showList :: [WorkersSummary] -> String -> String
Show)

getAgentWorkersSummary :: AgentClient -> IO AgentWorkersSummary
getAgentWorkersSummary :: AgentClient -> IO AgentWorkersSummary
getAgentWorkersSummary AgentClient {TMap SMPTransportSession SMPClientVar
$sel:smpClients:AgentClient :: AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients :: TMap SMPTransportSession SMPClientVar
smpClients, TMap NtfTransportSession NtfClientVar
$sel:ntfClients:AgentClient :: AgentClient -> TMap NtfTransportSession NtfClientVar
ntfClients :: TMap NtfTransportSession NtfClientVar
ntfClients, TMap XFTPTransportSession XFTPClientVar
$sel:xftpClients:AgentClient :: AgentClient -> TMap XFTPTransportSession XFTPClientVar
xftpClients :: TMap XFTPTransportSession XFTPClientVar
xftpClients, TMap SndQAddr (Worker, TMVar ())
$sel:smpDeliveryWorkers:AgentClient :: AgentClient -> TMap SndQAddr (Worker, TMVar ())
smpDeliveryWorkers :: TMap SndQAddr (Worker, TMVar ())
smpDeliveryWorkers, TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
$sel:asyncCmdWorkers:AgentClient :: AgentClient
-> TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
asyncCmdWorkers :: TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
asyncCmdWorkers, TMap SMPTransportSession (SessionVar (Async ()))
$sel:smpSubWorkers:AgentClient :: AgentClient -> TMap SMPTransportSession (SessionVar (Async ()))
smpSubWorkers :: TMap SMPTransportSession (SessionVar (Async ()))
smpSubWorkers, Env
$sel:agentEnv:AgentClient :: AgentClient -> Env
agentEnv :: Env
agentEnv} = do
  Int
smpClientsCount <- Map
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> Int
forall k a. Map k a -> Int
M.size (Map
   (UserId, ProtocolServer 'PSMP, Maybe ByteString)
   (SessionVar
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
 -> Int)
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
-> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap SMPTransportSession SMPClientVar
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
smpClients
  Int
ntfClientsCount <- Map
  (UserId, ProtocolServer 'PNTF, Maybe ByteString)
  (SessionVar
     (Either
        (AgentErrorType, Maybe UTCTime)
        (ProtocolClient NTFVersion ErrorType NtfResponse)))
-> Int
forall k a. Map k a -> Int
M.size (Map
   (UserId, ProtocolServer 'PNTF, Maybe ByteString)
   (SessionVar
      (Either
         (AgentErrorType, Maybe UTCTime)
         (ProtocolClient NTFVersion ErrorType NtfResponse)))
 -> Int)
-> IO
     (Map
        (UserId, ProtocolServer 'PNTF, Maybe ByteString)
        (SessionVar
           (Either
              (AgentErrorType, Maybe UTCTime)
              (ProtocolClient NTFVersion ErrorType NtfResponse))))
-> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap
  (UserId, ProtocolServer 'PNTF, Maybe ByteString)
  (SessionVar
     (Either
        (AgentErrorType, Maybe UTCTime)
        (ProtocolClient NTFVersion ErrorType NtfResponse)))
-> IO
     (Map
        (UserId, ProtocolServer 'PNTF, Maybe ByteString)
        (SessionVar
           (Either
              (AgentErrorType, Maybe UTCTime)
              (ProtocolClient NTFVersion ErrorType NtfResponse))))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap NtfTransportSession NtfClientVar
TMap
  (UserId, ProtocolServer 'PNTF, Maybe ByteString)
  (SessionVar
     (Either
        (AgentErrorType, Maybe UTCTime)
        (ProtocolClient NTFVersion ErrorType NtfResponse)))
ntfClients
  Int
xftpClientsCount <- Map
  (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
  (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
-> Int
forall k a. Map k a -> Int
M.size (Map
   (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
   (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
 -> Int)
-> IO
     (Map
        (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
        (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)))
-> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap
  (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
  (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
-> IO
     (Map
        (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
        (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient)))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap XFTPTransportSession XFTPClientVar
TMap
  (UserId, ProtocolServer 'PXFTP, Maybe ByteString)
  (SessionVar (Either (AgentErrorType, Maybe UTCTime) XFTPClient))
xftpClients
  WorkersSummary
smpDeliveryWorkersCount <- TMap SndQAddr (Worker, TMVar ())
-> IO (Map SndQAddr (Worker, TMVar ()))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap SndQAddr (Worker, TMVar ())
smpDeliveryWorkers IO (Map SndQAddr (Worker, TMVar ()))
-> (Map SndQAddr (Worker, TMVar ()) -> IO WorkersSummary)
-> IO WorkersSummary
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map SndQAddr Worker -> IO WorkersSummary
forall k. Map k Worker -> IO WorkersSummary
workerSummary (Map SndQAddr Worker -> IO WorkersSummary)
-> (Map SndQAddr (Worker, TMVar ()) -> Map SndQAddr Worker)
-> Map SndQAddr (Worker, TMVar ())
-> IO WorkersSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Worker, TMVar ()) -> Worker)
-> Map SndQAddr (Worker, TMVar ()) -> Map SndQAddr Worker
forall a b. (a -> b) -> Map SndQAddr a -> Map SndQAddr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Worker, TMVar ()) -> Worker
forall a b. (a, b) -> a
fst
  WorkersSummary
asyncCmdWorkersCount <- TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
-> IO (Map (ByteString, Maybe (ProtocolServer 'PSMP)) Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
asyncCmdWorkers IO (Map (ByteString, Maybe (ProtocolServer 'PSMP)) Worker)
-> (Map (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
    -> IO WorkersSummary)
-> IO WorkersSummary
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map (ByteString, Maybe (ProtocolServer 'PSMP)) Worker
-> IO WorkersSummary
forall k. Map k Worker -> IO WorkersSummary
workerSummary
  Int
smpSubWorkersCount <- Map
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
-> Int
forall k a. Map k a -> Int
M.size (Map
   (UserId, ProtocolServer 'PSMP, Maybe ByteString)
   (SessionVar (Async ()))
 -> Int)
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar (Async ())))
-> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar (Async ())))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap SMPTransportSession (SessionVar (Async ()))
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar (Async ()))
smpSubWorkers
  WorkersSummary
ntfWorkersCount <- TVar (Map (ProtocolServer 'PNTF) Worker)
-> IO (Map (ProtocolServer 'PNTF) Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map (ProtocolServer 'PNTF) Worker)
ntfWorkers IO (Map (ProtocolServer 'PNTF) Worker)
-> (Map (ProtocolServer 'PNTF) Worker -> IO WorkersSummary)
-> IO WorkersSummary
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map (ProtocolServer 'PNTF) Worker -> IO WorkersSummary
forall k. Map k Worker -> IO WorkersSummary
workerSummary
  WorkersSummary
ntfSMPWorkersCount <- TVar (Map (ProtocolServer 'PSMP) Worker)
-> IO (Map (ProtocolServer 'PSMP) Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map (ProtocolServer 'PSMP) Worker)
ntfSMPWorkers IO (Map (ProtocolServer 'PSMP) Worker)
-> (Map (ProtocolServer 'PSMP) Worker -> IO WorkersSummary)
-> IO WorkersSummary
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map (ProtocolServer 'PSMP) Worker -> IO WorkersSummary
forall k. Map k Worker -> IO WorkersSummary
workerSummary
  WorkersSummary
xftpRcvWorkersCount <- TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
-> IO (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpRcvWorkers IO (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
-> (Map (Maybe (ProtocolServer 'PXFTP)) Worker
    -> IO WorkersSummary)
-> IO WorkersSummary
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map (Maybe (ProtocolServer 'PXFTP)) Worker -> IO WorkersSummary
forall k. Map k Worker -> IO WorkersSummary
workerSummary
  WorkersSummary
xftpSndWorkersCount <- TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
-> IO (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpSndWorkers IO (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
-> (Map (Maybe (ProtocolServer 'PXFTP)) Worker
    -> IO WorkersSummary)
-> IO WorkersSummary
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map (Maybe (ProtocolServer 'PXFTP)) Worker -> IO WorkersSummary
forall k. Map k Worker -> IO WorkersSummary
workerSummary
  WorkersSummary
xftpDelWorkersCount <- TVar (Map (ProtocolServer 'PXFTP) Worker)
-> IO (Map (ProtocolServer 'PXFTP) Worker)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map (ProtocolServer 'PXFTP) Worker)
xftpDelWorkers IO (Map (ProtocolServer 'PXFTP) Worker)
-> (Map (ProtocolServer 'PXFTP) Worker -> IO WorkersSummary)
-> IO WorkersSummary
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map (ProtocolServer 'PXFTP) Worker -> IO WorkersSummary
forall k. Map k Worker -> IO WorkersSummary
workerSummary
  AgentWorkersSummary -> IO AgentWorkersSummary
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    AgentWorkersSummary
      { Int
$sel:smpClientsCount:AgentWorkersSummary :: Int
smpClientsCount :: Int
smpClientsCount,
        Int
$sel:ntfClientsCount:AgentWorkersSummary :: Int
ntfClientsCount :: Int
ntfClientsCount,
        Int
$sel:xftpClientsCount:AgentWorkersSummary :: Int
xftpClientsCount :: Int
xftpClientsCount,
        WorkersSummary
$sel:smpDeliveryWorkersCount:AgentWorkersSummary :: WorkersSummary
smpDeliveryWorkersCount :: WorkersSummary
smpDeliveryWorkersCount,
        WorkersSummary
$sel:asyncCmdWorkersCount:AgentWorkersSummary :: WorkersSummary
asyncCmdWorkersCount :: WorkersSummary
asyncCmdWorkersCount,
        Int
$sel:smpSubWorkersCount:AgentWorkersSummary :: Int
smpSubWorkersCount :: Int
smpSubWorkersCount,
        WorkersSummary
$sel:ntfWorkersCount:AgentWorkersSummary :: WorkersSummary
ntfWorkersCount :: WorkersSummary
ntfWorkersCount,
        WorkersSummary
$sel:ntfSMPWorkersCount:AgentWorkersSummary :: WorkersSummary
ntfSMPWorkersCount :: WorkersSummary
ntfSMPWorkersCount,
        WorkersSummary
$sel:xftpRcvWorkersCount:AgentWorkersSummary :: WorkersSummary
xftpRcvWorkersCount :: WorkersSummary
xftpRcvWorkersCount,
        WorkersSummary
$sel:xftpSndWorkersCount:AgentWorkersSummary :: WorkersSummary
xftpSndWorkersCount :: WorkersSummary
xftpSndWorkersCount,
        WorkersSummary
$sel:xftpDelWorkersCount:AgentWorkersSummary :: WorkersSummary
xftpDelWorkersCount :: WorkersSummary
xftpDelWorkersCount
      }
  where
    Env {NtfSupervisor
$sel:ntfSupervisor:Env :: Env -> NtfSupervisor
ntfSupervisor :: NtfSupervisor
ntfSupervisor, XFTPAgent
$sel:xftpAgent:Env :: Env -> XFTPAgent
xftpAgent :: XFTPAgent
xftpAgent} = Env
agentEnv
    NtfSupervisor {TVar (Map (ProtocolServer 'PNTF) Worker)
$sel:ntfWorkers:NtfSupervisor :: NtfSupervisor -> TVar (Map (ProtocolServer 'PNTF) Worker)
ntfWorkers :: TVar (Map (ProtocolServer 'PNTF) Worker)
ntfWorkers, TVar (Map (ProtocolServer 'PSMP) Worker)
$sel:ntfSMPWorkers:NtfSupervisor :: NtfSupervisor -> TVar (Map (ProtocolServer 'PSMP) Worker)
ntfSMPWorkers :: TVar (Map (ProtocolServer 'PSMP) Worker)
ntfSMPWorkers} = NtfSupervisor
ntfSupervisor
    XFTPAgent {TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
$sel:xftpRcvWorkers:XFTPAgent :: XFTPAgent -> TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpRcvWorkers :: TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpRcvWorkers, TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
$sel:xftpSndWorkers:XFTPAgent :: XFTPAgent -> TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpSndWorkers :: TVar (Map (Maybe (ProtocolServer 'PXFTP)) Worker)
xftpSndWorkers, TVar (Map (ProtocolServer 'PXFTP) Worker)
$sel:xftpDelWorkers:XFTPAgent :: XFTPAgent -> TVar (Map (ProtocolServer 'PXFTP) Worker)
xftpDelWorkers :: TVar (Map (ProtocolServer 'PXFTP) Worker)
xftpDelWorkers} = XFTPAgent
xftpAgent
    workerSummary :: M.Map k Worker -> IO WorkersSummary
    workerSummary :: forall k. Map k Worker -> IO WorkersSummary
workerSummary = IO WorkersSummary -> IO WorkersSummary
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WorkersSummary -> IO WorkersSummary)
-> (Map k Worker -> IO WorkersSummary)
-> Map k Worker
-> IO WorkersSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkersSummary -> Worker -> IO WorkersSummary)
-> WorkersSummary -> Map k Worker -> IO WorkersSummary
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM WorkersSummary -> Worker -> IO WorkersSummary
forall {m :: * -> *}.
MonadIO m =>
WorkersSummary -> Worker -> m WorkersSummary
byWork WorkersSummary {$sel:numActive:WorkersSummary :: Int
numActive = Int
0, $sel:numIdle:WorkersSummary :: Int
numIdle = Int
0, $sel:totalRestarts:WorkersSummary :: Int
totalRestarts = Int
0}
      where
        byWork :: WorkersSummary -> Worker -> m WorkersSummary
byWork WorkersSummary {Int
$sel:numActive:WorkersSummary :: WorkersSummary -> Int
numActive :: Int
numActive, Int
$sel:numIdle:WorkersSummary :: WorkersSummary -> Int
numIdle :: Int
numIdle, Int
$sel:totalRestarts:WorkersSummary :: WorkersSummary -> Int
totalRestarts :: Int
totalRestarts} Worker {TMVar (Maybe (Weak ThreadId))
$sel:action:Worker :: Worker -> TMVar (Maybe (Weak ThreadId))
action :: TMVar (Maybe (Weak ThreadId))
action, TVar RestartCount
$sel:restarts:Worker :: Worker -> TVar RestartCount
restarts :: TVar RestartCount
restarts} = do
          RestartCount {Int
$sel:restartCount:RestartCount :: RestartCount -> Int
restartCount :: Int
restartCount} <- TVar RestartCount -> m RestartCount
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar RestartCount
restarts
          m Bool -> m WorkersSummary -> m WorkersSummary -> m WorkersSummary
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
            (STM Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> m Bool) -> STM Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe (Weak ThreadId)) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Maybe (Weak ThreadId)) -> Bool)
-> STM (Maybe (Maybe (Weak ThreadId))) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar (Maybe (Weak ThreadId))
-> STM (Maybe (Maybe (Weak ThreadId)))
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar (Maybe (Weak ThreadId))
action)
            (WorkersSummary -> m WorkersSummary
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WorkersSummary {Int
$sel:numActive:WorkersSummary :: Int
numActive :: Int
numActive, $sel:numIdle:WorkersSummary :: Int
numIdle = Int
numIdle Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, $sel:totalRestarts:WorkersSummary :: Int
totalRestarts = Int
totalRestarts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
restartCount})
            (WorkersSummary -> m WorkersSummary
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WorkersSummary {$sel:numActive:WorkersSummary :: Int
numActive = Int
numActive Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
$sel:numIdle:WorkersSummary :: Int
numIdle :: Int
numIdle, $sel:totalRestarts:WorkersSummary :: Int
totalRestarts = Int
totalRestarts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
restartCount})

data AgentQueuesInfo = AgentQueuesInfo
  { AgentQueuesInfo -> TBQueueInfo
msgQInfo :: TBQueueInfo,
    AgentQueuesInfo -> TBQueueInfo
subQInfo :: TBQueueInfo,
    AgentQueuesInfo -> Map Text (Int, UTCTime, ClientInfo)
smpClientsQueues :: Map Text (Int, UTCTime, ClientInfo)
  }
  deriving (Int -> AgentQueuesInfo -> String -> String
[AgentQueuesInfo] -> String -> String
AgentQueuesInfo -> String
(Int -> AgentQueuesInfo -> String -> String)
-> (AgentQueuesInfo -> String)
-> ([AgentQueuesInfo] -> String -> String)
-> Show AgentQueuesInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AgentQueuesInfo -> String -> String
showsPrec :: Int -> AgentQueuesInfo -> String -> String
$cshow :: AgentQueuesInfo -> String
show :: AgentQueuesInfo -> String
$cshowList :: [AgentQueuesInfo] -> String -> String
showList :: [AgentQueuesInfo] -> String -> String
Show)

data ClientInfo
  = ClientInfoQueues {ClientInfo -> TBQueueInfo
sndQInfo :: TBQueueInfo, ClientInfo -> TBQueueInfo
rcvQInfo :: TBQueueInfo}
  | ClientInfoError {ClientInfo -> (AgentErrorType, Maybe UTCTime)
clientError :: (AgentErrorType, Maybe UTCTime)}
  | ClientInfoConnecting
  deriving (Int -> ClientInfo -> String -> String
[ClientInfo] -> String -> String
ClientInfo -> String
(Int -> ClientInfo -> String -> String)
-> (ClientInfo -> String)
-> ([ClientInfo] -> String -> String)
-> Show ClientInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ClientInfo -> String -> String
showsPrec :: Int -> ClientInfo -> String -> String
$cshow :: ClientInfo -> String
show :: ClientInfo -> String
$cshowList :: [ClientInfo] -> String -> String
showList :: [ClientInfo] -> String -> String
Show)

getAgentQueuesInfo :: AgentClient -> IO AgentQueuesInfo
getAgentQueuesInfo :: AgentClient -> IO AgentQueuesInfo
getAgentQueuesInfo AgentClient {TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
$sel:msgQ:AgentClient :: AgentClient
-> TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
msgQ, TBQueue ATransmission
$sel:subQ:AgentClient :: AgentClient -> TBQueue ATransmission
subQ :: TBQueue ATransmission
subQ, TMap SMPTransportSession SMPClientVar
$sel:smpClients:AgentClient :: AgentClient -> TMap SMPTransportSession SMPClientVar
smpClients :: TMap SMPTransportSession SMPClientVar
smpClients} = do
  TBQueueInfo
msgQInfo <- STM TBQueueInfo -> IO TBQueueInfo
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM TBQueueInfo -> IO TBQueueInfo)
-> STM TBQueueInfo -> IO TBQueueInfo
forall a b. (a -> b) -> a -> b
$ TBQueue
  ((UserId, ProtocolServer 'PSMP, Maybe ByteString),
   Version SMPVersion, ByteString,
   NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg))
-> STM TBQueueInfo
forall a. TBQueue a -> STM TBQueueInfo
getTBQueueInfo TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
TBQueue
  ((UserId, ProtocolServer 'PSMP, Maybe ByteString),
   Version SMPVersion, ByteString,
   NonEmpty (RecipientId, ServerTransmission ErrorType BrokerMsg))
msgQ
  TBQueueInfo
subQInfo <- STM TBQueueInfo -> IO TBQueueInfo
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM TBQueueInfo -> IO TBQueueInfo)
-> STM TBQueueInfo -> IO TBQueueInfo
forall a b. (a -> b) -> a -> b
$ TBQueue ATransmission -> STM TBQueueInfo
forall a. TBQueue a -> STM TBQueueInfo
getTBQueueInfo TBQueue ATransmission
subQ
  Map
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
smpClientsMap <- TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> IO
     (Map
        (UserId, ProtocolServer 'PSMP, Maybe ByteString)
        (SessionVar
           (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap SMPTransportSession SMPClientVar
TMap
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
smpClients
  let smpClientsMap' :: Map
  Text
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
smpClientsMap' = ((UserId, ProtocolServer 'PSMP, Maybe ByteString) -> Text)
-> Map
     (UserId, ProtocolServer 'PSMP, Maybe ByteString)
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> Map
     Text
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (ByteString -> Text
decodeLatin1 (ByteString -> Text)
-> ((UserId, ProtocolServer 'PSMP, Maybe ByteString) -> ByteString)
-> (UserId, ProtocolServer 'PSMP, Maybe ByteString)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserId, ProtocolServer 'PSMP, Maybe ByteString) -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode) Map
  (UserId, ProtocolServer 'PSMP, Maybe ByteString)
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
smpClientsMap
  Map Text (Int, UTCTime, ClientInfo)
smpClientsQueues <- (SessionVar
   (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
 -> IO (Int, UTCTime, ClientInfo))
-> Map
     Text
     (SessionVar
        (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> IO (Map Text (Int, UTCTime, ClientInfo))
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) -> Map Text a -> m (Map Text b)
mapM SMPClientVar -> IO (Int, UTCTime, ClientInfo)
SessionVar
  (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> IO (Int, UTCTime, ClientInfo)
getClientQueuesInfo Map
  Text
  (SessionVar
     (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
smpClientsMap'
  AgentQueuesInfo -> IO AgentQueuesInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AgentQueuesInfo {TBQueueInfo
$sel:msgQInfo:AgentQueuesInfo :: TBQueueInfo
msgQInfo :: TBQueueInfo
msgQInfo, TBQueueInfo
$sel:subQInfo:AgentQueuesInfo :: TBQueueInfo
subQInfo :: TBQueueInfo
subQInfo, Map Text (Int, UTCTime, ClientInfo)
$sel:smpClientsQueues:AgentQueuesInfo :: Map Text (Int, UTCTime, ClientInfo)
smpClientsQueues :: Map Text (Int, UTCTime, ClientInfo)
smpClientsQueues}
  where
    getClientQueuesInfo :: SMPClientVar -> IO (Int, UTCTime, ClientInfo)
    getClientQueuesInfo :: SMPClientVar -> IO (Int, UTCTime, ClientInfo)
getClientQueuesInfo SessionVar {TMVar (Either (AgentErrorType, Maybe UTCTime) (Client BrokerMsg))
sessionVar :: forall a. SessionVar a -> TMVar a
sessionVar :: TMVar (Either (AgentErrorType, Maybe UTCTime) (Client BrokerMsg))
sessionVar, Int
sessionVarId :: Int
sessionVarId :: forall a. SessionVar a -> Int
sessionVarId, UTCTime
sessionVarTs :: UTCTime
sessionVarTs :: forall a. SessionVar a -> UTCTime
sessionVarTs} = do
      ClientInfo
clientInfo <-
        STM
  (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> IO
     (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
-> STM
     (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar (Either (AgentErrorType, Maybe UTCTime) (Client BrokerMsg))
TMVar (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
sessionVar) IO
  (Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient))
-> (Maybe
      (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
    -> IO ClientInfo)
-> IO ClientInfo
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just (Right SMPConnectedClient
c) -> do
            (TBQueueInfo
sndQInfo, TBQueueInfo
rcvQInfo) <- SMPClient -> IO (TBQueueInfo, TBQueueInfo)
forall v err msg.
ProtocolClient v err msg -> IO (TBQueueInfo, TBQueueInfo)
getProtocolClientQueuesInfo (SMPClient -> IO (TBQueueInfo, TBQueueInfo))
-> SMPClient -> IO (TBQueueInfo, TBQueueInfo)
forall a b. (a -> b) -> a -> b
$ Client BrokerMsg -> ProtoClient BrokerMsg
forall v err msg.
ProtocolServerClient v err msg =>
Client msg -> ProtoClient msg
protocolClient Client BrokerMsg
SMPConnectedClient
c
            ClientInfo -> IO ClientInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientInfoQueues {TBQueueInfo
$sel:sndQInfo:ClientInfoQueues :: TBQueueInfo
sndQInfo :: TBQueueInfo
sndQInfo, TBQueueInfo
$sel:rcvQInfo:ClientInfoQueues :: TBQueueInfo
rcvQInfo :: TBQueueInfo
rcvQInfo}
          Just (Left (AgentErrorType, Maybe UTCTime)
e) -> ClientInfo -> IO ClientInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientInfo -> IO ClientInfo) -> ClientInfo -> IO ClientInfo
forall a b. (a -> b) -> a -> b
$ (AgentErrorType, Maybe UTCTime) -> ClientInfo
ClientInfoError (AgentErrorType, Maybe UTCTime)
e
          Maybe (Either (AgentErrorType, Maybe UTCTime) SMPConnectedClient)
Nothing -> ClientInfo -> IO ClientInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientInfo
ClientInfoConnecting
      (Int, UTCTime, ClientInfo) -> IO (Int, UTCTime, ClientInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
sessionVarId, UTCTime
sessionVarTs, ClientInfo
clientInfo)

$(J.deriveJSON defaultJSON ''AgentLocks)

$(J.deriveJSON (enumJSON $ dropPrefix "TS") ''ProtocolTestStep)

$(J.deriveJSON defaultJSON ''ProtocolTestFailure)

$(J.deriveJSON defaultJSON ''ServerSessions)

$(J.deriveJSON defaultJSON ''SMPServerSubs)

$(J.deriveJSON defaultJSON ''AgentServersSummary)

$(J.deriveJSON defaultJSON ''SubInfo)

$(J.deriveJSON defaultJSON ''SubscriptionsInfo)

$(J.deriveJSON defaultJSON ''WorkersDetails)

$(J.deriveJSON defaultJSON ''WorkersSummary)

$(J.deriveJSON defaultJSON {J.fieldLabelModifier = takeWhile (/= '_')} ''AgentWorkersDetails)

$(J.deriveJSON defaultJSON ''AgentWorkersSummary)

$(J.deriveJSON (sumTypeJSON $ dropPrefix "ClientInfo") ''ClientInfo)

$(J.deriveJSON defaultJSON ''AgentQueuesInfo)

$(J.deriveJSON (enumJSON $ dropPrefix "UN") ''UserNetworkType)

$(J.deriveJSON defaultJSON ''UserNetworkInfo)

$(J.deriveJSON defaultJSON ''ServerQueueInfo)