{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

-- |
-- Module      : Simplex.Messaging.Agent
-- Copyright   : (c) simplex.chat
-- License     : AGPL-3
--
-- Maintainer  : chat@simplex.chat
-- Stability   : experimental
-- Portability : non-portable
--
-- This module defines SMP protocol agent with SQLite persistence.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
module Simplex.Messaging.Agent
  ( -- * SMP agent functional API
    AgentClient (..),
    AE,
    SubscriptionsInfo (..),
    MsgReq,
    ValueOrRef (..),
    vrValue,
    getSMPAgentClient,
    getSMPAgentClient_,
    disconnectAgentClient,
    disposeAgentClient,
    resumeAgentClient,
    withConnLock,
    withInvLock,
    createUser,
    deleteUser,
    connRequestPQSupport,
    createConnectionAsync,
    setConnShortLinkAsync,
    getConnShortLinkAsync,
    joinConnectionAsync,
    allowConnectionAsync,
    acceptContactAsync,
    ackMessageAsync,
    switchConnectionAsync,
    deleteConnectionAsync,
    deleteConnectionsAsync,
    createConnection,
    prepareConnectionLink,
    createConnectionForLink,
    setConnShortLink,
    deleteConnShortLink,
    getConnShortLink,
    getConnLinkPrivKey,
    deleteLocalInvShortLink,
    changeConnectionUser,
    prepareConnectionToJoin,
    prepareConnectionToAccept,
    joinConnection,
    allowConnection,
    acceptContact,
    rejectContact,
    DatabaseDiff (..),
    compareConnections,
    syncConnections,
    subscribeConnection,
    subscribeConnections,
    subscribeAllConnections,
    getConnectionMessages,
    getNotificationConns,
    resubscribeConnection,
    resubscribeConnections,
    subscribeClientService,
    sendMessage,
    sendMessages,
    sendMessagesB,
    ackMessage,
    getConnectionQueueInfo,
    switchConnection,
    abortConnectionSwitch,
    synchronizeRatchet,
    suspendConnection,
    deleteConnection,
    deleteConnections,
    getConnectionServers,
    getConnectionRatchetAdHash,
    setProtocolServers,
    checkUserServers,
    testProtocolServer,
    setNtfServers,
    setNetworkConfig,
    setUserNetworkInfo,
    reconnectAllServers,
    reconnectSMPServer,
    registerNtfToken,
    verifyNtfToken,
    checkNtfToken,
    deleteNtfToken,
    getNtfToken,
    getNtfTokenData,
    toggleConnectionNtfs,
    xftpStartWorkers,
    xftpStartSndWorkers,
    xftpReceiveFile,
    xftpDeleteRcvFile,
    xftpDeleteRcvFiles,
    xftpSendFile,
    xftpSendDescription,
    xftpDeleteSndFileInternal,
    xftpDeleteSndFilesInternal,
    xftpDeleteSndFileRemote,
    xftpDeleteSndFilesRemote,
    rcNewHostPairing,
    rcConnectHost,
    rcConnectCtrl,
    rcDiscoverCtrl,
    getAgentSubsTotal,
    getAgentServersSummary,
    resetAgentServersStats,
    foregroundAgent,
    suspendAgent,
    execAgentStoreSQL,
    getAgentMigrations,
    debugAgentLocks,
    getAgentSubscriptions,
    logConnection,
    -- for tests
    withAgentEnv,
  )
where

import Control.Applicative ((<|>))
import Control.Concurrent.STM (retry)
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import Data.Bifunctor (bimap, first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Composition
import Data.Either (isRight, partitionEithers, rights)
import Data.Foldable (foldl', toList)
import Data.Functor (($>))
import Data.Functor.Identity
import Data.Int (Int64)
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
import Data.List (find, sortOn)
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 qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Clock.System (systemToUTCTime)
import Data.Traversable (mapAccumL)
import Data.Word (Word16)
import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile')
import Simplex.FileTransfer.Description (ValidFileDescription)
import Simplex.FileTransfer.Protocol (FileParty (..))
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
import Simplex.FileTransfer.Util (removePath)
import Simplex.Messaging.Agent.Client
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Lock (withLock, withLock')
import Simplex.Messaging.Agent.NtfSubSupervisor
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
import Simplex.Messaging.Agent.Store.Common (DBStore)
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Agent.Store.Entity
import Simplex.Messaging.Agent.Store.Interface (closeDBStore, execSQL, getCurrentMigrations)
import Simplex.Messaging.Agent.Store.Shared (UpMigration (..), upMigration)
import qualified Simplex.Messaging.Agent.TSessionSubs as SS
import Simplex.Messaging.Client (NetworkRequestMode (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, nonBlockingWriteTBQueue, smpErrorClientNotice, temporaryClientError, unexpectedResponse)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import qualified Simplex.Messaging.Crypto.ShortLink as SL
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP)
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Parsers (defaultJSON, parse)
import Simplex.Messaging.Protocol
  ( BrokerMsg,
    Cmd (..),
    ErrorType (AUTH),
    MsgBody,
    MsgFlags (..),
    NtfServer,
    ProtoServerWithAuth (..),
    ProtocolServer (..),
    ProtocolType (..),
    ProtocolTypeI (..),
    QueueLinkData,
    QueueMode (..),
    SMPMsgMeta,
    SParty (..),
    SProtocolType (..),
    SndPublicAuthKey,
    SubscriptionMode (..),
    UserProtocol,
    VersionSMPC,
    senderCanSecure,
  )
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
import Simplex.Messaging.SystemTime
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (SMPVersion)
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import Simplex.RemoteControl.Client
import Simplex.RemoteControl.Invitation
import Simplex.RemoteControl.Types
import System.Mem.Weak (deRefWeak)
import UnliftIO.Async (mapConcurrently)
import UnliftIO.Concurrent (forkFinally, forkIO, killThread, mkWeakThreadId, threadDelay)
import qualified UnliftIO.Exception as E
import UnliftIO.STM

-- import GHC.Conc (unsafeIOToSTM)

type AE a = ExceptT AgentErrorType IO a

-- | Creates an SMP agent client instance
getSMPAgentClient :: AgentConfig -> InitialAgentServers -> DBStore -> Bool -> IO AgentClient
getSMPAgentClient :: AgentConfig
-> InitialAgentServers -> DBStore -> Bool -> IO AgentClient
getSMPAgentClient = Int
-> AgentConfig
-> InitialAgentServers
-> DBStore
-> Bool
-> IO AgentClient
getSMPAgentClient_ Int
1
{-# INLINE getSMPAgentClient #-}

getSMPAgentClient_ :: Int -> AgentConfig -> InitialAgentServers -> DBStore -> Bool -> IO AgentClient
getSMPAgentClient_ :: Int
-> AgentConfig
-> InitialAgentServers
-> DBStore
-> Bool
-> IO AgentClient
getSMPAgentClient_ Int
clientId AgentConfig
cfg initServers :: InitialAgentServers
initServers@InitialAgentServers {Map UserId (NonEmpty (ServerCfg 'PSMP))
smp :: Map UserId (NonEmpty (ServerCfg 'PSMP))
$sel:smp:InitialAgentServers :: InitialAgentServers -> Map UserId (NonEmpty (ServerCfg 'PSMP))
smp, Map UserId (NonEmpty (ServerCfg 'PXFTP))
xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP))
$sel:xftp:InitialAgentServers :: InitialAgentServers -> Map UserId (NonEmpty (ServerCfg 'PXFTP))
xftp, [SMPServer]
presetServers :: [SMPServer]
$sel:presetServers:InitialAgentServers :: InitialAgentServers -> [SMPServer]
presetServers} DBStore
store Bool
backgroundMode =
  AgentConfig -> DBStore -> IO Env
newSMPAgentEnv AgentConfig
cfg DBStore
store IO Env -> (Env -> IO AgentClient) -> IO AgentClient
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT Env IO AgentClient -> Env -> IO AgentClient
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Env IO AgentClient
runAgent
  where
    runAgent :: ReaderT Env IO AgentClient
runAgent = 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
$ Text -> Map UserId (NonEmpty (ServerCfg 'PSMP)) -> IO ()
forall {a} {p :: ProtocolType}.
Show a =>
Text -> Map a (NonEmpty (ServerCfg p)) -> IO ()
checkServers Text
"SMP" Map UserId (NonEmpty (ServerCfg 'PSMP))
smp IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Map UserId (NonEmpty (ServerCfg 'PXFTP)) -> IO ()
forall {a} {p :: ProtocolType}.
Show a =>
Text -> Map a (NonEmpty (ServerCfg p)) -> IO ()
checkServers Text
"XFTP" Map UserId (NonEmpty (ServerCfg 'PXFTP))
xftp
      InternalTs
currentTs <- IO InternalTs -> ReaderT Env IO InternalTs
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO InternalTs
getCurrentTime
      Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
notices <- IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)))
-> ReaderT
     Env IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)))
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)))
 -> ReaderT
      Env IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))))
-> IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)))
-> ReaderT
     Env IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)))
forall a b. (a -> b) -> a -> b
$ DBStore
-> (Connection
    -> IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))))
-> IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)))
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction DBStore
store (Connection
-> [SMPServer]
-> IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)))
`getClientNotices` [SMPServer]
presetServers) IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)))
-> IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)))
-> IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)))
forall a. IO a -> IO a -> IO a
`catchAll_` Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
-> IO (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      c :: AgentClient
c@AgentClient {TVar (Maybe (Weak ThreadId))
acThread :: TVar (Maybe (Weak ThreadId))
$sel:acThread:AgentClient :: AgentClient -> TVar (Maybe (Weak ThreadId))
acThread} <- IO AgentClient -> ReaderT Env IO AgentClient
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AgentClient -> ReaderT Env IO AgentClient)
-> (Env -> IO AgentClient) -> Env -> ReaderT Env IO AgentClient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> InitialAgentServers
-> InternalTs
-> Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
-> Env
-> IO AgentClient
newAgentClient Int
clientId InitialAgentServers
initServers InternalTs
currentTs Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
notices (Env -> ReaderT Env IO AgentClient)
-> ReaderT Env IO Env -> ReaderT Env IO AgentClient
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT Env IO Env
forall r (m :: * -> *). MonadReader r m => m r
ask
      ThreadId
t <- AgentClient -> ReaderT Env IO ()
runAgentThreads AgentClient
c ReaderT Env IO ()
-> (Either SomeException () -> ReaderT Env IO ())
-> ReaderT Env IO ThreadId
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
`forkFinally` ReaderT Env IO () -> Either SomeException () -> ReaderT Env IO ()
forall a b. a -> b -> a
const (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 ()
disconnectAgentClient AgentClient
c)
      STM () -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Env IO ())
-> (Weak ThreadId -> STM ()) -> Weak ThreadId -> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Maybe (Weak ThreadId)) -> Maybe (Weak ThreadId) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (Weak ThreadId))
acThread (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 -> ReaderT Env IO ())
-> ReaderT Env IO (Weak ThreadId) -> ReaderT Env IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ThreadId -> ReaderT Env IO (Weak ThreadId)
forall (m :: * -> *). MonadIO m => ThreadId -> m (Weak ThreadId)
mkWeakThreadId ThreadId
t
      AgentClient -> ReaderT Env IO AgentClient
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AgentClient
c
    checkServers :: Text -> Map a (NonEmpty (ServerCfg p)) -> IO ()
checkServers Text
protocol Map a (NonEmpty (ServerCfg p))
srvs =
      [(a, NonEmpty (ServerCfg p))]
-> ((a, NonEmpty (ServerCfg p)) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map a (NonEmpty (ServerCfg p)) -> [(a, NonEmpty (ServerCfg p))]
forall k a. Map k a -> [(k, a)]
M.assocs Map a (NonEmpty (ServerCfg p))
srvs) (((a, NonEmpty (ServerCfg p)) -> IO ()) -> IO ())
-> ((a, NonEmpty (ServerCfg p)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(a
userId, NonEmpty (ServerCfg p)
srvs') -> Text -> NonEmpty (ServerCfg p) -> IO ()
forall (p :: ProtocolType). Text -> NonEmpty (ServerCfg p) -> IO ()
checkUserServers (Text
"getSMPAgentClient " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
protocol Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
tshow a
userId) NonEmpty (ServerCfg p)
srvs'
    runAgentThreads :: AgentClient -> ReaderT Env IO ()
runAgentThreads AgentClient
c
      | Bool
backgroundMode = AgentClient -> Text -> ReaderT Env IO () -> ReaderT Env IO ()
forall {m :: * -> *}.
MonadUnliftIO m =>
AgentClient -> Text -> m () -> m ()
run AgentClient
c Text
"subscriber" (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> ReaderT Env IO ()
subscriber AgentClient
c
      | Bool
otherwise = do
          AgentClient -> ReaderT Env IO ()
restoreServersStats AgentClient
c
          [ReaderT Env IO ()] -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadUnliftIO m => [m a] -> m ()
raceAny_
            [ AgentClient -> Text -> ReaderT Env IO () -> ReaderT Env IO ()
forall {m :: * -> *}.
MonadUnliftIO m =>
AgentClient -> Text -> m () -> m ()
run AgentClient
c Text
"subscriber" (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> ReaderT Env IO ()
subscriber AgentClient
c,
              AgentClient -> Text -> ReaderT Env IO () -> ReaderT Env IO ()
forall {m :: * -> *}.
MonadUnliftIO m =>
AgentClient -> Text -> m () -> m ()
run AgentClient
c Text
"runNtfSupervisor" (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> ReaderT Env IO ()
runNtfSupervisor AgentClient
c,
              AgentClient -> Text -> ReaderT Env IO () -> ReaderT Env IO ()
forall {m :: * -> *}.
MonadUnliftIO m =>
AgentClient -> Text -> m () -> m ()
run AgentClient
c Text
"cleanupManager" (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> ReaderT Env IO ()
cleanupManager AgentClient
c,
              AgentClient -> Text -> ReaderT Env IO () -> ReaderT Env IO ()
forall {m :: * -> *}.
MonadUnliftIO m =>
AgentClient -> Text -> m () -> m ()
run AgentClient
c Text
"logServersStats" (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> ReaderT Env IO ()
logServersStats AgentClient
c
            ]
            ReaderT Env IO () -> ReaderT Env IO () -> ReaderT Env IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`E.finally` AgentClient -> ReaderT Env IO ()
saveServersStats AgentClient
c
    run :: AgentClient -> Text -> m () -> m ()
run AgentClient {TBQueue ATransmission
subQ :: TBQueue ATransmission
$sel:subQ:AgentClient :: AgentClient -> TBQueue ATransmission
subQ, TVar (Maybe (Weak ThreadId))
$sel:acThread:AgentClient :: AgentClient -> TVar (Maybe (Weak ThreadId))
acThread :: TVar (Maybe (Weak ThreadId))
acThread} Text
name m ()
a =
      m ()
a m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`E.catchAny` \SomeException
e -> m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Maybe (Weak ThreadId) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Weak ThreadId) -> Bool)
-> m (Maybe (Weak ThreadId)) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe (Weak ThreadId)) -> m (Maybe (Weak ThreadId))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe (Weak ThreadId))
acThread) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Agent thread " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" crashed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
e
        STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue ATransmission
subQ (ConnId
"", ConnId
"", 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
$ Bool -> String -> AgentErrorType
CRITICAL Bool
True (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)

logServersStats :: AgentClient -> AM' ()
logServersStats :: AgentClient -> ReaderT Env IO ()
logServersStats AgentClient
c = do
  UserId
delay <- (Env -> UserId) -> ReaderT Env IO UserId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (AgentConfig -> UserId
initialLogStatsDelay (AgentConfig -> UserId) -> (Env -> AgentConfig) -> Env -> UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config)
  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
$ UserId -> IO ()
threadDelay' UserId
delay
  UserId
int <- (Env -> UserId) -> ReaderT Env IO UserId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (AgentConfig -> UserId
logStatsInterval (AgentConfig -> UserId) -> (Env -> AgentConfig) -> Env -> UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config)
  ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (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 ()
waitUntilActive AgentClient
c
    AgentClient -> ReaderT Env IO ()
saveServersStats 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
$ UserId -> IO ()
threadDelay' UserId
int

saveServersStats :: AgentClient -> AM' ()
saveServersStats :: AgentClient -> ReaderT Env IO ()
saveServersStats c :: AgentClient
c@AgentClient {TBQueue ATransmission
$sel:subQ:AgentClient :: AgentClient -> TBQueue ATransmission
subQ :: TBQueue ATransmission
subQ, TMap (UserId, SMPServer) AgentSMPServerStats
smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats
$sel:smpServersStats:AgentClient :: AgentClient -> TMap (UserId, SMPServer) AgentSMPServerStats
smpServersStats, TMap (UserId, XFTPServer) AgentXFTPServerStats
xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats
$sel:xftpServersStats:AgentClient :: AgentClient -> TMap (UserId, XFTPServer) AgentXFTPServerStats
xftpServersStats, TMap (UserId, NtfServer) AgentNtfServerStats
ntfServersStats :: TMap (UserId, NtfServer) AgentNtfServerStats
$sel:ntfServersStats:AgentClient :: AgentClient -> TMap (UserId, NtfServer) AgentNtfServerStats
ntfServersStats} = do
  Map (UserId, SMPServer) AgentSMPServerStatsData
sss <- (AgentSMPServerStats -> ReaderT Env IO AgentSMPServerStatsData)
-> Map (UserId, SMPServer) AgentSMPServerStats
-> ReaderT Env IO (Map (UserId, SMPServer) 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, SMPServer) a -> m (Map (UserId, SMPServer) b)
mapM (IO AgentSMPServerStatsData
-> ReaderT Env IO AgentSMPServerStatsData
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AgentSMPServerStatsData
 -> ReaderT Env IO AgentSMPServerStatsData)
-> (AgentSMPServerStats -> IO AgentSMPServerStatsData)
-> AgentSMPServerStats
-> ReaderT Env IO AgentSMPServerStatsData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentSMPServerStats -> IO AgentSMPServerStatsData
getAgentSMPServerStats) (Map (UserId, SMPServer) AgentSMPServerStats
 -> ReaderT
      Env IO (Map (UserId, SMPServer) AgentSMPServerStatsData))
-> ReaderT Env IO (Map (UserId, SMPServer) AgentSMPServerStats)
-> ReaderT Env IO (Map (UserId, SMPServer) AgentSMPServerStatsData)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap (UserId, SMPServer) AgentSMPServerStats
-> ReaderT Env IO (Map (UserId, SMPServer) AgentSMPServerStats)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap (UserId, SMPServer) AgentSMPServerStats
smpServersStats
  Map (UserId, XFTPServer) AgentXFTPServerStatsData
xss <- (AgentXFTPServerStats -> ReaderT Env IO AgentXFTPServerStatsData)
-> Map (UserId, XFTPServer) AgentXFTPServerStats
-> ReaderT
     Env IO (Map (UserId, XFTPServer) 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, XFTPServer) a -> m (Map (UserId, XFTPServer) b)
mapM (IO AgentXFTPServerStatsData
-> ReaderT Env IO AgentXFTPServerStatsData
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AgentXFTPServerStatsData
 -> ReaderT Env IO AgentXFTPServerStatsData)
-> (AgentXFTPServerStats -> IO AgentXFTPServerStatsData)
-> AgentXFTPServerStats
-> ReaderT Env IO AgentXFTPServerStatsData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentXFTPServerStats -> IO AgentXFTPServerStatsData
getAgentXFTPServerStats) (Map (UserId, XFTPServer) AgentXFTPServerStats
 -> ReaderT
      Env IO (Map (UserId, XFTPServer) AgentXFTPServerStatsData))
-> ReaderT Env IO (Map (UserId, XFTPServer) AgentXFTPServerStats)
-> ReaderT
     Env IO (Map (UserId, XFTPServer) AgentXFTPServerStatsData)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap (UserId, XFTPServer) AgentXFTPServerStats
-> ReaderT Env IO (Map (UserId, XFTPServer) AgentXFTPServerStats)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap (UserId, XFTPServer) AgentXFTPServerStats
xftpServersStats
  Map (UserId, NtfServer) AgentNtfServerStatsData
nss <- (AgentNtfServerStats -> ReaderT Env IO AgentNtfServerStatsData)
-> Map (UserId, NtfServer) AgentNtfServerStats
-> ReaderT Env IO (Map (UserId, NtfServer) 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, NtfServer) a -> m (Map (UserId, NtfServer) b)
mapM (IO AgentNtfServerStatsData
-> ReaderT Env IO AgentNtfServerStatsData
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AgentNtfServerStatsData
 -> ReaderT Env IO AgentNtfServerStatsData)
-> (AgentNtfServerStats -> IO AgentNtfServerStatsData)
-> AgentNtfServerStats
-> ReaderT Env IO AgentNtfServerStatsData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentNtfServerStats -> IO AgentNtfServerStatsData
getAgentNtfServerStats) (Map (UserId, NtfServer) AgentNtfServerStats
 -> ReaderT
      Env IO (Map (UserId, NtfServer) AgentNtfServerStatsData))
-> ReaderT Env IO (Map (UserId, NtfServer) AgentNtfServerStats)
-> ReaderT Env IO (Map (UserId, NtfServer) AgentNtfServerStatsData)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap (UserId, NtfServer) AgentNtfServerStats
-> ReaderT Env IO (Map (UserId, NtfServer) AgentNtfServerStats)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap (UserId, NtfServer) AgentNtfServerStats
ntfServersStats
  let stats :: AgentPersistedServerStats
stats = AgentPersistedServerStats {$sel:smpServersStats:AgentPersistedServerStats :: Map (UserId, SMPServer) AgentSMPServerStatsData
smpServersStats = Map (UserId, SMPServer) AgentSMPServerStatsData
sss, $sel:xftpServersStats:AgentPersistedServerStats :: Map (UserId, XFTPServer) AgentXFTPServerStatsData
xftpServersStats = Map (UserId, XFTPServer) AgentXFTPServerStatsData
xss, $sel:ntfServersStats:AgentPersistedServerStats :: OptionalMap (UserId, NtfServer) AgentNtfServerStatsData
ntfServersStats = Map (UserId, NtfServer) AgentNtfServerStatsData
-> OptionalMap (UserId, NtfServer) AgentNtfServerStatsData
forall k v. Map k v -> OptionalMap k v
OptionalMap Map (UserId, NtfServer) AgentNtfServerStatsData
nss}
  ExceptT AgentErrorType (ReaderT Env IO) ()
-> ReaderT Env IO (Either AgentErrorType ())
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> AgentPersistedServerStats -> IO ()
`updateServersStats` AgentPersistedServerStats
stats)) ReaderT Env IO (Either AgentErrorType ())
-> (Either AgentErrorType () -> 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
    Left AgentErrorType
e -> 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
$ TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue ATransmission
subQ (ConnId
"", ConnId
"", 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
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> String
forall a. Show a => a -> String
show AgentErrorType
e)
    Right () -> () -> ReaderT Env IO ()
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

restoreServersStats :: AgentClient -> AM' ()
restoreServersStats :: AgentClient -> ReaderT Env IO ()
restoreServersStats c :: AgentClient
c@AgentClient {TMap (UserId, SMPServer) AgentSMPServerStats
$sel:smpServersStats:AgentClient :: AgentClient -> TMap (UserId, SMPServer) AgentSMPServerStats
smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats
smpServersStats, TMap (UserId, XFTPServer) AgentXFTPServerStats
$sel:xftpServersStats:AgentClient :: AgentClient -> TMap (UserId, XFTPServer) AgentXFTPServerStats
xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats
xftpServersStats, TMap (UserId, NtfServer) AgentNtfServerStats
$sel:ntfServersStats:AgentClient :: AgentClient -> TMap (UserId, NtfServer) AgentNtfServerStats
ntfServersStats :: TMap (UserId, NtfServer) AgentNtfServerStats
ntfServersStats, TVar InternalTs
srvStatsStartedAt :: TVar InternalTs
$sel:srvStatsStartedAt:AgentClient :: AgentClient -> TVar InternalTs
srvStatsStartedAt} = do
  ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (InternalTs, Maybe AgentPersistedServerStats)
-> ReaderT
     Env
     IO
     (Either
        AgentErrorType (InternalTs, Maybe AgentPersistedServerStats))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (AgentClient
-> (Connection
    -> IO
         (Either StoreError (InternalTs, Maybe AgentPersistedServerStats)))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (InternalTs, Maybe AgentPersistedServerStats)
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c Connection
-> IO
     (Either StoreError (InternalTs, Maybe AgentPersistedServerStats))
getServersStats) ReaderT
  Env
  IO
  (Either
     AgentErrorType (InternalTs, Maybe AgentPersistedServerStats))
-> (Either
      AgentErrorType (InternalTs, Maybe AgentPersistedServerStats)
    -> 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
    Left AgentErrorType
e -> 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
$ TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ConnId
"", ConnId
"", 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
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> String
forall a. Show a => a -> String
show AgentErrorType
e)
    Right (InternalTs
startedAt, Maybe AgentPersistedServerStats
Nothing) -> 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 InternalTs -> InternalTs -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar InternalTs
srvStatsStartedAt InternalTs
startedAt
    Right (InternalTs
startedAt, Just AgentPersistedServerStats {$sel:smpServersStats:AgentPersistedServerStats :: AgentPersistedServerStats
-> Map (UserId, SMPServer) AgentSMPServerStatsData
smpServersStats = Map (UserId, SMPServer) AgentSMPServerStatsData
sss, $sel:xftpServersStats:AgentPersistedServerStats :: AgentPersistedServerStats
-> Map (UserId, XFTPServer) AgentXFTPServerStatsData
xftpServersStats = Map (UserId, XFTPServer) AgentXFTPServerStatsData
xss, $sel:ntfServersStats:AgentPersistedServerStats :: AgentPersistedServerStats
-> OptionalMap (UserId, NtfServer) AgentNtfServerStatsData
ntfServersStats = OptionalMap Map (UserId, NtfServer) AgentNtfServerStatsData
nss}) -> 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 InternalTs -> InternalTs -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar InternalTs
srvStatsStartedAt InternalTs
startedAt
      STM () -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Env IO ())
-> (Map (UserId, SMPServer) AgentSMPServerStats -> STM ())
-> Map (UserId, SMPServer) AgentSMPServerStats
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMap (UserId, SMPServer) AgentSMPServerStats
-> Map (UserId, SMPServer) AgentSMPServerStats -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TMap (UserId, SMPServer) AgentSMPServerStats
smpServersStats (Map (UserId, SMPServer) AgentSMPServerStats -> ReaderT Env IO ())
-> ReaderT Env IO (Map (UserId, SMPServer) AgentSMPServerStats)
-> ReaderT Env IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (AgentSMPServerStatsData -> ReaderT Env IO AgentSMPServerStats)
-> Map (UserId, SMPServer) AgentSMPServerStatsData
-> ReaderT Env IO (Map (UserId, SMPServer) AgentSMPServerStats)
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, SMPServer) a -> m (Map (UserId, SMPServer) b)
mapM (STM AgentSMPServerStats -> ReaderT Env IO AgentSMPServerStats
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AgentSMPServerStats -> ReaderT Env IO AgentSMPServerStats)
-> (AgentSMPServerStatsData -> STM AgentSMPServerStats)
-> AgentSMPServerStatsData
-> ReaderT Env IO AgentSMPServerStats
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentSMPServerStatsData -> STM AgentSMPServerStats
newAgentSMPServerStats') Map (UserId, SMPServer) AgentSMPServerStatsData
sss
      STM () -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Env IO ())
-> (Map (UserId, XFTPServer) AgentXFTPServerStats -> STM ())
-> Map (UserId, XFTPServer) AgentXFTPServerStats
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMap (UserId, XFTPServer) AgentXFTPServerStats
-> Map (UserId, XFTPServer) AgentXFTPServerStats -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TMap (UserId, XFTPServer) AgentXFTPServerStats
xftpServersStats (Map (UserId, XFTPServer) AgentXFTPServerStats
 -> ReaderT Env IO ())
-> ReaderT Env IO (Map (UserId, XFTPServer) AgentXFTPServerStats)
-> ReaderT Env IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (AgentXFTPServerStatsData -> ReaderT Env IO AgentXFTPServerStats)
-> Map (UserId, XFTPServer) AgentXFTPServerStatsData
-> ReaderT Env IO (Map (UserId, XFTPServer) AgentXFTPServerStats)
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, XFTPServer) a -> m (Map (UserId, XFTPServer) b)
mapM (STM AgentXFTPServerStats -> ReaderT Env IO AgentXFTPServerStats
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AgentXFTPServerStats -> ReaderT Env IO AgentXFTPServerStats)
-> (AgentXFTPServerStatsData -> STM AgentXFTPServerStats)
-> AgentXFTPServerStatsData
-> ReaderT Env IO AgentXFTPServerStats
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentXFTPServerStatsData -> STM AgentXFTPServerStats
newAgentXFTPServerStats') Map (UserId, XFTPServer) AgentXFTPServerStatsData
xss
      STM () -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Env IO ())
-> (Map (UserId, NtfServer) AgentNtfServerStats -> STM ())
-> Map (UserId, NtfServer) AgentNtfServerStats
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMap (UserId, NtfServer) AgentNtfServerStats
-> Map (UserId, NtfServer) AgentNtfServerStats -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TMap (UserId, NtfServer) AgentNtfServerStats
ntfServersStats (Map (UserId, NtfServer) AgentNtfServerStats -> ReaderT Env IO ())
-> ReaderT Env IO (Map (UserId, NtfServer) AgentNtfServerStats)
-> ReaderT Env IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (AgentNtfServerStatsData -> ReaderT Env IO AgentNtfServerStats)
-> Map (UserId, NtfServer) AgentNtfServerStatsData
-> ReaderT Env IO (Map (UserId, NtfServer) AgentNtfServerStats)
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, NtfServer) a -> m (Map (UserId, NtfServer) b)
mapM (STM AgentNtfServerStats -> ReaderT Env IO AgentNtfServerStats
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AgentNtfServerStats -> ReaderT Env IO AgentNtfServerStats)
-> (AgentNtfServerStatsData -> STM AgentNtfServerStats)
-> AgentNtfServerStatsData
-> ReaderT Env IO AgentNtfServerStats
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentNtfServerStatsData -> STM AgentNtfServerStats
newAgentNtfServerStats') Map (UserId, NtfServer) AgentNtfServerStatsData
nss

disconnectAgentClient :: AgentClient -> IO ()
disconnectAgentClient :: AgentClient -> IO ()
disconnectAgentClient c :: AgentClient
c@AgentClient {$sel:agentEnv:AgentClient :: AgentClient -> Env
agentEnv = Env {$sel:ntfSupervisor:Env :: Env -> NtfSupervisor
ntfSupervisor = NtfSupervisor
ns, $sel:xftpAgent:Env :: Env -> XFTPAgent
xftpAgent = XFTPAgent
xa}} = do
  AgentClient -> IO ()
closeAgentClient AgentClient
c
  NtfSupervisor -> IO ()
closeNtfSupervisor NtfSupervisor
ns
  XFTPAgent -> IO ()
closeXFTPAgent XFTPAgent
xa
  AgentClient -> Bool -> IO ()
logConnection AgentClient
c Bool
False

-- only used in the tests
disposeAgentClient :: AgentClient -> IO ()
disposeAgentClient :: AgentClient -> IO ()
disposeAgentClient c :: AgentClient
c@AgentClient {TVar (Maybe (Weak ThreadId))
$sel:acThread:AgentClient :: AgentClient -> TVar (Maybe (Weak ThreadId))
acThread :: TVar (Maybe (Weak ThreadId))
acThread, $sel:agentEnv:AgentClient :: AgentClient -> Env
agentEnv = Env {DBStore
store :: DBStore
$sel:store:Env :: Env -> DBStore
store}} = do
  Maybe ThreadId
t_ <- STM (Maybe (Weak ThreadId)) -> IO (Maybe (Weak ThreadId))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar (Maybe (Weak ThreadId))
-> Maybe (Weak ThreadId) -> STM (Maybe (Weak ThreadId))
forall a. TVar a -> a -> STM a
swapTVar TVar (Maybe (Weak ThreadId))
acThread Maybe (Weak ThreadId)
forall a. Maybe a
Nothing) IO (Maybe (Weak ThreadId))
-> (Weak ThreadId -> IO (Maybe ThreadId)) -> IO (Maybe ThreadId)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= (IO (Maybe ThreadId) -> IO (Maybe ThreadId)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ThreadId) -> IO (Maybe ThreadId))
-> (Weak ThreadId -> IO (Maybe ThreadId))
-> Weak ThreadId
-> IO (Maybe ThreadId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak)
  AgentClient -> IO ()
disconnectAgentClient AgentClient
c
  (ThreadId -> IO ()) -> Maybe ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
forall (m :: * -> *). MonadIO m => ThreadId -> m ()
killThread Maybe ThreadId
t_
  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
$ DBStore -> IO ()
closeDBStore DBStore
store

resumeAgentClient :: AgentClient -> IO ()
resumeAgentClient :: AgentClient -> IO ()
resumeAgentClient 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
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (AgentClient -> TVar Bool
active AgentClient
c) Bool
True
{-# INLINE resumeAgentClient #-}

createUser :: AgentClient -> NonEmpty (ServerCfg 'PSMP) -> NonEmpty (ServerCfg 'PXFTP) -> AE UserId
createUser :: AgentClient
-> NonEmpty (ServerCfg 'PSMP)
-> NonEmpty (ServerCfg 'PXFTP)
-> AE UserId
createUser AgentClient
c = AgentClient -> AM UserId -> AE UserId
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM UserId -> AE UserId)
-> (NonEmpty (ServerCfg 'PSMP)
    -> NonEmpty (ServerCfg 'PXFTP) -> AM UserId)
-> NonEmpty (ServerCfg 'PSMP)
-> NonEmpty (ServerCfg 'PXFTP)
-> AE UserId
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> NonEmpty (ServerCfg 'PSMP)
-> NonEmpty (ServerCfg 'PXFTP)
-> AM UserId
createUser' AgentClient
c
{-# INLINE createUser #-}

-- | Delete user record optionally deleting all user's connections on SMP servers
deleteUser :: AgentClient -> UserId -> Bool -> AE ()
deleteUser :: AgentClient -> UserId -> Bool -> AE ()
deleteUser AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (UserId -> Bool -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> UserId
-> Bool
-> AE ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> UserId -> Bool -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteUser' AgentClient
c
{-# INLINE deleteUser #-}

-- | Create SMP agent connection (NEW command) asynchronously, synchronous response is new connection id
createConnectionAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AE ConnId
createConnectionAsync :: forall (c :: ConnectionMode).
ConnectionModeI c =>
AgentClient
-> UserId
-> ConnId
-> Bool
-> SConnectionMode c
-> InitialKeys
-> SubscriptionMode
-> AE ConnId
createConnectionAsync AgentClient
c UserId
userId ConnId
aCorrId Bool
enableNtfs = AgentClient -> AM ConnId -> AE ConnId
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnId -> AE ConnId)
-> (SConnectionMode c
    -> InitialKeys -> SubscriptionMode -> AM ConnId)
-> SConnectionMode c
-> InitialKeys
-> SubscriptionMode
-> AE ConnId
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. AgentClient
-> UserId
-> ConnId
-> Bool
-> SConnectionMode c
-> InitialKeys
-> SubscriptionMode
-> AM ConnId
forall (c :: ConnectionMode).
ConnectionModeI c =>
AgentClient
-> UserId
-> ConnId
-> Bool
-> SConnectionMode c
-> InitialKeys
-> SubscriptionMode
-> AM ConnId
newConnAsync AgentClient
c UserId
userId ConnId
aCorrId Bool
enableNtfs
{-# INLINE createConnectionAsync #-}

-- | Create or update user's contact connection short link (LSET command) asynchronously, no synchronous response
setConnShortLinkAsync :: AgentClient -> ACorrId -> ConnId -> UserConnLinkData 'CMContact -> Maybe CRClientData -> AE ()
setConnShortLinkAsync :: AgentClient
-> ConnId
-> ConnId
-> UserConnLinkData 'CMContact
-> Maybe Text
-> AE ()
setConnShortLinkAsync AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (ConnId
    -> ConnId
    -> UserConnLinkData 'CMContact
    -> Maybe Text
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId
-> ConnId
-> UserConnLinkData 'CMContact
-> Maybe Text
-> AE ()
forall {d} {e} {a1} {a2} {b} {c}.
(d -> e) -> (a1 -> a2 -> b -> c -> d) -> a1 -> a2 -> b -> c -> e
.:: AgentClient
-> ConnId
-> ConnId
-> UserConnLinkData 'CMContact
-> Maybe Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
setConnShortLinkAsync' AgentClient
c
{-# INLINE setConnShortLinkAsync #-}

-- | Get and verify data from short link (LGET/LKEY command) asynchronously, synchronous response is new/passed connection id
getConnShortLinkAsync :: AgentClient -> UserId -> ACorrId -> Maybe ConnId -> ConnShortLink 'CMContact -> AE ConnId
getConnShortLinkAsync :: AgentClient
-> UserId
-> ConnId
-> Maybe ConnId
-> ConnShortLink 'CMContact
-> AE ConnId
getConnShortLinkAsync AgentClient
c = AgentClient -> AM ConnId -> AE ConnId
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnId -> AE ConnId)
-> (UserId
    -> ConnId -> Maybe ConnId -> ConnShortLink 'CMContact -> AM ConnId)
-> UserId
-> ConnId
-> Maybe ConnId
-> ConnShortLink 'CMContact
-> AE ConnId
forall {d} {e} {a1} {a2} {b} {c}.
(d -> e) -> (a1 -> a2 -> b -> c -> d) -> a1 -> a2 -> b -> c -> e
.:: AgentClient
-> UserId
-> ConnId
-> Maybe ConnId
-> ConnShortLink 'CMContact
-> AM ConnId
getConnShortLinkAsync' AgentClient
c
{-# INLINE getConnShortLinkAsync #-}

-- | Join SMP agent connection (JOIN command) asynchronously, synchronous response is new connection id.
-- If connId is provided (for contact URIs), it updates the existing connection record created by getConnShortLinkAsync.
joinConnectionAsync :: AgentClient -> UserId -> ACorrId -> Maybe ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId
joinConnectionAsync :: forall (c :: ConnectionMode).
AgentClient
-> UserId
-> ConnId
-> Maybe ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AE ConnId
joinConnectionAsync AgentClient
c UserId
userId ConnId
aCorrId Maybe ConnId
connId_ Bool
enableNtfs = AgentClient -> AM ConnId -> AE ConnId
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnId -> AE ConnId)
-> (ConnectionRequestUri c
    -> ConnId -> PQSupport -> SubscriptionMode -> AM ConnId)
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AE ConnId
forall {d} {e} {a1} {a2} {b} {c}.
(d -> e) -> (a1 -> a2 -> b -> c -> d) -> a1 -> a2 -> b -> c -> e
.:: AgentClient
-> UserId
-> ConnId
-> Maybe ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM ConnId
forall (c :: ConnectionMode).
AgentClient
-> UserId
-> ConnId
-> Maybe ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM ConnId
joinConnAsync AgentClient
c UserId
userId ConnId
aCorrId Maybe ConnId
connId_ Bool
enableNtfs
{-# INLINE joinConnectionAsync #-}

-- | Allow connection to continue after CONF notification (LET command), no synchronous response
allowConnectionAsync :: AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> AE ()
allowConnectionAsync :: AgentClient -> ConnId -> ConnId -> ConnId -> ConnId -> AE ()
allowConnectionAsync AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (ConnId
    -> ConnId
    -> ConnId
    -> ConnId
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId
-> ConnId
-> ConnId
-> ConnId
-> AE ()
forall {d} {e} {a1} {a2} {b} {c}.
(d -> e) -> (a1 -> a2 -> b -> c -> d) -> a1 -> a2 -> b -> c -> e
.:: AgentClient
-> ConnId
-> ConnId
-> ConnId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
allowConnectionAsync' AgentClient
c
{-# INLINE allowConnectionAsync #-}

-- | Accept contact after REQ notification (ACPT command) asynchronously, synchronous response is new connection id
acceptContactAsync :: AgentClient -> UserId -> ACorrId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId
acceptContactAsync :: AgentClient
-> UserId
-> ConnId
-> Bool
-> ConnId
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AE ConnId
acceptContactAsync AgentClient
c UserId
userId ConnId
aCorrId Bool
enableNtfs = AgentClient -> AM ConnId -> AE ConnId
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnId -> AE ConnId)
-> (ConnId -> ConnId -> PQSupport -> SubscriptionMode -> AM ConnId)
-> ConnId
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AE ConnId
forall {d} {e} {a1} {a2} {b} {c}.
(d -> e) -> (a1 -> a2 -> b -> c -> d) -> a1 -> a2 -> b -> c -> e
.:: AgentClient
-> UserId
-> ConnId
-> Bool
-> ConnId
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM ConnId
acceptContactAsync' AgentClient
c UserId
userId ConnId
aCorrId Bool
enableNtfs
{-# INLINE acceptContactAsync #-}

-- | Acknowledge message (ACK command) asynchronously, no synchronous response
ackMessageAsync :: AgentClient -> ACorrId -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AE ()
ackMessageAsync :: AgentClient -> ConnId -> ConnId -> UserId -> Maybe ConnId -> AE ()
ackMessageAsync AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (ConnId
    -> ConnId
    -> UserId
    -> Maybe ConnId
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId
-> ConnId
-> UserId
-> Maybe ConnId
-> AE ()
forall {d} {e} {a1} {a2} {b} {c}.
(d -> e) -> (a1 -> a2 -> b -> c -> d) -> a1 -> a2 -> b -> c -> e
.:: AgentClient
-> ConnId
-> ConnId
-> UserId
-> Maybe ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
ackMessageAsync' AgentClient
c
{-# INLINE ackMessageAsync #-}

-- | Switch connection to the new receive queue
switchConnectionAsync :: AgentClient -> ACorrId -> ConnId -> AE ConnectionStats
switchConnectionAsync :: AgentClient -> ConnId -> ConnId -> AE ConnectionStats
switchConnectionAsync AgentClient
c = AgentClient -> AM ConnectionStats -> AE ConnectionStats
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnectionStats -> AE ConnectionStats)
-> (ConnId -> ConnId -> AM ConnectionStats)
-> ConnId
-> ConnId
-> AE ConnectionStats
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient -> ConnId -> ConnId -> AM ConnectionStats
switchConnectionAsync' AgentClient
c
{-# INLINE switchConnectionAsync #-}

-- | Delete SMP agent connection (DEL command) asynchronously, no synchronous response
deleteConnectionAsync :: AgentClient -> Bool -> ConnId -> AE ()
deleteConnectionAsync :: AgentClient -> Bool -> ConnId -> AE ()
deleteConnectionAsync AgentClient
c Bool
waitDelivery = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId
-> AE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> Bool -> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnectionAsync' AgentClient
c Bool
waitDelivery
{-# INLINE deleteConnectionAsync #-}

-- | Delete SMP agent connections using batch commands asynchronously, no synchronous response
deleteConnectionsAsync :: AgentClient -> Bool -> [ConnId] -> AE ()
deleteConnectionsAsync :: AgentClient -> Bool -> [ConnId] -> AE ()
deleteConnectionsAsync AgentClient
c Bool
waitDelivery = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> ([ConnId] -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> [ConnId]
-> AE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> Bool -> [ConnId] -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnectionsAsync' AgentClient
c Bool
waitDelivery
{-# INLINE deleteConnectionsAsync #-}

-- | Create SMP agent connection (NEW command)
createConnection :: ConnectionModeI c => AgentClient -> NetworkRequestMode -> UserId -> Bool -> Bool -> SConnectionMode c -> Maybe (UserConnLinkData c) -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
createConnection :: forall (c :: ConnectionMode).
ConnectionModeI c =>
AgentClient
-> NetworkRequestMode
-> UserId
-> Bool
-> Bool
-> SConnectionMode c
-> Maybe (UserConnLinkData c)
-> Maybe Text
-> InitialKeys
-> SubscriptionMode
-> AE (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
createConnection AgentClient
c NetworkRequestMode
nm UserId
userId Bool
enableNtfs Bool
checkNotices = AgentClient
-> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
-> AE (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
 -> AE (ConnId, (CreatedConnLink c, Maybe ClientServiceId)))
-> (SConnectionMode c
    -> Maybe (UserConnLinkData c)
    -> Maybe Text
    -> InitialKeys
    -> SubscriptionMode
    -> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId)))
-> SConnectionMode c
-> Maybe (UserConnLinkData c)
-> Maybe Text
-> InitialKeys
-> SubscriptionMode
-> AE (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
forall {d} {e} {a1} {a2} {a3} {b} {c}.
(d -> e)
-> (a1 -> a2 -> a3 -> b -> c -> d) -> a1 -> a2 -> a3 -> b -> c -> e
.::. AgentClient
-> NetworkRequestMode
-> UserId
-> Bool
-> Bool
-> SConnectionMode c
-> Maybe (UserConnLinkData c)
-> Maybe Text
-> InitialKeys
-> SubscriptionMode
-> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
forall (c :: ConnectionMode).
ConnectionModeI c =>
AgentClient
-> NetworkRequestMode
-> UserId
-> Bool
-> Bool
-> SConnectionMode c
-> Maybe (UserConnLinkData c)
-> Maybe Text
-> InitialKeys
-> SubscriptionMode
-> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
newConn AgentClient
c NetworkRequestMode
nm UserId
userId Bool
enableNtfs Bool
checkNotices
{-# INLINE createConnection #-}

-- | Prepare connection link for contact mode (no network call).
-- Caller provides root signing key pair and link entity ID.
-- Returns the created link and internal params.
-- The link address is fully determined at this point.
prepareConnectionLink :: AgentClient -> UserId -> C.KeyPairEd25519 -> ByteString -> Bool -> Maybe CRClientData -> AE (CreatedConnLink 'CMContact, PreparedLinkParams)
prepareConnectionLink :: AgentClient
-> UserId
-> KeyPairEd25519
-> ConnId
-> Bool
-> Maybe Text
-> AE (CreatedConnLink 'CMContact, PreparedLinkParams)
prepareConnectionLink AgentClient
c UserId
userId KeyPairEd25519
rootKey ConnId
linkEntityId Bool
checkNotices = AgentClient
-> AM (CreatedConnLink 'CMContact, PreparedLinkParams)
-> AE (CreatedConnLink 'CMContact, PreparedLinkParams)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (CreatedConnLink 'CMContact, PreparedLinkParams)
 -> AE (CreatedConnLink 'CMContact, PreparedLinkParams))
-> (Maybe Text
    -> AM (CreatedConnLink 'CMContact, PreparedLinkParams))
-> Maybe Text
-> AE (CreatedConnLink 'CMContact, PreparedLinkParams)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> UserId
-> KeyPairEd25519
-> ConnId
-> Bool
-> Maybe Text
-> AM (CreatedConnLink 'CMContact, PreparedLinkParams)
prepareConnectionLink' AgentClient
c UserId
userId KeyPairEd25519
rootKey ConnId
linkEntityId Bool
checkNotices
{-# INLINE prepareConnectionLink #-}

-- | Create connection for prepared link (single network call).
-- Validates that server response matches the prepared link.
createConnectionForLink :: AgentClient -> NetworkRequestMode -> UserId -> Bool -> CreatedConnLink 'CMContact -> PreparedLinkParams -> UserConnLinkData 'CMContact -> CR.InitialKeys -> SubscriptionMode -> AE ConnId
createConnectionForLink :: AgentClient
-> NetworkRequestMode
-> UserId
-> Bool
-> CreatedConnLink 'CMContact
-> PreparedLinkParams
-> UserConnLinkData 'CMContact
-> InitialKeys
-> SubscriptionMode
-> AE ConnId
createConnectionForLink AgentClient
c NetworkRequestMode
nm UserId
userId Bool
enableNtfs = AgentClient -> AM ConnId -> AE ConnId
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnId -> AE ConnId)
-> (CreatedConnLink 'CMContact
    -> PreparedLinkParams
    -> UserConnLinkData 'CMContact
    -> InitialKeys
    -> SubscriptionMode
    -> AM ConnId)
-> CreatedConnLink 'CMContact
-> PreparedLinkParams
-> UserConnLinkData 'CMContact
-> InitialKeys
-> SubscriptionMode
-> AE ConnId
forall {d} {e} {a1} {a2} {a3} {b} {c}.
(d -> e)
-> (a1 -> a2 -> a3 -> b -> c -> d) -> a1 -> a2 -> a3 -> b -> c -> e
.::. AgentClient
-> NetworkRequestMode
-> UserId
-> Bool
-> CreatedConnLink 'CMContact
-> PreparedLinkParams
-> UserConnLinkData 'CMContact
-> InitialKeys
-> SubscriptionMode
-> AM ConnId
createConnectionForLink' AgentClient
c NetworkRequestMode
nm UserId
userId Bool
enableNtfs
{-# INLINE createConnectionForLink #-}

-- | Create or update user's contact connection short link
setConnShortLink :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> UserConnLinkData c -> Maybe CRClientData -> AE (ConnShortLink c)
setConnShortLink :: forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> ConnId
-> SConnectionMode c
-> UserConnLinkData c
-> Maybe Text
-> AE (ConnShortLink c)
setConnShortLink AgentClient
c = AgentClient -> AM (ConnShortLink c) -> AE (ConnShortLink c)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (ConnShortLink c) -> AE (ConnShortLink c))
-> (NetworkRequestMode
    -> ConnId
    -> SConnectionMode c
    -> UserConnLinkData c
    -> Maybe Text
    -> AM (ConnShortLink c))
-> NetworkRequestMode
-> ConnId
-> SConnectionMode c
-> UserConnLinkData c
-> Maybe Text
-> AE (ConnShortLink c)
forall {d} {e} {a1} {a2} {a3} {b} {c}.
(d -> e)
-> (a1 -> a2 -> a3 -> b -> c -> d) -> a1 -> a2 -> a3 -> b -> c -> e
.::. AgentClient
-> NetworkRequestMode
-> ConnId
-> SConnectionMode c
-> UserConnLinkData c
-> Maybe Text
-> AM (ConnShortLink c)
forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> ConnId
-> SConnectionMode c
-> UserConnLinkData c
-> Maybe Text
-> AM (ConnShortLink c)
setConnShortLink' AgentClient
c
{-# INLINE setConnShortLink #-}

deleteConnShortLink :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> AE ()
deleteConnShortLink :: forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode -> ConnId -> SConnectionMode c -> AE ()
deleteConnShortLink AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (NetworkRequestMode
    -> ConnId
    -> SConnectionMode c
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> NetworkRequestMode
-> ConnId
-> SConnectionMode c
-> AE ()
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. AgentClient
-> NetworkRequestMode
-> ConnId
-> SConnectionMode c
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> ConnId
-> SConnectionMode c
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnShortLink' AgentClient
c
{-# INLINE deleteConnShortLink #-}

-- | Get and verify data from short link. For 1-time invitations it preserves the key to allow retries
getConnShortLink :: AgentClient -> NetworkRequestMode -> UserId -> ConnShortLink c -> AE (FixedLinkData c, ConnLinkData c)
getConnShortLink :: forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnShortLink c
-> AE (FixedLinkData c, ConnLinkData c)
getConnShortLink AgentClient
c = AgentClient
-> AM (FixedLinkData c, ConnLinkData c)
-> AE (FixedLinkData c, ConnLinkData c)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (FixedLinkData c, ConnLinkData c)
 -> AE (FixedLinkData c, ConnLinkData c))
-> (NetworkRequestMode
    -> UserId
    -> ConnShortLink c
    -> AM (FixedLinkData c, ConnLinkData c))
-> NetworkRequestMode
-> UserId
-> ConnShortLink c
-> AE (FixedLinkData c, ConnLinkData c)
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. AgentClient
-> NetworkRequestMode
-> UserId
-> ConnShortLink c
-> AM (FixedLinkData c, ConnLinkData c)
forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnShortLink c
-> AM (FixedLinkData c, ConnLinkData c)
getConnShortLink' AgentClient
c
{-# INLINE getConnShortLink #-}

getConnLinkPrivKey :: AgentClient -> ConnId -> AE (Maybe C.PrivateKeyEd25519)
getConnLinkPrivKey :: AgentClient -> ConnId -> AE (Maybe PrivateKeyEd25519)
getConnLinkPrivKey AgentClient
c = AgentClient
-> AM (Maybe PrivateKeyEd25519) -> AE (Maybe PrivateKeyEd25519)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (Maybe PrivateKeyEd25519) -> AE (Maybe PrivateKeyEd25519))
-> (ConnId -> AM (Maybe PrivateKeyEd25519))
-> ConnId
-> AE (Maybe PrivateKeyEd25519)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ConnId -> AM (Maybe PrivateKeyEd25519)
getConnLinkPrivKey' AgentClient
c
{-# INLINE getConnLinkPrivKey #-}

-- | This irreversibly deletes short link data, and it won't be retrievable again
deleteLocalInvShortLink :: AgentClient -> ConnShortLink 'CMInvitation -> AE ()
deleteLocalInvShortLink :: AgentClient -> ConnShortLink 'CMInvitation -> AE ()
deleteLocalInvShortLink AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (ConnShortLink 'CMInvitation
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnShortLink 'CMInvitation
-> AE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> ConnShortLink 'CMInvitation
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteLocalInvShortLink' AgentClient
c
{-# INLINE deleteLocalInvShortLink #-}

-- | Changes the user id associated with a connection
changeConnectionUser :: AgentClient -> UserId -> ConnId -> UserId -> AE ()
changeConnectionUser :: AgentClient -> UserId -> ConnId -> UserId -> AE ()
changeConnectionUser AgentClient
c UserId
oldUserId ConnId
connId UserId
newUserId = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> UserId
-> ConnId
-> UserId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
changeConnectionUser' AgentClient
c UserId
oldUserId ConnId
connId UserId
newUserId
{-# INLINE changeConnectionUser #-}

-- | Create SMP agent connection without queue (to be joined with joinConnection passing connection ID).
-- This method is required to prevent race condition when confirmation from peer is received before
-- the caller of joinConnection saves connection ID to the database.
-- Instead of it we could send confirmation asynchronously, but then it would be harder to report
-- "link deleted" (SMP AUTH) interactively, so this approach is simpler overall.
prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE ConnId
prepareConnectionToJoin :: forall (c :: ConnectionMode).
AgentClient
-> UserId
-> Bool
-> ConnectionRequestUri c
-> PQSupport
-> AE ConnId
prepareConnectionToJoin AgentClient
c UserId
userId Bool
enableNtfs = AgentClient -> AM ConnId -> AE ConnId
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnId -> AE ConnId)
-> (ConnectionRequestUri c -> PQSupport -> AM ConnId)
-> ConnectionRequestUri c
-> PQSupport
-> AE ConnId
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> PQSupport
-> AM ConnId
forall (c :: ConnectionMode).
AgentClient
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> PQSupport
-> AM ConnId
newConnToJoin AgentClient
c UserId
userId ConnId
"" Bool
enableNtfs
{-# INLINE prepareConnectionToJoin #-}

-- | Create SMP agent connection without queue (to be joined with acceptContact passing invitation ID).
prepareConnectionToAccept :: AgentClient -> UserId -> Bool -> ConfirmationId -> PQSupport -> AE ConnId
prepareConnectionToAccept :: AgentClient -> UserId -> Bool -> ConnId -> PQSupport -> AE ConnId
prepareConnectionToAccept AgentClient
c UserId
userId Bool
enableNtfs = AgentClient -> AM ConnId -> AE ConnId
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnId -> AE ConnId)
-> (ConnId -> PQSupport -> AM ConnId)
-> ConnId
-> PQSupport
-> AE ConnId
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> UserId -> ConnId -> Bool -> ConnId -> PQSupport -> AM ConnId
newConnToAccept AgentClient
c UserId
userId ConnId
"" Bool
enableNtfs
{-# INLINE prepareConnectionToAccept #-}

-- | Join SMP agent connection (JOIN command).
joinConnection :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId)
joinConnection :: forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AE (Bool, Maybe ClientServiceId)
joinConnection AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId Bool
enableNtfs = AgentClient
-> AM (Bool, Maybe ClientServiceId)
-> AE (Bool, Maybe ClientServiceId)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (Bool, Maybe ClientServiceId)
 -> AE (Bool, Maybe ClientServiceId))
-> (ConnectionRequestUri c
    -> ConnId
    -> PQSupport
    -> SubscriptionMode
    -> AM (Bool, Maybe ClientServiceId))
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AE (Bool, Maybe ClientServiceId)
forall {d} {e} {a1} {a2} {b} {c}.
(d -> e) -> (a1 -> a2 -> b -> c -> d) -> a1 -> a2 -> b -> c -> e
.:: AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM (Bool, Maybe ClientServiceId)
forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM (Bool, Maybe ClientServiceId)
joinConn AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId Bool
enableNtfs
{-# INLINE joinConnection #-}

-- | Allow connection to continue after CONF notification (LET command)
allowConnection :: AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> AE ()
allowConnection :: AgentClient -> ConnId -> ConnId -> ConnId -> AE ()
allowConnection AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (ConnId
    -> ConnId -> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId
-> ConnId
-> ConnId
-> AE ()
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. AgentClient
-> ConnId
-> ConnId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
allowConnection' AgentClient
c
{-# INLINE allowConnection #-}

-- | Accept contact after REQ notification (ACPT command)
acceptContact :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId)
acceptContact :: AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnId
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AE (Bool, Maybe ClientServiceId)
acceptContact AgentClient
c NetworkRequestMode
userId UserId
connId ConnId
enableNtfs = AgentClient
-> AM (Bool, Maybe ClientServiceId)
-> AE (Bool, Maybe ClientServiceId)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (Bool, Maybe ClientServiceId)
 -> AE (Bool, Maybe ClientServiceId))
-> (Bool
    -> ConnId
    -> ConnId
    -> PQSupport
    -> SubscriptionMode
    -> AM (Bool, Maybe ClientServiceId))
-> Bool
-> ConnId
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AE (Bool, Maybe ClientServiceId)
forall {d} {e} {a1} {a2} {a3} {b} {c}.
(d -> e)
-> (a1 -> a2 -> a3 -> b -> c -> d) -> a1 -> a2 -> a3 -> b -> c -> e
.::. AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnId
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM (Bool, Maybe ClientServiceId)
acceptContact' AgentClient
c NetworkRequestMode
userId UserId
connId ConnId
enableNtfs
{-# INLINE acceptContact #-}

-- | Reject contact (RJCT command)
rejectContact :: AgentClient -> ConfirmationId -> AE ()
rejectContact :: AgentClient -> ConnId -> AE ()
rejectContact AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId
-> AE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
rejectContact' AgentClient
c
{-# INLINE rejectContact #-}

data DatabaseDiff a = DatabaseDiff
  { forall a. DatabaseDiff a -> [a]
missingIds :: [a],
    forall a. DatabaseDiff a -> [a]
extraIds :: [a]
  }
  deriving (Int -> DatabaseDiff a -> ShowS
[DatabaseDiff a] -> ShowS
DatabaseDiff a -> String
(Int -> DatabaseDiff a -> ShowS)
-> (DatabaseDiff a -> String)
-> ([DatabaseDiff a] -> ShowS)
-> Show (DatabaseDiff a)
forall a. Show a => Int -> DatabaseDiff a -> ShowS
forall a. Show a => [DatabaseDiff a] -> ShowS
forall a. Show a => DatabaseDiff a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> DatabaseDiff a -> ShowS
showsPrec :: Int -> DatabaseDiff a -> ShowS
$cshow :: forall a. Show a => DatabaseDiff a -> String
show :: DatabaseDiff a -> String
$cshowList :: forall a. Show a => [DatabaseDiff a] -> ShowS
showList :: [DatabaseDiff a] -> ShowS
Show)

instance Functor DatabaseDiff where
  fmap :: forall a b. (a -> b) -> DatabaseDiff a -> DatabaseDiff b
fmap a -> b
f DatabaseDiff {[a]
$sel:missingIds:DatabaseDiff :: forall a. DatabaseDiff a -> [a]
missingIds :: [a]
missingIds, [a]
$sel:extraIds:DatabaseDiff :: forall a. DatabaseDiff a -> [a]
extraIds :: [a]
extraIds} =
    DatabaseDiff {$sel:missingIds:DatabaseDiff :: [b]
missingIds = (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
missingIds, $sel:extraIds:DatabaseDiff :: [b]
extraIds = (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
extraIds}

compareConnections :: AgentClient -> [UserId] -> [ConnId] -> AE (DatabaseDiff UserId, DatabaseDiff ConnId)
compareConnections :: AgentClient
-> [UserId]
-> [ConnId]
-> AE (DatabaseDiff UserId, DatabaseDiff ConnId)
compareConnections AgentClient
c = AgentClient
-> AM (DatabaseDiff UserId, DatabaseDiff ConnId)
-> AE (DatabaseDiff UserId, DatabaseDiff ConnId)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (DatabaseDiff UserId, DatabaseDiff ConnId)
 -> AE (DatabaseDiff UserId, DatabaseDiff ConnId))
-> ([UserId]
    -> [ConnId] -> AM (DatabaseDiff UserId, DatabaseDiff ConnId))
-> [UserId]
-> [ConnId]
-> AE (DatabaseDiff UserId, DatabaseDiff ConnId)
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> [UserId]
-> [ConnId]
-> AM (DatabaseDiff UserId, DatabaseDiff ConnId)
compareConnections' AgentClient
c
{-# INLINE compareConnections #-}

syncConnections :: AgentClient -> [UserId] -> [ConnId] -> AE (DatabaseDiff UserId, DatabaseDiff ConnId)
syncConnections :: AgentClient
-> [UserId]
-> [ConnId]
-> AE (DatabaseDiff UserId, DatabaseDiff ConnId)
syncConnections AgentClient
c = AgentClient
-> AM (DatabaseDiff UserId, DatabaseDiff ConnId)
-> AE (DatabaseDiff UserId, DatabaseDiff ConnId)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (DatabaseDiff UserId, DatabaseDiff ConnId)
 -> AE (DatabaseDiff UserId, DatabaseDiff ConnId))
-> ([UserId]
    -> [ConnId] -> AM (DatabaseDiff UserId, DatabaseDiff ConnId))
-> [UserId]
-> [ConnId]
-> AE (DatabaseDiff UserId, DatabaseDiff ConnId)
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> [UserId]
-> [ConnId]
-> AM (DatabaseDiff UserId, DatabaseDiff ConnId)
syncConnections' AgentClient
c
{-# INLINE syncConnections #-}

-- | Subscribe to receive connection messages (SUB command)
subscribeConnection :: AgentClient -> ConnId -> AE (Maybe ClientServiceId)
subscribeConnection :: AgentClient -> ConnId -> AE (Maybe ClientServiceId)
subscribeConnection AgentClient
c = AgentClient
-> AM (Maybe ClientServiceId) -> AE (Maybe ClientServiceId)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (Maybe ClientServiceId) -> AE (Maybe ClientServiceId))
-> (ConnId -> AM (Maybe ClientServiceId))
-> ConnId
-> AE (Maybe ClientServiceId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ConnId -> AM (Maybe ClientServiceId)
subscribeConnection' AgentClient
c
{-# INLINE subscribeConnection #-}

-- | Subscribe to receive connection messages from multiple connections, batching commands when possible
subscribeConnections :: AgentClient -> [ConnId] -> AE (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
subscribeConnections :: AgentClient
-> [ConnId]
-> AE (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
subscribeConnections AgentClient
c = AgentClient
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
-> AE (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
 -> AE (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))))
-> ([ConnId]
    -> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))))
-> [ConnId]
-> AE (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
subscribeConnections' AgentClient
c
{-# INLINE subscribeConnections #-}

-- | Subscribe to all connections
subscribeAllConnections :: AgentClient -> Bool -> Maybe UserId -> AE ()
subscribeAllConnections :: AgentClient -> Bool -> Maybe UserId -> AE ()
subscribeAllConnections AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (Bool
    -> Maybe UserId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Bool
-> Maybe UserId
-> AE ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> Bool
-> Maybe UserId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
subscribeAllConnections' AgentClient
c

-- | Get messages for connections (GET commands)
getConnectionMessages :: AgentClient -> NonEmpty ConnMsgReq -> IO (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
getConnectionMessages :: AgentClient
-> NonEmpty ConnMsgReq
-> IO (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
getConnectionMessages AgentClient
c = AgentClient
-> AM' (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
-> IO (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
forall a. AgentClient -> AM' a -> IO a
withAgentEnv' AgentClient
c (AM' (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
 -> IO (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta))))
-> (NonEmpty ConnMsgReq
    -> AM' (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta))))
-> NonEmpty ConnMsgReq
-> IO (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> NonEmpty ConnMsgReq
-> AM' (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
getConnectionMessages' AgentClient
c
{-# INLINE getConnectionMessages #-}

-- | Get connections for received notification
getNotificationConns :: AgentClient -> C.CbNonce -> ByteString -> AE (NonEmpty NotificationInfo)
getNotificationConns :: AgentClient -> CbNonce -> ConnId -> AE (NonEmpty NotificationInfo)
getNotificationConns AgentClient
c = AgentClient
-> AM (NonEmpty NotificationInfo) -> AE (NonEmpty NotificationInfo)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (NonEmpty NotificationInfo) -> AE (NonEmpty NotificationInfo))
-> (CbNonce -> ConnId -> AM (NonEmpty NotificationInfo))
-> CbNonce
-> ConnId
-> AE (NonEmpty NotificationInfo)
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient -> CbNonce -> ConnId -> AM (NonEmpty NotificationInfo)
getNotificationConns' AgentClient
c
{-# INLINE getNotificationConns #-}

resubscribeConnection :: AgentClient -> ConnId -> AE (Maybe ClientServiceId)
resubscribeConnection :: AgentClient -> ConnId -> AE (Maybe ClientServiceId)
resubscribeConnection AgentClient
c = AgentClient
-> AM (Maybe ClientServiceId) -> AE (Maybe ClientServiceId)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (Maybe ClientServiceId) -> AE (Maybe ClientServiceId))
-> (ConnId -> AM (Maybe ClientServiceId))
-> ConnId
-> AE (Maybe ClientServiceId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ConnId -> AM (Maybe ClientServiceId)
resubscribeConnection' AgentClient
c
{-# INLINE resubscribeConnection #-}

resubscribeConnections :: AgentClient -> [ConnId] -> AE (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
resubscribeConnections :: AgentClient
-> [ConnId]
-> AE (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
resubscribeConnections AgentClient
c = AgentClient
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
-> AE (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
 -> AE (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))))
-> ([ConnId]
    -> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))))
-> [ConnId]
-> AE (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
resubscribeConnections' AgentClient
c
{-# INLINE resubscribeConnections #-}

-- TODO [certs rcv] how to communicate that service ID changed - as error or as result?
subscribeClientService :: AgentClient -> ClientServiceId -> AE Int
subscribeClientService :: AgentClient -> ClientServiceId -> AE Int
subscribeClientService AgentClient
c = AgentClient -> AM Int -> AE Int
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM Int -> AE Int)
-> (ClientServiceId -> AM Int) -> ClientServiceId -> AE Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ClientServiceId -> AM Int
subscribeClientService' AgentClient
c
{-# INLINE subscribeClientService #-}

-- | Send message to the connection (SEND command)
sendMessage :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> AE (AgentMsgId, PQEncryption)
sendMessage :: AgentClient
-> ConnId
-> PQEncryption
-> MsgFlags
-> ConnId
-> AE (UserId, PQEncryption)
sendMessage AgentClient
c = AgentClient
-> AM (UserId, PQEncryption) -> AE (UserId, PQEncryption)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (UserId, PQEncryption) -> AE (UserId, PQEncryption))
-> (ConnId
    -> PQEncryption -> MsgFlags -> ConnId -> AM (UserId, PQEncryption))
-> ConnId
-> PQEncryption
-> MsgFlags
-> ConnId
-> AE (UserId, PQEncryption)
forall {d} {e} {a1} {a2} {b} {c}.
(d -> e) -> (a1 -> a2 -> b -> c -> d) -> a1 -> a2 -> b -> c -> e
.:: AgentClient
-> ConnId
-> PQEncryption
-> MsgFlags
-> ConnId
-> AM (UserId, PQEncryption)
sendMessage' AgentClient
c
{-# INLINE sendMessage #-}

data ValueOrRef a = VRValue (Maybe Int) a | VRRef Int

instance Functor ValueOrRef where
  fmap :: forall a b. (a -> b) -> ValueOrRef a -> ValueOrRef b
fmap a -> b
f = \case
    VRValue Maybe Int
i_ a
a -> Maybe Int -> b -> ValueOrRef b
forall a. Maybe Int -> a -> ValueOrRef a
VRValue Maybe Int
i_ (a -> b
f a
a)
    VRRef Int
i -> Int -> ValueOrRef b
forall a. Int -> ValueOrRef a
VRRef Int
i

vrValue :: a -> ValueOrRef a
vrValue :: forall a. a -> ValueOrRef a
vrValue = Maybe Int -> a -> ValueOrRef a
forall a. Maybe Int -> a -> ValueOrRef a
VRValue Maybe Int
forall a. Maybe a
Nothing

-- When sending multiple messages to the same connection,
-- only the first MsgReq for this connection should have non-empty ConnId.
-- All subsequent MsgReq in traversable for this connection must be empty.
-- This is done to optimize processing by grouping all messages to one connection together.
-- Also, repeated msg bodies should us MBRef constructor to reference previously used body.
-- It is an error:
-- - to use MBBody with the same Int
-- - to use MBRef with Int that wasn't previously used in MBBody
type MsgReq = (ConnId, PQEncryption, MsgFlags, ValueOrRef MsgBody)

-- | Send multiple messages to different connections (SEND command)
sendMessages :: AgentClient -> [MsgReq] -> AE [Either AgentErrorType (AgentMsgId, PQEncryption)]
sendMessages :: AgentClient
-> [MsgReq] -> AE [Either AgentErrorType (UserId, PQEncryption)]
sendMessages AgentClient
c = AgentClient
-> AM [Either AgentErrorType (UserId, PQEncryption)]
-> AE [Either AgentErrorType (UserId, PQEncryption)]
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM [Either AgentErrorType (UserId, PQEncryption)]
 -> AE [Either AgentErrorType (UserId, PQEncryption)])
-> ([MsgReq] -> AM [Either AgentErrorType (UserId, PQEncryption)])
-> [MsgReq]
-> AE [Either AgentErrorType (UserId, PQEncryption)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> [MsgReq] -> AM [Either AgentErrorType (UserId, PQEncryption)]
sendMessages' AgentClient
c
{-# INLINE sendMessages #-}

sendMessagesB :: Traversable t => AgentClient -> t (Either AgentErrorType MsgReq) -> AE (t (Either AgentErrorType (AgentMsgId, PQEncryption)))
sendMessagesB :: forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either AgentErrorType MsgReq)
-> AE (t (Either AgentErrorType (UserId, PQEncryption)))
sendMessagesB AgentClient
c = AgentClient
-> AM (t (Either AgentErrorType (UserId, PQEncryption)))
-> AE (t (Either AgentErrorType (UserId, PQEncryption)))
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (t (Either AgentErrorType (UserId, PQEncryption)))
 -> AE (t (Either AgentErrorType (UserId, PQEncryption))))
-> (t (Either AgentErrorType MsgReq)
    -> AM (t (Either AgentErrorType (UserId, PQEncryption))))
-> t (Either AgentErrorType MsgReq)
-> AE (t (Either AgentErrorType (UserId, PQEncryption)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> t (Either AgentErrorType MsgReq)
-> AM (t (Either AgentErrorType (UserId, PQEncryption)))
forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either AgentErrorType MsgReq)
-> AM (t (Either AgentErrorType (UserId, PQEncryption)))
sendMessagesB' AgentClient
c
{-# INLINE sendMessagesB #-}

ackMessage :: AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AE ()
ackMessage :: AgentClient -> ConnId -> UserId -> Maybe ConnId -> AE ()
ackMessage AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (ConnId
    -> UserId
    -> Maybe ConnId
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId
-> UserId
-> Maybe ConnId
-> AE ()
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. AgentClient
-> ConnId
-> UserId
-> Maybe ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
ackMessage' AgentClient
c
{-# INLINE ackMessage #-}

getConnectionQueueInfo :: AgentClient -> NetworkRequestMode -> ConnId -> AE ServerQueueInfo
getConnectionQueueInfo :: AgentClient -> NetworkRequestMode -> ConnId -> AE ServerQueueInfo
getConnectionQueueInfo AgentClient
c = AgentClient -> AM ServerQueueInfo -> AE ServerQueueInfo
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ServerQueueInfo -> AE ServerQueueInfo)
-> (NetworkRequestMode -> ConnId -> AM ServerQueueInfo)
-> NetworkRequestMode
-> ConnId
-> AE ServerQueueInfo
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient -> NetworkRequestMode -> ConnId -> AM ServerQueueInfo
getConnectionQueueInfo' AgentClient
c
{-# INLINE getConnectionQueueInfo #-}

-- | Switch connection to the new receive queue
switchConnection :: AgentClient -> NetworkRequestMode -> ConnId -> AE ConnectionStats
switchConnection :: AgentClient -> NetworkRequestMode -> ConnId -> AE ConnectionStats
switchConnection AgentClient
c = AgentClient -> AM ConnectionStats -> AE ConnectionStats
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnectionStats -> AE ConnectionStats)
-> (NetworkRequestMode -> ConnId -> AM ConnectionStats)
-> NetworkRequestMode
-> ConnId
-> AE ConnectionStats
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient -> NetworkRequestMode -> ConnId -> AM ConnectionStats
switchConnection' AgentClient
c
{-# INLINE switchConnection #-}

-- | Abort switching connection to the new receive queue
abortConnectionSwitch :: AgentClient -> ConnId -> AE ConnectionStats
abortConnectionSwitch :: AgentClient -> ConnId -> AE ConnectionStats
abortConnectionSwitch AgentClient
c = AgentClient -> AM ConnectionStats -> AE ConnectionStats
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnectionStats -> AE ConnectionStats)
-> (ConnId -> AM ConnectionStats) -> ConnId -> AE ConnectionStats
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ConnId -> AM ConnectionStats
abortConnectionSwitch' AgentClient
c
{-# INLINE abortConnectionSwitch #-}

-- | Re-synchronize connection ratchet keys
synchronizeRatchet :: AgentClient -> ConnId -> PQSupport -> Bool -> AE ConnectionStats
synchronizeRatchet :: AgentClient -> ConnId -> PQSupport -> Bool -> AE ConnectionStats
synchronizeRatchet AgentClient
c = AgentClient -> AM ConnectionStats -> AE ConnectionStats
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnectionStats -> AE ConnectionStats)
-> (ConnId -> PQSupport -> Bool -> AM ConnectionStats)
-> ConnId
-> PQSupport
-> Bool
-> AE ConnectionStats
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. AgentClient -> ConnId -> PQSupport -> Bool -> AM ConnectionStats
synchronizeRatchet' AgentClient
c
{-# INLINE synchronizeRatchet #-}

-- | Suspend SMP agent connection (OFF command)
suspendConnection :: AgentClient -> NetworkRequestMode -> ConnId -> AE ()
suspendConnection :: AgentClient -> NetworkRequestMode -> ConnId -> AE ()
suspendConnection AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (NetworkRequestMode
    -> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> NetworkRequestMode
-> ConnId
-> AE ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> NetworkRequestMode
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
suspendConnection' AgentClient
c
{-# INLINE suspendConnection #-}

-- | Delete SMP agent connection (DEL command)
deleteConnection :: AgentClient -> NetworkRequestMode -> ConnId -> AE ()
deleteConnection :: AgentClient -> NetworkRequestMode -> ConnId -> AE ()
deleteConnection AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (NetworkRequestMode
    -> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> NetworkRequestMode
-> ConnId
-> AE ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> NetworkRequestMode
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnection' AgentClient
c
{-# INLINE deleteConnection #-}

-- | Delete multiple connections, batching commands when possible
deleteConnections :: AgentClient -> NetworkRequestMode -> [ConnId] -> AE (Map ConnId (Either AgentErrorType ()))
deleteConnections :: AgentClient
-> NetworkRequestMode
-> [ConnId]
-> AE (Map ConnId (Either AgentErrorType ()))
deleteConnections AgentClient
c = AgentClient
-> AM (Map ConnId (Either AgentErrorType ()))
-> AE (Map ConnId (Either AgentErrorType ()))
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (Map ConnId (Either AgentErrorType ()))
 -> AE (Map ConnId (Either AgentErrorType ())))
-> (NetworkRequestMode
    -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ())))
-> NetworkRequestMode
-> [ConnId]
-> AE (Map ConnId (Either AgentErrorType ()))
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> NetworkRequestMode
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType ()))
deleteConnections' AgentClient
c
{-# INLINE deleteConnections #-}

-- | get servers used for connection
getConnectionServers :: AgentClient -> ConnId -> AE ConnectionStats
getConnectionServers :: AgentClient -> ConnId -> AE ConnectionStats
getConnectionServers AgentClient
c = AgentClient -> AM ConnectionStats -> AE ConnectionStats
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnectionStats -> AE ConnectionStats)
-> (ConnId -> AM ConnectionStats) -> ConnId -> AE ConnectionStats
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ConnId -> AM ConnectionStats
getConnectionServers' AgentClient
c
{-# INLINE getConnectionServers #-}

-- | get connection ratchet associated data hash for verification (should match peer AD hash)
getConnectionRatchetAdHash :: AgentClient -> ConnId -> AE ByteString
getConnectionRatchetAdHash :: AgentClient -> ConnId -> AE ConnId
getConnectionRatchetAdHash AgentClient
c = AgentClient -> AM ConnId -> AE ConnId
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnId -> AE ConnId)
-> (ConnId -> AM ConnId) -> ConnId -> AE ConnId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ConnId -> AM ConnId
getConnectionRatchetAdHash' AgentClient
c
{-# INLINE getConnectionRatchetAdHash #-}

-- | Test protocol server
testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Maybe ProtocolTestFailure)
testProtocolServer :: forall (p :: ProtocolType).
ProtocolTypeI p =>
AgentClient
-> NetworkRequestMode
-> UserId
-> ProtoServerWithAuth p
-> IO (Maybe ProtocolTestFailure)
testProtocolServer AgentClient
c NetworkRequestMode
nm UserId
userId ProtoServerWithAuth p
srv = AgentClient
-> AM' (Maybe ProtocolTestFailure)
-> IO (Maybe ProtocolTestFailure)
forall a. AgentClient -> AM' a -> IO a
withAgentEnv' AgentClient
c (AM' (Maybe ProtocolTestFailure) -> IO (Maybe ProtocolTestFailure))
-> AM' (Maybe ProtocolTestFailure)
-> IO (Maybe ProtocolTestFailure)
forall a b. (a -> b) -> a -> b
$ case forall (p :: ProtocolType). ProtocolTypeI p => SProtocolType p
protocolTypeI @p of
  SProtocolType p
SPSMP -> AgentClient
-> NetworkRequestMode
-> UserId
-> SMPServerWithAuth
-> AM' (Maybe ProtocolTestFailure)
runSMPServerTest AgentClient
c NetworkRequestMode
nm UserId
userId ProtoServerWithAuth p
SMPServerWithAuth
srv
  SProtocolType p
SPXFTP -> AgentClient
-> NetworkRequestMode
-> UserId
-> XFTPServerWithAuth
-> AM' (Maybe ProtocolTestFailure)
runXFTPServerTest AgentClient
c NetworkRequestMode
nm UserId
userId ProtoServerWithAuth p
XFTPServerWithAuth
srv
  SProtocolType p
SPNTF -> AgentClient
-> NetworkRequestMode
-> UserId
-> NtfServerWithAuth
-> AM' (Maybe ProtocolTestFailure)
runNTFServerTest AgentClient
c NetworkRequestMode
nm UserId
userId ProtoServerWithAuth p
NtfServerWithAuth
srv

-- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network
setNetworkConfig :: AgentClient -> NetworkConfig -> IO ()
setNetworkConfig :: AgentClient -> NetworkConfig -> IO ()
setNetworkConfig c :: AgentClient
c@AgentClient {TVar (NetworkConfig, NetworkConfig)
useNetworkConfig :: TVar (NetworkConfig, NetworkConfig)
$sel:useNetworkConfig:AgentClient :: AgentClient -> TVar (NetworkConfig, NetworkConfig)
useNetworkConfig, TVar InternalTs
proxySessTs :: TVar InternalTs
$sel:proxySessTs:AgentClient :: AgentClient -> TVar InternalTs
proxySessTs} NetworkConfig
cfg' = do
  InternalTs
ts <- IO InternalTs
getCurrentTime
  Bool
changed <- 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
$ do
    (NetworkConfig
_, NetworkConfig
cfg) <- TVar (NetworkConfig, NetworkConfig)
-> STM (NetworkConfig, NetworkConfig)
forall a. TVar a -> STM a
readTVar TVar (NetworkConfig, NetworkConfig)
useNetworkConfig
    let changed :: Bool
changed = NetworkConfig
cfg NetworkConfig -> NetworkConfig -> Bool
forall a. Eq a => a -> a -> Bool
/= NetworkConfig
cfg'
        !cfgSlow :: NetworkConfig
cfgSlow = NetworkConfig -> NetworkConfig
slowNetworkConfig NetworkConfig
cfg'
    Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TVar (NetworkConfig, NetworkConfig)
-> (NetworkConfig, NetworkConfig) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (NetworkConfig, NetworkConfig)
useNetworkConfig (NetworkConfig
cfgSlow, NetworkConfig
cfg')
    Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NetworkConfig -> Maybe SocksProxyWithAuth
socksProxy NetworkConfig
cfg Maybe SocksProxyWithAuth -> Maybe SocksProxyWithAuth -> Bool
forall a. Eq a => a -> a -> Bool
/= NetworkConfig -> Maybe SocksProxyWithAuth
socksProxy NetworkConfig
cfg') (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TVar InternalTs -> InternalTs -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar InternalTs
proxySessTs InternalTs
ts
    Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
changed
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> IO ()
reconnectAllServers AgentClient
c

setUserNetworkInfo :: AgentClient -> UserNetworkInfo -> IO ()
setUserNetworkInfo :: AgentClient -> UserNetworkInfo -> IO ()
setUserNetworkInfo c :: AgentClient
c@AgentClient {TVar UserNetworkInfo
userNetworkInfo :: TVar UserNetworkInfo
$sel:userNetworkInfo:AgentClient :: AgentClient -> TVar UserNetworkInfo
userNetworkInfo, TVar (Maybe InternalTs)
userNetworkUpdated :: TVar (Maybe InternalTs)
$sel:userNetworkUpdated:AgentClient :: AgentClient -> TVar (Maybe InternalTs)
userNetworkUpdated} UserNetworkInfo
ni = AgentClient -> ReaderT Env IO () -> IO ()
forall a. AgentClient -> AM' a -> IO a
withAgentEnv' AgentClient
c (ReaderT Env IO () -> IO ()) -> ReaderT Env IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  InternalTs
ts' <- IO InternalTs -> ReaderT Env IO InternalTs
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO InternalTs
getCurrentTime
  NominalDiffTime
i <- (Env -> NominalDiffTime) -> ReaderT Env IO NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> NominalDiffTime) -> ReaderT Env IO NominalDiffTime)
-> (Env -> NominalDiffTime) -> ReaderT Env IO NominalDiffTime
forall a b. (a -> b) -> a -> b
$ AgentConfig -> NominalDiffTime
userOfflineDelay (AgentConfig -> NominalDiffTime)
-> (Env -> AgentConfig) -> Env -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  -- if network offline event happens in less than `userOfflineDelay` after the previous event, it is ignored
  STM () -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Env IO ())
-> (STM () -> STM ()) -> STM () -> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((UserNetworkInfo -> Bool
isOnline UserNetworkInfo
ni Bool -> Bool -> Bool
||) (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InternalTs -> NominalDiffTime -> STM Bool
notRecentlyChanged InternalTs
ts' NominalDiffTime
i) (STM () -> ReaderT Env IO ()) -> STM () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ do
    TVar UserNetworkInfo -> UserNetworkInfo -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar UserNetworkInfo
userNetworkInfo UserNetworkInfo
ni
    TVar (Maybe InternalTs) -> Maybe InternalTs -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe InternalTs)
userNetworkUpdated (Maybe InternalTs -> STM ()) -> Maybe InternalTs -> STM ()
forall a b. (a -> b) -> a -> b
$ InternalTs -> Maybe InternalTs
forall a. a -> Maybe a
Just InternalTs
ts'
  where
    notRecentlyChanged :: InternalTs -> NominalDiffTime -> STM Bool
notRecentlyChanged InternalTs
ts' NominalDiffTime
i =
      Bool -> (InternalTs -> Bool) -> Maybe InternalTs -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\InternalTs
ts -> InternalTs -> InternalTs -> NominalDiffTime
diffUTCTime InternalTs
ts' InternalTs
ts NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
i) (Maybe InternalTs -> Bool) -> STM (Maybe InternalTs) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe InternalTs) -> STM (Maybe InternalTs)
forall a. TVar a -> STM a
readTVar TVar (Maybe InternalTs)
userNetworkUpdated

reconnectAllServers :: AgentClient -> IO ()
reconnectAllServers :: AgentClient -> IO ()
reconnectAllServers AgentClient
c = do
  AgentClient
-> (AgentClient
    -> TMap (TransportSession BrokerMsg) (ClientVar BrokerMsg))
-> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> (AgentClient -> TMap (TransportSession msg) (ClientVar msg))
-> IO ()
reconnectServerClients AgentClient
c AgentClient
-> TMap (TransportSession BrokerMsg) (ClientVar BrokerMsg)
smpClients
  AgentClient
-> (AgentClient
    -> TMap (TransportSession FileResponse) (ClientVar FileResponse))
-> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> (AgentClient -> TMap (TransportSession msg) (ClientVar msg))
-> IO ()
reconnectServerClients AgentClient
c AgentClient
-> TMap (TransportSession FileResponse) (ClientVar FileResponse)
xftpClients
  AgentClient
-> (AgentClient
    -> TMap (TransportSession NtfResponse) (ClientVar NtfResponse))
-> IO ()
forall v err msg.
ProtocolServerClient v err msg =>
AgentClient
-> (AgentClient -> TMap (TransportSession msg) (ClientVar msg))
-> IO ()
reconnectServerClients AgentClient
c AgentClient
-> TMap (TransportSession NtfResponse) (ClientVar NtfResponse)
ntfClients

-- | Register device notifications token
registerNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> NotificationsMode -> AE NtfTknStatus
registerNtfToken :: AgentClient
-> NetworkRequestMode
-> DeviceToken
-> NotificationsMode
-> AE NtfTknStatus
registerNtfToken AgentClient
c = AgentClient -> AM NtfTknStatus -> AE NtfTknStatus
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM NtfTknStatus -> AE NtfTknStatus)
-> (NetworkRequestMode
    -> DeviceToken -> NotificationsMode -> AM NtfTknStatus)
-> NetworkRequestMode
-> DeviceToken
-> NotificationsMode
-> AE NtfTknStatus
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. AgentClient
-> NetworkRequestMode
-> DeviceToken
-> NotificationsMode
-> AM NtfTknStatus
registerNtfToken' AgentClient
c
{-# INLINE registerNtfToken #-}

-- | Verify device notifications token
verifyNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
verifyNtfToken :: AgentClient
-> NetworkRequestMode -> DeviceToken -> CbNonce -> ConnId -> AE ()
verifyNtfToken AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (NetworkRequestMode
    -> DeviceToken
    -> CbNonce
    -> ConnId
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> NetworkRequestMode
-> DeviceToken
-> CbNonce
-> ConnId
-> AE ()
forall {d} {e} {a1} {a2} {b} {c}.
(d -> e) -> (a1 -> a2 -> b -> c -> d) -> a1 -> a2 -> b -> c -> e
.:: AgentClient
-> NetworkRequestMode
-> DeviceToken
-> CbNonce
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
verifyNtfToken' AgentClient
c
{-# INLINE verifyNtfToken #-}

checkNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> AE NtfTknStatus
checkNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> AE NtfTknStatus
checkNtfToken AgentClient
c = AgentClient -> AM NtfTknStatus -> AE NtfTknStatus
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM NtfTknStatus -> AE NtfTknStatus)
-> (NetworkRequestMode -> DeviceToken -> AM NtfTknStatus)
-> NetworkRequestMode
-> DeviceToken
-> AE NtfTknStatus
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient -> NetworkRequestMode -> DeviceToken -> AM NtfTknStatus
checkNtfToken' AgentClient
c
{-# INLINE checkNtfToken #-}

deleteNtfToken :: AgentClient -> DeviceToken -> AE ()
deleteNtfToken :: AgentClient -> DeviceToken -> AE ()
deleteNtfToken AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (DeviceToken -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> DeviceToken
-> AE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> DeviceToken -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteNtfToken' AgentClient
c
{-# INLINE deleteNtfToken #-}

getNtfToken :: AgentClient -> AE (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
getNtfToken :: AgentClient
-> AE (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
getNtfToken AgentClient
c = AgentClient
-> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
-> AE (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
 -> AE (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer))
-> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
-> AE (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
forall a b. (a -> b) -> a -> b
$ AgentClient
-> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
getNtfToken' AgentClient
c
{-# INLINE getNtfToken #-}

getNtfTokenData :: AgentClient -> AE NtfToken
getNtfTokenData :: AgentClient -> AE NtfToken
getNtfTokenData AgentClient
c = AgentClient -> AM NtfToken -> AE NtfToken
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM NtfToken -> AE NtfToken) -> AM NtfToken -> AE NtfToken
forall a b. (a -> b) -> a -> b
$ AgentClient -> AM NtfToken
getNtfTokenData' AgentClient
c
{-# INLINE getNtfTokenData #-}

-- | Set connection notifications on/off
toggleConnectionNtfs :: AgentClient -> ConnId -> Bool -> AE ()
toggleConnectionNtfs :: AgentClient -> ConnId -> Bool -> AE ()
toggleConnectionNtfs AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (ConnId -> Bool -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId
-> Bool
-> AE ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> ConnId -> Bool -> ExceptT AgentErrorType (ReaderT Env IO) ()
toggleConnectionNtfs' AgentClient
c
{-# INLINE toggleConnectionNtfs #-}

xftpStartWorkers :: AgentClient -> Maybe FilePath -> AE ()
xftpStartWorkers :: AgentClient -> Maybe String -> AE ()
xftpStartWorkers AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (Maybe String -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Maybe String
-> AE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> Maybe String -> ExceptT AgentErrorType (ReaderT Env IO) ()
startXFTPWorkers AgentClient
c
{-# INLINE xftpStartWorkers #-}

xftpStartSndWorkers :: AgentClient -> Maybe FilePath -> AE ()
xftpStartSndWorkers :: AgentClient -> Maybe String -> AE ()
xftpStartSndWorkers AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> (Maybe String -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Maybe String
-> AE ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> Maybe String -> ExceptT AgentErrorType (ReaderT Env IO) ()
startXFTPSndWorkers AgentClient
c
{-# INLINE xftpStartSndWorkers #-}

-- | Receive XFTP file
xftpReceiveFile :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AE RcvFileId
xftpReceiveFile :: AgentClient
-> UserId
-> ValidFileDescription 'FRecipient
-> Maybe CryptoFileArgs
-> Bool
-> AE ConnId
xftpReceiveFile AgentClient
c = AgentClient -> AM ConnId -> AE ConnId
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnId -> AE ConnId)
-> (UserId
    -> ValidFileDescription 'FRecipient
    -> Maybe CryptoFileArgs
    -> Bool
    -> AM ConnId)
-> UserId
-> ValidFileDescription 'FRecipient
-> Maybe CryptoFileArgs
-> Bool
-> AE ConnId
forall {d} {e} {a1} {a2} {b} {c}.
(d -> e) -> (a1 -> a2 -> b -> c -> d) -> a1 -> a2 -> b -> c -> e
.:: AgentClient
-> UserId
-> ValidFileDescription 'FRecipient
-> Maybe CryptoFileArgs
-> Bool
-> AM ConnId
xftpReceiveFile' AgentClient
c
{-# INLINE xftpReceiveFile #-}

-- | Delete XFTP rcv file (deletes work files from file system and db records)
xftpDeleteRcvFile :: AgentClient -> RcvFileId -> IO ()
xftpDeleteRcvFile :: AgentClient -> ConnId -> IO ()
xftpDeleteRcvFile AgentClient
c = AgentClient -> ReaderT Env IO () -> IO ()
forall a. AgentClient -> AM' a -> IO a
withAgentEnv' AgentClient
c (ReaderT Env IO () -> IO ())
-> (ConnId -> ReaderT Env IO ()) -> ConnId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ConnId -> ReaderT Env IO ()
xftpDeleteRcvFile' AgentClient
c
{-# INLINE xftpDeleteRcvFile #-}

-- | Delete multiple rcv files, batching operations when possible (deletes work files from file system and db records)
xftpDeleteRcvFiles :: AgentClient -> [RcvFileId] -> IO ()
xftpDeleteRcvFiles :: AgentClient -> [ConnId] -> IO ()
xftpDeleteRcvFiles AgentClient
c = AgentClient -> ReaderT Env IO () -> IO ()
forall a. AgentClient -> AM' a -> IO a
withAgentEnv' AgentClient
c (ReaderT Env IO () -> IO ())
-> ([ConnId] -> ReaderT Env IO ()) -> [ConnId] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> [ConnId] -> ReaderT Env IO ()
xftpDeleteRcvFiles' AgentClient
c
{-# INLINE xftpDeleteRcvFiles #-}

-- | Send XFTP file
xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE SndFileId
xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE ConnId
xftpSendFile AgentClient
c = AgentClient -> AM ConnId -> AE ConnId
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnId -> AE ConnId)
-> (UserId -> CryptoFile -> Int -> AM ConnId)
-> UserId
-> CryptoFile
-> Int
-> AE ConnId
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. AgentClient -> UserId -> CryptoFile -> Int -> AM ConnId
xftpSendFile' AgentClient
c
{-# INLINE xftpSendFile #-}

-- | Send XFTP file
xftpSendDescription :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Int -> AE SndFileId
xftpSendDescription :: AgentClient
-> UserId -> ValidFileDescription 'FRecipient -> Int -> AE ConnId
xftpSendDescription AgentClient
c = AgentClient -> AM ConnId -> AE ConnId
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM ConnId -> AE ConnId)
-> (UserId -> ValidFileDescription 'FRecipient -> Int -> AM ConnId)
-> UserId
-> ValidFileDescription 'FRecipient
-> Int
-> AE ConnId
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. AgentClient
-> UserId -> ValidFileDescription 'FRecipient -> Int -> AM ConnId
xftpSendDescription' AgentClient
c
{-# INLINE xftpSendDescription #-}

-- | Delete XFTP snd file internally (deletes work files from file system and db records)
xftpDeleteSndFileInternal :: AgentClient -> SndFileId -> IO ()
xftpDeleteSndFileInternal :: AgentClient -> ConnId -> IO ()
xftpDeleteSndFileInternal AgentClient
c = AgentClient -> ReaderT Env IO () -> IO ()
forall a. AgentClient -> AM' a -> IO a
withAgentEnv' AgentClient
c (ReaderT Env IO () -> IO ())
-> (ConnId -> ReaderT Env IO ()) -> ConnId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ConnId -> ReaderT Env IO ()
deleteSndFileInternal AgentClient
c
{-# INLINE xftpDeleteSndFileInternal #-}

-- | Delete multiple snd files internally, batching operations when possible (deletes work files from file system and db records)
xftpDeleteSndFilesInternal :: AgentClient -> [SndFileId] -> IO ()
xftpDeleteSndFilesInternal :: AgentClient -> [ConnId] -> IO ()
xftpDeleteSndFilesInternal AgentClient
c = AgentClient -> ReaderT Env IO () -> IO ()
forall a. AgentClient -> AM' a -> IO a
withAgentEnv' AgentClient
c (ReaderT Env IO () -> IO ())
-> ([ConnId] -> ReaderT Env IO ()) -> [ConnId] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> [ConnId] -> ReaderT Env IO ()
deleteSndFilesInternal AgentClient
c
{-# INLINE xftpDeleteSndFilesInternal #-}

-- | Delete XFTP snd file chunks on servers
xftpDeleteSndFileRemote :: AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> IO ()
xftpDeleteSndFileRemote :: AgentClient
-> UserId -> ConnId -> ValidFileDescription 'FSender -> IO ()
xftpDeleteSndFileRemote AgentClient
c = AgentClient -> ReaderT Env IO () -> IO ()
forall a. AgentClient -> AM' a -> IO a
withAgentEnv' AgentClient
c (ReaderT Env IO () -> IO ())
-> (UserId
    -> ConnId -> ValidFileDescription 'FSender -> ReaderT Env IO ())
-> UserId
-> ConnId
-> ValidFileDescription 'FSender
-> IO ()
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. AgentClient
-> UserId
-> ConnId
-> ValidFileDescription 'FSender
-> ReaderT Env IO ()
deleteSndFileRemote AgentClient
c
{-# INLINE xftpDeleteSndFileRemote #-}

-- | Delete XFTP snd file chunks on servers for multiple snd files, batching operations when possible
xftpDeleteSndFilesRemote :: AgentClient -> UserId -> [(SndFileId, ValidFileDescription 'FSender)] -> IO ()
xftpDeleteSndFilesRemote :: AgentClient
-> UserId -> [(ConnId, ValidFileDescription 'FSender)] -> IO ()
xftpDeleteSndFilesRemote AgentClient
c = AgentClient -> ReaderT Env IO () -> IO ()
forall a. AgentClient -> AM' a -> IO a
withAgentEnv' AgentClient
c (ReaderT Env IO () -> IO ())
-> (UserId
    -> [(ConnId, ValidFileDescription 'FSender)] -> ReaderT Env IO ())
-> UserId
-> [(ConnId, ValidFileDescription 'FSender)]
-> IO ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> UserId
-> [(ConnId, ValidFileDescription 'FSender)]
-> ReaderT Env IO ()
deleteSndFilesRemote AgentClient
c
{-# INLINE xftpDeleteSndFilesRemote #-}

-- | Create new remote host pairing
rcNewHostPairing :: AgentClient -> IO RCHostPairing
rcNewHostPairing :: AgentClient -> IO RCHostPairing
rcNewHostPairing AgentClient {$sel:agentEnv:AgentClient :: AgentClient -> Env
agentEnv = Env {TVar ChaChaDRG
random :: TVar ChaChaDRG
$sel:random:Env :: Env -> TVar ChaChaDRG
random}} = TVar ChaChaDRG -> IO RCHostPairing
newRCHostPairing TVar ChaChaDRG
random
{-# INLINE rcNewHostPairing #-}

-- | start TLS server for remote host with optional multicast
rcConnectHost :: AgentClient -> RCHostPairing -> J.Value -> Bool -> Maybe RCCtrlAddress -> Maybe Word16 -> AE RCHostConnection
rcConnectHost :: AgentClient
-> RCHostPairing
-> Value
-> Bool
-> Maybe RCCtrlAddress
-> Maybe Word16
-> AE RCHostConnection
rcConnectHost AgentClient {$sel:agentEnv:AgentClient :: AgentClient -> Env
agentEnv = Env {TVar ChaChaDRG
$sel:random:Env :: Env -> TVar ChaChaDRG
random :: TVar ChaChaDRG
random}} = (RCErrorType -> AgentErrorType)
-> ExceptT RCErrorType IO RCHostConnection -> AE RCHostConnection
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT RCErrorType -> AgentErrorType
RCP (ExceptT RCErrorType IO RCHostConnection -> AE RCHostConnection)
-> (RCHostPairing
    -> Value
    -> Bool
    -> Maybe RCCtrlAddress
    -> Maybe Word16
    -> ExceptT RCErrorType IO RCHostConnection)
-> RCHostPairing
-> Value
-> Bool
-> Maybe RCCtrlAddress
-> Maybe Word16
-> AE RCHostConnection
forall {d} {e} {a1} {a2} {a3} {b} {c}.
(d -> e)
-> (a1 -> a2 -> a3 -> b -> c -> d) -> a1 -> a2 -> a3 -> b -> c -> e
.::. TVar ChaChaDRG
-> RCHostPairing
-> Value
-> Bool
-> Maybe RCCtrlAddress
-> Maybe Word16
-> ExceptT RCErrorType IO RCHostConnection
connectRCHost TVar ChaChaDRG
random
{-# INLINE rcConnectHost #-}

-- | connect to remote controller via URI
rcConnectCtrl :: AgentClient -> RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> AE RCCtrlConnection
rcConnectCtrl :: AgentClient
-> RCVerifiedInvitation
-> Maybe RCCtrlPairing
-> Value
-> AE RCCtrlConnection
rcConnectCtrl AgentClient {$sel:agentEnv:AgentClient :: AgentClient -> Env
agentEnv = Env {TVar ChaChaDRG
$sel:random:Env :: Env -> TVar ChaChaDRG
random :: TVar ChaChaDRG
random}} = (RCErrorType -> AgentErrorType)
-> ExceptT RCErrorType IO RCCtrlConnection -> AE RCCtrlConnection
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT RCErrorType -> AgentErrorType
RCP (ExceptT RCErrorType IO RCCtrlConnection -> AE RCCtrlConnection)
-> (RCVerifiedInvitation
    -> Maybe RCCtrlPairing
    -> Value
    -> ExceptT RCErrorType IO RCCtrlConnection)
-> RCVerifiedInvitation
-> Maybe RCCtrlPairing
-> Value
-> AE RCCtrlConnection
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. TVar ChaChaDRG
-> RCVerifiedInvitation
-> Maybe RCCtrlPairing
-> Value
-> ExceptT RCErrorType IO RCCtrlConnection
connectRCCtrl TVar ChaChaDRG
random
{-# INLINE rcConnectCtrl #-}

-- | connect to known remote controller via multicast
rcDiscoverCtrl :: AgentClient -> NonEmpty RCCtrlPairing -> AE (RCCtrlPairing, RCVerifiedInvitation)
rcDiscoverCtrl :: AgentClient
-> NonEmpty RCCtrlPairing
-> AE (RCCtrlPairing, RCVerifiedInvitation)
rcDiscoverCtrl AgentClient {$sel:agentEnv:AgentClient :: AgentClient -> Env
agentEnv = Env {$sel:multicastSubscribers:Env :: Env -> TMVar Int
multicastSubscribers = TMVar Int
subs}} = (RCErrorType -> AgentErrorType)
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
-> AE (RCCtrlPairing, RCVerifiedInvitation)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT RCErrorType -> AgentErrorType
RCP (ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
 -> AE (RCCtrlPairing, RCVerifiedInvitation))
-> (NonEmpty RCCtrlPairing
    -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation))
-> NonEmpty RCCtrlPairing
-> AE (RCCtrlPairing, RCVerifiedInvitation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar Int
-> NonEmpty RCCtrlPairing
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
discoverRCCtrl TMVar Int
subs
{-# INLINE rcDiscoverCtrl #-}

resetAgentServersStats :: AgentClient -> AE ()
resetAgentServersStats :: AgentClient -> AE ()
resetAgentServersStats AgentClient
c = AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (ExceptT AgentErrorType (ReaderT Env IO) () -> AE ())
-> ExceptT AgentErrorType (ReaderT Env IO) () -> AE ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) ()
resetAgentServersStats' AgentClient
c
{-# INLINE resetAgentServersStats #-}

withAgentEnv' :: AgentClient -> AM' a -> IO a
withAgentEnv' :: forall a. AgentClient -> AM' a -> IO a
withAgentEnv' AgentClient
c = (ReaderT Env IO a -> Env -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` AgentClient -> Env
agentEnv AgentClient
c)
{-# INLINE withAgentEnv' #-}

withAgentEnv :: AgentClient -> AM a -> AE a
withAgentEnv :: forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c AM a
a = IO (Either AgentErrorType a) -> ExceptT AgentErrorType IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either AgentErrorType a) -> ExceptT AgentErrorType IO a)
-> IO (Either AgentErrorType a) -> ExceptT AgentErrorType IO a
forall a b. (a -> b) -> a -> b
$ AM a -> ReaderT Env IO (Either AgentErrorType a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT AM a
a ReaderT Env IO (Either AgentErrorType a)
-> Env -> IO (Either AgentErrorType a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` AgentClient -> Env
agentEnv AgentClient
c
{-# INLINE withAgentEnv #-}

logConnection :: AgentClient -> Bool -> IO ()
logConnection :: AgentClient -> Bool -> IO ()
logConnection AgentClient
c Bool
connected =
  let event :: Text
event = if Bool
connected then Text
"connected to" else Text
"disconnected from"
   in Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text
Item [Text]
"client", Int -> Text
forall a. Show a => a -> Text
tshow (AgentClient -> Int
clientId AgentClient
c), Text
Item [Text]
event, Text
Item [Text]
"Agent"]

createUser' :: AgentClient -> NonEmpty (ServerCfg 'PSMP) -> NonEmpty (ServerCfg 'PXFTP) -> AM UserId
createUser' :: AgentClient
-> NonEmpty (ServerCfg 'PSMP)
-> NonEmpty (ServerCfg 'PXFTP)
-> AM UserId
createUser' AgentClient
c NonEmpty (ServerCfg 'PSMP)
smp NonEmpty (ServerCfg 'PXFTP)
xftp = do
  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
$ Text -> NonEmpty (ServerCfg 'PSMP) -> IO ()
forall (p :: ProtocolType). Text -> NonEmpty (ServerCfg p) -> IO ()
checkUserServers Text
"createUser SMP" NonEmpty (ServerCfg 'PSMP)
smp
  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
$ Text -> NonEmpty (ServerCfg 'PXFTP) -> IO ()
forall (p :: ProtocolType). Text -> NonEmpty (ServerCfg p) -> IO ()
checkUserServers Text
"createUser XFTP" NonEmpty (ServerCfg 'PXFTP)
xftp
  UserId
userId <- AgentClient -> (Connection -> IO UserId) -> AM UserId
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO UserId
createUserRecord
  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
$ UserId
-> UserServers 'PSMP -> TMap UserId (UserServers 'PSMP) -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert UserId
userId (NonEmpty (ServerCfg 'PSMP) -> UserServers 'PSMP
forall (p :: ProtocolType). NonEmpty (ServerCfg p) -> UserServers p
mkUserServers NonEmpty (ServerCfg 'PSMP)
smp) (TMap UserId (UserServers 'PSMP) -> STM ())
-> TMap UserId (UserServers 'PSMP) -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMap UserId (UserServers 'PSMP)
smpServers AgentClient
c
  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
$ UserId
-> UserServers 'PXFTP -> TMap UserId (UserServers 'PXFTP) -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert UserId
userId (NonEmpty (ServerCfg 'PXFTP) -> UserServers 'PXFTP
forall (p :: ProtocolType). NonEmpty (ServerCfg p) -> UserServers p
mkUserServers NonEmpty (ServerCfg 'PXFTP)
xftp) (TMap UserId (UserServers 'PXFTP) -> STM ())
-> TMap UserId (UserServers 'PXFTP) -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMap UserId (UserServers 'PXFTP)
xftpServers AgentClient
c
  UserId -> AM UserId
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserId
userId

deleteUser' :: AgentClient -> UserId -> Bool -> AM ()
deleteUser' :: AgentClient
-> UserId -> Bool -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteUser' c :: AgentClient
c@AgentClient {TMap (UserId, SMPServer) AgentSMPServerStats
$sel:smpServersStats:AgentClient :: AgentClient -> TMap (UserId, SMPServer) AgentSMPServerStats
smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats
smpServersStats, TMap (UserId, XFTPServer) AgentXFTPServerStats
$sel:xftpServersStats:AgentClient :: AgentClient -> TMap (UserId, XFTPServer) AgentXFTPServerStats
xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats
xftpServersStats} UserId
userId Bool
delSMPQueues = do
  if Bool
delSMPQueues
    then AgentClient
-> (Connection -> IO (Either StoreError [ConnId])) -> AM [ConnId]
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> UserId -> IO (Either StoreError [ConnId])
`setUserDeleted` UserId
userId) AM [ConnId]
-> ([ConnId] -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
>>= ExceptT AgentErrorType (ReaderT Env IO) ()
-> AgentClient
-> Bool
-> [ConnId]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnectionsAsync_ ExceptT AgentErrorType (ReaderT Env IO) ()
delUser AgentClient
c Bool
False
    else AgentClient
-> (Connection -> IO (Either StoreError ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> UserId -> IO (Either StoreError ())
`deleteUserRecord` UserId
userId)
  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
$ UserId -> TMap UserId (UserServers 'PSMP) -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete UserId
userId (TMap UserId (UserServers 'PSMP) -> STM ())
-> TMap UserId (UserServers 'PSMP) -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMap UserId (UserServers 'PSMP)
smpServers AgentClient
c
  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
$ UserId -> TMap UserId (UserServers 'PXFTP) -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete UserId
userId (TMap UserId (UserServers 'PXFTP) -> STM ())
-> TMap UserId (UserServers 'PXFTP) -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMap UserId (UserServers 'PXFTP)
xftpServers AgentClient
c
  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
$ TMap (UserId, SMPServer) AgentSMPServerStats
-> (Map (UserId, SMPServer) AgentSMPServerStats
    -> Map (UserId, SMPServer) AgentSMPServerStats)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TMap (UserId, SMPServer) AgentSMPServerStats
smpServersStats ((Map (UserId, SMPServer) AgentSMPServerStats
  -> Map (UserId, SMPServer) AgentSMPServerStats)
 -> STM ())
-> (Map (UserId, SMPServer) AgentSMPServerStats
    -> Map (UserId, SMPServer) AgentSMPServerStats)
-> STM ()
forall a b. (a -> b) -> a -> b
$ ((UserId, SMPServer) -> AgentSMPServerStats -> Bool)
-> Map (UserId, SMPServer) AgentSMPServerStats
-> Map (UserId, SMPServer) AgentSMPServerStats
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\(UserId
userId', SMPServer
_) AgentSMPServerStats
_ -> UserId
userId' UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
/= UserId
userId)
  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
$ TMap (UserId, XFTPServer) AgentXFTPServerStats
-> (Map (UserId, XFTPServer) AgentXFTPServerStats
    -> Map (UserId, XFTPServer) AgentXFTPServerStats)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TMap (UserId, XFTPServer) AgentXFTPServerStats
xftpServersStats ((Map (UserId, XFTPServer) AgentXFTPServerStats
  -> Map (UserId, XFTPServer) AgentXFTPServerStats)
 -> STM ())
-> (Map (UserId, XFTPServer) AgentXFTPServerStats
    -> Map (UserId, XFTPServer) AgentXFTPServerStats)
-> STM ()
forall a b. (a -> b) -> a -> b
$ ((UserId, XFTPServer) -> AgentXFTPServerStats -> Bool)
-> Map (UserId, XFTPServer) AgentXFTPServerStats
-> Map (UserId, XFTPServer) AgentXFTPServerStats
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\(UserId
userId', XFTPServer
_) AgentXFTPServerStats
_ -> UserId
userId' UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
/= UserId
userId)
  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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> ReaderT Env IO ()
saveServersStats AgentClient
c
  where
    delUser :: ExceptT AgentErrorType (ReaderT Env IO) ()
delUser =
      ExceptT AgentErrorType (ReaderT Env IO) Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (AgentClient
-> (Connection -> IO Bool)
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> UserId -> IO Bool
`deleteUserWithoutConns` UserId
userId)) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> STM ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
$
        TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ConnId
"", ConnId
"", 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
$ UserId -> AEvent 'AENone
DEL_USER UserId
userId)

newConnAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AM ConnId
newConnAsync :: forall (c :: ConnectionMode).
ConnectionModeI c =>
AgentClient
-> UserId
-> ConnId
-> Bool
-> SConnectionMode c
-> InitialKeys
-> SubscriptionMode
-> AM ConnId
newConnAsync AgentClient
c UserId
userId ConnId
corrId Bool
enableNtfs SConnectionMode c
cMode InitialKeys
pqInitKeys SubscriptionMode
subMode = do
  ConnId
connId <- AgentClient
-> UserId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
forall (c :: ConnectionMode).
AgentClient
-> UserId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
newConnNoQueues AgentClient
c UserId
userId Bool
enableNtfs SConnectionMode c
cMode (InitialKeys -> PQSupport
CR.connPQEncryption InitialKeys
pqInitKeys)
  AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
corrId ConnId
connId Maybe SMPServer
forall a. Maybe a
Nothing (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ACommand -> AgentCommand
AClientCommand (ACommand -> AgentCommand) -> ACommand -> AgentCommand
forall a b. (a -> b) -> a -> b
$ Bool
-> AConnectionMode -> InitialKeys -> SubscriptionMode -> ACommand
NEW Bool
enableNtfs (SConnectionMode c -> AConnectionMode
forall (m :: ConnectionMode).
ConnectionModeI m =>
SConnectionMode m -> AConnectionMode
ACM SConnectionMode c
cMode) InitialKeys
pqInitKeys SubscriptionMode
subMode
  ConnId -> AM ConnId
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnId
connId

newConnNoQueues :: AgentClient -> UserId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
newConnNoQueues :: forall (c :: ConnectionMode).
AgentClient
-> UserId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
newConnNoQueues AgentClient
c UserId
userId Bool
enableNtfs SConnectionMode c
cMode PQSupport
pqSupport = 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
  VersionSMPA
connAgentVersion <- (Env -> VersionSMPA)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionSMPA
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> VersionSMPA)
 -> ExceptT AgentErrorType (ReaderT Env IO) VersionSMPA)
-> (Env -> VersionSMPA)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionSMPA
forall a b. (a -> b) -> a -> b
$ VersionRange SMPAgentVersion -> VersionSMPA
forall v. VersionRange v -> Version v
maxVersion (VersionRange SMPAgentVersion -> VersionSMPA)
-> (Env -> VersionRange SMPAgentVersion) -> Env -> VersionSMPA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange (AgentConfig -> VersionRange SMPAgentVersion)
-> (Env -> AgentConfig) -> Env -> VersionRange SMPAgentVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  let cData :: ConnData
cData = ConnData {UserId
userId :: UserId
$sel:userId:ConnData :: UserId
userId, $sel:connId:ConnData :: ConnId
connId = ConnId
"", VersionSMPA
connAgentVersion :: VersionSMPA
$sel:connAgentVersion:ConnData :: VersionSMPA
connAgentVersion, Bool
enableNtfs :: Bool
$sel:enableNtfs:ConnData :: Bool
enableNtfs, $sel:lastExternalSndId:ConnData :: UserId
lastExternalSndId = UserId
0, $sel:deleted:ConnData :: Bool
deleted = Bool
False, $sel:ratchetSyncState:ConnData :: RatchetSyncState
ratchetSyncState = RatchetSyncState
RSOk, PQSupport
pqSupport :: PQSupport
$sel:pqSupport:ConnData :: PQSupport
pqSupport}
  AgentClient
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError ConnId)) -> AM ConnId)
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> TVar ChaChaDRG
-> ConnData
-> SConnectionMode c
-> IO (Either StoreError ConnId)
forall (c :: ConnectionMode).
Connection
-> TVar ChaChaDRG
-> ConnData
-> SConnectionMode c
-> IO (Either StoreError ConnId)
createNewConn Connection
db TVar ChaChaDRG
g ConnData
cData SConnectionMode c
cMode

-- TODO [short links] TBC, but probably we will need async join for contact addresses as the contact will be created after user confirming the connection,
-- and join should retry, the same as 1-time invitation joins.
joinConnAsync :: AgentClient -> UserId -> ACorrId -> Maybe ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
joinConnAsync :: forall (c :: ConnectionMode).
AgentClient
-> UserId
-> ConnId
-> Maybe ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM ConnId
joinConnAsync AgentClient
c UserId
userId ConnId
corrId Maybe ConnId
connId_ Bool
enableNtfs cReqUri :: ConnectionRequestUri c
cReqUri@CRInvitationUri {} ConnId
cInfo PQSupport
pqSup SubscriptionMode
subMode = do
  Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ConnId -> Bool
forall a. Maybe a -> Bool
isJust Maybe ConnId
connId_) (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"joinConnAsync: connId not allowed for invitation URI"
  AgentClient -> ConnId -> Text -> AM ConnId -> AM ConnId
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withInvLock AgentClient
c (ConnectionRequestUri c -> ConnId
forall a. StrEncoding a => a -> ConnId
strEncode ConnectionRequestUri c
cReqUri) Text
"joinConnAsync" (AM ConnId -> AM ConnId) -> AM ConnId -> AM ConnId
forall a b. (a -> b) -> a -> b
$ do
    ReaderT
  Env
  IO
  (Maybe
     (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
      Compatible VersionSMPA))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
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 (ConnectionRequestUri 'CMInvitation
-> ReaderT
     Env
     IO
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
compatibleInvitationUri ConnectionRequestUri c
ConnectionRequestUri 'CMInvitation
cReqUri) ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Maybe
     (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
      Compatible VersionSMPA))
-> (Maybe
      (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
       Compatible VersionSMPA)
    -> AM ConnId)
-> AM ConnId
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 (Compatible SMPQueueInfo
_, Compatible (CR.E2ERatchetParams VersionE2E
v PublicKey 'X448
_ PublicKey 'X448
_ Maybe (RKEMParams 'RKSProposed)
_), Compatible VersionSMPA
connAgentVersion) -> 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
        let pqSupport :: PQSupport
pqSupport = PQSupport
pqSup PQSupport -> PQSupport -> PQSupport
`CR.pqSupportAnd` VersionSMPA -> Maybe VersionE2E -> PQSupport
versionPQSupport_ VersionSMPA
connAgentVersion (VersionE2E -> Maybe VersionE2E
forall a. a -> Maybe a
Just VersionE2E
v)
            cData :: ConnData
cData = ConnData {UserId
$sel:userId:ConnData :: UserId
userId :: UserId
userId, $sel:connId:ConnData :: ConnId
connId = ConnId
"", VersionSMPA
$sel:connAgentVersion:ConnData :: VersionSMPA
connAgentVersion :: VersionSMPA
connAgentVersion, Bool
$sel:enableNtfs:ConnData :: Bool
enableNtfs :: Bool
enableNtfs, $sel:lastExternalSndId:ConnData :: UserId
lastExternalSndId = UserId
0, $sel:deleted:ConnData :: Bool
deleted = Bool
False, $sel:ratchetSyncState:ConnData :: RatchetSyncState
ratchetSyncState = RatchetSyncState
RSOk, PQSupport
$sel:pqSupport:ConnData :: PQSupport
pqSupport :: PQSupport
pqSupport}
        ConnId
connId <- AgentClient
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError ConnId)) -> AM ConnId)
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> TVar ChaChaDRG
-> ConnData
-> SConnectionMode 'CMInvitation
-> IO (Either StoreError ConnId)
forall (c :: ConnectionMode).
Connection
-> TVar ChaChaDRG
-> ConnData
-> SConnectionMode c
-> IO (Either StoreError ConnId)
createNewConn Connection
db TVar ChaChaDRG
g ConnData
cData SConnectionMode 'CMInvitation
SCMInvitation
        AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
corrId ConnId
connId Maybe SMPServer
forall a. Maybe a
Nothing (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ACommand -> AgentCommand
AClientCommand (ACommand -> AgentCommand) -> ACommand -> AgentCommand
forall a b. (a -> b) -> a -> b
$ Bool
-> AConnectionRequestUri
-> PQSupport
-> SubscriptionMode
-> ConnId
-> ACommand
JOIN Bool
enableNtfs (SConnectionMode c
-> ConnectionRequestUri c -> AConnectionRequestUri
forall (m :: ConnectionMode).
ConnectionModeI m =>
SConnectionMode m
-> ConnectionRequestUri m -> AConnectionRequestUri
ACR SConnectionMode c
forall (m :: ConnectionMode).
ConnectionModeI m =>
SConnectionMode m
sConnectionMode ConnectionRequestUri c
cReqUri) PQSupport
pqSupport SubscriptionMode
subMode ConnId
cInfo
        ConnId -> AM ConnId
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnId
connId
      Maybe
  (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
   Compatible VersionSMPA)
Nothing -> AgentErrorType -> AM ConnId
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnId) -> AgentErrorType -> AM ConnId
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION
joinConnAsync AgentClient
c UserId
userId ConnId
corrId Maybe ConnId
connId_ Bool
enableNtfs cReqUri :: ConnectionRequestUri c
cReqUri@(CRContactUri ConnReqUriData
_) ConnId
cInfo PQSupport
pqSup SubscriptionMode
subMode = do
  ReaderT
  Env IO (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
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 (ConnectionRequestUri 'CMContact
-> ReaderT
     Env IO (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
compatibleContactUri ConnectionRequestUri c
ConnectionRequestUri 'CMContact
cReqUri) ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
-> (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)
    -> AM ConnId)
-> AM ConnId
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 (Compatible SMPQueueInfo
_, Compatible VersionSMPA
connAgentVersion) -> do
      let pqSupport :: PQSupport
pqSupport = PQSupport
pqSup PQSupport -> PQSupport -> PQSupport
`CR.pqSupportAnd` VersionSMPA -> Maybe VersionE2E -> PQSupport
versionPQSupport_ VersionSMPA
connAgentVersion Maybe VersionE2E
forall a. Maybe a
Nothing
      ConnId
connId <- case Maybe ConnId
connId_ of
        Just ConnId
cId -> do
          -- update connection record created by getConnShortLinkAsync
          AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> VersionSMPA -> PQSupport -> Bool -> IO ()
updateNewConnJoin Connection
db ConnId
cId VersionSMPA
connAgentVersion PQSupport
pqSupport Bool
enableNtfs
          ConnId -> AM ConnId
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnId
cId
        Maybe ConnId
Nothing -> 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
          let cData :: ConnData
cData = ConnData {UserId
$sel:userId:ConnData :: UserId
userId :: UserId
userId, $sel:connId:ConnData :: ConnId
connId = ConnId
"", VersionSMPA
$sel:connAgentVersion:ConnData :: VersionSMPA
connAgentVersion :: VersionSMPA
connAgentVersion, Bool
$sel:enableNtfs:ConnData :: Bool
enableNtfs :: Bool
enableNtfs, $sel:lastExternalSndId:ConnData :: UserId
lastExternalSndId = UserId
0, $sel:deleted:ConnData :: Bool
deleted = Bool
False, $sel:ratchetSyncState:ConnData :: RatchetSyncState
ratchetSyncState = RatchetSyncState
RSOk, PQSupport
$sel:pqSupport:ConnData :: PQSupport
pqSupport :: PQSupport
pqSupport}
          AgentClient
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError ConnId)) -> AM ConnId)
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> TVar ChaChaDRG
-> ConnData
-> SConnectionMode 'CMInvitation
-> IO (Either StoreError ConnId)
forall (c :: ConnectionMode).
Connection
-> TVar ChaChaDRG
-> ConnData
-> SConnectionMode c
-> IO (Either StoreError ConnId)
createNewConn Connection
db TVar ChaChaDRG
g ConnData
cData SConnectionMode 'CMInvitation
SCMInvitation
      AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
corrId ConnId
connId Maybe SMPServer
forall a. Maybe a
Nothing (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ACommand -> AgentCommand
AClientCommand (ACommand -> AgentCommand) -> ACommand -> AgentCommand
forall a b. (a -> b) -> a -> b
$ Bool
-> AConnectionRequestUri
-> PQSupport
-> SubscriptionMode
-> ConnId
-> ACommand
JOIN Bool
enableNtfs (SConnectionMode c
-> ConnectionRequestUri c -> AConnectionRequestUri
forall (m :: ConnectionMode).
ConnectionModeI m =>
SConnectionMode m
-> ConnectionRequestUri m -> AConnectionRequestUri
ACR SConnectionMode c
forall (m :: ConnectionMode).
ConnectionModeI m =>
SConnectionMode m
sConnectionMode ConnectionRequestUri c
cReqUri) PQSupport
pqSupport SubscriptionMode
subMode ConnId
cInfo
      ConnId -> AM ConnId
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnId
connId
    Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)
Nothing -> AgentErrorType -> AM ConnId
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnId) -> AgentErrorType -> AM ConnId
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION

allowConnectionAsync' :: AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> AM ()
allowConnectionAsync' :: AgentClient
-> ConnId
-> ConnId
-> ConnId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
allowConnectionAsync' AgentClient
c ConnId
corrId ConnId
connId ConnId
confId ConnId
ownConnInfo =
  AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId) AM SomeConn
-> (SomeConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
    SomeConn SConnType d
_ (RcvConnection ConnData
_ RcvQueue {SMPServer
server :: SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server}) ->
      AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
corrId ConnId
connId (SMPServer -> Maybe SMPServer
forall a. a -> Maybe a
Just SMPServer
server) (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ACommand -> AgentCommand
AClientCommand (ACommand -> AgentCommand) -> ACommand -> AgentCommand
forall a b. (a -> b) -> a -> b
$ ConnId -> ConnId -> ACommand
LET ConnId
confId ConnId
ownConnInfo
    SomeConn
_ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"allowConnectionAsync"

-- TODO
-- Unlike `acceptContact` (synchronous version), `acceptContactAsync` uses `unacceptInvitation` in case of error,
-- because we're not taking lock here. In practice it is less likely to fail because it doesn't involve network IO,
-- and also it can't be triggered by user concurrently several times in a row. It could be improved similarly to
-- `acceptContact` by creating a new map for invitation locks and taking lock here, and removing `unacceptInvitation`
-- while marking invitation as accepted inside "lock level transaction" after successful `joinConnAsync`.
acceptContactAsync' :: AgentClient -> UserId -> ACorrId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
acceptContactAsync' :: AgentClient
-> UserId
-> ConnId
-> Bool
-> ConnId
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM ConnId
acceptContactAsync' AgentClient
c UserId
userId ConnId
corrId Bool
enableNtfs ConnId
invId ConnId
ownConnInfo PQSupport
pqSupport SubscriptionMode
subMode = do
  Invitation {ConnectionRequestUri 'CMInvitation
connReq :: ConnectionRequestUri 'CMInvitation
$sel:connReq:Invitation :: Invitation -> ConnectionRequestUri 'CMInvitation
connReq} <- AgentClient
-> (Connection -> IO (Either StoreError Invitation))
-> AM Invitation
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError Invitation))
 -> AM Invitation)
-> (Connection -> IO (Either StoreError Invitation))
-> AM Invitation
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> String -> ConnId -> IO (Either StoreError Invitation)
getInvitation Connection
db String
"acceptContactAsync'" ConnId
invId
  AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> ConnId -> IO ()
acceptInvitation Connection
db ConnId
invId ConnId
ownConnInfo
  AgentClient
-> UserId
-> ConnId
-> Maybe ConnId
-> Bool
-> ConnectionRequestUri 'CMInvitation
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM ConnId
forall (c :: ConnectionMode).
AgentClient
-> UserId
-> ConnId
-> Maybe ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM ConnId
joinConnAsync AgentClient
c UserId
userId ConnId
corrId Maybe ConnId
forall a. Maybe a
Nothing Bool
enableNtfs ConnectionRequestUri 'CMInvitation
connReq ConnId
ownConnInfo PQSupport
pqSupport SubscriptionMode
subMode AM ConnId -> (AgentErrorType -> AM ConnId) -> AM ConnId
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \AgentErrorType
err -> do
    AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> ConnId -> IO ()
`unacceptInvitation` ConnId
invId)
    AgentErrorType -> AM ConnId
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
err

ackMessageAsync' :: AgentClient -> ACorrId -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AM ()
ackMessageAsync' :: AgentClient
-> ConnId
-> ConnId
-> UserId
-> Maybe ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
ackMessageAsync' AgentClient
c ConnId
corrId ConnId
connId UserId
msgId Maybe ConnId
rcptInfo_ = do
  SomeConn SConnType d
cType Connection' d RcvQueue SndQueue
_ <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
  case SConnType d
cType of
    SConnType d
SCDuplex -> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueAck
    SConnType d
SCRcv -> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueAck
    SConnType d
SCSnd -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX String
"ackMessageAsync"
    SConnType d
SCContact -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"ackMessageAsync: SCContact"
    SConnType d
SCNew -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"ackMessageAsync: SCNew"
  where
    enqueueAck :: AM ()
    enqueueAck :: ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueAck = do
      let mId :: InternalId
mId = UserId -> InternalId
InternalId UserId
msgId
      RcvMsg {AgentMessageType
msgType :: AgentMessageType
$sel:msgType:RcvMsg :: RcvMsg -> AgentMessageType
msgType} <- AgentClient
-> (Connection -> IO (Either StoreError RcvMsg)) -> AM RcvMsg
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError RcvMsg)) -> AM RcvMsg)
-> (Connection -> IO (Either StoreError RcvMsg)) -> AM RcvMsg
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> InternalId -> IO (Either StoreError RcvMsg)
getRcvMsg Connection
db ConnId
connId InternalId
mId
      Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ConnId -> Bool
forall a. Maybe a -> Bool
isJust Maybe ConnId
rcptInfo_ Bool -> Bool -> Bool
&& AgentMessageType
msgType AgentMessageType -> AgentMessageType -> Bool
forall a. Eq a => a -> a -> Bool
/= AgentMessageType
AM_A_MSG_) (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"ackMessageAsync: receipt not allowed"
      (RcvQueue {SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server :: SMPServer
server}, ConnId
_) <- AgentClient
-> (Connection -> IO (Either StoreError (RcvQueue, ConnId)))
-> AM (RcvQueue, ConnId)
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError (RcvQueue, ConnId)))
 -> AM (RcvQueue, ConnId))
-> (Connection -> IO (Either StoreError (RcvQueue, ConnId)))
-> AM (RcvQueue, ConnId)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ConnId
-> InternalId
-> IO (Either StoreError (RcvQueue, ConnId))
setMsgUserAck Connection
db ConnId
connId InternalId
mId
      AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
corrId ConnId
connId (SMPServer -> Maybe SMPServer
forall a. a -> Maybe a
Just SMPServer
server) (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ACommand -> AgentCommand)
-> ACommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ACommand -> AgentCommand
AClientCommand (ACommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ACommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ UserId -> Maybe ConnId -> ACommand
ACK UserId
msgId Maybe ConnId
rcptInfo_

deleteConnectionAsync' :: AgentClient -> Bool -> ConnId -> AM ()
deleteConnectionAsync' :: AgentClient
-> Bool -> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnectionAsync' AgentClient
c Bool
waitDelivery ConnId
connId = AgentClient
-> Bool -> [ConnId] -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnectionsAsync' AgentClient
c Bool
waitDelivery [ConnId
Item [ConnId]
connId]
{-# INLINE deleteConnectionAsync' #-}

deleteConnectionsAsync' :: AgentClient -> Bool -> [ConnId] -> AM ()
deleteConnectionsAsync' :: AgentClient
-> Bool -> [ConnId] -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnectionsAsync' = ExceptT AgentErrorType (ReaderT Env IO) ()
-> AgentClient
-> Bool
-> [ConnId]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnectionsAsync_ (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> AgentClient
 -> Bool
 -> [ConnId]
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> AgentClient
-> Bool
-> [ConnId]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINE deleteConnectionsAsync' #-}

deleteConnectionsAsync_ :: AM () -> AgentClient -> Bool -> [ConnId] -> AM ()
deleteConnectionsAsync_ :: ExceptT AgentErrorType (ReaderT Env IO) ()
-> AgentClient
-> Bool
-> [ConnId]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnectionsAsync_ ExceptT AgentErrorType (ReaderT Env IO) ()
onSuccess AgentClient
c Bool
waitDelivery [ConnId]
connIds = case [ConnId]
connIds of
  [] -> ExceptT AgentErrorType (ReaderT Env IO) ()
onSuccess
  [ConnId]
_ -> do
    (Map ConnId (Either AgentErrorType ())
_, [RcvQueue]
rqs, [ConnId]
connIds') <- (Connection -> [ConnId] -> IO [Either StoreError SomeConn])
-> AgentClient
-> Bool
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
prepareDeleteConnections_ Connection -> [ConnId] -> IO [Either StoreError SomeConn]
getConns AgentClient
c Bool
waitDelivery [ConnId]
connIds
    AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> [ConnId] -> (ConnId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ConnId]
connIds' ((ConnId -> IO ()) -> IO ()) -> (ConnId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Bool -> ConnId -> IO ()
setConnDeleted Connection
db Bool
waitDelivery
    ExceptT AgentErrorType (ReaderT Env IO) ThreadId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT AgentErrorType (ReaderT Env IO) ThreadId
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ReaderT Env IO ()
    -> ExceptT AgentErrorType (ReaderT Env IO) ThreadId)
-> ReaderT Env IO ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Env IO ThreadId
-> ExceptT AgentErrorType (ReaderT Env IO) ThreadId
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 ThreadId
 -> ExceptT AgentErrorType (ReaderT Env IO) ThreadId)
-> (ReaderT Env IO () -> ReaderT Env IO ThreadId)
-> ReaderT Env IO ()
-> ExceptT AgentErrorType (ReaderT Env IO) ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Env IO () -> ReaderT Env IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$
      Lock -> Text -> ReaderT Env IO () -> ReaderT Env IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Lock -> Text -> m a -> m a
withLock' (AgentClient -> Lock
deleteLock AgentClient
c) Text
"deleteConnectionsAsync" (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$
        AgentClient
-> NetworkRequestMode
-> Bool
-> Bool
-> [RcvQueue]
-> AM' (Map ConnId (Either AgentErrorType ()))
deleteConnQueues AgentClient
c NetworkRequestMode
NRMBackground Bool
waitDelivery Bool
True [RcvQueue]
rqs AM' (Map ConnId (Either AgentErrorType ()))
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b.
ReaderT Env IO a -> ReaderT Env IO b -> ReaderT Env IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReaderT Env IO (Either AgentErrorType ()) -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT AgentErrorType (ReaderT Env IO) ()
-> ReaderT Env IO (Either AgentErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT AgentErrorType (ReaderT Env IO) ()
onSuccess)

-- | Add connection to the new receive queue
switchConnectionAsync' :: AgentClient -> ACorrId -> ConnId -> AM ConnectionStats
switchConnectionAsync' :: AgentClient -> ConnId -> ConnId -> AM ConnectionStats
switchConnectionAsync' AgentClient
c ConnId
corrId ConnId
connId =
  AgentClient
-> ConnId -> Text -> AM ConnectionStats -> AM ConnectionStats
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
"switchConnectionAsync" (AM ConnectionStats -> AM ConnectionStats)
-> AM ConnectionStats -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$
    AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId) AM SomeConn
-> (SomeConn -> AM ConnectionStats) -> AM ConnectionStats
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
      SomeConn SConnType d
_ (DuplexConnection ConnData
cData rqs :: NonEmpty RcvQueue
rqs@(RcvQueue
rq :| [RcvQueue]
_rqs) NonEmpty SndQueue
sqs)
        | Maybe RcvQueue -> Bool
forall a. Maybe a -> Bool
isJust (NonEmpty RcvQueue -> Maybe RcvQueue
switchingRQ NonEmpty RcvQueue
rqs) -> AgentErrorType -> AM ConnectionStats
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnectionStats)
-> AgentErrorType -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"switchConnectionAsync: already switching"
        | Bool
otherwise -> do
            Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnData -> Bool
ratchetSyncSendProhibited ConnData
cData) (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"switchConnectionAsync: send prohibited"
            RcvQueue
rq1 <- AgentClient -> (Connection -> IO RcvQueue) -> AM RcvQueue
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO RcvQueue) -> AM RcvQueue)
-> (Connection -> IO RcvQueue) -> AM RcvQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvQueue -> Maybe RcvSwitchStatus -> IO RcvQueue
setRcvSwitchStatus Connection
db RcvQueue
rq (Maybe RcvSwitchStatus -> IO RcvQueue)
-> Maybe RcvSwitchStatus -> IO RcvQueue
forall a b. (a -> b) -> a -> b
$ RcvSwitchStatus -> Maybe RcvSwitchStatus
forall a. a -> Maybe a
Just RcvSwitchStatus
RSSwitchStarted
            AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
corrId ConnId
connId Maybe SMPServer
forall a. Maybe a
Nothing (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ACommand -> AgentCommand
AClientCommand ACommand
SWCH
            let rqs' :: NonEmpty RcvQueue
rqs' = RcvQueue -> NonEmpty RcvQueue -> NonEmpty RcvQueue
forall q. SMPQueueRec q => q -> NonEmpty q -> NonEmpty q
updatedQs RcvQueue
rq1 NonEmpty RcvQueue
rqs
            AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c (Connection 'CDuplex -> AM ConnectionStats)
-> Connection 'CDuplex -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ ConnData
-> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection 'CDuplex
forall rq sq.
ConnData
-> NonEmpty rq -> NonEmpty sq -> Connection' 'CDuplex rq sq
DuplexConnection ConnData
cData NonEmpty RcvQueue
rqs' NonEmpty SndQueue
sqs
      SomeConn
_ -> AgentErrorType -> AM ConnectionStats
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnectionStats)
-> AgentErrorType -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"switchConnectionAsync: not duplex"

newConn :: ConnectionModeI c => AgentClient -> NetworkRequestMode -> UserId -> Bool -> Bool -> SConnectionMode c -> Maybe (UserConnLinkData c) -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
newConn :: forall (c :: ConnectionMode).
ConnectionModeI c =>
AgentClient
-> NetworkRequestMode
-> UserId
-> Bool
-> Bool
-> SConnectionMode c
-> Maybe (UserConnLinkData c)
-> Maybe Text
-> InitialKeys
-> SubscriptionMode
-> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
newConn AgentClient
c NetworkRequestMode
nm UserId
userId Bool
enableNtfs Bool
checkNotices SConnectionMode c
cMode Maybe (UserConnLinkData c)
linkData_ Maybe Text
clientData InitialKeys
pqInitKeys SubscriptionMode
subMode = do
  SMPServerWithAuth
srv <- AgentClient -> UserId -> AM SMPServerWithAuth
getSMPServer AgentClient
c UserId
userId
  Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
checkNotices Bool -> Bool -> Bool
&& SConnectionMode c -> ConnectionMode
forall (m :: ConnectionMode). SConnectionMode m -> ConnectionMode
connMode SConnectionMode c
cMode ConnectionMode -> ConnectionMode -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectionMode
CMContact) (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
$ AgentClient
-> SMPServerWithAuth -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkClientNotices AgentClient
c SMPServerWithAuth
srv
  ConnId
connId <- AgentClient
-> UserId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
forall (c :: ConnectionMode).
AgentClient
-> UserId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
newConnNoQueues AgentClient
c UserId
userId Bool
enableNtfs SConnectionMode c
cMode (InitialKeys -> PQSupport
CR.connPQEncryption InitialKeys
pqInitKeys)
  (ConnId
connId,)
    ((CreatedConnLink c, Maybe ClientServiceId)
 -> (ConnId, (CreatedConnLink c, Maybe ClientServiceId)))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (CreatedConnLink c, Maybe ClientServiceId)
-> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> SConnectionMode c
-> Maybe (UserConnLinkData c)
-> Maybe Text
-> InitialKeys
-> SubscriptionMode
-> SMPServerWithAuth
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (CreatedConnLink c, Maybe ClientServiceId)
forall (c :: ConnectionMode).
ConnectionModeI c =>
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> SConnectionMode c
-> Maybe (UserConnLinkData c)
-> Maybe Text
-> InitialKeys
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (CreatedConnLink c, Maybe ClientServiceId)
newRcvConnSrv AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId Bool
enableNtfs SConnectionMode c
cMode Maybe (UserConnLinkData c)
linkData_ Maybe Text
clientData InitialKeys
pqInitKeys SubscriptionMode
subMode SMPServerWithAuth
srv
      ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (CreatedConnLink c, Maybe ClientServiceId)
-> (AgentErrorType
    -> ExceptT
         AgentErrorType
         (ReaderT Env IO)
         (CreatedConnLink c, Maybe ClientServiceId))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (CreatedConnLink c, Maybe ClientServiceId)
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
`catchE` \AgentErrorType
e -> AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> ConnId -> IO ()
`deleteConnRecord` ConnId
connId) ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (CreatedConnLink c, Maybe ClientServiceId)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (CreatedConnLink c, Maybe ClientServiceId)
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
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (CreatedConnLink c, Maybe ClientServiceId)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e

-- | Prepare connection link for contact mode (no network, no database).
-- Caller provides root signing key pair and link entity ID.
prepareConnectionLink' :: AgentClient -> UserId -> C.KeyPairEd25519 -> ByteString -> Bool -> Maybe CRClientData -> AM (CreatedConnLink 'CMContact, PreparedLinkParams)
prepareConnectionLink' :: AgentClient
-> UserId
-> KeyPairEd25519
-> ConnId
-> Bool
-> Maybe Text
-> AM (CreatedConnLink 'CMContact, PreparedLinkParams)
prepareConnectionLink' AgentClient
c UserId
userId rootKey :: KeyPairEd25519
rootKey@(PublicKeyType PrivateKeyEd25519
_, PrivateKeyEd25519
plpRootPrivKey) ConnId
linkEntityId Bool
checkNotices Maybe Text
clientData = 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
  plpSrvWithAuth :: SMPServerWithAuth
plpSrvWithAuth@(ProtoServerWithAuth SMPServer
srv Maybe BasicAuth
_) <- AgentClient -> UserId -> AM SMPServerWithAuth
getSMPServer AgentClient
c UserId
userId
  Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkNotices (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
$ AgentClient
-> SMPServerWithAuth -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkClientNotices AgentClient
c SMPServerWithAuth
plpSrvWithAuth
  AgentConfig {VersionRangeSMPC
smpClientVRange :: VersionRangeSMPC
$sel:smpClientVRange:AgentConfig :: AgentConfig -> VersionRangeSMPC
smpClientVRange, VersionRange SMPAgentVersion
$sel:smpAgentVRange:AgentConfig :: AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange :: VersionRange SMPAgentVersion
smpAgentVRange} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
  plpNonce :: CbNonce
plpNonce@(C.CbNonce ConnId
corrId) <- 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
  plpQueueE2EKeys :: (PublicKeyX25519, PrivateKey 'X25519)
plpQueueE2EKeys@(PublicKeyX25519
e2ePubKey, PrivateKey 'X25519
_) <- STM (PublicKeyX25519, PrivateKey 'X25519)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PublicKeyX25519, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKeyX25519, PrivateKey 'X25519)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (PublicKeyX25519, PrivateKey 'X25519))
-> STM (PublicKeyX25519, PrivateKey 'X25519)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PublicKeyX25519, 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 sndId :: QueueId
sndId = ConnId -> QueueId
SMP.EntityId (ConnId -> QueueId) -> ConnId -> QueueId
forall a b. (a -> b) -> a -> b
$ Int -> ConnId -> ConnId
B.take Int
24 (ConnId -> ConnId) -> ConnId -> ConnId
forall a b. (a -> b) -> a -> b
$ ConnId -> ConnId
C.sha3_384 ConnId
corrId
      qUri :: SMPQueueUri
qUri = VersionRangeSMPC -> SMPQueueAddress -> SMPQueueUri
SMPQueueUri VersionRangeSMPC
smpClientVRange (SMPQueueAddress -> SMPQueueUri) -> SMPQueueAddress -> SMPQueueUri
forall a b. (a -> b) -> a -> b
$ SMPServer
-> QueueId -> PublicKeyX25519 -> Maybe QueueMode -> SMPQueueAddress
SMPQueueAddress SMPServer
srv QueueId
sndId PublicKeyX25519
e2ePubKey (QueueMode -> Maybe QueueMode
forall a. a -> Maybe a
Just QueueMode
QMContact)
      connReq :: ConnectionRequestUri 'CMContact
connReq = ConnReqUriData -> ConnectionRequestUri 'CMContact
CRContactUri (ConnReqUriData -> ConnectionRequestUri 'CMContact)
-> ConnReqUriData -> ConnectionRequestUri 'CMContact
forall a b. (a -> b) -> a -> b
$ ServiceScheme
-> VersionRange SMPAgentVersion
-> NonEmpty SMPQueueUri
-> Maybe Text
-> ConnReqUriData
ConnReqUriData ServiceScheme
SSSimplex VersionRange SMPAgentVersion
smpAgentVRange [Item (NonEmpty SMPQueueUri)
SMPQueueUri
qUri] Maybe Text
clientData
      (LinkKey
plpLinkKey, ConnId
plpSignedFixedData) = KeyPairEd25519
-> VersionRange SMPAgentVersion
-> ConnectionRequestUri 'CMContact
-> Maybe ConnId
-> (LinkKey, ConnId)
forall (c :: ConnectionMode).
ConnectionModeI c =>
KeyPairEd25519
-> VersionRange SMPAgentVersion
-> ConnectionRequestUri c
-> Maybe ConnId
-> (LinkKey, ConnId)
SL.encodeSignFixedData KeyPairEd25519
rootKey VersionRange SMPAgentVersion
smpAgentVRange ConnectionRequestUri 'CMContact
connReq (ConnId -> Maybe ConnId
forall a. a -> Maybe a
Just ConnId
linkEntityId)
      ccLink :: CreatedConnLink 'CMContact
ccLink = ConnectionRequestUri 'CMContact
-> Maybe (ConnShortLink 'CMContact) -> CreatedConnLink 'CMContact
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
CCLink ConnectionRequestUri 'CMContact
connReq (Maybe (ConnShortLink 'CMContact) -> CreatedConnLink 'CMContact)
-> Maybe (ConnShortLink 'CMContact) -> CreatedConnLink 'CMContact
forall a b. (a -> b) -> a -> b
$ ConnShortLink 'CMContact -> Maybe (ConnShortLink 'CMContact)
forall a. a -> Maybe a
Just (ConnShortLink 'CMContact -> Maybe (ConnShortLink 'CMContact))
-> ConnShortLink 'CMContact -> Maybe (ConnShortLink 'CMContact)
forall a b. (a -> b) -> a -> b
$ ShortLinkScheme
-> ContactConnType
-> SMPServer
-> LinkKey
-> ConnShortLink 'CMContact
CSLContact ShortLinkScheme
SLSServer ContactConnType
CCTContact SMPServer
srv LinkKey
plpLinkKey
      params :: PreparedLinkParams
params = PreparedLinkParams {CbNonce
plpNonce :: CbNonce
$sel:plpNonce:PreparedLinkParams :: CbNonce
plpNonce, KeyPair 'X25519
(PublicKeyX25519, PrivateKey 'X25519)
plpQueueE2EKeys :: (PublicKeyX25519, PrivateKey 'X25519)
$sel:plpQueueE2EKeys:PreparedLinkParams :: KeyPair 'X25519
plpQueueE2EKeys, LinkKey
plpLinkKey :: LinkKey
$sel:plpLinkKey:PreparedLinkParams :: LinkKey
plpLinkKey, PrivateKeyEd25519
plpRootPrivKey :: PrivateKeyEd25519
$sel:plpRootPrivKey:PreparedLinkParams :: PrivateKeyEd25519
plpRootPrivKey, ConnId
plpSignedFixedData :: ConnId
$sel:plpSignedFixedData:PreparedLinkParams :: ConnId
plpSignedFixedData, SMPServerWithAuth
plpSrvWithAuth :: SMPServerWithAuth
$sel:plpSrvWithAuth:PreparedLinkParams :: SMPServerWithAuth
plpSrvWithAuth}
  (CreatedConnLink 'CMContact, PreparedLinkParams)
-> AM (CreatedConnLink 'CMContact, PreparedLinkParams)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreatedConnLink 'CMContact
ccLink, PreparedLinkParams
params)

-- | Create connection for prepared link (single network call).
createConnectionForLink' :: AgentClient -> NetworkRequestMode -> UserId -> Bool -> CreatedConnLink 'CMContact -> PreparedLinkParams -> UserConnLinkData 'CMContact -> CR.InitialKeys -> SubscriptionMode -> AM ConnId
createConnectionForLink' :: AgentClient
-> NetworkRequestMode
-> UserId
-> Bool
-> CreatedConnLink 'CMContact
-> PreparedLinkParams
-> UserConnLinkData 'CMContact
-> InitialKeys
-> SubscriptionMode
-> AM ConnId
createConnectionForLink' AgentClient
c NetworkRequestMode
nm UserId
userId Bool
enableNtfs (CCLink ConnectionRequestUri 'CMContact
connReq Maybe (ConnShortLink 'CMContact)
_) PreparedLinkParams {CbNonce
$sel:plpNonce:PreparedLinkParams :: PreparedLinkParams -> CbNonce
plpNonce :: CbNonce
plpNonce, KeyPair 'X25519
$sel:plpQueueE2EKeys:PreparedLinkParams :: PreparedLinkParams -> KeyPair 'X25519
plpQueueE2EKeys :: KeyPair 'X25519
plpQueueE2EKeys, LinkKey
$sel:plpLinkKey:PreparedLinkParams :: PreparedLinkParams -> LinkKey
plpLinkKey :: LinkKey
plpLinkKey, PrivateKeyEd25519
$sel:plpRootPrivKey:PreparedLinkParams :: PreparedLinkParams -> PrivateKeyEd25519
plpRootPrivKey :: PrivateKeyEd25519
plpRootPrivKey, ConnId
$sel:plpSignedFixedData:PreparedLinkParams :: PreparedLinkParams -> ConnId
plpSignedFixedData :: ConnId
plpSignedFixedData, SMPServerWithAuth
$sel:plpSrvWithAuth:PreparedLinkParams :: PreparedLinkParams -> SMPServerWithAuth
plpSrvWithAuth :: SMPServerWithAuth
plpSrvWithAuth} UserConnLinkData 'CMContact
userLinkData InitialKeys
pqInitKeys SubscriptionMode
subMode = 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
  AgentConfig {VersionRange SMPAgentVersion
$sel:smpAgentVRange:AgentConfig :: AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange :: VersionRange SMPAgentVersion
smpAgentVRange} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
  case InitialKeys
pqInitKeys of
    InitialKeys
CR.IKUsePQ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"createConnectionForLink"
    InitialKeys
_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ConnId
connId <- AgentClient
-> UserId
-> Bool
-> SConnectionMode 'CMContact
-> PQSupport
-> AM ConnId
forall (c :: ConnectionMode).
AgentClient
-> UserId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
newConnNoQueues AgentClient
c UserId
userId Bool
enableNtfs SConnectionMode 'CMContact
SCMContact (InitialKeys -> PQSupport
CR.connPQEncryption InitialKeys
pqInitKeys)
  let CRContactUri ConnReqUriData {$sel:crSmpQueues:ConnReqUriData :: ConnReqUriData -> NonEmpty SMPQueueUri
crSmpQueues = SMPQueueUri VersionRangeSMPC
_ SMPQueueAddress {$sel:senderId:SMPQueueAddress :: SMPQueueAddress -> QueueId
senderId = QueueId
sndId} :| [SMPQueueUri]
_} = ConnectionRequestUri 'CMContact
connReq
      md :: ConnId
md = SConnectionMode 'CMContact
-> PrivateKeyEd25519
-> VersionRange SMPAgentVersion
-> UserConnLinkData 'CMContact
-> ConnId
forall (c :: ConnectionMode).
ConnectionModeI c =>
SConnectionMode c
-> PrivateKeyEd25519
-> VersionRange SMPAgentVersion
-> UserConnLinkData c
-> ConnId
SL.encodeSignUserData SConnectionMode 'CMContact
SCMContact PrivateKeyEd25519
plpRootPrivKey VersionRange SMPAgentVersion
smpAgentVRange UserConnLinkData 'CMContact
userLinkData
      linkData :: (ConnId, ConnId)
linkData = (ConnId
plpSignedFixedData, ConnId
md)
  ClntQueueReqData
qd <- TVar ChaChaDRG
-> PrivateKeyEd25519
-> LinkKey
-> QueueId
-> (ConnId, ConnId)
-> AM ClntQueueReqData
encryptContactLinkData TVar ChaChaDRG
g PrivateKeyEd25519
plpRootPrivKey LinkKey
plpLinkKey QueueId
sndId (ConnId, ConnId)
linkData
  (RcvQueue
_, SMPQueueUri
qUri) <-
    AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> SMPServerWithAuth
-> Bool
-> SubscriptionMode
-> Maybe CbNonce
-> ClntQueueReqData
-> KeyPair 'X25519
-> AM (RcvQueue, SMPQueueUri)
createRcvQueue AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId SMPServerWithAuth
plpSrvWithAuth Bool
enableNtfs SubscriptionMode
subMode (CbNonce -> Maybe CbNonce
forall a. a -> Maybe a
Just CbNonce
plpNonce) ClntQueueReqData
qd KeyPair 'X25519
plpQueueE2EKeys
      AM (RcvQueue, SMPQueueUri)
-> (AgentErrorType -> AM (RcvQueue, SMPQueueUri))
-> AM (RcvQueue, SMPQueueUri)
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
`catchE` \AgentErrorType
e -> AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> ConnId -> IO ()
`deleteConnRecord` ConnId
connId) ExceptT AgentErrorType (ReaderT Env IO) ()
-> AM (RcvQueue, SMPQueueUri) -> AM (RcvQueue, SMPQueueUri)
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 (RcvQueue, SMPQueueUri)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e
  let SMPQueueUri VersionRangeSMPC
_ SMPQueueAddress {$sel:senderId:SMPQueueAddress :: SMPQueueAddress -> QueueId
senderId = QueueId
actualSndId} = SMPQueueUri
qUri
  Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (QueueId
actualSndId QueueId -> QueueId -> Bool
forall a. Eq a => a -> a -> Bool
== QueueId
sndId) (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"createConnectionForLink: sender ID mismatch"
  ConnId -> AM ConnId
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnId
connId

-- | Encrypt signed link data for contact mode.
encryptContactLinkData :: TVar ChaChaDRG -> C.PrivateKeyEd25519 -> LinkKey -> SMP.SenderId -> (ByteString, ByteString) -> AM ClntQueueReqData
encryptContactLinkData :: TVar ChaChaDRG
-> PrivateKeyEd25519
-> LinkKey
-> QueueId
-> (ConnId, ConnId)
-> AM ClntQueueReqData
encryptContactLinkData TVar ChaChaDRG
g PrivateKeyEd25519
privSigKey LinkKey
linkKey QueueId
sndId (ConnId, ConnId)
linkData = do
  let (QueueId
linkId, SbKey
k) = LinkKey -> (QueueId, SbKey)
SL.contactShortLinkKdf LinkKey
linkKey
  QueueLinkData
srvData <- (AgentErrorType -> AgentErrorType)
-> ExceptT AgentErrorType IO QueueLinkData
-> ExceptT AgentErrorType (ReaderT Env IO) QueueLinkData
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError AgentErrorType -> AgentErrorType
forall a. a -> a
id (ExceptT AgentErrorType IO QueueLinkData
 -> ExceptT AgentErrorType (ReaderT Env IO) QueueLinkData)
-> ExceptT AgentErrorType IO QueueLinkData
-> ExceptT AgentErrorType (ReaderT Env IO) QueueLinkData
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> SbKey
-> (ConnId, ConnId)
-> ExceptT AgentErrorType IO QueueLinkData
SL.encryptLinkData TVar ChaChaDRG
g SbKey
k (ConnId, ConnId)
linkData
  ClntQueueReqData -> AM ClntQueueReqData
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClntQueueReqData -> AM ClntQueueReqData)
-> ClntQueueReqData -> AM ClntQueueReqData
forall a b. (a -> b) -> a -> b
$ Maybe (CQRData (QueueId, (QueueId, QueueLinkData)))
-> ClntQueueReqData
CQRContact (Maybe (CQRData (QueueId, (QueueId, QueueLinkData)))
 -> ClntQueueReqData)
-> Maybe (CQRData (QueueId, (QueueId, QueueLinkData)))
-> ClntQueueReqData
forall a b. (a -> b) -> a -> b
$ CQRData (QueueId, (QueueId, QueueLinkData))
-> Maybe (CQRData (QueueId, (QueueId, QueueLinkData)))
forall a. a -> Maybe a
Just CQRData {LinkKey
linkKey :: LinkKey
$sel:linkKey:CQRData :: LinkKey
linkKey, PrivateKeyEd25519
privSigKey :: PrivateKeyEd25519
$sel:privSigKey:CQRData :: PrivateKeyEd25519
privSigKey, $sel:srvReq:CQRData :: (QueueId, (QueueId, QueueLinkData))
srvReq = (QueueId
linkId, (QueueId
sndId, QueueLinkData
srvData))}

-- | Shared helper: create receive queue and set up subscriptions.
createRcvQueue :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> Bool -> SubscriptionMode -> Maybe C.CbNonce -> ClntQueueReqData -> C.KeyPairX25519 -> AM (RcvQueue, SMPQueueUri)
createRcvQueue :: AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> SMPServerWithAuth
-> Bool
-> SubscriptionMode
-> Maybe CbNonce
-> ClntQueueReqData
-> KeyPair 'X25519
-> AM (RcvQueue, SMPQueueUri)
createRcvQueue AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId srvWithAuth :: SMPServerWithAuth
srvWithAuth@(ProtoServerWithAuth SMPServer
srv Maybe BasicAuth
_) Bool
enableNtfs SubscriptionMode
subMode Maybe CbNonce
nonce_ ClntQueueReqData
qd KeyPair 'X25519
e2eKeys = do
  AgentConfig {$sel:smpClientVRange:AgentConfig :: AgentConfig -> VersionRangeSMPC
smpClientVRange = VersionRangeSMPC
vr} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
  Maybe NtfServer
ntfServer_ <- if Bool
enableNtfs then AM (Maybe NtfServer)
newQueueNtfServer else Maybe NtfServer -> AM (Maybe NtfServer)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NtfServer
forall a. Maybe a
Nothing
  (StoredRcvQueue 'DBNew
rq, SMPQueueUri
qUri, (UserId, SMPServer, Maybe ConnId)
tSess, ConnId
sessId) <-
    AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> SMPServerWithAuth
-> VersionRangeSMPC
-> ClntQueueReqData
-> Bool
-> SubscriptionMode
-> Maybe CbNonce
-> KeyPair 'X25519
-> AM
     (StoredRcvQueue 'DBNew, SMPQueueUri, TransportSession BrokerMsg,
      ConnId)
newRcvQueue_ AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId SMPServerWithAuth
srvWithAuth VersionRangeSMPC
vr ClntQueueReqData
qd (Maybe NtfServer -> Bool
forall a. Maybe a -> Bool
isJust Maybe NtfServer
ntfServer_) SubscriptionMode
subMode Maybe CbNonce
nonce_ KeyPair 'X25519
e2eKeys
      ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (StoredRcvQueue 'DBNew, SMPQueueUri,
   (UserId, SMPServer, Maybe ConnId), ConnId)
-> (AgentErrorType
    -> ExceptT
         AgentErrorType
         (ReaderT Env IO)
         (StoredRcvQueue 'DBNew, SMPQueueUri,
          (UserId, SMPServer, Maybe ConnId), ConnId))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (StoredRcvQueue 'DBNew, SMPQueueUri,
      (UserId, SMPServer, Maybe ConnId), ConnId)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \AgentErrorType
e -> 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 (AgentErrorType -> IO ()
forall a. Show a => a -> IO ()
print AgentErrorType
e) ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (StoredRcvQueue 'DBNew, SMPQueueUri,
      (UserId, SMPServer, Maybe ConnId), ConnId)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (StoredRcvQueue 'DBNew, SMPQueueUri,
      (UserId, SMPServer, Maybe ConnId), ConnId)
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
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (StoredRcvQueue 'DBNew, SMPQueueUri,
      (UserId, SMPServer, Maybe ConnId), ConnId)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e
  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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId SMPServer
srv AgentSMPServerStats -> TVar Int
connCreated
  RcvQueue
rq' <- AgentClient
-> (Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue)
-> (Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ConnId
-> StoredRcvQueue 'DBNew
-> SubscriptionMode
-> IO (Either StoreError RcvQueue)
updateNewConnRcv Connection
db ConnId
connId StoredRcvQueue 'DBNew
rq SubscriptionMode
subMode
  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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SubscriptionMode
subMode SubscriptionMode -> SubscriptionMode -> Bool
forall a. Eq a => a -> a -> Bool
== SubscriptionMode
SMSubscribe) (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> RcvQueue
-> TransportSession BrokerMsg
-> ConnId
-> ReaderT Env IO ()
addNewQueueSubscription AgentClient
c RcvQueue
rq' TransportSession BrokerMsg
(UserId, SMPServer, Maybe ConnId)
tSess ConnId
sessId
  (NtfServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Maybe NtfServer -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient
-> RcvQueue
-> NtfServer
-> ExceptT AgentErrorType (ReaderT Env IO) ()
newQueueNtfSubscription AgentClient
c RcvQueue
rq') Maybe NtfServer
ntfServer_
  (RcvQueue, SMPQueueUri) -> AM (RcvQueue, SMPQueueUri)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RcvQueue
rq', SMPQueueUri
qUri)

checkClientNotices :: AgentClient -> SMPServerWithAuth -> AM ()
checkClientNotices :: AgentClient
-> SMPServerWithAuth -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkClientNotices AgentClient {TMap (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
clientNotices :: TMap (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
$sel:clientNotices:AgentClient :: AgentClient -> TMap (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
clientNotices, [SMPServer]
presetServers :: [SMPServer]
$sel:presetServers:AgentClient :: AgentClient -> [SMPServer]
presetServers} (ProtoServerWithAuth srv :: SMPServer
srv@(ProtocolServer {NonEmpty TransportHost
host :: NonEmpty TransportHost
$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host}) Maybe BasicAuth
_) = do
  Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
notices <- TMap (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
clientNotices
  Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1)) -> Bool
forall k a. Map k a -> Bool
M.null Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
notices) (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
$ Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
-> RoundedSystemTime 1
-> ExceptT AgentErrorType (ReaderT Env IO) ()
checkNotices Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
notices (RoundedSystemTime 1 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) (RoundedSystemTime 1)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (RoundedSystemTime 1)
-> ExceptT AgentErrorType (ReaderT Env IO) (RoundedSystemTime 1)
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (RoundedSystemTime 1)
getSystemSeconds
  where
    srvKey :: Maybe SMPServer
srvKey
      | SMPServer -> [SMPServer] -> Bool
forall (t :: * -> *).
Foldable t =>
SMPServer -> t SMPServer -> Bool
isPresetServer SMPServer
srv [SMPServer]
presetServers = Maybe SMPServer
forall a. Maybe a
Nothing -- Nothing is used as key for preset servers
      | Bool
otherwise = SMPServer -> Maybe SMPServer
forall a. a -> Maybe a
Just SMPServer
srv
    checkNotices :: Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
-> RoundedSystemTime 1
-> ExceptT AgentErrorType (ReaderT Env IO) ()
checkNotices Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
notices RoundedSystemTime 1
ts =
      Maybe (Maybe (RoundedSystemTime 1))
-> (Maybe (RoundedSystemTime 1)
    -> 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 SMPServer
-> Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
-> Maybe (Maybe (RoundedSystemTime 1))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Maybe SMPServer
srvKey Map (Maybe SMPServer) (Maybe (RoundedSystemTime 1))
notices) ((Maybe (RoundedSystemTime 1)
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Maybe (RoundedSystemTime 1)
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Maybe (RoundedSystemTime 1)
expires_ ->
        Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
-> (RoundedSystemTime 1 -> Bool)
-> Maybe (RoundedSystemTime 1)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (RoundedSystemTime 1
ts RoundedSystemTime 1 -> RoundedSystemTime 1 -> Bool
forall a. Ord a => a -> a -> Bool
<) Maybe (RoundedSystemTime 1)
expires_) (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 a.
AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError NOTICE {$sel:server:CMD :: Text
server = ConnId -> Text
safeDecodeUtf8 (ConnId -> Text) -> ConnId -> Text
forall a b. (a -> b) -> a -> b
$ TransportHost -> ConnId
forall a. StrEncoding a => a -> ConnId
strEncode (TransportHost -> ConnId) -> TransportHost -> ConnId
forall a b. (a -> b) -> a -> b
$ NonEmpty TransportHost -> TransportHost
forall a. NonEmpty a -> a
L.head NonEmpty TransportHost
host, $sel:preset:CMD :: Bool
preset = Maybe SMPServer -> Bool
forall a. Maybe a -> Bool
isNothing Maybe SMPServer
srvKey, $sel:expiresAt:CMD :: Maybe InternalTs
expiresAt = RoundedSystemTime 1 -> InternalTs
forall (t :: Nat). RoundedSystemTime t -> InternalTs
roundedToUTCTime (RoundedSystemTime 1 -> InternalTs)
-> Maybe (RoundedSystemTime 1) -> Maybe InternalTs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RoundedSystemTime 1)
expires_}

setConnShortLinkAsync' :: AgentClient -> ACorrId -> ConnId -> UserConnLinkData 'CMContact -> Maybe CRClientData -> AM ()
setConnShortLinkAsync' :: AgentClient
-> ConnId
-> ConnId
-> UserConnLinkData 'CMContact
-> Maybe Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
setConnShortLinkAsync' AgentClient
c ConnId
corrId ConnId
connId UserConnLinkData 'CMContact
userLinkData Maybe Text
clientData =
  AgentClient
-> ConnId
-> Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
"setConnShortLinkAsync" (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
$ do
    SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
    SMPServer
srv <- case (Connection' d RcvQueue SndQueue
conn, UserConnLinkData 'CMContact
userLinkData) of
      (ContactConnection ConnData
_ RcvQueue {SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server :: SMPServer
server, Maybe ShortLinkCreds
shortLink :: Maybe ShortLinkCreds
$sel:shortLink:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Maybe ShortLinkCreds
shortLink}, UserContactLinkData UserContactData
d) -> do
        (String -> AgentErrorType)
-> Either String () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED (String -> AgentErrorType) -> ShowS -> String -> AgentErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"setConnShortLinkAsync: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>)) (Either String () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Either String () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ Maybe ShortLinkCreds -> UserContactData -> Either String ()
validateOwners Maybe ShortLinkCreds
shortLink UserContactData
d
        SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) SMPServer
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPServer
server
      (Connection' d RcvQueue SndQueue, UserConnLinkData 'CMContact)
_ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) SMPServer
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType
 -> ExceptT AgentErrorType (ReaderT Env IO) SMPServer)
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) SMPServer
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"setConnShortLinkAsync: invalid connection or mode"
    AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
corrId ConnId
connId (SMPServer -> Maybe SMPServer
forall a. a -> Maybe a
Just SMPServer
srv) (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ACommand -> AgentCommand
AClientCommand (ACommand -> AgentCommand) -> ACommand -> AgentCommand
forall a b. (a -> b) -> a -> b
$ UserConnLinkData 'CMContact -> Maybe Text -> ACommand
LSET UserConnLinkData 'CMContact
userLinkData Maybe Text
clientData

getConnShortLinkAsync' :: AgentClient -> UserId -> ACorrId -> Maybe ConnId -> ConnShortLink 'CMContact -> AM ConnId
getConnShortLinkAsync' :: AgentClient
-> UserId
-> ConnId
-> Maybe ConnId
-> ConnShortLink 'CMContact
-> AM ConnId
getConnShortLinkAsync' AgentClient
c UserId
userId ConnId
corrId Maybe ConnId
connId_ shortLink :: ConnShortLink 'CMContact
shortLink@(CSLContact ShortLinkScheme
_ ContactConnType
_ SMPServer
srv LinkKey
_) = do
  ConnId
connId <- case Maybe ConnId
connId_ of
    Just ConnId
existingConnId -> do
      -- connId and srv can be unrelated: connId is used as "mailbox" for LDATA delivery,
      -- while srv is the short link's server for the LGET request.
      -- E.g., owner's relay connection (connId, on server A) fetches relay's group link data (srv = server B).
      -- This works because enqueueCommand stores (connId, srv) independently in the commands table,
      -- the network request targets srv, and event delivery uses connId via corrId correlation.
      AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> IO (Maybe KeyHash) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe KeyHash) -> IO ()) -> IO (Maybe KeyHash) -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> SMPServer -> IO (Maybe KeyHash)
createServer Connection
db SMPServer
srv
      ConnId -> AM ConnId
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnId
existingConnId
    Maybe ConnId
Nothing -> 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
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError ConnId)) -> AM ConnId)
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
        IO (Maybe KeyHash) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe KeyHash) -> IO ()) -> IO (Maybe KeyHash) -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> SMPServer -> IO (Maybe KeyHash)
createServer Connection
db SMPServer
srv
        Connection -> TVar ChaChaDRG -> IO (Either StoreError ConnId)
prepareNewConn Connection
db TVar ChaChaDRG
g
  AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
corrId ConnId
connId (SMPServer -> Maybe SMPServer
forall a. a -> Maybe a
Just SMPServer
srv) (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ACommand -> AgentCommand
AClientCommand (ACommand -> AgentCommand) -> ACommand -> AgentCommand
forall a b. (a -> b) -> a -> b
$ ConnShortLink 'CMContact -> ACommand
LGET ConnShortLink 'CMContact
shortLink
  ConnId -> AM ConnId
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnId
connId
  where
    prepareNewConn :: Connection -> TVar ChaChaDRG -> IO (Either StoreError ConnId)
prepareNewConn Connection
db TVar ChaChaDRG
g = do
      let cData :: ConnData
cData =
            ConnData
              { UserId
$sel:userId:ConnData :: UserId
userId :: UserId
userId,
                $sel:connId:ConnData :: ConnId
connId = ConnId
"",
                $sel:connAgentVersion:ConnData :: VersionSMPA
connAgentVersion = VersionSMPA
currentSMPAgentVersion,
                $sel:enableNtfs:ConnData :: Bool
enableNtfs = Bool
False,
                $sel:lastExternalSndId:ConnData :: UserId
lastExternalSndId = UserId
0,
                $sel:deleted:ConnData :: Bool
deleted = Bool
False,
                $sel:ratchetSyncState:ConnData :: RatchetSyncState
ratchetSyncState = RatchetSyncState
RSOk,
                $sel:pqSupport:ConnData :: PQSupport
pqSupport = PQSupport
PQSupportOff
              }
      Connection
-> TVar ChaChaDRG
-> ConnData
-> SConnectionMode 'CMInvitation
-> IO (Either StoreError ConnId)
forall (c :: ConnectionMode).
Connection
-> TVar ChaChaDRG
-> ConnData
-> SConnectionMode c
-> IO (Either StoreError ConnId)
createNewConn Connection
db TVar ChaChaDRG
g ConnData
cData SConnectionMode 'CMInvitation
SCMInvitation

setConnShortLink' :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> UserConnLinkData c -> Maybe CRClientData -> AM (ConnShortLink c)
setConnShortLink' :: forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> ConnId
-> SConnectionMode c
-> UserConnLinkData c
-> Maybe Text
-> AM (ConnShortLink c)
setConnShortLink' AgentClient
c NetworkRequestMode
nm ConnId
connId SConnectionMode c
cMode UserConnLinkData c
userLinkData Maybe Text
clientData =
  AgentClient
-> ConnId -> Text -> AM (ConnShortLink c) -> AM (ConnShortLink c)
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
"setConnShortLink" (AM (ConnShortLink c) -> AM (ConnShortLink c))
-> AM (ConnShortLink c) -> AM (ConnShortLink c)
forall a b. (a -> b) -> a -> b
$ do
    SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
    (RcvQueue
rq, QueueId
lnkId, ConnShortLink c
sl, QueueLinkData
d) <- case (Connection' d RcvQueue SndQueue
conn, SConnectionMode c
cMode, UserConnLinkData c
userLinkData) of
      (ContactConnection ConnData
_ RcvQueue
rq, SConnectionMode c
SCMContact, d :: UserConnLinkData c
d@UserContactLinkData {}) -> RcvQueue
-> UserConnLinkData 'CMContact
-> AM (RcvQueue, QueueId, ConnShortLink 'CMContact, QueueLinkData)
prepareContactLinkData RcvQueue
rq UserConnLinkData c
UserConnLinkData 'CMContact
d
      (RcvConnection ConnData
_ RcvQueue
rq, SConnectionMode c
SCMInvitation, d :: UserConnLinkData c
d@UserInvLinkData {}) -> RcvQueue
-> UserConnLinkData 'CMInvitation
-> AM
     (RcvQueue, QueueId, ConnShortLink 'CMInvitation, QueueLinkData)
prepareInvLinkData RcvQueue
rq UserConnLinkData c
UserConnLinkData 'CMInvitation
d
      (Connection' d RcvQueue SndQueue, SConnectionMode c,
 UserConnLinkData c)
_ -> AgentErrorType
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RcvQueue, QueueId, ConnShortLink c, QueueLinkData)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (RcvQueue, QueueId, ConnShortLink c, QueueLinkData))
-> AgentErrorType
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RcvQueue, QueueId, ConnShortLink c, QueueLinkData)
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"setConnShortLink: invalid connection or mode"
    AgentClient
-> NetworkRequestMode
-> RcvQueue
-> QueueId
-> QueueLinkData
-> ExceptT AgentErrorType (ReaderT Env IO) ()
addQueueLink AgentClient
c NetworkRequestMode
nm RcvQueue
rq QueueId
lnkId QueueLinkData
d
    ConnShortLink c -> AM (ConnShortLink c)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnShortLink c
sl
  where
    prepareContactLinkData :: RcvQueue -> UserConnLinkData 'CMContact -> AM (RcvQueue, SMP.LinkId, ConnShortLink 'CMContact, QueueLinkData)
    prepareContactLinkData :: RcvQueue
-> UserConnLinkData 'CMContact
-> AM (RcvQueue, QueueId, ConnShortLink 'CMContact, QueueLinkData)
prepareContactLinkData rq :: RcvQueue
rq@RcvQueue {Maybe ShortLinkCreds
$sel:shortLink:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Maybe ShortLinkCreds
shortLink :: Maybe ShortLinkCreds
shortLink} ud :: UserConnLinkData 'CMContact
ud@(UserContactLinkData UserContactData
d') = do
      (String -> AgentErrorType)
-> Either String () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED (String -> AgentErrorType) -> ShowS -> String -> AgentErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"setConnShortLink: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>)) (Either String () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Either String () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ Maybe ShortLinkCreds -> UserContactData -> Either String ()
validateOwners Maybe ShortLinkCreds
shortLink UserContactData
d'
      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
      AgentConfig {$sel:smpClientVRange:AgentConfig :: AgentConfig -> VersionRangeSMPC
smpClientVRange = VersionRangeSMPC
vr, VersionRange SMPAgentVersion
$sel:smpAgentVRange:AgentConfig :: AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange :: VersionRange SMPAgentVersion
smpAgentVRange} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
      let cslContact :: LinkKey -> ConnShortLink 'CMContact
cslContact = ShortLinkScheme
-> ContactConnType
-> SMPServer
-> LinkKey
-> ConnShortLink 'CMContact
CSLContact ShortLinkScheme
SLSServer ContactConnType
CCTContact (RcvQueue -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer RcvQueue
rq)
      case Maybe ShortLinkCreds
shortLink of
        Just ShortLinkCreds {QueueId
shortLinkId :: QueueId
$sel:shortLinkId:ShortLinkCreds :: ShortLinkCreds -> QueueId
shortLinkId, LinkKey
shortLinkKey :: LinkKey
$sel:shortLinkKey:ShortLinkCreds :: ShortLinkCreds -> LinkKey
shortLinkKey, PrivateKeyEd25519
linkPrivSigKey :: PrivateKeyEd25519
$sel:linkPrivSigKey:ShortLinkCreds :: ShortLinkCreds -> PrivateKeyEd25519
linkPrivSigKey, EncFixedDataBytes
linkEncFixedData :: EncFixedDataBytes
$sel:linkEncFixedData:ShortLinkCreds :: ShortLinkCreds -> EncFixedDataBytes
linkEncFixedData} -> do
          let (QueueId
linkId, SbKey
k) = LinkKey -> (QueueId, SbKey)
SL.contactShortLinkKdf LinkKey
shortLinkKey
          Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (QueueId
shortLinkId QueueId -> QueueId -> Bool
forall a. Eq a => a -> a -> Bool
== QueueId
linkId) (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"setConnShortLink: link ID is not derived from link"
          EncFixedDataBytes
d <- (AgentErrorType -> AgentErrorType)
-> ExceptT AgentErrorType IO EncFixedDataBytes
-> ExceptT AgentErrorType (ReaderT Env IO) EncFixedDataBytes
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError AgentErrorType -> AgentErrorType
forall a. a -> a
id (ExceptT AgentErrorType IO EncFixedDataBytes
 -> ExceptT AgentErrorType (ReaderT Env IO) EncFixedDataBytes)
-> ExceptT AgentErrorType IO EncFixedDataBytes
-> ExceptT AgentErrorType (ReaderT Env IO) EncFixedDataBytes
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> SbKey -> ConnId -> ExceptT AgentErrorType IO EncFixedDataBytes
SL.encryptUserData TVar ChaChaDRG
g SbKey
k (ConnId -> ExceptT AgentErrorType IO EncFixedDataBytes)
-> ConnId -> ExceptT AgentErrorType IO EncFixedDataBytes
forall a b. (a -> b) -> a -> b
$ SConnectionMode 'CMContact
-> PrivateKeyEd25519
-> VersionRange SMPAgentVersion
-> UserConnLinkData 'CMContact
-> ConnId
forall (c :: ConnectionMode).
ConnectionModeI c =>
SConnectionMode c
-> PrivateKeyEd25519
-> VersionRange SMPAgentVersion
-> UserConnLinkData c
-> ConnId
SL.encodeSignUserData SConnectionMode 'CMContact
SCMContact PrivateKeyEd25519
linkPrivSigKey VersionRange SMPAgentVersion
smpAgentVRange UserConnLinkData 'CMContact
ud
          (RcvQueue, QueueId, ConnShortLink 'CMContact, QueueLinkData)
-> AM (RcvQueue, QueueId, ConnShortLink 'CMContact, QueueLinkData)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RcvQueue
rq, QueueId
linkId, LinkKey -> ConnShortLink 'CMContact
cslContact LinkKey
shortLinkKey, (EncFixedDataBytes
linkEncFixedData, EncFixedDataBytes
d))
        Maybe ShortLinkCreds
Nothing -> do
          sigKeys :: (PublicKey 'Ed25519, PrivateKeyEd25519)
sigKeys@(PublicKey 'Ed25519
_, PrivateKeyEd25519
privSigKey) <- STM KeyPairEd25519
-> ExceptT AgentErrorType (ReaderT Env IO) KeyPairEd25519
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM KeyPairEd25519
 -> ExceptT AgentErrorType (ReaderT Env IO) KeyPairEd25519)
-> STM KeyPairEd25519
-> ExceptT AgentErrorType (ReaderT Env IO) KeyPairEd25519
forall a b. (a -> b) -> a -> b
$ forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair @'C.Ed25519 TVar ChaChaDRG
g
          let qUri :: SMPQueueUri
qUri = VersionRangeSMPC -> SMPQueueAddress -> SMPQueueUri
SMPQueueUri VersionRangeSMPC
vr (SMPQueueAddress -> SMPQueueUri) -> SMPQueueAddress -> SMPQueueUri
forall a b. (a -> b) -> a -> b
$ (RcvQueue -> SMPQueueAddress
rcvSMPQueueAddress RcvQueue
rq) {queueMode = Just QMContact}
              connReq :: ConnectionRequestUri 'CMContact
connReq = ConnReqUriData -> ConnectionRequestUri 'CMContact
CRContactUri (ConnReqUriData -> ConnectionRequestUri 'CMContact)
-> ConnReqUriData -> ConnectionRequestUri 'CMContact
forall a b. (a -> b) -> a -> b
$ ServiceScheme
-> VersionRange SMPAgentVersion
-> NonEmpty SMPQueueUri
-> Maybe Text
-> ConnReqUriData
ConnReqUriData ServiceScheme
SSSimplex VersionRange SMPAgentVersion
smpAgentVRange [Item (NonEmpty SMPQueueUri)
SMPQueueUri
qUri] Maybe Text
clientData
              (LinkKey
linkKey, (ConnId, ConnId)
linkData) = KeyPairEd25519
-> VersionRange SMPAgentVersion
-> ConnectionRequestUri 'CMContact
-> Maybe ConnId
-> UserConnLinkData 'CMContact
-> (LinkKey, (ConnId, ConnId))
forall (c :: ConnectionMode).
ConnectionModeI c =>
KeyPairEd25519
-> VersionRange SMPAgentVersion
-> ConnectionRequestUri c
-> Maybe ConnId
-> UserConnLinkData c
-> (LinkKey, (ConnId, ConnId))
SL.encodeSignLinkData KeyPairEd25519
(PublicKey 'Ed25519, PrivateKeyEd25519)
sigKeys VersionRange SMPAgentVersion
smpAgentVRange ConnectionRequestUri 'CMContact
connReq Maybe ConnId
forall a. Maybe a
Nothing UserConnLinkData 'CMContact
ud
              (QueueId
linkId, SbKey
k) = LinkKey -> (QueueId, SbKey)
SL.contactShortLinkKdf LinkKey
linkKey
          QueueLinkData
srvData <- (AgentErrorType -> AgentErrorType)
-> ExceptT AgentErrorType IO QueueLinkData
-> ExceptT AgentErrorType (ReaderT Env IO) QueueLinkData
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError AgentErrorType -> AgentErrorType
forall a. a -> a
id (ExceptT AgentErrorType IO QueueLinkData
 -> ExceptT AgentErrorType (ReaderT Env IO) QueueLinkData)
-> ExceptT AgentErrorType IO QueueLinkData
-> ExceptT AgentErrorType (ReaderT Env IO) QueueLinkData
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> SbKey
-> (ConnId, ConnId)
-> ExceptT AgentErrorType IO QueueLinkData
SL.encryptLinkData TVar ChaChaDRG
g SbKey
k (ConnId, ConnId)
linkData
          let slCreds :: ShortLinkCreds
slCreds = QueueId
-> LinkKey
-> PrivateKeyEd25519
-> Maybe (PublicKey 'Ed25519)
-> EncFixedDataBytes
-> ShortLinkCreds
ShortLinkCreds QueueId
linkId LinkKey
linkKey PrivateKeyEd25519
privSigKey Maybe (PublicKey 'Ed25519)
forall a. Maybe a
Nothing (QueueLinkData -> EncFixedDataBytes
forall a b. (a, b) -> a
fst QueueLinkData
srvData)
          AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvQueue -> ShortLinkCreds -> IO ()
updateShortLinkCreds Connection
db RcvQueue
rq ShortLinkCreds
slCreds
          (RcvQueue, QueueId, ConnShortLink 'CMContact, QueueLinkData)
-> AM (RcvQueue, QueueId, ConnShortLink 'CMContact, QueueLinkData)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RcvQueue
rq, QueueId
linkId, LinkKey -> ConnShortLink 'CMContact
cslContact LinkKey
linkKey, QueueLinkData
srvData)
    prepareInvLinkData :: RcvQueue -> UserConnLinkData 'CMInvitation -> AM (RcvQueue, SMP.LinkId, ConnShortLink 'CMInvitation, QueueLinkData)
    prepareInvLinkData :: RcvQueue
-> UserConnLinkData 'CMInvitation
-> AM
     (RcvQueue, QueueId, ConnShortLink 'CMInvitation, QueueLinkData)
prepareInvLinkData rq :: RcvQueue
rq@RcvQueue {Maybe ShortLinkCreds
$sel:shortLink:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Maybe ShortLinkCreds
shortLink :: Maybe ShortLinkCreds
shortLink} UserConnLinkData 'CMInvitation
ud = case Maybe ShortLinkCreds
shortLink of
      Just ShortLinkCreds {QueueId
$sel:shortLinkId:ShortLinkCreds :: ShortLinkCreds -> QueueId
shortLinkId :: QueueId
shortLinkId, LinkKey
$sel:shortLinkKey:ShortLinkCreds :: ShortLinkCreds -> LinkKey
shortLinkKey :: LinkKey
shortLinkKey, PrivateKeyEd25519
$sel:linkPrivSigKey:ShortLinkCreds :: ShortLinkCreds -> PrivateKeyEd25519
linkPrivSigKey :: PrivateKeyEd25519
linkPrivSigKey, EncFixedDataBytes
$sel:linkEncFixedData:ShortLinkCreds :: ShortLinkCreds -> EncFixedDataBytes
linkEncFixedData :: EncFixedDataBytes
linkEncFixedData} -> 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
        AgentConfig {VersionRange SMPAgentVersion
$sel:smpAgentVRange:AgentConfig :: AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange :: VersionRange SMPAgentVersion
smpAgentVRange} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
        let k :: SbKey
k = LinkKey -> SbKey
SL.invShortLinkKdf LinkKey
shortLinkKey
        EncFixedDataBytes
d <- (AgentErrorType -> AgentErrorType)
-> ExceptT AgentErrorType IO EncFixedDataBytes
-> ExceptT AgentErrorType (ReaderT Env IO) EncFixedDataBytes
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError AgentErrorType -> AgentErrorType
forall a. a -> a
id (ExceptT AgentErrorType IO EncFixedDataBytes
 -> ExceptT AgentErrorType (ReaderT Env IO) EncFixedDataBytes)
-> ExceptT AgentErrorType IO EncFixedDataBytes
-> ExceptT AgentErrorType (ReaderT Env IO) EncFixedDataBytes
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> SbKey -> ConnId -> ExceptT AgentErrorType IO EncFixedDataBytes
SL.encryptUserData TVar ChaChaDRG
g SbKey
k (ConnId -> ExceptT AgentErrorType IO EncFixedDataBytes)
-> ConnId -> ExceptT AgentErrorType IO EncFixedDataBytes
forall a b. (a -> b) -> a -> b
$ SConnectionMode 'CMInvitation
-> PrivateKeyEd25519
-> VersionRange SMPAgentVersion
-> UserConnLinkData 'CMInvitation
-> ConnId
forall (c :: ConnectionMode).
ConnectionModeI c =>
SConnectionMode c
-> PrivateKeyEd25519
-> VersionRange SMPAgentVersion
-> UserConnLinkData c
-> ConnId
SL.encodeSignUserData SConnectionMode 'CMInvitation
SCMInvitation PrivateKeyEd25519
linkPrivSigKey VersionRange SMPAgentVersion
smpAgentVRange UserConnLinkData 'CMInvitation
ud
        let sl :: ConnShortLink 'CMInvitation
sl = ShortLinkScheme
-> SMPServer -> QueueId -> LinkKey -> ConnShortLink 'CMInvitation
CSLInvitation ShortLinkScheme
SLSServer (RcvQueue -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer RcvQueue
rq) QueueId
shortLinkId LinkKey
shortLinkKey
        (RcvQueue, QueueId, ConnShortLink 'CMInvitation, QueueLinkData)
-> AM
     (RcvQueue, QueueId, ConnShortLink 'CMInvitation, QueueLinkData)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RcvQueue
rq, QueueId
shortLinkId, ConnShortLink 'CMInvitation
sl, (EncFixedDataBytes
linkEncFixedData, EncFixedDataBytes
d))
      Maybe ShortLinkCreds
Nothing -> AgentErrorType
-> AM
     (RcvQueue, QueueId, ConnShortLink 'CMInvitation, QueueLinkData)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType
 -> AM
      (RcvQueue, QueueId, ConnShortLink 'CMInvitation, QueueLinkData))
-> AgentErrorType
-> AM
     (RcvQueue, QueueId, ConnShortLink 'CMInvitation, QueueLinkData)
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"setConnShortLink: no ShortLinkCreds in invitation"

deleteConnShortLink' :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> AM ()
deleteConnShortLink' :: forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> ConnId
-> SConnectionMode c
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnShortLink' AgentClient
c NetworkRequestMode
nm ConnId
connId SConnectionMode c
cMode =
  AgentClient
-> ConnId
-> Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
"deleteConnShortLink" (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
$ do
    SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
    case (Connection' d RcvQueue SndQueue
conn, SConnectionMode c
cMode) of
      (ContactConnection ConnData
_ RcvQueue
rq, SConnectionMode c
SCMContact) -> AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteQueueLink AgentClient
c NetworkRequestMode
nm RcvQueue
rq
      (RcvConnection ConnData
_ RcvQueue
rq, SConnectionMode c
SCMInvitation) -> AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteQueueLink AgentClient
c NetworkRequestMode
nm RcvQueue
rq
      (Connection' d RcvQueue SndQueue, SConnectionMode c)
_ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"deleteConnShortLink: not contact address"

getConnLinkPrivKey' :: AgentClient -> ConnId -> AM (Maybe C.PrivateKeyEd25519)
getConnLinkPrivKey' :: AgentClient -> ConnId -> AM (Maybe PrivateKeyEd25519)
getConnLinkPrivKey' AgentClient
c ConnId
connId = do
  SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
  Maybe PrivateKeyEd25519 -> AM (Maybe PrivateKeyEd25519)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PrivateKeyEd25519 -> AM (Maybe PrivateKeyEd25519))
-> Maybe PrivateKeyEd25519 -> AM (Maybe PrivateKeyEd25519)
forall a b. (a -> b) -> a -> b
$ case Connection' d RcvQueue SndQueue
conn of
    ContactConnection ConnData
_ RcvQueue
rq -> ShortLinkCreds -> PrivateKeyEd25519
linkPrivSigKey (ShortLinkCreds -> PrivateKeyEd25519)
-> Maybe ShortLinkCreds -> Maybe PrivateKeyEd25519
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RcvQueue -> Maybe ShortLinkCreds
forall (q :: DBStored). StoredRcvQueue q -> Maybe ShortLinkCreds
shortLink RcvQueue
rq
    RcvConnection ConnData
_ RcvQueue
rq -> ShortLinkCreds -> PrivateKeyEd25519
linkPrivSigKey (ShortLinkCreds -> PrivateKeyEd25519)
-> Maybe ShortLinkCreds -> Maybe PrivateKeyEd25519
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RcvQueue -> Maybe ShortLinkCreds
forall (q :: DBStored). StoredRcvQueue q -> Maybe ShortLinkCreds
shortLink RcvQueue
rq
    Connection' d RcvQueue SndQueue
_ -> Maybe PrivateKeyEd25519
forall a. Maybe a
Nothing

-- TODO [short links] remove 1-time invitation data and link ID from the server after the message is sent.
getConnShortLink' :: forall c. AgentClient -> NetworkRequestMode -> UserId -> ConnShortLink c -> AM (FixedLinkData c, ConnLinkData c)
getConnShortLink' :: forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnShortLink c
-> AM (FixedLinkData c, ConnLinkData c)
getConnShortLink' AgentClient
c NetworkRequestMode
nm UserId
userId = \case
  CSLInvitation ShortLinkScheme
_ SMPServer
srv QueueId
linkId LinkKey
linkKey -> 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
    InvShortLink
invLink <- AgentClient -> (Connection -> IO InvShortLink) -> AM InvShortLink
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO InvShortLink) -> AM InvShortLink)
-> (Connection -> IO InvShortLink) -> AM InvShortLink
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
      Connection -> SMPServer -> QueueId -> IO (Maybe InvShortLink)
getInvShortLink Connection
db SMPServer
srv QueueId
linkId IO (Maybe InvShortLink)
-> (Maybe InvShortLink -> IO InvShortLink) -> IO InvShortLink
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 sl :: InvShortLink
sl@InvShortLink {$sel:linkKey:InvShortLink :: InvShortLink -> LinkKey
linkKey = LinkKey
lk} | LinkKey
linkKey LinkKey -> LinkKey -> Bool
forall a. Eq a => a -> a -> Bool
== LinkKey
lk -> InvShortLink -> IO InvShortLink
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InvShortLink
sl
        Maybe InvShortLink
_ -> do
          APrivateAuthKey
sndPrivateKey <- STM APrivateAuthKey -> IO APrivateAuthKey
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM APrivateAuthKey -> IO APrivateAuthKey)
-> STM APrivateAuthKey -> IO APrivateAuthKey
forall a b. (a -> b) -> a -> b
$ SAlgorithm 'Ed25519 -> TVar ChaChaDRG -> STM APrivateAuthKey
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM APrivateAuthKey
C.generatePrivateAuthKey SAlgorithm 'Ed25519
C.SEd25519 TVar ChaChaDRG
g
          let sl :: InvShortLink
sl = InvShortLink {$sel:server:InvShortLink :: SMPServer
server = SMPServer
srv, QueueId
linkId :: QueueId
$sel:linkId:InvShortLink :: QueueId
linkId, LinkKey
linkKey :: LinkKey
$sel:linkKey:InvShortLink :: LinkKey
linkKey, APrivateAuthKey
sndPrivateKey :: APrivateAuthKey
$sel:sndPrivateKey:InvShortLink :: APrivateAuthKey
sndPrivateKey, $sel:sndId:InvShortLink :: Maybe QueueId
sndId = Maybe QueueId
forall a. Maybe a
Nothing}
          Connection -> InvShortLink -> IO ()
createInvShortLink Connection
db InvShortLink
sl
          InvShortLink -> IO InvShortLink
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InvShortLink
sl
    let k :: SbKey
k = LinkKey -> SbKey
SL.invShortLinkKdf LinkKey
linkKey
    ld :: (QueueId, QueueLinkData)
ld@(QueueId
sndId, QueueLinkData
_) <- AgentClient
-> NetworkRequestMode
-> UserId
-> InvShortLink
-> AM (QueueId, QueueLinkData)
secureGetQueueLink AgentClient
c NetworkRequestMode
nm UserId
userId InvShortLink
invLink
    AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> InvShortLink -> QueueId -> IO ()
setInvShortLinkSndId Connection
db InvShortLink
invLink QueueId
sndId
    SMPServer
-> LinkKey
-> SbKey
-> (QueueId, QueueLinkData)
-> AM (FixedLinkData c, ConnLinkData c)
ConnectionModeI c =>
SMPServer
-> LinkKey
-> SbKey
-> (QueueId, QueueLinkData)
-> AM (FixedLinkData c, ConnLinkData c)
decryptData SMPServer
srv LinkKey
linkKey SbKey
k (QueueId, QueueLinkData)
ld
  CSLContact ShortLinkScheme
_ ContactConnType
_ SMPServer
srv LinkKey
linkKey -> do
    let (QueueId
linkId, SbKey
k) = LinkKey -> (QueueId, SbKey)
SL.contactShortLinkKdf LinkKey
linkKey
    (QueueId, QueueLinkData)
ld <- AgentClient
-> NetworkRequestMode
-> UserId
-> SMPServer
-> QueueId
-> AM (QueueId, QueueLinkData)
getQueueLink AgentClient
c NetworkRequestMode
nm UserId
userId SMPServer
srv QueueId
linkId
    SMPServer
-> LinkKey
-> SbKey
-> (QueueId, QueueLinkData)
-> AM (FixedLinkData c, ConnLinkData c)
ConnectionModeI c =>
SMPServer
-> LinkKey
-> SbKey
-> (QueueId, QueueLinkData)
-> AM (FixedLinkData c, ConnLinkData c)
decryptData SMPServer
srv LinkKey
linkKey SbKey
k (QueueId, QueueLinkData)
ld
  where
    decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, QueueLinkData) -> AM (FixedLinkData c, ConnLinkData c)
    decryptData :: ConnectionModeI c =>
SMPServer
-> LinkKey
-> SbKey
-> (QueueId, QueueLinkData)
-> AM (FixedLinkData c, ConnLinkData c)
decryptData SMPServer
srv LinkKey
linkKey SbKey
k (QueueId
sndId, QueueLinkData
d) = do
      r :: (FixedLinkData c, ConnLinkData c)
r@(FixedLinkData c
fd, ConnLinkData c
clData) <- Either AgentErrorType (FixedLinkData c, ConnLinkData c)
-> AM (FixedLinkData c, ConnLinkData c)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either AgentErrorType (FixedLinkData c, ConnLinkData c)
 -> AM (FixedLinkData c, ConnLinkData c))
-> Either AgentErrorType (FixedLinkData c, ConnLinkData c)
-> AM (FixedLinkData c, ConnLinkData c)
forall a b. (a -> b) -> a -> b
$ forall (c :: ConnectionMode).
ConnectionModeI c =>
LinkKey
-> SbKey
-> QueueLinkData
-> Either AgentErrorType (FixedLinkData c, ConnLinkData c)
SL.decryptLinkData @c LinkKey
linkKey SbKey
k QueueLinkData
d
      let (SMPServer
srv', QueueId
sndId') = SMPQueueUri -> (SMPServer, QueueId)
forall q. SMPQueue q => q -> (SMPServer, QueueId)
qAddress (ConnectionRequestUri c -> SMPQueueUri
forall (c :: ConnectionMode). ConnectionRequestUri c -> SMPQueueUri
connReqQueue (ConnectionRequestUri c -> SMPQueueUri)
-> ConnectionRequestUri c -> SMPQueueUri
forall a b. (a -> b) -> a -> b
$ FixedLinkData c -> ConnectionRequestUri c
forall (c :: ConnectionMode).
FixedLinkData c -> ConnectionRequestUri c
linkConnReq FixedLinkData c
fd)
      Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SMPServer
srv SMPServer -> SMPServer -> Bool
forall {p :: ProtocolType} {p :: ProtocolType}.
ProtocolServer p -> ProtocolServer p -> Bool
`sameSrvHost` SMPServer
srv' Bool -> Bool -> Bool
&& QueueId
sndId QueueId -> QueueId -> Bool
forall a. Eq a => a -> a -> Bool
== QueueId
sndId') (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT (SMPAgentError -> AgentErrorType)
-> SMPAgentError -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String -> SMPAgentError
A_LINK String
"different address"
      (FixedLinkData c, ConnLinkData c)
-> AM (FixedLinkData c, ConnLinkData c)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FixedLinkData c, ConnLinkData c)
 -> AM (FixedLinkData c, ConnLinkData c))
-> (FixedLinkData c, ConnLinkData c)
-> AM (FixedLinkData c, ConnLinkData c)
forall a b. (a -> b) -> a -> b
$ if SMPServer
srv' SMPServer -> SMPServer -> Bool
forall a. Eq a => a -> a -> Bool
== SMPServer
srv then (FixedLinkData c, ConnLinkData c)
r else (SMPServer -> FixedLinkData c -> FixedLinkData c
updateConnReqServer SMPServer
srv FixedLinkData c
fd, ConnLinkData c
clData)
    sameSrvHost :: ProtocolServer p -> ProtocolServer p -> Bool
sameSrvHost ProtocolServer {$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host = TransportHost
h :| [TransportHost]
_} ProtocolServer {$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host = NonEmpty TransportHost
hs} = TransportHost
h TransportHost -> NonEmpty TransportHost -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NonEmpty TransportHost
hs
    updateConnReqServer :: SMPServer -> FixedLinkData c -> FixedLinkData c
    updateConnReqServer :: SMPServer -> FixedLinkData c -> FixedLinkData c
updateConnReqServer SMPServer
srv FixedLinkData c
fd =
      let connReq' :: ConnectionRequestUri c
connReq' = case FixedLinkData c -> ConnectionRequestUri c
forall (c :: ConnectionMode).
FixedLinkData c -> ConnectionRequestUri c
linkConnReq FixedLinkData c
fd of
            CRInvitationUri ConnReqUriData
crData RcvE2ERatchetParamsUri 'X448
e2eParams -> ConnReqUriData
-> RcvE2ERatchetParamsUri 'X448
-> ConnectionRequestUri 'CMInvitation
CRInvitationUri (ConnReqUriData -> ConnReqUriData
updateQueues ConnReqUriData
crData) RcvE2ERatchetParamsUri 'X448
e2eParams
            CRContactUri ConnReqUriData
crData -> ConnReqUriData -> ConnectionRequestUri 'CMContact
CRContactUri (ConnReqUriData -> ConnectionRequestUri 'CMContact)
-> ConnReqUriData -> ConnectionRequestUri 'CMContact
forall a b. (a -> b) -> a -> b
$ ConnReqUriData -> ConnReqUriData
updateQueues ConnReqUriData
crData
       in FixedLinkData c
fd {linkConnReq = connReq'}
      where
        updateQueues :: ConnReqUriData -> ConnReqUriData
updateQueues crData :: ConnReqUriData
crData@(ConnReqUriData {$sel:crSmpQueues:ConnReqUriData :: ConnReqUriData -> NonEmpty SMPQueueUri
crSmpQueues = SMPQueueUri VersionRangeSMPC
vr SMPQueueAddress
addr :| [SMPQueueUri]
qs}) =
          ConnReqUriData
crData {crSmpQueues = SMPQueueUri vr addr {smpServer = srv} :| qs}

deleteLocalInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM ()
deleteLocalInvShortLink' :: AgentClient
-> ConnShortLink 'CMInvitation
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteLocalInvShortLink' AgentClient
c (CSLInvitation ShortLinkScheme
_ SMPServer
srv QueueId
linkId LinkKey
_) = AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> SMPServer -> QueueId -> IO ()
deleteInvShortLink Connection
db SMPServer
srv QueueId
linkId

changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM ()
changeConnectionUser' :: AgentClient
-> UserId
-> ConnId
-> UserId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
changeConnectionUser' AgentClient
c UserId
oldUserId ConnId
connId UserId
newUserId = do
  SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
  case Connection' d RcvQueue SndQueue
conn of
    NewConnection {} -> ExceptT AgentErrorType (ReaderT Env IO) ()
updateConn
    RcvConnection {} -> ExceptT AgentErrorType (ReaderT Env IO) ()
updateConn
    Connection' d RcvQueue SndQueue
_ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"changeConnectionUser: established connection"
  where
    updateConn :: ExceptT AgentErrorType (ReaderT Env IO) ()
updateConn = AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> ConnId -> UserId -> IO ()
setConnUserId Connection
db UserId
oldUserId ConnId
connId UserId
newUserId

newRcvConnSrv :: forall c. ConnectionModeI c => AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe (UserConnLinkData c) -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (CreatedConnLink c, Maybe ClientServiceId)
newRcvConnSrv :: forall (c :: ConnectionMode).
ConnectionModeI c =>
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> SConnectionMode c
-> Maybe (UserConnLinkData c)
-> Maybe Text
-> InitialKeys
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (CreatedConnLink c, Maybe ClientServiceId)
newRcvConnSrv AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId Bool
enableNtfs SConnectionMode c
cMode Maybe (UserConnLinkData c)
userLinkData_ Maybe Text
clientData InitialKeys
pqInitKeys SubscriptionMode
subMode srvWithAuth :: SMPServerWithAuth
srvWithAuth@(ProtoServerWithAuth SMPServer
srv Maybe BasicAuth
_) = do
  case (SConnectionMode c
cMode, InitialKeys
pqInitKeys) of
    (SConnectionMode c
SCMContact, InitialKeys
CR.IKUsePQ) -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"newRcvConnSrv"
    (SConnectionMode c, InitialKeys)
_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  (PublicKeyX25519, PrivateKey 'X25519)
e2eKeys <- STM (PublicKeyX25519, PrivateKey 'X25519)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PublicKeyX25519, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKeyX25519, PrivateKey 'X25519)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (PublicKeyX25519, PrivateKey 'X25519))
-> (TVar ChaChaDRG -> STM (PublicKeyX25519, PrivateKey 'X25519))
-> TVar ChaChaDRG
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PublicKeyX25519, PrivateKey 'X25519)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChaChaDRG -> STM (KeyPair 'X25519)
TVar ChaChaDRG -> STM (PublicKeyX25519, PrivateKey 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair (TVar ChaChaDRG
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (PublicKeyX25519, PrivateKey 'X25519))
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PublicKeyX25519, 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
  case Maybe (UserConnLinkData c)
userLinkData_ of
    Just UserConnLinkData c
d -> do
      (CbNonce
nonce, SMPQueueUri
qUri, ConnectionRequestUri c
cReq, ClntQueueReqData
qd) <- UserConnLinkData c
-> PublicKeyX25519
-> AM
     (CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData)
prepareLinkData UserConnLinkData c
d (PublicKeyX25519
 -> AM
      (CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData))
-> PublicKeyX25519
-> AM
     (CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData)
forall a b. (a -> b) -> a -> b
$ (PublicKeyX25519, PrivateKey 'X25519) -> PublicKeyX25519
forall a b. (a, b) -> a
fst (PublicKeyX25519, PrivateKey 'X25519)
e2eKeys
      (RcvQueue
rq, SMPQueueUri
qUri') <- AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> SMPServerWithAuth
-> Bool
-> SubscriptionMode
-> Maybe CbNonce
-> ClntQueueReqData
-> KeyPair 'X25519
-> AM (RcvQueue, SMPQueueUri)
createRcvQueue AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId SMPServerWithAuth
srvWithAuth Bool
enableNtfs SubscriptionMode
subMode (CbNonce -> Maybe CbNonce
forall a. a -> Maybe a
Just CbNonce
nonce) ClntQueueReqData
qd KeyPair 'X25519
(PublicKeyX25519, PrivateKey 'X25519)
e2eKeys
      CreatedConnLink c
ccLink <- SMPQueueUri
-> ConnectionRequestUri c
-> SMPQueueUri
-> Maybe ShortLinkCreds
-> AM (CreatedConnLink c)
connReqWithShortLink SMPQueueUri
qUri ConnectionRequestUri c
cReq SMPQueueUri
qUri' (RcvQueue -> Maybe ShortLinkCreds
forall (q :: DBStored). StoredRcvQueue q -> Maybe ShortLinkCreds
shortLink RcvQueue
rq)
      (CreatedConnLink c, Maybe ClientServiceId)
-> AM (CreatedConnLink c, Maybe ClientServiceId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreatedConnLink c
ccLink, RcvQueue -> Maybe ClientServiceId
clientServiceId RcvQueue
rq)
    Maybe (UserConnLinkData c)
Nothing -> do
      let qd :: ClntQueueReqData
qd = case SConnectionMode c
cMode of SConnectionMode c
SCMContact -> Maybe (CQRData (QueueId, (QueueId, QueueLinkData)))
-> ClntQueueReqData
CQRContact Maybe (CQRData (QueueId, (QueueId, QueueLinkData)))
forall a. Maybe a
Nothing; SConnectionMode c
SCMInvitation -> Maybe (CQRData (QueueId, QueueLinkData)) -> ClntQueueReqData
CQRMessaging Maybe (CQRData (QueueId, QueueLinkData))
forall a. Maybe a
Nothing
      (RcvQueue
rq, SMPQueueUri
qUri) <- AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> SMPServerWithAuth
-> Bool
-> SubscriptionMode
-> Maybe CbNonce
-> ClntQueueReqData
-> KeyPair 'X25519
-> AM (RcvQueue, SMPQueueUri)
createRcvQueue AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId SMPServerWithAuth
srvWithAuth Bool
enableNtfs SubscriptionMode
subMode Maybe CbNonce
forall a. Maybe a
Nothing ClntQueueReqData
qd KeyPair 'X25519
(PublicKeyX25519, PrivateKey 'X25519)
e2eKeys
      ConnectionRequestUri c
cReq <- SMPQueueUri -> AM (ConnectionRequestUri c)
createConnReq SMPQueueUri
qUri
      (CreatedConnLink c, Maybe ClientServiceId)
-> AM (CreatedConnLink c, Maybe ClientServiceId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectionRequestUri c
-> Maybe (ConnShortLink c) -> CreatedConnLink c
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
CCLink ConnectionRequestUri c
cReq Maybe (ConnShortLink c)
forall a. Maybe a
Nothing, RcvQueue -> Maybe ClientServiceId
clientServiceId RcvQueue
rq)
  where
    createConnReq :: SMPQueueUri -> AM (ConnectionRequestUri c)
    createConnReq :: SMPQueueUri -> AM (ConnectionRequestUri c)
createConnReq SMPQueueUri
qUri = do
      AgentConfig {VersionRange SMPAgentVersion
$sel:smpAgentVRange:AgentConfig :: AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange :: VersionRange SMPAgentVersion
smpAgentVRange, VersionRangeE2E
e2eEncryptVRange :: VersionRangeE2E
$sel:e2eEncryptVRange:AgentConfig :: AgentConfig -> VersionRangeE2E
e2eEncryptVRange} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
      let crData :: ConnReqUriData
crData = ServiceScheme
-> VersionRange SMPAgentVersion
-> NonEmpty SMPQueueUri
-> Maybe Text
-> ConnReqUriData
ConnReqUriData ServiceScheme
SSSimplex VersionRange SMPAgentVersion
smpAgentVRange [Item (NonEmpty SMPQueueUri)
SMPQueueUri
qUri] Maybe Text
clientData
      case SConnectionMode c
cMode of
        SConnectionMode c
SCMContact -> ConnectionRequestUri 'CMContact
-> ExceptT
     AgentErrorType (ReaderT Env IO) (ConnectionRequestUri 'CMContact)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectionRequestUri 'CMContact
 -> ExceptT
      AgentErrorType (ReaderT Env IO) (ConnectionRequestUri 'CMContact))
-> ConnectionRequestUri 'CMContact
-> ExceptT
     AgentErrorType (ReaderT Env IO) (ConnectionRequestUri 'CMContact)
forall a b. (a -> b) -> a -> b
$ ConnReqUriData -> ConnectionRequestUri 'CMContact
CRContactUri ConnReqUriData
crData
        SConnectionMode c
SCMInvitation -> 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
          let pqEnc :: PQSupport
pqEnc = Bool -> InitialKeys -> PQSupport
CR.initialPQEncryption (Maybe (UserConnLinkData c) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (UserConnLinkData c)
userLinkData_) InitialKeys
pqInitKeys
          (PrivateKey 'X448
pk1, PrivateKey 'X448
pk2, Maybe (PrivRKEMParams 'RKSProposed)
pKem, RcvE2ERatchetParams 'X448
e2eRcvParams) <- IO
  (PrivateKey 'X448, PrivateKey 'X448,
   Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (PrivateKey 'X448, PrivateKey 'X448,
    Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (PrivateKey 'X448, PrivateKey 'X448,
       Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448))
-> IO
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> VersionE2E
-> PQSupport
-> IO
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> VersionE2E
-> PQSupport
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed),
      E2ERatchetParams 'RKSProposed a)
CR.generateRcvE2EParams TVar ChaChaDRG
g (VersionRangeE2E -> VersionE2E
forall v. VersionRange v -> Version v
maxVersion VersionRangeE2E
e2eEncryptVRange) PQSupport
pqEnc
          AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ConnId
-> PrivateKey 'X448
-> PrivateKey 'X448
-> Maybe (PrivRKEMParams 'RKSProposed)
-> IO ()
createRatchetX3dhKeys Connection
db ConnId
connId PrivateKey 'X448
pk1 PrivateKey 'X448
pk2 Maybe (PrivRKEMParams 'RKSProposed)
pKem
          ConnectionRequestUri c -> AM (ConnectionRequestUri c)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectionRequestUri c -> AM (ConnectionRequestUri c))
-> ConnectionRequestUri c -> AM (ConnectionRequestUri c)
forall a b. (a -> b) -> a -> b
$ ConnReqUriData
-> RcvE2ERatchetParamsUri 'X448
-> ConnectionRequestUri 'CMInvitation
CRInvitationUri ConnReqUriData
crData (RcvE2ERatchetParamsUri 'X448
 -> ConnectionRequestUri 'CMInvitation)
-> RcvE2ERatchetParamsUri 'X448
-> ConnectionRequestUri 'CMInvitation
forall a b. (a -> b) -> a -> b
$ RcvE2ERatchetParams 'X448
-> VersionRangeE2E
-> VersionRangeT E2EVersion (RcvE2ERatchetParams 'X448)
forall v a.
VersionI v a =>
a -> VersionRange v -> VersionRangeT v a
toVersionRangeT RcvE2ERatchetParams 'X448
e2eRcvParams VersionRangeE2E
e2eEncryptVRange
    prepareLinkData :: UserConnLinkData c -> C.PublicKeyX25519 -> AM (C.CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData)
    prepareLinkData :: UserConnLinkData c
-> PublicKeyX25519
-> AM
     (CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData)
prepareLinkData UserConnLinkData c
userLinkData PublicKeyX25519
e2eDhKey = 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
      nonce :: CbNonce
nonce@(C.CbNonce ConnId
corrId) <- 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
      sigKeys :: (PublicKey 'Ed25519, PrivateKeyEd25519)
sigKeys@(PublicKey 'Ed25519
_, PrivateKeyEd25519
privSigKey) <- STM KeyPairEd25519
-> ExceptT AgentErrorType (ReaderT Env IO) KeyPairEd25519
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM KeyPairEd25519
 -> ExceptT AgentErrorType (ReaderT Env IO) KeyPairEd25519)
-> STM KeyPairEd25519
-> ExceptT AgentErrorType (ReaderT Env IO) KeyPairEd25519
forall a b. (a -> b) -> a -> b
$ forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair @'C.Ed25519 TVar ChaChaDRG
g
      AgentConfig {$sel:smpClientVRange:AgentConfig :: AgentConfig -> VersionRangeSMPC
smpClientVRange = VersionRangeSMPC
vr, VersionRange SMPAgentVersion
$sel:smpAgentVRange:AgentConfig :: AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange :: VersionRange SMPAgentVersion
smpAgentVRange} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
      -- the remaining 24 bytes are reserved, possibly for notifier ID in the new notifications protocol
      let sndId :: QueueId
sndId = ConnId -> QueueId
SMP.EntityId (ConnId -> QueueId) -> ConnId -> QueueId
forall a b. (a -> b) -> a -> b
$ Int -> ConnId -> ConnId
B.take Int
24 (ConnId -> ConnId) -> ConnId -> ConnId
forall a b. (a -> b) -> a -> b
$ ConnId -> ConnId
C.sha3_384 ConnId
corrId
          qm :: QueueMode
qm = case SConnectionMode c
cMode of SConnectionMode c
SCMContact -> QueueMode
QMContact; SConnectionMode c
SCMInvitation -> QueueMode
QMMessaging
          qUri :: SMPQueueUri
qUri = VersionRangeSMPC -> SMPQueueAddress -> SMPQueueUri
SMPQueueUri VersionRangeSMPC
vr (SMPQueueAddress -> SMPQueueUri) -> SMPQueueAddress -> SMPQueueUri
forall a b. (a -> b) -> a -> b
$ SMPServer
-> QueueId -> PublicKeyX25519 -> Maybe QueueMode -> SMPQueueAddress
SMPQueueAddress SMPServer
srv QueueId
sndId PublicKeyX25519
e2eDhKey (QueueMode -> Maybe QueueMode
forall a. a -> Maybe a
Just QueueMode
qm)
      ConnectionRequestUri c
connReq <- SMPQueueUri -> AM (ConnectionRequestUri c)
createConnReq SMPQueueUri
qUri
      let (LinkKey
linkKey, (ConnId, ConnId)
linkData) = KeyPairEd25519
-> VersionRange SMPAgentVersion
-> ConnectionRequestUri c
-> Maybe ConnId
-> UserConnLinkData c
-> (LinkKey, (ConnId, ConnId))
forall (c :: ConnectionMode).
ConnectionModeI c =>
KeyPairEd25519
-> VersionRange SMPAgentVersion
-> ConnectionRequestUri c
-> Maybe ConnId
-> UserConnLinkData c
-> (LinkKey, (ConnId, ConnId))
SL.encodeSignLinkData KeyPairEd25519
(PublicKey 'Ed25519, PrivateKeyEd25519)
sigKeys VersionRange SMPAgentVersion
smpAgentVRange ConnectionRequestUri c
connReq Maybe ConnId
forall a. Maybe a
Nothing UserConnLinkData c
userLinkData
      ClntQueueReqData
qd <- case SConnectionMode c
cMode of
        SConnectionMode c
SCMContact -> TVar ChaChaDRG
-> PrivateKeyEd25519
-> LinkKey
-> QueueId
-> (ConnId, ConnId)
-> AM ClntQueueReqData
encryptContactLinkData TVar ChaChaDRG
g PrivateKeyEd25519
privSigKey LinkKey
linkKey QueueId
sndId (ConnId, ConnId)
linkData
        SConnectionMode c
SCMInvitation -> do
          let k :: SbKey
k = LinkKey -> SbKey
SL.invShortLinkKdf LinkKey
linkKey
          QueueLinkData
srvData <- (AgentErrorType -> AgentErrorType)
-> ExceptT AgentErrorType IO QueueLinkData
-> ExceptT AgentErrorType (ReaderT Env IO) QueueLinkData
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError AgentErrorType -> AgentErrorType
forall a. a -> a
id (ExceptT AgentErrorType IO QueueLinkData
 -> ExceptT AgentErrorType (ReaderT Env IO) QueueLinkData)
-> ExceptT AgentErrorType IO QueueLinkData
-> ExceptT AgentErrorType (ReaderT Env IO) QueueLinkData
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> SbKey
-> (ConnId, ConnId)
-> ExceptT AgentErrorType IO QueueLinkData
SL.encryptLinkData TVar ChaChaDRG
g SbKey
k (ConnId, ConnId)
linkData
          ClntQueueReqData -> AM ClntQueueReqData
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClntQueueReqData -> AM ClntQueueReqData)
-> ClntQueueReqData -> AM ClntQueueReqData
forall a b. (a -> b) -> a -> b
$ Maybe (CQRData (QueueId, QueueLinkData)) -> ClntQueueReqData
CQRMessaging (Maybe (CQRData (QueueId, QueueLinkData)) -> ClntQueueReqData)
-> Maybe (CQRData (QueueId, QueueLinkData)) -> ClntQueueReqData
forall a b. (a -> b) -> a -> b
$ CQRData (QueueId, QueueLinkData)
-> Maybe (CQRData (QueueId, QueueLinkData))
forall a. a -> Maybe a
Just CQRData {LinkKey
$sel:linkKey:CQRData :: LinkKey
linkKey :: LinkKey
linkKey, PrivateKeyEd25519
$sel:privSigKey:CQRData :: PrivateKeyEd25519
privSigKey :: PrivateKeyEd25519
privSigKey, $sel:srvReq:CQRData :: (QueueId, QueueLinkData)
srvReq = (QueueId
sndId, QueueLinkData
srvData)}
      (CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData)
-> AM
     (CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CbNonce
nonce, SMPQueueUri
qUri, ConnectionRequestUri c
connReq, ClntQueueReqData
qd)
    connReqWithShortLink :: SMPQueueUri -> ConnectionRequestUri c -> SMPQueueUri -> Maybe ShortLinkCreds -> AM (CreatedConnLink c)
    connReqWithShortLink :: SMPQueueUri
-> ConnectionRequestUri c
-> SMPQueueUri
-> Maybe ShortLinkCreds
-> AM (CreatedConnLink c)
connReqWithShortLink SMPQueueUri
qUri ConnectionRequestUri c
cReq SMPQueueUri
qUri' Maybe ShortLinkCreds
shortLink = case Maybe ShortLinkCreds
shortLink of
      Just ShortLinkCreds {QueueId
$sel:shortLinkId:ShortLinkCreds :: ShortLinkCreds -> QueueId
shortLinkId :: QueueId
shortLinkId, LinkKey
$sel:shortLinkKey:ShortLinkCreds :: ShortLinkCreds -> LinkKey
shortLinkKey :: LinkKey
shortLinkKey}
        | SMPQueueUri
qUri SMPQueueUri -> SMPQueueUri -> Bool
forall a. Eq a => a -> a -> Bool
== SMPQueueUri
qUri' -> CreatedConnLink c -> AM (CreatedConnLink c)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreatedConnLink c -> AM (CreatedConnLink c))
-> CreatedConnLink c -> AM (CreatedConnLink c)
forall a b. (a -> b) -> a -> b
$ case ConnectionRequestUri c
cReq of
            CRContactUri ConnReqUriData
_ -> ConnectionRequestUri c
-> Maybe (ConnShortLink c) -> CreatedConnLink c
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
CCLink ConnectionRequestUri c
cReq (Maybe (ConnShortLink c) -> CreatedConnLink c)
-> Maybe (ConnShortLink c) -> CreatedConnLink c
forall a b. (a -> b) -> a -> b
$ ConnShortLink 'CMContact -> Maybe (ConnShortLink 'CMContact)
forall a. a -> Maybe a
Just (ConnShortLink 'CMContact -> Maybe (ConnShortLink 'CMContact))
-> ConnShortLink 'CMContact -> Maybe (ConnShortLink 'CMContact)
forall a b. (a -> b) -> a -> b
$ ShortLinkScheme
-> ContactConnType
-> SMPServer
-> LinkKey
-> ConnShortLink 'CMContact
CSLContact ShortLinkScheme
SLSServer ContactConnType
CCTContact SMPServer
srv LinkKey
shortLinkKey
            CRInvitationUri ConnReqUriData
crData (CR.E2ERatchetParamsUri VersionRangeE2E
vr PublicKey 'X448
k1 PublicKey 'X448
k2 Maybe (RKEMParams 'RKSProposed)
_) ->
              let cReq' :: ConnectionRequestUri 'CMInvitation
cReq' = case InitialKeys
pqInitKeys of
                    InitialKeys
CR.IKPQOn -> ConnReqUriData
-> RcvE2ERatchetParamsUri 'X448
-> ConnectionRequestUri 'CMInvitation
CRInvitationUri ConnReqUriData
crData (RcvE2ERatchetParamsUri 'X448
 -> ConnectionRequestUri 'CMInvitation)
-> RcvE2ERatchetParamsUri 'X448
-> ConnectionRequestUri 'CMInvitation
forall a b. (a -> b) -> a -> b
$ VersionRangeE2E
-> PublicKey 'X448
-> PublicKey 'X448
-> Maybe (RKEMParams 'RKSProposed)
-> RcvE2ERatchetParamsUri 'X448
forall (s :: RatchetKEMState) (a :: Algorithm).
VersionRangeE2E
-> PublicKey a
-> PublicKey a
-> Maybe (RKEMParams s)
-> E2ERatchetParamsUri s a
CR.E2ERatchetParamsUri VersionRangeE2E
vr PublicKey 'X448
k1 PublicKey 'X448
k2 Maybe (RKEMParams 'RKSProposed)
forall a. Maybe a
Nothing -- remove PQ keys
                    InitialKeys
_ -> ConnectionRequestUri c
ConnectionRequestUri 'CMInvitation
cReq -- either PQ is disabled, or disabled for initial request because there is no short link
               in ConnectionRequestUri c
-> Maybe (ConnShortLink c) -> CreatedConnLink c
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
CCLink ConnectionRequestUri c
ConnectionRequestUri 'CMInvitation
cReq' (Maybe (ConnShortLink c) -> CreatedConnLink c)
-> Maybe (ConnShortLink c) -> CreatedConnLink c
forall a b. (a -> b) -> a -> b
$ ConnShortLink 'CMInvitation -> Maybe (ConnShortLink 'CMInvitation)
forall a. a -> Maybe a
Just (ConnShortLink 'CMInvitation
 -> Maybe (ConnShortLink 'CMInvitation))
-> ConnShortLink 'CMInvitation
-> Maybe (ConnShortLink 'CMInvitation)
forall a b. (a -> b) -> a -> b
$ ShortLinkScheme
-> SMPServer -> QueueId -> LinkKey -> ConnShortLink 'CMInvitation
CSLInvitation ShortLinkScheme
SLSServer SMPServer
srv QueueId
shortLinkId LinkKey
shortLinkKey
        | Bool
otherwise -> AgentErrorType -> AM (CreatedConnLink c)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (CreatedConnLink c))
-> AgentErrorType -> AM (CreatedConnLink c)
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"different rcv queue address"
      Maybe ShortLinkCreds
Nothing ->
        let updated :: ConnReqUriData -> ConnReqUriData
updated (ConnReqUriData ServiceScheme
_ VersionRange SMPAgentVersion
vr NonEmpty SMPQueueUri
_ Maybe Text
_) = (ServiceScheme
-> VersionRange SMPAgentVersion
-> NonEmpty SMPQueueUri
-> Maybe Text
-> ConnReqUriData
ConnReqUriData ServiceScheme
SSSimplex VersionRange SMPAgentVersion
vr [Item (NonEmpty SMPQueueUri)
SMPQueueUri
qUri'] Maybe Text
clientData)
            cReq' :: ConnectionRequestUri c
cReq' = case ConnectionRequestUri c
cReq of
              CRContactUri ConnReqUriData
crData -> ConnReqUriData -> ConnectionRequestUri 'CMContact
CRContactUri (ConnReqUriData -> ConnReqUriData
updated ConnReqUriData
crData)
              CRInvitationUri ConnReqUriData
crData RcvE2ERatchetParamsUri 'X448
e2eParams -> ConnReqUriData
-> RcvE2ERatchetParamsUri 'X448
-> ConnectionRequestUri 'CMInvitation
CRInvitationUri (ConnReqUriData -> ConnReqUriData
updated ConnReqUriData
crData) RcvE2ERatchetParamsUri 'X448
e2eParams
         in CreatedConnLink c -> AM (CreatedConnLink c)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreatedConnLink c -> AM (CreatedConnLink c))
-> CreatedConnLink c -> AM (CreatedConnLink c)
forall a b. (a -> b) -> a -> b
$ ConnectionRequestUri c
-> Maybe (ConnShortLink c) -> CreatedConnLink c
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
CCLink ConnectionRequestUri c
cReq' Maybe (ConnShortLink c)
forall a. Maybe a
Nothing

newQueueNtfServer :: AM (Maybe NtfServer)
newQueueNtfServer :: AM (Maybe NtfServer)
newQueueNtfServer = (Maybe NtfToken -> Maybe NtfServer)
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
-> AM (Maybe NtfServer)
forall a b.
(a -> b)
-> ExceptT AgentErrorType (ReaderT Env IO) a
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe NtfToken -> Maybe NtfServer
ntfServer_ (ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
 -> AM (Maybe NtfServer))
-> (NtfSupervisor
    -> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken))
-> NtfSupervisor
-> AM (Maybe NtfServer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Maybe NtfToken)
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (Maybe NtfToken)
 -> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken))
-> (NtfSupervisor -> TVar (Maybe NtfToken))
-> NtfSupervisor
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NtfSupervisor -> TVar (Maybe NtfToken)
ntfTkn (NtfSupervisor -> AM (Maybe NtfServer))
-> ExceptT AgentErrorType (ReaderT Env IO) NtfSupervisor
-> AM (Maybe NtfServer)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env -> NtfSupervisor)
-> ExceptT AgentErrorType (ReaderT Env IO) NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
  where
    ntfServer_ :: Maybe NtfToken -> Maybe NtfServer
ntfServer_ = \case
      Just tkn :: NtfToken
tkn@NtfToken {NtfServer
ntfServer :: NtfServer
$sel:ntfServer:NtfToken :: NtfToken -> NtfServer
ntfServer} | NtfToken -> Bool
instantNotifications NtfToken
tkn -> NtfServer -> Maybe NtfServer
forall a. a -> Maybe a
Just NtfServer
ntfServer
      Maybe NtfToken
_ -> Maybe NtfServer
forall a. Maybe a
Nothing

newQueueNtfSubscription :: AgentClient -> RcvQueue -> NtfServer -> AM ()
newQueueNtfSubscription :: AgentClient
-> RcvQueue
-> NtfServer
-> ExceptT AgentErrorType (ReaderT Env IO) ()
newQueueNtfSubscription AgentClient
c RcvQueue {UserId
userId :: UserId
$sel:userId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> UserId
userId, ConnId
connId :: ConnId
$sel:connId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> ConnId
connId, SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server :: SMPServer
server, Maybe ClientNtfCreds
clientNtfCreds :: Maybe ClientNtfCreds
$sel:clientNtfCreds:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Maybe ClientNtfCreds
clientNtfCreds} NtfServer
ntfServer = do
  Maybe ClientNtfCreds
-> (ClientNtfCreds -> 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 ClientNtfCreds
clientNtfCreds ((ClientNtfCreds -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ClientNtfCreds -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \ClientNtfCreds {QueueId
notifierId :: QueueId
$sel:notifierId:ClientNtfCreds :: ClientNtfCreds -> QueueId
notifierId} -> do
    let sub :: NtfSubscription
sub = UserId
-> ConnId
-> SMPServer
-> Maybe QueueId
-> NtfServer
-> NtfAgentSubStatus
-> NtfSubscription
newNtfSubscription UserId
userId ConnId
connId SMPServer
server (QueueId -> Maybe QueueId
forall a. a -> Maybe a
Just QueueId
notifierId) NtfServer
ntfServer NtfAgentSubStatus
NASKey
    AgentClient
-> (Connection -> IO (Either StoreError ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError ()))
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO (Either StoreError ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> NtfSubscription -> NtfSubAction -> IO (Either StoreError ())
createNtfSubscription Connection
db NtfSubscription
sub (NtfSubNTFAction -> NtfSubAction
NSANtf NtfSubNTFAction
NSACreate)
  NtfSupervisor
ns <- (Env -> NtfSupervisor)
-> ExceptT AgentErrorType (ReaderT Env IO) NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
  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
$ NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> IO ()
sendNtfSubCommand NtfSupervisor
ns (NtfSupervisorCommand
NSCCreate, [ConnId
Item (NonEmpty ConnId)
connId])

newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId
newConnToJoin :: forall (c :: ConnectionMode).
AgentClient
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> PQSupport
-> AM ConnId
newConnToJoin AgentClient
c UserId
userId ConnId
connId Bool
enableNtfs ConnectionRequestUri c
cReq PQSupport
pqSup = case ConnectionRequestUri c
cReq of
  CRInvitationUri {} ->
    ReaderT
  Env
  IO
  (Maybe
     (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
      Compatible VersionSMPA))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
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 (ConnectionRequestUri 'CMInvitation
-> ReaderT
     Env
     IO
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
compatibleInvitationUri ConnectionRequestUri c
ConnectionRequestUri 'CMInvitation
cReq) ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Maybe
     (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
      Compatible VersionSMPA))
-> (Maybe
      (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
       Compatible VersionSMPA)
    -> AM ConnId)
-> AM ConnId
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 (Compatible SMPQueueInfo
_, Compatible (CR.E2ERatchetParams VersionE2E
v PublicKey 'X448
_ PublicKey 'X448
_ Maybe (RKEMParams 'RKSProposed)
_), Compatible VersionSMPA
aVersion) -> Compatible VersionSMPA -> Maybe VersionE2E -> AM ConnId
create Compatible VersionSMPA
aVersion (VersionE2E -> Maybe VersionE2E
forall a. a -> Maybe a
Just VersionE2E
v)
      Maybe
  (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
   Compatible VersionSMPA)
Nothing -> AgentErrorType -> AM ConnId
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnId) -> AgentErrorType -> AM ConnId
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION
  CRContactUri {} ->
    ReaderT
  Env IO (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
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 (ConnectionRequestUri 'CMContact
-> ReaderT
     Env IO (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
compatibleContactUri ConnectionRequestUri c
ConnectionRequestUri 'CMContact
cReq) ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
-> (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)
    -> AM ConnId)
-> AM ConnId
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 (Compatible SMPQueueInfo
_, Compatible VersionSMPA
aVersion) -> Compatible VersionSMPA -> Maybe VersionE2E -> AM ConnId
create Compatible VersionSMPA
aVersion Maybe VersionE2E
forall a. Maybe a
Nothing
      Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)
Nothing -> AgentErrorType -> AM ConnId
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnId) -> AgentErrorType -> AM ConnId
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION
  where
    create :: Compatible VersionSMPA -> Maybe CR.VersionE2E -> AM ConnId
    create :: Compatible VersionSMPA -> Maybe VersionE2E -> AM ConnId
create (Compatible VersionSMPA
connAgentVersion) Maybe VersionE2E
e2eV_ = 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
      let pqSupport :: PQSupport
pqSupport = PQSupport
pqSup PQSupport -> PQSupport -> PQSupport
`CR.pqSupportAnd` VersionSMPA -> Maybe VersionE2E -> PQSupport
versionPQSupport_ VersionSMPA
connAgentVersion Maybe VersionE2E
e2eV_
          cData :: ConnData
cData = ConnData {UserId
$sel:userId:ConnData :: UserId
userId :: UserId
userId, ConnId
$sel:connId:ConnData :: ConnId
connId :: ConnId
connId, VersionSMPA
$sel:connAgentVersion:ConnData :: VersionSMPA
connAgentVersion :: VersionSMPA
connAgentVersion, Bool
$sel:enableNtfs:ConnData :: Bool
enableNtfs :: Bool
enableNtfs, $sel:lastExternalSndId:ConnData :: UserId
lastExternalSndId = UserId
0, $sel:deleted:ConnData :: Bool
deleted = Bool
False, $sel:ratchetSyncState:ConnData :: RatchetSyncState
ratchetSyncState = RatchetSyncState
RSOk, PQSupport
$sel:pqSupport:ConnData :: PQSupport
pqSupport :: PQSupport
pqSupport}
      AgentClient
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError ConnId)) -> AM ConnId)
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> TVar ChaChaDRG
-> ConnData
-> SConnectionMode 'CMInvitation
-> IO (Either StoreError ConnId)
forall (c :: ConnectionMode).
Connection
-> TVar ChaChaDRG
-> ConnData
-> SConnectionMode c
-> IO (Either StoreError ConnId)
createNewConn Connection
db TVar ChaChaDRG
g ConnData
cData SConnectionMode 'CMInvitation
SCMInvitation

newConnToAccept :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> PQSupport -> AM ConnId
newConnToAccept :: AgentClient
-> UserId -> ConnId -> Bool -> ConnId -> PQSupport -> AM ConnId
newConnToAccept AgentClient
c UserId
userId ConnId
connId Bool
enableNtfs ConnId
invId PQSupport
pqSup = do
  Invitation {ConnectionRequestUri 'CMInvitation
$sel:connReq:Invitation :: Invitation -> ConnectionRequestUri 'CMInvitation
connReq :: ConnectionRequestUri 'CMInvitation
connReq} <- AgentClient
-> (Connection -> IO (Either StoreError Invitation))
-> AM Invitation
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError Invitation))
 -> AM Invitation)
-> (Connection -> IO (Either StoreError Invitation))
-> AM Invitation
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> String -> ConnId -> IO (Either StoreError Invitation)
getInvitation Connection
db String
"newConnToAccept" ConnId
invId
  AgentClient
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri 'CMInvitation
-> PQSupport
-> AM ConnId
forall (c :: ConnectionMode).
AgentClient
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> PQSupport
-> AM ConnId
newConnToJoin AgentClient
c UserId
userId ConnId
connId Bool
enableNtfs ConnectionRequestUri 'CMInvitation
connReq PQSupport
pqSup

joinConn :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
joinConn :: forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM (Bool, Maybe ClientServiceId)
joinConn AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId Bool
enableNtfs ConnectionRequestUri c
cReq ConnId
cInfo PQSupport
pqSupport SubscriptionMode
subMode = do
  SMPServerWithAuth
srv <- AgentClient -> UserId -> [SMPServer] -> AM SMPServerWithAuth
getNextSMPServer AgentClient
c UserId
userId [SMPQueueUri -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer (SMPQueueUri -> SMPServer) -> SMPQueueUri -> SMPServer
forall a b. (a -> b) -> a -> b
$ ConnectionRequestUri c -> SMPQueueUri
forall (c :: ConnectionMode). ConnectionRequestUri c -> SMPQueueUri
connReqQueue ConnectionRequestUri c
cReq]
  AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (Bool, Maybe ClientServiceId)
forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (Bool, Maybe ClientServiceId)
joinConnSrv AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId Bool
enableNtfs ConnectionRequestUri c
cReq ConnId
cInfo PQSupport
pqSupport SubscriptionMode
subMode SMPServerWithAuth
srv

connReqQueue :: ConnectionRequestUri c -> SMPQueueUri
connReqQueue :: forall (c :: ConnectionMode). ConnectionRequestUri c -> SMPQueueUri
connReqQueue = \case
  CRInvitationUri ConnReqUriData {$sel:crSmpQueues:ConnReqUriData :: ConnReqUriData -> NonEmpty SMPQueueUri
crSmpQueues = SMPQueueUri
q :| [SMPQueueUri]
_} RcvE2ERatchetParamsUri 'X448
_ -> SMPQueueUri
q
  CRContactUri ConnReqUriData {$sel:crSmpQueues:ConnReqUriData :: ConnReqUriData -> NonEmpty SMPQueueUri
crSmpQueues = SMPQueueUri
q :| [SMPQueueUri]
_} -> SMPQueueUri
q

startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, SndQueue, CR.SndE2ERatchetParams 'C.X448, Maybe SMP.LinkId)
startJoinInvitation :: AgentClient
-> UserId
-> ConnId
-> Maybe SndQueue
-> Bool
-> ConnectionRequestUri 'CMInvitation
-> PQSupport
-> AM
     (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
startJoinInvitation AgentClient
c UserId
userId ConnId
connId Maybe SndQueue
sq_ Bool
enableNtfs ConnectionRequestUri 'CMInvitation
cReqUri PQSupport
pqSup =
  ReaderT
  Env
  IO
  (Maybe
     (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
      Compatible VersionSMPA))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
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 (ConnectionRequestUri 'CMInvitation
-> ReaderT
     Env
     IO
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
compatibleInvitationUri ConnectionRequestUri 'CMInvitation
cReqUri) ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Maybe
     (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
      Compatible VersionSMPA))
-> (Maybe
      (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
       Compatible VersionSMPA)
    -> AM
         (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId))
-> AM
     (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
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 (Compatible SMPQueueInfo
qInfo, Compatible e2eRcvParams :: RcvE2ERatchetParams 'X448
e2eRcvParams@(CR.E2ERatchetParams VersionE2E
v PublicKey 'X448
_ PublicKey 'X448
_ Maybe (RKEMParams 'RKSProposed)
_), Compatible VersionSMPA
connAgentVersion) -> do
      -- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out
      -- e2ePubKey is always present, it's Maybe historically
      let pqSupport :: PQSupport
pqSupport = PQSupport
pqSup PQSupport -> PQSupport -> PQSupport
`CR.pqSupportAnd` VersionSMPA -> Maybe VersionE2E -> PQSupport
versionPQSupport_ VersionSMPA
connAgentVersion (VersionE2E -> Maybe VersionE2E
forall a. a -> Maybe a
Just VersionE2E
v)
      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
      VersionE2E
maxSupported <- (Env -> VersionE2E)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionE2E
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> VersionE2E)
 -> ExceptT AgentErrorType (ReaderT Env IO) VersionE2E)
-> (Env -> VersionE2E)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionE2E
forall a b. (a -> b) -> a -> b
$ VersionRangeE2E -> VersionE2E
forall v. VersionRange v -> Version v
maxVersion (VersionRangeE2E -> VersionE2E)
-> (Env -> VersionRangeE2E) -> Env -> VersionE2E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentConfig -> VersionRangeE2E
e2eEncryptVRange (AgentConfig -> VersionRangeE2E)
-> (Env -> AgentConfig) -> Env -> VersionRangeE2E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
      let cData :: ConnData
cData = ConnData {UserId
$sel:userId:ConnData :: UserId
userId :: UserId
userId, ConnId
$sel:connId:ConnData :: ConnId
connId :: ConnId
connId, VersionSMPA
$sel:connAgentVersion:ConnData :: VersionSMPA
connAgentVersion :: VersionSMPA
connAgentVersion, Bool
$sel:enableNtfs:ConnData :: Bool
enableNtfs :: Bool
enableNtfs, $sel:lastExternalSndId:ConnData :: UserId
lastExternalSndId = UserId
0, $sel:deleted:ConnData :: Bool
deleted = Bool
False, $sel:ratchetSyncState:ConnData :: RatchetSyncState
ratchetSyncState = RatchetSyncState
RSOk, PQSupport
$sel:pqSupport:ConnData :: PQSupport
pqSupport :: PQSupport
pqSupport}
      case Maybe SndQueue
sq_ of
        Just sq :: SndQueue
sq@SndQueue {$sel:e2ePubKey:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> Maybe PublicKeyX25519
e2ePubKey = Just PublicKeyX25519
_k} -> do
          SndE2ERatchetParams 'X448
e2eSndParams <- AgentClient
-> (Connection
    -> IO (Either StoreError (SndE2ERatchetParams 'X448)))
-> AM (SndE2ERatchetParams 'X448)
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError (SndE2ERatchetParams 'X448)))
 -> AM (SndE2ERatchetParams 'X448))
-> (Connection
    -> IO (Either StoreError (SndE2ERatchetParams 'X448)))
-> AM (SndE2ERatchetParams 'X448)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
            Connection -> ConnId -> IO ()
lockConnForUpdate Connection
db ConnId
connId
            Connection
-> ConnId
-> VersionE2E
-> IO (Either StoreError (RatchetX448, SndE2ERatchetParams 'X448))
getSndRatchet Connection
db ConnId
connId VersionE2E
v IO (Either StoreError (RatchetX448, SndE2ERatchetParams 'X448))
-> (Either StoreError (RatchetX448, SndE2ERatchetParams 'X448)
    -> IO (Either StoreError (SndE2ERatchetParams 'X448)))
-> IO (Either StoreError (SndE2ERatchetParams 'X448))
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 (RatchetX448, SndE2ERatchetParams 'X448)
r -> Either StoreError (SndE2ERatchetParams 'X448)
-> IO (Either StoreError (SndE2ERatchetParams 'X448))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError (SndE2ERatchetParams 'X448)
 -> IO (Either StoreError (SndE2ERatchetParams 'X448)))
-> Either StoreError (SndE2ERatchetParams 'X448)
-> IO (Either StoreError (SndE2ERatchetParams 'X448))
forall a b. (a -> b) -> a -> b
$ SndE2ERatchetParams 'X448
-> Either StoreError (SndE2ERatchetParams 'X448)
forall a b. b -> Either a b
Right (SndE2ERatchetParams 'X448
 -> Either StoreError (SndE2ERatchetParams 'X448))
-> SndE2ERatchetParams 'X448
-> Either StoreError (SndE2ERatchetParams 'X448)
forall a b. (a -> b) -> a -> b
$ (RatchetX448, SndE2ERatchetParams 'X448)
-> SndE2ERatchetParams 'X448
forall a b. (a, b) -> b
snd (RatchetX448, SndE2ERatchetParams 'X448)
r
              Left StoreError
e -> do
                TBQueue ATransmission -> ATransmission -> IO ()
forall a. TBQueue a -> a -> IO ()
nonBlockingWriteTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ConnId
"", ConnId
connId, SAEntity 'AEConn -> AEvent 'AEConn -> AEvt
forall (e :: AEntity). AEntityI e => SAEntity e -> AEvent e -> AEvt
AEvt SAEntity 'AEConn
SAEConn (AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> AEvent 'AEConn)
-> AgentErrorType -> AEvent 'AEConn
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"no snd ratchet " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> StoreError -> String
forall a. Show a => a -> String
show StoreError
e))
                ExceptT StoreError IO (SndE2ERatchetParams 'X448)
-> IO (Either StoreError (SndE2ERatchetParams 'X448))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO (SndE2ERatchetParams 'X448)
 -> IO (Either StoreError (SndE2ERatchetParams 'X448)))
-> ExceptT StoreError IO (SndE2ERatchetParams 'X448)
-> IO (Either StoreError (SndE2ERatchetParams 'X448))
forall a b. (a -> b) -> a -> b
$ Connection
-> TVar ChaChaDRG
-> VersionE2E
-> PQSupport
-> RcvE2ERatchetParams 'X448
-> ExceptT StoreError IO (SndE2ERatchetParams 'X448)
createRatchet_ Connection
db TVar ChaChaDRG
g VersionE2E
maxSupported PQSupport
pqSupport RcvE2ERatchetParams 'X448
e2eRcvParams
          (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
-> AM
     (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnData
cData, SndQueue
sq, SndE2ERatchetParams 'X448
e2eSndParams, Maybe QueueId
forall a. Maybe a
Nothing)
        Maybe SndQueue
_ -> do
          let Compatible SMPQueueInfo {$sel:queueAddress:SMPQueueInfo :: SMPQueueInfo -> SMPQueueAddress
queueAddress = SMPQueueAddress {SMPServer
smpServer :: SMPServer
$sel:smpServer:SMPQueueAddress :: SMPQueueAddress -> SMPServer
smpServer, QueueId
$sel:senderId:SMPQueueAddress :: SMPQueueAddress -> QueueId
senderId :: QueueId
senderId}} = Compatible SMPQueueInfo
qInfo
          Maybe (QueueId, APrivateAuthKey)
invLink_ <- AgentClient
-> (Connection -> IO (Maybe (QueueId, APrivateAuthKey)))
-> AM (Maybe (QueueId, APrivateAuthKey))
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO (Maybe (QueueId, APrivateAuthKey)))
 -> AM (Maybe (QueueId, APrivateAuthKey)))
-> (Connection -> IO (Maybe (QueueId, APrivateAuthKey)))
-> AM (Maybe (QueueId, APrivateAuthKey))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> SMPServer -> QueueId -> IO (Maybe (QueueId, APrivateAuthKey))
getInvShortLinkKeys Connection
db SMPServer
smpServer QueueId
senderId
          let lnkId_ :: Maybe QueueId
lnkId_ = (QueueId, APrivateAuthKey) -> QueueId
forall a b. (a, b) -> a
fst ((QueueId, APrivateAuthKey) -> QueueId)
-> Maybe (QueueId, APrivateAuthKey) -> Maybe QueueId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (QueueId, APrivateAuthKey)
invLink_
              sndKey_ :: Maybe APrivateAuthKey
sndKey_ = (QueueId, APrivateAuthKey) -> APrivateAuthKey
forall a b. (a, b) -> b
snd ((QueueId, APrivateAuthKey) -> APrivateAuthKey)
-> Maybe (QueueId, APrivateAuthKey) -> Maybe APrivateAuthKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (QueueId, APrivateAuthKey)
invLink_
          (NewSndQueue
q, PublicKeyX25519
_) <- ReaderT Env IO (NewSndQueue, PublicKeyX25519)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (NewSndQueue, PublicKeyX25519)
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 (NewSndQueue, PublicKeyX25519)
 -> ExceptT
      AgentErrorType (ReaderT Env IO) (NewSndQueue, PublicKeyX25519))
-> ReaderT Env IO (NewSndQueue, PublicKeyX25519)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (NewSndQueue, PublicKeyX25519)
forall a b. (a -> b) -> a -> b
$ UserId
-> ConnId
-> Compatible SMPQueueInfo
-> Maybe APrivateAuthKey
-> ReaderT Env IO (NewSndQueue, PublicKeyX25519)
newSndQueue UserId
userId ConnId
"" Compatible SMPQueueInfo
qInfo Maybe APrivateAuthKey
sndKey_
          AgentClient
-> (Connection
    -> IO
         (Either
            StoreError
            (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)))
-> AM
     (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection
  -> IO
       (Either
          StoreError
          (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)))
 -> AM
      (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId))
-> (Connection
    -> IO
         (Either
            StoreError
            (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)))
-> AM
     (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ExceptT
  StoreError
  IO
  (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
-> IO
     (Either
        StoreError
        (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   StoreError
   IO
   (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
 -> IO
      (Either
         StoreError
         (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)))
-> ExceptT
     StoreError
     IO
     (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
-> IO
     (Either
        StoreError
        (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId))
forall a b. (a -> b) -> a -> b
$ do
            IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> IO ()
lockConnForUpdate Connection
db ConnId
connId
            SndE2ERatchetParams 'X448
e2eSndParams <- Connection
-> TVar ChaChaDRG
-> VersionE2E
-> PQSupport
-> RcvE2ERatchetParams 'X448
-> ExceptT StoreError IO (SndE2ERatchetParams 'X448)
createRatchet_ Connection
db TVar ChaChaDRG
g VersionE2E
maxSupported PQSupport
pqSupport RcvE2ERatchetParams 'X448
e2eRcvParams
            SndQueue
sq' <- ExceptT StoreError IO SndQueue
-> (SndQueue -> ExceptT StoreError IO SndQueue)
-> Maybe SndQueue
-> ExceptT StoreError IO SndQueue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO (Either StoreError SndQueue) -> ExceptT StoreError IO SndQueue
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError SndQueue) -> ExceptT StoreError IO SndQueue)
-> IO (Either StoreError SndQueue)
-> ExceptT StoreError IO SndQueue
forall a b. (a -> b) -> a -> b
$ Connection
-> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
updateNewConnSnd Connection
db ConnId
connId NewSndQueue
q) SndQueue -> ExceptT StoreError IO SndQueue
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SndQueue
sq_
            (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
-> ExceptT
     StoreError
     IO
     (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnData
cData, SndQueue
sq', SndE2ERatchetParams 'X448
e2eSndParams, Maybe QueueId
lnkId_)
    Maybe
  (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
   Compatible VersionSMPA)
Nothing -> AgentErrorType
-> AM
     (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType
 -> AM
      (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId))
-> AgentErrorType
-> AM
     (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION
  where
    createRatchet_ :: Connection
-> TVar ChaChaDRG
-> VersionE2E
-> PQSupport
-> RcvE2ERatchetParams 'X448
-> ExceptT StoreError IO (SndE2ERatchetParams 'X448)
createRatchet_ Connection
db TVar ChaChaDRG
g VersionE2E
maxSupported PQSupport
pqSupport e2eRcvParams :: RcvE2ERatchetParams 'X448
e2eRcvParams@(CR.E2ERatchetParams VersionE2E
v PublicKey 'X448
_ PublicKey 'X448
rcDHRr Maybe (RKEMParams 'RKSProposed)
kem_) = do
      (PrivateKey 'X448
pk1, PrivateKey 'X448
pk2, Maybe APrivRKEMParams
pKem, SndE2ERatchetParams 'X448
e2eSndParams) <- IO
  (PrivateKey 'X448, PrivateKey 'X448, Maybe APrivRKEMParams,
   SndE2ERatchetParams 'X448)
-> ExceptT
     StoreError
     IO
     (PrivateKey 'X448, PrivateKey 'X448, Maybe APrivRKEMParams,
      SndE2ERatchetParams 'X448)
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (PrivateKey 'X448, PrivateKey 'X448, Maybe APrivRKEMParams,
    SndE2ERatchetParams 'X448)
 -> ExceptT
      StoreError
      IO
      (PrivateKey 'X448, PrivateKey 'X448, Maybe APrivRKEMParams,
       SndE2ERatchetParams 'X448))
-> IO
     (PrivateKey 'X448, PrivateKey 'X448, Maybe APrivRKEMParams,
      SndE2ERatchetParams 'X448)
-> ExceptT
     StoreError
     IO
     (PrivateKey 'X448, PrivateKey 'X448, Maybe APrivRKEMParams,
      SndE2ERatchetParams 'X448)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> VersionE2E
-> Maybe AUseKEM
-> IO
     (PrivateKey 'X448, PrivateKey 'X448, Maybe APrivRKEMParams,
      SndE2ERatchetParams 'X448)
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> VersionE2E
-> Maybe AUseKEM
-> IO
     (PrivateKey a, PrivateKey a, Maybe APrivRKEMParams,
      AE2ERatchetParams a)
CR.generateSndE2EParams TVar ChaChaDRG
g VersionE2E
v (VersionE2E
-> Maybe (RKEMParams 'RKSProposed) -> PQSupport -> Maybe AUseKEM
CR.replyKEM_ VersionE2E
v Maybe (RKEMParams 'RKSProposed)
kem_ PQSupport
pqSupport)
      (PublicKey 'X448
_, PrivateKey 'X448
rcDHRs) <- STM (PublicKey 'X448, PrivateKey 'X448)
-> ExceptT StoreError IO (PublicKey 'X448, PrivateKey 'X448)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKey 'X448, PrivateKey 'X448)
 -> ExceptT StoreError IO (PublicKey 'X448, PrivateKey 'X448))
-> STM (PublicKey 'X448, PrivateKey 'X448)
-> ExceptT StoreError IO (PublicKey 'X448, PrivateKey 'X448)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair 'X448)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
g
      (RatchetInitParams, Maybe KEMKeyPair)
rcParams <- (CryptoError -> StoreError)
-> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
-> ExceptT StoreError IO (RatchetInitParams, Maybe KEMKeyPair)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (AgentErrorType -> StoreError
SEAgentError (AgentErrorType -> StoreError)
-> (CryptoError -> AgentErrorType) -> CryptoError -> StoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoError -> AgentErrorType
cryptoError) (Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
 -> ExceptT StoreError IO (RatchetInitParams, Maybe KEMKeyPair))
-> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
-> ExceptT StoreError IO (RatchetInitParams, Maybe KEMKeyPair)
forall a b. (a -> b) -> a -> b
$ PrivateKey 'X448
-> PrivateKey 'X448
-> Maybe APrivRKEMParams
-> RcvE2ERatchetParams 'X448
-> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
forall (a :: Algorithm).
DhAlgorithm a =>
PrivateKey a
-> PrivateKey a
-> Maybe APrivRKEMParams
-> E2ERatchetParams 'RKSProposed a
-> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
CR.pqX3dhSnd PrivateKey 'X448
pk1 PrivateKey 'X448
pk2 Maybe APrivRKEMParams
pKem RcvE2ERatchetParams 'X448
e2eRcvParams
      let rcVs :: RatchetVersions
rcVs = CR.RatchetVersions {$sel:current:RatchetVersions :: VersionE2E
current = VersionE2E
v, VersionE2E
maxSupported :: VersionE2E
$sel:maxSupported:RatchetVersions :: VersionE2E
maxSupported}
          rc :: RatchetX448
rc = RatchetVersions
-> PublicKey 'X448
-> PrivateKey 'X448
-> (RatchetInitParams, Maybe KEMKeyPair)
-> RatchetX448
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
RatchetVersions
-> PublicKey a
-> PrivateKey a
-> (RatchetInitParams, Maybe KEMKeyPair)
-> Ratchet a
CR.initSndRatchet RatchetVersions
rcVs PublicKey 'X448
rcDHRr PrivateKey 'X448
rcDHRs (RatchetInitParams, Maybe KEMKeyPair)
rcParams
      IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ConnId -> RatchetX448 -> SndE2ERatchetParams 'X448 -> IO ()
createSndRatchet Connection
db ConnId
connId RatchetX448
rc SndE2ERatchetParams 'X448
e2eSndParams
      SndE2ERatchetParams 'X448
-> ExceptT StoreError IO (SndE2ERatchetParams 'X448)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SndE2ERatchetParams 'X448
e2eSndParams

connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport))
connRequestPQSupport :: forall (c :: ConnectionMode).
AgentClient
-> PQSupport
-> ConnectionRequestUri c
-> IO (Maybe (VersionSMPA, PQSupport))
connRequestPQSupport AgentClient
c PQSupport
pqSup ConnectionRequestUri c
cReq = AgentClient
-> AM' (Maybe (VersionSMPA, PQSupport))
-> IO (Maybe (VersionSMPA, PQSupport))
forall a. AgentClient -> AM' a -> IO a
withAgentEnv' AgentClient
c (AM' (Maybe (VersionSMPA, PQSupport))
 -> IO (Maybe (VersionSMPA, PQSupport)))
-> AM' (Maybe (VersionSMPA, PQSupport))
-> IO (Maybe (VersionSMPA, PQSupport))
forall a b. (a -> b) -> a -> b
$ case ConnectionRequestUri c
cReq of
  CRInvitationUri {} -> (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
 Compatible VersionSMPA)
-> (VersionSMPA, PQSupport)
invPQSupported ((Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
  Compatible VersionSMPA)
 -> (VersionSMPA, PQSupport))
-> ReaderT
     Env
     IO
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
-> AM' (Maybe (VersionSMPA, PQSupport))
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> ConnectionRequestUri 'CMInvitation
-> ReaderT
     Env
     IO
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
compatibleInvitationUri ConnectionRequestUri c
ConnectionRequestUri 'CMInvitation
cReq
    where
      invPQSupported :: (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
 Compatible VersionSMPA)
-> (VersionSMPA, PQSupport)
invPQSupported (Compatible SMPQueueInfo
_, Compatible (CR.E2ERatchetParams VersionE2E
e2eV PublicKey 'X448
_ PublicKey 'X448
_ Maybe (RKEMParams 'RKSProposed)
_), Compatible VersionSMPA
agentV) = (VersionSMPA
agentV, PQSupport
pqSup PQSupport -> PQSupport -> PQSupport
`CR.pqSupportAnd` VersionSMPA -> Maybe VersionE2E -> PQSupport
versionPQSupport_ VersionSMPA
agentV (VersionE2E -> Maybe VersionE2E
forall a. a -> Maybe a
Just VersionE2E
e2eV))
  CRContactUri {} -> (Compatible SMPQueueInfo, Compatible VersionSMPA)
-> (VersionSMPA, PQSupport)
ctPQSupported ((Compatible SMPQueueInfo, Compatible VersionSMPA)
 -> (VersionSMPA, PQSupport))
-> ReaderT
     Env IO (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
-> AM' (Maybe (VersionSMPA, PQSupport))
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> ConnectionRequestUri 'CMContact
-> ReaderT
     Env IO (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
compatibleContactUri ConnectionRequestUri c
ConnectionRequestUri 'CMContact
cReq
    where
      ctPQSupported :: (Compatible SMPQueueInfo, Compatible VersionSMPA)
-> (VersionSMPA, PQSupport)
ctPQSupported (Compatible SMPQueueInfo
_, Compatible VersionSMPA
agentV) = (VersionSMPA
agentV, PQSupport
pqSup PQSupport -> PQSupport -> PQSupport
`CR.pqSupportAnd` VersionSMPA -> Maybe VersionE2E -> PQSupport
versionPQSupport_ VersionSMPA
agentV Maybe VersionE2E
forall a. Maybe a
Nothing)

compatibleInvitationUri :: ConnectionRequestUri 'CMInvitation -> AM' (Maybe (Compatible SMPQueueInfo, Compatible (CR.RcvE2ERatchetParams 'C.X448), Compatible VersionSMPA))
compatibleInvitationUri :: ConnectionRequestUri 'CMInvitation
-> ReaderT
     Env
     IO
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
compatibleInvitationUri (CRInvitationUri ConnReqUriData {VersionRange SMPAgentVersion
crAgentVRange :: VersionRange SMPAgentVersion
$sel:crAgentVRange:ConnReqUriData :: ConnReqUriData -> VersionRange SMPAgentVersion
crAgentVRange, $sel:crSmpQueues:ConnReqUriData :: ConnReqUriData -> NonEmpty SMPQueueUri
crSmpQueues = (SMPQueueUri
qUri :| [SMPQueueUri]
_)} RcvE2ERatchetParamsUri 'X448
e2eRcvParamsUri) = do
  AgentConfig {VersionRangeSMPC
$sel:smpClientVRange:AgentConfig :: AgentConfig -> VersionRangeSMPC
smpClientVRange :: VersionRangeSMPC
smpClientVRange, VersionRange SMPAgentVersion
$sel:smpAgentVRange:AgentConfig :: AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange :: VersionRange SMPAgentVersion
smpAgentVRange, VersionRangeE2E
$sel:e2eEncryptVRange:AgentConfig :: AgentConfig -> VersionRangeE2E
e2eEncryptVRange :: VersionRangeE2E
e2eEncryptVRange} <- (Env -> AgentConfig) -> ReaderT Env IO AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
  Maybe
  (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
   Compatible VersionSMPA)
-> ReaderT
     Env
     IO
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe
   (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
    Compatible VersionSMPA)
 -> ReaderT
      Env
      IO
      (Maybe
         (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
          Compatible VersionSMPA)))
-> Maybe
     (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
      Compatible VersionSMPA)
-> ReaderT
     Env
     IO
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
forall a b. (a -> b) -> a -> b
$
    (,,)
      (Compatible SMPQueueInfo
 -> Compatible (RcvE2ERatchetParams 'X448)
 -> Compatible VersionSMPA
 -> (Compatible SMPQueueInfo,
     Compatible (RcvE2ERatchetParams 'X448), Compatible VersionSMPA))
-> Maybe (Compatible SMPQueueInfo)
-> Maybe
     (Compatible (RcvE2ERatchetParams 'X448)
      -> Compatible VersionSMPA
      -> (Compatible SMPQueueInfo,
          Compatible (RcvE2ERatchetParams 'X448), Compatible VersionSMPA))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SMPQueueUri
qUri SMPQueueUri
-> VersionRangeSMPC
-> Maybe (Compatible (VersionT SMPClientVersion SMPQueueUri))
forall v a.
VersionRangeI v a =>
a -> VersionRange v -> Maybe (Compatible (VersionT v a))
`compatibleVersion` VersionRangeSMPC
smpClientVRange)
      Maybe
  (Compatible (RcvE2ERatchetParams 'X448)
   -> Compatible VersionSMPA
   -> (Compatible SMPQueueInfo,
       Compatible (RcvE2ERatchetParams 'X448), Compatible VersionSMPA))
-> Maybe (Compatible (RcvE2ERatchetParams 'X448))
-> Maybe
     (Compatible VersionSMPA
      -> (Compatible SMPQueueInfo,
          Compatible (RcvE2ERatchetParams 'X448), Compatible VersionSMPA))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (RcvE2ERatchetParamsUri 'X448
e2eRcvParamsUri RcvE2ERatchetParamsUri 'X448
-> VersionRangeE2E
-> Maybe
     (Compatible (VersionT E2EVersion (RcvE2ERatchetParamsUri 'X448)))
forall v a.
VersionRangeI v a =>
a -> VersionRange v -> Maybe (Compatible (VersionT v a))
`compatibleVersion` VersionRangeE2E
e2eEncryptVRange)
      Maybe
  (Compatible VersionSMPA
   -> (Compatible SMPQueueInfo,
       Compatible (RcvE2ERatchetParams 'X448), Compatible VersionSMPA))
-> Maybe (Compatible VersionSMPA)
-> Maybe
     (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
      Compatible VersionSMPA)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (VersionRange SMPAgentVersion
crAgentVRange VersionRange SMPAgentVersion
-> VersionRange SMPAgentVersion
-> Maybe
     (Compatible
        (VersionT SMPAgentVersion (VersionRange SMPAgentVersion)))
forall v a.
VersionRangeI v a =>
a -> VersionRange v -> Maybe (Compatible (VersionT v a))
`compatibleVersion` VersionRange SMPAgentVersion
smpAgentVRange)

compatibleContactUri :: ConnectionRequestUri 'CMContact -> AM' (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
compatibleContactUri :: ConnectionRequestUri 'CMContact
-> ReaderT
     Env IO (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
compatibleContactUri (CRContactUri ConnReqUriData {VersionRange SMPAgentVersion
$sel:crAgentVRange:ConnReqUriData :: ConnReqUriData -> VersionRange SMPAgentVersion
crAgentVRange :: VersionRange SMPAgentVersion
crAgentVRange, $sel:crSmpQueues:ConnReqUriData :: ConnReqUriData -> NonEmpty SMPQueueUri
crSmpQueues = (SMPQueueUri
qUri :| [SMPQueueUri]
_)}) = do
  AgentConfig {VersionRangeSMPC
$sel:smpClientVRange:AgentConfig :: AgentConfig -> VersionRangeSMPC
smpClientVRange :: VersionRangeSMPC
smpClientVRange, VersionRange SMPAgentVersion
$sel:smpAgentVRange:AgentConfig :: AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange :: VersionRange SMPAgentVersion
smpAgentVRange} <- (Env -> AgentConfig) -> ReaderT Env IO AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
  Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)
-> ReaderT
     Env IO (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)
 -> ReaderT
      Env IO (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)))
-> Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)
-> ReaderT
     Env IO (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
forall a b. (a -> b) -> a -> b
$
    (,)
      (Compatible SMPQueueInfo
 -> Compatible VersionSMPA
 -> (Compatible SMPQueueInfo, Compatible VersionSMPA))
-> Maybe (Compatible SMPQueueInfo)
-> Maybe
     (Compatible VersionSMPA
      -> (Compatible SMPQueueInfo, Compatible VersionSMPA))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SMPQueueUri
qUri SMPQueueUri
-> VersionRangeSMPC
-> Maybe (Compatible (VersionT SMPClientVersion SMPQueueUri))
forall v a.
VersionRangeI v a =>
a -> VersionRange v -> Maybe (Compatible (VersionT v a))
`compatibleVersion` VersionRangeSMPC
smpClientVRange)
      Maybe
  (Compatible VersionSMPA
   -> (Compatible SMPQueueInfo, Compatible VersionSMPA))
-> Maybe (Compatible VersionSMPA)
-> Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (VersionRange SMPAgentVersion
crAgentVRange VersionRange SMPAgentVersion
-> VersionRange SMPAgentVersion
-> Maybe
     (Compatible
        (VersionT SMPAgentVersion (VersionRange SMPAgentVersion)))
forall v a.
VersionRangeI v a =>
a -> VersionRange v -> Maybe (Compatible (VersionT v a))
`compatibleVersion` VersionRange SMPAgentVersion
smpAgentVRange)

versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport
versionPQSupport_ :: VersionSMPA -> Maybe VersionE2E -> PQSupport
versionPQSupport_ VersionSMPA
agentV Maybe VersionE2E
e2eV_ = Bool -> PQSupport
PQSupport (Bool -> PQSupport) -> Bool -> PQSupport
forall a b. (a -> b) -> a -> b
$ VersionSMPA
agentV VersionSMPA -> VersionSMPA -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMPA
pqdrSMPAgentVersion Bool -> Bool -> Bool
&& Bool -> (VersionE2E -> Bool) -> Maybe VersionE2E -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (VersionE2E -> VersionE2E -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionE2E
CR.pqRatchetE2EEncryptVersion) Maybe VersionE2E
e2eV_
{-# INLINE versionPQSupport_ #-}

joinConnSrv :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM (SndQueueSecured, Maybe ClientServiceId)
joinConnSrv :: forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (Bool, Maybe ClientServiceId)
joinConnSrv AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId Bool
enableNtfs inv :: ConnectionRequestUri c
inv@CRInvitationUri {} ConnId
cInfo PQSupport
pqSup SubscriptionMode
subMode SMPServerWithAuth
srv =
  AgentClient
-> ConnId
-> Text
-> AM (Bool, Maybe ClientServiceId)
-> AM (Bool, Maybe ClientServiceId)
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withInvLock AgentClient
c (ConnectionRequestUri c -> ConnId
forall a. StrEncoding a => a -> ConnId
strEncode ConnectionRequestUri c
inv) Text
"joinConnSrv" (AM (Bool, Maybe ClientServiceId)
 -> AM (Bool, Maybe ClientServiceId))
-> AM (Bool, Maybe ClientServiceId)
-> AM (Bool, Maybe ClientServiceId)
forall a b. (a -> b) -> a -> b
$ do
    SomeConn SConnType d
cType Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
    case Connection' d RcvQueue SndQueue
conn of
      NewConnection ConnData
_ -> Maybe RcvQueue
-> Maybe SndQueue -> AM (Bool, Maybe ClientServiceId)
doJoin Maybe RcvQueue
forall a. Maybe a
Nothing Maybe SndQueue
forall a. Maybe a
Nothing
      SndConnection ConnData
_ SndQueue
sq -> Maybe RcvQueue
-> Maybe SndQueue -> AM (Bool, Maybe ClientServiceId)
doJoin Maybe RcvQueue
forall a. Maybe a
Nothing (SndQueue -> Maybe SndQueue
forall a. a -> Maybe a
Just SndQueue
sq)
      DuplexConnection ConnData
_ (rq :: RcvQueue
rq@RcvQueue {$sel:status:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueStatus
status = QueueStatus
New} :| [RcvQueue]
_) (sq :: SndQueue
sq@SndQueue {$sel:status:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> QueueStatus
status = QueueStatus
sqStatus} :| [SndQueue]
_)
        | QueueStatus
sqStatus QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
New Bool -> Bool -> Bool
|| QueueStatus
sqStatus QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
Secured -> Maybe RcvQueue
-> Maybe SndQueue -> AM (Bool, Maybe ClientServiceId)
doJoin (RcvQueue -> Maybe RcvQueue
forall a. a -> Maybe a
Just RcvQueue
rq) (SndQueue -> Maybe SndQueue
forall a. a -> Maybe a
Just SndQueue
sq)
      Connection' d RcvQueue SndQueue
_ -> AgentErrorType -> AM (Bool, Maybe ClientServiceId)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (Bool, Maybe ClientServiceId))
-> AgentErrorType -> AM (Bool, Maybe ClientServiceId)
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"joinConnSrv: bad connection " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SConnType d -> String
forall a. Show a => a -> String
show SConnType d
cType
  where
    doJoin :: Maybe RcvQueue -> Maybe SndQueue -> AM (SndQueueSecured, Maybe ClientServiceId)
    doJoin :: Maybe RcvQueue
-> Maybe SndQueue -> AM (Bool, Maybe ClientServiceId)
doJoin Maybe RcvQueue
rq_ Maybe SndQueue
sq_ = do
      (ConnData
cData, SndQueue
sq, SndE2ERatchetParams 'X448
e2eSndParams, Maybe QueueId
lnkId_) <- AgentClient
-> UserId
-> ConnId
-> Maybe SndQueue
-> Bool
-> ConnectionRequestUri 'CMInvitation
-> PQSupport
-> AM
     (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
startJoinInvitation AgentClient
c UserId
userId ConnId
connId Maybe SndQueue
sq_ Bool
enableNtfs ConnectionRequestUri c
ConnectionRequestUri 'CMInvitation
inv PQSupport
pqSup
      AgentClient
-> NetworkRequestMode
-> ConnData
-> Maybe RcvQueue
-> SndQueue
-> SMPServerWithAuth
-> ConnId
-> Maybe (SndE2ERatchetParams 'X448)
-> SubscriptionMode
-> AM (Bool, Maybe ClientServiceId)
secureConfirmQueue AgentClient
c NetworkRequestMode
nm ConnData
cData Maybe RcvQueue
rq_ SndQueue
sq SMPServerWithAuth
srv ConnId
cInfo (SndE2ERatchetParams 'X448 -> Maybe (SndE2ERatchetParams 'X448)
forall a. a -> Maybe a
Just SndE2ERatchetParams 'X448
e2eSndParams) SubscriptionMode
subMode
        AM (Bool, Maybe ClientServiceId)
-> ((Bool, Maybe ClientServiceId)
    -> AM (Bool, Maybe ClientServiceId))
-> AM (Bool, Maybe ClientServiceId)
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
>>= ((QueueId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Maybe QueueId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient
-> ConnId
-> SMPServerWithAuth
-> QueueId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
delInvSL AgentClient
c ConnId
connId SMPServerWithAuth
srv) Maybe QueueId
lnkId_ ExceptT AgentErrorType (ReaderT Env IO) ()
-> (Bool, Maybe ClientServiceId)
-> AM (Bool, Maybe ClientServiceId)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
joinConnSrv AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId Bool
enableNtfs cReqUri :: ConnectionRequestUri c
cReqUri@CRContactUri {} ConnId
cInfo PQSupport
pqSup SubscriptionMode
subMode SMPServerWithAuth
srv =
  ReaderT
  Env IO (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
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 (ConnectionRequestUri 'CMContact
-> ReaderT
     Env IO (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
compatibleContactUri ConnectionRequestUri c
ConnectionRequestUri 'CMContact
cReqUri) ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
-> (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)
    -> AM (Bool, Maybe ClientServiceId))
-> AM (Bool, Maybe ClientServiceId)
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 (Compatible SMPQueueInfo
qInfo, vrsn :: Compatible VersionSMPA
vrsn@(Compatible VersionSMPA
v)) ->
      AgentClient
-> ConnId
-> Text
-> AM (Bool, Maybe ClientServiceId)
-> AM (Bool, Maybe ClientServiceId)
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withInvLock AgentClient
c (ConnectionRequestUri c -> ConnId
forall a. StrEncoding a => a -> ConnId
strEncode ConnectionRequestUri c
cReqUri) Text
"joinConnSrv" (AM (Bool, Maybe ClientServiceId)
 -> AM (Bool, Maybe ClientServiceId))
-> AM (Bool, Maybe ClientServiceId)
-> AM (Bool, Maybe ClientServiceId)
forall a b. (a -> b) -> a -> b
$ do
        SomeConn SConnType d
cType Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
        let pqInitKeys :: InitialKeys
pqInitKeys = Bool -> PQSupport -> InitialKeys
CR.joinContactInitialKeys (VersionSMPA
v VersionSMPA -> VersionSMPA -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMPA
pqdrSMPAgentVersion) PQSupport
pqSup
        (CCLink ConnectionRequestUri 'CMInvitation
cReq Maybe (ConnShortLink 'CMInvitation)
_, Maybe ClientServiceId
service) <- case Connection' d RcvQueue SndQueue
conn of
          NewConnection ConnData
_ -> AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> SConnectionMode 'CMInvitation
-> Maybe (UserConnLinkData 'CMInvitation)
-> Maybe Text
-> InitialKeys
-> SubscriptionMode
-> SMPServerWithAuth
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (CreatedConnLink 'CMInvitation, Maybe ClientServiceId)
forall (c :: ConnectionMode).
ConnectionModeI c =>
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> SConnectionMode c
-> Maybe (UserConnLinkData c)
-> Maybe Text
-> InitialKeys
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (CreatedConnLink c, Maybe ClientServiceId)
newRcvConnSrv AgentClient
c NetworkRequestMode
NRMBackground UserId
userId ConnId
connId Bool
enableNtfs SConnectionMode 'CMInvitation
SCMInvitation Maybe (UserConnLinkData 'CMInvitation)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing InitialKeys
pqInitKeys SubscriptionMode
subMode SMPServerWithAuth
srv
          RcvConnection ConnData
_ RcvQueue
rq -> RcvQueue
-> InitialKeys
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (CreatedConnLink 'CMInvitation, Maybe ClientServiceId)
mkJoinInvitation RcvQueue
rq InitialKeys
pqInitKeys
          Connection' d RcvQueue SndQueue
_ -> AgentErrorType
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (CreatedConnLink 'CMInvitation, Maybe ClientServiceId)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (CreatedConnLink 'CMInvitation, Maybe ClientServiceId))
-> AgentErrorType
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (CreatedConnLink 'CMInvitation, Maybe ClientServiceId)
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"joinConnSrv: bad connection " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SConnType d -> String
forall a. Show a => a -> String
show SConnType d
cType
        ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Compatible SMPQueueInfo
-> Compatible VersionSMPA
-> ConnectionRequestUri 'CMInvitation
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
sendInvitation AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId Compatible SMPQueueInfo
qInfo Compatible VersionSMPA
vrsn ConnectionRequestUri 'CMInvitation
cReq ConnId
cInfo
        (Bool, Maybe ClientServiceId) -> AM (Bool, Maybe ClientServiceId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, Maybe ClientServiceId
service)
      where
        mkJoinInvitation :: RcvQueue
-> InitialKeys
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (CreatedConnLink 'CMInvitation, Maybe ClientServiceId)
mkJoinInvitation rq :: RcvQueue
rq@RcvQueue {Maybe (StoredClientService 'DBStored)
clientService :: Maybe (StoredClientService 'DBStored)
$sel:clientService:RcvQueue :: forall (q :: DBStored).
StoredRcvQueue q -> Maybe (StoredClientService q)
clientService} InitialKeys
pqInitKeys = 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
          AgentConfig {$sel:smpClientVRange:AgentConfig :: AgentConfig -> VersionRangeSMPC
smpClientVRange = VersionRangeSMPC
vr, VersionRange SMPAgentVersion
$sel:smpAgentVRange:AgentConfig :: AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange :: VersionRange SMPAgentVersion
smpAgentVRange, $sel:e2eEncryptVRange:AgentConfig :: AgentConfig -> VersionRangeE2E
e2eEncryptVRange = VersionRangeE2E
e2eVR} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
          let qUri :: SMPQueueUri
qUri = VersionRangeSMPC -> SMPQueueAddress -> SMPQueueUri
SMPQueueUri VersionRangeSMPC
vr (SMPQueueAddress -> SMPQueueUri) -> SMPQueueAddress -> SMPQueueUri
forall a b. (a -> b) -> a -> b
$ (RcvQueue -> SMPQueueAddress
rcvSMPQueueAddress RcvQueue
rq) {queueMode = Just QMMessaging}
              crData :: ConnReqUriData
crData = ServiceScheme
-> VersionRange SMPAgentVersion
-> NonEmpty SMPQueueUri
-> Maybe Text
-> ConnReqUriData
ConnReqUriData ServiceScheme
SSSimplex VersionRange SMPAgentVersion
smpAgentVRange [Item (NonEmpty SMPQueueUri)
SMPQueueUri
qUri] Maybe Text
forall a. Maybe a
Nothing
          RcvE2ERatchetParams 'X448
e2eRcvParams <- AgentClient
-> (Connection -> IO (RcvE2ERatchetParams 'X448))
-> AM (RcvE2ERatchetParams 'X448)
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO (RcvE2ERatchetParams 'X448))
 -> AM (RcvE2ERatchetParams 'X448))
-> (Connection -> IO (RcvE2ERatchetParams 'X448))
-> AM (RcvE2ERatchetParams 'X448)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
            Connection -> ConnId -> IO ()
lockConnForUpdate Connection
db ConnId
connId
            Connection
-> ConnId
-> IO
     (Either
        StoreError
        (PrivateKey 'X448, PrivateKey 'X448,
         Maybe (PrivRKEMParams 'RKSProposed)))
getRatchetX3dhKeys Connection
db ConnId
connId IO
  (Either
     StoreError
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed)))
-> (Either
      StoreError
      (PrivateKey 'X448, PrivateKey 'X448,
       Maybe (PrivRKEMParams 'RKSProposed))
    -> IO (RcvE2ERatchetParams 'X448))
-> IO (RcvE2ERatchetParams 'X448)
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 (PrivateKey 'X448, PrivateKey 'X448,
 Maybe (PrivRKEMParams 'RKSProposed))
keys -> RcvE2ERatchetParams 'X448 -> IO (RcvE2ERatchetParams 'X448)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RcvE2ERatchetParams 'X448 -> IO (RcvE2ERatchetParams 'X448))
-> RcvE2ERatchetParams 'X448 -> IO (RcvE2ERatchetParams 'X448)
forall a b. (a -> b) -> a -> b
$ VersionE2E
-> (PrivateKey 'X448, PrivateKey 'X448,
    Maybe (PrivRKEMParams 'RKSProposed))
-> RcvE2ERatchetParams 'X448
forall (a :: Algorithm).
VersionE2E
-> (PrivateKey a, PrivateKey a,
    Maybe (PrivRKEMParams 'RKSProposed))
-> RcvE2ERatchetParams a
CR.mkRcvE2ERatchetParams (VersionRangeE2E -> VersionE2E
forall v. VersionRange v -> Version v
maxVersion VersionRangeE2E
e2eVR) (PrivateKey 'X448, PrivateKey 'X448,
 Maybe (PrivRKEMParams 'RKSProposed))
keys
              Left StoreError
e -> do
                TBQueue ATransmission -> ATransmission -> IO ()
forall a. TBQueue a -> a -> IO ()
nonBlockingWriteTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ConnId
"", ConnId
connId, SAEntity 'AEConn -> AEvent 'AEConn -> AEvt
forall (e :: AEntity). AEntityI e => SAEntity e -> AEvent e -> AEvt
AEvt SAEntity 'AEConn
SAEConn (AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> AEvent 'AEConn)
-> AgentErrorType -> AEvent 'AEConn
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"no rcv ratchet " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> StoreError -> String
forall a. Show a => a -> String
show StoreError
e))
                let pqEnc :: PQSupport
pqEnc = Bool -> InitialKeys -> PQSupport
CR.initialPQEncryption Bool
False InitialKeys
pqInitKeys
                (PrivateKey 'X448
pk1, PrivateKey 'X448
pk2, Maybe (PrivRKEMParams 'RKSProposed)
pKem, RcvE2ERatchetParams 'X448
e2eRcvParams) <- IO
  (PrivateKey 'X448, PrivateKey 'X448,
   Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
-> IO
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (PrivateKey 'X448, PrivateKey 'X448,
    Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
 -> IO
      (PrivateKey 'X448, PrivateKey 'X448,
       Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448))
-> IO
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
-> IO
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> VersionE2E
-> PQSupport
-> IO
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> VersionE2E
-> PQSupport
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed),
      E2ERatchetParams 'RKSProposed a)
CR.generateRcvE2EParams TVar ChaChaDRG
g (VersionRangeE2E -> VersionE2E
forall v. VersionRange v -> Version v
maxVersion VersionRangeE2E
e2eVR) PQSupport
pqEnc
                Connection
-> ConnId
-> PrivateKey 'X448
-> PrivateKey 'X448
-> Maybe (PrivRKEMParams 'RKSProposed)
-> IO ()
createRatchetX3dhKeys Connection
db ConnId
connId PrivateKey 'X448
pk1 PrivateKey 'X448
pk2 Maybe (PrivRKEMParams 'RKSProposed)
pKem
                RcvE2ERatchetParams 'X448 -> IO (RcvE2ERatchetParams 'X448)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RcvE2ERatchetParams 'X448
e2eRcvParams
          let cReq :: ConnectionRequestUri 'CMInvitation
cReq = ConnReqUriData
-> RcvE2ERatchetParamsUri 'X448
-> ConnectionRequestUri 'CMInvitation
CRInvitationUri ConnReqUriData
crData (RcvE2ERatchetParamsUri 'X448
 -> ConnectionRequestUri 'CMInvitation)
-> RcvE2ERatchetParamsUri 'X448
-> ConnectionRequestUri 'CMInvitation
forall a b. (a -> b) -> a -> b
$ RcvE2ERatchetParams 'X448
-> VersionRangeE2E
-> VersionRangeT E2EVersion (RcvE2ERatchetParams 'X448)
forall v a.
VersionI v a =>
a -> VersionRange v -> VersionRangeT v a
toVersionRangeT RcvE2ERatchetParams 'X448
e2eRcvParams VersionRangeE2E
e2eVR
          (CreatedConnLink 'CMInvitation, Maybe ClientServiceId)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (CreatedConnLink 'CMInvitation, Maybe ClientServiceId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectionRequestUri 'CMInvitation
-> Maybe (ConnShortLink 'CMInvitation)
-> CreatedConnLink 'CMInvitation
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
CCLink ConnectionRequestUri 'CMInvitation
cReq Maybe (ConnShortLink 'CMInvitation)
forall a. Maybe a
Nothing, StoredClientService 'DBStored -> ClientServiceId
forall (s :: DBStored). StoredClientService s -> DBEntityId' s
dbServiceId (StoredClientService 'DBStored -> ClientServiceId)
-> Maybe (StoredClientService 'DBStored) -> Maybe ClientServiceId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (StoredClientService 'DBStored)
clientService)
    Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)
Nothing -> AgentErrorType -> AM (Bool, Maybe ClientServiceId)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (Bool, Maybe ClientServiceId))
-> AgentErrorType -> AM (Bool, Maybe ClientServiceId)
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION

delInvSL :: AgentClient -> ConnId -> SMPServerWithAuth -> SMP.LinkId -> AM ()
delInvSL :: AgentClient
-> ConnId
-> SMPServerWithAuth
-> QueueId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
delInvSL AgentClient
c ConnId
connId SMPServerWithAuth
srv QueueId
lnkId =
  AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (\Connection
db -> Connection -> SMPServer -> QueueId -> IO ()
deleteInvShortLink Connection
db (SMPServerWithAuth -> SMPServer
forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtocolServer p
protoServer SMPServerWithAuth
srv) QueueId
lnkId) ExceptT AgentErrorType (ReaderT Env IO) ()
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
`catchE` \AgentErrorType
e ->
    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) (ConnId
"", ConnId
connId, SAEntity 'AEConn -> AEvent 'AEConn -> AEvt
forall (e :: AEntity). AEntityI e => SAEntity e -> AEvent e -> AEvt
AEvt SAEntity 'AEConn
SAEConn (AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> AEvent 'AEConn)
-> AgentErrorType -> AEvent 'AEConn
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"error deleting short link " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> AgentErrorType -> String
forall a. Show a => a -> String
show AgentErrorType
e))

joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM (SndQueueSecured, Maybe ClientServiceId)
joinConnSrvAsync :: forall (c :: ConnectionMode).
AgentClient
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (Bool, Maybe ClientServiceId)
joinConnSrvAsync AgentClient
c UserId
userId ConnId
connId Bool
enableNtfs inv :: ConnectionRequestUri c
inv@CRInvitationUri {} ConnId
cInfo PQSupport
pqSupport SubscriptionMode
subMode SMPServerWithAuth
srv = do
  SomeConn SConnType d
cType Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
  case Connection' d RcvQueue SndQueue
conn of
    NewConnection ConnData
_ -> Maybe RcvQueue
-> Maybe SndQueue -> AM (Bool, Maybe ClientServiceId)
doJoin Maybe RcvQueue
forall a. Maybe a
Nothing Maybe SndQueue
forall a. Maybe a
Nothing
    SndConnection ConnData
_ SndQueue
sq -> Maybe RcvQueue
-> Maybe SndQueue -> AM (Bool, Maybe ClientServiceId)
doJoin Maybe RcvQueue
forall a. Maybe a
Nothing (SndQueue -> Maybe SndQueue
forall a. a -> Maybe a
Just SndQueue
sq)
    -- this branch should never be reached with async flow because once receive queue is created,
    -- there are not more failure points (sending confirmation is asynchronous)
    DuplexConnection ConnData
_ (rq :: RcvQueue
rq@RcvQueue {$sel:status:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueStatus
status = QueueStatus
New} :| [RcvQueue]
_) (sq :: SndQueue
sq@SndQueue {$sel:status:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> QueueStatus
status = QueueStatus
sqStatus} :| [SndQueue]
_)
      | QueueStatus
sqStatus QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
New Bool -> Bool -> Bool
|| QueueStatus
sqStatus QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
Secured -> Maybe RcvQueue
-> Maybe SndQueue -> AM (Bool, Maybe ClientServiceId)
doJoin (RcvQueue -> Maybe RcvQueue
forall a. a -> Maybe a
Just RcvQueue
rq) (SndQueue -> Maybe SndQueue
forall a. a -> Maybe a
Just SndQueue
sq)
    Connection' d RcvQueue SndQueue
_ -> AgentErrorType -> AM (Bool, Maybe ClientServiceId)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (Bool, Maybe ClientServiceId))
-> AgentErrorType -> AM (Bool, Maybe ClientServiceId)
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"joinConnSrvAsync: bad connection " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SConnType d -> String
forall a. Show a => a -> String
show SConnType d
cType
  where
    doJoin :: Maybe RcvQueue -> Maybe SndQueue -> AM (SndQueueSecured, Maybe ClientServiceId)
    doJoin :: Maybe RcvQueue
-> Maybe SndQueue -> AM (Bool, Maybe ClientServiceId)
doJoin Maybe RcvQueue
rq_ Maybe SndQueue
sq_ = do
      (ConnData
cData, SndQueue
sq, SndE2ERatchetParams 'X448
e2eSndParams, Maybe QueueId
lnkId_) <- AgentClient
-> UserId
-> ConnId
-> Maybe SndQueue
-> Bool
-> ConnectionRequestUri 'CMInvitation
-> PQSupport
-> AM
     (ConnData, SndQueue, SndE2ERatchetParams 'X448, Maybe QueueId)
startJoinInvitation AgentClient
c UserId
userId ConnId
connId Maybe SndQueue
sq_ Bool
enableNtfs ConnectionRequestUri c
ConnectionRequestUri 'CMInvitation
inv PQSupport
pqSupport
      AgentClient
-> ConnData
-> Maybe RcvQueue
-> SndQueue
-> SMPServerWithAuth
-> ConnId
-> Maybe (SndE2ERatchetParams 'X448)
-> SubscriptionMode
-> AM (Bool, Maybe ClientServiceId)
secureConfirmQueueAsync AgentClient
c ConnData
cData Maybe RcvQueue
rq_ SndQueue
sq SMPServerWithAuth
srv ConnId
cInfo (SndE2ERatchetParams 'X448 -> Maybe (SndE2ERatchetParams 'X448)
forall a. a -> Maybe a
Just SndE2ERatchetParams 'X448
e2eSndParams) SubscriptionMode
subMode
        AM (Bool, Maybe ClientServiceId)
-> ((Bool, Maybe ClientServiceId)
    -> AM (Bool, Maybe ClientServiceId))
-> AM (Bool, Maybe ClientServiceId)
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
>>= ((QueueId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Maybe QueueId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient
-> ConnId
-> SMPServerWithAuth
-> QueueId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
delInvSL AgentClient
c ConnId
connId SMPServerWithAuth
srv) Maybe QueueId
lnkId_ ExceptT AgentErrorType (ReaderT Env IO) ()
-> (Bool, Maybe ClientServiceId)
-> AM (Bool, Maybe ClientServiceId)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
joinConnSrvAsync AgentClient
_c UserId
_userId ConnId
_connId Bool
_enableNtfs (CRContactUri ConnReqUriData
_) ConnId
_cInfo PQSupport
_subMode SubscriptionMode
_pqSupport SMPServerWithAuth
_srv = do
  AgentErrorType -> AM (Bool, Maybe ClientServiceId)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (Bool, Maybe ClientServiceId))
-> AgentErrorType -> AM (Bool, Maybe ClientServiceId)
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"joinConnSrvAsync"

createReplyQueue :: AgentClient -> NetworkRequestMode -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM (SMPQueueInfo, Maybe ClientServiceId)
createReplyQueue :: AgentClient
-> NetworkRequestMode
-> ConnData
-> SndQueue
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (SMPQueueInfo, Maybe ClientServiceId)
createReplyQueue AgentClient
c NetworkRequestMode
nm ConnData {UserId
$sel:userId:ConnData :: ConnData -> UserId
userId :: UserId
userId, ConnId
$sel:connId:ConnData :: ConnData -> ConnId
connId :: ConnId
connId, Bool
$sel:enableNtfs:ConnData :: ConnData -> Bool
enableNtfs :: Bool
enableNtfs} SndQueue {VersionSMPC
smpClientVersion :: VersionSMPC
$sel:smpClientVersion:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> VersionSMPC
smpClientVersion} SubscriptionMode
subMode SMPServerWithAuth
srv = do
  Maybe NtfServer
ntfServer_ <- if Bool
enableNtfs then AM (Maybe NtfServer)
newQueueNtfServer else Maybe NtfServer -> AM (Maybe NtfServer)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NtfServer
forall a. Maybe a
Nothing
  (StoredRcvQueue 'DBNew
rq, SMPQueueUri
qUri, (UserId, SMPServer, Maybe ConnId)
tSess, ConnId
sessId) <- AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> SMPServerWithAuth
-> VersionRangeSMPC
-> SConnectionMode 'CMInvitation
-> Bool
-> SubscriptionMode
-> AM
     (StoredRcvQueue 'DBNew, SMPQueueUri, TransportSession BrokerMsg,
      ConnId)
forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> SMPServerWithAuth
-> VersionRangeSMPC
-> SConnectionMode c
-> Bool
-> SubscriptionMode
-> AM
     (StoredRcvQueue 'DBNew, SMPQueueUri, TransportSession BrokerMsg,
      ConnId)
newRcvQueue AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId SMPServerWithAuth
srv (VersionSMPC -> VersionRangeSMPC
forall v. Version v -> VersionRange v
versionToRange VersionSMPC
smpClientVersion) SConnectionMode 'CMInvitation
SCMInvitation (Maybe NtfServer -> Bool
forall a. Maybe a -> Bool
isJust Maybe NtfServer
ntfServer_) SubscriptionMode
subMode
  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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId (StoredRcvQueue 'DBNew -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer StoredRcvQueue 'DBNew
rq) AgentSMPServerStats -> TVar Int
connCreated
  let qInfo :: VersionT SMPClientVersion SMPQueueUri
qInfo = SMPQueueUri -> VersionSMPC -> VersionT SMPClientVersion SMPQueueUri
forall v a. VersionRangeI v a => a -> Version v -> VersionT v a
toVersionT SMPQueueUri
qUri VersionSMPC
smpClientVersion
  RcvQueue
rq' <- AgentClient
-> (Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue)
-> (Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ConnId
-> StoredRcvQueue 'DBNew
-> SubscriptionMode
-> IO (Either StoreError RcvQueue)
upgradeSndConnToDuplex Connection
db ConnId
connId StoredRcvQueue 'DBNew
rq SubscriptionMode
subMode
  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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SubscriptionMode
subMode SubscriptionMode -> SubscriptionMode -> Bool
forall a. Eq a => a -> a -> Bool
== SubscriptionMode
SMSubscribe) (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> RcvQueue
-> TransportSession BrokerMsg
-> ConnId
-> ReaderT Env IO ()
addNewQueueSubscription AgentClient
c RcvQueue
rq' TransportSession BrokerMsg
(UserId, SMPServer, Maybe ConnId)
tSess ConnId
sessId
  (NtfServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Maybe NtfServer -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient
-> RcvQueue
-> NtfServer
-> ExceptT AgentErrorType (ReaderT Env IO) ()
newQueueNtfSubscription AgentClient
c RcvQueue
rq') Maybe NtfServer
ntfServer_
  (SMPQueueInfo, Maybe ClientServiceId)
-> AM (SMPQueueInfo, Maybe ClientServiceId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VersionT SMPClientVersion SMPQueueUri
SMPQueueInfo
qInfo, RcvQueue -> Maybe ClientServiceId
clientServiceId RcvQueue
rq')

-- | Approve confirmation (LET command) in Reader monad
allowConnection' :: AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> AM ()
allowConnection' :: AgentClient
-> ConnId
-> ConnId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
allowConnection' AgentClient
c ConnId
connId ConnId
confId ConnId
ownConnInfo = AgentClient
-> ConnId
-> Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
"allowConnection" (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
$ do
  AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId) AM SomeConn
-> (SomeConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
    SomeConn SConnType d
_ (RcvConnection ConnData
_ RcvQueue {SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server :: SMPServer
server, QueueId
rcvId :: QueueId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueId
rcvId}) -> do
      AcceptedConfirmation {$sel:senderConf:AcceptedConfirmation :: AcceptedConfirmation -> SMPConfirmation
senderConf = SMPConfirmation {Maybe SndPublicAuthKey
senderKey :: Maybe SndPublicAuthKey
$sel:senderKey:SMPConfirmation :: SMPConfirmation -> Maybe SndPublicAuthKey
senderKey}} <-
        AgentClient
-> (Connection -> IO (Either StoreError AcceptedConfirmation))
-> AM AcceptedConfirmation
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError AcceptedConfirmation))
 -> AM AcceptedConfirmation)
-> (Connection -> IO (Either StoreError AcceptedConfirmation))
-> AM AcceptedConfirmation
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ConnId -> ConnId -> IO (Either StoreError AcceptedConfirmation)
acceptConfirmation Connection
db ConnId
confId ConnId
ownConnInfo
      AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
"" ConnId
connId (SMPServer -> Maybe SMPServer
forall a. a -> Maybe a
Just SMPServer
server) (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (InternalCommand -> AgentCommand)
-> InternalCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalCommand -> AgentCommand
AInternalCommand (InternalCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> InternalCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ QueueId -> Maybe SndPublicAuthKey -> InternalCommand
ICAllowSecure QueueId
rcvId Maybe SndPublicAuthKey
senderKey
    SomeConn
_ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"allowConnection"

-- | Accept contact (ACPT command) in Reader monad
acceptContact' :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
acceptContact' :: AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnId
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM (Bool, Maybe ClientServiceId)
acceptContact' AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId Bool
enableNtfs ConnId
invId ConnId
ownConnInfo PQSupport
pqSupport SubscriptionMode
subMode = AgentClient
-> ConnId
-> Text
-> AM (Bool, Maybe ClientServiceId)
-> AM (Bool, Maybe ClientServiceId)
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
"acceptContact" (AM (Bool, Maybe ClientServiceId)
 -> AM (Bool, Maybe ClientServiceId))
-> AM (Bool, Maybe ClientServiceId)
-> AM (Bool, Maybe ClientServiceId)
forall a b. (a -> b) -> a -> b
$ do
  Invitation {ConnectionRequestUri 'CMInvitation
$sel:connReq:Invitation :: Invitation -> ConnectionRequestUri 'CMInvitation
connReq :: ConnectionRequestUri 'CMInvitation
connReq} <- AgentClient
-> (Connection -> IO (Either StoreError Invitation))
-> AM Invitation
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError Invitation))
 -> AM Invitation)
-> (Connection -> IO (Either StoreError Invitation))
-> AM Invitation
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> String -> ConnId -> IO (Either StoreError Invitation)
getInvitation Connection
db String
"acceptContact'" ConnId
invId
  (Bool, Maybe ClientServiceId)
r <- AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri 'CMInvitation
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM (Bool, Maybe ClientServiceId)
forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> AM (Bool, Maybe ClientServiceId)
joinConn AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId Bool
enableNtfs ConnectionRequestUri 'CMInvitation
connReq ConnId
ownConnInfo PQSupport
pqSupport SubscriptionMode
subMode
  AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> ConnId -> IO ()
acceptInvitation Connection
db ConnId
invId ConnId
ownConnInfo
  (Bool, Maybe ClientServiceId) -> AM (Bool, Maybe ClientServiceId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool, Maybe ClientServiceId)
r

-- | Reject contact (RJCT command) in Reader monad
rejectContact' :: AgentClient -> InvitationId -> AM ()
rejectContact' :: AgentClient -> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
rejectContact' AgentClient
c ConnId
invId =
  AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> IO ()
deleteInvitation Connection
db ConnId
invId
{-# INLINE rejectContact' #-}

syncConnections' :: AgentClient -> [UserId] -> [ConnId] -> AM (DatabaseDiff UserId, DatabaseDiff ConnId)
syncConnections' :: AgentClient
-> [UserId]
-> [ConnId]
-> AM (DatabaseDiff UserId, DatabaseDiff ConnId)
syncConnections' AgentClient
c [UserId]
userIds [ConnId]
connIds = do
  r :: (DatabaseDiff UserId, DatabaseDiff ConnId)
r@(DatabaseDiff {$sel:extraIds:DatabaseDiff :: forall a. DatabaseDiff a -> [a]
extraIds = [UserId]
uIds}, DatabaseDiff {$sel:extraIds:DatabaseDiff :: forall a. DatabaseDiff a -> [a]
extraIds = [ConnId]
cIds}) <- AgentClient
-> [UserId]
-> [ConnId]
-> AM (DatabaseDiff UserId, DatabaseDiff ConnId)
compareConnections' AgentClient
c [UserId]
userIds [ConnId]
connIds
  [UserId]
-> (UserId -> 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_ [UserId]
uIds ((UserId -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (UserId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \UserId
uid -> AgentClient
-> UserId -> Bool -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteUser' AgentClient
c UserId
uid Bool
False
  AgentClient
-> Bool -> [ConnId] -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnectionsAsync' AgentClient
c Bool
False [ConnId]
cIds
  (DatabaseDiff UserId, DatabaseDiff ConnId)
-> AM (DatabaseDiff UserId, DatabaseDiff ConnId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DatabaseDiff UserId, DatabaseDiff ConnId)
r

compareConnections' :: AgentClient -> [UserId] -> [ConnId] -> AM (DatabaseDiff UserId, DatabaseDiff ConnId)
compareConnections' :: AgentClient
-> [UserId]
-> [ConnId]
-> AM (DatabaseDiff UserId, DatabaseDiff ConnId)
compareConnections' AgentClient
c [UserId]
userIds [ConnId]
connIds = do
  [UserId]
knownUserIds <- AgentClient -> (Connection -> IO [UserId]) -> AM [UserId]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO [UserId]
getUserIds
  [ConnId]
knownConnIds <- AgentClient -> (Connection -> IO [ConnId]) -> AM [ConnId]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO [ConnId]
getConnIds
  (DatabaseDiff UserId, DatabaseDiff ConnId)
-> AM (DatabaseDiff UserId, DatabaseDiff ConnId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([UserId] -> [UserId] -> DatabaseDiff UserId
forall a. Ord a => [a] -> [a] -> DatabaseDiff a
databaseDiff [UserId]
userIds [UserId]
knownUserIds, [ConnId] -> [ConnId] -> DatabaseDiff ConnId
forall a. Ord a => [a] -> [a] -> DatabaseDiff a
databaseDiff [ConnId]
connIds [ConnId]
knownConnIds)

databaseDiff :: Ord a => [a] -> [a] -> DatabaseDiff a
databaseDiff :: forall a. Ord a => [a] -> [a] -> DatabaseDiff a
databaseDiff [a]
passed [a]
known =
  let passedSet :: Set a
passedSet = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
passed
      knownSet :: Set a
knownSet = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
known
      missingIds :: [a]
missingIds = Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ Set a
passedSet Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set a
knownSet
      extraIds :: [a]
extraIds = Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ Set a
knownSet Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set a
passedSet
   in DatabaseDiff {[a]
$sel:missingIds:DatabaseDiff :: [a]
missingIds :: [a]
missingIds, [a]
$sel:extraIds:DatabaseDiff :: [a]
extraIds :: [a]
extraIds}

-- | Subscribe to receive connection messages (SUB command) in Reader monad
subscribeConnection' :: AgentClient -> ConnId -> AM (Maybe ClientServiceId)
subscribeConnection' :: AgentClient -> ConnId -> AM (Maybe ClientServiceId)
subscribeConnection' AgentClient
c ConnId
connId = ConnId
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> AM (Maybe ClientServiceId)
forall a. ConnId -> Map ConnId (Either AgentErrorType a) -> AM a
toConnResult ConnId
connId (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
 -> AM (Maybe ClientServiceId))
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
-> AM (Maybe ClientServiceId)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AgentClient
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
subscribeConnections' AgentClient
c [ConnId
Item [ConnId]
connId]
{-# INLINE subscribeConnection' #-}

toConnResult :: ConnId -> Map ConnId (Either AgentErrorType a) -> AM a
toConnResult :: forall a. ConnId -> Map ConnId (Either AgentErrorType a) -> AM a
toConnResult ConnId
connId Map ConnId (Either AgentErrorType a)
rs = case ConnId
-> Map ConnId (Either AgentErrorType a)
-> Maybe (Either AgentErrorType a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ConnId
connId Map ConnId (Either AgentErrorType a)
rs of
  Just (Right a
r) -> a
r a -> ExceptT AgentErrorType (ReaderT Env IO) () -> AM 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
<$ Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map ConnId (Either AgentErrorType a) -> Int
forall k a. Map k a -> Int
M.size Map ConnId (Either AgentErrorType a)
rs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"too many results " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Map ConnId (Either AgentErrorType a) -> Int
forall k a. Map k a -> Int
M.size Map ConnId (Either AgentErrorType a)
rs))
  Just (Left AgentErrorType
e) -> AgentErrorType -> AM a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e
  Maybe (Either AgentErrorType a)
_ -> AgentErrorType -> AM a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM a) -> AgentErrorType -> AM a
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"no result for connection " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ConnId -> String
B.unpack ConnId
connId

type QCmdResult a = (QueueStatus, Either AgentErrorType a)

type QDelResult = QCmdResult ()

type QSubResult = QCmdResult (Maybe SMP.ServiceId)

subscribeConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
subscribeConnections' :: AgentClient
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
subscribeConnections' AgentClient
_ [] = Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
forall k a. Map k a
M.empty
subscribeConnections' AgentClient
c [ConnId]
connIds = AgentClient
-> [(ConnId, Either StoreError SomeConnSub)]
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
subscribeConnections_ AgentClient
c ([(ConnId, Either StoreError SomeConnSub)]
 -> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))))
-> ([Either StoreError SomeConnSub]
    -> [(ConnId, Either StoreError SomeConnSub)])
-> [Either StoreError SomeConnSub]
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ConnId]
-> [Either StoreError SomeConnSub]
-> [(ConnId, Either StoreError SomeConnSub)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ConnId]
connIds ([Either StoreError SomeConnSub]
 -> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))))
-> ExceptT
     AgentErrorType (ReaderT Env IO) [Either StoreError SomeConnSub]
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AgentClient
-> (Connection -> IO [Either StoreError SomeConnSub])
-> ExceptT
     AgentErrorType (ReaderT Env IO) [Either StoreError SomeConnSub]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> [ConnId] -> IO [Either StoreError SomeConnSub]
`getConnSubs` [ConnId]
connIds)

subscribeConnections_ :: AgentClient -> [(ConnId, Either StoreError SomeConnSub)] -> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
subscribeConnections_ :: AgentClient
-> [(ConnId, Either StoreError SomeConnSub)]
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
subscribeConnections_ AgentClient
c [(ConnId, Either StoreError SomeConnSub)]
conns = do
  let (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
subRs, [(ConnId, SomeConnSub)]
cs) = ((ConnId, Either StoreError SomeConnSub)
 -> (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)),
     [(ConnId, SomeConnSub)])
 -> (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)),
     [(ConnId, SomeConnSub)]))
-> (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)),
    [(ConnId, SomeConnSub)])
-> [(ConnId, Either StoreError SomeConnSub)]
-> (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)),
    [(ConnId, SomeConnSub)])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ConnId, Either StoreError SomeConnSub)
-> (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)),
    [(ConnId, SomeConnSub)])
-> (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)),
    [(ConnId, SomeConnSub)])
partitionResultsConns ([], []) [(ConnId, Either StoreError SomeConnSub)]
conns
  [(ConnId, SomeConnSub)]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
resumeDelivery [(ConnId, SomeConnSub)]
cs
  AgentClient
-> [ConnId] -> ExceptT AgentErrorType (ReaderT Env IO) ()
resumeConnCmds AgentClient
c ([ConnId] -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> [ConnId] -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ((ConnId, SomeConnSub) -> ConnId)
-> [(ConnId, SomeConnSub)] -> [ConnId]
forall a b. (a -> b) -> [a] -> [b]
map (ConnId, SomeConnSub) -> ConnId
forall a b. (a, b) -> a
fst [(ConnId, SomeConnSub)]
cs
  Map ConnId (Either AgentErrorType (Maybe QueueId))
rcvRs <- ReaderT Env IO (Map ConnId (Either AgentErrorType (Maybe QueueId)))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Map ConnId (Either AgentErrorType (Maybe QueueId)))
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 (Map ConnId (Either AgentErrorType (Maybe QueueId)))
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (Map ConnId (Either AgentErrorType (Maybe QueueId))))
-> ReaderT
     Env IO (Map ConnId (Either AgentErrorType (Maybe QueueId)))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Map ConnId (Either AgentErrorType (Maybe QueueId)))
forall a b. (a -> b) -> a -> b
$ [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
-> Map ConnId (Either AgentErrorType (Maybe QueueId))
connResults ([(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
 -> Map ConnId (Either AgentErrorType (Maybe QueueId)))
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
-> ReaderT
     Env IO (Map ConnId (Either AgentErrorType (Maybe QueueId)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> Bool
-> [RcvQueueSub]
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
subscribeQueues AgentClient
c Bool
False (((ConnId, SomeConnSub) -> [RcvQueueSub])
-> [(ConnId, SomeConnSub)] -> [RcvQueueSub]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ConnId, SomeConnSub) -> [RcvQueueSub]
rcvQueues [(ConnId, SomeConnSub)]
cs)
  Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rcvRs' <- Map ConnId (Either AgentErrorType (Maybe QueueId))
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
storeClientServiceAssocs Map ConnId (Either AgentErrorType (Maybe QueueId))
rcvRs
  NtfSupervisor
ns <- (Env -> NtfSupervisor)
-> ExceptT AgentErrorType (ReaderT Env IO) NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
  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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO Bool -> ReaderT Env IO () -> ReaderT Env IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (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
$ NtfSupervisor -> IO Bool
hasInstantNotifications NtfSupervisor
ns) (ReaderT Env IO () -> ReaderT Env IO ())
-> (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO ()
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Env IO ThreadId -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Env IO ThreadId -> ReaderT Env IO ())
-> (ReaderT Env IO () -> ReaderT Env IO ThreadId)
-> ReaderT Env IO ()
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Env IO () -> ReaderT Env IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (ReaderT Env IO () -> ReaderT Env IO ThreadId)
-> (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO ()
-> ReaderT Env IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ NtfSupervisor
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> [(ConnId, SomeConnSub)]
-> ReaderT Env IO ()
sendNtfCreate NtfSupervisor
ns Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rcvRs' [(ConnId, SomeConnSub)]
cs
  -- union is left-biased
  let rs :: Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rs = Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rcvRs' Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
subRs
  Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyResultError Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rs
  Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rs
  where
    partitionResultsConns ::
      (ConnId, Either StoreError SomeConnSub) ->
      (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)), [(ConnId, SomeConnSub)]) ->
      (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)), [(ConnId, SomeConnSub)])
    partitionResultsConns :: (ConnId, Either StoreError SomeConnSub)
-> (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)),
    [(ConnId, SomeConnSub)])
-> (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)),
    [(ConnId, SomeConnSub)])
partitionResultsConns (ConnId
connId, Either StoreError SomeConnSub
conn_) (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rs, [(ConnId, SomeConnSub)]
cs) = case Either StoreError SomeConnSub
conn_ of
      Left StoreError
e -> (ConnId
-> Either AgentErrorType (Maybe ClientServiceId)
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ConnId
connId (AgentErrorType -> Either AgentErrorType (Maybe ClientServiceId)
forall a b. a -> Either a b
Left (AgentErrorType -> Either AgentErrorType (Maybe ClientServiceId))
-> AgentErrorType -> Either AgentErrorType (Maybe ClientServiceId)
forall a b. (a -> b) -> a -> b
$ StoreError -> AgentErrorType
storeError StoreError
e) Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rs, [(ConnId, SomeConnSub)]
cs)
      Right c' :: SomeConnSub
c'@(SomeConn SConnType d
_ Connection' d RcvQueueSub SndQueue
conn) -> case Connection' d RcvQueueSub SndQueue
conn of
        DuplexConnection {} -> (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rs, [(ConnId, SomeConnSub)]
cs')
        SndConnection ConnData
_ SndQueue
sq -> (ConnId
-> Either AgentErrorType (Maybe ClientServiceId)
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ConnId
connId (SndQueue -> Either AgentErrorType (Maybe ClientServiceId)
sndSubResult SndQueue
sq) Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rs, [(ConnId, SomeConnSub)]
cs')
        RcvConnection ConnData
_ RcvQueueSub
_ -> (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rs, [(ConnId, SomeConnSub)]
cs')
        ContactConnection ConnData
_ RcvQueueSub
_ -> (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rs, [(ConnId, SomeConnSub)]
cs')
        NewConnection ConnData
_ -> (ConnId
-> Either AgentErrorType (Maybe ClientServiceId)
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ConnId
connId (Maybe ClientServiceId
-> Either AgentErrorType (Maybe ClientServiceId)
forall a b. b -> Either a b
Right Maybe ClientServiceId
forall a. Maybe a
Nothing) Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rs, [(ConnId, SomeConnSub)]
cs')
        where
          cs' :: [(ConnId, SomeConnSub)]
cs' = (ConnId
connId, SomeConnSub
c') (ConnId, SomeConnSub)
-> [(ConnId, SomeConnSub)] -> [(ConnId, SomeConnSub)]
forall a. a -> [a] -> [a]
: [(ConnId, SomeConnSub)]
cs
    sndSubResult :: SndQueue -> Either AgentErrorType (Maybe ClientServiceId)
    sndSubResult :: SndQueue -> Either AgentErrorType (Maybe ClientServiceId)
sndSubResult SndQueue {QueueStatus
$sel:status:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> QueueStatus
status :: QueueStatus
status} = case QueueStatus
status of
      QueueStatus
Confirmed -> Maybe ClientServiceId
-> Either AgentErrorType (Maybe ClientServiceId)
forall a b. b -> Either a b
Right Maybe ClientServiceId
forall a. Maybe a
Nothing
      QueueStatus
Active -> AgentErrorType -> Either AgentErrorType (Maybe ClientServiceId)
forall a b. a -> Either a b
Left (AgentErrorType -> Either AgentErrorType (Maybe ClientServiceId))
-> AgentErrorType -> Either AgentErrorType (Maybe ClientServiceId)
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX String
"subscribeConnections"
      QueueStatus
_ -> AgentErrorType -> Either AgentErrorType (Maybe ClientServiceId)
forall a b. a -> Either a b
Left (AgentErrorType -> Either AgentErrorType (Maybe ClientServiceId))
-> AgentErrorType -> Either AgentErrorType (Maybe ClientServiceId)
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"unexpected queue status"
    rcvQueues :: (ConnId, SomeConnSub) -> [RcvQueueSub]
    rcvQueues :: (ConnId, SomeConnSub) -> [RcvQueueSub]
rcvQueues (ConnId
_, SomeConn SConnType d
_ Connection' d RcvQueueSub SndQueue
conn) = Connection' d RcvQueueSub SndQueue -> [RcvQueueSub]
forall (d :: ConnType) rq sq. Connection' d rq sq -> [rq]
connRcvQueues Connection' d RcvQueueSub SndQueue
conn
    connResults :: [(RcvQueueSub, Either AgentErrorType (Maybe SMP.ServiceId))] -> Map ConnId (Either AgentErrorType (Maybe SMP.ServiceId))
    connResults :: [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
-> Map ConnId (Either AgentErrorType (Maybe QueueId))
connResults = ((QueueStatus, Either AgentErrorType (Maybe QueueId))
 -> Either AgentErrorType (Maybe QueueId))
-> Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
-> Map ConnId (Either AgentErrorType (Maybe QueueId))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (QueueStatus, Either AgentErrorType (Maybe QueueId))
-> Either AgentErrorType (Maybe QueueId)
forall a b. (a, b) -> b
snd (Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
 -> Map ConnId (Either AgentErrorType (Maybe QueueId)))
-> ([(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
    -> Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId)))
-> [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
-> Map ConnId (Either AgentErrorType (Maybe QueueId))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
 -> (RcvQueueSub, Either AgentErrorType (Maybe QueueId))
 -> Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId)))
-> Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
-> [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
-> Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
-> (RcvQueueSub, Either AgentErrorType (Maybe QueueId))
-> Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
addResult Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
forall k a. Map k a
M.empty
      where
        -- collects results by connection ID
        addResult :: Map ConnId QSubResult -> (RcvQueueSub, Either AgentErrorType (Maybe SMP.ServiceId)) -> Map ConnId QSubResult
        addResult :: Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
-> (RcvQueueSub, Either AgentErrorType (Maybe QueueId))
-> Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
addResult Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
rs (RcvQueueSub {ConnId
connId :: ConnId
$sel:connId:RcvQueueSub :: RcvQueueSub -> ConnId
connId, QueueStatus
status :: QueueStatus
$sel:status:RcvQueueSub :: RcvQueueSub -> QueueStatus
status}, Either AgentErrorType (Maybe QueueId)
r) = (Maybe (QueueStatus, Either AgentErrorType (Maybe QueueId))
 -> Maybe (QueueStatus, Either AgentErrorType (Maybe QueueId)))
-> ConnId
-> Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
-> Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter ((QueueStatus, Either AgentErrorType (Maybe QueueId))
-> Maybe (QueueStatus, Either AgentErrorType (Maybe QueueId))
-> Maybe (QueueStatus, Either AgentErrorType (Maybe QueueId))
combineRes (QueueStatus
status, Either AgentErrorType (Maybe QueueId)
r)) ConnId
connId Map ConnId (QueueStatus, Either AgentErrorType (Maybe QueueId))
rs
        -- combines two results for one connection, by using only Active queues (if there is at least one Active queue)
        combineRes :: QSubResult -> Maybe QSubResult -> Maybe QSubResult
        combineRes :: (QueueStatus, Either AgentErrorType (Maybe QueueId))
-> Maybe (QueueStatus, Either AgentErrorType (Maybe QueueId))
-> Maybe (QueueStatus, Either AgentErrorType (Maybe QueueId))
combineRes (QueueStatus, Either AgentErrorType (Maybe QueueId))
r' (Just (QueueStatus, Either AgentErrorType (Maybe QueueId))
r) = (QueueStatus, Either AgentErrorType (Maybe QueueId))
-> Maybe (QueueStatus, Either AgentErrorType (Maybe QueueId))
forall a. a -> Maybe a
Just ((QueueStatus, Either AgentErrorType (Maybe QueueId))
 -> Maybe (QueueStatus, Either AgentErrorType (Maybe QueueId)))
-> (QueueStatus, Either AgentErrorType (Maybe QueueId))
-> Maybe (QueueStatus, Either AgentErrorType (Maybe QueueId))
forall a b. (a -> b) -> a -> b
$ if (QueueStatus, Either AgentErrorType (Maybe QueueId)) -> Int
order (QueueStatus, Either AgentErrorType (Maybe QueueId))
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= (QueueStatus, Either AgentErrorType (Maybe QueueId)) -> Int
order (QueueStatus, Either AgentErrorType (Maybe QueueId))
r' then (QueueStatus, Either AgentErrorType (Maybe QueueId))
r else (QueueStatus, Either AgentErrorType (Maybe QueueId))
r'
        combineRes (QueueStatus, Either AgentErrorType (Maybe QueueId))
r' Maybe (QueueStatus, Either AgentErrorType (Maybe QueueId))
_ = (QueueStatus, Either AgentErrorType (Maybe QueueId))
-> Maybe (QueueStatus, Either AgentErrorType (Maybe QueueId))
forall a. a -> Maybe a
Just (QueueStatus, Either AgentErrorType (Maybe QueueId))
r'
        order :: QSubResult -> Int
        order :: (QueueStatus, Either AgentErrorType (Maybe QueueId)) -> Int
order (QueueStatus
Active, Right Maybe QueueId
_) = Int
1
        order (QueueStatus
Active, Either AgentErrorType (Maybe QueueId)
_) = Int
2
        order (QueueStatus
_, Right Maybe QueueId
_) = Int
3
        order (QueueStatus, Either AgentErrorType (Maybe QueueId))
_ = Int
4
    -- TODO [certs rcv] store associations of queues with client service ID
    storeClientServiceAssocs :: Map ConnId (Either AgentErrorType (Maybe SMP.ServiceId)) -> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
    storeClientServiceAssocs :: Map ConnId (Either AgentErrorType (Maybe QueueId))
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
storeClientServiceAssocs = Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
 -> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))))
-> (Map ConnId (Either AgentErrorType (Maybe QueueId))
    -> Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
-> Map ConnId (Either AgentErrorType (Maybe QueueId))
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either AgentErrorType (Maybe QueueId)
 -> Either AgentErrorType (Maybe ClientServiceId))
-> Map ConnId (Either AgentErrorType (Maybe QueueId))
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Maybe ClientServiceId
forall a. Maybe a
Nothing Maybe ClientServiceId
-> Either AgentErrorType (Maybe QueueId)
-> Either AgentErrorType (Maybe ClientServiceId)
forall a b. a -> Either AgentErrorType b -> Either AgentErrorType a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)
    sendNtfCreate :: NtfSupervisor -> Map ConnId (Either AgentErrorType (Maybe ClientServiceId)) -> [(ConnId, SomeConnSub)] -> AM' ()
    sendNtfCreate :: NtfSupervisor
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> [(ConnId, SomeConnSub)]
-> ReaderT Env IO ()
sendNtfCreate NtfSupervisor
ns Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rcvRs [(ConnId, SomeConnSub)]
cs = do
      let oks :: Set ConnId
oks = Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> Set ConnId
forall k a. Map k a -> Set k
M.keysSet (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
 -> Set ConnId)
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> Set ConnId
forall a b. (a -> b) -> a -> b
$ (Either AgentErrorType (Maybe ClientServiceId) -> Bool)
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((AgentErrorType -> Bool)
-> (Maybe ClientServiceId -> Bool)
-> Either AgentErrorType (Maybe ClientServiceId)
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either AgentErrorType -> Bool
temporaryAgentError ((Maybe ClientServiceId -> Bool)
 -> Either AgentErrorType (Maybe ClientServiceId) -> Bool)
-> (Maybe ClientServiceId -> Bool)
-> Either AgentErrorType (Maybe ClientServiceId)
-> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ClientServiceId -> Bool
forall a b. a -> b -> a
const Bool
True) Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rcvRs
          ([ConnId]
csCreate, [ConnId]
csDelete) = ((ConnId, SomeConnSub)
 -> ([ConnId], [ConnId]) -> ([ConnId], [ConnId]))
-> ([ConnId], [ConnId])
-> [(ConnId, SomeConnSub)]
-> ([ConnId], [ConnId])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Set ConnId
-> (ConnId, SomeConnSub)
-> ([ConnId], [ConnId])
-> ([ConnId], [ConnId])
forall {a} {rq} {sq}.
Ord a =>
Set a -> (a, SomeConn' rq sq) -> ([a], [a]) -> ([a], [a])
groupConnIds Set ConnId
oks) ([], []) [(ConnId, SomeConnSub)]
cs
      NtfSupervisorCommand -> [ConnId] -> ReaderT Env IO ()
sendNtfCmd NtfSupervisorCommand
NSCCreate [ConnId]
csCreate
      NtfSupervisorCommand -> [ConnId] -> ReaderT Env IO ()
sendNtfCmd NtfSupervisorCommand
NSCSmpDelete [ConnId]
csDelete
      where
        groupConnIds :: Set a -> (a, SomeConn' rq sq) -> ([a], [a]) -> ([a], [a])
groupConnIds Set a
oks (a
connId, SomeConn SConnType d
_ Connection' d rq sq
conn) acc :: ([a], [a])
acc@([a]
csCreate, [a]
csDelete)
          | a
connId a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set a
oks = ([a], [a])
acc
          | Bool
enableNtfs = (a
connId a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
csCreate, [a]
csDelete)
          | Bool
otherwise = ([a]
csCreate, a
connId a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
csDelete)
          where
            ConnData {Bool
$sel:enableNtfs:ConnData :: ConnData -> Bool
enableNtfs :: Bool
enableNtfs} = Connection' d rq sq -> ConnData
forall (d :: ConnType) rq sq. Connection' d rq sq -> ConnData
toConnData Connection' d rq sq
conn
        sendNtfCmd :: NtfSupervisorCommand -> [ConnId] -> ReaderT Env IO ()
sendNtfCmd NtfSupervisorCommand
cmd = (NonEmpty ConnId -> ReaderT Env IO ())
-> Maybe (NonEmpty ConnId) -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\NonEmpty ConnId
cids -> 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
$ TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
-> (NtfSupervisorCommand, NonEmpty ConnId) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (NtfSupervisor -> TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
ntfSubQ NtfSupervisor
ns) (NtfSupervisorCommand
cmd, NonEmpty ConnId
cids)) (Maybe (NonEmpty ConnId) -> ReaderT Env IO ())
-> ([ConnId] -> Maybe (NonEmpty ConnId))
-> [ConnId]
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ConnId] -> Maybe (NonEmpty ConnId)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty
    resumeDelivery :: [(ConnId, SomeConnSub)] -> AM ()
    resumeDelivery :: [(ConnId, SomeConnSub)]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
resumeDelivery [(ConnId, SomeConnSub)]
conns' = do
      Set ConnId
deliverTo <- [ConnId] -> Set ConnId
forall a. Ord a => [a] -> Set a
S.fromList ([ConnId] -> Set ConnId)
-> AM [ConnId]
-> ExceptT AgentErrorType (ReaderT Env IO) (Set ConnId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient -> (Connection -> IO [ConnId]) -> AM [ConnId]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO [ConnId]
getConnectionsForDelivery
      let conns'' :: [(ConnId, SomeConnSub)]
conns'' = ((ConnId, SomeConnSub) -> Bool)
-> [(ConnId, SomeConnSub)] -> [(ConnId, SomeConnSub)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ConnId -> Set ConnId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set ConnId
deliverTo) (ConnId -> Bool)
-> ((ConnId, SomeConnSub) -> ConnId)
-> (ConnId, SomeConnSub)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConnId, SomeConnSub) -> ConnId
forall a b. (a, b) -> a
fst) [(ConnId, SomeConnSub)]
conns'
      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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ((ConnId, SomeConnSub) -> ReaderT Env IO ())
-> [(ConnId, SomeConnSub)] -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((SndQueue -> ReaderT Env IO ()) -> [SndQueue] -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient -> SndQueue -> ReaderT Env IO ()
resumeMsgDelivery AgentClient
c) ([SndQueue] -> ReaderT Env IO ())
-> ((ConnId, SomeConnSub) -> [SndQueue])
-> (ConnId, SomeConnSub)
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConnId, SomeConnSub) -> [SndQueue]
sndQueues) [(ConnId, SomeConnSub)]
conns''
    sndQueues :: (ConnId, SomeConnSub) -> [SndQueue]
    sndQueues :: (ConnId, SomeConnSub) -> [SndQueue]
sndQueues (ConnId
_, SomeConn SConnType d
_ Connection' d RcvQueueSub SndQueue
conn) = case Connection' d RcvQueueSub SndQueue
conn of
      DuplexConnection ConnData
_ NonEmpty RcvQueueSub
_ NonEmpty SndQueue
sqs -> NonEmpty SndQueue -> [SndQueue]
forall a. NonEmpty a -> [a]
L.toList NonEmpty SndQueue
sqs
      SndConnection ConnData
_ SndQueue
sq -> [Item [SndQueue]
SndQueue
sq]
      Connection' d RcvQueueSub SndQueue
_ -> []
    notifyResultError :: Map ConnId (Either AgentErrorType (Maybe ClientServiceId)) -> AM ()
    notifyResultError :: Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyResultError Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rs = do
      let actual :: Int
actual = Map ConnId (Either AgentErrorType (Maybe ClientServiceId)) -> Int
forall k a. Map k a -> Int
M.size Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
rs
          expected :: Int
expected = [(ConnId, Either StoreError SomeConnSub)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ConnId, Either StoreError SomeConnSub)]
conns
      Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
actual Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
expected) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> STM ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
$
        TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ConnId
"", ConnId
"", 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
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"subscribeConnections result size: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
actual String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", expected " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
expected)

subscribeAllConnections' :: AgentClient -> Bool -> Maybe UserId -> AM ()
subscribeAllConnections' :: AgentClient
-> Bool
-> Maybe UserId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
subscribeAllConnections' AgentClient
c Bool
onlyNeeded Maybe UserId
activeUserId_ = ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
handleErr (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
$ do
  [(UserId, SMPServer)]
userSrvs <- AgentClient
-> (Connection -> IO [(UserId, SMPServer)])
-> AM [(UserId, SMPServer)]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> Bool -> IO [(UserId, SMPServer)]
`getSubscriptionServers` Bool
onlyNeeded)
  Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(UserId, SMPServer)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UserId, SMPServer)]
userSrvs) (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
$ do
    Int
batchSize <- (Env -> Int) -> AM Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> Int) -> AM Int) -> (Env -> Int) -> AM 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
    let userSrvs' :: [(UserId, SMPServer)]
userSrvs' = case Maybe UserId
activeUserId_ of
          Just UserId
activeUserId -> ((UserId, SMPServer) -> Int)
-> [(UserId, SMPServer)] -> [(UserId, SMPServer)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(UserId
uId, SMPServer
_) -> if UserId
uId UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== UserId
activeUserId then Int
0 else Int
1 :: Int) [(UserId, SMPServer)]
userSrvs
          Maybe UserId
Nothing -> [(UserId, SMPServer)]
userSrvs
    [Either AgentErrorType Int]
rs <- ReaderT Env IO [Either AgentErrorType Int]
-> ExceptT
     AgentErrorType (ReaderT Env IO) [Either AgentErrorType Int]
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 [Either AgentErrorType Int]
 -> ExceptT
      AgentErrorType (ReaderT Env IO) [Either AgentErrorType Int])
-> ReaderT Env IO [Either AgentErrorType Int]
-> ExceptT
     AgentErrorType (ReaderT Env IO) [Either AgentErrorType Int]
forall a b. (a -> b) -> a -> b
$ ((UserId, SMPServer) -> ReaderT Env IO (Either AgentErrorType Int))
-> [(UserId, SMPServer)]
-> ReaderT Env IO [Either AgentErrorType Int]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
(a -> m b) -> t a -> m (t b)
mapConcurrently (Int
-> (UserId, SMPServer)
-> ReaderT Env IO (Either AgentErrorType Int)
subscribeUserServer Int
batchSize) [(UserId, SMPServer)]
userSrvs'
    let ([AgentErrorType]
errs, [Int]
oks) = [Either AgentErrorType Int] -> ([AgentErrorType], [Int])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either AgentErrorType Int]
rs
    Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ Text
"subscribed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
oks) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" queues"
    Maybe (NonEmpty AgentErrorType)
-> (NonEmpty AgentErrorType
    -> 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_ ([AgentErrorType] -> Maybe (NonEmpty AgentErrorType)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [AgentErrorType]
errs) ((NonEmpty AgentErrorType
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (NonEmpty AgentErrorType
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> AEvent 'AENone -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *).
MonadIO m =>
AgentClient -> AEvent 'AENone -> m ()
notifySub AgentClient
c (AEvent 'AENone -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (NonEmpty AgentErrorType -> AEvent 'AENone)
-> NonEmpty AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ConnId, AgentErrorType) -> AEvent 'AENone
ERRS (NonEmpty (ConnId, AgentErrorType) -> AEvent 'AENone)
-> (NonEmpty AgentErrorType -> NonEmpty (ConnId, AgentErrorType))
-> NonEmpty AgentErrorType
-> AEvent 'AENone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AgentErrorType -> (ConnId, AgentErrorType))
-> NonEmpty AgentErrorType -> NonEmpty (ConnId, AgentErrorType)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (ConnId
"",)
    AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO ()
unsetQueuesToSubscribe
  ExceptT AgentErrorType (ReaderT Env IO) ()
resumeAllDelivery
  AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) ()
resumeAllCommands AgentClient
c
  where
    handleErr :: ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
handleErr = (ExceptT AgentErrorType (ReaderT Env IO) ()
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \AgentErrorType
e -> AgentClient
-> ConnId
-> AEvent 'AEConn
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AgentClient -> ConnId -> AEvent e -> m ()
notifySub' AgentClient
c ConnId
"" (AgentErrorType -> AEvent 'AEConn
ERR AgentErrorType
e) ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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 -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e)
    subscribeUserServer :: Int -> (UserId, SMPServer) -> AM' (Either AgentErrorType Int)
    subscribeUserServer :: Int
-> (UserId, SMPServer)
-> ReaderT Env IO (Either AgentErrorType Int)
subscribeUserServer Int
batchSize (UserId
userId, SMPServer
srv) = AM Int -> ReaderT Env IO (Either AgentErrorType Int)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (AM Int -> ReaderT Env IO (Either AgentErrorType Int))
-> AM Int -> ReaderT Env IO (Either AgentErrorType Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe QueueId -> AM Int
loop Int
0 Maybe QueueId
forall a. Maybe a
Nothing
      where
        loop :: Int -> Maybe QueueId -> AM Int
loop !Int
n Maybe QueueId
cursor_ = do
          [RcvQueueSub]
qs <- AgentClient -> (Connection -> IO [RcvQueueSub]) -> AM [RcvQueueSub]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO [RcvQueueSub]) -> AM [RcvQueueSub])
-> (Connection -> IO [RcvQueueSub]) -> AM [RcvQueueSub]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> UserId
-> SMPServer
-> Bool
-> Int
-> Maybe QueueId
-> IO [RcvQueueSub]
getUserServerRcvQueueSubs Connection
db UserId
userId SMPServer
srv Bool
onlyNeeded Int
batchSize Maybe QueueId
cursor_
          if [RcvQueueSub] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RcvQueueSub]
qs then Int -> AM Int
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n else do
            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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ [RcvQueueSub] -> ReaderT Env IO ()
subscribe [RcvQueueSub]
qs
            let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [RcvQueueSub] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RcvQueueSub]
qs
                lastRcvId :: Maybe QueueId
lastRcvId = QueueId -> Maybe QueueId
forall a. a -> Maybe a
Just (QueueId -> Maybe QueueId) -> QueueId -> Maybe QueueId
forall a b. (a -> b) -> a -> b
$ RcvQueueSub -> QueueId
forall q. SMPQueue q => q -> QueueId
queueId (RcvQueueSub -> QueueId) -> RcvQueueSub -> QueueId
forall a b. (a -> b) -> a -> b
$ [RcvQueueSub] -> RcvQueueSub
forall a. (?callStack::CallStack) => [a] -> a
last [RcvQueueSub]
qs
            if [RcvQueueSub] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RcvQueueSub]
qs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
batchSize then Int -> AM Int
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n' else Int -> Maybe QueueId -> AM Int
loop Int
n' Maybe QueueId
lastRcvId
        subscribe :: [RcvQueueSub] -> ReaderT Env IO ()
subscribe [RcvQueueSub]
qs = do
          [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
rs <- AgentClient
-> UserId
-> SMPServer
-> [RcvQueueSub]
-> ReaderT
     Env IO [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
subscribeUserServerQueues AgentClient
c UserId
userId SMPServer
srv [RcvQueueSub]
qs
          -- TODO [certs rcv] storeClientServiceAssocs store associations of queues with client service ID
          NtfSupervisor
ns <- (Env -> NtfSupervisor) -> ReaderT Env IO NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
          ReaderT Env IO Bool -> ReaderT Env IO () -> ReaderT Env IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (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
$ NtfSupervisor -> IO Bool
hasInstantNotifications NtfSupervisor
ns) (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ NtfSupervisor
-> [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
-> ReaderT Env IO ()
sendNtfCreate NtfSupervisor
ns [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
rs
    sendNtfCreate :: NtfSupervisor -> [(RcvQueueSub, Either AgentErrorType (Maybe SMP.ServiceId))] -> AM' ()
    sendNtfCreate :: NtfSupervisor
-> [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
-> ReaderT Env IO ()
sendNtfCreate NtfSupervisor
ns [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
rs = do
      let (Set ConnId
csCreate, Set ConnId
csDelete) = ((Set ConnId, Set ConnId)
 -> (RcvQueueSub, Either AgentErrorType (Maybe QueueId))
 -> (Set ConnId, Set ConnId))
-> (Set ConnId, Set ConnId)
-> [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
-> (Set ConnId, Set ConnId)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Set ConnId, Set ConnId)
-> (RcvQueueSub, Either AgentErrorType (Maybe QueueId))
-> (Set ConnId, Set ConnId)
forall {b}.
(Set ConnId, Set ConnId)
-> (RcvQueueSub, Either AgentErrorType b)
-> (Set ConnId, Set ConnId)
groupConnIds (Set ConnId
forall a. Set a
S.empty, Set ConnId
forall a. Set a
S.empty) [(RcvQueueSub, Either AgentErrorType (Maybe QueueId))]
rs
      NtfSupervisorCommand -> Set ConnId -> ReaderT Env IO ()
sendNtfCmd NtfSupervisorCommand
NSCCreate Set ConnId
csCreate
      NtfSupervisorCommand -> Set ConnId -> ReaderT Env IO ()
sendNtfCmd NtfSupervisorCommand
NSCSmpDelete Set ConnId
csDelete
      where
        groupConnIds :: (Set ConnId, Set ConnId)
-> (RcvQueueSub, Either AgentErrorType b)
-> (Set ConnId, Set ConnId)
groupConnIds acc :: (Set ConnId, Set ConnId)
acc@(!Set ConnId
csCreate, !Set ConnId
csDelete) (RcvQueueSub {ConnId
$sel:connId:RcvQueueSub :: RcvQueueSub -> ConnId
connId :: ConnId
connId, Bool
enableNtfs :: Bool
$sel:enableNtfs:RcvQueueSub :: RcvQueueSub -> Bool
enableNtfs}, Either AgentErrorType b
r) = case Either AgentErrorType b
r of
          Left AgentErrorType
e
            | Bool -> Bool
not (AgentErrorType -> Bool
temporaryAgentError AgentErrorType
e) -> (Set ConnId, Set ConnId)
acc
          Either AgentErrorType b
_
            | Bool
enableNtfs -> (ConnId -> Set ConnId -> Set ConnId
forall a. Ord a => a -> Set a -> Set a
S.insert ConnId
connId Set ConnId
csCreate, Set ConnId
csDelete)
            | Bool
otherwise -> (Set ConnId
csCreate, ConnId -> Set ConnId -> Set ConnId
forall a. Ord a => a -> Set a -> Set a
S.insert ConnId
connId Set ConnId
csDelete)
        sendNtfCmd :: NtfSupervisorCommand -> Set ConnId -> ReaderT Env IO ()
sendNtfCmd NtfSupervisorCommand
cmd = (NonEmpty ConnId -> ReaderT Env IO ())
-> Maybe (NonEmpty ConnId) -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\NonEmpty ConnId
cIds -> 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
$ TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
-> (NtfSupervisorCommand, NonEmpty ConnId) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (NtfSupervisor -> TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
ntfSubQ NtfSupervisor
ns) (NtfSupervisorCommand
cmd, NonEmpty ConnId
cIds)) (Maybe (NonEmpty ConnId) -> ReaderT Env IO ())
-> (Set ConnId -> Maybe (NonEmpty ConnId))
-> Set ConnId
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ConnId] -> Maybe (NonEmpty ConnId)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ([ConnId] -> Maybe (NonEmpty ConnId))
-> (Set ConnId -> [ConnId])
-> Set ConnId
-> Maybe (NonEmpty ConnId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ConnId -> [ConnId]
forall a. Set a -> [a]
S.toList
    resumeAllDelivery :: AM ()
    resumeAllDelivery :: ExceptT AgentErrorType (ReaderT Env IO) ()
resumeAllDelivery = do
      [SndQueue]
sqs <- AgentClient -> (Connection -> IO [SndQueue]) -> AM [SndQueue]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO [SndQueue]
getAllSndQueuesForDelivery
      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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ (SndQueue -> ReaderT Env IO ()) -> [SndQueue] -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient -> SndQueue -> ReaderT Env IO ()
resumeMsgDelivery AgentClient
c) [SndQueue]
sqs

resubscribeConnection' :: AgentClient -> ConnId -> AM (Maybe ClientServiceId)
resubscribeConnection' :: AgentClient -> ConnId -> AM (Maybe ClientServiceId)
resubscribeConnection' AgentClient
c ConnId
connId = ConnId
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> AM (Maybe ClientServiceId)
forall a. ConnId -> Map ConnId (Either AgentErrorType a) -> AM a
toConnResult ConnId
connId (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
 -> AM (Maybe ClientServiceId))
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
-> AM (Maybe ClientServiceId)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AgentClient
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
resubscribeConnections' AgentClient
c [ConnId
Item [ConnId]
connId]
{-# INLINE resubscribeConnection' #-}

resubscribeConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
resubscribeConnections' :: AgentClient
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
resubscribeConnections' AgentClient
_ [] = Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
forall k a. Map k a
M.empty
resubscribeConnections' AgentClient
c [ConnId]
connIds = do
  [(ConnId, Either StoreError SomeConnSub)]
conns <- [ConnId]
-> [Either StoreError SomeConnSub]
-> [(ConnId, Either StoreError SomeConnSub)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ConnId]
connIds ([Either StoreError SomeConnSub]
 -> [(ConnId, Either StoreError SomeConnSub)])
-> ExceptT
     AgentErrorType (ReaderT Env IO) [Either StoreError SomeConnSub]
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     [(ConnId, Either StoreError SomeConnSub)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> (Connection -> IO [Either StoreError SomeConnSub])
-> ExceptT
     AgentErrorType (ReaderT Env IO) [Either StoreError SomeConnSub]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> [ConnId] -> IO [Either StoreError SomeConnSub]
`getConnSubs` [ConnId]
connIds)
  let r :: Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
r = [(ConnId, Either AgentErrorType (Maybe ClientServiceId))]
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(ConnId, Either AgentErrorType (Maybe ClientServiceId))]
 -> Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
-> [(ConnId, Either AgentErrorType (Maybe ClientServiceId))]
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
forall a b. (a -> b) -> a -> b
$ (ConnId -> (ConnId, Either AgentErrorType (Maybe ClientServiceId)))
-> [ConnId]
-> [(ConnId, Either AgentErrorType (Maybe ClientServiceId))]
forall a b. (a -> b) -> [a] -> [b]
map (,Maybe ClientServiceId
-> Either AgentErrorType (Maybe ClientServiceId)
forall a b. b -> Either a b
Right Maybe ClientServiceId
forall a. Maybe a
Nothing) [ConnId]
connIds -- TODO [certs rcv]
  [(ConnId, Either StoreError SomeConnSub)]
conns' <- ((ConnId, Either StoreError SomeConnSub)
 -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> [(ConnId, Either StoreError SomeConnSub)]
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     [(ConnId, Either StoreError SomeConnSub)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool)
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a b.
(a -> b)
-> ExceptT AgentErrorType (ReaderT Env IO) a
-> ExceptT AgentErrorType (ReaderT Env IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (ExceptT AgentErrorType (ReaderT Env IO) Bool
 -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> ((ConnId, Either StoreError SomeConnSub)
    -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> (ConnId, Either StoreError SomeConnSub)
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either StoreError SomeConnSub
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
isActiveConn (Either StoreError SomeConnSub
 -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> ((ConnId, Either StoreError SomeConnSub)
    -> Either StoreError SomeConnSub)
-> (ConnId, Either StoreError SomeConnSub)
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConnId, Either StoreError SomeConnSub)
-> Either StoreError SomeConnSub
forall a b. (a, b) -> b
snd) [(ConnId, Either StoreError SomeConnSub)]
conns
  -- union is left-biased, so results returned by subscribeConnections' take precedence
  (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
-> Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
r) (Map ConnId (Either AgentErrorType (Maybe ClientServiceId))
 -> Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> [(ConnId, Either StoreError SomeConnSub)]
-> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
subscribeConnections_ AgentClient
c [(ConnId, Either StoreError SomeConnSub)]
conns'
  where
    isActiveConn :: Either StoreError SomeConnSub -> AM Bool
    isActiveConn :: Either StoreError SomeConnSub
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
isActiveConn (Left StoreError
_) = 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 -- to have results processed by subscribeConnections_
    isActiveConn (Right (SomeConn SConnType d
_ Connection' d RcvQueueSub SndQueue
conn)) = case Connection' d RcvQueueSub SndQueue -> [RcvQueueSub]
forall (d :: ConnType) rq sq. Connection' d rq sq -> [rq]
connRcvQueues Connection' d RcvQueueSub SndQueue
conn of
      [] -> 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
      [RcvQueueSub]
rqs' -> [ExceptT AgentErrorType (ReaderT Env IO) Bool]
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
anyM ([ExceptT AgentErrorType (ReaderT Env IO) Bool]
 -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> [ExceptT AgentErrorType (ReaderT Env IO) Bool]
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a b. (a -> b) -> a -> b
$ (RcvQueueSub -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> [RcvQueueSub] -> [ExceptT AgentErrorType (ReaderT Env IO) Bool]
forall a b. (a -> b) -> [a] -> [b]
map (STM Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> (RcvQueueSub -> STM Bool)
-> RcvQueueSub
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> RcvQueueSub -> STM Bool
forall q. SomeRcvQueue q => AgentClient -> q -> STM Bool
hasActiveSubscription AgentClient
c) [RcvQueueSub]
rqs'

-- TODO [certs rcv]
subscribeClientService' :: AgentClient -> ClientServiceId -> AM Int
subscribeClientService' :: AgentClient -> ClientServiceId -> AM Int
subscribeClientService' = AgentClient -> ClientServiceId -> AM Int
forall a. (?callStack::CallStack) => a
undefined

-- requesting messages sequentially, to reduce memory usage
getConnectionMessages' :: AgentClient -> NonEmpty ConnMsgReq -> AM' (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
getConnectionMessages' :: AgentClient
-> NonEmpty ConnMsgReq
-> AM' (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
getConnectionMessages' AgentClient
c = (ConnMsgReq
 -> ReaderT Env IO (Either AgentErrorType (Maybe SMPMsgMeta)))
-> NonEmpty ConnMsgReq
-> AM' (NonEmpty (Either AgentErrorType (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) -> NonEmpty a -> m (NonEmpty b)
mapM ((ConnMsgReq
  -> ReaderT Env IO (Either AgentErrorType (Maybe SMPMsgMeta)))
 -> NonEmpty ConnMsgReq
 -> AM' (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta))))
-> (ConnMsgReq
    -> ReaderT Env IO (Either AgentErrorType (Maybe SMPMsgMeta)))
-> NonEmpty ConnMsgReq
-> AM' (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
forall a b. (a -> b) -> a -> b
$ ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta)
-> ReaderT Env IO (Either AgentErrorType (Maybe SMPMsgMeta))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta)
 -> ReaderT Env IO (Either AgentErrorType (Maybe SMPMsgMeta)))
-> (ConnMsgReq
    -> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta))
-> ConnMsgReq
-> ReaderT Env IO (Either AgentErrorType (Maybe SMPMsgMeta))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnMsgReq
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta)
getConnectionMessage
  where
    getConnectionMessage :: ConnMsgReq -> AM (Maybe SMPMsgMeta)
    getConnectionMessage :: ConnMsgReq
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta)
getConnectionMessage (ConnMsgReq ConnId
connId UserId
dbQueueId Maybe InternalTs
msgTs_) = do
      SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
      RcvQueue
rq <- case Connection' d RcvQueue SndQueue
conn of
        DuplexConnection ConnData
_ (RcvQueue
rq :| [RcvQueue]
_) NonEmpty SndQueue
_ -> RcvQueue -> AM RcvQueue
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RcvQueue
rq
        RcvConnection ConnData
_ RcvQueue
rq -> RcvQueue -> AM RcvQueue
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RcvQueue
rq
        ContactConnection ConnData
_ RcvQueue
rq -> RcvQueue -> AM RcvQueue
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RcvQueue
rq
        SndConnection ConnData
_ SndQueue
_ -> AgentErrorType -> AM RcvQueue
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM RcvQueue) -> AgentErrorType -> AM RcvQueue
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX String
"getConnectionMessage"
        NewConnection ConnData
_ -> AgentErrorType -> AM RcvQueue
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM RcvQueue) -> AgentErrorType -> AM RcvQueue
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"getConnectionMessage: NewConnection"
      ExceptT AgentErrorType (ReaderT Env IO) Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (STM Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> STM Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a b. (a -> b) -> a -> b
$ AgentClient -> RcvQueue -> STM Bool
forall q. SomeRcvQueue q => AgentClient -> q -> STM Bool
hasActiveSubscription AgentClient
c RcvQueue
rq) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"getConnectionMessage: subscribed"
      Maybe SMPMsgMeta
msg_ <- AgentClient
-> RcvQueue
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta)
getQueueMessage AgentClient
c RcvQueue
rq ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta)
-> (AgentErrorType
    -> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta))
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \AgentErrorType
e -> STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (AgentClient -> RcvQueue -> STM ()
forall q. SomeRcvQueue q => AgentClient -> q -> STM ()
releaseGetLock AgentClient
c RcvQueue
rq) ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta)
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta)
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
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta)
forall a.
AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AgentErrorType
e
      Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe SMPMsgMeta -> Bool
forall a. Maybe a -> Bool
isNothing Maybe SMPMsgMeta
msg_) (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
$ 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 -> RcvQueue -> STM ()
forall q. SomeRcvQueue q => AgentClient -> q -> STM ()
releaseGetLock AgentClient
c RcvQueue
rq
        Maybe InternalTs
-> (InternalTs -> 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 InternalTs
msgTs_ ((InternalTs -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (InternalTs -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \InternalTs
msgTs -> AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> ClientServiceId -> InternalTs -> IO ()
setLastBrokerTs Connection
db ConnId
connId (UserId -> ClientServiceId
DBEntityId UserId
dbQueueId) InternalTs
msgTs
      Maybe SMPMsgMeta
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPMsgMeta)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SMPMsgMeta
msg_
{-# INLINE getConnectionMessages' #-}

getNotificationConns' :: AgentClient -> C.CbNonce -> ByteString -> AM (NonEmpty NotificationInfo)
getNotificationConns' :: AgentClient -> CbNonce -> ConnId -> AM (NonEmpty NotificationInfo)
getNotificationConns' AgentClient
c CbNonce
nonce ConnId
encNtfInfo =
  AgentClient
-> (Connection -> IO (Maybe NtfToken))
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO (Maybe NtfToken)
getActiveNtfToken ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
-> (Maybe NtfToken -> AM (NonEmpty NotificationInfo))
-> AM (NonEmpty NotificationInfo)
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 NtfToken {$sel:ntfDhSecret:NtfToken :: NtfToken -> Maybe DhSecretX25519
ntfDhSecret = Just DhSecretX25519
dhSecret} -> do
      ConnId
ntfData <- Either AgentErrorType ConnId -> AM ConnId
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either AgentErrorType ConnId -> AM ConnId)
-> Either AgentErrorType ConnId -> AM ConnId
forall a b. (a -> b) -> a -> b
$ DhSecretX25519 -> CbNonce -> ConnId -> Either AgentErrorType ConnId
agentCbDecrypt DhSecretX25519
dhSecret CbNonce
nonce ConnId
encNtfInfo
      NonEmpty PNMessageData
pnMsgs <- Either AgentErrorType (NonEmpty PNMessageData)
-> ExceptT AgentErrorType (ReaderT Env IO) (NonEmpty PNMessageData)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Parser (NonEmpty PNMessageData)
-> AgentErrorType
-> ConnId
-> Either AgentErrorType (NonEmpty PNMessageData)
forall a e. Parser a -> e -> ConnId -> Either e a
parse Parser (NonEmpty PNMessageData)
pnMessagesP (String -> AgentErrorType
INTERNAL String
"error parsing PNMessageData") ConnId
ntfData)
      let ([PNMessageData]
initNtfs, PNMessageData
lastNtf) = (NonEmpty PNMessageData -> [PNMessageData]
forall a. NonEmpty a -> [a]
L.init NonEmpty PNMessageData
pnMsgs, NonEmpty PNMessageData -> PNMessageData
forall a. NonEmpty a -> a
L.last NonEmpty PNMessageData
pnMsgs)
      [Either AgentErrorType (Maybe NotificationInfo)]
rs <-
        ReaderT Env IO [Either AgentErrorType (Maybe NotificationInfo)]
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     [Either AgentErrorType (Maybe NotificationInfo)]
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 [Either AgentErrorType (Maybe NotificationInfo)]
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      [Either AgentErrorType (Maybe NotificationInfo)])
-> ReaderT Env IO [Either AgentErrorType (Maybe NotificationInfo)]
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     [Either AgentErrorType (Maybe NotificationInfo)]
forall a b. (a -> b) -> a -> b
$ AgentClient
-> (Connection
    -> [IO (Either AgentErrorType (Maybe NotificationInfo))])
-> ReaderT Env IO [Either AgentErrorType (Maybe NotificationInfo)]
forall (t :: * -> *) a.
Traversable t =>
AgentClient
-> (Connection -> t (IO (Either AgentErrorType a)))
-> AM' (t (Either AgentErrorType a))
withStoreBatch AgentClient
c ((Connection
  -> [IO (Either AgentErrorType (Maybe NotificationInfo))])
 -> ReaderT Env IO [Either AgentErrorType (Maybe NotificationInfo)])
-> (Connection
    -> [IO (Either AgentErrorType (Maybe NotificationInfo))])
-> ReaderT Env IO [Either AgentErrorType (Maybe NotificationInfo)]
forall a b. (a -> b) -> a -> b
$ \Connection
db ->
          let initNtfInfos :: [IO (Either AgentErrorType (Maybe NotificationInfo))]
initNtfInfos = (PNMessageData
 -> IO (Either AgentErrorType (Maybe NotificationInfo)))
-> [PNMessageData]
-> [IO (Either AgentErrorType (Maybe NotificationInfo))]
forall a b. (a -> b) -> [a] -> [b]
map (Connection
-> PNMessageData
-> IO (Either AgentErrorType (Maybe NotificationInfo))
getInitNtfInfo Connection
db) [PNMessageData]
initNtfs
              lastNtfInfo :: IO (Either AgentErrorType (Maybe NotificationInfo))
lastNtfInfo = NotificationInfo -> Maybe NotificationInfo
forall a. a -> Maybe a
Just (NotificationInfo -> Maybe NotificationInfo)
-> ((NotificationInfo, Maybe InternalTs) -> NotificationInfo)
-> (NotificationInfo, Maybe InternalTs)
-> Maybe NotificationInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NotificationInfo, Maybe InternalTs) -> NotificationInfo
forall a b. (a, b) -> a
fst ((NotificationInfo, Maybe InternalTs) -> Maybe NotificationInfo)
-> IO (Either AgentErrorType (NotificationInfo, Maybe InternalTs))
-> IO (Either AgentErrorType (Maybe NotificationInfo))
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> Connection
-> PNMessageData
-> IO (Either AgentErrorType (NotificationInfo, Maybe InternalTs))
getNtfInfo Connection
db PNMessageData
lastNtf
           in [IO (Either AgentErrorType (Maybe NotificationInfo))]
initNtfInfos [IO (Either AgentErrorType (Maybe NotificationInfo))]
-> [IO (Either AgentErrorType (Maybe NotificationInfo))]
-> [IO (Either AgentErrorType (Maybe NotificationInfo))]
forall a. Semigroup a => a -> a -> a
<> [IO (Either AgentErrorType (Maybe NotificationInfo))
Item [IO (Either AgentErrorType (Maybe NotificationInfo))]
lastNtfInfo]
      let ([AgentErrorType]
errs, [Maybe NotificationInfo]
ntfInfos_) = [Either AgentErrorType (Maybe NotificationInfo)]
-> ([AgentErrorType], [Maybe NotificationInfo])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either AgentErrorType (Maybe NotificationInfo)]
rs
      Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([AgentErrorType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AgentErrorType]
errs) (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
$ Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ Text
"Error(s) loading notifications: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [AgentErrorType] -> Text
forall a. Show a => a -> Text
tshow [AgentErrorType]
errs
      case [NotificationInfo] -> Maybe (NonEmpty NotificationInfo)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ([NotificationInfo] -> Maybe (NonEmpty NotificationInfo))
-> [NotificationInfo] -> Maybe (NonEmpty NotificationInfo)
forall a b. (a -> b) -> a -> b
$ [Maybe NotificationInfo] -> [NotificationInfo]
forall a. [Maybe a] -> [a]
catMaybes [Maybe NotificationInfo]
ntfInfos_ of
        Just NonEmpty NotificationInfo
r -> NonEmpty NotificationInfo -> AM (NonEmpty NotificationInfo)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty NotificationInfo
r
        Maybe (NonEmpty NotificationInfo)
Nothing -> AgentErrorType -> AM (NonEmpty NotificationInfo)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (NonEmpty NotificationInfo))
-> AgentErrorType -> AM (NonEmpty NotificationInfo)
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"getNotificationConns: couldn't get conn info"
    Maybe NtfToken
_ -> AgentErrorType -> AM (NonEmpty NotificationInfo)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (NonEmpty NotificationInfo))
-> AgentErrorType -> AM (NonEmpty NotificationInfo)
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"getNotificationConns"
  where
    getNtfInfo :: DB.Connection -> PNMessageData -> IO (Either AgentErrorType (NotificationInfo, Maybe UTCTime))
    getNtfInfo :: Connection
-> PNMessageData
-> IO (Either AgentErrorType (NotificationInfo, Maybe InternalTs))
getNtfInfo Connection
db PNMessageData {SMPQueueNtf
smpQueue :: SMPQueueNtf
smpQueue :: PNMessageData -> SMPQueueNtf
smpQueue, SystemTime
ntfTs :: SystemTime
ntfTs :: PNMessageData -> SystemTime
ntfTs, CbNonce
nmsgNonce :: CbNonce
nmsgNonce :: PNMessageData -> CbNonce
nmsgNonce, ConnId
encNMsgMeta :: ConnId
encNMsgMeta :: PNMessageData -> ConnId
encNMsgMeta} = ExceptT AgentErrorType IO (NotificationInfo, Maybe InternalTs)
-> IO (Either AgentErrorType (NotificationInfo, Maybe InternalTs))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT AgentErrorType IO (NotificationInfo, Maybe InternalTs)
 -> IO (Either AgentErrorType (NotificationInfo, Maybe InternalTs)))
-> ExceptT AgentErrorType IO (NotificationInfo, Maybe InternalTs)
-> IO (Either AgentErrorType (NotificationInfo, Maybe InternalTs))
forall a b. (a -> b) -> a -> b
$ do
      (ConnId
ntfConnId, UserId
ntfDbQueueId, DhSecretX25519
rcvNtfDhSecret, Maybe InternalTs
lastBrokerTs_) <- (StoreError -> AgentErrorType)
-> IO
     (Either
        StoreError (ConnId, UserId, DhSecretX25519, Maybe InternalTs))
-> ExceptT
     AgentErrorType
     IO
     (ConnId, UserId, DhSecretX25519, Maybe InternalTs)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> IO (Either e a) -> ExceptT e' m a
liftError' StoreError -> AgentErrorType
storeError (IO
   (Either
      StoreError (ConnId, UserId, DhSecretX25519, Maybe InternalTs))
 -> ExceptT
      AgentErrorType
      IO
      (ConnId, UserId, DhSecretX25519, Maybe InternalTs))
-> IO
     (Either
        StoreError (ConnId, UserId, DhSecretX25519, Maybe InternalTs))
-> ExceptT
     AgentErrorType
     IO
     (ConnId, UserId, DhSecretX25519, Maybe InternalTs)
forall a b. (a -> b) -> a -> b
$ Connection
-> SMPQueueNtf
-> IO
     (Either
        StoreError (ConnId, UserId, DhSecretX25519, Maybe InternalTs))
getNtfRcvQueue Connection
db SMPQueueNtf
smpQueue
      let ntfMsgMeta :: Maybe NMsgMeta
ntfMsgMeta = Either String NMsgMeta -> Maybe NMsgMeta
forall a b. Either a b -> Maybe b
eitherToMaybe (Either String NMsgMeta -> Maybe NMsgMeta)
-> Either String NMsgMeta -> Maybe NMsgMeta
forall a b. (a -> b) -> a -> b
$ ConnId -> Either String NMsgMeta
forall a. Encoding a => ConnId -> Either String a
smpDecode (ConnId -> Either String NMsgMeta)
-> Either String ConnId -> Either String NMsgMeta
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (CryptoError -> String)
-> Either CryptoError ConnId -> Either String ConnId
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 -> String
forall a. Show a => a -> String
show (DhSecretX25519 -> CbNonce -> ConnId -> Either CryptoError ConnId
C.cbDecrypt DhSecretX25519
rcvNtfDhSecret CbNonce
nmsgNonce ConnId
encNMsgMeta)
          ntfInfo :: NotificationInfo
ntfInfo = NotificationInfo {ConnId
ntfConnId :: ConnId
$sel:ntfConnId:NotificationInfo :: ConnId
ntfConnId, UserId
ntfDbQueueId :: UserId
$sel:ntfDbQueueId:NotificationInfo :: UserId
ntfDbQueueId, SystemTime
ntfTs :: SystemTime
$sel:ntfTs:NotificationInfo :: SystemTime
ntfTs, Maybe NMsgMeta
ntfMsgMeta :: Maybe NMsgMeta
$sel:ntfMsgMeta:NotificationInfo :: Maybe NMsgMeta
ntfMsgMeta}
      (NotificationInfo, Maybe InternalTs)
-> ExceptT AgentErrorType IO (NotificationInfo, Maybe InternalTs)
forall a. a -> ExceptT AgentErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NotificationInfo
ntfInfo, Maybe InternalTs
lastBrokerTs_)
    getInitNtfInfo :: DB.Connection -> PNMessageData -> IO (Either AgentErrorType (Maybe NotificationInfo))
    getInitNtfInfo :: Connection
-> PNMessageData
-> IO (Either AgentErrorType (Maybe NotificationInfo))
getInitNtfInfo Connection
db PNMessageData
msgData = ExceptT AgentErrorType IO (Maybe NotificationInfo)
-> IO (Either AgentErrorType (Maybe NotificationInfo))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT AgentErrorType IO (Maybe NotificationInfo)
 -> IO (Either AgentErrorType (Maybe NotificationInfo)))
-> ExceptT AgentErrorType IO (Maybe NotificationInfo)
-> IO (Either AgentErrorType (Maybe NotificationInfo))
forall a b. (a -> b) -> a -> b
$ do
      (NotificationInfo
ntfInfo, Maybe InternalTs
lastBrokerTs_) <- IO (Either AgentErrorType (NotificationInfo, Maybe InternalTs))
-> ExceptT AgentErrorType IO (NotificationInfo, Maybe InternalTs)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either AgentErrorType (NotificationInfo, Maybe InternalTs))
 -> ExceptT AgentErrorType IO (NotificationInfo, Maybe InternalTs))
-> IO (Either AgentErrorType (NotificationInfo, Maybe InternalTs))
-> ExceptT AgentErrorType IO (NotificationInfo, Maybe InternalTs)
forall a b. (a -> b) -> a -> b
$ Connection
-> PNMessageData
-> IO (Either AgentErrorType (NotificationInfo, Maybe InternalTs))
getNtfInfo Connection
db PNMessageData
msgData
      Maybe NotificationInfo
-> ExceptT AgentErrorType IO (Maybe NotificationInfo)
forall a. a -> ExceptT AgentErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NotificationInfo
 -> ExceptT AgentErrorType IO (Maybe NotificationInfo))
-> Maybe NotificationInfo
-> ExceptT AgentErrorType IO (Maybe NotificationInfo)
forall a b. (a -> b) -> a -> b
$ case NotificationInfo -> Maybe NMsgMeta
ntfMsgMeta NotificationInfo
ntfInfo of
        Just SMP.NMsgMeta {SystemTime
msgTs :: SystemTime
$sel:msgTs:NMsgMeta :: NMsgMeta -> SystemTime
msgTs}
          | Bool -> (InternalTs -> Bool) -> Maybe InternalTs -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (SystemTime -> InternalTs
systemToUTCTime SystemTime
msgTs InternalTs -> InternalTs -> Bool
forall a. Ord a => a -> a -> Bool
>) Maybe InternalTs
lastBrokerTs_ -> NotificationInfo -> Maybe NotificationInfo
forall a. a -> Maybe a
Just NotificationInfo
ntfInfo
        Maybe NMsgMeta
_ -> Maybe NotificationInfo
forall a. Maybe a
Nothing
{-# INLINE getNotificationConns' #-}

-- | Send message to the connection (SEND command) in Reader monad
sendMessage' :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> AM (AgentMsgId, PQEncryption)
sendMessage' :: AgentClient
-> ConnId
-> PQEncryption
-> MsgFlags
-> ConnId
-> AM (UserId, PQEncryption)
sendMessage' AgentClient
c ConnId
connId PQEncryption
pqEnc MsgFlags
msgFlags ConnId
msg = ReaderT Env IO (Either AgentErrorType (UserId, PQEncryption))
-> AM (UserId, PQEncryption)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT Env IO (Either AgentErrorType (UserId, PQEncryption))
 -> AM (UserId, PQEncryption))
-> ReaderT Env IO (Either AgentErrorType (UserId, PQEncryption))
-> AM (UserId, PQEncryption)
forall a b. (a -> b) -> a -> b
$ Identity (Either AgentErrorType (UserId, PQEncryption))
-> Either AgentErrorType (UserId, PQEncryption)
forall a. Identity a -> a
runIdentity (Identity (Either AgentErrorType (UserId, PQEncryption))
 -> Either AgentErrorType (UserId, PQEncryption))
-> ReaderT
     Env IO (Identity (Either AgentErrorType (UserId, PQEncryption)))
-> ReaderT Env IO (Either AgentErrorType (UserId, PQEncryption))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> Identity (Either AgentErrorType MsgReq)
-> Set ConnId
-> ReaderT
     Env IO (Identity (Either AgentErrorType (UserId, PQEncryption)))
forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either AgentErrorType MsgReq)
-> Set ConnId
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
sendMessagesB_ AgentClient
c (Either AgentErrorType MsgReq
-> Identity (Either AgentErrorType MsgReq)
forall a. a -> Identity a
Identity (MsgReq -> Either AgentErrorType MsgReq
forall a b. b -> Either a b
Right (ConnId
connId, PQEncryption
pqEnc, MsgFlags
msgFlags, ConnId -> ValueOrRef ConnId
forall a. a -> ValueOrRef a
vrValue ConnId
msg))) (ConnId -> Set ConnId
forall a. a -> Set a
S.singleton ConnId
connId)
{-# INLINE sendMessage' #-}

-- | Send multiple messages to different connections (SEND command) in Reader monad
sendMessages' :: AgentClient -> [MsgReq] -> AM [Either AgentErrorType (AgentMsgId, PQEncryption)]
sendMessages' :: AgentClient
-> [MsgReq] -> AM [Either AgentErrorType (UserId, PQEncryption)]
sendMessages' AgentClient
c = AgentClient
-> [Either AgentErrorType MsgReq]
-> AM [Either AgentErrorType (UserId, PQEncryption)]
forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either AgentErrorType MsgReq)
-> AM (t (Either AgentErrorType (UserId, PQEncryption)))
sendMessagesB' AgentClient
c ([Either AgentErrorType MsgReq]
 -> AM [Either AgentErrorType (UserId, PQEncryption)])
-> ([MsgReq] -> [Either AgentErrorType MsgReq])
-> [MsgReq]
-> AM [Either AgentErrorType (UserId, PQEncryption)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgReq -> Either AgentErrorType MsgReq)
-> [MsgReq] -> [Either AgentErrorType MsgReq]
forall a b. (a -> b) -> [a] -> [b]
map MsgReq -> Either AgentErrorType MsgReq
forall a b. b -> Either a b
Right
{-# INLINE sendMessages' #-}

sendMessagesB' :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType MsgReq) -> AM (t (Either AgentErrorType (AgentMsgId, PQEncryption)))
sendMessagesB' :: forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either AgentErrorType MsgReq)
-> AM (t (Either AgentErrorType (UserId, PQEncryption)))
sendMessagesB' AgentClient
c t (Either AgentErrorType MsgReq)
reqs = do
  (ConnId
_, Set ConnId
connIds) <- Either AgentErrorType (ConnId, Set ConnId)
-> ExceptT AgentErrorType (ReaderT Env IO) (ConnId, Set ConnId)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either AgentErrorType (ConnId, Set ConnId)
 -> ExceptT AgentErrorType (ReaderT Env IO) (ConnId, Set ConnId))
-> Either AgentErrorType (ConnId, Set ConnId)
-> ExceptT AgentErrorType (ReaderT Env IO) (ConnId, Set ConnId)
forall a b. (a -> b) -> a -> b
$ (Either AgentErrorType (ConnId, Set ConnId)
 -> Either AgentErrorType MsgReq
 -> Either AgentErrorType (ConnId, Set ConnId))
-> Either AgentErrorType (ConnId, Set ConnId)
-> t (Either AgentErrorType MsgReq)
-> Either AgentErrorType (ConnId, Set ConnId)
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Either AgentErrorType (ConnId, Set ConnId)
-> Either AgentErrorType MsgReq
-> Either AgentErrorType (ConnId, Set ConnId)
forall {a} {b} {c} {d}.
Either AgentErrorType (ConnId, Set ConnId)
-> Either a (ConnId, b, c, d)
-> Either AgentErrorType (ConnId, Set ConnId)
addConnId ((ConnId, Set ConnId) -> Either AgentErrorType (ConnId, Set ConnId)
forall a b. b -> Either a b
Right (ConnId
"", Set ConnId
forall a. Set a
S.empty)) t (Either AgentErrorType MsgReq)
reqs
  ReaderT Env IO (t (Either AgentErrorType (UserId, PQEncryption)))
-> AM (t (Either AgentErrorType (UserId, PQEncryption)))
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 (t (Either AgentErrorType (UserId, PQEncryption)))
 -> AM (t (Either AgentErrorType (UserId, PQEncryption))))
-> ReaderT
     Env IO (t (Either AgentErrorType (UserId, PQEncryption)))
-> AM (t (Either AgentErrorType (UserId, PQEncryption)))
forall a b. (a -> b) -> a -> b
$ AgentClient
-> t (Either AgentErrorType MsgReq)
-> Set ConnId
-> ReaderT
     Env IO (t (Either AgentErrorType (UserId, PQEncryption)))
forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either AgentErrorType MsgReq)
-> Set ConnId
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
sendMessagesB_ AgentClient
c t (Either AgentErrorType MsgReq)
reqs Set ConnId
connIds
  where
    addConnId :: Either AgentErrorType (ConnId, Set ConnId)
-> Either a (ConnId, b, c, d)
-> Either AgentErrorType (ConnId, Set ConnId)
addConnId acc :: Either AgentErrorType (ConnId, Set ConnId)
acc@(Right (ConnId
prevId, Set ConnId
s)) (Right (ConnId
connId, b
_, c
_, d
_))
      | ConnId -> Bool
B.null ConnId
connId = if ConnId -> Bool
B.null ConnId
prevId then AgentErrorType -> Either AgentErrorType (ConnId, Set ConnId)
forall a b. a -> Either a b
Left (AgentErrorType -> Either AgentErrorType (ConnId, Set ConnId))
-> AgentErrorType -> Either AgentErrorType (ConnId, Set ConnId)
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"sendMessages: empty first connId" else Either AgentErrorType (ConnId, Set ConnId)
acc
      | ConnId
connId ConnId -> Set ConnId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set ConnId
s = AgentErrorType -> Either AgentErrorType (ConnId, Set ConnId)
forall a b. a -> Either a b
Left (AgentErrorType -> Either AgentErrorType (ConnId, Set ConnId))
-> AgentErrorType -> Either AgentErrorType (ConnId, Set ConnId)
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"sendMessages: duplicate connId"
      | Bool
otherwise = (ConnId, Set ConnId) -> Either AgentErrorType (ConnId, Set ConnId)
forall a b. b -> Either a b
Right (ConnId
connId, ConnId -> Set ConnId -> Set ConnId
forall a. Ord a => a -> Set a -> Set a
S.insert ConnId
connId Set ConnId
s)
    addConnId Either AgentErrorType (ConnId, Set ConnId)
acc Either a (ConnId, b, c, d)
_ = Either AgentErrorType (ConnId, Set ConnId)
acc

sendMessagesB_ :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType MsgReq) -> Set ConnId -> AM' (t (Either AgentErrorType (AgentMsgId, PQEncryption)))
sendMessagesB_ :: forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either AgentErrorType MsgReq)
-> Set ConnId
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
sendMessagesB_ AgentClient
c t (Either AgentErrorType MsgReq)
reqs Set ConnId
connIds = AgentClient
-> Set ConnId
-> Text
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
forall a. AgentClient -> Set ConnId -> Text -> AM' a -> AM' a
withConnLocks AgentClient
c Set ConnId
connIds Text
"sendMessages" (AM' (t (Either AgentErrorType (UserId, PQEncryption)))
 -> AM' (t (Either AgentErrorType (UserId, PQEncryption))))
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
forall a b. (a -> b) -> a -> b
$ do
  TVar (Maybe (Either AgentErrorType SomeConn))
prev <- Maybe (Either AgentErrorType SomeConn)
-> ReaderT Env IO (TVar (Maybe (Either AgentErrorType SomeConn)))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe (Either AgentErrorType SomeConn)
forall a. Maybe a
Nothing
  t (Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn))
reqs' <- AgentClient
-> (Connection
    -> t (IO
            (Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn))))
-> AM'
     (t (Either
           AgentErrorType (MsgReq, Either AgentErrorType SomeConn)))
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 (MsgReq, Either AgentErrorType SomeConn))))
 -> AM'
      (t (Either
            AgentErrorType (MsgReq, Either AgentErrorType SomeConn))))
-> (Connection
    -> t (IO
            (Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn))))
-> AM'
     (t (Either
           AgentErrorType (MsgReq, Either AgentErrorType SomeConn)))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> (Either AgentErrorType MsgReq
 -> IO
      (Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn)))
-> t (Either AgentErrorType MsgReq)
-> t (IO
        (Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn)))
forall a b. (a -> b) -> t a -> t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((MsgReq -> IO (MsgReq, Either AgentErrorType SomeConn))
-> Either AgentErrorType MsgReq
-> IO
     (Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn))
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)
-> Either AgentErrorType a -> m (Either AgentErrorType b)
mapM ((MsgReq -> IO (MsgReq, Either AgentErrorType SomeConn))
 -> Either AgentErrorType MsgReq
 -> IO
      (Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn)))
-> (MsgReq -> IO (MsgReq, Either AgentErrorType SomeConn))
-> Either AgentErrorType MsgReq
-> IO
     (Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn))
forall a b. (a -> b) -> a -> b
$ Connection
-> TVar (Maybe (Either AgentErrorType SomeConn))
-> MsgReq
-> IO (MsgReq, Either AgentErrorType SomeConn)
getConn_ Connection
db TVar (Maybe (Either AgentErrorType SomeConn))
prev) t (Either AgentErrorType MsgReq)
reqs
  let (Set ConnId
toEnable, t (Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
reqs'') = (Set ConnId
 -> Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn)
 -> (Set ConnId,
     Either
       AgentErrorType
       (Either AgentErrorType (ConnData, NonEmpty SndQueue),
        Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)))
-> Set ConnId
-> t (Either
        AgentErrorType (MsgReq, Either AgentErrorType SomeConn))
-> (Set ConnId,
    t (Either
         AgentErrorType
         (Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)))
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Set ConnId
-> Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn)
-> (Set ConnId,
    Either
      AgentErrorType
      (Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
prepareConn [] t (Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn))
reqs'
  ReaderT Env IO [Either AgentErrorType ()] -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Env IO [Either AgentErrorType ()] -> ReaderT Env IO ())
-> ReaderT Env IO [Either AgentErrorType ()] -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> (Connection -> [IO ()])
-> ReaderT Env IO [Either AgentErrorType ()]
forall (t :: * -> *) a.
Traversable t =>
AgentClient
-> (Connection -> t (IO a)) -> AM' (t (Either AgentErrorType a))
withStoreBatch' AgentClient
c ((Connection -> [IO ()])
 -> ReaderT Env IO [Either AgentErrorType ()])
-> (Connection -> [IO ()])
-> ReaderT Env IO [Either AgentErrorType ()]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> (ConnId -> IO ()) -> [ConnId] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (\ConnId
connId -> Connection -> ConnId -> PQSupport -> IO ()
setConnPQSupport Connection
db ConnId
connId PQSupport
PQSupportOn) ([ConnId] -> [IO ()]) -> [ConnId] -> [IO ()]
forall a b. (a -> b) -> a -> b
$ Set ConnId -> [ConnId]
forall a. Set a -> [a]
S.toList Set ConnId
toEnable
  AgentClient
-> t (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
enqueueMessagesB AgentClient
c t (Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
reqs''
  where
    getConn_ :: DB.Connection -> TVar (Maybe (Either AgentErrorType SomeConn)) -> MsgReq -> IO (MsgReq, Either AgentErrorType SomeConn)
    getConn_ :: Connection
-> TVar (Maybe (Either AgentErrorType SomeConn))
-> MsgReq
-> IO (MsgReq, Either AgentErrorType SomeConn)
getConn_ Connection
db TVar (Maybe (Either AgentErrorType SomeConn))
prev req :: MsgReq
req@(ConnId
connId, PQEncryption
_, MsgFlags
_, ValueOrRef ConnId
_) =
      (MsgReq
req,)
        (Either AgentErrorType SomeConn
 -> (MsgReq, Either AgentErrorType SomeConn))
-> IO (Either AgentErrorType SomeConn)
-> IO (MsgReq, Either AgentErrorType SomeConn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if ConnId -> Bool
B.null ConnId
connId
          then Either AgentErrorType SomeConn
-> Maybe (Either AgentErrorType SomeConn)
-> Either AgentErrorType SomeConn
forall a. a -> Maybe a -> a
fromMaybe (AgentErrorType -> Either AgentErrorType SomeConn
forall a b. a -> Either a b
Left (AgentErrorType -> Either AgentErrorType SomeConn)
-> AgentErrorType -> Either AgentErrorType SomeConn
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"sendMessagesB_: empty prev connId") (Maybe (Either AgentErrorType SomeConn)
 -> Either AgentErrorType SomeConn)
-> IO (Maybe (Either AgentErrorType SomeConn))
-> IO (Either AgentErrorType SomeConn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe (Either AgentErrorType SomeConn))
-> IO (Maybe (Either AgentErrorType SomeConn))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe (Either AgentErrorType SomeConn))
prev
          else do
            Either AgentErrorType SomeConn
conn <- (StoreError -> AgentErrorType)
-> Either StoreError SomeConn -> Either AgentErrorType SomeConn
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 StoreError -> AgentErrorType
storeError (Either StoreError SomeConn -> Either AgentErrorType SomeConn)
-> IO (Either StoreError SomeConn)
-> IO (Either AgentErrorType SomeConn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> ConnId -> IO (Either StoreError SomeConn)
getConn Connection
db ConnId
connId
            Either AgentErrorType SomeConn
conn Either AgentErrorType SomeConn
-> IO () -> IO (Either AgentErrorType SomeConn)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar (Maybe (Either AgentErrorType SomeConn))
-> Maybe (Either AgentErrorType SomeConn) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (Either AgentErrorType SomeConn))
prev (Maybe (Either AgentErrorType SomeConn) -> STM ())
-> Maybe (Either AgentErrorType SomeConn) -> STM ()
forall a b. (a -> b) -> a -> b
$ Either AgentErrorType SomeConn
-> Maybe (Either AgentErrorType SomeConn)
forall a. a -> Maybe a
Just Either AgentErrorType SomeConn
conn)
    prepareConn :: Set ConnId -> Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn) -> (Set ConnId, Either AgentErrorType (Either AgentErrorType (ConnData, NonEmpty SndQueue), Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
    prepareConn :: Set ConnId
-> Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn)
-> (Set ConnId,
    Either
      AgentErrorType
      (Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
prepareConn Set ConnId
s (Left AgentErrorType
e) = (Set ConnId
s, AgentErrorType
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
forall a b. a -> Either a b
Left AgentErrorType
e)
    prepareConn Set ConnId
s (Right ((ConnId
_, PQEncryption
pqEnc, MsgFlags
msgFlags, ValueOrRef ConnId
msgOrRef), Either AgentErrorType SomeConn
conn_)) = case Either AgentErrorType SomeConn
conn_ of
      Right (SomeConn SConnType d
cType Connection' d RcvQueue SndQueue
conn) -> case Connection' d RcvQueue SndQueue
conn of
        DuplexConnection ConnData
cData NonEmpty RcvQueue
_ NonEmpty SndQueue
sqs -> ConnData
-> NonEmpty SndQueue
-> (Set ConnId,
    Either
      AgentErrorType
      (Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
prepareMsg ConnData
cData NonEmpty SndQueue
sqs
        SndConnection ConnData
cData SndQueue
sq -> ConnData
-> NonEmpty SndQueue
-> (Set ConnId,
    Either
      AgentErrorType
      (Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
prepareMsg ConnData
cData [Item (NonEmpty SndQueue)
SndQueue
sq]
        -- we can't fail here, as it may prevent delivery of subsequent messages that reference the body of the failed message.
        Connection' d RcvQueue SndQueue
_ -> (Set ConnId
s, Either AgentErrorType (ConnData, NonEmpty SndQueue)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
mkReq (Either AgentErrorType (ConnData, NonEmpty SndQueue)
 -> Either
      AgentErrorType
      (Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
forall a b. a -> Either a b
Left (AgentErrorType
 -> Either AgentErrorType (ConnData, NonEmpty SndQueue))
-> AgentErrorType
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"sendMessagesB_ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ConnType -> String
forall a. Show a => a -> String
show (SConnType d -> ConnType
forall (c :: ConnType). SConnType c -> ConnType
connType SConnType d
cType))
      Left AgentErrorType
e -> (Set ConnId
s, Either AgentErrorType (ConnData, NonEmpty SndQueue)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
mkReq (Either AgentErrorType (ConnData, NonEmpty SndQueue)
 -> Either
      AgentErrorType
      (Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
forall a b. a -> Either a b
Left AgentErrorType
e)
      where
        prepareMsg :: ConnData -> NonEmpty SndQueue -> (Set ConnId, Either AgentErrorType (Either AgentErrorType (ConnData, NonEmpty SndQueue), Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
        prepareMsg :: ConnData
-> NonEmpty SndQueue
-> (Set ConnId,
    Either
      AgentErrorType
      (Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
prepareMsg cData :: ConnData
cData@ConnData {ConnId
$sel:connId:ConnData :: ConnData -> ConnId
connId :: ConnId
connId, PQSupport
$sel:pqSupport:ConnData :: ConnData -> PQSupport
pqSupport :: PQSupport
pqSupport} NonEmpty SndQueue
sqs
          | ConnData -> Bool
ratchetSyncSendProhibited ConnData
cData = (Set ConnId
s, Either AgentErrorType (ConnData, NonEmpty SndQueue)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
mkReq (Either AgentErrorType (ConnData, NonEmpty SndQueue)
 -> Either
      AgentErrorType
      (Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
forall a b. a -> Either a b
Left (AgentErrorType
 -> Either AgentErrorType (ConnData, NonEmpty SndQueue))
-> AgentErrorType
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"sendMessagesB: send prohibited")
          -- connection is only updated if PQ encryption was disabled, and now it has to be enabled.
          -- support for PQ encryption (small message envelopes) will not be disabled when message is sent.
          | PQEncryption
pqEnc PQEncryption -> PQEncryption -> Bool
forall a. Eq a => a -> a -> Bool
== PQEncryption
PQEncOn Bool -> Bool -> Bool
&& PQSupport
pqSupport PQSupport -> PQSupport -> Bool
forall a. Eq a => a -> a -> Bool
== PQSupport
PQSupportOff =
              let cData' :: ConnData
cData' = ConnData
cData {pqSupport = PQSupportOn} :: ConnData
               in (ConnId -> Set ConnId -> Set ConnId
forall a. Ord a => a -> Set a -> Set a
S.insert ConnId
connId Set ConnId
s, Either AgentErrorType (ConnData, NonEmpty SndQueue)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
mkReq (Either AgentErrorType (ConnData, NonEmpty SndQueue)
 -> Either
      AgentErrorType
      (Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
forall a b. (a -> b) -> a -> b
$ (ConnData, NonEmpty SndQueue)
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
forall a b. b -> Either a b
Right (ConnData
cData', NonEmpty SndQueue
sqs))
          | Bool
otherwise = (Set ConnId
s, Either AgentErrorType (ConnData, NonEmpty SndQueue)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
mkReq (Either AgentErrorType (ConnData, NonEmpty SndQueue)
 -> Either
      AgentErrorType
      (Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
forall a b. (a -> b) -> a -> b
$ (ConnData, NonEmpty SndQueue)
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
forall a b. b -> Either a b
Right (ConnData
cData, NonEmpty SndQueue
sqs))
        mkReq :: Either AgentErrorType (ConnData, NonEmpty SndQueue)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
mkReq Either AgentErrorType (ConnData, NonEmpty SndQueue)
csqs_ = (Either AgentErrorType (ConnData, NonEmpty SndQueue),
 Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
forall a b. b -> Either a b
Right (Either AgentErrorType (ConnData, NonEmpty SndQueue)
csqs_, PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just PQEncryption
pqEnc, MsgFlags
msgFlags, ConnId -> AMessage
A_MSG (ConnId -> AMessage) -> ValueOrRef ConnId -> ValueOrRef AMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueOrRef ConnId
msgOrRef)

-- / async command processing v v v

enqueueCommand :: AgentClient -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> AM ()
enqueueCommand :: AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
corrId ConnId
connId Maybe SMPServer
server AgentCommand
aCommand = do
  AgentClient
-> (Connection -> IO (Either StoreError ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError ()))
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO (Either StoreError ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> IO (Either StoreError ())
createCommand Connection
db ConnId
corrId ConnId
connId Maybe SMPServer
server AgentCommand
aCommand
  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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AM' Worker -> ReaderT Env IO ())
-> AM' Worker
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AM' Worker -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM' Worker -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM' Worker -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ Bool -> AgentClient -> ConnId -> Maybe SMPServer -> AM' Worker
getAsyncCmdWorker Bool
True AgentClient
c ConnId
connId Maybe SMPServer
server

resumeSrvCmds :: AgentClient -> ConnId -> Maybe SMPServer -> AM' ()
resumeSrvCmds :: AgentClient -> ConnId -> Maybe SMPServer -> ReaderT Env IO ()
resumeSrvCmds = AM' Worker -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM' Worker -> ReaderT Env IO ())
-> (AgentClient -> ConnId -> Maybe SMPServer -> AM' Worker)
-> AgentClient
-> ConnId
-> Maybe SMPServer
-> ReaderT Env IO ()
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. Bool -> AgentClient -> ConnId -> Maybe SMPServer -> AM' Worker
getAsyncCmdWorker Bool
False
{-# INLINE resumeSrvCmds #-}

resumeConnCmds :: AgentClient -> [ConnId] -> AM ()
resumeConnCmds :: AgentClient
-> [ConnId] -> ExceptT AgentErrorType (ReaderT Env IO) ()
resumeConnCmds AgentClient
c [ConnId]
connIds = do
  [(ConnId, NonEmpty (Maybe SMPServer))]
connSrvs <- AgentClient
-> (Connection -> IO [(ConnId, NonEmpty (Maybe SMPServer))])
-> AM [(ConnId, NonEmpty (Maybe SMPServer))]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> [ConnId] -> IO [(ConnId, NonEmpty (Maybe SMPServer))]
`getPendingCommandServers` [ConnId]
connIds)
  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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ((ConnId, NonEmpty (Maybe SMPServer)) -> ReaderT Env IO ())
-> [(ConnId, NonEmpty (Maybe SMPServer))] -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(ConnId
connId, NonEmpty (Maybe SMPServer)
srvs) -> (Maybe SMPServer -> ReaderT Env IO ())
-> NonEmpty (Maybe SMPServer) -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient -> ConnId -> Maybe SMPServer -> ReaderT Env IO ()
resumeSrvCmds AgentClient
c ConnId
connId) NonEmpty (Maybe SMPServer)
srvs) [(ConnId, NonEmpty (Maybe SMPServer))]
connSrvs

resumeAllCommands :: AgentClient -> AM ()
resumeAllCommands :: AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) ()
resumeAllCommands AgentClient
c = do
  [(ConnId, Maybe SMPServer)]
connSrvs <- AgentClient
-> (Connection -> IO [(ConnId, Maybe SMPServer)])
-> AM [(ConnId, Maybe SMPServer)]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO [(ConnId, Maybe SMPServer)]
getAllPendingCommandConns AM [(ConnId, Maybe SMPServer)]
-> (AgentErrorType -> AM [(ConnId, Maybe SMPServer)])
-> AM [(ConnId, Maybe SMPServer)]
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` (\AgentErrorType
e -> 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 (AgentErrorType -> IO ()
forall a. Show a => a -> IO ()
print AgentErrorType
e) ExceptT AgentErrorType (ReaderT Env IO) ()
-> AM [(ConnId, Maybe SMPServer)] -> AM [(ConnId, Maybe SMPServer)]
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 [(ConnId, Maybe SMPServer)]
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE 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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ((ConnId, Maybe SMPServer) -> ReaderT Env IO ())
-> [(ConnId, Maybe SMPServer)] -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ConnId -> Maybe SMPServer -> ReaderT Env IO ())
-> (ConnId, Maybe SMPServer) -> ReaderT Env IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((ConnId -> Maybe SMPServer -> ReaderT Env IO ())
 -> (ConnId, Maybe SMPServer) -> ReaderT Env IO ())
-> (ConnId -> Maybe SMPServer -> ReaderT Env IO ())
-> (ConnId, Maybe SMPServer)
-> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> ConnId -> Maybe SMPServer -> ReaderT Env IO ()
resumeSrvCmds AgentClient
c) [(ConnId, Maybe SMPServer)]
connSrvs

getAsyncCmdWorker :: Bool -> AgentClient -> ConnId -> Maybe SMPServer -> AM' Worker
getAsyncCmdWorker :: Bool -> AgentClient -> ConnId -> Maybe SMPServer -> AM' Worker
getAsyncCmdWorker Bool
hasWork AgentClient
c ConnId
connId Maybe SMPServer
server =
  String
-> Bool
-> AgentClient
-> (ConnId, Maybe SMPServer)
-> TMap (ConnId, Maybe SMPServer) Worker
-> (Worker -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM' Worker
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 String
"async_cmd" Bool
hasWork AgentClient
c (ConnId
connId, Maybe SMPServer
server) (AgentClient -> TMap (ConnId, Maybe SMPServer) Worker
asyncCmdWorkers AgentClient
c) (AgentClient
-> ConnId
-> Maybe SMPServer
-> Worker
-> ExceptT AgentErrorType (ReaderT Env IO) ()
runCommandProcessing AgentClient
c ConnId
connId Maybe SMPServer
server)

data CommandCompletion = CCMoved | CCCompleted

runCommandProcessing :: AgentClient -> ConnId -> Maybe SMPServer -> Worker -> AM ()
runCommandProcessing :: AgentClient
-> ConnId
-> Maybe SMPServer
-> Worker
-> ExceptT AgentErrorType (ReaderT Env IO) ()
runCommandProcessing c :: AgentClient
c@AgentClient {TBQueue ATransmission
$sel:subQ:AgentClient :: AgentClient -> TBQueue ATransmission
subQ :: TBQueue ATransmission
subQ} ConnId
connId Maybe SMPServer
server_ Worker {TMVar ()
doWork :: TMVar ()
$sel:doWork:Worker :: Worker -> TMVar ()
doWork} = do
  RetryInterval2
ri <- (Env -> RetryInterval2)
-> ExceptT AgentErrorType (ReaderT Env IO) RetryInterval2
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> RetryInterval2)
 -> ExceptT AgentErrorType (ReaderT Env IO) RetryInterval2)
-> (Env -> RetryInterval2)
-> ExceptT AgentErrorType (ReaderT Env IO) RetryInterval2
forall a b. (a -> b) -> a -> b
$ AgentConfig -> RetryInterval2
messageRetryInterval (AgentConfig -> RetryInterval2)
-> (Env -> AgentConfig) -> Env -> RetryInterval2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config -- different retry interval?
  ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (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
$ 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 -> AgentOperation -> STM ()
endAgentOperation AgentClient
c AgentOperation
AOSndNetwork
    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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> ReaderT Env IO ()
forall (m :: * -> *). MonadIO m => TMVar () -> m ()
waitForWork TMVar ()
doWork
    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
$ AgentClient -> IO ()
throwWhenInactive AgentClient
c
    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 -> AgentOperation -> STM ()
beginAgentOperation AgentClient
c AgentOperation
AOSndNetwork
    AgentClient
-> TMVar ()
-> (Connection -> IO (Either StoreError (Maybe PendingCommand)))
-> (PendingCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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 (\Connection
db -> Connection
-> ConnId
-> Maybe SMPServer
-> IO (Either StoreError (Maybe PendingCommand))
getPendingServerCommand Connection
db ConnId
connId Maybe SMPServer
server_) ((PendingCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (PendingCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ RetryInterval
-> PendingCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
runProcessCmd (RetryInterval2 -> RetryInterval
riFast RetryInterval2
ri)
  where
    runProcessCmd :: RetryInterval
-> PendingCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
runProcessCmd RetryInterval
ri PendingCommand
cmd = do
      TVar [ATransmission]
pending <- [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar [ATransmission])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
      RetryInterval
-> PendingCommand
-> TVar [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
processCmd RetryInterval
ri PendingCommand
cmd TVar [ATransmission]
pending
      (ATransmission -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> [ATransmission] -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ATransmission -> STM ())
-> ATransmission
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue ATransmission
subQ) ([ATransmission] -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ([ATransmission] -> [ATransmission])
-> [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ATransmission] -> [ATransmission]
forall a. [a] -> [a]
reverse ([ATransmission] -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) [ATransmission]
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar [ATransmission]
pending
    processCmd :: RetryInterval -> PendingCommand -> TVar [ATransmission] -> AM ()
    processCmd :: RetryInterval
-> PendingCommand
-> TVar [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
processCmd RetryInterval
ri PendingCommand {UserId
cmdId :: UserId
$sel:cmdId:PendingCommand :: PendingCommand -> UserId
cmdId, ConnId
corrId :: ConnId
$sel:corrId:PendingCommand :: PendingCommand -> ConnId
corrId, UserId
userId :: UserId
$sel:userId:PendingCommand :: PendingCommand -> UserId
userId, AgentCommand
command :: AgentCommand
$sel:command:PendingCommand :: PendingCommand -> AgentCommand
command} TVar [ATransmission]
pendingCmds = case AgentCommand
command of
      AClientCommand ACommand
cmd -> case ACommand
cmd of
        NEW Bool
enableNtfs (ACM SConnectionMode m
cMode) InitialKeys
pqEnc SubscriptionMode
subMode -> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
noServer (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
$ do
          TVar (Set TransportHost)
triedHosts <- Set TransportHost
-> ExceptT
     AgentErrorType (ReaderT Env IO) (TVar (Set TransportHost))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Set TransportHost
forall a. Set a
S.empty
          ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryCommand (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((SMPServerWithAuth
     -> ExceptT AgentErrorType (ReaderT Env IO) ())
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPServerWithAuth
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> UserId
-> (UserServers 'PSMP
    -> NonEmpty (Maybe UserId, SMPServerWithAuth))
-> TVar (Set TransportHost)
-> [SMPServer]
-> (SMPServerWithAuth
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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 'PSMP -> NonEmpty (Maybe UserId, SMPServerWithAuth)
forall (p :: ProtocolType).
UserServers p -> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
storageSrvs TVar (Set TransportHost)
triedHosts [] ((SMPServerWithAuth -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPServerWithAuth
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPServerWithAuth
srv -> do
            (CCLink ConnectionRequestUri m
cReq Maybe (ConnShortLink m)
_, Maybe ClientServiceId
service) <- AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> SConnectionMode m
-> Maybe (UserConnLinkData m)
-> Maybe Text
-> InitialKeys
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (CreatedConnLink m, Maybe ClientServiceId)
forall (c :: ConnectionMode).
ConnectionModeI c =>
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> SConnectionMode c
-> Maybe (UserConnLinkData c)
-> Maybe Text
-> InitialKeys
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (CreatedConnLink c, Maybe ClientServiceId)
newRcvConnSrv AgentClient
c NetworkRequestMode
NRMBackground UserId
userId ConnId
connId Bool
enableNtfs SConnectionMode m
cMode Maybe (UserConnLinkData m)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing InitialKeys
pqEnc SubscriptionMode
subMode SMPServerWithAuth
srv
            AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AConnectionRequestUri -> Maybe ClientServiceId -> AEvent 'AEConn
INV (SConnectionMode m
-> ConnectionRequestUri m -> AConnectionRequestUri
forall (m :: ConnectionMode).
ConnectionModeI m =>
SConnectionMode m
-> ConnectionRequestUri m -> AConnectionRequestUri
ACR SConnectionMode m
cMode ConnectionRequestUri m
cReq) Maybe ClientServiceId
service
        LSET UserConnLinkData 'CMContact
userLinkData Maybe Text
clientData ->
          ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer' (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ExceptT AgentErrorType (ReaderT Env IO) ()
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryCommand (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
$ do
            ConnShortLink 'CMContact
link <- AgentClient
-> NetworkRequestMode
-> ConnId
-> SConnectionMode 'CMContact
-> UserConnLinkData 'CMContact
-> Maybe Text
-> AM (ConnShortLink 'CMContact)
forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> ConnId
-> SConnectionMode c
-> UserConnLinkData c
-> Maybe Text
-> AM (ConnShortLink c)
setConnShortLink' AgentClient
c NetworkRequestMode
NRMBackground ConnId
connId SConnectionMode 'CMContact
SCMContact UserConnLinkData 'CMContact
userLinkData Maybe Text
clientData
            AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnShortLink 'CMContact
-> UserConnLinkData 'CMContact -> AEvent 'AEConn
LINK ConnShortLink 'CMContact
link UserConnLinkData 'CMContact
userLinkData
        LGET ConnShortLink 'CMContact
shortLink ->
          ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer' (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ExceptT AgentErrorType (ReaderT Env IO) ()
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryCommand (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
$ do
            (FixedLinkData 'CMContact
fixedData, ConnLinkData 'CMContact
linkData) <- AgentClient
-> NetworkRequestMode
-> UserId
-> ConnShortLink 'CMContact
-> AM (FixedLinkData 'CMContact, ConnLinkData 'CMContact)
forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnShortLink c
-> AM (FixedLinkData c, ConnLinkData c)
getConnShortLink' AgentClient
c NetworkRequestMode
NRMBackground UserId
userId ConnShortLink 'CMContact
shortLink
            AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ FixedLinkData 'CMContact
-> ConnLinkData 'CMContact -> AEvent 'AEConn
LDATA FixedLinkData 'CMContact
fixedData ConnLinkData 'CMContact
linkData
        JOIN Bool
enableNtfs (ACR SConnectionMode m
_ cReq :: ConnectionRequestUri m
cReq@(CRInvitationUri ConnReqUriData {$sel:crSmpQueues:ConnReqUriData :: ConnReqUriData -> NonEmpty SMPQueueUri
crSmpQueues = SMPQueueUri
q :| [SMPQueueUri]
_} RcvE2ERatchetParamsUri 'X448
_)) PQSupport
pqEnc SubscriptionMode
subMode ConnId
connInfo -> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
noServer (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
$ do
          TVar (Set TransportHost)
triedHosts <- Set TransportHost
-> ExceptT
     AgentErrorType (ReaderT Env IO) (TVar (Set TransportHost))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Set TransportHost
forall a. Set a
S.empty
          ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryCommand (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((SMPServerWithAuth
     -> ExceptT AgentErrorType (ReaderT Env IO) ())
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPServerWithAuth
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> UserId
-> (UserServers 'PSMP
    -> NonEmpty (Maybe UserId, SMPServerWithAuth))
-> TVar (Set TransportHost)
-> [SMPServer]
-> (SMPServerWithAuth
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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 'PSMP -> NonEmpty (Maybe UserId, SMPServerWithAuth)
forall (p :: ProtocolType).
UserServers p -> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
storageSrvs TVar (Set TransportHost)
triedHosts [SMPQueueUri -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer SMPQueueUri
q] ((SMPServerWithAuth -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPServerWithAuth
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPServerWithAuth
srv -> do
            (Bool
sqSecured, Maybe ClientServiceId
service) <- AgentClient
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri m
-> ConnId
-> PQSupport
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (Bool, Maybe ClientServiceId)
forall (c :: ConnectionMode).
AgentClient
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (Bool, Maybe ClientServiceId)
joinConnSrvAsync AgentClient
c UserId
userId ConnId
connId Bool
enableNtfs ConnectionRequestUri m
cReq ConnId
connInfo PQSupport
pqEnc SubscriptionMode
subMode SMPServerWithAuth
srv
            AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ClientServiceId -> AEvent 'AEConn
JOINED Bool
sqSecured Maybe ClientServiceId
service
        -- TODO TBC using joinConnSrvAsync for contact URIs, with receive queue created asynchronously.
        -- Currently joinConnSrv is used because even joinConnSrvAsync for invitation URIs creates receive queue synchronously.
        JOIN Bool
enableNtfs (ACR SConnectionMode m
_ cReq :: ConnectionRequestUri m
cReq@(CRContactUri ConnReqUriData {$sel:crSmpQueues:ConnReqUriData :: ConnReqUriData -> NonEmpty SMPQueueUri
crSmpQueues = SMPQueueUri
q :| [SMPQueueUri]
_})) PQSupport
pqEnc SubscriptionMode
subMode ConnId
connInfo -> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
noServer (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
$ do
          TVar (Set TransportHost)
triedHosts <- Set TransportHost
-> ExceptT
     AgentErrorType (ReaderT Env IO) (TVar (Set TransportHost))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Set TransportHost
forall a. Set a
S.empty
          ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryCommand (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((SMPServerWithAuth
     -> ExceptT AgentErrorType (ReaderT Env IO) ())
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPServerWithAuth
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> UserId
-> (UserServers 'PSMP
    -> NonEmpty (Maybe UserId, SMPServerWithAuth))
-> TVar (Set TransportHost)
-> [SMPServer]
-> (SMPServerWithAuth
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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 'PSMP -> NonEmpty (Maybe UserId, SMPServerWithAuth)
forall (p :: ProtocolType).
UserServers p -> NonEmpty (Maybe UserId, ProtoServerWithAuth p)
storageSrvs TVar (Set TransportHost)
triedHosts [SMPQueueUri -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer SMPQueueUri
q] ((SMPServerWithAuth -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPServerWithAuth
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPServerWithAuth
srv -> do
            (Bool
sqSecured, Maybe ClientServiceId
service) <- AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri m
-> ConnId
-> PQSupport
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (Bool, Maybe ClientServiceId)
forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> Bool
-> ConnectionRequestUri c
-> ConnId
-> PQSupport
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (Bool, Maybe ClientServiceId)
joinConnSrv AgentClient
c NetworkRequestMode
NRMBackground UserId
userId ConnId
connId Bool
enableNtfs ConnectionRequestUri m
cReq ConnId
connInfo PQSupport
pqEnc SubscriptionMode
subMode SMPServerWithAuth
srv
            AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ClientServiceId -> AEvent 'AEConn
JOINED Bool
sqSecured Maybe ClientServiceId
service
        LET ConnId
confId ConnId
ownCInfo -> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer' (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ExceptT AgentErrorType (ReaderT Env IO) ()
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryCommand (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
$ AgentClient
-> ConnId
-> ConnId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
allowConnection' AgentClient
c ConnId
connId ConnId
confId ConnId
ownCInfo ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
>> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify AEvent 'AEConn
OK
        ACK UserId
msgId Maybe ConnId
rcptInfo_ -> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer' (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ExceptT AgentErrorType (ReaderT Env IO) ()
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryCommand (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
$ AgentClient
-> ConnId
-> UserId
-> Maybe ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
ackMessage' AgentClient
c ConnId
connId UserId
msgId Maybe ConnId
rcptInfo_ ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
>> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify AEvent 'AEConn
OK
        ACommand
SWCH ->
          ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
noServer (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ExceptT AgentErrorType (ReaderT Env IO) ()
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryWithLock Text
"switchConnection" (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
$
            AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId) AM SomeConn
-> (SomeConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
              SomeConn SConnType d
_ conn :: Connection' d RcvQueue SndQueue
conn@(DuplexConnection ConnData
_ (RcvQueue
replaced :| [RcvQueue]
_rqs) NonEmpty SndQueue
_) ->
                AgentClient
-> NetworkRequestMode
-> Connection 'CDuplex
-> RcvQueue
-> AM ConnectionStats
switchDuplexConnection AgentClient
c NetworkRequestMode
NRMBackground Connection' d RcvQueue SndQueue
Connection 'CDuplex
conn RcvQueue
replaced AM ConnectionStats
-> (ConnectionStats -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
>>= AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ConnectionStats -> AEvent 'AEConn)
-> ConnectionStats
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueueDirection -> SwitchPhase -> ConnectionStats -> AEvent 'AEConn
SWITCH QueueDirection
QDRcv SwitchPhase
SPStarted
              SomeConn
_ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"SWCH: not duplex"
        ACommand
DEL -> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer' (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ExceptT AgentErrorType (ReaderT Env IO) ()
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryCommand (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
$ AgentClient
-> NetworkRequestMode
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnection' AgentClient
c NetworkRequestMode
NRMBackground ConnId
connId ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
>> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify AEvent 'AEConn
OK
      AInternalCommand InternalCommand
cmd -> case InternalCommand
cmd of
        ICAckDel QueueId
rId ConnId
srvMsgId InternalId
msgId -> (SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer ((SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPServer
srv ->
          ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryCommand (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
$ AgentClient
-> ConnId
-> Text
-> AM (Maybe ATransmission)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withConnLockNotify AgentClient
c ConnId
connId Text
"ICAckDel" (AM (Maybe ATransmission)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (Maybe ATransmission)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ do
            Maybe ATransmission
t_ <- SMPServer -> QueueId -> ConnId -> AM (Maybe ATransmission)
ack SMPServer
srv QueueId
rId ConnId
srvMsgId
            AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (\Connection
db -> Connection -> ConnId -> InternalId -> IO ()
deleteMsg Connection
db ConnId
connId InternalId
msgId)
            Maybe ATransmission -> AM (Maybe ATransmission)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ATransmission
t_
        ICAck QueueId
rId ConnId
srvMsgId -> (SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer ((SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPServer
srv ->
          ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryCommand (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
$ AgentClient
-> ConnId
-> Text
-> AM (Maybe ATransmission)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withConnLockNotify AgentClient
c ConnId
connId Text
"ICAck" (AM (Maybe ATransmission)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (Maybe ATransmission)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ SMPServer -> QueueId -> ConnId -> AM (Maybe ATransmission)
ack SMPServer
srv QueueId
rId ConnId
srvMsgId
        ICAllowSecure QueueId
_rId Maybe SndPublicAuthKey
senderKey -> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer' (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AM CommandCompletion
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM CommandCompletion
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> AM CommandCompletion
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryMoveableWithLock Text
"ICAllowSecure" (AM CommandCompletion
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM CommandCompletion
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ do
          (SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn, AcceptedConfirmation {SMPConfirmation
$sel:senderConf:AcceptedConfirmation :: AcceptedConfirmation -> SMPConfirmation
senderConf :: SMPConfirmation
senderConf, ConnId
ownConnInfo :: ConnId
$sel:ownConnInfo:AcceptedConfirmation :: AcceptedConfirmation -> ConnId
ownConnInfo}) <-
            AgentClient
-> (Connection
    -> IO (Either StoreError (SomeConn, AcceptedConfirmation)))
-> AM (SomeConn, AcceptedConfirmation)
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection
  -> IO (Either StoreError (SomeConn, AcceptedConfirmation)))
 -> AM (SomeConn, AcceptedConfirmation))
-> (Connection
    -> IO (Either StoreError (SomeConn, AcceptedConfirmation)))
-> AM (SomeConn, AcceptedConfirmation)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ExceptT StoreError IO (SomeConn, AcceptedConfirmation)
-> IO (Either StoreError (SomeConn, AcceptedConfirmation))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO (SomeConn, AcceptedConfirmation)
 -> IO (Either StoreError (SomeConn, AcceptedConfirmation)))
-> ExceptT StoreError IO (SomeConn, AcceptedConfirmation)
-> IO (Either StoreError (SomeConn, AcceptedConfirmation))
forall a b. (a -> b) -> a -> b
$ (,) (SomeConn
 -> AcceptedConfirmation -> (SomeConn, AcceptedConfirmation))
-> ExceptT StoreError IO SomeConn
-> ExceptT
     StoreError
     IO
     (AcceptedConfirmation -> (SomeConn, AcceptedConfirmation))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either StoreError SomeConn) -> ExceptT StoreError IO SomeConn
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Connection -> ConnId -> IO (Either StoreError SomeConn)
getConn Connection
db ConnId
connId) ExceptT
  StoreError
  IO
  (AcceptedConfirmation -> (SomeConn, AcceptedConfirmation))
-> ExceptT StoreError IO AcceptedConfirmation
-> ExceptT StoreError IO (SomeConn, AcceptedConfirmation)
forall a b.
ExceptT StoreError IO (a -> b)
-> ExceptT StoreError IO a -> ExceptT StoreError IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Either StoreError AcceptedConfirmation)
-> ExceptT StoreError IO AcceptedConfirmation
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Connection -> ConnId -> IO (Either StoreError AcceptedConfirmation)
getAcceptedConfirmation Connection
db ConnId
connId)
          case Connection' d RcvQueue SndQueue
conn of
            RcvConnection ConnData
cData RcvQueue
rq -> do
              (SndPublicAuthKey -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Maybe SndPublicAuthKey
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RcvQueue
-> SndPublicAuthKey -> ExceptT AgentErrorType (ReaderT Env IO) ()
secure RcvQueue
rq) Maybe SndPublicAuthKey
senderKey
              (NonEmpty SMPQueueInfo
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Maybe (NonEmpty SMPQueueInfo)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient
-> ConnData
-> ConnId
-> Maybe SndQueue
-> NonEmpty SMPQueueInfo
-> ExceptT AgentErrorType (ReaderT Env IO) ()
connectReplyQueues AgentClient
c ConnData
cData ConnId
ownConnInfo Maybe SndQueue
forall a. Maybe a
Nothing) ([SMPQueueInfo] -> Maybe (NonEmpty SMPQueueInfo)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ([SMPQueueInfo] -> Maybe (NonEmpty SMPQueueInfo))
-> [SMPQueueInfo] -> Maybe (NonEmpty SMPQueueInfo)
forall a b. (a -> b) -> a -> b
$ SMPConfirmation -> [SMPQueueInfo]
smpReplyQueues SMPConfirmation
senderConf)
              CommandCompletion -> AM CommandCompletion
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandCompletion
CCCompleted
            -- duplex connection is matched to handle SKEY retries
            DuplexConnection ConnData
cData NonEmpty RcvQueue
_ (SndQueue
sq :| [SndQueue]
_) -> do
              ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Either AgentErrorType ())
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors ((NonEmpty SMPQueueInfo
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Maybe (NonEmpty SMPQueueInfo)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient
-> ConnData
-> ConnId
-> Maybe SndQueue
-> NonEmpty SMPQueueInfo
-> ExceptT AgentErrorType (ReaderT Env IO) ()
connectReplyQueues AgentClient
c ConnData
cData ConnId
ownConnInfo (SndQueue -> Maybe SndQueue
forall a. a -> Maybe a
Just SndQueue
sq)) ([SMPQueueInfo] -> Maybe (NonEmpty SMPQueueInfo)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ([SMPQueueInfo] -> Maybe (NonEmpty SMPQueueInfo))
-> [SMPQueueInfo] -> Maybe (NonEmpty SMPQueueInfo)
forall a b. (a -> b) -> a -> b
$ SMPConfirmation -> [SMPQueueInfo]
smpReplyQueues SMPConfirmation
senderConf)) ExceptT AgentErrorType (ReaderT Env IO) (Either AgentErrorType ())
-> (Either AgentErrorType () -> AM CommandCompletion)
-> AM CommandCompletion
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 () -> CommandCompletion -> AM CommandCompletion
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandCompletion
CCCompleted
                Left AgentErrorType
e
                  | AgentErrorType -> Bool
temporaryOrHostError AgentErrorType
e Bool -> Bool -> Bool
&& SMPServer -> Maybe SMPServer
forall a. a -> Maybe a
Just SMPServer
server Maybe SMPServer -> Maybe SMPServer -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe SMPServer
server_ -> do
                      -- In case the server is different we update server to remove command from this (connId, srv) queue
                      AgentClient
-> (Connection -> IO (Either StoreError ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError ()))
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO (Either StoreError ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> SMPServer -> IO (Either StoreError ())
updateCommandServer Connection
db UserId
cmdId SMPServer
server
                      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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AM' Worker -> ReaderT Env IO ())
-> AM' Worker
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AM' Worker -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM' Worker -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM' Worker -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ Bool -> AgentClient -> ConnId -> Maybe SMPServer -> AM' Worker
getAsyncCmdWorker Bool
True AgentClient
c ConnId
connId (SMPServer -> Maybe SMPServer
forall a. a -> Maybe a
Just SMPServer
server)
                      CommandCompletion -> AM CommandCompletion
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandCompletion
CCMoved
                  | Bool
otherwise -> AgentErrorType -> AM CommandCompletion
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e
              where
                server :: SMPServer
server = SndQueue -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer SndQueue
sq
            Connection' d RcvQueue SndQueue
_ -> AgentErrorType -> AM CommandCompletion
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM CommandCompletion)
-> AgentErrorType -> AM CommandCompletion
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"incorrect connection type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> InternalCommandTag -> String
forall a. Show a => a -> String
show (InternalCommand -> InternalCommandTag
internalCmdTag InternalCommand
cmd)
        ICDuplexSecure QueueId
_rId SndPublicAuthKey
senderKey -> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer' (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((Connection 'CDuplex
     -> ExceptT AgentErrorType (ReaderT Env IO) ())
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryWithLock Text
"ICDuplexSecure" (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((Connection 'CDuplex
     -> ExceptT AgentErrorType (ReaderT Env IO) ())
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection 'CDuplex -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withDuplexConn ((Connection 'CDuplex
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \(DuplexConnection ConnData
cData (RcvQueue
rq :| [RcvQueue]
_) (SndQueue
sq :| [SndQueue]
_)) -> do
          RcvQueue
-> SndPublicAuthKey -> ExceptT AgentErrorType (ReaderT Env IO) ()
secure RcvQueue
rq SndPublicAuthKey
senderKey
          AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM (UserId, PQEncryption)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> ConnData
-> SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessage AgentClient
c ConnData
cData SndQueue
sq SMP.MsgFlags {$sel:notification:MsgFlags :: Bool
notification = Bool
True} AMessage
HELLO
        -- ICDeleteConn is no longer used, but it can be present in old client databases
        InternalCommand
ICDeleteConn -> AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> UserId -> IO ()
`deleteCommand` UserId
cmdId)
        ICDeleteRcvQueue QueueId
rId -> (SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer ((SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPServer
srv -> Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryWithLock Text
"ICDeleteRcvQueue" (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
$ do
          RcvQueue
rq <- AgentClient
-> (Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (\Connection
db -> Connection
-> ConnId
-> SMPServer
-> QueueId
-> IO (Either StoreError RcvQueue)
getDeletedRcvQueue Connection
db ConnId
connId SMPServer
srv QueueId
rId)
          AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteQueue AgentClient
c NetworkRequestMode
NRMBackground RcvQueue
rq
          AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> RcvQueue -> IO ()
`deleteConnRcvQueue` RcvQueue
rq)
        ICQSecure QueueId
rId SndPublicAuthKey
senderKey ->
          (SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer ((SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPServer
srv -> Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryWithLock Text
"ICQSecure" (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((Connection 'CDuplex
     -> ExceptT AgentErrorType (ReaderT Env IO) ())
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection 'CDuplex -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withDuplexConn ((Connection 'CDuplex
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \(DuplexConnection ConnData
cData NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs) ->
            case (RcvQueue -> Bool) -> NonEmpty RcvQueue -> Maybe RcvQueue
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((SMPServer, QueueId) -> RcvQueue -> Bool
forall q. SMPQueue q => (SMPServer, QueueId) -> q -> Bool
sameQueue (SMPServer
srv, QueueId
rId)) NonEmpty RcvQueue
rqs of
              Just rq' :: RcvQueue
rq'@RcvQueue {SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server :: SMPServer
server, QueueId
sndId :: QueueId
$sel:sndId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueId
sndId, QueueStatus
$sel:status:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueStatus
status :: QueueStatus
status, $sel:dbReplaceQueueId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Maybe UserId
dbReplaceQueueId = Just UserId
replaceQId} ->
                case (RcvQueue -> Bool) -> NonEmpty RcvQueue -> Maybe RcvQueue
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((UserId
replaceQId UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
==) (UserId -> Bool) -> (RcvQueue -> UserId) -> RcvQueue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RcvQueue -> UserId
forall q. SMPQueueRec q => q -> UserId
dbQId) NonEmpty RcvQueue
rqs of
                  Just RcvQueue
rq1 -> Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QueueStatus
status QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
Confirmed) (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
$ do
                    AgentClient
-> NetworkRequestMode
-> RcvQueue
-> SndPublicAuthKey
-> ExceptT AgentErrorType (ReaderT Env IO) ()
secureQueue AgentClient
c NetworkRequestMode
NRMBackground RcvQueue
rq' SndPublicAuthKey
senderKey
                    -- we may add more statistics special to queue rotation later on,
                    -- not accounting secure during rotation for now:
                    -- atomically $ incSMPServerStat c userId server connSecured
                    AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvQueue -> QueueStatus -> IO ()
setRcvQueueStatus Connection
db RcvQueue
rq' QueueStatus
Secured
                    AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM (UserId, PQEncryption)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AMessage -> AM (UserId, PQEncryption))
-> AMessage
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> ConnData
-> NonEmpty SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessages AgentClient
c ConnData
cData NonEmpty SndQueue
sqs MsgFlags
SMP.noMsgFlags (AMessage -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AMessage -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ NonEmpty ((SMPServer, QueueId), Bool) -> AMessage
QUSE [((SMPServer
server, QueueId
sndId), Bool
True)]
                    RcvQueue
rq1' <- AgentClient -> (Connection -> IO RcvQueue) -> AM RcvQueue
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO RcvQueue) -> AM RcvQueue)
-> (Connection -> IO RcvQueue) -> AM RcvQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvQueue -> Maybe RcvSwitchStatus -> IO RcvQueue
setRcvSwitchStatus Connection
db RcvQueue
rq1 (Maybe RcvSwitchStatus -> IO RcvQueue)
-> Maybe RcvSwitchStatus -> IO RcvQueue
forall a b. (a -> b) -> a -> b
$ RcvSwitchStatus -> Maybe RcvSwitchStatus
forall a. a -> Maybe a
Just RcvSwitchStatus
RSSendingQUSE
                    let rqs' :: NonEmpty RcvQueue
rqs' = RcvQueue -> NonEmpty RcvQueue -> NonEmpty RcvQueue
forall q. SMPQueueRec q => q -> NonEmpty q -> NonEmpty q
updatedQs RcvQueue
rq1' NonEmpty RcvQueue
rqs
                        conn' :: Connection 'CDuplex
conn' = ConnData
-> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection 'CDuplex
forall rq sq.
ConnData
-> NonEmpty rq -> NonEmpty sq -> Connection' 'CDuplex rq sq
DuplexConnection ConnData
cData NonEmpty RcvQueue
rqs' NonEmpty SndQueue
sqs
                    ConnectionStats
cStats <- AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection 'CDuplex
conn'
                    AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ QueueDirection -> SwitchPhase -> ConnectionStats -> AEvent 'AEConn
SWITCH QueueDirection
QDRcv SwitchPhase
SPSecured ConnectionStats
cStats
                  Maybe RcvQueue
_ -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
internalErr String
"ICQSecure: no switching queue found"
              Maybe RcvQueue
_ -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
internalErr String
"ICQSecure: queue address not found in connection"
        ICQDelete QueueId
rId -> do
          (SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer ((SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \SMPServer
srv -> Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryWithLock Text
"ICQDelete" (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((Connection 'CDuplex
     -> ExceptT AgentErrorType (ReaderT Env IO) ())
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection 'CDuplex -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withDuplexConn ((Connection 'CDuplex
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \(DuplexConnection cData :: ConnData
cData@ConnData {Bool
$sel:enableNtfs:ConnData :: ConnData -> Bool
enableNtfs :: Bool
enableNtfs} NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs) -> do
            case (SMPServer, QueueId)
-> NonEmpty RcvQueue -> Maybe (RcvQueue, [RcvQueue])
forall q.
SMPQueue q =>
(SMPServer, QueueId) -> NonEmpty q -> Maybe (q, [q])
removeQ (SMPServer
srv, QueueId
rId) NonEmpty RcvQueue
rqs of
              Maybe (RcvQueue, [RcvQueue])
Nothing -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
internalErr String
"ICQDelete: queue address not found in connection"
              Just (rq' :: RcvQueue
rq'@RcvQueue {Bool
primary :: Bool
$sel:primary:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Bool
primary}, RcvQueue
rq'' : [RcvQueue]
rqs')
                | Bool
primary -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
internalErr String
"ICQDelete: cannot delete primary rcv queue"
                | Bool
otherwise -> do
                    RcvQueue
-> RcvSwitchStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkRQSwchStatus RcvQueue
rq' RcvSwitchStatus
RSReceivedMessage
                    ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Either AgentErrorType ())
forall e (m :: * -> *) a. MonadError e m => m a -> m (Either e a)
tryError (AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteQueue AgentClient
c NetworkRequestMode
NRMBackground RcvQueue
rq') ExceptT AgentErrorType (ReaderT Env IO) (Either AgentErrorType ())
-> (Either AgentErrorType ()
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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 () -> ExceptT AgentErrorType (ReaderT Env IO) ()
finalizeSwitch
                      Left AgentErrorType
e
                        | AgentErrorType -> Bool
temporaryOrHostError AgentErrorType
e -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e
                        | Bool
otherwise -> ExceptT AgentErrorType (ReaderT Env IO) ()
finalizeSwitch ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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 -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e
                where
                  finalizeSwitch :: ExceptT AgentErrorType (ReaderT Env IO) ()
finalizeSwitch = do
                    AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvQueue -> IO ()
deleteConnRcvQueue Connection
db RcvQueue
rq'
                    Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
enableNtfs (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
$ do
                      NtfSupervisor
ns <- (Env -> NtfSupervisor)
-> ExceptT AgentErrorType (ReaderT Env IO) NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
                      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
$ NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> IO ()
sendNtfSubCommand NtfSupervisor
ns (NtfSupervisorCommand
NSCCreate, [ConnId
Item (NonEmpty ConnId)
connId])
                    let conn' :: Connection 'CDuplex
conn' = ConnData
-> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection 'CDuplex
forall rq sq.
ConnData
-> NonEmpty rq -> NonEmpty sq -> Connection' 'CDuplex rq sq
DuplexConnection ConnData
cData (RcvQueue
rq'' RcvQueue -> [RcvQueue] -> NonEmpty RcvQueue
forall a. a -> [a] -> NonEmpty a
:| [RcvQueue]
rqs') NonEmpty SndQueue
sqs
                    ConnectionStats
cStats <- AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection 'CDuplex
conn'
                    AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ QueueDirection -> SwitchPhase -> ConnectionStats -> AEvent 'AEConn
SWITCH QueueDirection
QDRcv SwitchPhase
SPCompleted ConnectionStats
cStats
              Maybe (RcvQueue, [RcvQueue])
_ -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
internalErr String
"ICQDelete: cannot delete the only queue in connection"
        where
          ack :: SMPServer -> QueueId -> ConnId -> AM (Maybe ATransmission)
ack SMPServer
srv QueueId
rId ConnId
srvMsgId = do
            RcvQueue
rq <- AgentClient
-> (Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue)
-> (Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ConnId
-> SMPServer
-> QueueId
-> IO (Either StoreError RcvQueue)
getRcvQueue Connection
db ConnId
connId SMPServer
srv QueueId
rId
            AgentClient -> RcvQueue -> ConnId -> AM (Maybe ATransmission)
ackQueueMessage AgentClient
c RcvQueue
rq ConnId
srvMsgId
          secure :: RcvQueue -> SMP.SndPublicAuthKey -> AM ()
          secure :: RcvQueue
-> SndPublicAuthKey -> ExceptT AgentErrorType (ReaderT Env IO) ()
secure rq :: RcvQueue
rq@RcvQueue {SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server :: SMPServer
server} SndPublicAuthKey
senderKey = do
            AgentClient
-> NetworkRequestMode
-> RcvQueue
-> SndPublicAuthKey
-> ExceptT AgentErrorType (ReaderT Env IO) ()
secureQueue AgentClient
c NetworkRequestMode
NRMBackground RcvQueue
rq SndPublicAuthKey
senderKey
            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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId SMPServer
server AgentSMPServerStats -> TVar Int
connSecured
            AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvQueue -> QueueStatus -> IO ()
setRcvQueueStatus Connection
db RcvQueue
rq QueueStatus
Secured
      where
        withServer :: (SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ()
a = case Maybe SMPServer
server_ of
          Just SMPServer
srv -> SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ()
a SMPServer
srv
          Maybe SMPServer
_ -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
internalErr String
"command requires server"
        withServer' :: ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer' = (SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withServer ((SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ExceptT AgentErrorType (ReaderT Env IO) ()
    -> SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT AgentErrorType (ReaderT Env IO) ()
-> SMPServer -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. a -> b -> a
const
        noServer :: ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
noServer ExceptT AgentErrorType (ReaderT Env IO) ()
a = case Maybe SMPServer
server_ of
          Maybe SMPServer
Nothing -> ExceptT AgentErrorType (ReaderT Env IO) ()
a
          Maybe SMPServer
_ -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
internalErr String
"command requires no server"
        withDuplexConn :: (Connection 'CDuplex -> AM ()) -> AM ()
        withDuplexConn :: (Connection 'CDuplex -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withDuplexConn Connection 'CDuplex -> ExceptT AgentErrorType (ReaderT Env IO) ()
a =
          AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId) AM SomeConn
-> (SomeConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
            SomeConn SConnType d
_ conn :: Connection' d RcvQueue SndQueue
conn@DuplexConnection {} -> Connection 'CDuplex -> ExceptT AgentErrorType (ReaderT Env IO) ()
a Connection' d RcvQueue SndQueue
Connection 'CDuplex
conn
            SomeConn
_ -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
internalErr String
"command requires duplex connection"
        tryCommand :: ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryCommand ExceptT AgentErrorType (ReaderT Env IO) ()
action = AM CommandCompletion -> ExceptT AgentErrorType (ReaderT Env IO) ()
tryMoveableCommand (ExceptT AgentErrorType (ReaderT Env IO) ()
action ExceptT AgentErrorType (ReaderT Env IO) ()
-> CommandCompletion -> AM CommandCompletion
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> CommandCompletion
CCCompleted)
        tryMoveableCommand :: AM CommandCompletion -> ExceptT AgentErrorType (ReaderT Env IO) ()
tryMoveableCommand AM CommandCompletion
action = RetryInterval
-> (UserId
    -> ExceptT AgentErrorType (ReaderT Env IO) ()
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a.
MonadIO m =>
RetryInterval -> (UserId -> m a -> m a) -> m a
withRetryInterval RetryInterval
ri ((UserId
  -> ExceptT AgentErrorType (ReaderT Env IO) ()
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (UserId
    -> ExceptT AgentErrorType (ReaderT Env IO) ()
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \UserId
_ ExceptT AgentErrorType (ReaderT Env IO) ()
loop -> do
          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
$ AgentClient -> IO ()
waitWhileSuspended AgentClient
c
          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
$ AgentClient -> IO ()
waitForUserNetwork AgentClient
c
          AM CommandCompletion
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType CommandCompletion)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors AM CommandCompletion
action ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Either AgentErrorType CommandCompletion)
-> (Either AgentErrorType CommandCompletion
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
            Left AgentErrorType
e
              | AgentErrorType -> Bool
temporaryOrHostError AgentErrorType
e -> AgentClient
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
retrySndOp AgentClient
c ExceptT AgentErrorType (ReaderT Env IO) ()
loop
              | Bool
otherwise -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
cmdError AgentErrorType
e
            Right CommandCompletion
CCCompleted -> AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> UserId -> IO ()
`deleteCommand` UserId
cmdId)
            Right CommandCompletion
CCMoved -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- command processing moved to another command queue
        tryWithLock :: Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryWithLock Text
name = ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryCommand (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ExceptT AgentErrorType (ReaderT Env IO) ()
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> ConnId
-> Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
name
        tryMoveableWithLock :: Text
-> AM CommandCompletion
-> ExceptT AgentErrorType (ReaderT Env IO) ()
tryMoveableWithLock Text
name = AM CommandCompletion -> ExceptT AgentErrorType (ReaderT Env IO) ()
tryMoveableCommand (AM CommandCompletion
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AM CommandCompletion -> AM CommandCompletion)
-> AM CommandCompletion
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> ConnId -> Text -> AM CommandCompletion -> AM CommandCompletion
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
name
        internalErr :: String -> ExceptT AgentErrorType (ReaderT Env IO) ()
internalErr String
s = AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
cmdError (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> AgentCommandTag -> String
forall a. Show a => a -> String
show (AgentCommand -> AgentCommandTag
agentCommandTag AgentCommand
command)
        cmdError :: AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
cmdError AgentErrorType
e = AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AgentErrorType -> AEvent 'AEConn
ERR AgentErrorType
e) ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> UserId -> IO ()
`deleteCommand` UserId
cmdId)
        notify :: forall e. AEntityI e => AEvent e -> AM ()
        notify :: forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify AEvent e
cmd =
          let t :: ATransmission
t = (ConnId
corrId, ConnId
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)
           in 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
$ STM Bool -> STM () -> STM () -> STM ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TBQueue ATransmission -> STM Bool
forall a. TBQueue a -> STM Bool
isFullTBQueue TBQueue ATransmission
subQ) (TVar [ATransmission]
-> ([ATransmission] -> [ATransmission]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [ATransmission]
pendingCmds (ATransmission
t ATransmission -> [ATransmission] -> [ATransmission]
forall a. a -> [a] -> [a]
:)) (TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue ATransmission
subQ ATransmission
t)
-- ^ ^ ^ async command processing /

enqueueMessages :: AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, PQEncryption)
enqueueMessages :: AgentClient
-> ConnData
-> NonEmpty SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessages AgentClient
c ConnData
cData NonEmpty SndQueue
sqs MsgFlags
msgFlags AMessage
aMessage = do
  Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnData -> Bool
ratchetSyncSendProhibited ConnData
cData) (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"enqueueMessages: ratchet is not synchronized"
  AgentClient
-> ConnData
-> NonEmpty SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessages' AgentClient
c ConnData
cData NonEmpty SndQueue
sqs MsgFlags
msgFlags AMessage
aMessage

enqueueMessages' :: AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, CR.PQEncryption)
enqueueMessages' :: AgentClient
-> ConnData
-> NonEmpty SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessages' AgentClient
c ConnData
cData NonEmpty SndQueue
sqs MsgFlags
msgFlags AMessage
aMessage =
  ReaderT Env IO (Either AgentErrorType (UserId, PQEncryption))
-> AM (UserId, PQEncryption)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT Env IO (Either AgentErrorType (UserId, PQEncryption))
 -> AM (UserId, PQEncryption))
-> ReaderT Env IO (Either AgentErrorType (UserId, PQEncryption))
-> AM (UserId, PQEncryption)
forall a b. (a -> b) -> a -> b
$ Identity (Either AgentErrorType (UserId, PQEncryption))
-> Either AgentErrorType (UserId, PQEncryption)
forall a. Identity a -> a
runIdentity (Identity (Either AgentErrorType (UserId, PQEncryption))
 -> Either AgentErrorType (UserId, PQEncryption))
-> ReaderT
     Env IO (Identity (Either AgentErrorType (UserId, PQEncryption)))
-> ReaderT Env IO (Either AgentErrorType (UserId, PQEncryption))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> Identity
     (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> ReaderT
     Env IO (Identity (Either AgentErrorType (UserId, PQEncryption)))
forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
enqueueMessagesB AgentClient
c (Either
  AgentErrorType
  (Either AgentErrorType (ConnData, NonEmpty SndQueue),
   Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
-> Identity
     (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
forall a. a -> Identity a
Identity ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
 Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
forall a b. b -> Either a b
Right ((ConnData, NonEmpty SndQueue)
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
forall a b. b -> Either a b
Right (ConnData
cData, NonEmpty SndQueue
sqs), Maybe PQEncryption
forall a. Maybe a
Nothing, MsgFlags
msgFlags, AMessage -> ValueOrRef AMessage
forall a. a -> ValueOrRef a
vrValue AMessage
aMessage)))
{-# INLINE enqueueMessages' #-}

enqueueMessagesB :: Traversable t => AgentClient -> t (Either AgentErrorType (Either AgentErrorType (ConnData, NonEmpty SndQueue), Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) -> AM' (t (Either AgentErrorType (AgentMsgId, PQEncryption)))
enqueueMessagesB :: forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
enqueueMessagesB AgentClient
c t (Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
reqs = do
  t (Either
     AgentErrorType
     ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
reqs' <- AgentClient
-> t (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> AM'
     (t (Either
           AgentErrorType
           ((UserId, PQEncryption), Maybe ([SndQueue], UserId))))
forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> AM'
     (t (Either
           AgentErrorType
           ((UserId, PQEncryption), Maybe ([SndQueue], UserId))))
enqueueMessageB AgentClient
c t (Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
reqs
  AgentClient -> [([SndQueue], UserId)] -> ReaderT Env IO ()
forall (t :: * -> *).
Foldable t =>
AgentClient -> t ([SndQueue], UserId) -> ReaderT Env IO ()
enqueueSavedMessageB AgentClient
c ([([SndQueue], UserId)] -> ReaderT Env IO ())
-> [([SndQueue], UserId)] -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ (((UserId, PQEncryption), Maybe ([SndQueue], UserId))
 -> Maybe ([SndQueue], UserId))
-> [((UserId, PQEncryption), Maybe ([SndQueue], UserId))]
-> [([SndQueue], UserId)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((UserId, PQEncryption), Maybe ([SndQueue], UserId))
-> Maybe ([SndQueue], UserId)
forall a b. (a, b) -> b
snd ([((UserId, PQEncryption), Maybe ([SndQueue], UserId))]
 -> [([SndQueue], UserId)])
-> [((UserId, PQEncryption), Maybe ([SndQueue], UserId))]
-> [([SndQueue], UserId)]
forall a b. (a -> b) -> a -> b
$ [Either
   AgentErrorType
   ((UserId, PQEncryption), Maybe ([SndQueue], UserId))]
-> [((UserId, PQEncryption), Maybe ([SndQueue], UserId))]
forall a b. [Either a b] -> [b]
rights ([Either
    AgentErrorType
    ((UserId, PQEncryption), Maybe ([SndQueue], UserId))]
 -> [((UserId, PQEncryption), Maybe ([SndQueue], UserId))])
-> [Either
      AgentErrorType
      ((UserId, PQEncryption), Maybe ([SndQueue], UserId))]
-> [((UserId, PQEncryption), Maybe ([SndQueue], UserId))]
forall a b. (a -> b) -> a -> b
$ t (Either
     AgentErrorType
     ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
-> [Either
      AgentErrorType
      ((UserId, PQEncryption), Maybe ([SndQueue], UserId))]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (Either
     AgentErrorType
     ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
reqs'
  t (Either AgentErrorType (UserId, PQEncryption))
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t (Either AgentErrorType (UserId, PQEncryption))
 -> AM' (t (Either AgentErrorType (UserId, PQEncryption))))
-> t (Either AgentErrorType (UserId, PQEncryption))
-> AM' (t (Either AgentErrorType (UserId, PQEncryption)))
forall a b. (a -> b) -> a -> b
$ ((UserId, PQEncryption), Maybe ([SndQueue], UserId))
-> (UserId, PQEncryption)
forall a b. (a, b) -> a
fst (((UserId, PQEncryption), Maybe ([SndQueue], UserId))
 -> (UserId, PQEncryption))
-> t (Either
        AgentErrorType
        ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
-> t (Either AgentErrorType (UserId, PQEncryption))
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> t (Either
     AgentErrorType
     ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
reqs'

isActiveSndQ :: SndQueue -> Bool
isActiveSndQ :: SndQueue -> Bool
isActiveSndQ SndQueue {QueueStatus
$sel:status:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> QueueStatus
status :: QueueStatus
status} = QueueStatus
status QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
Secured Bool -> Bool -> Bool
|| QueueStatus
status QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
Active
{-# INLINE isActiveSndQ #-}

enqueueMessage :: AgentClient -> ConnData -> SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, PQEncryption)
enqueueMessage :: AgentClient
-> ConnData
-> SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessage AgentClient
c ConnData
cData SndQueue
sq MsgFlags
msgFlags AMessage
aMessage =
  ReaderT Env IO (Either AgentErrorType (UserId, PQEncryption))
-> AM (UserId, PQEncryption)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT Env IO (Either AgentErrorType (UserId, PQEncryption))
 -> AM (UserId, PQEncryption))
-> ReaderT Env IO (Either AgentErrorType (UserId, PQEncryption))
-> AM (UserId, PQEncryption)
forall a b. (a -> b) -> a -> b
$ (((UserId, PQEncryption), Maybe ([SndQueue], UserId))
 -> (UserId, PQEncryption))
-> Either
     AgentErrorType ((UserId, PQEncryption), Maybe ([SndQueue], UserId))
-> Either AgentErrorType (UserId, PQEncryption)
forall a b.
(a -> b) -> Either AgentErrorType a -> Either AgentErrorType b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((UserId, PQEncryption), Maybe ([SndQueue], UserId))
-> (UserId, PQEncryption)
forall a b. (a, b) -> a
fst (Either
   AgentErrorType ((UserId, PQEncryption), Maybe ([SndQueue], UserId))
 -> Either AgentErrorType (UserId, PQEncryption))
-> (Identity
      (Either
         AgentErrorType
         ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
    -> Either
         AgentErrorType
         ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
-> Identity
     (Either
        AgentErrorType
        ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
-> Either AgentErrorType (UserId, PQEncryption)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity
  (Either
     AgentErrorType
     ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
-> Either
     AgentErrorType ((UserId, PQEncryption), Maybe ([SndQueue], UserId))
forall a. Identity a -> a
runIdentity (Identity
   (Either
      AgentErrorType
      ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
 -> Either AgentErrorType (UserId, PQEncryption))
-> ReaderT
     Env
     IO
     (Identity
        (Either
           AgentErrorType
           ((UserId, PQEncryption), Maybe ([SndQueue], UserId))))
-> ReaderT Env IO (Either AgentErrorType (UserId, PQEncryption))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> Identity
     (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> ReaderT
     Env
     IO
     (Identity
        (Either
           AgentErrorType
           ((UserId, PQEncryption), Maybe ([SndQueue], UserId))))
forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> AM'
     (t (Either
           AgentErrorType
           ((UserId, PQEncryption), Maybe ([SndQueue], UserId))))
enqueueMessageB AgentClient
c (Either
  AgentErrorType
  (Either AgentErrorType (ConnData, NonEmpty SndQueue),
   Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
-> Identity
     (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
forall a. a -> Identity a
Identity ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
 Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
forall a b. b -> Either a b
Right ((ConnData, NonEmpty SndQueue)
-> Either AgentErrorType (ConnData, NonEmpty SndQueue)
forall a b. b -> Either a b
Right (ConnData
cData, [Item (NonEmpty SndQueue)
SndQueue
sq]), Maybe PQEncryption
forall a. Maybe a
Nothing, MsgFlags
msgFlags, AMessage -> ValueOrRef AMessage
forall a. a -> ValueOrRef a
vrValue AMessage
aMessage)))
{-# INLINE enqueueMessage #-}

-- this function is used only for sending messages in batch, it returns the list of successes to enqueue additional deliveries
enqueueMessageB :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType (Either AgentErrorType (ConnData, NonEmpty SndQueue), Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) -> AM' (t (Either AgentErrorType ((AgentMsgId, PQEncryption), Maybe ([SndQueue], AgentMsgId))))
enqueueMessageB :: forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> AM'
     (t (Either
           AgentErrorType
           ((UserId, PQEncryption), Maybe ([SndQueue], UserId))))
enqueueMessageB AgentClient
c t (Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
reqs = do
  AgentConfig
cfg <- (Env -> AgentConfig) -> ReaderT Env IO AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
  (IntMap (Maybe UserId, AMessage)
_, t (Either
     AgentErrorType
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption))
reqMids) <- AgentClient
-> (Connection
    -> IO
         (IntMap (Maybe UserId, AMessage),
          t (Either
               AgentErrorType
               ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
                 Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
                InternalId, PQEncryption))))
-> AM'
     (IntMap (Maybe UserId, AMessage),
      t (Either
           AgentErrorType
           ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
             Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
            InternalId, PQEncryption)))
forall a. AgentClient -> (Connection -> IO a) -> AM' a
unsafeWithStore AgentClient
c ((Connection
  -> IO
       (IntMap (Maybe UserId, AMessage),
        t (Either
             AgentErrorType
             ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
               Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
              InternalId, PQEncryption))))
 -> AM'
      (IntMap (Maybe UserId, AMessage),
       t (Either
            AgentErrorType
            ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
              Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
             InternalId, PQEncryption))))
-> (Connection
    -> IO
         (IntMap (Maybe UserId, AMessage),
          t (Either
               AgentErrorType
               ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
                 Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
                InternalId, PQEncryption))))
-> AM'
     (IntMap (Maybe UserId, AMessage),
      t (Either
           AgentErrorType
           ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
             Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
            InternalId, PQEncryption)))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
    (IntMap (Maybe UserId, AMessage)
 -> Either
      AgentErrorType
      (Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
 -> IO
      (IntMap (Maybe UserId, AMessage),
       Either
         AgentErrorType
         ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
           Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
          InternalId, PQEncryption)))
-> IntMap (Maybe UserId, AMessage)
-> t (Either
        AgentErrorType
        (Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
-> IO
     (IntMap (Maybe UserId, AMessage),
      t (Either
           AgentErrorType
           ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
             Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
            InternalId, PQEncryption)))
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM (\IntMap (Maybe UserId, AMessage)
ids Either
  AgentErrorType
  (Either AgentErrorType (ConnData, NonEmpty SndQueue),
   Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
r -> Connection
-> AgentConfig
-> IntMap (Maybe UserId, AMessage)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
-> IO
     (IntMap (Maybe UserId, AMessage),
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
storeSentMsg Connection
db AgentConfig
cfg IntMap (Maybe UserId, AMessage)
ids Either
  AgentErrorType
  (Either AgentErrorType (ConnData, NonEmpty SndQueue),
   Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
r IO
  (IntMap (Maybe UserId, AMessage),
   Either
     AgentErrorType
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption))
-> (SomeException
    -> IO
         (IntMap (Maybe UserId, AMessage),
          Either
            AgentErrorType
            ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
              Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
             InternalId, PQEncryption)))
-> IO
     (IntMap (Maybe UserId, AMessage),
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`E.catchAny` \SomeException
e -> (IntMap (Maybe UserId, AMessage)
ids,) (Either
   AgentErrorType
   ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
     Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
    InternalId, PQEncryption)
 -> (IntMap (Maybe UserId, AMessage),
     Either
       AgentErrorType
       ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
        InternalId, PQEncryption)))
-> IO
     (Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
-> IO
     (IntMap (Maybe UserId, AMessage),
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException
-> IO
     (Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall b. SomeException -> IO (Either AgentErrorType b)
handleInternal SomeException
e) IntMap (Maybe UserId, AMessage)
forall a. IntMap a
IM.empty t (Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
reqs
  t (Either
     AgentErrorType
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption))
-> (((Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
     InternalId, PQEncryption)
    -> ReaderT
         Env
         IO
         (Either
            AgentErrorType
            ((UserId, PQEncryption), Maybe ([SndQueue], UserId))))
-> AM'
     (t (Either
           AgentErrorType
           ((UserId, PQEncryption), Maybe ([SndQueue], UserId))))
forall (m :: * -> *) (t :: * -> *) e a b.
(Monad m, Traversable t) =>
t (Either e a) -> (a -> m (Either e b)) -> m (t (Either e b))
forME t (Either
     AgentErrorType
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption))
reqMids ((((Either AgentErrorType (ConnData, NonEmpty SndQueue),
    Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
   InternalId, PQEncryption)
  -> ReaderT
       Env
       IO
       (Either
          AgentErrorType
          ((UserId, PQEncryption), Maybe ([SndQueue], UserId))))
 -> AM'
      (t (Either
            AgentErrorType
            ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))))
-> (((Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
     InternalId, PQEncryption)
    -> ReaderT
         Env
         IO
         (Either
            AgentErrorType
            ((UserId, PQEncryption), Maybe ([SndQueue], UserId))))
-> AM'
     (t (Either
           AgentErrorType
           ((UserId, PQEncryption), Maybe ([SndQueue], UserId))))
forall a b. (a -> b) -> a -> b
$ \((Either AgentErrorType (ConnData, NonEmpty SndQueue)
csqs_, Maybe PQEncryption
_, MsgFlags
_, ValueOrRef AMessage
_), InternalId UserId
msgId, PQEncryption
pqSecr) -> Either AgentErrorType (ConnData, NonEmpty SndQueue)
-> ((ConnData, NonEmpty SndQueue)
    -> ReaderT
         Env IO ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
-> ReaderT
     Env
     IO
     (Either
        AgentErrorType
        ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Either AgentErrorType (ConnData, NonEmpty SndQueue)
csqs_ (((ConnData, NonEmpty SndQueue)
  -> ReaderT
       Env IO ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
 -> ReaderT
      Env
      IO
      (Either
         AgentErrorType
         ((UserId, PQEncryption), Maybe ([SndQueue], UserId))))
-> ((ConnData, NonEmpty SndQueue)
    -> ReaderT
         Env IO ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
-> ReaderT
     Env
     IO
     (Either
        AgentErrorType
        ((UserId, PQEncryption), Maybe ([SndQueue], UserId)))
forall a b. (a -> b) -> a -> b
$ \(ConnData
_, SndQueue
sq :| [SndQueue]
sqs) -> do
    AgentClient -> SndQueue -> ReaderT Env IO ()
submitPendingMsg AgentClient
c SndQueue
sq
    let sqs' :: [SndQueue]
sqs' = (SndQueue -> Bool) -> [SndQueue] -> [SndQueue]
forall a. (a -> Bool) -> [a] -> [a]
filter SndQueue -> Bool
isActiveSndQ [SndQueue]
sqs
    ((UserId, PQEncryption), Maybe ([SndQueue], UserId))
-> ReaderT
     Env IO ((UserId, PQEncryption), Maybe ([SndQueue], UserId))
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((UserId
msgId, PQEncryption
pqSecr), if [SndQueue] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SndQueue]
sqs' then Maybe ([SndQueue], UserId)
forall a. Maybe a
Nothing else ([SndQueue], UserId) -> Maybe ([SndQueue], UserId)
forall a. a -> Maybe a
Just ([SndQueue]
sqs', UserId
msgId))
  where
    storeSentMsg ::
      DB.Connection ->
      AgentConfig ->
      IntMap (Maybe Int64, AMessage) ->
      Either AgentErrorType (Either AgentErrorType (ConnData, NonEmpty SndQueue), Maybe PQEncryption, MsgFlags, ValueOrRef AMessage) ->
      IO (IntMap (Maybe Int64, AMessage), Either AgentErrorType ((Either AgentErrorType (ConnData, NonEmpty SndQueue), Maybe PQEncryption, MsgFlags, ValueOrRef AMessage), InternalId, PQEncryption))
    storeSentMsg :: Connection
-> AgentConfig
-> IntMap (Maybe UserId, AMessage)
-> Either
     AgentErrorType
     (Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
-> IO
     (IntMap (Maybe UserId, AMessage),
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
storeSentMsg Connection
db AgentConfig
cfg IntMap (Maybe UserId, AMessage)
aMessageIds = \case
      Left AgentErrorType
e -> (IntMap (Maybe UserId, AMessage),
 Either
   AgentErrorType
   ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
     Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
    InternalId, PQEncryption))
-> IO
     (IntMap (Maybe UserId, AMessage),
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntMap (Maybe UserId, AMessage)
aMessageIds, AgentErrorType
-> Either
     AgentErrorType
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption)
forall a b. a -> Either a b
Left AgentErrorType
e)
      Right req :: (Either AgentErrorType (ConnData, NonEmpty SndQueue),
 Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
req@(Either AgentErrorType (ConnData, NonEmpty SndQueue)
csqs_, Maybe PQEncryption
pqEnc_, MsgFlags
msgFlags, ValueOrRef AMessage
mbr) -> case ValueOrRef AMessage
mbr of
        VRValue Maybe Int
i_ AMessage
aMessage -> case Maybe Int
i_ Maybe Int
-> (Int -> Maybe (Maybe UserId, AMessage))
-> Maybe (Maybe UserId, AMessage)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int
-> IntMap (Maybe UserId, AMessage)
-> Maybe (Maybe UserId, AMessage)
forall a. Int -> IntMap a -> Maybe a
`IM.lookup` IntMap (Maybe UserId, AMessage)
aMessageIds) of
          Just (Maybe UserId, AMessage)
_ -> (IntMap (Maybe UserId, AMessage),
 Either
   AgentErrorType
   ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
     Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
    InternalId, PQEncryption))
-> IO
     (IntMap (Maybe UserId, AMessage),
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntMap (Maybe UserId, AMessage)
aMessageIds, AgentErrorType
-> Either
     AgentErrorType
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption)
forall a b. a -> Either a b
Left (AgentErrorType
 -> Either
      AgentErrorType
      ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
        Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
       InternalId, PQEncryption))
-> AgentErrorType
-> Either
     AgentErrorType
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption)
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"enqueueMessageB: storeSentMsg duplicate saved message body")
          Maybe (Maybe UserId, AMessage)
Nothing -> do
            (Maybe UserId
mbId_, Either
  AgentErrorType
  ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
    Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
   InternalId, PQEncryption)
r) <- case Either AgentErrorType (ConnData, NonEmpty SndQueue)
csqs_ of
              Left AgentErrorType
e -> (Maybe UserId,
 Either
   AgentErrorType
   ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
     Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
    InternalId, PQEncryption))
-> IO
     (Maybe UserId,
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UserId
forall a. Maybe a
Nothing, AgentErrorType
-> Either
     AgentErrorType
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption)
forall a b. a -> Either a b
Left AgentErrorType
e)
              Right (ConnData
cData, SndQueue
sq :| [SndQueue]
_) -> do
                UserId
mbId <- Connection -> AMessage -> IO UserId
createSndMsgBody Connection
db AMessage
aMessage
                (UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
mbId,) (Either
   AgentErrorType
   ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
     Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
    InternalId, PQEncryption)
 -> (Maybe UserId,
     Either
       AgentErrorType
       ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
        InternalId, PQEncryption)))
-> IO
     (Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
-> IO
     (Maybe UserId,
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConnData
-> SndQueue
-> UserId
-> AMessage
-> IO
     (Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
storeSentMsg_ ConnData
cData SndQueue
sq UserId
mbId AMessage
aMessage
            let aMessageIds' :: IntMap (Maybe UserId, AMessage)
aMessageIds' = (IntMap (Maybe UserId, AMessage)
 -> IntMap (Maybe UserId, AMessage))
-> (Int
    -> IntMap (Maybe UserId, AMessage)
    -> IntMap (Maybe UserId, AMessage))
-> Maybe Int
-> IntMap (Maybe UserId, AMessage)
-> IntMap (Maybe UserId, AMessage)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IntMap (Maybe UserId, AMessage) -> IntMap (Maybe UserId, AMessage)
forall a. a -> a
id (Int
-> (Maybe UserId, AMessage)
-> IntMap (Maybe UserId, AMessage)
-> IntMap (Maybe UserId, AMessage)
forall a. Int -> a -> IntMap a -> IntMap a
`IM.insert` (Maybe UserId
mbId_, AMessage
aMessage)) Maybe Int
i_ IntMap (Maybe UserId, AMessage)
aMessageIds
            (IntMap (Maybe UserId, AMessage),
 Either
   AgentErrorType
   ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
     Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
    InternalId, PQEncryption))
-> IO
     (IntMap (Maybe UserId, AMessage),
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntMap (Maybe UserId, AMessage)
aMessageIds', Either
  AgentErrorType
  ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
    Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
   InternalId, PQEncryption)
r)
        VRRef Int
i -> case Either AgentErrorType (ConnData, NonEmpty SndQueue)
csqs_ of
          Left AgentErrorType
e -> (IntMap (Maybe UserId, AMessage),
 Either
   AgentErrorType
   ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
     Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
    InternalId, PQEncryption))
-> IO
     (IntMap (Maybe UserId, AMessage),
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((IntMap (Maybe UserId, AMessage),
  Either
    AgentErrorType
    ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
      Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
     InternalId, PQEncryption))
 -> IO
      (IntMap (Maybe UserId, AMessage),
       Either
         AgentErrorType
         ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
           Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
          InternalId, PQEncryption)))
-> (IntMap (Maybe UserId, AMessage),
    Either
      AgentErrorType
      ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
        Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
       InternalId, PQEncryption))
-> IO
     (IntMap (Maybe UserId, AMessage),
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall a b. (a -> b) -> a -> b
$ (IntMap (Maybe UserId, AMessage)
aMessageIds, AgentErrorType
-> Either
     AgentErrorType
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption)
forall a b. a -> Either a b
Left AgentErrorType
e)
          Right (ConnData
cData, SndQueue
sq :| [SndQueue]
_) -> case Int
-> IntMap (Maybe UserId, AMessage)
-> Maybe (Maybe UserId, AMessage)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i IntMap (Maybe UserId, AMessage)
aMessageIds of
            Just (Just UserId
mbId, AMessage
aMessage) -> (IntMap (Maybe UserId, AMessage)
aMessageIds,) (Either
   AgentErrorType
   ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
     Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
    InternalId, PQEncryption)
 -> (IntMap (Maybe UserId, AMessage),
     Either
       AgentErrorType
       ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
        InternalId, PQEncryption)))
-> IO
     (Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
-> IO
     (IntMap (Maybe UserId, AMessage),
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConnData
-> SndQueue
-> UserId
-> AMessage
-> IO
     (Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
storeSentMsg_ ConnData
cData SndQueue
sq UserId
mbId AMessage
aMessage
            Just (Maybe UserId
Nothing, AMessage
aMessage) -> do
              UserId
mbId <- Connection -> AMessage -> IO UserId
createSndMsgBody Connection
db AMessage
aMessage
              let aMessageIds' :: IntMap (Maybe UserId, AMessage)
aMessageIds' = Int
-> (Maybe UserId, AMessage)
-> IntMap (Maybe UserId, AMessage)
-> IntMap (Maybe UserId, AMessage)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i (UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
mbId, AMessage
aMessage) IntMap (Maybe UserId, AMessage)
aMessageIds
              (IntMap (Maybe UserId, AMessage)
aMessageIds',) (Either
   AgentErrorType
   ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
     Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
    InternalId, PQEncryption)
 -> (IntMap (Maybe UserId, AMessage),
     Either
       AgentErrorType
       ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
         Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
        InternalId, PQEncryption)))
-> IO
     (Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
-> IO
     (IntMap (Maybe UserId, AMessage),
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConnData
-> SndQueue
-> UserId
-> AMessage
-> IO
     (Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
storeSentMsg_ ConnData
cData SndQueue
sq UserId
mbId AMessage
aMessage
            Maybe (Maybe UserId, AMessage)
Nothing -> (IntMap (Maybe UserId, AMessage),
 Either
   AgentErrorType
   ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
     Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
    InternalId, PQEncryption))
-> IO
     (IntMap (Maybe UserId, AMessage),
      Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntMap (Maybe UserId, AMessage)
aMessageIds, AgentErrorType
-> Either
     AgentErrorType
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption)
forall a b. a -> Either a b
Left (AgentErrorType
 -> Either
      AgentErrorType
      ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
        Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
       InternalId, PQEncryption))
-> AgentErrorType
-> Either
     AgentErrorType
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption)
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"enqueueMessageB: storeSentMsg missing saved message body id")
        where
          storeSentMsg_ :: ConnData
-> SndQueue
-> UserId
-> AMessage
-> IO
     (Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
storeSentMsg_ cData :: ConnData
cData@ConnData {ConnId
$sel:connId:ConnData :: ConnData -> ConnId
connId :: ConnId
connId} SndQueue
sq UserId
sndMsgBodyId AMessage
aMessage = (Either
   StoreError
   ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
     Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
    InternalId, PQEncryption)
 -> Either
      AgentErrorType
      ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
        Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
       InternalId, PQEncryption))
-> IO
     (Either
        StoreError
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
-> IO
     (Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((StoreError -> AgentErrorType)
-> Either
     StoreError
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption)
-> Either
     AgentErrorType
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption)
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 StoreError -> AgentErrorType
storeError) (IO
   (Either
      StoreError
      ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
        Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
       InternalId, PQEncryption))
 -> IO
      (Either
         AgentErrorType
         ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
           Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
          InternalId, PQEncryption)))
-> IO
     (Either
        StoreError
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
-> IO
     (Either
        AgentErrorType
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall a b. (a -> b) -> a -> b
$ ExceptT
  StoreError
  IO
  ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
    Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
   InternalId, PQEncryption)
-> IO
     (Either
        StoreError
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   StoreError
   IO
   ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
     Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
    InternalId, PQEncryption)
 -> IO
      (Either
         StoreError
         ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
           Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
          InternalId, PQEncryption)))
-> ExceptT
     StoreError
     IO
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption)
-> IO
     (Either
        StoreError
        ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
          Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
         InternalId, PQEncryption))
forall a b. (a -> b) -> a -> b
$ do
            let AgentConfig {VersionRangeE2E
$sel:e2eEncryptVRange:AgentConfig :: AgentConfig -> VersionRangeE2E
e2eEncryptVRange :: VersionRangeE2E
e2eEncryptVRange} = AgentConfig
cfg
            InternalTs
internalTs <- IO InternalTs -> ExceptT StoreError IO InternalTs
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO InternalTs
getCurrentTime
            (InternalId
internalId, InternalSndId
internalSndId, ConnId
prevMsgHash) <- IO (Either StoreError (InternalId, InternalSndId, ConnId))
-> ExceptT StoreError IO (InternalId, InternalSndId, ConnId)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError (InternalId, InternalSndId, ConnId))
 -> ExceptT StoreError IO (InternalId, InternalSndId, ConnId))
-> IO (Either StoreError (InternalId, InternalSndId, ConnId))
-> ExceptT StoreError IO (InternalId, InternalSndId, ConnId)
forall a b. (a -> b) -> a -> b
$ Connection
-> ConnId
-> IO (Either StoreError (InternalId, InternalSndId, ConnId))
updateSndIds Connection
db ConnId
connId
            -- We need to do pre-flight encoding that is not stored in database
            -- to calculate its hash and remember it on connection (createSndMsg -> updateSndMsgHash)
            -- to enable next enqueue.
            -- (As encoding is different per connection, we can't store shared body, so it's repeated on delivery)
            let agentMsgStr :: ConnId
agentMsgStr = AMessage -> InternalSndId -> ConnId -> ConnId
encodeAgentMsgStr AMessage
aMessage InternalSndId
internalSndId ConnId
prevMsgHash
                internalHash :: ConnId
internalHash = ConnId -> ConnId
C.sha256Hash ConnId
agentMsgStr
                currentE2EVersion :: VersionE2E
currentE2EVersion = VersionRangeE2E -> VersionE2E
forall v. VersionRange v -> Version v
maxVersion VersionRangeE2E
e2eEncryptVRange
            (MsgEncryptKeyX448
mek, Int
paddedLen, PQEncryption
pqEnc) <- Connection
-> ConnData
-> (VersionSMPA -> PQSupport -> Int)
-> Maybe PQEncryption
-> VersionE2E
-> ExceptT StoreError IO (MsgEncryptKeyX448, Int, PQEncryption)
agentRatchetEncryptHeader Connection
db ConnData
cData VersionSMPA -> PQSupport -> Int
e2eEncAgentMsgLength Maybe PQEncryption
pqEnc_ VersionE2E
currentE2EVersion
            (CryptoError -> StoreError)
-> ExceptT CryptoError IO () -> ExceptT StoreError IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (AgentErrorType -> StoreError
SEAgentError (AgentErrorType -> StoreError)
-> (CryptoError -> AgentErrorType) -> CryptoError -> StoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoError -> AgentErrorType
cryptoError) (ExceptT CryptoError IO () -> ExceptT StoreError IO ())
-> ExceptT CryptoError IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ConnId -> ExceptT CryptoError IO ()
CR.rcCheckCanPad Int
paddedLen ConnId
agentMsgStr
            let msgType :: AgentMessageType
msgType = AMessage -> AgentMessageType
aMessageType AMessage
aMessage
                -- msgBody is empty, because snd_messages record is linked to snd_message_bodies
                msgData :: SndMsgData
msgData = SndMsgData {InternalId
internalId :: InternalId
$sel:internalId:SndMsgData :: InternalId
internalId, InternalSndId
internalSndId :: InternalSndId
$sel:internalSndId:SndMsgData :: InternalSndId
internalSndId, InternalTs
internalTs :: InternalTs
$sel:internalTs:SndMsgData :: InternalTs
internalTs, AgentMessageType
msgType :: AgentMessageType
$sel:msgType:SndMsgData :: AgentMessageType
msgType, MsgFlags
msgFlags :: MsgFlags
$sel:msgFlags:SndMsgData :: MsgFlags
msgFlags, $sel:msgBody:SndMsgData :: ConnId
msgBody = ConnId
"", $sel:pqEncryption:SndMsgData :: PQEncryption
pqEncryption = PQEncryption
pqEnc, ConnId
internalHash :: ConnId
$sel:internalHash:SndMsgData :: ConnId
internalHash, ConnId
prevMsgHash :: ConnId
$sel:prevMsgHash:SndMsgData :: ConnId
prevMsgHash, $sel:sndMsgPrepData_:SndMsgData :: Maybe SndMsgPrepData
sndMsgPrepData_ = SndMsgPrepData -> Maybe SndMsgPrepData
forall a. a -> Maybe a
Just SndMsgPrepData {$sel:encryptKey:SndMsgPrepData :: MsgEncryptKeyX448
encryptKey = MsgEncryptKeyX448
mek, Int
paddedLen :: Int
$sel:paddedLen:SndMsgPrepData :: Int
paddedLen, UserId
sndMsgBodyId :: UserId
$sel:sndMsgBodyId:SndMsgPrepData :: UserId
sndMsgBodyId}}
            IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> SndMsgData -> IO ()
createSndMsg Connection
db ConnId
connId SndMsgData
msgData
            IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> SndQueue -> InternalId -> IO ()
createSndMsgDelivery Connection
db SndQueue
sq InternalId
internalId
            ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
  Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
 InternalId, PQEncryption)
-> ExceptT
     StoreError
     IO
     ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
       Maybe PQEncryption, MsgFlags, ValueOrRef AMessage),
      InternalId, PQEncryption)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Either AgentErrorType (ConnData, NonEmpty SndQueue),
 Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)
req, InternalId
internalId, PQEncryption
pqEnc)
    handleInternal :: E.SomeException -> IO (Either AgentErrorType b)
    handleInternal :: forall b. SomeException -> IO (Either AgentErrorType b)
handleInternal = Either AgentErrorType b -> IO (Either AgentErrorType b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either AgentErrorType b -> IO (Either AgentErrorType b))
-> (SomeException -> Either AgentErrorType b)
-> SomeException
-> IO (Either AgentErrorType b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> Either AgentErrorType b
forall a b. a -> Either a b
Left (AgentErrorType -> Either AgentErrorType b)
-> (SomeException -> AgentErrorType)
-> SomeException
-> Either AgentErrorType b
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

encodeAgentMsgStr :: AMessage -> InternalSndId -> PrevSndMsgHash -> ByteString
encodeAgentMsgStr :: AMessage -> InternalSndId -> ConnId -> ConnId
encodeAgentMsgStr AMessage
aMessage InternalSndId
internalSndId ConnId
prevMsgHash = do
  let privHeader :: APrivHeader
privHeader = UserId -> ConnId -> APrivHeader
APrivHeader (InternalSndId -> UserId
unSndId InternalSndId
internalSndId) ConnId
prevMsgHash
      agentMsg :: AgentMessage
agentMsg = APrivHeader -> AMessage -> AgentMessage
AgentMessage APrivHeader
privHeader AMessage
aMessage
   in AgentMessage -> ConnId
forall a. Encoding a => a -> ConnId
smpEncode AgentMessage
agentMsg

enqueueSavedMessage :: AgentClient -> AgentMsgId -> SndQueue -> AM' ()
enqueueSavedMessage :: AgentClient -> UserId -> SndQueue -> ReaderT Env IO ()
enqueueSavedMessage AgentClient
c UserId
msgId SndQueue
sq = AgentClient -> Identity ([SndQueue], UserId) -> ReaderT Env IO ()
forall (t :: * -> *).
Foldable t =>
AgentClient -> t ([SndQueue], UserId) -> ReaderT Env IO ()
enqueueSavedMessageB AgentClient
c (Identity ([SndQueue], UserId) -> ReaderT Env IO ())
-> Identity ([SndQueue], UserId) -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ ([SndQueue], UserId) -> Identity ([SndQueue], UserId)
forall a. a -> Identity a
Identity ([Item [SndQueue]
SndQueue
sq], UserId
msgId)
{-# INLINE enqueueSavedMessage #-}

enqueueSavedMessageB :: Foldable t => AgentClient -> t ([SndQueue], AgentMsgId) -> AM' ()
enqueueSavedMessageB :: forall (t :: * -> *).
Foldable t =>
AgentClient -> t ([SndQueue], UserId) -> ReaderT Env IO ()
enqueueSavedMessageB AgentClient
c t ([SndQueue], UserId)
reqs = do
  -- saving to the database is in the start to avoid race conditions when delivery is read from queue before it is saved
  ReaderT Env IO [Either AgentErrorType ()] -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Env IO [Either AgentErrorType ()] -> ReaderT Env IO ())
-> ReaderT Env IO [Either AgentErrorType ()] -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> (Connection -> [IO ()])
-> ReaderT Env IO [Either AgentErrorType ()]
forall (t :: * -> *) a.
Traversable t =>
AgentClient
-> (Connection -> t (IO a)) -> AM' (t (Either AgentErrorType a))
withStoreBatch' AgentClient
c ((Connection -> [IO ()])
 -> ReaderT Env IO [Either AgentErrorType ()])
-> (Connection -> [IO ()])
-> ReaderT Env IO [Either AgentErrorType ()]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> (([SndQueue], UserId) -> [IO ()])
-> t ([SndQueue], UserId) -> [IO ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Connection -> ([SndQueue], UserId) -> [IO ()]
storeDeliveries Connection
db) t ([SndQueue], UserId)
reqs
  -- TODO this needs to be optimized to insert them in one query
  t ([SndQueue], UserId)
-> (([SndQueue], UserId) -> ReaderT Env IO [()])
-> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t ([SndQueue], UserId)
reqs ((([SndQueue], UserId) -> ReaderT Env IO [()])
 -> ReaderT Env IO ())
-> (([SndQueue], UserId) -> ReaderT Env IO [()])
-> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ \([SndQueue]
sqs, UserId
_) -> [SndQueue]
-> (SndQueue -> ReaderT Env IO ()) -> ReaderT Env IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [SndQueue]
sqs ((SndQueue -> ReaderT Env IO ()) -> ReaderT Env IO [()])
-> (SndQueue -> ReaderT Env IO ()) -> ReaderT Env IO [()]
forall a b. (a -> b) -> a -> b
$ AgentClient -> SndQueue -> ReaderT Env IO ()
submitPendingMsg AgentClient
c
  where
    storeDeliveries :: DB.Connection -> ([SndQueue], AgentMsgId) -> [IO ()]
    storeDeliveries :: Connection -> ([SndQueue], UserId) -> [IO ()]
storeDeliveries Connection
db ([SndQueue]
sqs, UserId
msgId) = do
      let mId :: InternalId
mId = UserId -> InternalId
InternalId UserId
msgId
       in (SndQueue -> IO ()) -> [SndQueue] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (\SndQueue
sq -> Connection -> SndQueue -> InternalId -> IO ()
createSndMsgDelivery Connection
db SndQueue
sq InternalId
mId) [SndQueue]
sqs

resumeMsgDelivery :: AgentClient -> SndQueue -> AM' ()
-- hasWork is passed as False to avoid unnecessary write to TMVar:
-- - new worker is always created by "some work to do".
-- - if the worker already exists, there is no need to "push" it again.
resumeMsgDelivery :: AgentClient -> SndQueue -> ReaderT Env IO ()
resumeMsgDelivery = ReaderT Env IO (Worker, TMVar ()) -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Env IO (Worker, TMVar ()) -> ReaderT Env IO ())
-> (AgentClient -> SndQueue -> ReaderT Env IO (Worker, TMVar ()))
-> AgentClient
-> SndQueue
-> ReaderT Env IO ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: Bool
-> AgentClient -> SndQueue -> ReaderT Env IO (Worker, TMVar ())
getDeliveryWorker Bool
False
{-# INLINE resumeMsgDelivery #-}

getDeliveryWorker :: Bool -> AgentClient -> SndQueue -> AM' (Worker, TMVar ())
getDeliveryWorker :: Bool
-> AgentClient -> SndQueue -> ReaderT Env IO (Worker, TMVar ())
getDeliveryWorker Bool
hasWork AgentClient
c SndQueue
sq =
  ((Worker, TMVar ()) -> Worker)
-> (Worker -> STM (Worker, TMVar ()))
-> String
-> Bool
-> AgentClient
-> (SMPServer, QueueId)
-> TMap (SMPServer, QueueId) (Worker, TMVar ())
-> ((Worker, TMVar ())
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO (Worker, TMVar ())
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, TMVar ()) -> Worker
forall a b. (a, b) -> a
fst Worker -> STM (Worker, TMVar ())
forall {a} {a}. a -> STM (a, TMVar a)
mkLock String
"msg_delivery" Bool
hasWork AgentClient
c (SndQueue -> (SMPServer, QueueId)
forall q. SMPQueue q => q -> (SMPServer, QueueId)
qAddress SndQueue
sq) (AgentClient -> TMap (SMPServer, QueueId) (Worker, TMVar ())
smpDeliveryWorkers AgentClient
c) (AgentClient
-> SndQueue
-> (Worker, TMVar ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
runSmpQueueMsgDelivery AgentClient
c SndQueue
sq)
  where
    mkLock :: a -> STM (a, TMVar a)
mkLock a
w = do
      TMVar a
retryLock <- STM (TMVar a)
forall a. STM (TMVar a)
newEmptyTMVar
      (a, TMVar a) -> STM (a, TMVar a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
w, TMVar a
retryLock)

submitPendingMsg :: AgentClient -> SndQueue -> AM' ()
submitPendingMsg :: AgentClient -> SndQueue -> ReaderT Env IO ()
submitPendingMsg AgentClient
c SndQueue
sq = 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 AgentOpState -> (AgentOpState -> AgentOpState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (AgentClient -> TVar AgentOpState
msgDeliveryOp AgentClient
c) ((AgentOpState -> AgentOpState) -> STM ())
-> (AgentOpState -> AgentOpState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \AgentOpState
s -> AgentOpState
s {opsInProgress = opsInProgress s + 1}
  ReaderT Env IO (Worker, TMVar ()) -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Env IO (Worker, TMVar ()) -> ReaderT Env IO ())
-> ReaderT Env IO (Worker, TMVar ()) -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ Bool
-> AgentClient -> SndQueue -> ReaderT Env IO (Worker, TMVar ())
getDeliveryWorker Bool
True AgentClient
c SndQueue
sq

runSmpQueueMsgDelivery :: AgentClient -> SndQueue -> (Worker, TMVar ()) -> AM ()
runSmpQueueMsgDelivery :: AgentClient
-> SndQueue
-> (Worker, TMVar ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
runSmpQueueMsgDelivery c :: AgentClient
c@AgentClient {TBQueue ATransmission
$sel:subQ:AgentClient :: AgentClient -> TBQueue ATransmission
subQ :: TBQueue ATransmission
subQ} sq :: SndQueue
sq@SndQueue {UserId
userId :: UserId
$sel:userId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> UserId
userId, ConnId
connId :: ConnId
$sel:connId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> ConnId
connId, SMPServer
server :: SMPServer
$sel:server:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> SMPServer
server, Maybe QueueMode
queueMode :: Maybe QueueMode
$sel:queueMode:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> Maybe QueueMode
queueMode} (Worker {TMVar ()
$sel:doWork:Worker :: Worker -> TMVar ()
doWork :: TMVar ()
doWork}, TMVar ()
qLock) = do
  AgentConfig {$sel:messageRetryInterval:AgentConfig :: AgentConfig -> RetryInterval2
messageRetryInterval = RetryInterval2
ri, NominalDiffTime
messageTimeout :: NominalDiffTime
$sel:messageTimeout:AgentConfig :: AgentConfig -> NominalDiffTime
messageTimeout, NominalDiffTime
helloTimeout :: NominalDiffTime
$sel:helloTimeout:AgentConfig :: AgentConfig -> NominalDiffTime
helloTimeout, NominalDiffTime
quotaExceededTimeout :: NominalDiffTime
$sel:quotaExceededTimeout:AgentConfig :: AgentConfig -> NominalDiffTime
quotaExceededTimeout} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
  ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (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
$ 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 -> AgentOperation -> STM ()
endAgentOperation AgentClient
c AgentOperation
AOSndNetwork
    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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> ReaderT Env IO ()
forall (m :: * -> *). MonadIO m => TMVar () -> m ()
waitForWork TMVar ()
doWork
    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
$ AgentClient -> IO ()
throwWhenInactive AgentClient
c
    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
$ AgentClient -> SndQueue -> IO ()
throwWhenNoDelivery AgentClient
c SndQueue
sq
    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 -> AgentOperation -> STM ()
beginAgentOperation AgentClient
c AgentOperation
AOSndNetwork
    AgentClient
-> TMVar ()
-> (Connection
    -> IO (Either StoreError (Maybe (Maybe RcvQueue, PendingMsgData))))
-> ((Maybe RcvQueue, PendingMsgData)
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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 (\Connection
db -> Connection
-> ConnId
-> SndQueue
-> IO (Either StoreError (Maybe (Maybe RcvQueue, PendingMsgData)))
getPendingQueueMsg Connection
db ConnId
connId SndQueue
sq) (((Maybe RcvQueue, PendingMsgData)
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((Maybe RcvQueue, PendingMsgData)
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$
      \(Maybe RcvQueue
rq_, PendingMsgData {InternalId
msgId :: InternalId
$sel:msgId:PendingMsgData :: PendingMsgData -> InternalId
msgId, AgentMessageType
msgType :: AgentMessageType
$sel:msgType:PendingMsgData :: PendingMsgData -> AgentMessageType
msgType, ConnId
msgBody :: ConnId
$sel:msgBody:PendingMsgData :: PendingMsgData -> ConnId
msgBody, PQEncryption
pqEncryption :: PQEncryption
$sel:pqEncryption:PendingMsgData :: PendingMsgData -> PQEncryption
pqEncryption, MsgFlags
msgFlags :: MsgFlags
$sel:msgFlags:PendingMsgData :: PendingMsgData -> MsgFlags
msgFlags, Maybe RI2State
msgRetryState :: Maybe RI2State
$sel:msgRetryState:PendingMsgData :: PendingMsgData -> Maybe RI2State
msgRetryState, InternalTs
internalTs :: InternalTs
$sel:internalTs:PendingMsgData :: PendingMsgData -> InternalTs
internalTs, InternalSndId
internalSndId :: InternalSndId
$sel:internalSndId:PendingMsgData :: PendingMsgData -> InternalSndId
internalSndId, ConnId
prevMsgHash :: ConnId
$sel:prevMsgHash:PendingMsgData :: PendingMsgData -> ConnId
prevMsgHash, Maybe PendingMsgPrepData
pendingMsgPrepData_ :: Maybe PendingMsgPrepData
$sel:pendingMsgPrepData_:PendingMsgData :: PendingMsgData -> Maybe PendingMsgPrepData
pendingMsgPrepData_}) -> 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 -> AgentOperation -> STM ()
endAgentOperation AgentClient
c AgentOperation
AOMsgDelivery -- this operation begins in submitPendingMsg
        let mId :: UserId
mId = InternalId -> UserId
unId InternalId
msgId
            ri' :: RetryInterval2
ri' = (RetryInterval2 -> RetryInterval2)
-> (RI2State -> RetryInterval2 -> RetryInterval2)
-> Maybe RI2State
-> RetryInterval2
-> RetryInterval2
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RetryInterval2 -> RetryInterval2
forall a. a -> a
id RI2State -> RetryInterval2 -> RetryInterval2
updateRetryInterval2 Maybe RI2State
msgRetryState RetryInterval2
ri
        RetryInterval2
-> TMVar ()
-> (RI2State
    -> (RetryIntervalMode
        -> ExceptT AgentErrorType (ReaderT Env IO) ())
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *).
MonadIO m =>
RetryInterval2
-> TMVar ()
-> (RI2State -> (RetryIntervalMode -> m ()) -> m ())
-> m ()
withRetryLock2 RetryInterval2
ri' TMVar ()
qLock ((RI2State
  -> (RetryIntervalMode
      -> ExceptT AgentErrorType (ReaderT Env IO) ())
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (RI2State
    -> (RetryIntervalMode
        -> ExceptT AgentErrorType (ReaderT Env IO) ())
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \RI2State
riState RetryIntervalMode -> ExceptT AgentErrorType (ReaderT Env IO) ()
loop -> do
          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
$ AgentClient -> IO ()
waitWhileSuspended AgentClient
c
          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
$ AgentClient -> IO ()
waitForUserNetwork AgentClient
c
          Either AgentErrorType (Maybe SMPServer)
resp <- ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType (Maybe SMPServer))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors (ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (Either AgentErrorType (Maybe SMPServer)))
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either AgentErrorType (Maybe SMPServer))
forall a b. (a -> b) -> a -> b
$ case AgentMessageType
msgType of
            AgentMessageType
AM_CONN_INFO -> AgentClient
-> NetworkRequestMode
-> SndQueue
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
sendConfirmation AgentClient
c NetworkRequestMode
NRMBackground SndQueue
sq ConnId
msgBody
            AgentMessageType
AM_CONN_INFO_REPLY -> AgentClient
-> NetworkRequestMode
-> SndQueue
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
sendConfirmation AgentClient
c NetworkRequestMode
NRMBackground SndQueue
sq ConnId
msgBody
            AgentMessageType
_ -> case Maybe PendingMsgPrepData
pendingMsgPrepData_ of
              Maybe PendingMsgPrepData
Nothing -> AgentClient
-> SndQueue
-> MsgFlags
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
sendAgentMessage AgentClient
c SndQueue
sq MsgFlags
msgFlags ConnId
msgBody
              Just PendingMsgPrepData {MsgEncryptKeyX448
encryptKey :: MsgEncryptKeyX448
$sel:encryptKey:PendingMsgPrepData :: PendingMsgPrepData -> MsgEncryptKeyX448
encryptKey, Int
paddedLen :: Int
$sel:paddedLen:PendingMsgPrepData :: PendingMsgPrepData -> Int
paddedLen, AMessage
sndMsgBody :: AMessage
$sel:sndMsgBody:PendingMsgPrepData :: PendingMsgPrepData -> AMessage
sndMsgBody} -> do
                let agentMsgStr :: ConnId
agentMsgStr = AMessage -> InternalSndId -> ConnId -> ConnId
encodeAgentMsgStr AMessage
sndMsgBody InternalSndId
internalSndId ConnId
prevMsgHash
                AgentConfig {VersionRange SMPAgentVersion
$sel:smpAgentVRange:AgentConfig :: AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange :: VersionRange SMPAgentVersion
smpAgentVRange} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
                ConnId
encAgentMessage <- (CryptoError -> AgentErrorType)
-> ExceptT CryptoError IO ConnId -> AM ConnId
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError CryptoError -> AgentErrorType
cryptoError (ExceptT CryptoError IO ConnId -> AM ConnId)
-> ExceptT CryptoError IO ConnId -> AM ConnId
forall a b. (a -> b) -> a -> b
$ MsgEncryptKeyX448 -> Int -> ConnId -> ExceptT CryptoError IO ConnId
forall (a :: Algorithm).
AlgorithmI a =>
MsgEncryptKey a -> Int -> ConnId -> ExceptT CryptoError IO ConnId
CR.rcEncryptMsg MsgEncryptKeyX448
encryptKey Int
paddedLen ConnId
agentMsgStr
                let agentVersion :: VersionSMPA
agentVersion = VersionRange SMPAgentVersion -> VersionSMPA
forall v. VersionRange v -> Version v
maxVersion VersionRange SMPAgentVersion
smpAgentVRange
                    msgBody' :: ConnId
msgBody' = AgentMsgEnvelope -> ConnId
forall a. Encoding a => a -> ConnId
smpEncode (AgentMsgEnvelope -> ConnId) -> AgentMsgEnvelope -> ConnId
forall a b. (a -> b) -> a -> b
$ AgentMsgEnvelope {VersionSMPA
agentVersion :: VersionSMPA
$sel:agentVersion:AgentConfirmation :: VersionSMPA
agentVersion, ConnId
encAgentMessage :: ConnId
$sel:encAgentMessage:AgentConfirmation :: ConnId
encAgentMessage}
                AgentClient
-> SndQueue
-> MsgFlags
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
sendAgentMessage AgentClient
c SndQueue
sq MsgFlags
msgFlags ConnId
msgBody'
          case Either AgentErrorType (Maybe SMPServer)
resp of
            Left AgentErrorType
e -> do
              let err :: AEvent 'AEConn
err = if AgentMessageType
msgType AgentMessageType -> AgentMessageType -> Bool
forall a. Eq a => a -> a -> Bool
== AgentMessageType
AM_A_MSG_ then UserId -> AgentErrorType -> AEvent 'AEConn
MERR UserId
mId AgentErrorType
e else AgentErrorType -> AEvent 'AEConn
ERR AgentErrorType
e
              case AgentErrorType
e of
                SMP String
_ ErrorType
SMP.QUOTA -> 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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId SMPServer
server AgentSMPServerStats -> TVar Int
sentQuotaErrs
                  case AgentMessageType
msgType of
                    AgentMessageType
AM_CONN_INFO -> InternalId
-> ConnectionErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
connError InternalId
msgId ConnectionErrorType
NOT_AVAILABLE
                    AgentMessageType
AM_CONN_INFO_REPLY -> InternalId
-> ConnectionErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
connError InternalId
msgId ConnectionErrorType
NOT_AVAILABLE
                    AgentMessageType
_ -> do
                      InternalTs
expireTs <- NominalDiffTime -> InternalTs -> InternalTs
addUTCTime (-NominalDiffTime
quotaExceededTimeout) (InternalTs -> InternalTs)
-> ExceptT AgentErrorType (ReaderT Env IO) InternalTs
-> ExceptT AgentErrorType (ReaderT Env IO) InternalTs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO InternalTs -> ExceptT AgentErrorType (ReaderT Env IO) InternalTs
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO InternalTs
getCurrentTime
                      if InternalTs
internalTs InternalTs -> InternalTs -> Bool
forall a. Ord a => a -> a -> Bool
< InternalTs
expireTs
                        then InternalId
-> AgentErrorType
-> InternalTs
-> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyDelMsgs InternalId
msgId AgentErrorType
e InternalTs
expireTs
                        else do
                          AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ UserId -> AgentErrorType -> AEvent 'AEConn
MWARN (InternalId -> UserId
unId InternalId
msgId) AgentErrorType
e
                          RetryIntervalMode -> ExceptT AgentErrorType (ReaderT Env IO) ()
retrySndMsg RetryIntervalMode
RISlow
                SMP String
_ ErrorType
SMP.AUTH -> 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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId SMPServer
server AgentSMPServerStats -> TVar Int
sentAuthErrs
                  case AgentMessageType
msgType of
                    AgentMessageType
AM_CONN_INFO -> InternalId
-> ConnectionErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
connError InternalId
msgId ConnectionErrorType
NOT_AVAILABLE
                    AgentMessageType
AM_CONN_INFO_REPLY -> InternalId
-> ConnectionErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
connError InternalId
msgId ConnectionErrorType
NOT_AVAILABLE
                    AgentMessageType
AM_RATCHET_INFO -> InternalId
-> ConnectionErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
connError InternalId
msgId ConnectionErrorType
NOT_AVAILABLE
                    -- in duplexHandshake mode (v2) HELLO is only sent once, without retrying,
                    -- because the queue must be secured by the time the confirmation or the first HELLO is received
                    AgentMessageType
AM_HELLO_ -> case Maybe RcvQueue
rq_ of
                      -- party initiating connection
                      Just RcvQueue
_ -> InternalId
-> ConnectionErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
connError InternalId
msgId ConnectionErrorType
NOT_AVAILABLE
                      -- party joining connection
                      Maybe RcvQueue
_ -> InternalId
-> ConnectionErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
connError InternalId
msgId ConnectionErrorType
NOT_ACCEPTED
                    AgentMessageType
AM_A_MSG_ -> InternalId
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
InternalId
-> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyDel InternalId
msgId AEvent 'AEConn
err
                    AgentMessageType
AM_A_RCVD_ -> InternalId
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
InternalId
-> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyDel InternalId
msgId AEvent 'AEConn
err
                    AgentMessageType
AM_QCONT_ -> InternalId
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
InternalId
-> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyDel InternalId
msgId AEvent 'AEConn
err
                    AgentMessageType
AM_QADD_ -> InternalId -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
qError InternalId
msgId String
"QADD: AUTH"
                    AgentMessageType
AM_QKEY_ -> InternalId -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
qError InternalId
msgId String
"QKEY: AUTH"
                    AgentMessageType
AM_QUSE_ -> InternalId -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
qError InternalId
msgId String
"QUSE: AUTH"
                    AgentMessageType
AM_QTEST_ -> InternalId -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
qError InternalId
msgId String
"QTEST: AUTH"
                    AgentMessageType
AM_EREADY_ -> InternalId
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
InternalId
-> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyDel InternalId
msgId AEvent 'AEConn
err
                AgentErrorType
_
                  -- for other operations BROKER HOST is treated as a permanent error (e.g., when connecting to the server),
                  -- the message sending would be retried
                  | AgentErrorType -> Bool
temporaryOrHostError AgentErrorType
e -> do
                      let msgTimeout :: NominalDiffTime
msgTimeout = if AgentMessageType
msgType AgentMessageType -> AgentMessageType -> Bool
forall a. Eq a => a -> a -> Bool
== AgentMessageType
AM_HELLO_ then NominalDiffTime
helloTimeout else NominalDiffTime
messageTimeout
                      InternalTs
expireTs <- NominalDiffTime -> InternalTs -> InternalTs
addUTCTime (-NominalDiffTime
msgTimeout) (InternalTs -> InternalTs)
-> ExceptT AgentErrorType (ReaderT Env IO) InternalTs
-> ExceptT AgentErrorType (ReaderT Env IO) InternalTs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO InternalTs -> ExceptT AgentErrorType (ReaderT Env IO) InternalTs
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO InternalTs
getCurrentTime
                      if InternalTs
internalTs InternalTs -> InternalTs -> Bool
forall a. Ord a => a -> a -> Bool
< InternalTs
expireTs
                        then InternalId
-> AgentErrorType
-> InternalTs
-> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyDelMsgs InternalId
msgId AgentErrorType
e InternalTs
expireTs
                        else do
                          Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AgentErrorType -> Bool
serverHostError AgentErrorType
e) (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
$ AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ UserId -> AgentErrorType -> AEvent 'AEConn
MWARN (InternalId -> UserId
unId InternalId
msgId) AgentErrorType
e
                          RetryIntervalMode -> ExceptT AgentErrorType (ReaderT Env IO) ()
retrySndMsg RetryIntervalMode
RIFast
                  | Bool
otherwise -> 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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId SMPServer
server AgentSMPServerStats -> TVar Int
sentOtherErrs
                      InternalId
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
InternalId
-> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyDel InternalId
msgId AEvent 'AEConn
err
              where
                retrySndMsg :: RetryIntervalMode -> ExceptT AgentErrorType (ReaderT Env IO) ()
retrySndMsg RetryIntervalMode
riMode = do
                  AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> InternalId -> RI2State -> IO ()
updatePendingMsgRIState Connection
db ConnId
connId InternalId
msgId RI2State
riState
                  AgentClient
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
retrySndOp AgentClient
c (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
$ RetryIntervalMode -> ExceptT AgentErrorType (ReaderT Env IO) ()
loop RetryIntervalMode
riMode
            Right Maybe SMPServer
proxySrv_ -> do
              case AgentMessageType
msgType of
                AgentMessageType
AM_CONN_INFO
                  | Maybe QueueMode -> Bool
senderCanSecure Maybe QueueMode
queueMode -> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (PQEncryption -> AEvent 'AEConn
CON PQEncryption
pqEncryption) ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
>> QueueStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
setStatus QueueStatus
Active
                  | Bool
otherwise -> QueueStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
setStatus QueueStatus
Confirmed
                AgentMessageType
AM_CONN_INFO_REPLY -> QueueStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
setStatus QueueStatus
Confirmed
                AgentMessageType
AM_RATCHET_INFO -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                AgentMessageType
AM_HELLO_ -> do
                  AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> SndQueue -> QueueStatus -> IO ()
setSndQueueStatus Connection
db SndQueue
sq QueueStatus
Active
                  case Maybe RcvQueue
rq_ of
                    -- party initiating connection (in v1)
                    Just rq :: RcvQueue
rq@RcvQueue {QueueStatus
$sel:status:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueStatus
status :: QueueStatus
status} ->
                      -- it is unclear why subscribeQueue was needed here,
                      -- message delivery can only be enabled for queues that were created in the current session or subscribed
                      -- subscribeQueue c rq connId
                      --
                      -- If initiating party were to send CON to the user without waiting for reply HELLO (to reduce handshake time),
                      -- it would lead to the non-deterministic internal ID of the first sent message, at to some other race conditions,
                      -- because it can be sent before HELLO is received
                      -- With `status == Active` condition, CON is sent here only by the accepting party, that previously received HELLO
                      Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QueueStatus
status QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
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
$ 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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId (RcvQueue -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer RcvQueue
rq) AgentSMPServerStats -> TVar Int
connCompleted
                        AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ PQEncryption -> AEvent 'AEConn
CON PQEncryption
pqEncryption
                    -- this branch should never be reached as receive queue is created before the confirmation,
                    Maybe RcvQueue
_ -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError Text
"HELLO sent without receive queue"
                AgentMessageType
AM_A_MSG_ -> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ UserId -> Maybe SMPServer -> AEvent 'AEConn
SENT UserId
mId Maybe SMPServer
proxySrv_
                AgentMessageType
AM_A_RCVD_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                AgentMessageType
AM_QCONT_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                AgentMessageType
AM_QADD_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                AgentMessageType
AM_QKEY_ -> do
                  SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
                  ConnectionStats
cStats <- AgentClient
-> Connection' d RcvQueue SndQueue -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection' d RcvQueue SndQueue
conn
                  AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ QueueDirection -> SwitchPhase -> ConnectionStats -> AEvent 'AEConn
SWITCH QueueDirection
QDSnd SwitchPhase
SPConfirmed ConnectionStats
cStats
                AgentMessageType
AM_QUSE_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                AgentMessageType
AM_QTEST_ -> AgentClient
-> ConnId
-> Text
-> AM (Maybe ATransmission)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withConnLockNotify AgentClient
c ConnId
connId Text
"runSmpQueueMsgDelivery AM_QTEST_" (AM (Maybe ATransmission)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (Maybe ATransmission)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ do
                  AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> SndQueue -> QueueStatus -> IO ()
setSndQueueStatus Connection
db SndQueue
sq QueueStatus
Active
                  SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
                  case Connection' d RcvQueue SndQueue
conn of
                    DuplexConnection ConnData
cData' NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs -> do
                      -- remove old snd queue from connection once QTEST is sent to the new queue
                      let addr :: (SMPServer, QueueId)
addr = SndQueue -> (SMPServer, QueueId)
forall q. SMPQueue q => q -> (SMPServer, QueueId)
qAddress SndQueue
sq
                      case (SMPServer, QueueId) -> NonEmpty SndQueue -> Maybe SndQueue
forall q.
SMPQueue q =>
(SMPServer, QueueId) -> NonEmpty q -> Maybe q
findQ (SMPServer, QueueId)
addr NonEmpty SndQueue
sqs of
                        -- this is the same queue where this loop delivers messages to but with updated state
                        Just SndQueue {$sel:dbReplaceQueueId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> Maybe UserId
dbReplaceQueueId = Just UserId
replacedId, Bool
primary :: Bool
$sel:primary:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> Bool
primary} ->
                          -- second part of this condition is a sanity check because dbReplaceQueueId cannot point to the same queue, see switchConnection'
                          case (SndQueue -> Bool)
-> NonEmpty SndQueue -> Maybe (SndQueue, [SndQueue])
forall q. (q -> Bool) -> NonEmpty q -> Maybe (q, [q])
removeQP (\SndQueue
sq' -> SndQueue -> UserId
forall q. SMPQueueRec q => q -> UserId
dbQId SndQueue
sq' UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== UserId
replacedId Bool -> Bool -> Bool
&& Bool -> Bool
not ((SMPServer, QueueId) -> SndQueue -> Bool
forall q. SMPQueue q => (SMPServer, QueueId) -> q -> Bool
sameQueue (SMPServer, QueueId)
addr SndQueue
sq')) NonEmpty SndQueue
sqs of
                            Maybe (SndQueue, [SndQueue])
Nothing -> InternalId -> String -> AM (Maybe ATransmission)
internalErr InternalId
msgId String
"sent QTEST: queue not found in connection"
                            Just (SndQueue
sq', SndQueue
sq'' : [SndQueue]
sqs') -> do
                              SndQueue
-> SndSwitchStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkSQSwchStatus SndQueue
sq' SndSwitchStatus
SSSendingQTEST
                              -- remove the delivery from the map to stop the thread when the delivery loop is complete
                              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
$ (SMPServer, QueueId)
-> TMap (SMPServer, QueueId) (Worker, TMVar ()) -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete (SndQueue -> (SMPServer, QueueId)
forall q. SMPQueue q => q -> (SMPServer, QueueId)
qAddress SndQueue
sq') (TMap (SMPServer, QueueId) (Worker, TMVar ()) -> STM ())
-> TMap (SMPServer, QueueId) (Worker, TMVar ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMap (SMPServer, QueueId) (Worker, TMVar ())
smpDeliveryWorkers AgentClient
c
                              AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
primary (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> SndQueue -> IO ()
setSndQueuePrimary Connection
db ConnId
connId SndQueue
sq
                                Connection -> ConnId -> SndQueue -> IO ()
deletePendingMsgs Connection
db ConnId
connId SndQueue
sq'
                                Connection -> ConnId -> SndQueue -> IO ()
deleteConnSndQueue Connection
db ConnId
connId SndQueue
sq'
                              let sqs'' :: NonEmpty SndQueue
sqs'' = SndQueue
sq'' SndQueue -> [SndQueue] -> NonEmpty SndQueue
forall a. a -> [a] -> NonEmpty a
:| [SndQueue]
sqs'
                                  conn' :: Connection 'CDuplex
conn' = ConnData
-> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection 'CDuplex
forall rq sq.
ConnData
-> NonEmpty rq -> NonEmpty sq -> Connection' 'CDuplex rq sq
DuplexConnection ConnData
cData' NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs''
                              ConnectionStats
cStats <- AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection 'CDuplex
conn'
                              Maybe ATransmission -> AM (Maybe ATransmission)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ATransmission -> AM (Maybe ATransmission))
-> Maybe ATransmission -> AM (Maybe ATransmission)
forall a b. (a -> b) -> a -> b
$ ATransmission -> Maybe ATransmission
forall a. a -> Maybe a
Just (ConnId
"", ConnId
connId, 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
$ QueueDirection -> SwitchPhase -> ConnectionStats -> AEvent 'AEConn
SWITCH QueueDirection
QDSnd SwitchPhase
SPCompleted ConnectionStats
cStats)
                            Maybe (SndQueue, [SndQueue])
_ -> InternalId -> String -> AM (Maybe ATransmission)
internalErr InternalId
msgId String
"sent QTEST: there is only one queue in connection"
                        Maybe SndQueue
_ -> InternalId -> String -> AM (Maybe ATransmission)
internalErr InternalId
msgId String
"sent QTEST: queue not in connection or not replacing another queue"
                    Connection' d RcvQueue SndQueue
_ -> InternalId -> String -> AM (Maybe ATransmission)
internalErr InternalId
msgId String
"QTEST sent not in duplex connection"
                AgentMessageType
AM_EREADY_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Bool -> InternalId -> ExceptT AgentErrorType (ReaderT Env IO) ()
delMsgKeep (AgentMessageType
msgType AgentMessageType -> AgentMessageType -> Bool
forall a. Eq a => a -> a -> Bool
== AgentMessageType
AM_A_MSG_) InternalId
msgId
              where
                setStatus :: QueueStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
setStatus QueueStatus
status = do
                  AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                    Connection -> SndQueue -> QueueStatus -> IO ()
setSndQueueStatus Connection
db SndQueue
sq QueueStatus
status
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe RcvQueue -> Bool
forall a. Maybe a -> Bool
isJust Maybe RcvQueue
rq_) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> IO ()
removeConfirmations Connection
db ConnId
connId
  where
    notifyDelMsgs :: InternalId -> AgentErrorType -> UTCTime -> AM ()
    notifyDelMsgs :: InternalId
-> AgentErrorType
-> InternalTs
-> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyDelMsgs InternalId
msgId AgentErrorType
err InternalTs
expireTs = do
      InternalId
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
InternalId
-> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyDel InternalId
msgId (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ UserId -> AgentErrorType -> AEvent 'AEConn
MERR (InternalId -> UserId
unId InternalId
msgId) AgentErrorType
err
      [InternalId]
msgIds_ <- AgentClient -> (Connection -> IO [InternalId]) -> AM [InternalId]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO [InternalId]) -> AM [InternalId])
-> (Connection -> IO [InternalId]) -> AM [InternalId]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
        [InternalId]
msgIds_ <- Connection -> ConnId -> SndQueue -> InternalTs -> IO [InternalId]
getExpiredSndMessages Connection
db ConnId
connId SndQueue
sq InternalTs
expireTs
        [InternalId] -> (InternalId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [InternalId]
msgIds_ ((InternalId -> IO ()) -> IO ()) -> (InternalId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \InternalId
msgId' -> Connection -> ConnId -> SndQueue -> InternalId -> Bool -> IO ()
deleteSndMsgDelivery Connection
db ConnId
connId SndQueue
sq InternalId
msgId' Bool
False 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 ()
        [InternalId] -> IO [InternalId]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [InternalId]
msgIds_
      Maybe (NonEmpty InternalId)
-> (NonEmpty InternalId
    -> 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_ ([InternalId] -> Maybe (NonEmpty InternalId)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [InternalId]
msgIds_) ((NonEmpty InternalId
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (NonEmpty InternalId
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty InternalId
msgIds -> do
        AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ NonEmpty UserId -> AgentErrorType -> AEvent 'AEConn
MERRS ((InternalId -> UserId) -> NonEmpty InternalId -> NonEmpty UserId
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map InternalId -> UserId
unId NonEmpty InternalId
msgIds) AgentErrorType
err
      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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> Int
-> STM ()
incSMPServerStat' AgentClient
c UserId
userId SMPServer
server AgentSMPServerStats -> TVar Int
sentExpiredErrs ([InternalId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InternalId]
msgIds_ Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    delMsg :: InternalId -> AM ()
    delMsg :: InternalId -> ExceptT AgentErrorType (ReaderT Env IO) ()
delMsg = Bool -> InternalId -> ExceptT AgentErrorType (ReaderT Env IO) ()
delMsgKeep Bool
False
    delMsgKeep :: Bool -> InternalId -> AM ()
    delMsgKeep :: Bool -> InternalId -> ExceptT AgentErrorType (ReaderT Env IO) ()
delMsgKeep Bool
keepForReceipt InternalId
msgId = AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> SndQueue -> InternalId -> Bool -> IO ()
deleteSndMsgDelivery Connection
db ConnId
connId SndQueue
sq InternalId
msgId Bool
keepForReceipt
    notify :: forall e. AEntityI e => AEvent e -> AM ()
    notify :: forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify AEvent e
cmd = 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
$ TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue ATransmission
subQ (ConnId
"", ConnId
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)
    notifyDel :: AEntityI e => InternalId -> AEvent e -> AM ()
    notifyDel :: forall (e :: AEntity).
AEntityI e =>
InternalId
-> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyDel InternalId
msgId AEvent e
cmd = AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify AEvent e
cmd ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
>> InternalId -> ExceptT AgentErrorType (ReaderT Env IO) ()
delMsg InternalId
msgId
    connError :: InternalId
-> ConnectionErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
connError InternalId
msgId = InternalId
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
InternalId
-> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyDel InternalId
msgId (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ConnectionErrorType -> AEvent 'AEConn)
-> ConnectionErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> AEvent 'AEConn)
-> (ConnectionErrorType -> AgentErrorType)
-> ConnectionErrorType
-> AEvent 'AEConn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConnectionErrorType -> String -> AgentErrorType
`CONN` String
"")
    qError :: InternalId -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
qError InternalId
msgId = InternalId
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
InternalId
-> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyDel InternalId
msgId (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (String -> AEvent 'AEConn)
-> String
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> AEvent 'AEConn)
-> (String -> AgentErrorType) -> String -> AEvent 'AEConn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPAgentError -> AgentErrorType
AGENT (SMPAgentError -> AgentErrorType)
-> (String -> SMPAgentError) -> String -> AgentErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SMPAgentError
A_QUEUE
    internalErr :: InternalId -> String -> AM (Maybe ATransmission)
internalErr InternalId
msgId String
s = do
      InternalId -> ExceptT AgentErrorType (ReaderT Env IO) ()
delMsg InternalId
msgId
      Maybe ATransmission -> AM (Maybe ATransmission)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ATransmission -> AM (Maybe ATransmission))
-> Maybe ATransmission -> AM (Maybe ATransmission)
forall a b. (a -> b) -> a -> b
$ ATransmission -> Maybe ATransmission
forall a. a -> Maybe a
Just (ConnId
"", ConnId
connId, 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
INTERNAL String
s)

retrySndOp :: AgentClient -> AM () -> AM ()
retrySndOp :: AgentClient
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
retrySndOp AgentClient
c ExceptT AgentErrorType (ReaderT Env IO) ()
loop = do
  -- end... is in a separate atomically because if begin... blocks, SUSPENDED won't be sent
  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 -> AgentOperation -> STM ()
endAgentOperation AgentClient
c AgentOperation
AOSndNetwork
  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
$ AgentClient -> IO ()
throwWhenInactive AgentClient
c
  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 -> AgentOperation -> STM ()
beginAgentOperation AgentClient
c AgentOperation
AOSndNetwork
  ExceptT AgentErrorType (ReaderT Env IO) ()
loop

-- | Like 'withConnLock', but writes the returned 'ATransmission' to 'subQ'
-- after releasing the lock, preventing deadlock with agentSubscriber.
withConnLockNotify :: AgentClient -> ConnId -> Text -> AM (Maybe ATransmission) -> AM ()
withConnLockNotify :: AgentClient
-> ConnId
-> Text
-> AM (Maybe ATransmission)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withConnLockNotify AgentClient
c ConnId
connId Text
name AM (Maybe ATransmission)
action = do
  Maybe ATransmission
t_ <- AgentClient
-> ConnId
-> Text
-> AM (Maybe ATransmission)
-> AM (Maybe ATransmission)
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
name AM (Maybe ATransmission)
action
  Maybe ATransmission
-> (ATransmission -> 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 ATransmission
t_ ((ATransmission -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ATransmission -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ATransmission -> STM ())
-> ATransmission
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c)

ackMessage' :: AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AM ()
ackMessage' :: AgentClient
-> ConnId
-> UserId
-> Maybe ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
ackMessage' AgentClient
c ConnId
connId UserId
msgId Maybe ConnId
rcptInfo_ = AgentClient
-> ConnId
-> Text
-> AM (Maybe ATransmission)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
withConnLockNotify AgentClient
c ConnId
connId Text
"ackMessage" (AM (Maybe ATransmission)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (Maybe ATransmission)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ do
  SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
  case Connection' d RcvQueue SndQueue
conn of
    DuplexConnection {} -> do
      Maybe ATransmission
t_ <- AM (Maybe ATransmission)
ack
      Connection 'CDuplex -> ExceptT AgentErrorType (ReaderT Env IO) ()
sendRcpt Connection' d RcvQueue SndQueue
Connection 'CDuplex
conn
      ExceptT AgentErrorType (ReaderT Env IO) ()
del
      Maybe ATransmission -> AM (Maybe ATransmission)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ATransmission
t_
    RcvConnection {} -> do
      Maybe ATransmission
t_ <- AM (Maybe ATransmission)
ack
      ExceptT AgentErrorType (ReaderT Env IO) ()
del
      Maybe ATransmission -> AM (Maybe ATransmission)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ATransmission
t_
    SndConnection {} -> AgentErrorType -> AM (Maybe ATransmission)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (Maybe ATransmission))
-> AgentErrorType -> AM (Maybe ATransmission)
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX String
"ackMessage"
    ContactConnection {} -> AgentErrorType -> AM (Maybe ATransmission)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (Maybe ATransmission))
-> AgentErrorType -> AM (Maybe ATransmission)
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"ackMessage: ContactConnection"
    NewConnection ConnData
_ -> AgentErrorType -> AM (Maybe ATransmission)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM (Maybe ATransmission))
-> AgentErrorType -> AM (Maybe ATransmission)
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"ackMessage: NewConnection"
  where
    ack :: AM (Maybe ATransmission)
    ack :: AM (Maybe ATransmission)
ack = do
      -- the stored message was delivered via a specific queue, the rest failed to decrypt and were already acknowledged
      (RcvQueue
rq, ConnId
srvMsgId) <- AgentClient
-> (Connection -> IO (Either StoreError (RcvQueue, ConnId)))
-> AM (RcvQueue, ConnId)
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError (RcvQueue, ConnId)))
 -> AM (RcvQueue, ConnId))
-> (Connection -> IO (Either StoreError (RcvQueue, ConnId)))
-> AM (RcvQueue, ConnId)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ConnId
-> InternalId
-> IO (Either StoreError (RcvQueue, ConnId))
setMsgUserAck Connection
db ConnId
connId (InternalId -> IO (Either StoreError (RcvQueue, ConnId)))
-> InternalId -> IO (Either StoreError (RcvQueue, ConnId))
forall a b. (a -> b) -> a -> b
$ UserId -> InternalId
InternalId UserId
msgId
      AgentClient -> RcvQueue -> ConnId -> AM (Maybe ATransmission)
ackQueueMessage AgentClient
c RcvQueue
rq ConnId
srvMsgId
    del :: AM ()
    del :: ExceptT AgentErrorType (ReaderT Env IO) ()
del = AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> InternalId -> IO ()
deleteMsg Connection
db ConnId
connId (InternalId -> IO ()) -> InternalId -> IO ()
forall a b. (a -> b) -> a -> b
$ UserId -> InternalId
InternalId UserId
msgId
    sendRcpt :: Connection 'CDuplex -> AM ()
    sendRcpt :: Connection 'CDuplex -> ExceptT AgentErrorType (ReaderT Env IO) ()
sendRcpt (DuplexConnection cData :: ConnData
cData@ConnData {VersionSMPA
$sel:connAgentVersion:ConnData :: ConnData -> VersionSMPA
connAgentVersion :: VersionSMPA
connAgentVersion} NonEmpty RcvQueue
_ NonEmpty SndQueue
sqs) = do
      msg :: RcvMsg
msg@RcvMsg {AgentMessageType
$sel:msgType:RcvMsg :: RcvMsg -> AgentMessageType
msgType :: AgentMessageType
msgType, Maybe MsgReceipt
msgReceipt :: Maybe MsgReceipt
$sel:msgReceipt:RcvMsg :: RcvMsg -> Maybe MsgReceipt
msgReceipt} <- AgentClient
-> (Connection -> IO (Either StoreError RcvMsg)) -> AM RcvMsg
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError RcvMsg)) -> AM RcvMsg)
-> (Connection -> IO (Either StoreError RcvMsg)) -> AM RcvMsg
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> InternalId -> IO (Either StoreError RcvMsg)
getRcvMsg Connection
db ConnId
connId (InternalId -> IO (Either StoreError RcvMsg))
-> InternalId -> IO (Either StoreError RcvMsg)
forall a b. (a -> b) -> a -> b
$ UserId -> InternalId
InternalId UserId
msgId
      case Maybe ConnId
rcptInfo_ of
        Just ConnId
rcptInfo -> do
          Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AgentMessageType
msgType AgentMessageType -> AgentMessageType -> Bool
forall a. Eq a => a -> a -> Bool
== AgentMessageType
AM_A_MSG_) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"ackMessage: receipt not allowed"
          Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VersionSMPA
connAgentVersion VersionSMPA -> VersionSMPA -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMPA
deliveryRcptsSMPAgentVersion) (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
$ do
            let RcvMsg {$sel:msgMeta:RcvMsg :: RcvMsg -> MsgMeta
msgMeta = MsgMeta {UserId
sndMsgId :: UserId
$sel:sndMsgId:MsgMeta :: MsgMeta -> UserId
sndMsgId}, ConnId
internalHash :: ConnId
$sel:internalHash:RcvMsg :: RcvMsg -> ConnId
internalHash} = RcvMsg
msg
                rcpt :: AMessage
rcpt = NonEmpty AMessageReceipt -> AMessage
A_RCVD [AMessageReceipt {$sel:agentMsgId:AMessageReceipt :: UserId
agentMsgId = UserId
sndMsgId, $sel:msgHash:AMessageReceipt :: ConnId
msgHash = ConnId
internalHash, ConnId
rcptInfo :: ConnId
$sel:rcptInfo:AMessageReceipt :: ConnId
rcptInfo}]
            AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM (UserId, PQEncryption)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> ConnData
-> NonEmpty SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessages AgentClient
c ConnData
cData NonEmpty SndQueue
sqs SMP.MsgFlags {$sel:notification:MsgFlags :: Bool
notification = Bool
False} AMessage
rcpt
        Maybe ConnId
Nothing -> case (AgentMessageType
msgType, Maybe MsgReceipt
msgReceipt) of
          -- only remove sent message if receipt hash was Ok, both to debug and for future redundancy
          (AgentMessageType
AM_A_RCVD_, Just MsgReceipt {$sel:agentMsgId:MsgReceipt :: MsgReceipt -> UserId
agentMsgId = UserId
sndMsgId, $sel:msgRcptStatus:MsgReceipt :: MsgReceipt -> MsgReceiptStatus
msgRcptStatus = MsgReceiptStatus
MROk}) ->
            AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> InternalId -> IO ()
deleteDeliveredSndMsg Connection
db ConnId
connId (InternalId -> IO ()) -> InternalId -> IO ()
forall a b. (a -> b) -> a -> b
$ UserId -> InternalId
InternalId UserId
sndMsgId
          (AgentMessageType, Maybe MsgReceipt)
_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

getConnectionQueueInfo' :: AgentClient -> NetworkRequestMode -> ConnId -> AM ServerQueueInfo
getConnectionQueueInfo' :: AgentClient -> NetworkRequestMode -> ConnId -> AM ServerQueueInfo
getConnectionQueueInfo' AgentClient
c NetworkRequestMode
nm ConnId
connId = do
  SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
  case Connection' d RcvQueue SndQueue
conn of
    DuplexConnection ConnData
_ (RcvQueue
rq :| [RcvQueue]
_) NonEmpty SndQueue
_ -> AgentClient -> NetworkRequestMode -> RcvQueue -> AM ServerQueueInfo
getQueueInfo AgentClient
c NetworkRequestMode
nm RcvQueue
rq
    RcvConnection ConnData
_ RcvQueue
rq -> AgentClient -> NetworkRequestMode -> RcvQueue -> AM ServerQueueInfo
getQueueInfo AgentClient
c NetworkRequestMode
nm RcvQueue
rq
    ContactConnection ConnData
_ RcvQueue
rq -> AgentClient -> NetworkRequestMode -> RcvQueue -> AM ServerQueueInfo
getQueueInfo AgentClient
c NetworkRequestMode
nm RcvQueue
rq
    SndConnection {} -> AgentErrorType -> AM ServerQueueInfo
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ServerQueueInfo)
-> AgentErrorType -> AM ServerQueueInfo
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX String
"getConnectionQueueInfo"
    NewConnection ConnData
_ -> AgentErrorType -> AM ServerQueueInfo
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ServerQueueInfo)
-> AgentErrorType -> AM ServerQueueInfo
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"getConnectionQueueInfo: NewConnection"

switchConnection' :: AgentClient -> NetworkRequestMode -> ConnId -> AM ConnectionStats
switchConnection' :: AgentClient -> NetworkRequestMode -> ConnId -> AM ConnectionStats
switchConnection' AgentClient
c NetworkRequestMode
nm ConnId
connId =
  AgentClient
-> ConnId -> Text -> AM ConnectionStats -> AM ConnectionStats
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
"switchConnection" (AM ConnectionStats -> AM ConnectionStats)
-> AM ConnectionStats -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$
    AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId) AM SomeConn
-> (SomeConn -> AM ConnectionStats) -> AM ConnectionStats
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
      SomeConn SConnType d
_ conn :: Connection' d RcvQueue SndQueue
conn@(DuplexConnection ConnData
cData rqs :: NonEmpty RcvQueue
rqs@(RcvQueue
rq :| [RcvQueue]
_rqs) NonEmpty SndQueue
_)
        | Maybe RcvQueue -> Bool
forall a. Maybe a -> Bool
isJust (NonEmpty RcvQueue -> Maybe RcvQueue
switchingRQ NonEmpty RcvQueue
rqs) -> AgentErrorType -> AM ConnectionStats
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnectionStats)
-> AgentErrorType -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"switchConnection: already switching"
        | Bool
otherwise -> do
            Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnData -> Bool
ratchetSyncSendProhibited ConnData
cData) (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"switchConnection: send prohibited"
            RcvQueue
rq' <- AgentClient -> (Connection -> IO RcvQueue) -> AM RcvQueue
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO RcvQueue) -> AM RcvQueue)
-> (Connection -> IO RcvQueue) -> AM RcvQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvQueue -> Maybe RcvSwitchStatus -> IO RcvQueue
setRcvSwitchStatus Connection
db RcvQueue
rq (Maybe RcvSwitchStatus -> IO RcvQueue)
-> Maybe RcvSwitchStatus -> IO RcvQueue
forall a b. (a -> b) -> a -> b
$ RcvSwitchStatus -> Maybe RcvSwitchStatus
forall a. a -> Maybe a
Just RcvSwitchStatus
RSSwitchStarted
            AgentClient
-> NetworkRequestMode
-> Connection 'CDuplex
-> RcvQueue
-> AM ConnectionStats
switchDuplexConnection AgentClient
c NetworkRequestMode
nm Connection' d RcvQueue SndQueue
Connection 'CDuplex
conn RcvQueue
rq'
      SomeConn
_ -> AgentErrorType -> AM ConnectionStats
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnectionStats)
-> AgentErrorType -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"switchConnection: not duplex"

switchDuplexConnection :: AgentClient -> NetworkRequestMode -> Connection 'CDuplex -> RcvQueue -> AM ConnectionStats
switchDuplexConnection :: AgentClient
-> NetworkRequestMode
-> Connection 'CDuplex
-> RcvQueue
-> AM ConnectionStats
switchDuplexConnection AgentClient
c NetworkRequestMode
nm (DuplexConnection cData :: ConnData
cData@ConnData {ConnId
$sel:connId:ConnData :: ConnData -> ConnId
connId :: ConnId
connId, UserId
$sel:userId:ConnData :: ConnData -> UserId
userId :: UserId
userId} NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs) rq :: RcvQueue
rq@RcvQueue {SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server :: SMPServer
server, $sel:dbQueueId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> DBEntityId' q
dbQueueId = DBEntityId UserId
dbQueueId, QueueId
$sel:sndId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueId
sndId :: QueueId
sndId} = do
  RcvQueue
-> RcvSwitchStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkRQSwchStatus RcvQueue
rq RcvSwitchStatus
RSSwitchStarted
  VersionRangeSMPC
clientVRange <- (Env -> VersionRangeSMPC)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> VersionRangeSMPC)
 -> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC)
-> (Env -> VersionRangeSMPC)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC
forall a b. (a -> b) -> a -> b
$ AgentConfig -> VersionRangeSMPC
smpClientVRange (AgentConfig -> VersionRangeSMPC)
-> (Env -> AgentConfig) -> Env -> VersionRangeSMPC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  -- try to get the server that is different from all queues, or at least from the primary rcv queue
  srvAuth :: SMPServerWithAuth
srvAuth@(ProtoServerWithAuth SMPServer
srv Maybe BasicAuth
_) <- AgentClient -> UserId -> [SMPServer] -> AM SMPServerWithAuth
getNextSMPServer AgentClient
c UserId
userId ([SMPServer] -> AM SMPServerWithAuth)
-> [SMPServer] -> AM SMPServerWithAuth
forall a b. (a -> b) -> a -> b
$ (RcvQueue -> SMPServer) -> [RcvQueue] -> [SMPServer]
forall a b. (a -> b) -> [a] -> [b]
map RcvQueue -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer (NonEmpty RcvQueue -> [RcvQueue]
forall a. NonEmpty a -> [a]
L.toList NonEmpty RcvQueue
rqs) [SMPServer] -> [SMPServer] -> [SMPServer]
forall a. Semigroup a => a -> a -> a
<> (SndQueue -> SMPServer) -> [SndQueue] -> [SMPServer]
forall a b. (a -> b) -> [a] -> [b]
map SndQueue -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer (NonEmpty SndQueue -> [SndQueue]
forall a. NonEmpty a -> [a]
L.toList NonEmpty SndQueue
sqs)
  SMPServerWithAuth
srv' <- if SMPServer
srv SMPServer -> SMPServer -> Bool
forall a. Eq a => a -> a -> Bool
== SMPServer
server then AgentClient -> UserId -> [SMPServer] -> AM SMPServerWithAuth
getNextSMPServer AgentClient
c UserId
userId [Item [SMPServer]
SMPServer
server] else SMPServerWithAuth -> AM SMPServerWithAuth
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPServerWithAuth
srvAuth
  -- TODO [notications] possible improvement would be to create ntf credentials here, to avoid creating them after rotation completes.
  -- The problem is that currently subscription already exists, and we do not support queues with credentials but without subscriptions.
  (StoredRcvQueue 'DBNew
q, SMPQueueUri
qUri, (UserId, SMPServer, Maybe ConnId)
tSess, ConnId
sessId) <- AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> SMPServerWithAuth
-> VersionRangeSMPC
-> SConnectionMode 'CMInvitation
-> Bool
-> SubscriptionMode
-> AM
     (StoredRcvQueue 'DBNew, SMPQueueUri, TransportSession BrokerMsg,
      ConnId)
forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> UserId
-> ConnId
-> SMPServerWithAuth
-> VersionRangeSMPC
-> SConnectionMode c
-> Bool
-> SubscriptionMode
-> AM
     (StoredRcvQueue 'DBNew, SMPQueueUri, TransportSession BrokerMsg,
      ConnId)
newRcvQueue AgentClient
c NetworkRequestMode
nm UserId
userId ConnId
connId SMPServerWithAuth
srv' VersionRangeSMPC
clientVRange SConnectionMode 'CMInvitation
SCMInvitation Bool
False SubscriptionMode
SMSubscribe
  let rq' :: StoredRcvQueue 'DBNew
rq' = (StoredRcvQueue 'DBNew
q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
  RcvQueue
rq'' <- AgentClient
-> (Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue)
-> (Connection -> IO (Either StoreError RcvQueue)) -> AM RcvQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ConnId
-> StoredRcvQueue 'DBNew
-> SubscriptionMode
-> IO (Either StoreError RcvQueue)
addConnRcvQueue Connection
db ConnId
connId StoredRcvQueue 'DBNew
rq' SubscriptionMode
SMSubscribe
  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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> RcvQueue
-> TransportSession BrokerMsg
-> ConnId
-> ReaderT Env IO ()
addNewQueueSubscription AgentClient
c RcvQueue
rq'' TransportSession BrokerMsg
(UserId, SMPServer, Maybe ConnId)
tSess ConnId
sessId
  AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM (UserId, PQEncryption)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AMessage -> AM (UserId, PQEncryption))
-> AMessage
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> ConnData
-> NonEmpty SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessages AgentClient
c ConnData
cData NonEmpty SndQueue
sqs MsgFlags
SMP.noMsgFlags (AMessage -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AMessage -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ NonEmpty (SMPQueueUri, Maybe (SMPServer, QueueId)) -> AMessage
QADD [(SMPQueueUri
qUri, (SMPServer, QueueId) -> Maybe (SMPServer, QueueId)
forall a. a -> Maybe a
Just (SMPServer
server, QueueId
sndId))]
  RcvQueue
rq1 <- AgentClient -> (Connection -> IO RcvQueue) -> AM RcvQueue
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO RcvQueue) -> AM RcvQueue)
-> (Connection -> IO RcvQueue) -> AM RcvQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvQueue -> Maybe RcvSwitchStatus -> IO RcvQueue
setRcvSwitchStatus Connection
db RcvQueue
rq (Maybe RcvSwitchStatus -> IO RcvQueue)
-> Maybe RcvSwitchStatus -> IO RcvQueue
forall a b. (a -> b) -> a -> b
$ RcvSwitchStatus -> Maybe RcvSwitchStatus
forall a. a -> Maybe a
Just RcvSwitchStatus
RSSendingQADD
  let rqs' :: NonEmpty RcvQueue
rqs' = RcvQueue -> NonEmpty RcvQueue -> NonEmpty RcvQueue
forall q. SMPQueueRec q => q -> NonEmpty q -> NonEmpty q
updatedQs RcvQueue
rq1 NonEmpty RcvQueue
rqs NonEmpty RcvQueue -> NonEmpty RcvQueue -> NonEmpty RcvQueue
forall a. Semigroup a => a -> a -> a
<> [Item (NonEmpty RcvQueue)
RcvQueue
rq'']
  AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c (Connection 'CDuplex -> AM ConnectionStats)
-> Connection 'CDuplex -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ ConnData
-> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection 'CDuplex
forall rq sq.
ConnData
-> NonEmpty rq -> NonEmpty sq -> Connection' 'CDuplex rq sq
DuplexConnection ConnData
cData NonEmpty RcvQueue
rqs' NonEmpty SndQueue
sqs

abortConnectionSwitch' :: AgentClient -> ConnId -> AM ConnectionStats
abortConnectionSwitch' :: AgentClient -> ConnId -> AM ConnectionStats
abortConnectionSwitch' AgentClient
c ConnId
connId =
  AgentClient
-> ConnId -> Text -> AM ConnectionStats -> AM ConnectionStats
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
"abortConnectionSwitch" (AM ConnectionStats -> AM ConnectionStats)
-> AM ConnectionStats -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$
    AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId) AM SomeConn
-> (SomeConn -> AM ConnectionStats) -> AM ConnectionStats
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
      SomeConn SConnType d
_ (DuplexConnection ConnData
cData NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs) -> case NonEmpty RcvQueue -> Maybe RcvQueue
switchingRQ NonEmpty RcvQueue
rqs of
        Just RcvQueue
rq
          | RcvQueue -> Bool
canAbortRcvSwitch RcvQueue
rq -> do
              Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnData -> Bool
ratchetSyncSendProhibited ConnData
cData) (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"abortConnectionSwitch: send prohibited"
              -- multiple queues to which the connections switches were possible when repeating switch was allowed
              let ([RcvQueue]
delRqs, [RcvQueue]
keepRqs) = (RcvQueue -> Bool) -> NonEmpty RcvQueue -> ([RcvQueue], [RcvQueue])
forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
L.partition ((UserId -> Maybe UserId
forall a. a -> Maybe a
Just (RcvQueue -> UserId
forall q. SMPQueueRec q => q -> UserId
dbQId RcvQueue
rq) Maybe UserId -> Maybe UserId -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe UserId -> Bool)
-> (RcvQueue -> Maybe UserId) -> RcvQueue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RcvQueue -> Maybe UserId
forall q. SMPQueueRec q => q -> Maybe UserId
dbReplaceQId) NonEmpty RcvQueue
rqs
              case [RcvQueue] -> Maybe (NonEmpty RcvQueue)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [RcvQueue]
keepRqs of
                Just NonEmpty RcvQueue
rqs' -> do
                  RcvQueue
rq' <- AgentClient -> (Connection -> IO RcvQueue) -> AM RcvQueue
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO RcvQueue) -> AM RcvQueue)
-> (Connection -> IO RcvQueue) -> AM RcvQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                    (RcvQueue -> IO ()) -> [RcvQueue] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Connection -> RcvQueue -> IO ()
setRcvQueueDeleted Connection
db) [RcvQueue]
delRqs
                    Connection -> RcvQueue -> Maybe RcvSwitchStatus -> IO RcvQueue
setRcvSwitchStatus Connection
db RcvQueue
rq Maybe RcvSwitchStatus
forall a. Maybe a
Nothing
                  [RcvQueue]
-> (RcvQueue -> 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_ [RcvQueue]
delRqs ((RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \RcvQueue {SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server :: SMPServer
server, QueueId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueId
rcvId :: QueueId
rcvId} -> AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
"" ConnId
connId (SMPServer -> Maybe SMPServer
forall a. a -> Maybe a
Just SMPServer
server) (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ InternalCommand -> AgentCommand
AInternalCommand (InternalCommand -> AgentCommand)
-> InternalCommand -> AgentCommand
forall a b. (a -> b) -> a -> b
$ QueueId -> InternalCommand
ICDeleteRcvQueue QueueId
rcvId
                  let rqs'' :: NonEmpty RcvQueue
rqs'' = RcvQueue -> NonEmpty RcvQueue -> NonEmpty RcvQueue
forall q. SMPQueueRec q => q -> NonEmpty q -> NonEmpty q
updatedQs RcvQueue
rq' NonEmpty RcvQueue
rqs'
                      conn' :: Connection 'CDuplex
conn' = ConnData
-> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection 'CDuplex
forall rq sq.
ConnData
-> NonEmpty rq -> NonEmpty sq -> Connection' 'CDuplex rq sq
DuplexConnection ConnData
cData NonEmpty RcvQueue
rqs'' NonEmpty SndQueue
sqs
                  AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection 'CDuplex
conn'
                Maybe (NonEmpty RcvQueue)
_ -> AgentErrorType -> AM ConnectionStats
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnectionStats)
-> AgentErrorType -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ String -> AgentErrorType
INTERNAL String
"won't delete all rcv queues in connection"
          | Bool
otherwise -> AgentErrorType -> AM ConnectionStats
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnectionStats)
-> AgentErrorType -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"abortConnectionSwitch: no rcv queues left"
        Maybe RcvQueue
_ -> AgentErrorType -> AM ConnectionStats
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnectionStats)
-> AgentErrorType -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"abortConnectionSwitch: not allowed"
      SomeConn
_ -> AgentErrorType -> AM ConnectionStats
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnectionStats)
-> AgentErrorType -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"abortConnectionSwitch: not duplex"

synchronizeRatchet' :: AgentClient -> ConnId -> PQSupport -> Bool -> AM ConnectionStats
synchronizeRatchet' :: AgentClient -> ConnId -> PQSupport -> Bool -> AM ConnectionStats
synchronizeRatchet' AgentClient
c ConnId
connId PQSupport
pqSupport' Bool
force = AgentClient
-> ConnId -> Text -> AM ConnectionStats -> AM ConnectionStats
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
"synchronizeRatchet" (AM ConnectionStats -> AM ConnectionStats)
-> AM ConnectionStats -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ do
  AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId) AM SomeConn
-> (SomeConn -> AM ConnectionStats) -> AM ConnectionStats
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
    SomeConn SConnType d
_ (DuplexConnection cData :: ConnData
cData@ConnData {PQSupport
$sel:pqSupport:ConnData :: ConnData -> PQSupport
pqSupport :: PQSupport
pqSupport} NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs)
      | ConnData -> Bool
ratchetSyncAllowed ConnData
cData Bool -> Bool -> Bool
|| Bool
force -> do
          -- check queues are not switching?
          Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PQSupport
pqSupport' PQSupport -> PQSupport -> Bool
forall a. Eq a => a -> a -> Bool
/= PQSupport
pqSupport) (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
$ AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> PQSupport -> IO ()
setConnPQSupport Connection
db ConnId
connId PQSupport
pqSupport'
          let cData' :: ConnData
cData' = ConnData
cData {pqSupport = pqSupport'} :: ConnData
          AgentConfig {VersionRangeE2E
$sel:e2eEncryptVRange:AgentConfig :: AgentConfig -> VersionRangeE2E
e2eEncryptVRange :: VersionRangeE2E
e2eEncryptVRange} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks 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
          (PrivateKey 'X448
pk1, PrivateKey 'X448
pk2, Maybe (PrivRKEMParams 'RKSProposed)
pKem, RcvE2ERatchetParams 'X448
e2eParams) <- IO
  (PrivateKey 'X448, PrivateKey 'X448,
   Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (PrivateKey 'X448, PrivateKey 'X448,
    Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (PrivateKey 'X448, PrivateKey 'X448,
       Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448))
-> IO
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> VersionE2E
-> PQSupport
-> IO
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> VersionE2E
-> PQSupport
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed),
      E2ERatchetParams 'RKSProposed a)
CR.generateRcvE2EParams TVar ChaChaDRG
g (VersionRangeE2E -> VersionE2E
forall v. VersionRange v -> Version v
maxVersion VersionRangeE2E
e2eEncryptVRange) PQSupport
pqSupport'
          AgentClient
-> NonEmpty SndQueue
-> RcvE2ERatchetParams 'X448
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueRatchetKeyMsgs AgentClient
c NonEmpty SndQueue
sqs RcvE2ERatchetParams 'X448
e2eParams
          AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
            Connection -> ConnId -> RatchetSyncState -> IO ()
setConnRatchetSync Connection
db ConnId
connId RatchetSyncState
RSStarted
            Connection
-> ConnId
-> PrivateKey 'X448
-> PrivateKey 'X448
-> Maybe (PrivRKEMParams 'RKSProposed)
-> IO ()
setRatchetX3dhKeys Connection
db ConnId
connId PrivateKey 'X448
pk1 PrivateKey 'X448
pk2 Maybe (PrivRKEMParams 'RKSProposed)
pKem
          let cData'' :: ConnData
cData'' = ConnData
cData' {ratchetSyncState = RSStarted} :: ConnData
              conn' :: Connection 'CDuplex
conn' = ConnData
-> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection 'CDuplex
forall rq sq.
ConnData
-> NonEmpty rq -> NonEmpty sq -> Connection' 'CDuplex rq sq
DuplexConnection ConnData
cData'' NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs
          AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection 'CDuplex
conn'
      | Bool
otherwise -> AgentErrorType -> AM ConnectionStats
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnectionStats)
-> AgentErrorType -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"synchronizeRatchet: not allowed"
    SomeConn
_ -> AgentErrorType -> AM ConnectionStats
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM ConnectionStats)
-> AgentErrorType -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"synchronizeRatchet: not duplex"

ackQueueMessage :: AgentClient -> RcvQueue -> SMP.MsgId -> AM (Maybe ATransmission)
ackQueueMessage :: AgentClient -> RcvQueue -> ConnId -> AM (Maybe ATransmission)
ackQueueMessage AgentClient
c rq :: RcvQueue
rq@RcvQueue {UserId
$sel:userId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> UserId
userId :: UserId
userId, ConnId
$sel:connId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> ConnId
connId :: ConnId
connId, SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server :: SMPServer
server} ConnId
srvMsgId = 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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId SMPServer
server AgentSMPServerStats -> TVar Int
ackAttempts
  ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Either AgentErrorType ())
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors (AgentClient
-> RcvQueue -> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
sendAck AgentClient
c RcvQueue
rq ConnId
srvMsgId) ExceptT AgentErrorType (ReaderT Env IO) (Either AgentErrorType ())
-> (Either AgentErrorType () -> AM (Maybe ATransmission))
-> AM (Maybe ATransmission)
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 ()
_ -> (AgentSMPServerStats -> TVar Int) -> AM (Maybe ATransmission)
sendMsgNtf AgentSMPServerStats -> TVar Int
ackMsgs
    Left (SMP String
_ ErrorType
SMP.NO_MSG) -> (AgentSMPServerStats -> TVar Int) -> AM (Maybe ATransmission)
sendMsgNtf AgentSMPServerStats -> TVar Int
ackNoMsgErrs
    Left AgentErrorType
e -> do
      Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AgentErrorType -> Bool
temporaryOrHostError AgentErrorType
e) (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
$ 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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId SMPServer
server AgentSMPServerStats -> TVar Int
ackOtherErrs
      AgentErrorType -> AM (Maybe ATransmission)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e
  where
    sendMsgNtf :: (AgentSMPServerStats -> TVar Int) -> AM (Maybe ATransmission)
sendMsgNtf AgentSMPServerStats -> TVar Int
stat = 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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId SMPServer
server AgentSMPServerStats -> TVar Int
stat
      ExceptT AgentErrorType (ReaderT Env IO) Bool
-> AM (Maybe ATransmission)
-> AM (Maybe ATransmission)
-> AM (Maybe ATransmission)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (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
$ AgentClient -> RcvQueue -> IO Bool
forall q. SomeRcvQueue q => AgentClient -> q -> IO Bool
hasGetLock AgentClient
c RcvQueue
rq)
        (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 -> RcvQueue -> STM ()
forall q. SomeRcvQueue q => AgentClient -> q -> STM ()
releaseGetLock AgentClient
c RcvQueue
rq
            Maybe InternalTs
brokerTs_ <- Either AgentErrorType InternalTs -> Maybe InternalTs
forall a b. Either a b -> Maybe b
eitherToMaybe (Either AgentErrorType InternalTs -> Maybe InternalTs)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Either AgentErrorType InternalTs)
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe InternalTs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT AgentErrorType (ReaderT Env IO) InternalTs
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Either AgentErrorType InternalTs)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors (AgentClient
-> (Connection -> IO (Either StoreError InternalTs))
-> ExceptT AgentErrorType (ReaderT Env IO) InternalTs
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError InternalTs))
 -> ExceptT AgentErrorType (ReaderT Env IO) InternalTs)
-> (Connection -> IO (Either StoreError InternalTs))
-> ExceptT AgentErrorType (ReaderT Env IO) InternalTs
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> ConnId -> IO (Either StoreError InternalTs)
getRcvMsgBrokerTs Connection
db ConnId
connId ConnId
srvMsgId)
            Maybe ATransmission -> AM (Maybe ATransmission)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ATransmission -> AM (Maybe ATransmission))
-> Maybe ATransmission -> AM (Maybe ATransmission)
forall a b. (a -> b) -> a -> b
$ ATransmission -> Maybe ATransmission
forall a. a -> Maybe a
Just (ConnId
"", ConnId
connId, 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
$ ConnId -> Maybe InternalTs -> AEvent 'AEConn
MSGNTF ConnId
srvMsgId Maybe InternalTs
brokerTs_))
        (Maybe ATransmission -> AM (Maybe ATransmission)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ATransmission
forall a. Maybe a
Nothing)

-- | Suspend SMP agent connection (OFF command) in Reader monad
suspendConnection' :: AgentClient -> NetworkRequestMode -> ConnId -> AM ()
suspendConnection' :: AgentClient
-> NetworkRequestMode
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
suspendConnection' AgentClient
c NetworkRequestMode
nm ConnId
connId = AgentClient
-> ConnId
-> Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
"suspendConnection" (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
$ do
  SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
  case Connection' d RcvQueue SndQueue
conn of
    DuplexConnection ConnData
_ NonEmpty RcvQueue
rqs NonEmpty SndQueue
_ -> (RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> NonEmpty RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
suspendQueue AgentClient
c NetworkRequestMode
nm) NonEmpty RcvQueue
rqs
    RcvConnection ConnData
_ RcvQueue
rq -> AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
suspendQueue AgentClient
c NetworkRequestMode
nm RcvQueue
rq
    ContactConnection ConnData
_ RcvQueue
rq -> AgentClient
-> NetworkRequestMode
-> RcvQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
suspendQueue AgentClient
c NetworkRequestMode
nm RcvQueue
rq
    SndConnection ConnData
_ SndQueue
_ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX String
"suspendConnection"
    NewConnection ConnData
_ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"suspendConnection"

-- | Delete SMP agent connection (DEL command) in Reader monad
-- unlike deleteConnectionAsync, this function does not mark connection as deleted in case of deletion failure
-- currently it is used only in tests
deleteConnection' :: AgentClient -> NetworkRequestMode -> ConnId -> AM ()
deleteConnection' :: AgentClient
-> NetworkRequestMode
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConnection' AgentClient
c NetworkRequestMode
nm ConnId
connId = ConnId
-> Map ConnId (Either AgentErrorType ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. ConnId -> Map ConnId (Either AgentErrorType a) -> AM a
toConnResult ConnId
connId (Map ConnId (Either AgentErrorType ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (Map ConnId (Either AgentErrorType ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AgentClient
-> NetworkRequestMode
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType ()))
deleteConnections' AgentClient
c NetworkRequestMode
nm [ConnId
Item [ConnId]
connId]
{-# INLINE deleteConnection' #-}

connRcvQueues :: Connection' d rq sq -> [rq]
connRcvQueues :: forall (d :: ConnType) rq sq. Connection' d rq sq -> [rq]
connRcvQueues = \case
  DuplexConnection ConnData
_ NonEmpty rq
rqs NonEmpty sq
_ -> NonEmpty rq -> [rq]
forall a. NonEmpty a -> [a]
L.toList NonEmpty rq
rqs
  RcvConnection ConnData
_ rq
rq -> [rq
Item [rq]
rq]
  ContactConnection ConnData
_ rq
rq -> [rq
Item [rq]
rq]
  SndConnection ConnData
_ sq
_ -> []
  NewConnection ConnData
_ -> []

-- Unlike deleteConnectionsAsync, this function does not mark connections as deleted in case of deletion failure.
deleteConnections' :: AgentClient -> NetworkRequestMode -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
deleteConnections' :: AgentClient
-> NetworkRequestMode
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType ()))
deleteConnections' = (Connection -> [ConnId] -> IO [Either StoreError SomeConn])
-> Bool
-> Bool
-> AgentClient
-> NetworkRequestMode
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType ()))
deleteConnections_ Connection -> [ConnId] -> IO [Either StoreError SomeConn]
getConns Bool
False Bool
False
{-# INLINE deleteConnections' #-}

deleteDeletedConns :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
deleteDeletedConns :: AgentClient
-> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
deleteDeletedConns AgentClient
c = (Connection -> [ConnId] -> IO [Either StoreError SomeConn])
-> Bool
-> Bool
-> AgentClient
-> NetworkRequestMode
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType ()))
deleteConnections_ Connection -> [ConnId] -> IO [Either StoreError SomeConn]
getDeletedConns Bool
True Bool
False AgentClient
c NetworkRequestMode
NRMBackground
{-# INLINE deleteDeletedConns #-}

deleteDeletedWaitingDeliveryConns :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
deleteDeletedWaitingDeliveryConns :: AgentClient
-> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
deleteDeletedWaitingDeliveryConns AgentClient
c = (Connection -> [ConnId] -> IO [Either StoreError SomeConn])
-> Bool
-> Bool
-> AgentClient
-> NetworkRequestMode
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType ()))
deleteConnections_ Connection -> [ConnId] -> IO [Either StoreError SomeConn]
getConns Bool
True Bool
True AgentClient
c NetworkRequestMode
NRMBackground
{-# INLINE deleteDeletedWaitingDeliveryConns #-}

prepareDeleteConnections_ ::
  (DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]) ->
  AgentClient ->
  Bool ->
  [ConnId] ->
  AM (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
prepareDeleteConnections_ :: (Connection -> [ConnId] -> IO [Either StoreError SomeConn])
-> AgentClient
-> Bool
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
prepareDeleteConnections_ Connection -> [ConnId] -> IO [Either StoreError SomeConn]
getConnections AgentClient
c Bool
waitDelivery [ConnId]
connIds = do
  [Either StoreError SomeConn]
conns <- AgentClient
-> (Connection -> IO [Either StoreError SomeConn])
-> AM [Either StoreError SomeConn]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> [ConnId] -> IO [Either StoreError SomeConn]
`getConnections` [ConnId]
connIds)
  let res :: (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
res@(Map ConnId (Either AgentErrorType ())
delRs, [RcvQueue]
rqs, [ConnId]
connIds') = ((ConnId, Either StoreError SomeConn)
 -> (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
 -> (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId]))
-> (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
-> [(ConnId, Either StoreError SomeConn)]
-> (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ConnId, Either StoreError SomeConn)
-> (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
-> (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
partitionResultsConns (Map ConnId (Either AgentErrorType ())
forall k a. Map k a
M.empty, [], []) ([(ConnId, Either StoreError SomeConn)]
 -> (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId]))
-> [(ConnId, Either StoreError SomeConn)]
-> (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
forall a b. (a -> b) -> a -> b
$ [ConnId]
-> [Either StoreError SomeConn]
-> [(ConnId, Either StoreError SomeConn)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ConnId]
connIds [Either StoreError SomeConn]
conns
  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 -> [ConnId] -> [RcvQueue] -> STM ()
forall q.
SomeRcvQueue q =>
AgentClient -> [ConnId] -> [q] -> STM ()
removeSubscriptions AgentClient
c [ConnId]
connIds' [RcvQueue]
rqs
  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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ Maybe (NonEmpty ConnId)
-> (NonEmpty ConnId -> ReaderT Env IO ()) -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([ConnId] -> Maybe (NonEmpty ConnId)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [ConnId]
connIds') NonEmpty ConnId -> ReaderT Env IO ()
unsubNtfConnIds
  -- ! delRs is not used to notify about the result in any of the calling functions,
  -- ! it is only used to check results count in deleteConnections_;
  -- ! if it was used to notify about the result, it might be necessary to differentiate
  -- ! between completed deletions of connections, and deletions delayed due to wait for delivery (see deleteConn)
  Maybe NominalDiffTime
deliveryTimeout <- if Bool
waitDelivery then (Env -> Maybe NominalDiffTime)
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NominalDiffTime)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just (NominalDiffTime -> Maybe NominalDiffTime)
-> (Env -> NominalDiffTime) -> Env -> Maybe NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentConfig -> NominalDiffTime
connDeleteDeliveryTimeout (AgentConfig -> NominalDiffTime)
-> (Env -> AgentConfig) -> Env -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config) else Maybe NominalDiffTime
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NominalDiffTime)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NominalDiffTime
forall a. Maybe a
Nothing
  Maybe (NonEmpty ConnId)
cIds_ <- ReaderT Env IO (Maybe (NonEmpty ConnId))
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Maybe (NonEmpty ConnId))
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 (Maybe (NonEmpty ConnId))
 -> ExceptT
      AgentErrorType (ReaderT Env IO) (Maybe (NonEmpty ConnId)))
-> ReaderT Env IO (Maybe (NonEmpty ConnId))
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Maybe (NonEmpty ConnId))
forall a b. (a -> b) -> a -> b
$ [ConnId] -> Maybe (NonEmpty ConnId)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ([ConnId] -> Maybe (NonEmpty ConnId))
-> ([Either AgentErrorType (Maybe ConnId)] -> [ConnId])
-> [Either AgentErrorType (Maybe ConnId)]
-> Maybe (NonEmpty ConnId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ConnId] -> [ConnId]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ConnId] -> [ConnId])
-> ([Either AgentErrorType (Maybe ConnId)] -> [Maybe ConnId])
-> [Either AgentErrorType (Maybe ConnId)]
-> [ConnId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either AgentErrorType (Maybe ConnId)] -> [Maybe ConnId]
forall a b. [Either a b] -> [b]
rights ([Either AgentErrorType (Maybe ConnId)] -> Maybe (NonEmpty ConnId))
-> ReaderT Env IO [Either AgentErrorType (Maybe ConnId)]
-> ReaderT Env IO (Maybe (NonEmpty ConnId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> (Connection -> [IO (Maybe ConnId)])
-> ReaderT Env IO [Either AgentErrorType (Maybe ConnId)]
forall (t :: * -> *) a.
Traversable t =>
AgentClient
-> (Connection -> t (IO a)) -> AM' (t (Either AgentErrorType a))
withStoreBatch' AgentClient
c (\Connection
db -> (ConnId -> IO (Maybe ConnId)) -> [ConnId] -> [IO (Maybe ConnId)]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> Maybe NominalDiffTime -> ConnId -> IO (Maybe ConnId)
deleteConn Connection
db Maybe NominalDiffTime
deliveryTimeout) (Map ConnId (Either AgentErrorType ()) -> [ConnId]
forall k a. Map k a -> [k]
M.keys Map ConnId (Either AgentErrorType ())
delRs))
  Maybe (NonEmpty ConnId)
-> (NonEmpty ConnId -> 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 (NonEmpty ConnId)
cIds_ ((NonEmpty ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (NonEmpty ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty ConnId
cIds -> ATransmission -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify (ConnId
"", ConnId
"", 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
$ NonEmpty ConnId -> AEvent 'AEConn
DEL_CONNS NonEmpty ConnId
cIds)
  (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
-> AM (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
res
  where
    partitionResultsConns ::
      (ConnId, Either StoreError SomeConn) ->
      (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId]) ->
      (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
    partitionResultsConns :: (ConnId, Either StoreError SomeConn)
-> (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
-> (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
partitionResultsConns (ConnId
connId, Either StoreError SomeConn
conn_) (Map ConnId (Either AgentErrorType ())
rs, [RcvQueue]
rqs, [ConnId]
cIds) = case Either StoreError SomeConn
conn_ of
      Left StoreError
e -> (ConnId
-> Either AgentErrorType ()
-> Map ConnId (Either AgentErrorType ())
-> Map ConnId (Either AgentErrorType ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ConnId
connId (AgentErrorType -> Either AgentErrorType ()
forall a b. a -> Either a b
Left (AgentErrorType -> Either AgentErrorType ())
-> AgentErrorType -> Either AgentErrorType ()
forall a b. (a -> b) -> a -> b
$ StoreError -> AgentErrorType
storeError StoreError
e) Map ConnId (Either AgentErrorType ())
rs, [RcvQueue]
rqs, [ConnId]
cIds)
      Right (SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn) -> case Connection' d RcvQueue SndQueue -> [RcvQueue]
forall (d :: ConnType) rq sq. Connection' d rq sq -> [rq]
connRcvQueues Connection' d RcvQueue SndQueue
conn of
        [] -> (ConnId
-> Either AgentErrorType ()
-> Map ConnId (Either AgentErrorType ())
-> Map ConnId (Either AgentErrorType ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ConnId
connId (() -> Either AgentErrorType ()
forall a b. b -> Either a b
Right ()) Map ConnId (Either AgentErrorType ())
rs, [RcvQueue]
rqs, [ConnId]
cIds)
        [RcvQueue]
rqs' -> (Map ConnId (Either AgentErrorType ())
rs, [RcvQueue]
rqs' [RcvQueue] -> [RcvQueue] -> [RcvQueue]
forall a. [a] -> [a] -> [a]
++ [RcvQueue]
rqs, ConnId
connId ConnId -> [ConnId] -> [ConnId]
forall a. a -> [a] -> [a]
: [ConnId]
cIds)
    unsubNtfConnIds :: NonEmpty ConnId -> AM' ()
    unsubNtfConnIds :: NonEmpty ConnId -> ReaderT Env IO ()
unsubNtfConnIds NonEmpty ConnId
connIds' = do
      NtfSupervisor
ns <- (Env -> NtfSupervisor) -> ReaderT Env IO NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
      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
$ TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
-> (NtfSupervisorCommand, NonEmpty ConnId) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (NtfSupervisor -> TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
ntfSubQ NtfSupervisor
ns) (NtfSupervisorCommand
NSCDeleteSub, NonEmpty ConnId
connIds')
    notify :: ATransmission -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify = STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ATransmission -> STM ())
-> ATransmission
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c)

deleteConnQueues :: AgentClient -> NetworkRequestMode -> Bool -> Bool -> [RcvQueue] -> AM' (Map ConnId (Either AgentErrorType ()))
deleteConnQueues :: AgentClient
-> NetworkRequestMode
-> Bool
-> Bool
-> [RcvQueue]
-> AM' (Map ConnId (Either AgentErrorType ()))
deleteConnQueues AgentClient
c NetworkRequestMode
nm Bool
waitDelivery Bool
ntf [RcvQueue]
rqs = do
  Map ConnId (Either AgentErrorType ())
rs <- [(RcvQueue, Either AgentErrorType ())]
-> Map ConnId (Either AgentErrorType ())
connResults ([(RcvQueue, Either AgentErrorType ())]
 -> Map ConnId (Either AgentErrorType ()))
-> ReaderT Env IO [(RcvQueue, Either AgentErrorType ())]
-> AM' (Map ConnId (Either AgentErrorType ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(RcvQueue, Either AgentErrorType ())]
-> ReaderT Env IO [(RcvQueue, Either AgentErrorType ())]
deleteQueueRecs ([(RcvQueue, Either AgentErrorType ())]
 -> ReaderT Env IO [(RcvQueue, Either AgentErrorType ())])
-> ReaderT Env IO [(RcvQueue, Either AgentErrorType ())]
-> ReaderT Env IO [(RcvQueue, Either AgentErrorType ())]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AgentClient
-> NetworkRequestMode
-> [RcvQueue]
-> ReaderT Env IO [(RcvQueue, Either AgentErrorType ())]
deleteQueues AgentClient
c NetworkRequestMode
nm [RcvQueue]
rqs)
  let connIds :: [ConnId]
connIds = Map ConnId (Either AgentErrorType ()) -> [ConnId]
forall k a. Map k a -> [k]
M.keys (Map ConnId (Either AgentErrorType ()) -> [ConnId])
-> Map ConnId (Either AgentErrorType ()) -> [ConnId]
forall a b. (a -> b) -> a -> b
$ (Either AgentErrorType () -> Bool)
-> Map ConnId (Either AgentErrorType ())
-> Map ConnId (Either AgentErrorType ())
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter Either AgentErrorType () -> Bool
forall a b. Either a b -> Bool
isRight Map ConnId (Either AgentErrorType ())
rs
  Maybe NominalDiffTime
deliveryTimeout <- if Bool
waitDelivery then (Env -> Maybe NominalDiffTime)
-> ReaderT Env IO (Maybe NominalDiffTime)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just (NominalDiffTime -> Maybe NominalDiffTime)
-> (Env -> NominalDiffTime) -> Env -> Maybe NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentConfig -> NominalDiffTime
connDeleteDeliveryTimeout (AgentConfig -> NominalDiffTime)
-> (Env -> AgentConfig) -> Env -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config) else Maybe NominalDiffTime -> ReaderT Env IO (Maybe NominalDiffTime)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NominalDiffTime
forall a. Maybe a
Nothing
  Maybe (NonEmpty ConnId)
cIds_ <- [ConnId] -> Maybe (NonEmpty ConnId)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ([ConnId] -> Maybe (NonEmpty ConnId))
-> ([Either AgentErrorType (Maybe ConnId)] -> [ConnId])
-> [Either AgentErrorType (Maybe ConnId)]
-> Maybe (NonEmpty ConnId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ConnId] -> [ConnId]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ConnId] -> [ConnId])
-> ([Either AgentErrorType (Maybe ConnId)] -> [Maybe ConnId])
-> [Either AgentErrorType (Maybe ConnId)]
-> [ConnId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either AgentErrorType (Maybe ConnId)] -> [Maybe ConnId]
forall a b. [Either a b] -> [b]
rights ([Either AgentErrorType (Maybe ConnId)] -> Maybe (NonEmpty ConnId))
-> ReaderT Env IO [Either AgentErrorType (Maybe ConnId)]
-> ReaderT Env IO (Maybe (NonEmpty ConnId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> (Connection -> [IO (Maybe ConnId)])
-> ReaderT Env IO [Either AgentErrorType (Maybe ConnId)]
forall (t :: * -> *) a.
Traversable t =>
AgentClient
-> (Connection -> t (IO a)) -> AM' (t (Either AgentErrorType a))
withStoreBatch' AgentClient
c (\Connection
db -> (ConnId -> IO (Maybe ConnId)) -> [ConnId] -> [IO (Maybe ConnId)]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> Maybe NominalDiffTime -> ConnId -> IO (Maybe ConnId)
deleteConn Connection
db Maybe NominalDiffTime
deliveryTimeout) [ConnId]
connIds)
  Maybe (NonEmpty ConnId)
-> (NonEmpty ConnId -> ReaderT Env IO ()) -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (NonEmpty ConnId)
cIds_ ((NonEmpty ConnId -> ReaderT Env IO ()) -> ReaderT Env IO ())
-> (NonEmpty ConnId -> ReaderT Env IO ()) -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty ConnId
cIds -> ATransmission -> ReaderT Env IO ()
notify (ConnId
"", ConnId
"", 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
$ NonEmpty ConnId -> AEvent 'AEConn
DEL_CONNS NonEmpty ConnId
cIds)
  Map ConnId (Either AgentErrorType ())
-> AM' (Map ConnId (Either AgentErrorType ()))
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map ConnId (Either AgentErrorType ())
rs
  where
    deleteQueueRecs :: [(RcvQueue, Either AgentErrorType ())] -> AM' [(RcvQueue, Either AgentErrorType ())]
    deleteQueueRecs :: [(RcvQueue, Either AgentErrorType ())]
-> ReaderT Env IO [(RcvQueue, Either AgentErrorType ())]
deleteQueueRecs [(RcvQueue, Either AgentErrorType ())]
rs = do
      Int
maxErrs <- (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
deleteErrorCount (AgentConfig -> Int) -> (Env -> AgentConfig) -> Env -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
      [((RcvQueue, Either AgentErrorType ()),
  Maybe (Maybe AgentErrorType))]
rs' <- [Either
   AgentErrorType
   ((RcvQueue, Either AgentErrorType ()),
    Maybe (Maybe AgentErrorType))]
-> [((RcvQueue, Either AgentErrorType ()),
     Maybe (Maybe AgentErrorType))]
forall a b. [Either a b] -> [b]
rights ([Either
    AgentErrorType
    ((RcvQueue, Either AgentErrorType ()),
     Maybe (Maybe AgentErrorType))]
 -> [((RcvQueue, Either AgentErrorType ()),
      Maybe (Maybe AgentErrorType))])
-> ReaderT
     Env
     IO
     [Either
        AgentErrorType
        ((RcvQueue, Either AgentErrorType ()),
         Maybe (Maybe AgentErrorType))]
-> ReaderT
     Env
     IO
     [((RcvQueue, Either AgentErrorType ()),
       Maybe (Maybe AgentErrorType))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> (Connection
    -> [IO
          ((RcvQueue, Either AgentErrorType ()),
           Maybe (Maybe AgentErrorType))])
-> ReaderT
     Env
     IO
     [Either
        AgentErrorType
        ((RcvQueue, Either AgentErrorType ()),
         Maybe (Maybe AgentErrorType))]
forall (t :: * -> *) a.
Traversable t =>
AgentClient
-> (Connection -> t (IO a)) -> AM' (t (Either AgentErrorType a))
withStoreBatch' AgentClient
c (\Connection
db -> ((RcvQueue, Either AgentErrorType ())
 -> IO
      ((RcvQueue, Either AgentErrorType ()),
       Maybe (Maybe AgentErrorType)))
-> [(RcvQueue, Either AgentErrorType ())]
-> [IO
      ((RcvQueue, Either AgentErrorType ()),
       Maybe (Maybe AgentErrorType))]
forall a b. (a -> b) -> [a] -> [b]
map (Connection
-> Int
-> (RcvQueue, Either AgentErrorType ())
-> IO
     ((RcvQueue, Either AgentErrorType ()),
      Maybe (Maybe AgentErrorType))
deleteQueueRec Connection
db Int
maxErrs) [(RcvQueue, Either AgentErrorType ())]
rs)
      let delQ :: ((q, b), f a) -> f (ConnId, SMPServer, QueueId, a)
delQ ((q
rq, b
_), f a
err_) = (q -> ConnId
forall q. SMPQueueRec q => q -> ConnId
qConnId q
rq,q -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer q
rq,q -> QueueId
forall q. SMPQueue q => q -> QueueId
queueId q
rq,) (a -> (ConnId, SMPServer, QueueId, a))
-> f a -> f (ConnId, SMPServer, QueueId, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
err_
          delQs_ :: Maybe (NonEmpty (ConnId, SMPServer, QueueId, Maybe AgentErrorType))
delQs_ = [(ConnId, SMPServer, QueueId, Maybe AgentErrorType)]
-> Maybe
     (NonEmpty (ConnId, SMPServer, QueueId, Maybe AgentErrorType))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ([(ConnId, SMPServer, QueueId, Maybe AgentErrorType)]
 -> Maybe
      (NonEmpty (ConnId, SMPServer, QueueId, Maybe AgentErrorType)))
-> [(ConnId, SMPServer, QueueId, Maybe AgentErrorType)]
-> Maybe
     (NonEmpty (ConnId, SMPServer, QueueId, Maybe AgentErrorType))
forall a b. (a -> b) -> a -> b
$ (((RcvQueue, Either AgentErrorType ()),
  Maybe (Maybe AgentErrorType))
 -> Maybe (ConnId, SMPServer, QueueId, Maybe AgentErrorType))
-> [((RcvQueue, Either AgentErrorType ()),
     Maybe (Maybe AgentErrorType))]
-> [(ConnId, SMPServer, QueueId, Maybe AgentErrorType)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((RcvQueue, Either AgentErrorType ()),
 Maybe (Maybe AgentErrorType))
-> Maybe (ConnId, SMPServer, QueueId, Maybe AgentErrorType)
forall {f :: * -> *} {q} {b} {a}.
(Functor f, SMPQueueRec q) =>
((q, b), f a) -> f (ConnId, SMPServer, QueueId, a)
delQ [((RcvQueue, Either AgentErrorType ()),
  Maybe (Maybe AgentErrorType))]
rs'
      Maybe (NonEmpty (ConnId, SMPServer, QueueId, Maybe AgentErrorType))
-> (NonEmpty (ConnId, SMPServer, QueueId, Maybe AgentErrorType)
    -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (NonEmpty (ConnId, SMPServer, QueueId, Maybe AgentErrorType))
delQs_ ((NonEmpty (ConnId, SMPServer, QueueId, Maybe AgentErrorType)
  -> ReaderT Env IO ())
 -> ReaderT Env IO ())
-> (NonEmpty (ConnId, SMPServer, QueueId, Maybe AgentErrorType)
    -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty (ConnId, SMPServer, QueueId, Maybe AgentErrorType)
delQs -> ATransmission -> ReaderT Env IO ()
notify (ConnId
"", ConnId
"", 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
$ NonEmpty (ConnId, SMPServer, QueueId, Maybe AgentErrorType)
-> AEvent 'AEConn
DEL_RCVQS NonEmpty (ConnId, SMPServer, QueueId, Maybe AgentErrorType)
delQs)
      [(RcvQueue, Either AgentErrorType ())]
-> ReaderT Env IO [(RcvQueue, Either AgentErrorType ())]
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(RcvQueue, Either AgentErrorType ())]
 -> ReaderT Env IO [(RcvQueue, Either AgentErrorType ())])
-> [(RcvQueue, Either AgentErrorType ())]
-> ReaderT Env IO [(RcvQueue, Either AgentErrorType ())]
forall a b. (a -> b) -> a -> b
$ (((RcvQueue, Either AgentErrorType ()),
  Maybe (Maybe AgentErrorType))
 -> (RcvQueue, Either AgentErrorType ()))
-> [((RcvQueue, Either AgentErrorType ()),
     Maybe (Maybe AgentErrorType))]
-> [(RcvQueue, Either AgentErrorType ())]
forall a b. (a -> b) -> [a] -> [b]
map ((RcvQueue, Either AgentErrorType ()),
 Maybe (Maybe AgentErrorType))
-> (RcvQueue, Either AgentErrorType ())
forall a b. (a, b) -> a
fst [((RcvQueue, Either AgentErrorType ()),
  Maybe (Maybe AgentErrorType))]
rs'
      where
        deleteQueueRec ::
          DB.Connection ->
          Int ->
          (RcvQueue, Either AgentErrorType ()) ->
          IO ((RcvQueue, Either AgentErrorType ()), Maybe (Maybe AgentErrorType)) -- Nothing - no event, Just Nothing - no error
        deleteQueueRec :: Connection
-> Int
-> (RcvQueue, Either AgentErrorType ())
-> IO
     ((RcvQueue, Either AgentErrorType ()),
      Maybe (Maybe AgentErrorType))
deleteQueueRec Connection
db Int
maxErrs (rq :: RcvQueue
rq@RcvQueue {UserId
$sel:userId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> UserId
userId :: UserId
userId, SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server :: SMPServer
server}, Either AgentErrorType ()
r) = case Either AgentErrorType ()
r of
          Right ()
_ -> Connection -> RcvQueue -> IO ()
deleteConnRcvQueue Connection
db RcvQueue
rq IO ()
-> ((RcvQueue, Either AgentErrorType ()),
    Maybe (Maybe AgentErrorType))
-> IO
     ((RcvQueue, Either AgentErrorType ()),
      Maybe (Maybe AgentErrorType))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ((RcvQueue
rq, Either AgentErrorType ()
r), Maybe AgentErrorType -> Maybe (Maybe AgentErrorType)
forall a. a -> Maybe a
Just Maybe AgentErrorType
forall a. Maybe a
Nothing)
          Left AgentErrorType
e
            | AgentErrorType -> Bool
temporaryOrHostError AgentErrorType
e Bool -> Bool -> Bool
&& RcvQueue -> Int
forall (q :: DBStored). StoredRcvQueue q -> Int
deleteErrors RcvQueue
rq Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxErrs -> Connection -> RcvQueue -> IO ()
incRcvDeleteErrors Connection
db RcvQueue
rq IO ()
-> ((RcvQueue, Either AgentErrorType ()),
    Maybe (Maybe AgentErrorType))
-> IO
     ((RcvQueue, Either AgentErrorType ()),
      Maybe (Maybe AgentErrorType))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ((RcvQueue
rq, Either AgentErrorType ()
r), Maybe (Maybe AgentErrorType)
forall a. Maybe a
Nothing)
            | Bool
otherwise -> do
                Connection -> RcvQueue -> IO ()
deleteConnRcvQueue Connection
db RcvQueue
rq
                -- attempts and successes are counted in deleteQueues function
                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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId SMPServer
server AgentSMPServerStats -> TVar Int
connDeleted
                ((RcvQueue, Either AgentErrorType ()),
 Maybe (Maybe AgentErrorType))
-> IO
     ((RcvQueue, Either AgentErrorType ()),
      Maybe (Maybe AgentErrorType))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((RcvQueue
rq, () -> Either AgentErrorType ()
forall a b. b -> Either a b
Right ()), Maybe AgentErrorType -> Maybe (Maybe AgentErrorType)
forall a. a -> Maybe a
Just (AgentErrorType -> Maybe AgentErrorType
forall a. a -> Maybe a
Just AgentErrorType
e))
    notify :: ATransmission -> ReaderT Env IO ()
notify = Bool -> ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ntf (ReaderT Env IO () -> ReaderT Env IO ())
-> (ATransmission -> ReaderT Env IO ())
-> ATransmission
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Env IO ())
-> (ATransmission -> STM ()) -> ATransmission -> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c)
    connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ())
    connResults :: [(RcvQueue, Either AgentErrorType ())]
-> Map ConnId (Either AgentErrorType ())
connResults = ((QueueStatus, Either AgentErrorType ())
 -> Either AgentErrorType ())
-> Map ConnId (QueueStatus, Either AgentErrorType ())
-> Map ConnId (Either AgentErrorType ())
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (QueueStatus, Either AgentErrorType ()) -> Either AgentErrorType ()
forall a b. (a, b) -> b
snd (Map ConnId (QueueStatus, Either AgentErrorType ())
 -> Map ConnId (Either AgentErrorType ()))
-> ([(RcvQueue, Either AgentErrorType ())]
    -> Map ConnId (QueueStatus, Either AgentErrorType ()))
-> [(RcvQueue, Either AgentErrorType ())]
-> Map ConnId (Either AgentErrorType ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ConnId (QueueStatus, Either AgentErrorType ())
 -> (RcvQueue, Either AgentErrorType ())
 -> Map ConnId (QueueStatus, Either AgentErrorType ()))
-> Map ConnId (QueueStatus, Either AgentErrorType ())
-> [(RcvQueue, Either AgentErrorType ())]
-> Map ConnId (QueueStatus, Either AgentErrorType ())
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map ConnId (QueueStatus, Either AgentErrorType ())
-> (RcvQueue, Either AgentErrorType ())
-> Map ConnId (QueueStatus, Either AgentErrorType ())
addResult Map ConnId (QueueStatus, Either AgentErrorType ())
forall k a. Map k a
M.empty
      where
        -- collects results by connection ID
        addResult :: Map ConnId QDelResult -> (RcvQueue, Either AgentErrorType ()) -> Map ConnId QDelResult
        addResult :: Map ConnId (QueueStatus, Either AgentErrorType ())
-> (RcvQueue, Either AgentErrorType ())
-> Map ConnId (QueueStatus, Either AgentErrorType ())
addResult Map ConnId (QueueStatus, Either AgentErrorType ())
rs (RcvQueue {ConnId
$sel:connId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> ConnId
connId :: ConnId
connId, QueueStatus
$sel:status:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueStatus
status :: QueueStatus
status}, Either AgentErrorType ()
r) = (Maybe (QueueStatus, Either AgentErrorType ())
 -> Maybe (QueueStatus, Either AgentErrorType ()))
-> ConnId
-> Map ConnId (QueueStatus, Either AgentErrorType ())
-> Map ConnId (QueueStatus, Either AgentErrorType ())
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter ((QueueStatus, Either AgentErrorType ())
-> Maybe (QueueStatus, Either AgentErrorType ())
-> Maybe (QueueStatus, Either AgentErrorType ())
combineRes (QueueStatus
status, Either AgentErrorType ()
r)) ConnId
connId Map ConnId (QueueStatus, Either AgentErrorType ())
rs
        -- combines two results for one connection, by prioritizing errors in Active queues
        combineRes :: QDelResult -> Maybe QDelResult -> Maybe QDelResult
        combineRes :: (QueueStatus, Either AgentErrorType ())
-> Maybe (QueueStatus, Either AgentErrorType ())
-> Maybe (QueueStatus, Either AgentErrorType ())
combineRes (QueueStatus, Either AgentErrorType ())
r' (Just (QueueStatus, Either AgentErrorType ())
r) = (QueueStatus, Either AgentErrorType ())
-> Maybe (QueueStatus, Either AgentErrorType ())
forall a. a -> Maybe a
Just ((QueueStatus, Either AgentErrorType ())
 -> Maybe (QueueStatus, Either AgentErrorType ()))
-> (QueueStatus, Either AgentErrorType ())
-> Maybe (QueueStatus, Either AgentErrorType ())
forall a b. (a -> b) -> a -> b
$ if (QueueStatus, Either AgentErrorType ()) -> Int
order (QueueStatus, Either AgentErrorType ())
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= (QueueStatus, Either AgentErrorType ()) -> Int
order (QueueStatus, Either AgentErrorType ())
r' then (QueueStatus, Either AgentErrorType ())
r else (QueueStatus, Either AgentErrorType ())
r'
        combineRes (QueueStatus, Either AgentErrorType ())
r' Maybe (QueueStatus, Either AgentErrorType ())
_ = (QueueStatus, Either AgentErrorType ())
-> Maybe (QueueStatus, Either AgentErrorType ())
forall a. a -> Maybe a
Just (QueueStatus, Either AgentErrorType ())
r'
        order :: QDelResult -> Int
        order :: (QueueStatus, Either AgentErrorType ()) -> Int
order (QueueStatus
Active, Left AgentErrorType
_) = Int
1
        order (QueueStatus
_, Left AgentErrorType
_) = Int
2
        order (QueueStatus, Either AgentErrorType ())
_ = Int
3

deleteConnections_ ::
  (DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]) ->
  Bool ->
  Bool ->
  AgentClient ->
  NetworkRequestMode ->
  [ConnId] ->
  AM (Map ConnId (Either AgentErrorType ()))
deleteConnections_ :: (Connection -> [ConnId] -> IO [Either StoreError SomeConn])
-> Bool
-> Bool
-> AgentClient
-> NetworkRequestMode
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType ()))
deleteConnections_ Connection -> [ConnId] -> IO [Either StoreError SomeConn]
_ Bool
_ Bool
_ AgentClient
_ NetworkRequestMode
_ [] = Map ConnId (Either AgentErrorType ())
-> AM (Map ConnId (Either AgentErrorType ()))
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map ConnId (Either AgentErrorType ())
forall k a. Map k a
M.empty
deleteConnections_ Connection -> [ConnId] -> IO [Either StoreError SomeConn]
getConnections Bool
ntf Bool
waitDelivery AgentClient
c NetworkRequestMode
nm [ConnId]
connIds = do
  (Map ConnId (Either AgentErrorType ())
rs, [RcvQueue]
rqs, [ConnId]
_) <- (Connection -> [ConnId] -> IO [Either StoreError SomeConn])
-> AgentClient
-> Bool
-> [ConnId]
-> AM (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
prepareDeleteConnections_ Connection -> [ConnId] -> IO [Either StoreError SomeConn]
getConnections AgentClient
c Bool
waitDelivery [ConnId]
connIds
  Map ConnId (Either AgentErrorType ())
rcvRs <- AM' (Map ConnId (Either AgentErrorType ()))
-> AM (Map ConnId (Either AgentErrorType ()))
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 (AM' (Map ConnId (Either AgentErrorType ()))
 -> AM (Map ConnId (Either AgentErrorType ())))
-> AM' (Map ConnId (Either AgentErrorType ()))
-> AM (Map ConnId (Either AgentErrorType ()))
forall a b. (a -> b) -> a -> b
$ AgentClient
-> NetworkRequestMode
-> Bool
-> Bool
-> [RcvQueue]
-> AM' (Map ConnId (Either AgentErrorType ()))
deleteConnQueues AgentClient
c NetworkRequestMode
nm Bool
waitDelivery Bool
ntf [RcvQueue]
rqs
  let rs' :: Map ConnId (Either AgentErrorType ())
rs' = Map ConnId (Either AgentErrorType ())
-> Map ConnId (Either AgentErrorType ())
-> Map ConnId (Either AgentErrorType ())
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map ConnId (Either AgentErrorType ())
rs Map ConnId (Either AgentErrorType ())
rcvRs
  Map ConnId (Either AgentErrorType ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyResultError Map ConnId (Either AgentErrorType ())
rs'
  Map ConnId (Either AgentErrorType ())
-> AM (Map ConnId (Either AgentErrorType ()))
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map ConnId (Either AgentErrorType ())
rs'
  where
    notifyResultError :: Map ConnId (Either AgentErrorType ()) -> AM ()
    notifyResultError :: Map ConnId (Either AgentErrorType ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyResultError Map ConnId (Either AgentErrorType ())
rs = do
      let actual :: Int
actual = Map ConnId (Either AgentErrorType ()) -> Int
forall k a. Map k a -> Int
M.size Map ConnId (Either AgentErrorType ())
rs
          expected :: Int
expected = [ConnId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConnId]
connIds
      Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
actual Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
expected) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> STM ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
$
        TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue ATransmission
subQ AgentClient
c) (ConnId
"", ConnId
"", 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
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"deleteConnections result size: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
actual String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", expected " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
expected)

getConnectionServers' :: AgentClient -> ConnId -> AM ConnectionStats
getConnectionServers' :: AgentClient -> ConnId -> AM ConnectionStats
getConnectionServers' AgentClient
c ConnId
connId = do
  SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
  AgentClient
-> Connection' d RcvQueue SndQueue -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection' d RcvQueue SndQueue
conn

getConnectionRatchetAdHash' :: AgentClient -> ConnId -> AM ByteString
getConnectionRatchetAdHash' :: AgentClient -> ConnId -> AM ConnId
getConnectionRatchetAdHash' AgentClient
c ConnId
connId = do
  CR.Ratchet {$sel:rcAD:Ratchet :: forall (a :: Algorithm). Ratchet a -> Str
rcAD = Str ConnId
rcAD} <- AgentClient
-> (Connection -> IO (Either StoreError RatchetX448))
-> AM RatchetX448
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError RatchetX448)
`getRatchet` ConnId
connId)
  ConnId -> AM ConnId
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnId -> AM ConnId) -> ConnId -> AM ConnId
forall a b. (a -> b) -> a -> b
$ ConnId -> ConnId
C.sha256Hash ConnId
rcAD

connectionStats :: AgentClient -> Connection c -> AM ConnectionStats
connectionStats :: forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c = \case
  RcvConnection ConnData
cData RcvQueue
rq -> do
    [RcvQueueInfo]
rcvQueuesInfo <- (RcvQueueInfo -> [RcvQueueInfo] -> [RcvQueueInfo]
forall a. a -> [a] -> [a]
: []) (RcvQueueInfo -> [RcvQueueInfo])
-> ExceptT AgentErrorType (ReaderT Env IO) RcvQueueInfo
-> ExceptT AgentErrorType (ReaderT Env IO) [RcvQueueInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) RcvQueueInfo
rcvQueueInfo RcvQueue
rq
    ConnectionStats -> AM ConnectionStats
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnData -> ConnectionStats
stats ConnData
cData) {rcvQueuesInfo, subStatus = connSubStatus rcvQueuesInfo}
  SndConnection ConnData
cData SndQueue
sq -> do
    ConnectionStats -> AM ConnectionStats
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnData -> ConnectionStats
stats ConnData
cData) {sndQueuesInfo = [sndQueueInfo sq]}
  DuplexConnection ConnData
cData NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs -> do
    [RcvQueueInfo]
rcvQueuesInfo <- (RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) RcvQueueInfo)
-> [RcvQueue]
-> ExceptT AgentErrorType (ReaderT Env IO) [RcvQueueInfo]
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 RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) RcvQueueInfo
rcvQueueInfo (NonEmpty RcvQueue -> [RcvQueue]
forall a. NonEmpty a -> [a]
L.toList NonEmpty RcvQueue
rqs)
    ConnectionStats -> AM ConnectionStats
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (ConnData -> ConnectionStats
stats ConnData
cData)
        { rcvQueuesInfo,
          sndQueuesInfo = map sndQueueInfo $ L.toList sqs,
          subStatus = connSubStatus rcvQueuesInfo
        }
  ContactConnection ConnData
cData RcvQueue
rq -> do
    [RcvQueueInfo]
rcvQueuesInfo <- (RcvQueueInfo -> [RcvQueueInfo] -> [RcvQueueInfo]
forall a. a -> [a] -> [a]
: []) (RcvQueueInfo -> [RcvQueueInfo])
-> ExceptT AgentErrorType (ReaderT Env IO) RcvQueueInfo
-> ExceptT AgentErrorType (ReaderT Env IO) [RcvQueueInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) RcvQueueInfo
rcvQueueInfo RcvQueue
rq
    ConnectionStats -> AM ConnectionStats
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnData -> ConnectionStats
stats ConnData
cData) {rcvQueuesInfo, subStatus = connSubStatus rcvQueuesInfo}
  NewConnection ConnData
cData ->
    ConnectionStats -> AM ConnectionStats
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectionStats -> AM ConnectionStats)
-> ConnectionStats -> AM ConnectionStats
forall a b. (a -> b) -> a -> b
$ ConnData -> ConnectionStats
stats ConnData
cData
  where
    stats :: ConnData -> ConnectionStats
    stats :: ConnData -> ConnectionStats
stats ConnData {VersionSMPA
$sel:connAgentVersion:ConnData :: ConnData -> VersionSMPA
connAgentVersion :: VersionSMPA
connAgentVersion, RatchetSyncState
$sel:ratchetSyncState:ConnData :: ConnData -> RatchetSyncState
ratchetSyncState :: RatchetSyncState
ratchetSyncState} =
      ConnectionStats
        { VersionSMPA
connAgentVersion :: VersionSMPA
$sel:connAgentVersion:ConnectionStats :: VersionSMPA
connAgentVersion,
          $sel:rcvQueuesInfo:ConnectionStats :: [RcvQueueInfo]
rcvQueuesInfo = [],
          $sel:sndQueuesInfo:ConnectionStats :: [SndQueueInfo]
sndQueuesInfo = [],
          RatchetSyncState
ratchetSyncState :: RatchetSyncState
$sel:ratchetSyncState:ConnectionStats :: RatchetSyncState
ratchetSyncState,
          $sel:ratchetSyncSupported:ConnectionStats :: Bool
ratchetSyncSupported = VersionSMPA
connAgentVersion VersionSMPA -> VersionSMPA -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMPA
ratchetSyncSMPAgentVersion,
          $sel:subStatus:ConnectionStats :: Maybe SubscriptionStatus
subStatus = Maybe SubscriptionStatus
forall a. Maybe a
Nothing
        }
    rcvQueueInfo :: RcvQueue -> AM RcvQueueInfo
    rcvQueueInfo :: RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) RcvQueueInfo
rcvQueueInfo rq :: RcvQueue
rq@RcvQueue {SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server :: SMPServer
server, QueueStatus
$sel:status:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueStatus
status :: QueueStatus
status, Maybe RcvSwitchStatus
rcvSwchStatus :: Maybe RcvSwitchStatus
$sel:rcvSwchStatus:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Maybe RcvSwitchStatus
rcvSwchStatus} = do
      SubscriptionStatus
subStatus <- STM SubscriptionStatus
-> ExceptT AgentErrorType (ReaderT Env IO) SubscriptionStatus
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM SubscriptionStatus
checkQueueSubStatus
      RcvQueueInfo
-> ExceptT AgentErrorType (ReaderT Env IO) RcvQueueInfo
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RcvQueueInfo
 -> ExceptT AgentErrorType (ReaderT Env IO) RcvQueueInfo)
-> RcvQueueInfo
-> ExceptT AgentErrorType (ReaderT Env IO) RcvQueueInfo
forall a b. (a -> b) -> a -> b
$ RcvQueueInfo {$sel:rcvServer:RcvQueueInfo :: SMPServer
rcvServer = SMPServer
server, QueueStatus
status :: QueueStatus
$sel:status:RcvQueueInfo :: QueueStatus
status, $sel:rcvSwitchStatus:RcvQueueInfo :: Maybe RcvSwitchStatus
rcvSwitchStatus = Maybe RcvSwitchStatus
rcvSwchStatus, $sel:canAbortSwitch:RcvQueueInfo :: Bool
canAbortSwitch = RcvQueue -> Bool
canAbortRcvSwitch RcvQueue
rq, SubscriptionStatus
subStatus :: SubscriptionStatus
$sel:subStatus:RcvQueueInfo :: SubscriptionStatus
subStatus}
      where
        checkQueueSubStatus :: STM SubscriptionStatus
        checkQueueSubStatus :: STM SubscriptionStatus
checkQueueSubStatus =
          STM Bool
-> STM SubscriptionStatus
-> STM SubscriptionStatus
-> STM SubscriptionStatus
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (AgentClient -> RcvQueue -> STM Bool
forall q. SomeRcvQueue q => AgentClient -> q -> STM Bool
hasActiveSubscription AgentClient
c RcvQueue
rq) (SubscriptionStatus -> STM SubscriptionStatus
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubscriptionStatus
SSActive) (STM SubscriptionStatus -> STM SubscriptionStatus)
-> STM SubscriptionStatus -> STM SubscriptionStatus
forall a b. (a -> b) -> a -> b
$
            STM Bool
-> STM SubscriptionStatus
-> STM SubscriptionStatus
-> STM SubscriptionStatus
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (AgentClient -> RcvQueue -> STM Bool
forall q. SomeRcvQueue q => AgentClient -> q -> STM Bool
hasPendingSubscription AgentClient
c RcvQueue
rq) (SubscriptionStatus -> STM SubscriptionStatus
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubscriptionStatus
SSPending) (STM SubscriptionStatus -> STM SubscriptionStatus)
-> STM SubscriptionStatus -> STM SubscriptionStatus
forall a b. (a -> b) -> a -> b
$
              SubscriptionStatus
-> (ProtocolClientError ErrorType -> SubscriptionStatus)
-> Maybe (ProtocolClientError ErrorType)
-> SubscriptionStatus
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SubscriptionStatus
SSNoSub (String -> SubscriptionStatus
SSRemoved (String -> SubscriptionStatus)
-> (ProtocolClientError ErrorType -> String)
-> ProtocolClientError ErrorType
-> SubscriptionStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolClientError ErrorType -> String
forall a. Show a => a -> String
show) (Maybe (ProtocolClientError ErrorType) -> SubscriptionStatus)
-> STM (Maybe (ProtocolClientError ErrorType))
-> STM SubscriptionStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> RcvQueue -> STM (Maybe (ProtocolClientError ErrorType))
forall q.
SomeRcvQueue q =>
AgentClient -> q -> STM (Maybe (ProtocolClientError ErrorType))
hasRemovedSubscription AgentClient
c RcvQueue
rq
    sndQueueInfo :: SndQueue -> SndQueueInfo
    sndQueueInfo :: SndQueue -> SndQueueInfo
sndQueueInfo SndQueue {SMPServer
$sel:server:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> SMPServer
server :: SMPServer
server, QueueStatus
$sel:status:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> QueueStatus
status :: QueueStatus
status, Maybe SndSwitchStatus
sndSwchStatus :: Maybe SndSwitchStatus
$sel:sndSwchStatus:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> Maybe SndSwitchStatus
sndSwchStatus} =
      SndQueueInfo {$sel:sndServer:SndQueueInfo :: SMPServer
sndServer = SMPServer
server, QueueStatus
status :: QueueStatus
$sel:status:SndQueueInfo :: QueueStatus
status, $sel:sndSwitchStatus:SndQueueInfo :: Maybe SndSwitchStatus
sndSwitchStatus = Maybe SndSwitchStatus
sndSwchStatus}
    connSubStatus :: [RcvQueueInfo] -> Maybe SubscriptionStatus
    connSubStatus :: [RcvQueueInfo] -> Maybe SubscriptionStatus
connSubStatus [RcvQueueInfo]
rqs =
      let isActive :: RcvQueueInfo -> Bool
isActive RcvQueueInfo {QueueStatus
$sel:status:RcvQueueInfo :: RcvQueueInfo -> QueueStatus
status :: QueueStatus
status} = QueueStatus
status QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
Active
          subStatus' :: RcvQueueInfo -> SubscriptionStatus
subStatus' RcvQueueInfo {SubscriptionStatus
$sel:subStatus:RcvQueueInfo :: RcvQueueInfo -> SubscriptionStatus
subStatus :: SubscriptionStatus
subStatus} = SubscriptionStatus
subStatus
       in NonEmpty SubscriptionStatus -> SubscriptionStatus
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (NonEmpty SubscriptionStatus -> SubscriptionStatus)
-> (NonEmpty RcvQueueInfo -> NonEmpty SubscriptionStatus)
-> NonEmpty RcvQueueInfo
-> SubscriptionStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RcvQueueInfo -> SubscriptionStatus)
-> NonEmpty RcvQueueInfo -> NonEmpty SubscriptionStatus
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map RcvQueueInfo -> SubscriptionStatus
subStatus' (NonEmpty RcvQueueInfo -> SubscriptionStatus)
-> Maybe (NonEmpty RcvQueueInfo) -> Maybe SubscriptionStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([RcvQueueInfo] -> Maybe (NonEmpty RcvQueueInfo)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ((RcvQueueInfo -> Bool) -> [RcvQueueInfo] -> [RcvQueueInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter RcvQueueInfo -> Bool
isActive [RcvQueueInfo]
rqs) Maybe (NonEmpty RcvQueueInfo)
-> Maybe (NonEmpty RcvQueueInfo) -> Maybe (NonEmpty RcvQueueInfo)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [RcvQueueInfo] -> Maybe (NonEmpty RcvQueueInfo)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [RcvQueueInfo]
rqs)

-- | Change servers to be used for creating new queues.
-- This function will set all servers as enabled in case all passed servers are disabled.
setProtocolServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> NonEmpty (ServerCfg p) -> IO ()
setProtocolServers :: forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
AgentClient -> UserId -> NonEmpty (ServerCfg p) -> IO ()
setProtocolServers AgentClient
c UserId
userId NonEmpty (ServerCfg p)
srvs = do
  Text -> NonEmpty (ServerCfg p) -> IO ()
forall (p :: ProtocolType). Text -> NonEmpty (ServerCfg p) -> IO ()
checkUserServers Text
"setProtocolServers" NonEmpty (ServerCfg p)
srvs
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ UserId -> UserServers p -> TMap UserId (UserServers p) -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert UserId
userId (NonEmpty (ServerCfg p) -> UserServers p
forall (p :: ProtocolType). NonEmpty (ServerCfg p) -> UserServers p
mkUserServers NonEmpty (ServerCfg p)
srvs) (AgentClient -> TMap UserId (UserServers p)
forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
AgentClient -> TMap UserId (UserServers p)
userServers AgentClient
c)

checkUserServers :: Text -> NonEmpty (ServerCfg p) -> IO ()
checkUserServers :: forall (p :: ProtocolType). Text -> NonEmpty (ServerCfg p) -> IO ()
checkUserServers Text
name NonEmpty (ServerCfg p)
srvs =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((ServerCfg p -> Bool) -> NonEmpty (ServerCfg p) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ServerCfg {Bool
enabled :: Bool
$sel:enabled:ServerCfg :: forall (p :: ProtocolType). ServerCfg p -> Bool
enabled} -> Bool
enabled) NonEmpty (ServerCfg p)
srvs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": all passed servers are disabled, using all servers.")

registerNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> NotificationsMode -> AM NtfTknStatus
registerNtfToken' :: AgentClient
-> NetworkRequestMode
-> DeviceToken
-> NotificationsMode
-> AM NtfTknStatus
registerNtfToken' AgentClient
c NetworkRequestMode
nm DeviceToken
suppliedDeviceToken NotificationsMode
suppliedNtfMode =
  AgentClient
-> (Connection -> IO (Maybe NtfToken))
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO (Maybe NtfToken)
getSavedNtfToken ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
-> (Maybe NtfToken -> AM NtfTknStatus) -> AM NtfTknStatus
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 tkn :: NtfToken
tkn@NtfToken {$sel:deviceToken:NtfToken :: NtfToken -> DeviceToken
deviceToken = DeviceToken
savedDeviceToken, Maybe QueueId
ntfTokenId :: Maybe QueueId
$sel:ntfTokenId:NtfToken :: NtfToken -> Maybe QueueId
ntfTokenId, NtfTknStatus
ntfTknStatus :: NtfTknStatus
$sel:ntfTknStatus:NtfToken :: NtfToken -> NtfTknStatus
ntfTknStatus, Maybe NtfTknAction
ntfTknAction :: Maybe NtfTknAction
$sel:ntfTknAction:NtfToken :: NtfToken -> Maybe NtfTknAction
ntfTknAction, $sel:ntfMode:NtfToken :: NtfToken -> NotificationsMode
ntfMode = NotificationsMode
savedNtfMode} -> do
      NtfTknStatus
status <- case (Maybe QueueId
ntfTokenId, Maybe NtfTknAction
ntfTknAction) of
        (Maybe QueueId
Nothing, Just NtfTknAction
NTARegister) -> do
          Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DeviceToken
savedDeviceToken DeviceToken -> DeviceToken -> Bool
forall a. Eq a => a -> a -> Bool
/= DeviceToken
suppliedDeviceToken) (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
$ AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> NtfToken -> DeviceToken -> IO ()
updateDeviceToken Connection
db NtfToken
tkn DeviceToken
suppliedDeviceToken
          NtfToken -> ExceptT AgentErrorType (ReaderT Env IO) ()
registerToken NtfToken
tkn ExceptT AgentErrorType (ReaderT Env IO) ()
-> NtfTknStatus -> AM NtfTknStatus
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> NtfTknStatus
NTRegistered
        -- possible improvement: add minimal time before repeat registration
        (Just QueueId
tknId, Maybe NtfTknAction
Nothing)
          | DeviceToken
savedDeviceToken DeviceToken -> DeviceToken -> Bool
forall a. Eq a => a -> a -> Bool
== DeviceToken
suppliedDeviceToken ->
              NtfToken -> ExceptT AgentErrorType (ReaderT Env IO) ()
registerToken NtfToken
tkn ExceptT AgentErrorType (ReaderT Env IO) ()
-> NtfTknStatus -> AM NtfTknStatus
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> NtfTknStatus
NTRegistered
          | Bool
otherwise -> QueueId -> AM NtfTknStatus
replaceToken QueueId
tknId
        (Just QueueId
tknId, Just (NTAVerify NtfRegCode
code))
          | DeviceToken
savedDeviceToken DeviceToken -> DeviceToken -> Bool
forall a. Eq a => a -> a -> Bool
== DeviceToken
suppliedDeviceToken ->
              NtfToken
-> (NtfTknStatus, Maybe NtfTknAction)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> AM NtfTknStatus
t NtfToken
tkn (NtfTknStatus
NTActive, NtfTknAction -> Maybe NtfTknAction
forall a. a -> Maybe a
Just NtfTknAction
NTACheck) (ExceptT AgentErrorType (ReaderT Env IO) () -> AM NtfTknStatus)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> AM NtfTknStatus
forall a b. (a -> b) -> a -> b
$ AgentClient
-> NetworkRequestMode
-> QueueId
-> NtfToken
-> NtfRegCode
-> ExceptT AgentErrorType (ReaderT Env IO) ()
agentNtfVerifyToken AgentClient
c NetworkRequestMode
nm QueueId
tknId NtfToken
tkn NtfRegCode
code
          | Bool
otherwise -> QueueId -> AM NtfTknStatus
replaceToken QueueId
tknId
        (Just QueueId
tknId, Just NtfTknAction
NTACheck)
          | DeviceToken
savedDeviceToken DeviceToken -> DeviceToken -> Bool
forall a. Eq a => a -> a -> Bool
== DeviceToken
suppliedDeviceToken -> do
              NtfSupervisor
ns <- (Env -> NtfSupervisor)
-> ExceptT AgentErrorType (ReaderT Env IO) NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
              let tkn' :: NtfToken
tkn' = NtfToken
tkn {ntfMode = suppliedNtfMode}
              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
$ NtfSupervisor -> NtfToken -> STM ()
nsUpdateToken NtfSupervisor
ns NtfToken
tkn'
              AgentClient
-> NetworkRequestMode -> QueueId -> NtfToken -> AM NtfTknStatus
agentNtfCheckToken AgentClient
c NetworkRequestMode
nm QueueId
tknId NtfToken
tkn' AM NtfTknStatus
-> (NtfTknStatus -> AM NtfTknStatus) -> AM NtfTknStatus
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
                NtfTknStatus
NTActive -> do
                  Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NotificationsMode
suppliedNtfMode NotificationsMode -> NotificationsMode -> Bool
forall a. Eq a => a -> a -> Bool
== NotificationsMode
NMInstant) (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
$ AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) ()
initializeNtfSubs AgentClient
c
                  Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NotificationsMode
suppliedNtfMode NotificationsMode -> NotificationsMode -> Bool
forall a. Eq a => a -> a -> Bool
== NotificationsMode
NMPeriodic Bool -> Bool -> Bool
&& NotificationsMode
savedNtfMode NotificationsMode -> NotificationsMode -> Bool
forall a. Eq a => a -> a -> Bool
== NotificationsMode
NMInstant) (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
$ AgentClient
-> NtfSupervisorCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteNtfSubs AgentClient
c NtfSupervisorCommand
NSCSmpDelete
                  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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> NetworkRequestMode -> QueueId -> NtfToken -> ReaderT Env IO ()
setCronInterval AgentClient
c NetworkRequestMode
nm QueueId
tknId NtfToken
tkn
                  NtfToken
-> (NtfTknStatus, Maybe NtfTknAction)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> AM NtfTknStatus
t NtfToken
tkn' (NtfTknStatus
NTActive, NtfTknAction -> Maybe NtfTknAction
forall a. a -> Maybe a
Just NtfTknAction
NTACheck) (ExceptT AgentErrorType (ReaderT Env IO) () -> AM NtfTknStatus)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> AM NtfTknStatus
forall a b. (a -> b) -> a -> b
$ () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                NtfTknStatus
status -> NtfToken
-> (NtfTknStatus, Maybe NtfTknAction)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> AM NtfTknStatus
t NtfToken
tkn' (NtfTknStatus
status, Maybe NtfTknAction
forall a. Maybe a
Nothing) (ExceptT AgentErrorType (ReaderT Env IO) () -> AM NtfTknStatus)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> AM NtfTknStatus
forall a b. (a -> b) -> a -> b
$ () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          | Bool
otherwise -> QueueId -> AM NtfTknStatus
replaceToken QueueId
tknId
        -- deprecated
        (Just QueueId
_tknId, Just NtfTknAction
NTADelete) -> AgentClient
-> NtfToken -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteToken AgentClient
c NtfToken
tkn ExceptT AgentErrorType (ReaderT Env IO) ()
-> NtfTknStatus -> AM NtfTknStatus
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> NtfTknStatus
NTExpired
        (Maybe QueueId, Maybe NtfTknAction)
_ -> NtfTknStatus -> AM NtfTknStatus
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfTknStatus
ntfTknStatus
      AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> NtfToken -> NotificationsMode -> IO ()
updateNtfMode Connection
db NtfToken
tkn NotificationsMode
suppliedNtfMode
      NtfTknStatus -> AM NtfTknStatus
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfTknStatus
status
      where
        replaceToken :: NtfTokenId -> AM NtfTknStatus
        replaceToken :: QueueId -> AM NtfTknStatus
replaceToken QueueId
tknId = do
          NtfSupervisor
ns <- (Env -> NtfSupervisor)
-> ExceptT AgentErrorType (ReaderT Env IO) NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
          NtfSupervisor -> AM NtfTknStatus
tryReplace NtfSupervisor
ns AM NtfTknStatus
-> (AgentErrorType -> AM NtfTknStatus) -> AM NtfTknStatus
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \AgentErrorType
e ->
            if AgentErrorType -> Bool
temporaryOrHostError AgentErrorType
e
              then AgentErrorType -> AM NtfTknStatus
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e
              else do
                AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> NtfToken -> IO ()
removeNtfToken Connection
db NtfToken
tkn
                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
$ NtfSupervisor -> STM ()
nsRemoveNtfToken NtfSupervisor
ns
                AM NtfTknStatus
createToken
          where
            tryReplace :: NtfSupervisor -> AM NtfTknStatus
tryReplace NtfSupervisor
ns = do
              AgentClient
-> NetworkRequestMode
-> QueueId
-> NtfToken
-> DeviceToken
-> ExceptT AgentErrorType (ReaderT Env IO) ()
agentNtfReplaceToken AgentClient
c NetworkRequestMode
nm QueueId
tknId NtfToken
tkn DeviceToken
suppliedDeviceToken
              AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> NtfToken -> DeviceToken -> IO ()
updateDeviceToken Connection
db NtfToken
tkn DeviceToken
suppliedDeviceToken
              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
$ NtfSupervisor -> NtfToken -> STM ()
nsUpdateToken NtfSupervisor
ns NtfToken
tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode}
              NtfTknStatus -> AM NtfTknStatus
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfTknStatus
NTRegistered
    Maybe NtfToken
_ -> AM NtfTknStatus
createToken
  where
    t :: NtfToken
-> (NtfTknStatus, Maybe NtfTknAction)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> AM NtfTknStatus
t NtfToken
tkn = AgentClient
-> NetworkRequestMode
-> NtfToken
-> Maybe (NtfTknStatus, NtfTknAction)
-> (NtfTknStatus, Maybe NtfTknAction)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> AM NtfTknStatus
forall a.
AgentClient
-> NetworkRequestMode
-> NtfToken
-> Maybe (NtfTknStatus, NtfTknAction)
-> (NtfTknStatus, Maybe NtfTknAction)
-> AM a
-> AM NtfTknStatus
withToken AgentClient
c NetworkRequestMode
nm NtfToken
tkn Maybe (NtfTknStatus, NtfTknAction)
forall a. Maybe a
Nothing
    createToken :: AM NtfTknStatus
    createToken :: AM NtfTknStatus
createToken =
      ReaderT Env IO (Maybe NtfServer) -> AM (Maybe NtfServer)
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 -> ReaderT Env IO (Maybe NtfServer)
getNtfServer AgentClient
c) AM (Maybe NtfServer)
-> (Maybe NtfServer -> AM NtfTknStatus) -> AM NtfTknStatus
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 NtfServer
ntfServer ->
          (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) ExceptT AgentErrorType (ReaderT Env IO) AuthAlg
-> (AuthAlg -> AM NtfTknStatus) -> AM NtfTknStatus
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
            C.AuthAlg SAlgorithm a
a -> 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
              (SndPublicAuthKey, APrivateAuthKey)
tknKeys <- 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
              (PublicKeyX25519, PrivateKey 'X25519)
dhKeys <- STM (PublicKeyX25519, PrivateKey 'X25519)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PublicKeyX25519, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKeyX25519, PrivateKey 'X25519)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (PublicKeyX25519, PrivateKey 'X25519))
-> STM (PublicKeyX25519, PrivateKey 'X25519)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PublicKeyX25519, 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 tkn :: NtfToken
tkn = DeviceToken
-> NtfServer
-> AAuthKeyPair
-> KeyPair 'X25519
-> NotificationsMode
-> NtfToken
newNtfToken DeviceToken
suppliedDeviceToken NtfServer
ntfServer AAuthKeyPair
(SndPublicAuthKey, APrivateAuthKey)
tknKeys KeyPair 'X25519
(PublicKeyX25519, PrivateKey 'X25519)
dhKeys NotificationsMode
suppliedNtfMode
              AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> NtfToken -> IO ()
`createNtfToken` NtfToken
tkn)
              NtfToken -> ExceptT AgentErrorType (ReaderT Env IO) ()
registerToken NtfToken
tkn
              NtfTknStatus -> AM NtfTknStatus
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfTknStatus
NTRegistered
        Maybe NtfServer
_ -> AgentErrorType -> AM NtfTknStatus
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM NtfTknStatus)
-> AgentErrorType -> AM NtfTknStatus
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"createToken"
    registerToken :: NtfToken -> AM ()
    registerToken :: NtfToken -> ExceptT AgentErrorType (ReaderT Env IO) ()
registerToken tkn :: NtfToken
tkn@NtfToken {SndPublicAuthKey
ntfPubKey :: SndPublicAuthKey
$sel:ntfPubKey:NtfToken :: NtfToken -> SndPublicAuthKey
ntfPubKey, $sel:ntfDhKeys:NtfToken :: NtfToken -> KeyPair 'X25519
ntfDhKeys = (PublicKeyType (PrivateKey 'X25519)
pubDhKey, PrivateKey 'X25519
privDhKey)} = do
      (QueueId
tknId, PublicKeyX25519
srvPubDhKey) <- AgentClient
-> NetworkRequestMode
-> NtfToken
-> SndPublicAuthKey
-> PublicKeyX25519
-> AM (QueueId, PublicKeyX25519)
agentNtfRegisterToken AgentClient
c NetworkRequestMode
nm NtfToken
tkn SndPublicAuthKey
ntfPubKey PublicKeyType (PrivateKey 'X25519)
PublicKeyX25519
pubDhKey
      let dhSecret :: DhSecretX25519
dhSecret = PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecretX25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKeyX25519
srvPubDhKey PrivateKey 'X25519
privDhKey
      AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> NtfToken -> QueueId -> DhSecretX25519 -> IO ()
updateNtfTokenRegistration Connection
db NtfToken
tkn QueueId
tknId DhSecretX25519
dhSecret
      NtfSupervisor
ns <- (Env -> NtfSupervisor)
-> ExceptT AgentErrorType (ReaderT Env IO) NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
      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
$ NtfSupervisor -> NtfToken -> STM ()
nsUpdateToken NtfSupervisor
ns NtfToken
tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode}

verifyNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> C.CbNonce -> ByteString -> AM ()
verifyNtfToken' :: AgentClient
-> NetworkRequestMode
-> DeviceToken
-> CbNonce
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
verifyNtfToken' AgentClient
c NetworkRequestMode
nm DeviceToken
deviceToken CbNonce
nonce ConnId
code =
  AgentClient
-> (Connection -> IO (Maybe NtfToken))
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO (Maybe NtfToken)
getSavedNtfToken ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
-> (Maybe NtfToken -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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 tkn :: NtfToken
tkn@NtfToken {$sel:deviceToken:NtfToken :: NtfToken -> DeviceToken
deviceToken = DeviceToken
savedDeviceToken, $sel:ntfTokenId:NtfToken :: NtfToken -> Maybe QueueId
ntfTokenId = Just QueueId
tknId, $sel:ntfDhSecret:NtfToken :: NtfToken -> Maybe DhSecretX25519
ntfDhSecret = Just DhSecretX25519
dhSecret, NotificationsMode
$sel:ntfMode:NtfToken :: NtfToken -> NotificationsMode
ntfMode :: NotificationsMode
ntfMode} -> do
      Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DeviceToken
deviceToken DeviceToken -> DeviceToken -> Bool
forall a. Eq a => a -> a -> Bool
/= DeviceToken
savedDeviceToken) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"verifyNtfToken: different token"
      NtfRegCode
code' <- Either AgentErrorType NtfRegCode
-> ExceptT AgentErrorType (ReaderT Env IO) NtfRegCode
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either AgentErrorType NtfRegCode
 -> ExceptT AgentErrorType (ReaderT Env IO) NtfRegCode)
-> (Either CryptoError ConnId -> Either AgentErrorType NtfRegCode)
-> Either CryptoError ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) NtfRegCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CryptoError -> AgentErrorType)
-> (ConnId -> NtfRegCode)
-> Either CryptoError ConnId
-> Either AgentErrorType NtfRegCode
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 CryptoError -> AgentErrorType
cryptoError ConnId -> NtfRegCode
NtfRegCode (Either CryptoError ConnId
 -> ExceptT AgentErrorType (ReaderT Env IO) NtfRegCode)
-> Either CryptoError ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) NtfRegCode
forall a b. (a -> b) -> a -> b
$ DhSecretX25519 -> CbNonce -> ConnId -> Either CryptoError ConnId
C.cbDecrypt DhSecretX25519
dhSecret CbNonce
nonce ConnId
code
      NtfTknStatus
toStatus <-
        AgentClient
-> NetworkRequestMode
-> NtfToken
-> Maybe (NtfTknStatus, NtfTknAction)
-> (NtfTknStatus, Maybe NtfTknAction)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> AM NtfTknStatus
forall a.
AgentClient
-> NetworkRequestMode
-> NtfToken
-> Maybe (NtfTknStatus, NtfTknAction)
-> (NtfTknStatus, Maybe NtfTknAction)
-> AM a
-> AM NtfTknStatus
withToken AgentClient
c NetworkRequestMode
nm NtfToken
tkn ((NtfTknStatus, NtfTknAction) -> Maybe (NtfTknStatus, NtfTknAction)
forall a. a -> Maybe a
Just (NtfTknStatus
NTConfirmed, NtfRegCode -> NtfTknAction
NTAVerify NtfRegCode
code')) (NtfTknStatus
NTActive, NtfTknAction -> Maybe NtfTknAction
forall a. a -> Maybe a
Just NtfTknAction
NTACheck) (ExceptT AgentErrorType (ReaderT Env IO) () -> AM NtfTknStatus)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> AM NtfTknStatus
forall a b. (a -> b) -> a -> b
$
          AgentClient
-> NetworkRequestMode
-> QueueId
-> NtfToken
-> NtfRegCode
-> ExceptT AgentErrorType (ReaderT Env IO) ()
agentNtfVerifyToken AgentClient
c NetworkRequestMode
nm QueueId
tknId NtfToken
tkn NtfRegCode
code'
      Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NtfTknStatus
toStatus NtfTknStatus -> NtfTknStatus -> Bool
forall a. Eq a => a -> a -> Bool
== NtfTknStatus
NTActive) (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
$ do
        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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> NetworkRequestMode -> QueueId -> NtfToken -> ReaderT Env IO ()
setCronInterval AgentClient
c NetworkRequestMode
nm QueueId
tknId NtfToken
tkn
        Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NotificationsMode
ntfMode NotificationsMode -> NotificationsMode -> Bool
forall a. Eq a => a -> a -> Bool
== NotificationsMode
NMInstant) (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
$ AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) ()
initializeNtfSubs AgentClient
c
    Maybe NtfToken
_ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"verifyNtfToken: no token"

setCronInterval :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> AM' ()
setCronInterval :: AgentClient
-> NetworkRequestMode -> QueueId -> NtfToken -> ReaderT Env IO ()
setCronInterval AgentClient
c NetworkRequestMode
nm QueueId
tknId NtfToken
tkn = do
  Word16
cron <- (Env -> Word16) -> ReaderT Env IO Word16
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> Word16) -> ReaderT Env IO Word16)
-> (Env -> Word16) -> ReaderT Env IO Word16
forall a b. (a -> b) -> a -> b
$ AgentConfig -> Word16
ntfCron (AgentConfig -> Word16) -> (Env -> AgentConfig) -> Env -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  ReaderT Env IO ThreadId -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Env IO ThreadId -> ReaderT Env IO ())
-> ReaderT Env IO ThreadId -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO () -> ReaderT Env IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (ReaderT Env IO () -> ReaderT Env IO ThreadId)
-> ReaderT Env IO () -> ReaderT Env IO ThreadId
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO (Either AgentErrorType ()) -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Env IO (Either AgentErrorType ()) -> ReaderT Env IO ())
-> ReaderT Env IO (Either AgentErrorType ()) -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ ExceptT AgentErrorType (ReaderT Env IO) ()
-> ReaderT Env IO (Either AgentErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ReaderT Env IO (Either AgentErrorType ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ReaderT Env IO (Either AgentErrorType ())
forall a b. (a -> b) -> a -> b
$ AgentClient
-> NetworkRequestMode
-> QueueId
-> NtfToken
-> Word16
-> ExceptT AgentErrorType (ReaderT Env IO) ()
agentNtfSetCronInterval AgentClient
c NetworkRequestMode
nm QueueId
tknId NtfToken
tkn Word16
cron

checkNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> AM NtfTknStatus
checkNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> AM NtfTknStatus
checkNtfToken' AgentClient
c NetworkRequestMode
nm DeviceToken
deviceToken =
  AgentClient
-> (Connection -> IO (Maybe NtfToken))
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO (Maybe NtfToken)
getSavedNtfToken ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
-> (Maybe NtfToken -> AM NtfTknStatus) -> AM NtfTknStatus
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 tkn :: NtfToken
tkn@NtfToken {$sel:deviceToken:NtfToken :: NtfToken -> DeviceToken
deviceToken = DeviceToken
savedDeviceToken, $sel:ntfTokenId:NtfToken :: NtfToken -> Maybe QueueId
ntfTokenId = Just QueueId
tknId, Maybe NtfTknAction
$sel:ntfTknAction:NtfToken :: NtfToken -> Maybe NtfTknAction
ntfTknAction :: Maybe NtfTknAction
ntfTknAction} -> do
      Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DeviceToken
deviceToken DeviceToken -> DeviceToken -> Bool
forall a. Eq a => a -> a -> Bool
/= DeviceToken
savedDeviceToken) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"checkNtfToken: different token"
      NtfTknStatus
status <- AgentClient
-> NetworkRequestMode -> QueueId -> NtfToken -> AM NtfTknStatus
agentNtfCheckToken AgentClient
c NetworkRequestMode
nm QueueId
tknId NtfToken
tkn
      let action :: Maybe NtfTknAction
action = case NtfTknStatus
status of
            NTInvalid Maybe NTInvalidReason
_ -> Maybe NtfTknAction
forall a. Maybe a
Nothing
            NtfTknStatus
NTExpired -> Maybe NtfTknAction
forall a. Maybe a
Nothing
            NtfTknStatus
_ -> Maybe NtfTknAction
ntfTknAction
      AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> IO ()
updateNtfToken Connection
db NtfToken
tkn NtfTknStatus
status Maybe NtfTknAction
action
      NtfTknStatus -> AM NtfTknStatus
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfTknStatus
status
    Maybe NtfToken
_ -> AgentErrorType -> AM NtfTknStatus
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM NtfTknStatus)
-> AgentErrorType -> AM NtfTknStatus
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"checkNtfToken: no token"

deleteNtfToken' :: AgentClient -> DeviceToken -> AM ()
deleteNtfToken' :: AgentClient
-> DeviceToken -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteNtfToken' AgentClient
c DeviceToken
deviceToken =
  AgentClient
-> (Connection -> IO (Maybe NtfToken))
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO (Maybe NtfToken)
getSavedNtfToken ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
-> (Maybe NtfToken -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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 tkn :: NtfToken
tkn@NtfToken {$sel:deviceToken:NtfToken :: NtfToken -> DeviceToken
deviceToken = DeviceToken
savedDeviceToken} -> do
      Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DeviceToken
deviceToken DeviceToken -> DeviceToken -> Bool
forall a. Eq a => a -> a -> Bool
/= DeviceToken
savedDeviceToken) (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
$ Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn Text
"deleteNtfToken: different token"
      AgentClient
-> NtfToken -> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteToken AgentClient
c NtfToken
tkn
      AgentClient
-> NtfSupervisorCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteNtfSubs AgentClient
c NtfSupervisorCommand
NSCSmpDelete
    Maybe NtfToken
_ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"deleteNtfToken: no token"

getNtfToken' :: AgentClient -> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
getNtfToken' :: AgentClient
-> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
getNtfToken' AgentClient
c =
  AgentClient
-> (Connection -> IO (Maybe NtfToken))
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO (Maybe NtfToken)
getSavedNtfToken ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
-> (Maybe NtfToken
    -> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer))
-> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
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 NtfToken {DeviceToken
$sel:deviceToken:NtfToken :: NtfToken -> DeviceToken
deviceToken :: DeviceToken
deviceToken, NtfTknStatus
$sel:ntfTknStatus:NtfToken :: NtfToken -> NtfTknStatus
ntfTknStatus :: NtfTknStatus
ntfTknStatus, NotificationsMode
$sel:ntfMode:NtfToken :: NtfToken -> NotificationsMode
ntfMode :: NotificationsMode
ntfMode, NtfServer
$sel:ntfServer:NtfToken :: NtfToken -> NtfServer
ntfServer :: NtfServer
ntfServer} -> (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
-> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DeviceToken
deviceToken, NtfTknStatus
ntfTknStatus, NotificationsMode
ntfMode, NtfServer
ntfServer)
    Maybe NtfToken
_ -> AgentErrorType
-> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType
 -> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer))
-> AgentErrorType
-> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"getNtfToken"

getNtfTokenData' :: AgentClient -> AM NtfToken
getNtfTokenData' :: AgentClient -> AM NtfToken
getNtfTokenData' AgentClient
c =
  AgentClient
-> (Connection -> IO (Maybe NtfToken))
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO (Maybe NtfToken)
getSavedNtfToken ExceptT AgentErrorType (ReaderT Env IO) (Maybe NtfToken)
-> (Maybe NtfToken -> AM NtfToken) -> AM NtfToken
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 NtfToken
tkn -> NtfToken -> AM NtfToken
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfToken
tkn
    Maybe NtfToken
_ -> AgentErrorType -> AM NtfToken
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> AM NtfToken) -> AgentErrorType -> AM NtfToken
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> String -> AgentErrorType
CMD CommandErrorType
PROHIBITED String
"getNtfTokenData"

-- | Set connection notifications, in Reader monad
toggleConnectionNtfs' :: AgentClient -> ConnId -> Bool -> AM ()
toggleConnectionNtfs' :: AgentClient
-> ConnId -> Bool -> ExceptT AgentErrorType (ReaderT Env IO) ()
toggleConnectionNtfs' AgentClient
c ConnId
connId Bool
enable = do
  SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn <- AgentClient
-> (Connection -> IO (Either StoreError SomeConn)) -> AM SomeConn
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection -> ConnId -> IO (Either StoreError SomeConn)
`getConn` ConnId
connId)
  case Connection' d RcvQueue SndQueue
conn of
    DuplexConnection ConnData
cData NonEmpty RcvQueue
_ NonEmpty SndQueue
_ -> ConnData -> ExceptT AgentErrorType (ReaderT Env IO) ()
toggle ConnData
cData
    RcvConnection ConnData
cData RcvQueue
_ -> ConnData -> ExceptT AgentErrorType (ReaderT Env IO) ()
toggle ConnData
cData
    ContactConnection ConnData
cData RcvQueue
_ -> ConnData -> ExceptT AgentErrorType (ReaderT Env IO) ()
toggle ConnData
cData
    Connection' d RcvQueue SndQueue
_ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> String -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX String
"toggleConnectionNtfs"
  where
    toggle :: ConnData -> AM ()
    toggle :: ConnData -> ExceptT AgentErrorType (ReaderT Env IO) ()
toggle ConnData {Bool
$sel:enableNtfs:ConnData :: ConnData -> Bool
enableNtfs :: Bool
enableNtfs}
      | Bool
enableNtfs Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
enable = () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
          AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> Bool -> IO ()
setConnectionNtfs Connection
db ConnId
connId Bool
enable
          NtfSupervisor
ns <- (Env -> NtfSupervisor)
-> ExceptT AgentErrorType (ReaderT Env IO) NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
          let cmd :: NtfSupervisorCommand
cmd = if Bool
enable then NtfSupervisorCommand
NSCCreate else NtfSupervisorCommand
NSCSmpDelete
          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
$ NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> IO ()
sendNtfSubCommand NtfSupervisor
ns (NtfSupervisorCommand
cmd, [ConnId
Item (NonEmpty ConnId)
connId])

withToken :: AgentClient -> NetworkRequestMode -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus
withToken :: forall a.
AgentClient
-> NetworkRequestMode
-> NtfToken
-> Maybe (NtfTknStatus, NtfTknAction)
-> (NtfTknStatus, Maybe NtfTknAction)
-> AM a
-> AM NtfTknStatus
withToken AgentClient
c NetworkRequestMode
nm tkn :: NtfToken
tkn@NtfToken {DeviceToken
$sel:deviceToken:NtfToken :: NtfToken -> DeviceToken
deviceToken :: DeviceToken
deviceToken, NotificationsMode
$sel:ntfMode:NtfToken :: NtfToken -> NotificationsMode
ntfMode :: NotificationsMode
ntfMode} Maybe (NtfTknStatus, NtfTknAction)
from_ (NtfTknStatus
toStatus, Maybe NtfTknAction
toAction_) AM a
f = do
  NtfSupervisor
ns <- (Env -> NtfSupervisor)
-> ExceptT AgentErrorType (ReaderT Env IO) NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
  Maybe (NtfTknStatus, NtfTknAction)
-> ((NtfTknStatus, NtfTknAction)
    -> 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 (NtfTknStatus, NtfTknAction)
from_ (((NtfTknStatus, NtfTknAction)
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((NtfTknStatus, NtfTknAction)
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \(NtfTknStatus
status, NtfTknAction
action) -> do
    AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> IO ()
updateNtfToken Connection
db NtfToken
tkn NtfTknStatus
status (NtfTknAction -> Maybe NtfTknAction
forall a. a -> Maybe a
Just NtfTknAction
action)
    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
$ NtfSupervisor -> NtfToken -> STM ()
nsUpdateToken NtfSupervisor
ns NtfToken
tkn {ntfTknStatus = status, ntfTknAction = Just action}
  AM a
-> ExceptT
     AgentErrorType (ReaderT Env IO) (Either AgentErrorType a)
forall e (m :: * -> *) a. MonadError e m => m a -> m (Either e a)
tryError AM a
f ExceptT AgentErrorType (ReaderT Env IO) (Either AgentErrorType a)
-> (Either AgentErrorType a -> AM NtfTknStatus) -> AM NtfTknStatus
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
_ -> do
      AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> IO ()
updateNtfToken Connection
db NtfToken
tkn NtfTknStatus
toStatus Maybe NtfTknAction
toAction_
      let updatedToken :: NtfToken
updatedToken = NtfToken
tkn {ntfTknStatus = toStatus, ntfTknAction = toAction_}
      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
$ NtfSupervisor -> NtfToken -> STM ()
nsUpdateToken NtfSupervisor
ns NtfToken
updatedToken
      NtfTknStatus -> AM NtfTknStatus
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfTknStatus
toStatus
    Left e :: AgentErrorType
e@(NTF String
_ ErrorType
AUTH) -> do
      AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> NtfToken -> IO ()
removeNtfToken Connection
db NtfToken
tkn
      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
$ NtfSupervisor -> STM ()
nsRemoveNtfToken NtfSupervisor
ns
      AM NtfTknStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM NtfTknStatus -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM NtfTknStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> NetworkRequestMode
-> DeviceToken
-> NotificationsMode
-> AM NtfTknStatus
registerNtfToken' AgentClient
c NetworkRequestMode
nm DeviceToken
deviceToken NotificationsMode
ntfMode
      AgentErrorType -> AM NtfTknStatus
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e
    Left AgentErrorType
e -> AgentErrorType -> AM NtfTknStatus
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE AgentErrorType
e

initializeNtfSubs :: AgentClient -> AM ()
initializeNtfSubs :: AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) ()
initializeNtfSubs AgentClient
c = AgentClient
-> NtfSupervisorCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
sendNtfConnCommands AgentClient
c NtfSupervisorCommand
NSCCreate
{-# INLINE initializeNtfSubs #-}

deleteNtfSubs :: AgentClient -> NtfSupervisorCommand -> AM ()
deleteNtfSubs :: AgentClient
-> NtfSupervisorCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
deleteNtfSubs AgentClient
c NtfSupervisorCommand
deleteCmd = do
  NtfSupervisor
ns <- (Env -> NtfSupervisor)
-> ExceptT AgentErrorType (ReaderT Env IO) NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
  ExceptT
  AgentErrorType
  (ReaderT Env IO)
  [(NtfSupervisorCommand, NonEmpty ConnId)]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   AgentErrorType
   (ReaderT Env IO)
   [(NtfSupervisorCommand, NonEmpty ConnId)]
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
    -> ExceptT
         AgentErrorType
         (ReaderT Env IO)
         [(NtfSupervisorCommand, NonEmpty ConnId)])
-> TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM [(NtfSupervisorCommand, NonEmpty ConnId)]
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     [(NtfSupervisorCommand, NonEmpty ConnId)]
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM [(NtfSupervisorCommand, NonEmpty ConnId)]
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      [(NtfSupervisorCommand, NonEmpty ConnId)])
-> (TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
    -> STM [(NtfSupervisorCommand, NonEmpty ConnId)])
-> TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     [(NtfSupervisorCommand, NonEmpty ConnId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
-> STM [(NtfSupervisorCommand, NonEmpty ConnId)]
forall a. TBQueue a -> STM [a]
flushTBQueue (TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ NtfSupervisor -> TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
ntfSubQ NtfSupervisor
ns
  AgentClient
-> NtfSupervisorCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
sendNtfConnCommands AgentClient
c NtfSupervisorCommand
deleteCmd

sendNtfConnCommands :: AgentClient -> NtfSupervisorCommand -> AM ()
sendNtfConnCommands :: AgentClient
-> NtfSupervisorCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
sendNtfConnCommands AgentClient
c NtfSupervisorCommand
cmd = do
  NtfSupervisor
ns <- (Env -> NtfSupervisor)
-> ExceptT AgentErrorType (ReaderT Env IO) NtfSupervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> NtfSupervisor
ntfSupervisor
  [ConnId]
connIds <- IO [ConnId] -> AM [ConnId]
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ConnId] -> AM [ConnId]) -> IO [ConnId] -> AM [ConnId]
forall a b. (a -> b) -> a -> b
$ Set ConnId -> [ConnId]
forall a. Set a -> [a]
S.toList (Set ConnId -> [ConnId]) -> IO (Set ConnId) -> IO [ConnId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient -> IO (Set ConnId)
getSubscriptions AgentClient
c
  [Either StoreError (Maybe (ConnData, ConnectionMode))]
rs <- AgentClient
-> (Connection
    -> IO [Either StoreError (Maybe (ConnData, ConnectionMode))])
-> AM [Either StoreError (Maybe (ConnData, ConnectionMode))]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection
-> [ConnId]
-> IO [Either StoreError (Maybe (ConnData, ConnectionMode))]
`getConnsData` [ConnId]
connIds)
  let ([ConnId]
connIds', [(ConnId, AgentErrorType)]
errs) = [(ConnId, Either StoreError (Maybe (ConnData, ConnectionMode)))]
-> ([ConnId], [(ConnId, AgentErrorType)])
enabledNtfConns ([ConnId]
-> [Either StoreError (Maybe (ConnData, ConnectionMode))]
-> [(ConnId, Either StoreError (Maybe (ConnData, ConnectionMode)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [ConnId]
connIds [Either StoreError (Maybe (ConnData, ConnectionMode))]
rs)
  Maybe (NonEmpty ConnId)
-> (NonEmpty ConnId -> 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_ ([ConnId] -> Maybe (NonEmpty ConnId)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [ConnId]
connIds') ((NonEmpty ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (NonEmpty ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty ConnId
connIds'' ->
    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
$ TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
-> (NtfSupervisorCommand, NonEmpty ConnId) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (NtfSupervisor -> TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
ntfSubQ NtfSupervisor
ns) (NtfSupervisorCommand
cmd, NonEmpty ConnId
connIds'')
  Maybe (NonEmpty (ConnId, AgentErrorType))
-> (NonEmpty (ConnId, AgentErrorType)
    -> 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_ ([(ConnId, AgentErrorType)]
-> Maybe (NonEmpty (ConnId, AgentErrorType))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [(ConnId, AgentErrorType)]
errs) ((NonEmpty (ConnId, AgentErrorType)
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (NonEmpty (ConnId, AgentErrorType)
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> AEvent 'AENone -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *).
MonadIO m =>
AgentClient -> AEvent 'AENone -> m ()
notifySub AgentClient
c (AEvent 'AENone -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (NonEmpty (ConnId, AgentErrorType) -> AEvent 'AENone)
-> NonEmpty (ConnId, AgentErrorType)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ConnId, AgentErrorType) -> AEvent 'AENone
ERRS
  where
    enabledNtfConns :: [(ConnId, Either StoreError (Maybe (ConnData, ConnectionMode)))] -> ([ConnId], [(ConnId, AgentErrorType)])
    enabledNtfConns :: [(ConnId, Either StoreError (Maybe (ConnData, ConnectionMode)))]
-> ([ConnId], [(ConnId, AgentErrorType)])
enabledNtfConns = ((ConnId, Either StoreError (Maybe (ConnData, ConnectionMode)))
 -> ([ConnId], [(ConnId, AgentErrorType)])
 -> ([ConnId], [(ConnId, AgentErrorType)]))
-> ([ConnId], [(ConnId, AgentErrorType)])
-> [(ConnId, Either StoreError (Maybe (ConnData, ConnectionMode)))]
-> ([ConnId], [(ConnId, AgentErrorType)])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ConnId, Either StoreError (Maybe (ConnData, ConnectionMode)))
-> ([ConnId], [(ConnId, AgentErrorType)])
-> ([ConnId], [(ConnId, AgentErrorType)])
addEnabledConn ([], [])
      where
        addEnabledConn ::
          (ConnId, Either StoreError (Maybe (ConnData, ConnectionMode))) ->
          ([ConnId], [(ConnId, AgentErrorType)]) ->
          ([ConnId], [(ConnId, AgentErrorType)])
        addEnabledConn :: (ConnId, Either StoreError (Maybe (ConnData, ConnectionMode)))
-> ([ConnId], [(ConnId, AgentErrorType)])
-> ([ConnId], [(ConnId, AgentErrorType)])
addEnabledConn (ConnId, Either StoreError (Maybe (ConnData, ConnectionMode)))
cData_ ([ConnId]
cIds, [(ConnId, AgentErrorType)]
errs) = case (ConnId, Either StoreError (Maybe (ConnData, ConnectionMode)))
cData_ of
          (ConnId
_, Right (Just (ConnData {ConnId
$sel:connId:ConnData :: ConnData -> ConnId
connId :: ConnId
connId, Bool
$sel:enableNtfs:ConnData :: ConnData -> Bool
enableNtfs :: Bool
enableNtfs}, ConnectionMode
_))) -> if Bool
enableNtfs then (ConnId
connId ConnId -> [ConnId] -> [ConnId]
forall a. a -> [a] -> [a]
: [ConnId]
cIds, [(ConnId, AgentErrorType)]
errs) else ([ConnId]
cIds, [(ConnId, AgentErrorType)]
errs)
          (ConnId
connId, Right Maybe (ConnData, ConnectionMode)
Nothing) -> ([ConnId]
cIds, (ConnId
connId, String -> AgentErrorType
INTERNAL String
"no connection data") (ConnId, AgentErrorType)
-> [(ConnId, AgentErrorType)] -> [(ConnId, AgentErrorType)]
forall a. a -> [a] -> [a]
: [(ConnId, AgentErrorType)]
errs)
          (ConnId
connId, Left StoreError
e) -> ([ConnId]
cIds, (ConnId
connId, String -> AgentErrorType
INTERNAL (StoreError -> String
forall a. Show a => a -> String
show StoreError
e)) (ConnId, AgentErrorType)
-> [(ConnId, AgentErrorType)] -> [(ConnId, AgentErrorType)]
forall a. a -> [a] -> [a]
: [(ConnId, AgentErrorType)]
errs)

setNtfServers :: AgentClient -> [NtfServer] -> IO ()
setNtfServers :: AgentClient -> [NtfServer] -> IO ()
setNtfServers AgentClient
c = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ())
-> ([NtfServer] -> STM ()) -> [NtfServer] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar [NtfServer] -> [NtfServer] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (AgentClient -> TVar [NtfServer]
ntfServers AgentClient
c)
{-# INLINE setNtfServers #-}

resetAgentServersStats' :: AgentClient -> AM ()
resetAgentServersStats' :: AgentClient -> ExceptT AgentErrorType (ReaderT Env IO) ()
resetAgentServersStats' c :: AgentClient
c@AgentClient {TMap (UserId, SMPServer) AgentSMPServerStats
$sel:smpServersStats:AgentClient :: AgentClient -> TMap (UserId, SMPServer) AgentSMPServerStats
smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats
smpServersStats, TMap (UserId, XFTPServer) AgentXFTPServerStats
$sel:xftpServersStats:AgentClient :: AgentClient -> TMap (UserId, XFTPServer) AgentXFTPServerStats
xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats
xftpServersStats, TVar InternalTs
$sel:srvStatsStartedAt:AgentClient :: AgentClient -> TVar InternalTs
srvStatsStartedAt :: TVar InternalTs
srvStatsStartedAt} = do
  InternalTs
startedAt <- IO InternalTs -> ExceptT AgentErrorType (ReaderT Env IO) InternalTs
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO InternalTs
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
$ TVar InternalTs -> InternalTs -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar InternalTs
srvStatsStartedAt InternalTs
startedAt
  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
$ TMap (UserId, SMPServer) AgentSMPServerStats -> STM ()
forall k a. TMap k a -> STM ()
TM.clear TMap (UserId, SMPServer) AgentSMPServerStats
smpServersStats
  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
$ TMap (UserId, XFTPServer) AgentXFTPServerStats -> STM ()
forall k a. TMap k a -> STM ()
TM.clear TMap (UserId, XFTPServer) AgentXFTPServerStats
xftpServersStats
  AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> InternalTs -> IO ()
`resetServersStats` InternalTs
startedAt)

-- | Activate operations
foregroundAgent :: AgentClient -> IO ()
foregroundAgent :: AgentClient -> IO ()
foregroundAgent 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 AgentState -> AgentState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (AgentClient -> TVar AgentState
agentState AgentClient
c) AgentState
ASForeground
  ((AgentClient -> TVar AgentOpState) -> IO ())
-> [AgentClient -> TVar AgentOpState] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient -> TVar AgentOpState) -> IO ()
activate ([AgentClient -> TVar AgentOpState] -> IO ())
-> [AgentClient -> TVar AgentOpState] -> IO ()
forall a b. (a -> b) -> a -> b
$ [AgentClient -> TVar AgentOpState]
-> [AgentClient -> TVar AgentOpState]
forall a. [a] -> [a]
reverse [AgentClient -> TVar AgentOpState]
agentOperations
  where
    activate :: (AgentClient -> TVar AgentOpState) -> IO ()
activate AgentClient -> TVar AgentOpState
opSel = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar AgentOpState -> (AgentOpState -> AgentOpState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (AgentClient -> TVar AgentOpState
opSel AgentClient
c) ((AgentOpState -> AgentOpState) -> STM ())
-> (AgentOpState -> AgentOpState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \AgentOpState
s -> AgentOpState
s {opSuspended = False}

-- | Suspend operations with max delay to deliver pending messages
suspendAgent :: AgentClient -> Int -> IO ()
suspendAgent :: AgentClient -> Int -> IO ()
suspendAgent AgentClient
c Int
0 = 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 AgentState -> AgentState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (AgentClient -> TVar AgentState
agentState AgentClient
c) AgentState
ASSuspended
  ((AgentClient -> TVar AgentOpState) -> IO ())
-> [AgentClient -> TVar AgentOpState] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AgentClient -> TVar AgentOpState) -> IO ()
suspend [AgentClient -> TVar AgentOpState]
agentOperations
  where
    suspend :: (AgentClient -> TVar AgentOpState) -> IO ()
suspend AgentClient -> TVar AgentOpState
opSel = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar AgentOpState -> (AgentOpState -> AgentOpState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (AgentClient -> TVar AgentOpState
opSel AgentClient
c) ((AgentOpState -> AgentOpState) -> STM ())
-> (AgentOpState -> AgentOpState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \AgentOpState
s -> AgentOpState
s {opSuspended = True}
suspendAgent c :: AgentClient
c@AgentClient {$sel:agentState:AgentClient :: AgentClient -> TVar AgentState
agentState = TVar AgentState
as} Int
maxDelay = do
  AgentState
state <-
    STM AgentState -> IO AgentState
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AgentState -> IO AgentState)
-> STM AgentState -> IO AgentState
forall a b. (a -> b) -> a -> b
$ do
      TVar AgentState -> AgentState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar AgentState
as AgentState
ASSuspending
      AgentClient -> AgentOperation -> STM () -> STM ()
suspendOperation AgentClient
c AgentOperation
AONtfNetwork (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      AgentClient -> AgentOperation -> STM () -> STM ()
suspendOperation AgentClient
c AgentOperation
AORcvNetwork (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
        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
      TVar AgentState -> STM AgentState
forall a. TVar a -> STM a
readTVar TVar AgentState
as
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AgentState
state AgentState -> AgentState -> Bool
forall a. Eq a => a -> a -> Bool
== AgentState
ASSuspending) (IO () -> IO ()) -> (IO () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
$ do
    Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
maxDelay
    -- liftIO $ putStrLn "suspendAgent after timeout"
    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> (STM () -> STM ()) -> STM () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> STM () -> STM ()
whenSuspending AgentClient
c (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      -- unsafeIOToSTM $ putStrLn $ "in timeout: suspendSendingAndDatabase"
      AgentClient -> STM ()
suspendSendingAndDatabase AgentClient
c

execAgentStoreSQL :: AgentClient -> Text -> AE [Text]
execAgentStoreSQL :: AgentClient -> Text -> AE [Text]
execAgentStoreSQL AgentClient
c Text
sql = AgentClient -> AM [Text] -> AE [Text]
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM [Text] -> AE [Text]) -> AM [Text] -> AE [Text]
forall a b. (a -> b) -> a -> b
$ AgentClient -> (Connection -> IO [Text]) -> AM [Text]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> Text -> IO [Text]
`execSQL` Text
sql)

getAgentMigrations :: AgentClient -> AE [UpMigration]
getAgentMigrations :: AgentClient -> AE [UpMigration]
getAgentMigrations AgentClient
c = AgentClient -> AM [UpMigration] -> AE [UpMigration]
forall a. AgentClient -> AM a -> AE a
withAgentEnv AgentClient
c (AM [UpMigration] -> AE [UpMigration])
-> AM [UpMigration] -> AE [UpMigration]
forall a b. (a -> b) -> a -> b
$ (Migration -> UpMigration) -> [Migration] -> [UpMigration]
forall a b. (a -> b) -> [a] -> [b]
map Migration -> UpMigration
upMigration ([Migration] -> [UpMigration])
-> ExceptT AgentErrorType (ReaderT Env IO) [Migration]
-> AM [UpMigration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> (Connection -> IO [Migration])
-> ExceptT AgentErrorType (ReaderT Env IO) [Migration]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Maybe Query -> Connection -> IO [Migration]
getCurrentMigrations Maybe Query
forall a. Maybe a
Nothing)

debugAgentLocks :: AgentClient -> IO AgentLocks
debugAgentLocks :: AgentClient -> IO AgentLocks
debugAgentLocks AgentClient {$sel:connLocks:AgentClient :: AgentClient -> TMap ConnId Lock
connLocks = TMap ConnId Lock
cs, $sel:invLocks:AgentClient :: AgentClient -> TMap ConnId Lock
invLocks = TMap ConnId Lock
is, $sel:deleteLock:AgentClient :: AgentClient -> Lock
deleteLock = Lock
d} = do
  Map Text Text
connLocks <- TMap ConnId Lock -> IO (Map Text Text)
forall {m :: * -> *} {k1} {a}.
(MonadIO m, StrEncoding k1) =>
TVar (Map k1 (TMVar a)) -> m (Map Text a)
getLocks TMap ConnId Lock
cs
  Map Text Text
invLocks <- TMap ConnId Lock -> IO (Map Text Text)
forall {m :: * -> *} {k1} {a}.
(MonadIO m, StrEncoding k1) =>
TVar (Map k1 (TMVar a)) -> m (Map Text a)
getLocks TMap ConnId Lock
is
  Maybe Text
delLock <- STM (Maybe Text) -> IO (Maybe Text)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe Text) -> IO (Maybe Text))
-> STM (Maybe Text) -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Lock -> STM (Maybe Text)
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar Lock
d
  AgentLocks -> IO AgentLocks
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AgentLocks {Map Text Text
connLocks :: Map Text Text
$sel:connLocks:AgentLocks :: Map Text Text
connLocks, Map Text Text
invLocks :: Map Text Text
$sel:invLocks:AgentLocks :: Map Text Text
invLocks, Maybe Text
delLock :: Maybe Text
$sel:delLock:AgentLocks :: Maybe Text
delLock}
  where
    getLocks :: TVar (Map k1 (TMVar a)) -> m (Map Text a)
getLocks TVar (Map k1 (TMVar a))
ls = STM (Map Text a) -> m (Map Text a)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Map Text a) -> m (Map Text a))
-> STM (Map Text a) -> m (Map Text a)
forall a b. (a -> b) -> a -> b
$ (k1 -> Text) -> Map k1 a -> Map Text a
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (ConnId -> Text
safeDecodeUtf8 (ConnId -> Text) -> (k1 -> ConnId) -> k1 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k1 -> ConnId
forall a. StrEncoding a => a -> ConnId
strEncode) (Map k1 a -> Map Text a)
-> (Map k1 (Maybe a) -> Map k1 a) -> Map k1 (Maybe a) -> Map Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> Maybe a) -> Map k1 (Maybe a) -> Map k1 a
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe Maybe a -> Maybe a
forall a. a -> a
id (Map k1 (Maybe a) -> Map Text a)
-> STM (Map k1 (Maybe a)) -> STM (Map Text a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((TMVar a -> STM (Maybe a))
-> Map k1 (TMVar a) -> STM (Map k1 (Maybe 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) -> Map k1 a -> m (Map k1 b)
mapM TMVar a -> STM (Maybe a)
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar (Map k1 (TMVar a) -> STM (Map k1 (Maybe a)))
-> STM (Map k1 (TMVar a)) -> STM (Map k1 (Maybe a))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar (Map k1 (TMVar a)) -> STM (Map k1 (TMVar a))
forall a. TVar a -> STM a
readTVar TVar (Map k1 (TMVar a))
ls)

getSMPServer :: AgentClient -> UserId -> AM SMPServerWithAuth
getSMPServer :: AgentClient -> UserId -> AM SMPServerWithAuth
getSMPServer AgentClient
c UserId
userId = AgentClient -> UserId -> [SMPServer] -> AM SMPServerWithAuth
getNextSMPServer AgentClient
c UserId
userId []
{-# INLINE getSMPServer #-}

getNextSMPServer :: AgentClient -> UserId -> [SMPServer] -> AM SMPServerWithAuth
getNextSMPServer :: AgentClient -> UserId -> [SMPServer] -> AM SMPServerWithAuth
getNextSMPServer AgentClient
c UserId
userId = AgentClient
-> UserId
-> (UserServers 'PSMP
    -> NonEmpty (Maybe UserId, SMPServerWithAuth))
-> [SMPServer]
-> AM 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)
storageSrvs
{-# INLINE getNextSMPServer #-}

subscriber :: AgentClient -> AM' ()
subscriber :: AgentClient -> ReaderT Env IO ()
subscriber c :: AgentClient
c@AgentClient {TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
$sel:msgQ:AgentClient :: AgentClient
-> TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
msgQ, TBQueue ATransmission
$sel:subQ:AgentClient :: AgentClient -> TBQueue ATransmission
subQ :: TBQueue ATransmission
subQ} = ReaderT Env IO () -> ReaderT Env IO ()
run (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ do
  ((UserId, SMPServer, Maybe ConnId), Version SMPVersion, ConnId,
 NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg))
t <- STM
  ((UserId, SMPServer, Maybe ConnId), Version SMPVersion, ConnId,
   NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg))
-> ReaderT
     Env
     IO
     ((UserId, SMPServer, Maybe ConnId), Version SMPVersion, ConnId,
      NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM
   ((UserId, SMPServer, Maybe ConnId), Version SMPVersion, ConnId,
    NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg))
 -> ReaderT
      Env
      IO
      ((UserId, SMPServer, Maybe ConnId), Version SMPVersion, ConnId,
       NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg)))
-> STM
     ((UserId, SMPServer, Maybe ConnId), Version SMPVersion, ConnId,
      NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg))
-> ReaderT
     Env
     IO
     ((UserId, SMPServer, Maybe ConnId), Version SMPVersion, ConnId,
      NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg))
forall a b. (a -> b) -> a -> b
$ TBQueue
  ((UserId, SMPServer, Maybe ConnId), Version SMPVersion, ConnId,
   NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg))
-> STM
     ((UserId, SMPServer, Maybe ConnId), Version SMPVersion, ConnId,
      NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg))
forall a. TBQueue a -> STM a
readTBQueue TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)
TBQueue
  ((UserId, SMPServer, Maybe ConnId), Version SMPVersion, ConnId,
   NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg))
msgQ
  AgentClient
-> AgentOperation
-> (AgentClient -> IO ())
-> ReaderT Env IO ()
-> ReaderT Env IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
AgentClient
-> AgentOperation -> (AgentClient -> IO ()) -> m a -> m a
agentOperationBracket AgentClient
c AgentOperation
AORcvNetwork AgentClient -> IO ()
waitUntilActive (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$
    AgentClient
-> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg
-> ReaderT Env IO ()
processSMPTransmissions AgentClient
c ServerTransmissionBatch SMPVersion ErrorType BrokerMsg
((UserId, SMPServer, Maybe ConnId), Version SMPVersion, ConnId,
 NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg))
t
  where
    run :: ReaderT Env IO () -> ReaderT Env IO ()
run ReaderT Env IO ()
a = ReaderT Env IO ()
a ReaderT Env IO ()
-> (SomeException -> ReaderT Env IO ()) -> ReaderT Env IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchOwn` \SomeException
e -> AgentErrorType -> ReaderT Env IO ()
notify (AgentErrorType -> ReaderT Env IO ())
-> AgentErrorType -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> AgentErrorType
CRITICAL Bool
True (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String
"Agent subscriber stopped: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e
    notify :: AgentErrorType -> ReaderT Env IO ()
notify AgentErrorType
err = 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
$ TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue ATransmission
subQ (ConnId
"", ConnId
"", 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
err)

cleanupManager :: AgentClient -> AM' ()
cleanupManager :: AgentClient -> ReaderT Env IO ()
cleanupManager c :: AgentClient
c@AgentClient {TBQueue ATransmission
$sel:subQ:AgentClient :: AgentClient -> TBQueue ATransmission
subQ :: TBQueue ATransmission
subQ} = do
  AgentConfig {UserId
initialCleanupDelay :: UserId
$sel:initialCleanupDelay:AgentConfig :: AgentConfig -> UserId
initialCleanupDelay, $sel:cleanupInterval:AgentConfig :: AgentConfig -> UserId
cleanupInterval = UserId
int, $sel:storedMsgDataTTL:AgentConfig :: AgentConfig -> NominalDiffTime
storedMsgDataTTL = NominalDiffTime
ttl, $sel:cleanupBatchSize:AgentConfig :: AgentConfig -> Int
cleanupBatchSize = Int
limit} <-
    (Env -> AgentConfig) -> ReaderT Env IO AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
  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
$ UserId -> IO ()
threadDelay' UserId
initialCleanupDelay
  ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO () -> ReaderT Env IO ()
forall a. ReaderT Env IO a -> ReaderT Env IO ()
waitActive (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ do
    (AgentErrorType -> AEvent 'AEConn)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent 'AEConn
ERR ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConns
    (AgentErrorType -> AEvent 'AEConn)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent 'AEConn
ERR (ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> NominalDiffTime -> Int -> IO ()
deleteRcvMsgHashesExpired Connection
db NominalDiffTime
ttl Int
limit
    (AgentErrorType -> AEvent 'AEConn)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent 'AEConn
ERR (ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> NominalDiffTime -> Int -> IO ()
deleteSndMsgsExpired Connection
db NominalDiffTime
ttl Int
limit
    (AgentErrorType -> AEvent 'AEConn)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent 'AEConn
ERR (ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> NominalDiffTime -> Int -> IO ()
deleteRatchetKeyHashesExpired Connection
db NominalDiffTime
ttl Int
limit
    (AgentErrorType -> AEvent 'AEConn)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent 'AEConn
ERR (ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> NominalDiffTime -> IO ()
`deleteExpiredNtfTokensToDelete` NominalDiffTime
ttl)
    (AgentErrorType -> AEvent 'AERcvFile)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent 'AERcvFile
RFERR ExceptT AgentErrorType (ReaderT Env IO) ()
deleteRcvFilesExpired
    (AgentErrorType -> AEvent 'AERcvFile)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent 'AERcvFile
RFERR ExceptT AgentErrorType (ReaderT Env IO) ()
deleteRcvFilesDeleted
    (AgentErrorType -> AEvent 'AERcvFile)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent 'AERcvFile
RFERR ExceptT AgentErrorType (ReaderT Env IO) ()
deleteRcvFilesTmpPaths
    (AgentErrorType -> AEvent 'AESndFile)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent 'AESndFile
SFERR ExceptT AgentErrorType (ReaderT Env IO) ()
deleteSndFilesExpired
    (AgentErrorType -> AEvent 'AESndFile)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent 'AESndFile
SFERR ExceptT AgentErrorType (ReaderT Env IO) ()
deleteSndFilesDeleted
    (AgentErrorType -> AEvent 'AESndFile)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent 'AESndFile
SFERR ExceptT AgentErrorType (ReaderT Env IO) ()
deleteSndFilesPrefixPaths
    (AgentErrorType -> AEvent 'AESndFile)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent 'AESndFile
SFERR ExceptT AgentErrorType (ReaderT Env IO) ()
deleteExpiredReplicasForDeletion
    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
$ UserId -> IO ()
threadDelay' UserId
int
  where
    run :: forall e. AEntityI e => (AgentErrorType -> AEvent e) -> AM () -> AM' ()
    run :: forall (e :: AEntity).
AEntityI e =>
(AgentErrorType -> AEvent e)
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
run AgentErrorType -> AEvent e
err ExceptT AgentErrorType (ReaderT Env IO) ()
a = do
      ReaderT Env IO (Either AgentErrorType ()) -> ReaderT Env IO ()
forall a. ReaderT Env IO a -> ReaderT Env IO ()
waitActive (ReaderT Env IO (Either AgentErrorType ()) -> ReaderT Env IO ())
-> (ExceptT AgentErrorType (ReaderT Env IO) ()
    -> ReaderT Env IO (Either AgentErrorType ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT AgentErrorType (ReaderT Env IO) ()
-> ReaderT Env IO (Either AgentErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ ExceptT AgentErrorType (ReaderT Env IO) ()
a ExceptT AgentErrorType (ReaderT Env IO) ()
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` (ConnId -> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
ConnId -> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify ConnId
"" (AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> AEvent e)
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent e
err)
      Int
step <- (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
cleanupStepInterval (AgentConfig -> Int) -> (Env -> AgentConfig) -> Env -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
      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
$ Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
step
    -- we are catching it to avoid CRITICAL errors in tests when this is the only remaining handle to active
    waitActive :: ReaderT Env IO a -> AM' ()
    waitActive :: forall a. ReaderT Env IO a -> ReaderT Env IO ()
waitActive ReaderT Env IO a
a = IO (Either SomeException ())
-> ReaderT Env IO (Either SomeException ())
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
E.tryAny (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ AgentClient -> IO ()
waitUntilActive AgentClient
c) ReaderT Env IO (Either SomeException ())
-> (Either SomeException () -> 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
>>= (SomeException -> ReaderT Env IO ())
-> (() -> ReaderT Env IO ())
-> Either SomeException ()
-> ReaderT Env IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\SomeException
_ -> () -> ReaderT Env IO ()
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\()
_ -> ReaderT Env IO a -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ReaderT Env IO a
a)
    deleteConns :: ExceptT AgentErrorType (ReaderT Env IO) ()
deleteConns =
      Lock
-> Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a.
MonadUnliftIO m =>
Lock -> Text -> ExceptT e m a -> ExceptT e m a
withLock (AgentClient -> Lock
deleteLock AgentClient
c) Text
"cleanupManager" (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
$ do
        AM (Map ConnId (Either AgentErrorType ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM (Map ConnId (Either AgentErrorType ()))
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (Map ConnId (Either AgentErrorType ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> (Connection -> IO [ConnId]) -> AM [ConnId]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO [ConnId]
getDeletedConnIds AM [ConnId]
-> ([ConnId] -> AM (Map ConnId (Either AgentErrorType ())))
-> AM (Map ConnId (Either AgentErrorType ()))
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
>>= AgentClient
-> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
deleteDeletedConns AgentClient
c
        AM (Map ConnId (Either AgentErrorType ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM (Map ConnId (Either AgentErrorType ()))
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (Map ConnId (Either AgentErrorType ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> (Connection -> IO [ConnId]) -> AM [ConnId]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO [ConnId]
getDeletedWaitingDeliveryConnIds AM [ConnId]
-> ([ConnId] -> AM (Map ConnId (Either AgentErrorType ())))
-> AM (Map ConnId (Either AgentErrorType ()))
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
>>= AgentClient
-> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
deleteDeletedWaitingDeliveryConns AgentClient
c
        AgentClient -> (Connection -> IO [UserId]) -> AM [UserId]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO [UserId]
deleteUsersWithoutConns AM [UserId]
-> ([UserId] -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> [UserId] -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ConnId
-> AEvent 'AENone -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
ConnId -> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify ConnId
"" (AEvent 'AENone -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (UserId -> AEvent 'AENone)
-> UserId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserId -> AEvent 'AENone
DEL_USER)
    deleteRcvFilesExpired :: ExceptT AgentErrorType (ReaderT Env IO) ()
deleteRcvFilesExpired = do
      NominalDiffTime
rcvFilesTTL <- (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
rcvFilesTTL (AgentConfig -> NominalDiffTime)
-> (Env -> AgentConfig) -> Env -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
      [(UserId, ConnId, String)]
rcvExpired <- AgentClient
-> (Connection -> IO [(UserId, ConnId, String)])
-> AM [(UserId, ConnId, String)]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> NominalDiffTime -> IO [(UserId, ConnId, String)]
`getRcvFilesExpired` NominalDiffTime
rcvFilesTTL)
      [(UserId, ConnId, String)]
-> ((UserId, ConnId, String)
    -> 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_ [(UserId, ConnId, String)]
rcvExpired (((UserId, ConnId, String)
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((UserId, ConnId, String)
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \(UserId
dbId, ConnId
entId, String
p) -> (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT AgentErrorType (ReaderT Env IO) ()
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catchAllErrors (ConnId
-> AEvent 'AERcvFile -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
ConnId -> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify ConnId
entId (AEvent 'AERcvFile -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> AEvent 'AERcvFile)
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AERcvFile
RFERR) (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
$ do
        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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ReaderT Env IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removePath (String -> ReaderT Env IO ())
-> ReaderT Env IO String -> ReaderT Env IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> ReaderT Env IO String
toFSFilePath String
p
        AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> UserId -> IO ()
`deleteRcvFile'` UserId
dbId)
    deleteRcvFilesDeleted :: ExceptT AgentErrorType (ReaderT Env IO) ()
deleteRcvFilesDeleted = do
      [(UserId, ConnId, String)]
rcvDeleted <- AgentClient
-> (Connection -> IO [(UserId, ConnId, String)])
-> AM [(UserId, ConnId, String)]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO [(UserId, ConnId, String)]
getCleanupRcvFilesDeleted
      [(UserId, ConnId, String)]
-> ((UserId, ConnId, String)
    -> 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_ [(UserId, ConnId, String)]
rcvDeleted (((UserId, ConnId, String)
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((UserId, ConnId, String)
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \(UserId
dbId, ConnId
entId, String
p) -> (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT AgentErrorType (ReaderT Env IO) ()
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catchAllErrors (ConnId
-> AEvent 'AERcvFile -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
ConnId -> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify ConnId
entId (AEvent 'AERcvFile -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> AEvent 'AERcvFile)
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AERcvFile
RFERR) (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
$ do
        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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ReaderT Env IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removePath (String -> ReaderT Env IO ())
-> ReaderT Env IO String -> ReaderT Env IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> ReaderT Env IO String
toFSFilePath String
p
        AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> UserId -> IO ()
`deleteRcvFile'` UserId
dbId)
    deleteRcvFilesTmpPaths :: ExceptT AgentErrorType (ReaderT Env IO) ()
deleteRcvFilesTmpPaths = do
      [(UserId, ConnId, String)]
rcvTmpPaths <- AgentClient
-> (Connection -> IO [(UserId, ConnId, String)])
-> AM [(UserId, ConnId, String)]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO [(UserId, ConnId, String)]
getCleanupRcvFilesTmpPaths
      [(UserId, ConnId, String)]
-> ((UserId, ConnId, String)
    -> 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_ [(UserId, ConnId, String)]
rcvTmpPaths (((UserId, ConnId, String)
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((UserId, ConnId, String)
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \(UserId
dbId, ConnId
entId, String
p) -> (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT AgentErrorType (ReaderT Env IO) ()
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catchAllErrors (ConnId
-> AEvent 'AERcvFile -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
ConnId -> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify ConnId
entId (AEvent 'AERcvFile -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> AEvent 'AERcvFile)
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AERcvFile
RFERR) (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
$ do
        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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ReaderT Env IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removePath (String -> ReaderT Env IO ())
-> ReaderT Env IO String -> ReaderT Env IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> ReaderT Env IO String
toFSFilePath String
p
        AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> UserId -> IO ()
`updateRcvFileNoTmpPath` UserId
dbId)
    deleteSndFilesExpired :: ExceptT AgentErrorType (ReaderT Env IO) ()
deleteSndFilesExpired = do
      NominalDiffTime
sndFilesTTL <- (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
sndFilesTTL (AgentConfig -> NominalDiffTime)
-> (Env -> AgentConfig) -> Env -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
      [(UserId, ConnId, Maybe String)]
sndExpired <- AgentClient
-> (Connection -> IO [(UserId, ConnId, Maybe String)])
-> AM [(UserId, ConnId, Maybe String)]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection
-> NominalDiffTime -> IO [(UserId, ConnId, Maybe String)]
`getSndFilesExpired` NominalDiffTime
sndFilesTTL)
      [(UserId, ConnId, Maybe String)]
-> ((UserId, ConnId, Maybe String)
    -> 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_ [(UserId, ConnId, Maybe String)]
sndExpired (((UserId, ConnId, Maybe String)
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((UserId, ConnId, Maybe String)
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \(UserId
dbId, ConnId
entId, Maybe String
p) -> (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT AgentErrorType (ReaderT Env IO) ()
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catchAllErrors (ConnId
-> AEvent 'AESndFile -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
ConnId -> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify ConnId
entId (AEvent 'AESndFile -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> AEvent 'AESndFile)
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AESndFile
SFERR) (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
$ do
        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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((String -> ReaderT Env IO ()) -> ReaderT Env IO ())
-> (String -> ReaderT Env IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> (String -> ReaderT Env IO ()) -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
p ((String -> ReaderT Env IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (String -> ReaderT Env IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ReaderT Env IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removePath (String -> ReaderT Env IO ())
-> (String -> ReaderT Env IO String) -> String -> ReaderT Env IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> ReaderT Env IO String
toFSFilePath
        AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> UserId -> IO ()
`deleteSndFile'` UserId
dbId)
    deleteSndFilesDeleted :: ExceptT AgentErrorType (ReaderT Env IO) ()
deleteSndFilesDeleted = do
      [(UserId, ConnId, Maybe String)]
sndDeleted <- AgentClient
-> (Connection -> IO [(UserId, ConnId, Maybe String)])
-> AM [(UserId, ConnId, Maybe String)]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO [(UserId, ConnId, Maybe String)]
getCleanupSndFilesDeleted
      [(UserId, ConnId, Maybe String)]
-> ((UserId, ConnId, Maybe String)
    -> 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_ [(UserId, ConnId, Maybe String)]
sndDeleted (((UserId, ConnId, Maybe String)
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((UserId, ConnId, Maybe String)
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \(UserId
dbId, ConnId
entId, Maybe String
p) -> (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT AgentErrorType (ReaderT Env IO) ()
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catchAllErrors (ConnId
-> AEvent 'AESndFile -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
ConnId -> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify ConnId
entId (AEvent 'AESndFile -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> AEvent 'AESndFile)
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AESndFile
SFERR) (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
$ do
        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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((String -> ReaderT Env IO ()) -> ReaderT Env IO ())
-> (String -> ReaderT Env IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> (String -> ReaderT Env IO ()) -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
p ((String -> ReaderT Env IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (String -> ReaderT Env IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ReaderT Env IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removePath (String -> ReaderT Env IO ())
-> (String -> ReaderT Env IO String) -> String -> ReaderT Env IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> ReaderT Env IO String
toFSFilePath
        AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> UserId -> IO ()
`deleteSndFile'` UserId
dbId)
    deleteSndFilesPrefixPaths :: ExceptT AgentErrorType (ReaderT Env IO) ()
deleteSndFilesPrefixPaths = do
      [(UserId, ConnId, String)]
sndPrefixPaths <- AgentClient
-> (Connection -> IO [(UserId, ConnId, String)])
-> AM [(UserId, ConnId, String)]
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c Connection -> IO [(UserId, ConnId, String)]
getCleanupSndFilesPrefixPaths
      [(UserId, ConnId, String)]
-> ((UserId, ConnId, String)
    -> 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_ [(UserId, ConnId, String)]
sndPrefixPaths (((UserId, ConnId, String)
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((UserId, ConnId, String)
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \(UserId
dbId, ConnId
entId, String
p) -> (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT AgentErrorType (ReaderT Env IO) ()
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catchAllErrors (ConnId
-> AEvent 'AESndFile -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity).
AEntityI e =>
ConnId -> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify ConnId
entId (AEvent 'AESndFile -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> AEvent 'AESndFile)
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AESndFile
SFERR) (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
$ do
        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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ReaderT Env IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removePath (String -> ReaderT Env IO ())
-> ReaderT Env IO String -> ReaderT Env IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> ReaderT Env IO String
toFSFilePath String
p
        AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> UserId -> IO ()
`updateSndFileNoPrefixPath` UserId
dbId)
    deleteExpiredReplicasForDeletion :: ExceptT AgentErrorType (ReaderT Env IO) ()
deleteExpiredReplicasForDeletion = do
      NominalDiffTime
rcvFilesTTL <- (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
rcvFilesTTL (AgentConfig -> NominalDiffTime)
-> (Env -> AgentConfig) -> Env -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
      AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (Connection -> NominalDiffTime -> IO ()
`deleteDeletedSndChunkReplicasExpired` NominalDiffTime
rcvFilesTTL)
    notify :: forall e. AEntityI e => AEntityId -> AEvent e -> AM ()
    notify :: forall (e :: AEntity).
AEntityI e =>
ConnId -> AEvent e -> ExceptT AgentErrorType (ReaderT Env IO) ()
notify ConnId
entId AEvent e
cmd = 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
$ TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue ATransmission
subQ (ConnId
"", ConnId
entId, 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)

data ACKd = ACKd | ACKPending

-- | Make sure to ACK or throw in each message processing branch
-- It cannot be finally, as sometimes it needs to be ACK+DEL,
-- and sometimes ACK has to be sent from the consumer.
processSMPTransmissions :: AgentClient -> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> AM' ()
processSMPTransmissions :: AgentClient
-> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg
-> ReaderT Env IO ()
processSMPTransmissions c :: AgentClient
c@AgentClient {TBQueue ATransmission
$sel:subQ:AgentClient :: AgentClient -> TBQueue ATransmission
subQ :: TBQueue ATransmission
subQ} (tSess :: TransportSession BrokerMsg
tSess@(UserId
userId, ProtoServer BrokerMsg
srv, Maybe ConnId
_), Version SMPVersion
_v, ConnId
sessId, NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg)
ts) = do
  TVar [ConnId]
upConnIds <- [ConnId] -> ReaderT Env IO (TVar [ConnId])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
  NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg)
-> ((QueueId, ServerTransmission ErrorType BrokerMsg)
    -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (QueueId, ServerTransmission ErrorType BrokerMsg)
ts (((QueueId, ServerTransmission ErrorType BrokerMsg)
  -> ReaderT Env IO ())
 -> ReaderT Env IO ())
-> ((QueueId, ServerTransmission ErrorType BrokerMsg)
    -> ReaderT Env IO ())
-> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ \(QueueId
entId, ServerTransmission ErrorType BrokerMsg
t) -> case ServerTransmission ErrorType BrokerMsg
t of
    STEvent Either (ProtocolClientError ErrorType) BrokerMsg
msgOrErr ->
      QueueId
-> (forall (c :: ConnType).
    RcvQueue
    -> Connection c -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO ()
withRcvConn QueueId
entId ((forall (c :: ConnType).
  RcvQueue
  -> Connection c -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ReaderT Env IO ())
-> (forall (c :: ConnType).
    RcvQueue
    -> Connection c -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ \rq :: RcvQueue
rq@RcvQueue {ConnId
$sel:connId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> ConnId
connId :: ConnId
connId} Connection c
conn -> case Either (ProtocolClientError ErrorType) BrokerMsg
msgOrErr of
        Right BrokerMsg
msg -> RcvQueue
-> Connection c
-> ConnData
-> BrokerMsg
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (c :: ConnType).
RcvQueue
-> Connection c
-> ConnData
-> BrokerMsg
-> ExceptT AgentErrorType (ReaderT Env IO) ()
runProcessSMP RcvQueue
rq Connection c
conn (Connection c -> ConnData
forall (d :: ConnType) rq sq. Connection' d rq sq -> ConnData
toConnData Connection c
conn) BrokerMsg
msg
        Left ProtocolClientError ErrorType
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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ do
          RcvQueue -> ProtocolClientError ErrorType -> ReaderT Env IO ()
processClientNotice RcvQueue
rq ProtocolClientError ErrorType
e
          ConnId -> ProtocolClientError ErrorType -> ReaderT Env IO ()
notifyErr ConnId
connId ProtocolClientError ErrorType
e
    STResponse (Cmd SParty p
SRecipient Command p
cmd) Either (ProtocolClientError ErrorType) BrokerMsg
respOrErr ->
      QueueId
-> (forall (c :: ConnType).
    RcvQueue
    -> Connection c -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO ()
withRcvConn QueueId
entId ((forall (c :: ConnType).
  RcvQueue
  -> Connection c -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ReaderT Env IO ())
-> (forall (c :: ConnType).
    RcvQueue
    -> Connection c -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ \RcvQueue
rq Connection c
conn -> case Command p
cmd of
        Command p
SMP.SUB -> case Either (ProtocolClientError ErrorType) BrokerMsg
respOrErr of
          Right BrokerMsg
SMP.OK -> 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
$ RcvQueue -> TVar [ConnId] -> IO ()
processSubOk RcvQueue
rq TVar [ConnId]
upConnIds
          -- TODO [certs rcv] associate queue with the service
          Right (SMP.SOK Maybe QueueId
serviceId_) -> 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
$ RcvQueue -> TVar [ConnId] -> IO ()
processSubOk RcvQueue
rq TVar [ConnId]
upConnIds
          Right msg :: BrokerMsg
msg@SMP.MSG {} -> do
            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
$ RcvQueue -> TVar [ConnId] -> IO ()
processSubOk RcvQueue
rq TVar [ConnId]
upConnIds -- the connection is UP even when processing this particular message fails
            RcvQueue
-> Connection c
-> ConnData
-> BrokerMsg
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (c :: ConnType).
RcvQueue
-> Connection c
-> ConnData
-> BrokerMsg
-> ExceptT AgentErrorType (ReaderT Env IO) ()
runProcessSMP RcvQueue
rq Connection c
conn (Connection c -> ConnData
forall (d :: ConnType) rq sq. Connection' d rq sq -> ConnData
toConnData Connection c
conn) BrokerMsg
msg
          Right BrokerMsg
r -> 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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ RcvQueue -> ProtocolClientError ErrorType -> ReaderT Env IO ()
processSubErr RcvQueue
rq (ProtocolClientError ErrorType -> ReaderT Env IO ())
-> ProtocolClientError ErrorType -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> ProtocolClientError ErrorType
forall r err. Show r => r -> ProtocolClientError err
unexpectedResponse BrokerMsg
r
          Left ProtocolClientError ErrorType
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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ Bool -> ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ProtocolClientError ErrorType -> Bool
forall err. ProtocolClientError err -> Bool
temporaryClientError ProtocolClientError ErrorType
e) (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ RcvQueue -> ProtocolClientError ErrorType -> ReaderT Env IO ()
processSubErr RcvQueue
rq ProtocolClientError ErrorType
e -- timeout/network was already reported
        SMP.ACK ConnId
_ -> case Either (ProtocolClientError ErrorType) BrokerMsg
respOrErr of
          Right msg :: BrokerMsg
msg@SMP.MSG {} -> RcvQueue
-> Connection c
-> ConnData
-> BrokerMsg
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (c :: ConnType).
RcvQueue
-> Connection c
-> ConnData
-> BrokerMsg
-> ExceptT AgentErrorType (ReaderT Env IO) ()
runProcessSMP RcvQueue
rq Connection c
conn (Connection c -> ConnData
forall (d :: ConnType) rq sq. Connection' d rq sq -> ConnData
toConnData Connection c
conn) BrokerMsg
msg
          Either (ProtocolClientError ErrorType) BrokerMsg
_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- TODO process OK response to ACK
        Command p
_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- TODO process expired response to DEL
    STResponse {} -> () -> ReaderT Env IO ()
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- TODO process expired responses to sent messages
    STUnexpectedError ProtocolClientError ErrorType
e -> do
      ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ReaderT Env IO ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
entId (ConnId -> ReaderT Env IO ()) -> ConnId -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ ConnId
"error: " ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ProtocolClientError ErrorType -> ConnId
forall a. Show a => a -> ConnId
bshow ProtocolClientError ErrorType
e
      ConnId -> ProtocolClientError ErrorType -> ReaderT Env IO ()
notifyErr ConnId
"" ProtocolClientError ErrorType
e
  [ConnId]
connIds <- TVar [ConnId] -> ReaderT Env IO [ConnId]
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar [ConnId]
upConnIds
  Bool -> ReaderT Env IO () -> ReaderT Env IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ConnId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConnId]
connIds) (ReaderT Env IO () -> ReaderT Env IO ())
-> ReaderT Env IO () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ do
    ConnId -> AEvent 'AENone -> ReaderT Env IO ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
ConnId -> AEvent e -> m ()
notify' ConnId
"" (AEvent 'AENone -> ReaderT Env IO ())
-> AEvent 'AENone -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ SMPServer -> [ConnId] -> AEvent 'AENone
UP ProtoServer BrokerMsg
SMPServer
srv [ConnId]
connIds
    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
$ AgentClient
-> UserId
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> Int
-> STM ()
incSMPServerStat' AgentClient
c UserId
userId ProtoServer BrokerMsg
SMPServer
srv AgentSMPServerStats -> TVar Int
connSubscribed (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$ [ConnId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConnId]
connIds
  where
    withRcvConn :: SMP.RecipientId -> (forall c. RcvQueue -> Connection c -> AM ()) -> AM' ()
    withRcvConn :: QueueId
-> (forall (c :: ConnType).
    RcvQueue
    -> Connection c -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO ()
withRcvConn QueueId
rId forall (c :: ConnType).
RcvQueue
-> Connection c -> ExceptT AgentErrorType (ReaderT Env IO) ()
a = do
      ExceptT AgentErrorType (ReaderT Env IO) (RcvQueue, SomeConn)
-> ReaderT Env IO (Either AgentErrorType (RcvQueue, SomeConn))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (AgentClient
-> (Connection -> IO (Either StoreError (RcvQueue, SomeConn)))
-> ExceptT AgentErrorType (ReaderT Env IO) (RcvQueue, SomeConn)
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError (RcvQueue, SomeConn)))
 -> ExceptT AgentErrorType (ReaderT Env IO) (RcvQueue, SomeConn))
-> (Connection -> IO (Either StoreError (RcvQueue, SomeConn)))
-> ExceptT AgentErrorType (ReaderT Env IO) (RcvQueue, SomeConn)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> SMPServer
-> QueueId
-> IO (Either StoreError (RcvQueue, SomeConn))
getRcvConn Connection
db ProtoServer BrokerMsg
SMPServer
srv QueueId
rId) ReaderT Env IO (Either AgentErrorType (RcvQueue, SomeConn))
-> (Either AgentErrorType (RcvQueue, SomeConn)
    -> 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
        Left AgentErrorType
e -> ConnId -> AEvent 'AEConn -> ReaderT Env IO ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
ConnId -> AEvent e -> m ()
notify' ConnId
"" (AgentErrorType -> AEvent 'AEConn
ERR AgentErrorType
e)
        Right (rq :: RcvQueue
rq@RcvQueue {ConnId
$sel:connId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> ConnId
connId :: ConnId
connId}, SomeConn SConnType d
_ Connection' d RcvQueue SndQueue
conn) ->
          ExceptT AgentErrorType (ReaderT Env IO) ()
-> ReaderT Env IO (Either AgentErrorType ())
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (RcvQueue
-> Connection' d RcvQueue SndQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (c :: ConnType).
RcvQueue
-> Connection c -> ExceptT AgentErrorType (ReaderT Env IO) ()
a RcvQueue
rq Connection' d RcvQueue SndQueue
conn) ReaderT Env IO (Either AgentErrorType ())
-> (Either AgentErrorType () -> 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
            Left AgentErrorType
e -> ConnId -> AEvent 'AEConn -> ReaderT Env IO ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
ConnId -> AEvent e -> m ()
notify' ConnId
connId (AgentErrorType -> AEvent 'AEConn
ERR AgentErrorType
e)
            Right () -> () -> ReaderT Env IO ()
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    processSubOk :: RcvQueue -> TVar [ConnId] -> IO ()
    processSubOk :: RcvQueue -> TVar [ConnId] -> IO ()
processSubOk rq :: RcvQueue
rq@RcvQueue {ConnId
$sel:connId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> ConnId
connId :: ConnId
connId} TVar [ConnId]
upConnIds =
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> (STM () -> STM ()) -> STM () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (RcvQueue -> STM Bool
isPendingSub RcvQueue
rq) (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        TransportSession BrokerMsg
-> ConnId -> RcvQueueSub -> TSessionSubs -> STM ()
SS.addActiveSub TransportSession BrokerMsg
tSess ConnId
sessId (RcvQueue -> RcvQueueSub
rcvQueueSub RcvQueue
rq) (TSessionSubs -> STM ()) -> TSessionSubs -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TSessionSubs
currentSubs AgentClient
c
        TVar [ConnId] -> ([ConnId] -> [ConnId]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [ConnId]
upConnIds (ConnId
connId ConnId -> [ConnId] -> [ConnId]
forall a. a -> [a] -> [a]
:)
    processSubErr :: RcvQueue -> SMPClientError -> AM' ()
    processSubErr :: RcvQueue -> ProtocolClientError ErrorType -> ReaderT Env IO ()
processSubErr rq :: RcvQueue
rq@RcvQueue {ConnId
$sel:connId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> ConnId
connId :: ConnId
connId} ProtocolClientError ErrorType
e = do
      STM () -> ReaderT Env IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Env IO ())
-> (STM () -> STM ()) -> STM () -> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (RcvQueue -> STM Bool
isPendingSub RcvQueue
rq) (STM () -> ReaderT Env IO ()) -> STM () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$
        AgentClient
-> TransportSession BrokerMsg
-> RcvQueue
-> ProtocolClientError ErrorType
-> STM ()
forall q.
SomeRcvQueue q =>
AgentClient
-> TransportSession BrokerMsg
-> q
-> ProtocolClientError ErrorType
-> STM ()
failSubscription AgentClient
c TransportSession BrokerMsg
tSess RcvQueue
rq ProtocolClientError ErrorType
e STM () -> STM () -> STM ()
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AgentClient
-> UserId
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtoServer BrokerMsg
SMPServer
srv AgentSMPServerStats -> TVar Int
connSubErrs
      RcvQueue -> ProtocolClientError ErrorType -> ReaderT Env IO ()
processClientNotice RcvQueue
rq ProtocolClientError ErrorType
e
      ConnId -> ProtocolClientError ErrorType -> ReaderT Env IO ()
notifyErr ConnId
connId ProtocolClientError ErrorType
e
    isPendingSub :: RcvQueue -> STM Bool
    isPendingSub :: RcvQueue -> STM Bool
isPendingSub RcvQueue
rq = do
      Bool
pending <- Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> STM Bool -> STM (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TransportSession BrokerMsg -> QueueId -> TSessionSubs -> STM Bool
SS.hasPendingSub TransportSession BrokerMsg
tSess (RcvQueue -> QueueId
forall q. SMPQueue q => q -> QueueId
queueId RcvQueue
rq) (AgentClient -> TSessionSubs
currentSubs AgentClient
c) STM (Bool -> Bool) -> STM Bool -> STM Bool
forall a b. STM (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AgentClient -> TransportSession BrokerMsg -> ConnId -> STM Bool
activeClientSession AgentClient
c TransportSession BrokerMsg
tSess ConnId
sessId
      Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
pending (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> UserId
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtoServer BrokerMsg
SMPServer
srv AgentSMPServerStats -> TVar Int
connSubIgnored
      Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
pending
    processClientNotice :: RcvQueue -> ProtocolClientError ErrorType -> ReaderT Env IO ()
processClientNotice RcvQueue
rq ProtocolClientError ErrorType
e =
      Maybe (Maybe ClientNotice)
-> (Maybe ClientNotice -> ReaderT Env IO ()) -> ReaderT Env IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ProtocolClientError ErrorType -> Maybe (Maybe ClientNotice)
smpErrorClientNotice ProtocolClientError ErrorType
e) ((Maybe ClientNotice -> ReaderT Env IO ()) -> ReaderT Env IO ())
-> (Maybe ClientNotice -> ReaderT Env IO ()) -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe ClientNotice
notice_ ->
        ReaderT Env IO ()
-> ReaderT Env IO () -> ReaderT Env IO () -> ReaderT Env IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
E.bracket_
          (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 () -> STM ()
forall a. TMVar a -> STM a
takeTMVar (TMVar () -> STM ()) -> TMVar () -> STM ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> TMVar ()
clientNoticesLock AgentClient
c)
          (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 () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (AgentClient -> TMVar ()
clientNoticesLock AgentClient
c) ())
          (AgentClient
-> TransportSession BrokerMsg
-> [(RcvQueueSub, Maybe ClientNotice)]
-> ReaderT Env IO ()
processClientNotices AgentClient
c TransportSession BrokerMsg
tSess [(RcvQueue -> RcvQueueSub
rcvQueueSub RcvQueue
rq, Maybe ClientNotice
notice_)])
    notify' :: forall e m. (AEntityI e, MonadIO m) => ConnId -> AEvent e -> m ()
    notify' :: forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
ConnId -> AEvent e -> m ()
notify' ConnId
connId AEvent e
msg = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue ATransmission
subQ (ConnId
"", ConnId
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
msg)
    notifyErr :: ConnId -> SMPClientError -> AM' ()
    notifyErr :: ConnId -> ProtocolClientError ErrorType -> ReaderT Env IO ()
notifyErr ConnId
connId = ConnId -> AEvent 'AEConn -> ReaderT Env IO ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
ConnId -> AEvent e -> m ()
notify' ConnId
connId (AEvent 'AEConn -> ReaderT Env IO ())
-> (ProtocolClientError ErrorType -> AEvent 'AEConn)
-> ProtocolClientError ErrorType
-> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> AEvent 'AEConn)
-> (ProtocolClientError ErrorType -> AgentErrorType)
-> ProtocolClientError ErrorType
-> AEvent 'AEConn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ErrorType -> AgentErrorType)
-> String -> ProtocolClientError ErrorType -> AgentErrorType
forall err.
(Show err, Encoding err) =>
(String -> err -> AgentErrorType)
-> String -> ProtocolClientError err -> AgentErrorType
protocolClientError String -> ErrorType -> AgentErrorType
SMP (ConnId -> String
B.unpack (ConnId -> String) -> ConnId -> String
forall a b. (a -> b) -> a -> b
$ SMPServer -> ConnId
forall a. StrEncoding a => a -> ConnId
strEncode ProtoServer BrokerMsg
SMPServer
srv)
    runProcessSMP :: RcvQueue -> Connection c -> ConnData -> BrokerMsg -> AM ()
    runProcessSMP :: forall (c :: ConnType).
RcvQueue
-> Connection c
-> ConnData
-> BrokerMsg
-> ExceptT AgentErrorType (ReaderT Env IO) ()
runProcessSMP RcvQueue
rq Connection c
conn ConnData
cData BrokerMsg
msg = do
      TVar [ATransmission]
pending <- [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar [ATransmission])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
      RcvQueue
-> Connection c
-> ConnData
-> BrokerMsg
-> TVar [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (c :: ConnType).
RcvQueue
-> Connection c
-> ConnData
-> BrokerMsg
-> TVar [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
processSMP RcvQueue
rq Connection c
conn ConnData
cData BrokerMsg
msg TVar [ATransmission]
pending
      (ATransmission -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> [ATransmission] -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ATransmission -> STM ())
-> ATransmission
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue ATransmission
subQ) ([ATransmission] -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ([ATransmission] -> [ATransmission])
-> [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ATransmission] -> [ATransmission]
forall a. [a] -> [a]
reverse ([ATransmission] -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) [ATransmission]
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar [ATransmission]
pending
    processSMP :: forall c. RcvQueue -> Connection c -> ConnData -> BrokerMsg -> TVar [ATransmission] -> AM ()
    processSMP :: forall (c :: ConnType).
RcvQueue
-> Connection c
-> ConnData
-> BrokerMsg
-> TVar [ATransmission]
-> ExceptT AgentErrorType (ReaderT Env IO) ()
processSMP
      rq :: RcvQueue
rq@RcvQueue {$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueId
rcvId = QueueId
rId, Maybe QueueMode
queueMode :: Maybe QueueMode
$sel:queueMode:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Maybe QueueMode
queueMode, PrivateKey 'X25519
e2ePrivKey :: PrivateKey 'X25519
$sel:e2ePrivKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> PrivateKey 'X25519
e2ePrivKey, Maybe DhSecretX25519
e2eDhSecret :: Maybe DhSecretX25519
$sel:e2eDhSecret:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Maybe DhSecretX25519
e2eDhSecret, QueueStatus
$sel:status:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueStatus
status :: QueueStatus
status, $sel:smpClientVersion:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> VersionSMPC
smpClientVersion = VersionSMPC
agreedClientVerion}
      Connection c
conn
      cData :: ConnData
cData@ConnData {ConnId
$sel:connId:ConnData :: ConnData -> ConnId
connId :: ConnId
connId, $sel:connAgentVersion:ConnData :: ConnData -> VersionSMPA
connAgentVersion = VersionSMPA
agreedAgentVersion, $sel:ratchetSyncState:ConnData :: ConnData -> RatchetSyncState
ratchetSyncState = RatchetSyncState
rss}
      BrokerMsg
smpMsg
      TVar [ATransmission]
pendingMsgs =
        AgentClient
-> ConnId
-> Text
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> ConnId -> Text -> AM a -> AM a
withConnLock AgentClient
c ConnId
connId Text
"processSMP" (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
$ case BrokerMsg
smpMsg of
          SMP.MSG msg :: RcvMessage
msg@SMP.RcvMessage {$sel:msgId:RcvMessage :: RcvMessage -> ConnId
msgId = ConnId
srvMsgId} -> 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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtoServer BrokerMsg
SMPServer
srv AgentSMPServerStats -> TVar Int
recvMsgs
            ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT AgentErrorType (ReaderT Env IO) ACKd
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (ExceptT AgentErrorType (ReaderT Env IO) ACKd
    -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
handleNotifyAck (ExceptT AgentErrorType (ReaderT Env IO) ACKd
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ do
              ClientRcvMsgBody
msg' <- RcvQueue -> RcvMessage -> AM ClientRcvMsgBody
decryptSMPMessage RcvQueue
rq RcvMessage
msg
              ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
handleNotifyAck (ExceptT AgentErrorType (ReaderT Env IO) ACKd
 -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall a b. (a -> b) -> a -> b
$ case ClientRcvMsgBody
msg' of
                SMP.ClientRcvMsgBody {$sel:msgTs:ClientRcvMsgBody :: ClientRcvMsgBody -> SystemTime
msgTs = SystemTime
srvTs, MsgFlags
msgFlags :: MsgFlags
$sel:msgFlags:ClientRcvMsgBody :: ClientRcvMsgBody -> MsgFlags
msgFlags, ConnId
msgBody :: ConnId
$sel:msgBody:ClientRcvMsgBody :: ClientRcvMsgBody -> ConnId
msgBody} -> SystemTime
-> MsgFlags
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
processClientMsg SystemTime
srvTs MsgFlags
msgFlags ConnId
msgBody
                SMP.ClientRcvMsgQuota {} -> ExceptT AgentErrorType (ReaderT Env IO) ()
queueDrained ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
            where
              queueDrained :: ExceptT AgentErrorType (ReaderT Env IO) ()
queueDrained = case Connection c
conn of
                DuplexConnection ConnData
_ NonEmpty RcvQueue
_ NonEmpty SndQueue
sqs -> AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM (UserId, PQEncryption)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> ConnData
-> NonEmpty SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessages AgentClient
c ConnData
cData NonEmpty SndQueue
sqs MsgFlags
SMP.noMsgFlags (AMessage -> AM (UserId, PQEncryption))
-> AMessage -> AM (UserId, PQEncryption)
forall a b. (a -> b) -> a -> b
$ (SMPServer, QueueId) -> AMessage
A_QCONT (RcvQueue -> (SMPServer, QueueId)
sndAddress RcvQueue
rq)
                Connection c
_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              processClientMsg :: SystemTime
-> MsgFlags
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
processClientMsg SystemTime
srvTs MsgFlags
msgFlags ConnId
msgBody = do
                clientMsg :: ClientMsgEnvelope
clientMsg@SMP.ClientMsgEnvelope {$sel:cmHeader:ClientMsgEnvelope :: ClientMsgEnvelope -> PubHeader
cmHeader = SMP.PubHeader VersionSMPC
phVer Maybe PublicKeyX25519
e2ePubKey_} <-
                  ConnId -> AM ClientMsgEnvelope
forall a. Encoding a => ConnId -> AM a
parseMessage ConnId
msgBody
                VersionRangeSMPC
clientVRange <- (Env -> VersionRangeSMPC)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> VersionRangeSMPC)
 -> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC)
-> (Env -> VersionRangeSMPC)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC
forall a b. (a -> b) -> a -> b
$ AgentConfig -> VersionRangeSMPC
smpClientVRange (AgentConfig -> VersionRangeSMPC)
-> (Env -> AgentConfig) -> Env -> VersionRangeSMPC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
                Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (VersionSMPC
phVer VersionSMPC -> VersionRangeSMPC -> Bool
forall v a. VersionI v a => a -> VersionRange v -> Bool
`isCompatible` VersionRangeSMPC
clientVRange Bool -> Bool -> Bool
|| VersionSMPC
phVer VersionSMPC -> VersionSMPC -> Bool
forall a. Ord a => a -> a -> Bool
<= VersionSMPC
agreedClientVerion) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION
                case (Maybe DhSecretX25519
e2eDhSecret, Maybe PublicKeyX25519
e2ePubKey_) of
                  (Maybe DhSecretX25519
Nothing, Just PublicKeyX25519
e2ePubKey) -> do
                    let e2eDh :: DhSecretX25519
e2eDh = PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecretX25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKeyX25519
e2ePubKey PrivateKey 'X25519
e2ePrivKey
                    DhSecretX25519
-> ClientMsgEnvelope -> AM (PrivHeader, AgentMsgEnvelope)
decryptClientMessage DhSecretX25519
e2eDh ClientMsgEnvelope
clientMsg AM (PrivHeader, AgentMsgEnvelope)
-> ((PrivHeader, AgentMsgEnvelope)
    -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
                      (SMP.PHConfirmation SndPublicAuthKey
senderKey, AgentConfirmation {Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_ :: Maybe (SndE2ERatchetParams 'X448)
$sel:e2eEncryption_:AgentConfirmation :: AgentMsgEnvelope -> Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_, ConnId
encConnInfo :: ConnId
$sel:encConnInfo:AgentConfirmation :: AgentMsgEnvelope -> ConnId
encConnInfo, VersionSMPA
$sel:agentVersion:AgentConfirmation :: AgentMsgEnvelope -> VersionSMPA
agentVersion :: VersionSMPA
agentVersion}) ->
                        ConnId
-> Connection c
-> Maybe SndPublicAuthKey
-> PublicKeyX25519
-> Maybe (SndE2ERatchetParams 'X448)
-> ConnId
-> VersionSMPC
-> VersionSMPA
-> ExceptT AgentErrorType (ReaderT Env IO) ()
smpConfirmation ConnId
srvMsgId Connection c
conn (SndPublicAuthKey -> Maybe SndPublicAuthKey
forall a. a -> Maybe a
Just SndPublicAuthKey
senderKey) PublicKeyX25519
e2ePubKey Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_ ConnId
encConnInfo VersionSMPC
phVer VersionSMPA
agentVersion ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                      (PrivHeader
SMP.PHEmpty, AgentConfirmation {Maybe (SndE2ERatchetParams 'X448)
$sel:e2eEncryption_:AgentConfirmation :: AgentMsgEnvelope -> Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_ :: Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_, ConnId
$sel:encConnInfo:AgentConfirmation :: AgentMsgEnvelope -> ConnId
encConnInfo :: ConnId
encConnInfo, VersionSMPA
$sel:agentVersion:AgentConfirmation :: AgentMsgEnvelope -> VersionSMPA
agentVersion :: VersionSMPA
agentVersion})
                        | Maybe QueueMode -> Bool
senderCanSecure Maybe QueueMode
queueMode -> ConnId
-> Connection c
-> Maybe SndPublicAuthKey
-> PublicKeyX25519
-> Maybe (SndE2ERatchetParams 'X448)
-> ConnId
-> VersionSMPC
-> VersionSMPA
-> ExceptT AgentErrorType (ReaderT Env IO) ()
smpConfirmation ConnId
srvMsgId Connection c
conn Maybe SndPublicAuthKey
forall a. Maybe a
Nothing PublicKeyX25519
e2ePubKey Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_ ConnId
encConnInfo VersionSMPC
phVer VersionSMPA
agentVersion ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                        | Bool
otherwise -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"handshake: missing sender key" ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                      (PrivHeader
SMP.PHEmpty, AgentInvitation {ConnectionRequestUri 'CMInvitation
connReq :: ConnectionRequestUri 'CMInvitation
$sel:connReq:AgentConfirmation :: AgentMsgEnvelope -> ConnectionRequestUri 'CMInvitation
connReq, ConnId
connInfo :: ConnId
$sel:connInfo:AgentConfirmation :: AgentMsgEnvelope -> ConnId
connInfo}) ->
                        ConnId
-> Connection c
-> ConnectionRequestUri 'CMInvitation
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
smpInvitation ConnId
srvMsgId Connection c
conn ConnectionRequestUri 'CMInvitation
connReq ConnId
connInfo ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                      (PrivHeader, AgentMsgEnvelope)
_ -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"handshake: incorrect state" ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                  (Just DhSecretX25519
e2eDh, Maybe PublicKeyX25519
Nothing) -> do
                    DhSecretX25519
-> ClientMsgEnvelope -> AM (PrivHeader, AgentMsgEnvelope)
decryptClientMessage DhSecretX25519
e2eDh ClientMsgEnvelope
clientMsg AM (PrivHeader, AgentMsgEnvelope)
-> ((PrivHeader, AgentMsgEnvelope)
    -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
                      (PrivHeader
SMP.PHEmpty, AgentRatchetKey {VersionSMPA
$sel:agentVersion:AgentConfirmation :: AgentMsgEnvelope -> VersionSMPA
agentVersion :: VersionSMPA
agentVersion, RcvE2ERatchetParams 'X448
e2eEncryption :: RcvE2ERatchetParams 'X448
$sel:e2eEncryption:AgentConfirmation :: AgentMsgEnvelope -> RcvE2ERatchetParams 'X448
e2eEncryption}) -> do
                        Connection c
conn' <- Connection c -> ConnData -> VersionSMPA -> AM (Connection c)
updateConnVersion Connection c
conn ConnData
cData VersionSMPA
agentVersion
                        Connection c
-> String
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall a.
Connection c -> String -> (Connection 'CDuplex -> AM a) -> AM a
qDuplex Connection c
conn' String
"AgentRatchetKey" ((Connection 'CDuplex
  -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
 -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall a b. (a -> b) -> a -> b
$ \Connection 'CDuplex
a -> RcvE2ERatchetParams 'X448
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ()
newRatchetKey RcvE2ERatchetParams 'X448
e2eEncryption Connection 'CDuplex
a ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                      (PrivHeader
SMP.PHEmpty, AgentMsgEnvelope {VersionSMPA
$sel:agentVersion:AgentConfirmation :: AgentMsgEnvelope -> VersionSMPA
agentVersion :: VersionSMPA
agentVersion, ConnId
$sel:encAgentMessage:AgentConfirmation :: AgentMsgEnvelope -> ConnId
encAgentMessage :: ConnId
encAgentMessage}) -> do
                        Connection c
conn' <- Connection c -> ConnData -> VersionSMPA -> AM (Connection c)
updateConnVersion Connection c
conn ConnData
cData VersionSMPA
agentVersion
                        -- primary queue is set as Active in helloMsg, below is to set additional queues Active
                        let RcvQueue {Bool
$sel:primary:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Bool
primary :: Bool
primary, Maybe UserId
$sel:dbReplaceQueueId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Maybe UserId
dbReplaceQueueId :: Maybe UserId
dbReplaceQueueId} = RcvQueue
rq
                        Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (QueueStatus
status QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
Active) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((Connection -> IO ())
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvQueue -> QueueStatus -> IO ()
setRcvQueueStatus Connection
db RcvQueue
rq QueueStatus
Active
                        case (Connection c
conn', Maybe UserId
dbReplaceQueueId) of
                          (DuplexConnection ConnData
_ NonEmpty RcvQueue
rqs NonEmpty SndQueue
_, Just UserId
replacedId) -> do
                            Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
primary (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ((Connection -> IO ())
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> RcvQueue -> IO ()
setRcvQueuePrimary Connection
db ConnId
connId RcvQueue
rq
                            case (RcvQueue -> Bool) -> NonEmpty RcvQueue -> Maybe RcvQueue
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((UserId
replacedId UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
==) (UserId -> Bool) -> (RcvQueue -> UserId) -> RcvQueue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RcvQueue -> UserId
forall q. SMPQueueRec q => q -> UserId
dbQId) NonEmpty RcvQueue
rqs of
                              Just rq' :: RcvQueue
rq'@RcvQueue {SMPServer
$sel:server:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> SMPServer
server :: SMPServer
server, QueueId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueId
rcvId :: QueueId
rcvId} -> do
                                RcvQueue
-> RcvSwitchStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkRQSwchStatus RcvQueue
rq' RcvSwitchStatus
RSSendingQUSE
                                AM RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM RcvQueue -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> (Connection -> IO RcvQueue) -> AM RcvQueue
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO RcvQueue) -> AM RcvQueue)
-> (Connection -> IO RcvQueue) -> AM RcvQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvQueue -> Maybe RcvSwitchStatus -> IO RcvQueue
setRcvSwitchStatus Connection
db RcvQueue
rq' (Maybe RcvSwitchStatus -> IO RcvQueue)
-> Maybe RcvSwitchStatus -> IO RcvQueue
forall a b. (a -> b) -> a -> b
$ RcvSwitchStatus -> Maybe RcvSwitchStatus
forall a. a -> Maybe a
Just RcvSwitchStatus
RSReceivedMessage
                                AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
"" ConnId
connId (SMPServer -> Maybe SMPServer
forall a. a -> Maybe a
Just SMPServer
server) (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ InternalCommand -> AgentCommand
AInternalCommand (InternalCommand -> AgentCommand)
-> InternalCommand -> AgentCommand
forall a b. (a -> b) -> a -> b
$ QueueId -> InternalCommand
ICQDelete QueueId
rcvId
                              Maybe RcvQueue
_ -> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPAgentError -> AEvent 'AEConn)
-> SMPAgentError
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> AEvent 'AEConn)
-> (SMPAgentError -> AgentErrorType)
-> SMPAgentError
-> AEvent 'AEConn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPAgentError -> AgentErrorType
AGENT (SMPAgentError -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> SMPAgentError -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> SMPAgentError
A_QUEUE String
"replaced RcvQueue not found in connection"
                          (Connection c, Maybe UserId)
_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        let encryptedMsgHash :: ConnId
encryptedMsgHash = ConnId -> ConnId
C.sha256Hash ConnId
encAgentMessage
                        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
                        ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either
        AgentErrorType
        (Maybe (InternalId, MsgMeta, AMessage, RatchetX448)))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors (TVar ChaChaDRG
-> ConnId
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
agentClientMsg TVar ChaChaDRG
g ConnId
encryptedMsgHash) ExceptT
  AgentErrorType
  (ReaderT Env IO)
  (Either
     AgentErrorType
     (Maybe (InternalId, MsgMeta, AMessage, RatchetX448)))
-> (Either
      AgentErrorType (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
    -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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 (Just (InternalId
msgId, MsgMeta
msgMeta, AMessage
aMessage, RatchetX448
rcPrev)) -> do
                            Connection c
conn'' <- AM (Connection c)
resetRatchetSync
                            case AMessage
aMessage of
                              AMessage
HELLO -> ConnId
-> MsgMeta
-> Connection c
-> ExceptT AgentErrorType (ReaderT Env IO) ()
helloMsg ConnId
srvMsgId MsgMeta
msgMeta Connection c
conn'' ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> InternalId -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ackDel InternalId
msgId
                              -- note that there is no ACK sent for A_MSG, it is sent with agent's user ACK command
                              A_MSG ConnId
body -> do
                                ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId
"MSG <MSG>:" ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId -> ConnId
logSecret' ConnId
srvMsgId
                                AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ MsgMeta -> MsgFlags -> ConnId -> AEvent 'AEConn
MSG MsgMeta
msgMeta MsgFlags
msgFlags ConnId
body
                                ACKd -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ACKd
ACKPending
                              A_RCVD NonEmpty AMessageReceipt
rcpts -> Connection c
-> String
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall a.
Connection c -> String -> (Connection 'CDuplex -> AM a) -> AM a
qDuplex Connection c
conn'' String
"RCVD" ((Connection 'CDuplex
  -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
 -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall a b. (a -> b) -> a -> b
$ NonEmpty AMessageReceipt
-> MsgMeta
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
messagesRcvd NonEmpty AMessageReceipt
rcpts MsgMeta
msgMeta
                              A_QCONT (SMPServer, QueueId)
addr -> Connection c
-> String
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
qDuplexAckDel Connection c
conn'' String
"QCONT" ((Connection 'CDuplex
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall a b. (a -> b) -> a -> b
$ ConnId
-> (SMPServer, QueueId)
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ()
continueSending ConnId
srvMsgId (SMPServer, QueueId)
addr
                              QADD NonEmpty (SMPQueueUri, Maybe (SMPServer, QueueId))
qs -> Connection c
-> String
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
qDuplexAckDel Connection c
conn'' String
"QADD" ((Connection 'CDuplex
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall a b. (a -> b) -> a -> b
$ ConnId
-> NonEmpty (SMPQueueUri, Maybe (SMPServer, QueueId))
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ()
qAddMsg ConnId
srvMsgId NonEmpty (SMPQueueUri, Maybe (SMPServer, QueueId))
qs
                              QKEY NonEmpty (SMPQueueInfo, SndPublicAuthKey)
qs -> Connection c
-> String
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
qDuplexAckDel Connection c
conn'' String
"QKEY" ((Connection 'CDuplex
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall a b. (a -> b) -> a -> b
$ ConnId
-> NonEmpty (SMPQueueInfo, SndPublicAuthKey)
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ()
qKeyMsg ConnId
srvMsgId NonEmpty (SMPQueueInfo, SndPublicAuthKey)
qs
                              QUSE NonEmpty ((SMPServer, QueueId), Bool)
qs -> Connection c
-> String
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
qDuplexAckDel Connection c
conn'' String
"QUSE" ((Connection 'CDuplex
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall a b. (a -> b) -> a -> b
$ ConnId
-> NonEmpty ((SMPServer, QueueId), Bool)
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ()
qUseMsg ConnId
srvMsgId NonEmpty ((SMPServer, QueueId), Bool)
qs
                              -- no action needed for QTEST
                              -- any message in the new queue will mark it active and trigger deletion of the old queue
                              QTEST NonEmpty (SMPServer, QueueId)
_ -> ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId (ConnId
"MSG <QTEST>:" ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId -> ConnId
logSecret' ConnId
srvMsgId) ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> InternalId -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ackDel InternalId
msgId
                              EREADY UserId
_ -> Connection c
-> String
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
qDuplexAckDel Connection c
conn'' String
"EREADY" ((Connection 'CDuplex
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall a b. (a -> b) -> a -> b
$ RatchetX448
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ()
ereadyMsg RatchetX448
rcPrev
                            where
                              qDuplexAckDel :: Connection c -> String -> (Connection 'CDuplex -> AM ()) -> AM ACKd
                              qDuplexAckDel :: Connection c
-> String
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
qDuplexAckDel Connection c
conn'' String
name Connection 'CDuplex -> ExceptT AgentErrorType (ReaderT Env IO) ()
a = Connection c
-> String
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a.
Connection c -> String -> (Connection 'CDuplex -> AM a) -> AM a
qDuplex Connection c
conn'' String
name Connection 'CDuplex -> ExceptT AgentErrorType (ReaderT Env IO) ()
a ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> InternalId -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ackDel InternalId
msgId
                              resetRatchetSync :: AM (Connection c)
                              resetRatchetSync :: AM (Connection c)
resetRatchetSync
                                | RatchetSyncState
rss RatchetSyncState -> [RatchetSyncState] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Item [RatchetSyncState]
RatchetSyncState
RSOk, Item [RatchetSyncState]
RatchetSyncState
RSStarted] :: [RatchetSyncState]) = do
                                    let cData'' :: ConnData
cData'' = (Connection c -> ConnData
forall (d :: ConnType) rq sq. Connection' d rq sq -> ConnData
toConnData Connection c
conn') {ratchetSyncState = RSOk} :: ConnData
                                        conn'' :: Connection c
conn'' = ConnData -> Connection c -> Connection c
forall (d :: ConnType) rq sq.
ConnData -> Connection' d rq sq -> Connection' d rq sq
updateConnection ConnData
cData'' Connection c
conn'
                                    ConnectionStats
cStats <- AgentClient -> Connection c -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection c
conn''
                                    AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ RatchetSyncState
-> Maybe AgentCryptoError -> ConnectionStats -> AEvent 'AEConn
RSYNC RatchetSyncState
RSOk Maybe AgentCryptoError
forall a. Maybe a
Nothing ConnectionStats
cStats
                                    AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> RatchetSyncState -> IO ()
setConnRatchetSync Connection
db ConnId
connId RatchetSyncState
RSOk
                                    Connection c -> AM (Connection c)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection c
conn''
                                | Bool
otherwise = Connection c -> AM (Connection c)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection c
conn'
                          Right Maybe (InternalId, MsgMeta, AMessage, RatchetX448)
Nothing -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"msg: bad agent msg" ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                          Left e :: AgentErrorType
e@(AGENT A_DUPLICATE {}) -> 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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtoServer BrokerMsg
SMPServer
srv AgentSMPServerStats -> TVar Int
recvDuplicates
                            AgentClient
-> (Connection -> IO (Maybe RcvMsg)) -> AM (Maybe RcvMsg)
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c (\Connection
db -> Connection -> ConnId -> ConnId -> IO (Maybe RcvMsg)
getLastMsg Connection
db ConnId
connId ConnId
srvMsgId) AM (Maybe RcvMsg)
-> (Maybe RcvMsg -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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 RcvMsg {InternalId
internalId :: InternalId
$sel:internalId:RcvMsg :: RcvMsg -> InternalId
internalId, MsgMeta
$sel:msgMeta:RcvMsg :: RcvMsg -> MsgMeta
msgMeta :: MsgMeta
msgMeta, $sel:msgBody:RcvMsg :: RcvMsg -> ConnId
msgBody = ConnId
agentMsgBody, Bool
userAck :: Bool
$sel:userAck:RcvMsg :: RcvMsg -> Bool
userAck}
                                | Bool
userAck -> InternalId -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ackDel InternalId
internalId
                                | Bool
otherwise -> do
                                    Int
attempts <- AgentClient -> (Connection -> IO Int) -> AM Int
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO Int) -> AM Int)
-> (Connection -> IO Int) -> AM Int
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> InternalId -> IO Int
incMsgRcvAttempts Connection
db ConnId
connId InternalId
internalId
                                    AgentConfig {Int
rcvExpireCount :: Int
$sel:rcvExpireCount:AgentConfig :: AgentConfig -> Int
rcvExpireCount, NominalDiffTime
rcvExpireInterval :: NominalDiffTime
$sel:rcvExpireInterval:AgentConfig :: AgentConfig -> NominalDiffTime
rcvExpireInterval} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
                                    let firstTs :: InternalTs
firstTs = (UserId, InternalTs) -> InternalTs
forall a b. (a, b) -> b
snd ((UserId, InternalTs) -> InternalTs)
-> (UserId, InternalTs) -> InternalTs
forall a b. (a -> b) -> a -> b
$ MsgMeta -> (UserId, InternalTs)
recipient MsgMeta
msgMeta
                                        brokerTs :: InternalTs
brokerTs = (ConnId, InternalTs) -> InternalTs
forall a b. (a, b) -> b
snd ((ConnId, InternalTs) -> InternalTs)
-> (ConnId, InternalTs) -> InternalTs
forall a b. (a -> b) -> a -> b
$ MsgMeta -> (ConnId, InternalTs)
broker MsgMeta
msgMeta
                                    InternalTs
now <- IO InternalTs -> ExceptT AgentErrorType (ReaderT Env IO) InternalTs
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO InternalTs
getCurrentTime
                                    if Int
attempts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
rcvExpireCount Bool -> Bool -> Bool
&& InternalTs -> InternalTs -> NominalDiffTime
diffUTCTime InternalTs
now InternalTs
firstTs NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
rcvExpireInterval
                                      then do
                                        AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> AEvent 'AEConn
ERR (SMPAgentError -> AgentErrorType
AGENT (SMPAgentError -> AgentErrorType)
-> SMPAgentError -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ Maybe DroppedMsg -> SMPAgentError
A_DUPLICATE (Maybe DroppedMsg -> SMPAgentError)
-> Maybe DroppedMsg -> SMPAgentError
forall a b. (a -> b) -> a -> b
$ DroppedMsg -> Maybe DroppedMsg
forall a. a -> Maybe a
Just DroppedMsg {InternalTs
brokerTs :: InternalTs
$sel:brokerTs:DroppedMsg :: InternalTs
brokerTs, Int
attempts :: Int
$sel:attempts:DroppedMsg :: Int
attempts})
                                        InternalId -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ackDel InternalId
internalId
                                      else
                                        Either AgentErrorType AgentMessage
-> ExceptT AgentErrorType (ReaderT Env IO) AgentMessage
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Parser AgentMessage
-> AgentErrorType -> ConnId -> Either AgentErrorType AgentMessage
forall a e. Parser a -> e -> ConnId -> Either e a
parse Parser AgentMessage
forall a. Encoding a => Parser a
smpP (SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_MESSAGE) ConnId
agentMsgBody) ExceptT AgentErrorType (ReaderT Env IO) AgentMessage
-> (AgentMessage -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
                                          AgentMessage APrivHeader
_ (A_MSG ConnId
body) -> do
                                            ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId
"MSG <MSG>:" ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId -> ConnId
logSecret' ConnId
srvMsgId
                                            AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ MsgMeta -> MsgFlags -> ConnId -> AEvent 'AEConn
MSG MsgMeta
msgMeta MsgFlags
msgFlags ConnId
body
                                            ACKd -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ACKd
ACKPending
                                          AgentMessage
_ -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                              Maybe RcvMsg
_ -> AgentErrorType
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkDuplicateHash AgentErrorType
e ConnId
encryptedMsgHash ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                          Left (AGENT (A_CRYPTO AgentCryptoError
e)) -> 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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtoServer BrokerMsg
SMPServer
srv AgentSMPServerStats -> TVar Int
recvCryptoErrs
                            Bool
exists <- AgentClient
-> (Connection -> IO Bool)
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO Bool)
 -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> (Connection -> IO Bool)
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> ConnId -> IO Bool
checkRcvMsgHashExists Connection
db ConnId
connId ConnId
encryptedMsgHash
                            Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists ExceptT AgentErrorType (ReaderT Env IO) ()
notifySync
                            ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                            where
                              notifySync :: AM ()
                              notifySync :: ExceptT AgentErrorType (ReaderT Env IO) ()
notifySync = Connection c
-> String
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a.
Connection c -> String -> (Connection 'CDuplex -> AM a) -> AM a
qDuplex Connection c
conn' String
"AGENT A_CRYPTO error" ((Connection 'CDuplex
  -> ExceptT AgentErrorType (ReaderT Env IO) ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection 'CDuplex
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection 'CDuplex
connDuplex -> do
                                let rss' :: RatchetSyncState
rss' = AgentCryptoError -> RatchetSyncState
cryptoErrToSyncState AgentCryptoError
e
                                Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RatchetSyncState
rss RatchetSyncState -> [RatchetSyncState] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Item [RatchetSyncState]
RatchetSyncState
RSOk, Item [RatchetSyncState]
RatchetSyncState
RSAllowed, Item [RatchetSyncState]
RatchetSyncState
RSRequired] :: [RatchetSyncState])) (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
$ do
                                  let cData'' :: ConnData
cData'' = (Connection c -> ConnData
forall (d :: ConnType) rq sq. Connection' d rq sq -> ConnData
toConnData Connection c
conn') {ratchetSyncState = rss'} :: ConnData
                                      conn'' :: Connection 'CDuplex
conn'' = ConnData -> Connection 'CDuplex -> Connection 'CDuplex
forall (d :: ConnType) rq sq.
ConnData -> Connection' d rq sq -> Connection' d rq sq
updateConnection ConnData
cData'' Connection 'CDuplex
connDuplex
                                  ConnectionStats
cStats <- AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection 'CDuplex
conn''
                                  AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ RatchetSyncState
-> Maybe AgentCryptoError -> ConnectionStats -> AEvent 'AEConn
RSYNC RatchetSyncState
rss' (AgentCryptoError -> Maybe AgentCryptoError
forall a. a -> Maybe a
Just AgentCryptoError
e) ConnectionStats
cStats
                                  AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> RatchetSyncState -> IO ()
setConnRatchetSync Connection
db ConnId
connId RatchetSyncState
rss'
                          Left AgentErrorType
e -> 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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtoServer BrokerMsg
SMPServer
srv AgentSMPServerStats -> TVar Int
recvErrs
                            AgentErrorType
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkDuplicateHash AgentErrorType
e ConnId
encryptedMsgHash ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                        where
                          checkDuplicateHash :: AgentErrorType -> ByteString -> AM ()
                          checkDuplicateHash :: AgentErrorType
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkDuplicateHash AgentErrorType
e ConnId
encryptedMsgHash =
                            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 (AgentClient
-> (Connection -> IO Bool)
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO Bool)
 -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> (Connection -> IO Bool)
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> ConnId -> IO Bool
checkRcvMsgHashExists Connection
db ConnId
connId ConnId
encryptedMsgHash) (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
e
                          agentClientMsg :: TVar ChaChaDRG -> ByteString -> AM (Maybe (InternalId, MsgMeta, AMessage, CR.RatchetX448))
                          agentClientMsg :: TVar ChaChaDRG
-> ConnId
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
agentClientMsg TVar ChaChaDRG
g ConnId
encryptedMsgHash = AgentClient
-> (Connection
    -> IO
         (Either
            StoreError (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection
  -> IO
       (Either
          StoreError (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))))
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (Maybe (InternalId, MsgMeta, AMessage, RatchetX448)))
-> (Connection
    -> IO
         (Either
            StoreError (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))))
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ExceptT
  StoreError IO (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
-> IO
     (Either
        StoreError (Maybe (InternalId, MsgMeta, AMessage, RatchetX448)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   StoreError IO (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
 -> IO
      (Either
         StoreError (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))))
-> ExceptT
     StoreError IO (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
-> IO
     (Either
        StoreError (Maybe (InternalId, MsgMeta, AMessage, RatchetX448)))
forall a b. (a -> b) -> a -> b
$ do
                            IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> IO ()
lockConnForUpdate Connection
db ConnId
connId
                            RatchetX448
rc <- IO (Either StoreError RatchetX448)
-> ExceptT StoreError IO RatchetX448
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError RatchetX448)
 -> ExceptT StoreError IO RatchetX448)
-> IO (Either StoreError RatchetX448)
-> ExceptT StoreError IO RatchetX448
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> IO (Either StoreError RatchetX448)
getRatchetForUpdate Connection
db ConnId
connId -- ratchet state pre-decryption - required for processing EREADY
                            (ConnId
agentMsgBody, PQEncryption
pqEncryption) <- TVar ChaChaDRG
-> Connection
-> ConnId
-> RatchetX448
-> ConnId
-> ExceptT StoreError IO (ConnId, PQEncryption)
agentRatchetDecrypt' TVar ChaChaDRG
g Connection
db ConnId
connId RatchetX448
rc ConnId
encAgentMessage
                            Either StoreError AgentMessage
-> ExceptT StoreError IO AgentMessage
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Parser AgentMessage
-> StoreError -> ConnId -> Either StoreError AgentMessage
forall a e. Parser a -> e -> ConnId -> Either e a
parse Parser AgentMessage
forall a. Encoding a => Parser a
smpP (AgentErrorType -> StoreError
SEAgentError (AgentErrorType -> StoreError) -> AgentErrorType -> StoreError
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_MESSAGE) ConnId
agentMsgBody) ExceptT StoreError IO AgentMessage
-> (AgentMessage
    -> ExceptT
         StoreError IO (Maybe (InternalId, MsgMeta, AMessage, RatchetX448)))
-> ExceptT
     StoreError IO (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
forall a b.
ExceptT StoreError IO a
-> (a -> ExceptT StoreError IO b) -> ExceptT StoreError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                              agentMsg :: AgentMessage
agentMsg@(AgentMessage APrivHeader {UserId
sndMsgId :: UserId
$sel:sndMsgId:APrivHeader :: APrivHeader -> UserId
sndMsgId, ConnId
prevMsgHash :: ConnId
$sel:prevMsgHash:APrivHeader :: APrivHeader -> ConnId
prevMsgHash} AMessage
aMessage) -> do
                                let msgType :: AgentMessageType
msgType = AgentMessage -> AgentMessageType
agentMessageType AgentMessage
agentMsg
                                    internalHash :: ConnId
internalHash = ConnId -> ConnId
C.sha256Hash ConnId
agentMsgBody
                                InternalTs
internalTs <- IO InternalTs -> ExceptT StoreError IO InternalTs
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO InternalTs
getCurrentTime
                                (InternalId
internalId, InternalRcvId
internalRcvId, UserId
prevExtSndId, ConnId
prevRcvMsgHash) <- IO (InternalId, InternalRcvId, UserId, ConnId)
-> ExceptT
     StoreError IO (InternalId, InternalRcvId, UserId, ConnId)
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InternalId, InternalRcvId, UserId, ConnId)
 -> ExceptT
      StoreError IO (InternalId, InternalRcvId, UserId, ConnId))
-> IO (InternalId, InternalRcvId, UserId, ConnId)
-> ExceptT
     StoreError IO (InternalId, InternalRcvId, UserId, ConnId)
forall a b. (a -> b) -> a -> b
$ Connection
-> ConnId -> IO (InternalId, InternalRcvId, UserId, ConnId)
updateRcvIds Connection
db ConnId
connId
                                let integrity :: MsgIntegrity
integrity = UserId -> UserId -> ConnId -> ConnId -> MsgIntegrity
checkMsgIntegrity UserId
prevExtSndId UserId
sndMsgId ConnId
prevRcvMsgHash ConnId
prevMsgHash
                                    recipient :: (UserId, InternalTs)
recipient = (InternalId -> UserId
unId InternalId
internalId, InternalTs
internalTs)
                                    broker :: (ConnId, InternalTs)
broker = (ConnId
srvMsgId, SystemTime -> InternalTs
systemToUTCTime SystemTime
srvTs)
                                    msgMeta :: MsgMeta
msgMeta = MsgMeta {MsgIntegrity
integrity :: MsgIntegrity
$sel:integrity:MsgMeta :: MsgIntegrity
integrity, (UserId, InternalTs)
$sel:recipient:MsgMeta :: (UserId, InternalTs)
recipient :: (UserId, InternalTs)
recipient, (ConnId, InternalTs)
$sel:broker:MsgMeta :: (ConnId, InternalTs)
broker :: (ConnId, InternalTs)
broker, UserId
$sel:sndMsgId:MsgMeta :: UserId
sndMsgId :: UserId
sndMsgId, PQEncryption
pqEncryption :: PQEncryption
$sel:pqEncryption:MsgMeta :: PQEncryption
pqEncryption}
                                    rcvMsg :: RcvMsgData
rcvMsg = RcvMsgData {MsgMeta
msgMeta :: MsgMeta
$sel:msgMeta:RcvMsgData :: MsgMeta
msgMeta, AgentMessageType
msgType :: AgentMessageType
$sel:msgType:RcvMsgData :: AgentMessageType
msgType, MsgFlags
msgFlags :: MsgFlags
$sel:msgFlags:RcvMsgData :: MsgFlags
msgFlags, $sel:msgBody:RcvMsgData :: ConnId
msgBody = ConnId
agentMsgBody, InternalRcvId
internalRcvId :: InternalRcvId
$sel:internalRcvId:RcvMsgData :: InternalRcvId
internalRcvId, ConnId
internalHash :: ConnId
$sel:internalHash:RcvMsgData :: ConnId
internalHash, $sel:externalPrevSndHash:RcvMsgData :: ConnId
externalPrevSndHash = ConnId
prevMsgHash, ConnId
encryptedMsgHash :: ConnId
$sel:encryptedMsgHash:RcvMsgData :: ConnId
encryptedMsgHash}
                                IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO ()
createRcvMsg Connection
db ConnId
connId RcvQueue
rq RcvMsgData
rcvMsg
                                Maybe (InternalId, MsgMeta, AMessage, RatchetX448)
-> ExceptT
     StoreError IO (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (InternalId, MsgMeta, AMessage, RatchetX448)
 -> ExceptT
      StoreError IO (Maybe (InternalId, MsgMeta, AMessage, RatchetX448)))
-> Maybe (InternalId, MsgMeta, AMessage, RatchetX448)
-> ExceptT
     StoreError IO (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
forall a b. (a -> b) -> a -> b
$ (InternalId, MsgMeta, AMessage, RatchetX448)
-> Maybe (InternalId, MsgMeta, AMessage, RatchetX448)
forall a. a -> Maybe a
Just (InternalId
internalId, MsgMeta
msgMeta, AMessage
aMessage, RatchetX448
rc)
                              AgentMessage
_ -> Maybe (InternalId, MsgMeta, AMessage, RatchetX448)
-> ExceptT
     StoreError IO (Maybe (InternalId, MsgMeta, AMessage, RatchetX448))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (InternalId, MsgMeta, AMessage, RatchetX448)
forall a. Maybe a
Nothing
                      (PrivHeader, AgentMsgEnvelope)
_ -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"msg: bad client msg" ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                  (Just DhSecretX25519
e2eDh, Just PublicKeyX25519
_) ->
                    DhSecretX25519
-> ClientMsgEnvelope -> AM (PrivHeader, AgentMsgEnvelope)
decryptClientMessage DhSecretX25519
e2eDh ClientMsgEnvelope
clientMsg AM (PrivHeader, AgentMsgEnvelope)
-> ((PrivHeader, AgentMsgEnvelope)
    -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
                      -- this is a repeated confirmation delivery because ack failed to be sent
                      (PrivHeader
_, AgentConfirmation {}) -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                      (PrivHeader, AgentMsgEnvelope)
_ -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"msg: public header" ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
                  (Maybe DhSecretX25519
Nothing, Maybe PublicKeyX25519
Nothing) -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"msg: no keys" ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
              updateConnVersion :: Connection c -> ConnData -> VersionSMPA -> AM (Connection c)
              updateConnVersion :: Connection c -> ConnData -> VersionSMPA -> AM (Connection c)
updateConnVersion Connection c
conn' ConnData
cData' VersionSMPA
msgAgentVersion = do
                VersionRange SMPAgentVersion
aVRange <- (Env -> VersionRange SMPAgentVersion)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (VersionRange SMPAgentVersion)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> VersionRange SMPAgentVersion)
 -> ExceptT
      AgentErrorType (ReaderT Env IO) (VersionRange SMPAgentVersion))
-> (Env -> VersionRange SMPAgentVersion)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (VersionRange SMPAgentVersion)
forall a b. (a -> b) -> a -> b
$ AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange (AgentConfig -> VersionRange SMPAgentVersion)
-> (Env -> AgentConfig) -> Env -> VersionRange SMPAgentVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
                let msgAVRange :: VersionRange SMPAgentVersion
msgAVRange = VersionRange SMPAgentVersion
-> Maybe (VersionRange SMPAgentVersion)
-> VersionRange SMPAgentVersion
forall a. a -> Maybe a -> a
fromMaybe (VersionSMPA -> VersionRange SMPAgentVersion
forall v. Version v -> VersionRange v
versionToRange VersionSMPA
msgAgentVersion) (Maybe (VersionRange SMPAgentVersion)
 -> VersionRange SMPAgentVersion)
-> Maybe (VersionRange SMPAgentVersion)
-> VersionRange SMPAgentVersion
forall a b. (a -> b) -> a -> b
$ VersionSMPA -> VersionSMPA -> Maybe (VersionRange SMPAgentVersion)
forall v. Version v -> Version v -> Maybe (VersionRange v)
safeVersionRange (VersionRange SMPAgentVersion -> VersionSMPA
forall v. VersionRange v -> Version v
minVersion VersionRange SMPAgentVersion
aVRange) VersionSMPA
msgAgentVersion
                case VersionRange SMPAgentVersion
msgAVRange VersionRange SMPAgentVersion
-> VersionRange SMPAgentVersion
-> Maybe
     (Compatible
        (VersionT SMPAgentVersion (VersionRange SMPAgentVersion)))
forall v a.
VersionRangeI v a =>
a -> VersionRange v -> Maybe (Compatible (VersionT v a))
`compatibleVersion` VersionRange SMPAgentVersion
aVRange of
                  Just (Compatible VersionSMPA
av)
                    | VersionSMPA
av VersionSMPA -> VersionSMPA -> Bool
forall a. Ord a => a -> a -> Bool
> VersionSMPA
agreedAgentVersion -> do
                        AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> VersionSMPA -> IO ()
setConnAgentVersion Connection
db ConnId
connId VersionSMPA
av
                        let cData'' :: ConnData
cData'' = ConnData
cData' {connAgentVersion = av} :: ConnData
                        Connection c -> AM (Connection c)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Connection c -> AM (Connection c))
-> Connection c -> AM (Connection c)
forall a b. (a -> b) -> a -> b
$ ConnData -> Connection c -> Connection c
forall (d :: ConnType) rq sq.
ConnData -> Connection' d rq sq -> Connection' d rq sq
updateConnection ConnData
cData'' Connection c
conn'
                    | Bool
otherwise -> Connection c -> AM (Connection c)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection c
conn'
                  Maybe
  (Compatible
     (VersionT SMPAgentVersion (VersionRange SMPAgentVersion)))
Nothing -> Connection c -> AM (Connection c)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection c
conn'
              ack :: AM ACKd
              ack :: ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack = InternalCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCmd (QueueId -> ConnId -> InternalCommand
ICAck QueueId
rId ConnId
srvMsgId) ExceptT AgentErrorType (ReaderT Env IO) ()
-> ACKd -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ACKd
ACKd
              ackDel :: InternalId -> AM ACKd
              ackDel :: InternalId -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ackDel InternalId
aId = InternalCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCmd (QueueId -> ConnId -> InternalId -> InternalCommand
ICAckDel QueueId
rId ConnId
srvMsgId InternalId
aId) ExceptT AgentErrorType (ReaderT Env IO) ()
-> ACKd -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ACKd
ACKd
              handleNotifyAck :: AM ACKd -> AM ACKd
              handleNotifyAck :: ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
handleNotifyAck ExceptT AgentErrorType (ReaderT Env IO) ACKd
m = ExceptT AgentErrorType (ReaderT Env IO) ACKd
m ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ACKd)
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllOwnErrors` \AgentErrorType
e -> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AgentErrorType -> AEvent 'AEConn
ERR AgentErrorType
e) ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
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
>> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
          BrokerMsg
SMP.END ->
            STM Bool -> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> STM Bool -> STM Bool -> STM Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (AgentClient -> TransportSession BrokerMsg -> ConnId -> STM Bool
activeClientSession AgentClient
c TransportSession BrokerMsg
tSess ConnId
sessId) (AgentClient
-> TransportSession BrokerMsg -> ConnId -> RcvQueue -> STM ()
forall q.
SomeRcvQueue q =>
AgentClient -> TransportSession BrokerMsg -> ConnId -> q -> STM ()
removeSubscription AgentClient
c TransportSession BrokerMsg
tSess ConnId
connId RcvQueue
rq STM () -> Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True) (Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False))
              ExceptT AgentErrorType (ReaderT Env IO) Bool
-> (Bool -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
>>= Bool -> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyEnd
            where
              notifyEnd :: Bool -> ExceptT AgentErrorType (ReaderT Env IO) ()
notifyEnd Bool
removed
                | Bool
removed = AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify AEvent 'AEConn
END ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
>> ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId ConnId
"END"
                | Bool
otherwise = ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId ConnId
"END from disconnected client - ignored"
          -- Possibly, we need to add some flag to connection that it was deleted
          BrokerMsg
SMP.DELD -> STM () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (AgentClient
-> TransportSession BrokerMsg -> ConnId -> RcvQueue -> STM ()
forall q.
SomeRcvQueue q =>
AgentClient -> TransportSession BrokerMsg -> ConnId -> q -> STM ()
removeSubscription AgentClient
c TransportSession BrokerMsg
tSess ConnId
connId RcvQueue
rq) ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
>> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify AEvent 'AEConn
DELD
          SMP.ERR ErrorType
e -> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
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 -> ErrorType -> AgentErrorType
SMP (ConnId -> String
B.unpack (ConnId -> String) -> ConnId -> String
forall a b. (a -> b) -> a -> b
$ SMPServer -> ConnId
forall a. StrEncoding a => a -> ConnId
strEncode ProtoServer BrokerMsg
SMPServer
srv) ErrorType
e
          BrokerMsg
r -> BrokerMsg -> ExceptT AgentErrorType (ReaderT Env IO) ()
unexpected BrokerMsg
r
        where
          notify :: forall e m. (AEntityI e, MonadIO m) => AEvent e -> m ()
          notify :: forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify AEvent e
msg =
            let t :: ATransmission
t = (ConnId
"", ConnId
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
msg)
             in STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM () -> STM () -> STM ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TBQueue ATransmission -> STM Bool
forall a. TBQueue a -> STM Bool
isFullTBQueue TBQueue ATransmission
subQ) (TVar [ATransmission]
-> ([ATransmission] -> [ATransmission]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [ATransmission]
pendingMsgs (ATransmission
t ATransmission -> [ATransmission] -> [ATransmission]
forall a. a -> [a] -> [a]
:)) (TBQueue ATransmission -> ATransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue ATransmission
subQ ATransmission
t)

          prohibited :: Text -> AM ()
          prohibited :: Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
s = do
            Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ Text
"prohibited: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
            AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SMPAgentError -> AEvent 'AEConn)
-> SMPAgentError
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> AEvent 'AEConn)
-> (SMPAgentError -> AgentErrorType)
-> SMPAgentError
-> AEvent 'AEConn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPAgentError -> AgentErrorType
AGENT (SMPAgentError -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> SMPAgentError -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> SMPAgentError
A_PROHIBITED (String -> SMPAgentError) -> String -> SMPAgentError
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s

          enqueueCmd :: InternalCommand -> AM ()
          enqueueCmd :: InternalCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCmd = AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
"" ConnId
connId (SMPServer -> Maybe SMPServer
forall a. a -> Maybe a
Just ProtoServer BrokerMsg
SMPServer
srv) (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (InternalCommand -> AgentCommand)
-> InternalCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalCommand -> AgentCommand
AInternalCommand

          unexpected :: BrokerMsg -> AM ()
          unexpected :: BrokerMsg -> ExceptT AgentErrorType (ReaderT Env IO) ()
unexpected BrokerMsg
r = do
            ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId
"unexpected: " ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> BrokerMsg -> ConnId
forall a. Show a => a -> ConnId
bshow BrokerMsg
r
            -- TODO add extended information about transmission type once UNEXPECTED has string
            AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> AEvent 'AEConn)
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> AEvent 'AEConn
ERR (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ String -> BrokerErrorType -> AgentErrorType
BROKER (ConnId -> String
B.unpack (ConnId -> String) -> ConnId -> String
forall a b. (a -> b) -> a -> b
$ SMPServer -> ConnId
forall a. StrEncoding a => a -> ConnId
strEncode ProtoServer BrokerMsg
SMPServer
srv) (BrokerErrorType -> AgentErrorType)
-> BrokerErrorType -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ String -> BrokerErrorType
UNEXPECTED (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
32 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> String
forall a. Show a => a -> String
show BrokerMsg
r)

          decryptClientMessage :: C.DhSecretX25519 -> SMP.ClientMsgEnvelope -> AM (SMP.PrivHeader, AgentMsgEnvelope)
          decryptClientMessage :: DhSecretX25519
-> ClientMsgEnvelope -> AM (PrivHeader, AgentMsgEnvelope)
decryptClientMessage DhSecretX25519
e2eDh SMP.ClientMsgEnvelope {CbNonce
cmNonce :: CbNonce
$sel:cmNonce:ClientMsgEnvelope :: ClientMsgEnvelope -> CbNonce
cmNonce, ConnId
cmEncBody :: ConnId
$sel:cmEncBody:ClientMsgEnvelope :: ClientMsgEnvelope -> ConnId
cmEncBody} = do
            ConnId
clientMsg <- Either AgentErrorType ConnId -> AM ConnId
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either AgentErrorType ConnId -> AM ConnId)
-> Either AgentErrorType ConnId -> AM ConnId
forall a b. (a -> b) -> a -> b
$ DhSecretX25519 -> CbNonce -> ConnId -> Either AgentErrorType ConnId
agentCbDecrypt DhSecretX25519
e2eDh CbNonce
cmNonce ConnId
cmEncBody
            SMP.ClientMessage PrivHeader
privHeader ConnId
clientBody <- ConnId -> AM ClientMessage
forall a. Encoding a => ConnId -> AM a
parseMessage ConnId
clientMsg
            AgentMsgEnvelope
agentEnvelope <- ConnId -> AM AgentMsgEnvelope
forall a. Encoding a => ConnId -> AM a
parseMessage ConnId
clientBody
            -- Version check is removed here, because when connecting via v1 contact address the agent still sends v2 message,
            -- to allow duplexHandshake mode, in case the receiving agent was updated to v2 after the address was created.
            -- aVRange <- asks $ smpAgentVRange . config
            -- if agentVersion agentEnvelope `isCompatible` aVRange
            --   then pure (privHeader, agentEnvelope)
            --   else throwE $ AGENT A_VERSION
            (PrivHeader, AgentMsgEnvelope) -> AM (PrivHeader, AgentMsgEnvelope)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrivHeader
privHeader, AgentMsgEnvelope
agentEnvelope)

          parseMessage :: Encoding a => ByteString -> AM a
          parseMessage :: forall a. Encoding a => ConnId -> AM a
parseMessage = Either AgentErrorType a
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either AgentErrorType a
 -> ExceptT AgentErrorType (ReaderT Env IO) a)
-> (ConnId -> Either AgentErrorType a)
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> AgentErrorType -> ConnId -> Either AgentErrorType a
forall a e. Parser a -> e -> ConnId -> Either e a
parse Parser a
forall a. Encoding a => Parser a
smpP (SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_MESSAGE)

          smpConfirmation :: SMP.MsgId -> Connection c -> Maybe C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> ByteString -> VersionSMPC -> VersionSMPA -> AM ()
          smpConfirmation :: ConnId
-> Connection c
-> Maybe SndPublicAuthKey
-> PublicKeyX25519
-> Maybe (SndE2ERatchetParams 'X448)
-> ConnId
-> VersionSMPC
-> VersionSMPA
-> ExceptT AgentErrorType (ReaderT Env IO) ()
smpConfirmation ConnId
srvMsgId Connection c
conn' Maybe SndPublicAuthKey
senderKey PublicKeyX25519
e2ePubKey Maybe (SndE2ERatchetParams 'X448)
e2eEncryption ConnId
encConnInfo VersionSMPC
phVer VersionSMPA
agentVersion = do
            ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId
"MSG <CONF>:" ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId -> ConnId
logSecret' ConnId
srvMsgId
            AgentConfig {VersionRangeSMPC
$sel:smpClientVRange:AgentConfig :: AgentConfig -> VersionRangeSMPC
smpClientVRange :: VersionRangeSMPC
smpClientVRange, VersionRange SMPAgentVersion
$sel:smpAgentVRange:AgentConfig :: AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange :: VersionRange SMPAgentVersion
smpAgentVRange, VersionRangeE2E
$sel:e2eEncryptVRange:AgentConfig :: AgentConfig -> VersionRangeE2E
e2eEncryptVRange :: VersionRangeE2E
e2eEncryptVRange} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
            let ConnData {PQSupport
$sel:pqSupport:ConnData :: ConnData -> PQSupport
pqSupport :: PQSupport
pqSupport} = Connection c -> ConnData
forall (d :: ConnType) rq sq. Connection' d rq sq -> ConnData
toConnData Connection c
conn'
                -- checking agreed versions to continue connection in case of client/agent version downgrades
                compatible :: Bool
compatible =
                  (VersionSMPA
agentVersion VersionSMPA -> VersionRange SMPAgentVersion -> Bool
forall v a. VersionI v a => a -> VersionRange v -> Bool
`isCompatible` VersionRange SMPAgentVersion
smpAgentVRange Bool -> Bool -> Bool
|| VersionSMPA
agentVersion VersionSMPA -> VersionSMPA -> Bool
forall a. Ord a => a -> a -> Bool
<= VersionSMPA
agreedAgentVersion)
                    Bool -> Bool -> Bool
&& (VersionSMPC
phVer VersionSMPC -> VersionRangeSMPC -> Bool
forall v a. VersionI v a => a -> VersionRange v -> Bool
`isCompatible` VersionRangeSMPC
smpClientVRange Bool -> Bool -> Bool
|| VersionSMPC
phVer VersionSMPC -> VersionSMPC -> Bool
forall a. Ord a => a -> a -> Bool
<= VersionSMPC
agreedClientVerion)
            Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
compatible (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION
            case QueueStatus
status of
              QueueStatus
New -> case (Connection c
conn', Maybe (SndE2ERatchetParams 'X448)
e2eEncryption) of
                -- party initiating connection
                (RcvConnection ConnData
_ RcvQueue
_, Just (CR.AE2ERatchetParams SRatchetKEMState s
_ e2eSndParams :: E2ERatchetParams s 'X448
e2eSndParams@(CR.E2ERatchetParams VersionE2E
e2eVersion PublicKey 'X448
_ PublicKey 'X448
_ Maybe (RKEMParams s)
_))) -> do
                  Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (VersionE2E
e2eVersion VersionE2E -> VersionRangeE2E -> Bool
forall v a. VersionI v a => a -> VersionRange v -> Bool
`isCompatible` VersionRangeE2E
e2eEncryptVRange) (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION)
                  (PrivateKey 'X448
pk1, PrivateKey 'X448
rcDHRs, Maybe (PrivRKEMParams 'RKSProposed)
pKem) <- AgentClient
-> (Connection
    -> IO
         (Either
            StoreError
            (PrivateKey 'X448, PrivateKey 'X448,
             Maybe (PrivRKEMParams 'RKSProposed))))
-> AM
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed))
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection
-> ConnId
-> IO
     (Either
        StoreError
        (PrivateKey 'X448, PrivateKey 'X448,
         Maybe (PrivRKEMParams 'RKSProposed)))
`getRatchetX3dhKeys` ConnId
connId)
                  (RatchetInitParams, Maybe KEMKeyPair)
rcParams <- (CryptoError -> AgentErrorType)
-> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RatchetInitParams, Maybe KEMKeyPair)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError CryptoError -> AgentErrorType
cryptoError (ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (RatchetInitParams, Maybe KEMKeyPair))
-> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RatchetInitParams, Maybe KEMKeyPair)
forall a b. (a -> b) -> a -> b
$ PrivateKey 'X448
-> PrivateKey 'X448
-> Maybe (PrivRKEMParams 'RKSProposed)
-> E2ERatchetParams s 'X448
-> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
forall (s :: RatchetKEMState) (a :: Algorithm).
(RatchetKEMStateI s, DhAlgorithm a) =>
PrivateKey a
-> PrivateKey a
-> Maybe (PrivRKEMParams 'RKSProposed)
-> E2ERatchetParams s a
-> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
CR.pqX3dhRcv PrivateKey 'X448
pk1 PrivateKey 'X448
rcDHRs Maybe (PrivRKEMParams 'RKSProposed)
pKem E2ERatchetParams s 'X448
e2eSndParams
                  let rcVs :: RatchetVersions
rcVs = CR.RatchetVersions {$sel:current:RatchetVersions :: VersionE2E
current = VersionE2E
e2eVersion, $sel:maxSupported:RatchetVersions :: VersionE2E
maxSupported = VersionRangeE2E -> VersionE2E
forall v. VersionRange v -> Version v
maxVersion VersionRangeE2E
e2eEncryptVRange}
                      pqSupport' :: PQSupport
pqSupport' = PQSupport
pqSupport PQSupport -> PQSupport -> PQSupport
`CR.pqSupportAnd` VersionSMPA -> Maybe VersionE2E -> PQSupport
versionPQSupport_ VersionSMPA
agentVersion (VersionE2E -> Maybe VersionE2E
forall a. a -> Maybe a
Just VersionE2E
e2eVersion)
                      rc :: RatchetX448
rc = RatchetVersions
-> PrivateKey 'X448
-> (RatchetInitParams, Maybe KEMKeyPair)
-> PQSupport
-> RatchetX448
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
RatchetVersions
-> PrivateKey a
-> (RatchetInitParams, Maybe KEMKeyPair)
-> PQSupport
-> Ratchet a
CR.initRcvRatchet RatchetVersions
rcVs PrivateKey 'X448
rcDHRs (RatchetInitParams, Maybe KEMKeyPair)
rcParams PQSupport
pqSupport'
                  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
                  (Either CryptoError ConnId
agentMsgBody_, RatchetX448
rc', SkippedMsgDiff
skipped) <- (CryptoError -> AgentErrorType)
-> ExceptT
     CryptoError
     IO
     (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError CryptoError -> AgentErrorType
cryptoError (ExceptT
   CryptoError
   IO
   (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff))
-> ExceptT
     CryptoError
     IO
     (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> RatchetX448
-> SkippedMsgKeys
-> ConnId
-> ExceptT
     CryptoError
     IO
     (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff)
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> Ratchet a
-> SkippedMsgKeys
-> ConnId
-> ExceptT CryptoError IO (DecryptResult a)
CR.rcDecrypt TVar ChaChaDRG
g RatchetX448
rc SkippedMsgKeys
forall k a. Map k a
M.empty ConnId
encConnInfo
                  case SkippedMsgDiff
skipped of
                    SkippedMsgDiff
CR.SMDNoChange -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    SkippedMsgDiff
_ -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn Text
"conf: skipped confirmations"
                  case Either CryptoError ConnId
agentMsgBody_ of
                    Right ConnId
agentMsgBody ->
                      ConnId -> ExceptT AgentErrorType (ReaderT Env IO) AgentMessage
forall a. Encoding a => ConnId -> AM a
parseMessage ConnId
agentMsgBody ExceptT AgentErrorType (ReaderT Env IO) AgentMessage
-> (AgentMessage -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
                        AgentConnInfoReply NonEmpty SMPQueueInfo
smpQueues ConnId
connInfo -> do
                          ConnId
-> SMPConfirmation -> ExceptT AgentErrorType (ReaderT Env IO) ()
processConf ConnId
connInfo SMPConfirmation {Maybe SndPublicAuthKey
$sel:senderKey:SMPConfirmation :: Maybe SndPublicAuthKey
senderKey :: Maybe SndPublicAuthKey
senderKey, PublicKeyX25519
e2ePubKey :: PublicKeyX25519
$sel:e2ePubKey:SMPConfirmation :: PublicKeyX25519
e2ePubKey, ConnId
connInfo :: ConnId
$sel:connInfo:SMPConfirmation :: ConnId
connInfo, $sel:smpReplyQueues:SMPConfirmation :: [SMPQueueInfo]
smpReplyQueues = NonEmpty SMPQueueInfo -> [SMPQueueInfo]
forall a. NonEmpty a -> [a]
L.toList NonEmpty SMPQueueInfo
smpQueues, $sel:smpClientVersion:SMPConfirmation :: VersionSMPC
smpClientVersion = VersionSMPC
phVer}
                          AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> UserId -> InternalRcvId -> ConnId -> IO ()
updateRcvMsgHash Connection
db ConnId
connId UserId
1 (UserId -> InternalRcvId
InternalRcvId UserId
0) (ConnId -> ConnId
C.sha256Hash ConnId
agentMsgBody)
                        AgentMessage
_ -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"conf: not AgentConnInfoReply" -- including AgentConnInfo, that is prohibited here in v2
                      where
                        processConf :: ConnId
-> SMPConfirmation -> ExceptT AgentErrorType (ReaderT Env IO) ()
processConf ConnId
connInfo SMPConfirmation
senderConf = do
                          let newConfirmation :: NewConfirmation
newConfirmation = NewConfirmation {ConnId
connId :: ConnId
$sel:connId:NewConfirmation :: ConnId
connId, SMPConfirmation
senderConf :: SMPConfirmation
$sel:senderConf:NewConfirmation :: SMPConfirmation
senderConf, $sel:ratchetState:NewConfirmation :: RatchetX448
ratchetState = RatchetX448
rc'}
                          ConnId
confId <- AgentClient
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError ConnId)) -> AM ConnId)
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                            Connection -> ConnId -> VersionSMPA -> IO ()
setConnAgentVersion Connection
db ConnId
connId VersionSMPA
agentVersion
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PQSupport
pqSupport PQSupport -> PQSupport -> Bool
forall a. Eq a => a -> a -> Bool
/= PQSupport
pqSupport') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> PQSupport -> IO ()
setConnPQSupport Connection
db ConnId
connId PQSupport
pqSupport'
                            -- /
                            -- Starting with agent version 7 (ratchetOnConfSMPAgentVersion),
                            -- initiating party initializes ratchet on processing confirmation;
                            -- previously, it initialized ratchet on allowConnection;
                            -- this is to support decryption of messages that may be received before allowConnection
                            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
                              Connection -> ConnId -> RatchetX448 -> IO ()
createRatchet Connection
db ConnId
connId RatchetX448
rc'
                              let RcvQueue {$sel:smpClientVersion:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> VersionSMPC
smpClientVersion = VersionSMPC
v, $sel:e2ePrivKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> PrivateKey 'X25519
e2ePrivKey = PrivateKey 'X25519
e2ePrivKey'} = RcvQueue
rq
                                  SMPConfirmation {$sel:smpClientVersion:SMPConfirmation :: SMPConfirmation -> VersionSMPC
smpClientVersion = VersionSMPC
v', $sel:e2ePubKey:SMPConfirmation :: SMPConfirmation -> PublicKeyX25519
e2ePubKey = PublicKeyX25519
e2ePubKey'} = SMPConfirmation
senderConf
                                  dhSecret :: DhSecretX25519
dhSecret = PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecretX25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKeyX25519
e2ePubKey' PrivateKey 'X25519
e2ePrivKey'
                              Connection -> RcvQueue -> DhSecretX25519 -> VersionSMPC -> IO ()
setRcvQueueConfirmedE2E Connection
db RcvQueue
rq DhSecretX25519
dhSecret (VersionSMPC -> IO ()) -> VersionSMPC -> IO ()
forall a b. (a -> b) -> a -> b
$ VersionSMPC -> VersionSMPC -> VersionSMPC
forall a. Ord a => a -> a -> a
min VersionSMPC
v VersionSMPC
v'
                            -- /
                            Connection
-> TVar ChaChaDRG
-> NewConfirmation
-> IO (Either StoreError ConnId)
createConfirmation Connection
db TVar ChaChaDRG
g NewConfirmation
newConfirmation
                          let srvs :: [SMPServer]
srvs = (SMPQueueInfo -> SMPServer) -> [SMPQueueInfo] -> [SMPServer]
forall a b. (a -> b) -> [a] -> [b]
map SMPQueueInfo -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer ([SMPQueueInfo] -> [SMPServer]) -> [SMPQueueInfo] -> [SMPServer]
forall a b. (a -> b) -> a -> b
$ SMPConfirmation -> [SMPQueueInfo]
smpReplyQueues SMPConfirmation
senderConf
                          AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId -> PQSupport -> [SMPServer] -> ConnId -> AEvent 'AEConn
CONF ConnId
confId PQSupport
pqSupport' [SMPServer]
srvs ConnId
connInfo
                    Either CryptoError ConnId
_ -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"conf: decrypt error"
                -- party accepting connection
                (DuplexConnection ConnData
_ (rq' :: RcvQueue
rq'@RcvQueue {$sel:smpClientVersion:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> VersionSMPC
smpClientVersion = VersionSMPC
v'} :| [RcvQueue]
_) NonEmpty SndQueue
_, Maybe (SndE2ERatchetParams 'X448)
Nothing) -> 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
                  (ConnId
agentMsgBody, PQEncryption
pqEncryption) <- AgentClient
-> (Connection -> IO (Either StoreError (ConnId, PQEncryption)))
-> AM (ConnId, PQEncryption)
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError (ConnId, PQEncryption)))
 -> AM (ConnId, PQEncryption))
-> (Connection -> IO (Either StoreError (ConnId, PQEncryption)))
-> AM (ConnId, PQEncryption)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ExceptT StoreError IO (ConnId, PQEncryption)
-> IO (Either StoreError (ConnId, PQEncryption))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO (ConnId, PQEncryption)
 -> IO (Either StoreError (ConnId, PQEncryption)))
-> ExceptT StoreError IO (ConnId, PQEncryption)
-> IO (Either StoreError (ConnId, PQEncryption))
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> Connection
-> ConnId
-> ConnId
-> ExceptT StoreError IO (ConnId, PQEncryption)
agentRatchetDecrypt TVar ChaChaDRG
g Connection
db ConnId
connId ConnId
encConnInfo
                  ConnId -> ExceptT AgentErrorType (ReaderT Env IO) AgentMessage
forall a. Encoding a => ConnId -> AM a
parseMessage ConnId
agentMsgBody ExceptT AgentErrorType (ReaderT Env IO) AgentMessage
-> (AgentMessage -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
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
                    AgentConnInfo ConnId
connInfo -> do
                      AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ PQSupport -> ConnId -> AEvent 'AEConn
INFO PQSupport
pqSupport ConnId
connInfo
                      let dhSecret :: DhSecretX25519
dhSecret = PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecretX25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKeyX25519
e2ePubKey PrivateKey 'X25519
e2ePrivKey
                      AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                        Connection -> RcvQueue -> DhSecretX25519 -> VersionSMPC -> IO ()
setRcvQueueConfirmedE2E Connection
db RcvQueue
rq DhSecretX25519
dhSecret (VersionSMPC -> IO ()) -> VersionSMPC -> IO ()
forall a b. (a -> b) -> a -> b
$ VersionSMPC -> VersionSMPC -> VersionSMPC
forall a. Ord a => a -> a -> a
min VersionSMPC
v' VersionSMPC
phVer
                        Connection -> ConnId -> UserId -> InternalRcvId -> ConnId -> IO ()
updateRcvMsgHash Connection
db ConnId
connId UserId
1 (UserId -> InternalRcvId
InternalRcvId UserId
0) (ConnId -> ConnId
C.sha256Hash ConnId
agentMsgBody)
                      case Maybe SndPublicAuthKey
senderKey of
                        Just SndPublicAuthKey
k -> InternalCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCmd (InternalCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> InternalCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ QueueId -> SndPublicAuthKey -> InternalCommand
ICDuplexSecure QueueId
rId SndPublicAuthKey
k
                        Maybe SndPublicAuthKey
Nothing -> do
                          AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ PQEncryption -> AEvent 'AEConn
CON PQEncryption
pqEncryption
                          AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvQueue -> QueueStatus -> IO ()
setRcvQueueStatus Connection
db RcvQueue
rq' QueueStatus
Active
                    AgentMessage
_ -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"conf: not AgentConnInfo"
                (Connection c, Maybe (SndE2ERatchetParams 'X448))
_ -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"conf: incorrect state"
              QueueStatus
_ -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"conf: status /= new"

          helloMsg :: SMP.MsgId -> MsgMeta -> Connection c -> AM ()
          helloMsg :: ConnId
-> MsgMeta
-> Connection c
-> ExceptT AgentErrorType (ReaderT Env IO) ()
helloMsg ConnId
srvMsgId MsgMeta {PQEncryption
$sel:pqEncryption:MsgMeta :: MsgMeta -> PQEncryption
pqEncryption :: PQEncryption
pqEncryption} Connection c
conn' = do
            ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId
"MSG <HELLO>:" ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId -> ConnId
logSecret' ConnId
srvMsgId
            case QueueStatus
status of
              QueueStatus
Active -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"hello: active"
              QueueStatus
_ ->
                case Connection c
conn' of
                  DuplexConnection ConnData
_ NonEmpty RcvQueue
_ (sq :: SndQueue
sq@SndQueue {$sel:status:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> QueueStatus
status = QueueStatus
sndStatus} :| [SndQueue]
_)
                    -- `sndStatus == Active` when HELLO was previously sent, and this is the reply HELLO
                    -- this branch is executed by the accepting party in duplexHandshake mode (v2)
                    -- (was executed by initiating party in v1 that is no longer supported)
                    | QueueStatus
sndStatus QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
Active -> 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
-> SMPServer
-> (AgentSMPServerStats -> TVar Int)
-> STM ()
incSMPServerStat AgentClient
c UserId
userId ProtoServer BrokerMsg
SMPServer
srv AgentSMPServerStats -> TVar Int
connCompleted
                        AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ PQEncryption -> AEvent 'AEConn
CON PQEncryption
pqEncryption
                    | Bool
otherwise -> SndQueue -> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueDuplexHello SndQueue
sq
                  Connection c
_ -> () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            where
              enqueueDuplexHello :: SndQueue -> AM ()
              enqueueDuplexHello :: SndQueue -> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueDuplexHello SndQueue
sq = do
                let cData' :: ConnData
cData' = Connection c -> ConnData
forall (d :: ConnType) rq sq. Connection' d rq sq -> ConnData
toConnData Connection c
conn'
                AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM (UserId, PQEncryption)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> ConnData
-> SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessage AgentClient
c ConnData
cData' SndQueue
sq SMP.MsgFlags {$sel:notification:MsgFlags :: Bool
notification = Bool
True} AMessage
HELLO

          continueSending :: SMP.MsgId -> (SMPServer, SMP.SenderId) -> Connection 'CDuplex -> AM ()
          continueSending :: ConnId
-> (SMPServer, QueueId)
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ()
continueSending ConnId
srvMsgId (SMPServer, QueueId)
addr (DuplexConnection ConnData
_ NonEmpty RcvQueue
_ NonEmpty SndQueue
sqs) =
            case (SMPServer, QueueId) -> NonEmpty SndQueue -> Maybe SndQueue
forall q.
SMPQueue q =>
(SMPServer, QueueId) -> NonEmpty q -> Maybe q
findQ (SMPServer, QueueId)
addr NonEmpty SndQueue
sqs of
              Just SndQueue
sq -> do
                ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId
"MSG <QCONT>:" ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId -> ConnId
logSecret' ConnId
srvMsgId
                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
$
                  (SMPServer, QueueId)
-> TMap (SMPServer, QueueId) (Worker, TMVar ())
-> STM (Maybe (Worker, TMVar ()))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup (SndQueue -> (SMPServer, QueueId)
forall q. SMPQueue q => q -> (SMPServer, QueueId)
qAddress SndQueue
sq) (AgentClient -> TMap (SMPServer, QueueId) (Worker, TMVar ())
smpDeliveryWorkers AgentClient
c)
                    STM (Maybe (Worker, TMVar ()))
-> (Maybe (Worker, 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
>>= ((Worker, TMVar ()) -> STM Bool)
-> Maybe (Worker, TMVar ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Worker
_, TMVar ()
retryLock) -> TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
retryLock ())
                AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify AEvent 'AEConn
QCONT
              Maybe SndQueue
Nothing -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. String -> AM a
qError String
"QCONT: queue address not found"

          messagesRcvd :: NonEmpty AMessageReceipt -> MsgMeta -> Connection 'CDuplex -> AM ACKd
          messagesRcvd :: NonEmpty AMessageReceipt
-> MsgMeta
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ACKd
messagesRcvd NonEmpty AMessageReceipt
rcpts msgMeta :: MsgMeta
msgMeta@MsgMeta {$sel:broker:MsgMeta :: MsgMeta -> (ConnId, InternalTs)
broker = (ConnId
srvMsgId, InternalTs
_)} Connection 'CDuplex
_ = do
            ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId
"MSG <RCPT>:" ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId -> ConnId
logSecret' ConnId
srvMsgId
            NonEmpty (Maybe MsgReceipt)
rs <- NonEmpty AMessageReceipt
-> (AMessageReceipt
    -> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt))
-> ExceptT
     AgentErrorType (ReaderT Env IO) (NonEmpty (Maybe MsgReceipt))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty AMessageReceipt
rcpts ((AMessageReceipt
  -> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt))
 -> ExceptT
      AgentErrorType (ReaderT Env IO) (NonEmpty (Maybe MsgReceipt)))
-> (AMessageReceipt
    -> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt))
-> ExceptT
     AgentErrorType (ReaderT Env IO) (NonEmpty (Maybe MsgReceipt))
forall a b. (a -> b) -> a -> b
$ \AMessageReceipt
rcpt -> AMessageReceipt
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt)
clientReceipt AMessageReceipt
rcpt ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt)
-> (AgentErrorType
    -> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt))
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \AgentErrorType
e -> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AgentErrorType -> AEvent 'AEConn
ERR AgentErrorType
e) ExceptT AgentErrorType (ReaderT Env IO) ()
-> Maybe MsgReceipt
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe MsgReceipt
forall a. Maybe a
Nothing
            case [MsgReceipt] -> Maybe (NonEmpty MsgReceipt)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ([MsgReceipt] -> Maybe (NonEmpty MsgReceipt))
-> ([Maybe MsgReceipt] -> [MsgReceipt])
-> [Maybe MsgReceipt]
-> Maybe (NonEmpty MsgReceipt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe MsgReceipt] -> [MsgReceipt]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe MsgReceipt] -> Maybe (NonEmpty MsgReceipt))
-> [Maybe MsgReceipt] -> Maybe (NonEmpty MsgReceipt)
forall a b. (a -> b) -> a -> b
$ NonEmpty (Maybe MsgReceipt) -> [Maybe MsgReceipt]
forall a. NonEmpty a -> [a]
L.toList NonEmpty (Maybe MsgReceipt)
rs of
              Just NonEmpty MsgReceipt
rs' -> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (MsgMeta -> NonEmpty MsgReceipt -> AEvent 'AEConn
RCVD MsgMeta
msgMeta NonEmpty MsgReceipt
rs') ExceptT AgentErrorType (ReaderT Env IO) ()
-> ACKd -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ACKd
ACKPending
              Maybe (NonEmpty MsgReceipt)
Nothing -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack
            where
              ack :: AM ACKd
              ack :: ExceptT AgentErrorType (ReaderT Env IO) ACKd
ack = InternalCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCmd (QueueId -> ConnId -> InternalCommand
ICAck QueueId
rId ConnId
srvMsgId) ExceptT AgentErrorType (ReaderT Env IO) ()
-> ACKd -> ExceptT AgentErrorType (ReaderT Env IO) ACKd
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ACKd
ACKd
              clientReceipt :: AMessageReceipt -> AM (Maybe MsgReceipt)
              clientReceipt :: AMessageReceipt
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt)
clientReceipt AMessageReceipt {UserId
$sel:agentMsgId:AMessageReceipt :: AMessageReceipt -> UserId
agentMsgId :: UserId
agentMsgId, ConnId
$sel:msgHash:AMessageReceipt :: AMessageReceipt -> ConnId
msgHash :: ConnId
msgHash} = do
                let sndMsgId :: InternalSndId
sndMsgId = UserId -> InternalSndId
InternalSndId UserId
agentMsgId
                SndMsg {$sel:internalId:SndMsg :: SndMsg -> InternalId
internalId = InternalId UserId
msgId, AgentMessageType
msgType :: AgentMessageType
$sel:msgType:SndMsg :: SndMsg -> AgentMessageType
msgType, ConnId
internalHash :: ConnId
$sel:internalHash:SndMsg :: SndMsg -> ConnId
internalHash, Maybe MsgReceipt
msgReceipt :: Maybe MsgReceipt
$sel:msgReceipt:SndMsg :: SndMsg -> Maybe MsgReceipt
msgReceipt} <- AgentClient
-> (Connection -> IO (Either StoreError SndMsg)) -> AM SndMsg
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError SndMsg)) -> AM SndMsg)
-> (Connection -> IO (Either StoreError SndMsg)) -> AM SndMsg
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ConnId -> InternalSndId -> IO (Either StoreError SndMsg)
getSndMsgViaRcpt Connection
db ConnId
connId InternalSndId
sndMsgId
                if AgentMessageType
msgType AgentMessageType -> AgentMessageType -> Bool
forall a. Eq a => a -> a -> Bool
/= AgentMessageType
AM_A_MSG_
                  then Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"receipt: not a msg" ExceptT AgentErrorType (ReaderT Env IO) ()
-> Maybe MsgReceipt
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe MsgReceipt
forall a. Maybe a
Nothing
                  else case Maybe MsgReceipt
msgReceipt of
                    Just MsgReceipt {$sel:msgRcptStatus:MsgReceipt :: MsgReceipt -> MsgReceiptStatus
msgRcptStatus = MsgReceiptStatus
MROk} -> Maybe MsgReceipt
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MsgReceipt
forall a. Maybe a
Nothing -- already notified with MROk status
                    Maybe MsgReceipt
_ -> do
                      let msgRcptStatus :: MsgReceiptStatus
msgRcptStatus = if ConnId
msgHash ConnId -> ConnId -> Bool
forall a. Eq a => a -> a -> Bool
== ConnId
internalHash then MsgReceiptStatus
MROk else MsgReceiptStatus
MRBadMsgHash
                          rcpt :: MsgReceipt
rcpt = MsgReceipt {$sel:agentMsgId:MsgReceipt :: UserId
agentMsgId = UserId
msgId, MsgReceiptStatus
$sel:msgRcptStatus:MsgReceipt :: MsgReceiptStatus
msgRcptStatus :: MsgReceiptStatus
msgRcptStatus}
                      AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> InternalSndId -> MsgReceipt -> IO ()
updateSndMsgRcpt Connection
db ConnId
connId InternalSndId
sndMsgId MsgReceipt
rcpt
                      Maybe MsgReceipt
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe MsgReceipt
 -> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt))
-> Maybe MsgReceipt
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe MsgReceipt)
forall a b. (a -> b) -> a -> b
$ MsgReceipt -> Maybe MsgReceipt
forall a. a -> Maybe a
Just MsgReceipt
rcpt

          -- processed by queue sender
          qAddMsg :: SMP.MsgId -> NonEmpty (SMPQueueUri, Maybe SndQAddr) -> Connection 'CDuplex -> AM ()
          qAddMsg :: ConnId
-> NonEmpty (SMPQueueUri, Maybe (SMPServer, QueueId))
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ()
qAddMsg ConnId
_ ((SMPQueueUri
_, Maybe (SMPServer, QueueId)
Nothing) :| [(SMPQueueUri, Maybe (SMPServer, QueueId))]
_) Connection 'CDuplex
_ = String -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. String -> AM a
qError String
"adding queue without switching is not supported"
          qAddMsg ConnId
srvMsgId ((SMPQueueUri
qUri, Just (SMPServer, QueueId)
addr) :| [(SMPQueueUri, Maybe (SMPServer, QueueId))]
_) (DuplexConnection ConnData
cData' NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs) = do
            Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnData -> Bool
ratchetSyncSendProhibited ConnData
cData') (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT (String -> SMPAgentError
A_QUEUE String
"ratchet is not synchronized")
            VersionRangeSMPC
clientVRange <- (Env -> VersionRangeSMPC)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> VersionRangeSMPC)
 -> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC)
-> (Env -> VersionRangeSMPC)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC
forall a b. (a -> b) -> a -> b
$ AgentConfig -> VersionRangeSMPC
smpClientVRange (AgentConfig -> VersionRangeSMPC)
-> (Env -> AgentConfig) -> Env -> VersionRangeSMPC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
            case SMPQueueUri
qUri SMPQueueUri
-> VersionRangeSMPC
-> Maybe (Compatible (VersionT SMPClientVersion SMPQueueUri))
forall v a.
VersionRangeI v a =>
a -> VersionRange v -> Maybe (Compatible (VersionT v a))
`compatibleVersion` VersionRangeSMPC
clientVRange of
              Just qInfo :: Compatible (VersionT SMPClientVersion SMPQueueUri)
qInfo@(Compatible sqInfo :: SMPQueueInfo
sqInfo@SMPQueueInfo {SMPQueueAddress
$sel:queueAddress:SMPQueueInfo :: SMPQueueInfo -> SMPQueueAddress
queueAddress :: SMPQueueAddress
queueAddress}) ->
                case ((SMPServer, QueueId) -> NonEmpty SndQueue -> Maybe SndQueue
forall q.
SMPQueue q =>
(SMPServer, QueueId) -> NonEmpty q -> Maybe q
findQ (SMPQueueInfo -> (SMPServer, QueueId)
forall q. SMPQueue q => q -> (SMPServer, QueueId)
qAddress SMPQueueInfo
sqInfo) NonEmpty SndQueue
sqs, (SMPServer, QueueId) -> NonEmpty SndQueue -> Maybe SndQueue
forall q.
SMPQueue q =>
(SMPServer, QueueId) -> NonEmpty q -> Maybe q
findQ (SMPServer, QueueId)
addr NonEmpty SndQueue
sqs) of
                  (Just SndQueue
_, Maybe SndQueue
_) -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. String -> AM a
qError String
"QADD: queue address is already used in connection"
                  (Maybe SndQueue
_, Just sq :: SndQueue
sq@SndQueue {$sel:dbQueueId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> DBEntityId' q
dbQueueId = DBEntityId UserId
dbQueueId}) -> do
                    let ([SndQueue]
delSqs, [SndQueue]
keepSqs) = (SndQueue -> Bool) -> NonEmpty SndQueue -> ([SndQueue], [SndQueue])
forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
L.partition ((UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
dbQueueId Maybe UserId -> Maybe UserId -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe UserId -> Bool)
-> (SndQueue -> Maybe UserId) -> SndQueue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SndQueue -> Maybe UserId
forall q. SMPQueueRec q => q -> Maybe UserId
dbReplaceQId) NonEmpty SndQueue
sqs
                    case [SndQueue] -> Maybe (NonEmpty SndQueue)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [SndQueue]
keepSqs of
                      Just NonEmpty SndQueue
sqs' -> do
                        (sq_ :: NewSndQueue
sq_@SndQueue {APrivateAuthKey
sndPrivateKey :: APrivateAuthKey
$sel:sndPrivateKey:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> APrivateAuthKey
sndPrivateKey}, PublicKeyX25519
dhPublicKey) <- ReaderT Env IO (NewSndQueue, PublicKeyX25519)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (NewSndQueue, PublicKeyX25519)
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 (NewSndQueue, PublicKeyX25519)
 -> ExceptT
      AgentErrorType (ReaderT Env IO) (NewSndQueue, PublicKeyX25519))
-> ReaderT Env IO (NewSndQueue, PublicKeyX25519)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (NewSndQueue, PublicKeyX25519)
forall a b. (a -> b) -> a -> b
$ UserId
-> ConnId
-> Compatible SMPQueueInfo
-> Maybe APrivateAuthKey
-> ReaderT Env IO (NewSndQueue, PublicKeyX25519)
newSndQueue UserId
userId ConnId
connId Compatible (VersionT SMPClientVersion SMPQueueUri)
Compatible SMPQueueInfo
qInfo Maybe APrivateAuthKey
forall a. Maybe a
Nothing
                        SndQueue
sq2 <- AgentClient
-> (Connection -> IO (Either StoreError SndQueue)) -> AM SndQueue
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError SndQueue)) -> AM SndQueue)
-> (Connection -> IO (Either StoreError SndQueue)) -> AM SndQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                          Connection -> ConnId -> IO ()
lockConnForUpdate Connection
db ConnId
connId
                          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
$ (SndQueue -> IO ()) -> [SndQueue] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Connection -> ConnId -> SndQueue -> IO ()
deleteConnSndQueue Connection
db ConnId
connId) [SndQueue]
delSqs
                          Connection
-> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
addConnSndQueue Connection
db ConnId
connId (NewSndQueue
sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
                        ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId
"MSG <QADD>:" ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId -> ConnId
logSecret' ConnId
srvMsgId ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId
" " ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> QueueId -> ConnId
logSecret (SMPQueueAddress -> QueueId
senderId SMPQueueAddress
queueAddress)
                        let sqInfo' :: SMPQueueInfo
sqInfo' = (SMPQueueInfo
sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
                        AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM (UserId, PQEncryption)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AMessage -> AM (UserId, PQEncryption))
-> AMessage
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> ConnData
-> NonEmpty SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessages AgentClient
c ConnData
cData' NonEmpty SndQueue
sqs MsgFlags
SMP.noMsgFlags (AMessage -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AMessage -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ NonEmpty (SMPQueueInfo, SndPublicAuthKey) -> AMessage
QKEY [(SMPQueueInfo
sqInfo', APrivateAuthKey -> PublicKeyType APrivateAuthKey
forall pk. CryptoPrivateKey pk => pk -> PublicKeyType pk
C.toPublic APrivateAuthKey
sndPrivateKey)]
                        SndQueue
sq1 <- AgentClient -> (Connection -> IO SndQueue) -> AM SndQueue
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO SndQueue) -> AM SndQueue)
-> (Connection -> IO SndQueue) -> AM SndQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> SndQueue -> Maybe SndSwitchStatus -> IO SndQueue
setSndSwitchStatus Connection
db SndQueue
sq (Maybe SndSwitchStatus -> IO SndQueue)
-> Maybe SndSwitchStatus -> IO SndQueue
forall a b. (a -> b) -> a -> b
$ SndSwitchStatus -> Maybe SndSwitchStatus
forall a. a -> Maybe a
Just SndSwitchStatus
SSSendingQKEY
                        let sqs'' :: NonEmpty SndQueue
sqs'' = SndQueue -> NonEmpty SndQueue -> NonEmpty SndQueue
forall q. SMPQueueRec q => q -> NonEmpty q -> NonEmpty q
updatedQs SndQueue
sq1 NonEmpty SndQueue
sqs' NonEmpty SndQueue -> NonEmpty SndQueue -> NonEmpty SndQueue
forall a. Semigroup a => a -> a -> a
<> [Item (NonEmpty SndQueue)
SndQueue
sq2]
                            conn' :: Connection 'CDuplex
conn' = ConnData
-> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection 'CDuplex
forall rq sq.
ConnData
-> NonEmpty rq -> NonEmpty sq -> Connection' 'CDuplex rq sq
DuplexConnection ConnData
cData' NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs''
                        ConnectionStats
cStats <- AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection 'CDuplex
conn'
                        AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ QueueDirection -> SwitchPhase -> ConnectionStats -> AEvent 'AEConn
SWITCH QueueDirection
QDSnd SwitchPhase
SPStarted ConnectionStats
cStats
                      Maybe (NonEmpty SndQueue)
_ -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. String -> AM a
qError String
"QADD: won't delete all snd queues in connection"
                  (Maybe SndQueue, Maybe SndQueue)
_ -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. String -> AM a
qError String
"QADD: replaced queue address is not found in connection"
              Maybe (Compatible (VersionT SMPClientVersion SMPQueueUri))
_ -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION

          -- processed by queue recipient
          qKeyMsg :: SMP.MsgId -> NonEmpty (SMPQueueInfo, SndPublicAuthKey) -> Connection 'CDuplex -> AM ()
          qKeyMsg :: ConnId
-> NonEmpty (SMPQueueInfo, SndPublicAuthKey)
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ()
qKeyMsg ConnId
srvMsgId ((SMPQueueInfo
qInfo, SndPublicAuthKey
senderKey) :| [(SMPQueueInfo, SndPublicAuthKey)]
_) conn' :: Connection 'CDuplex
conn'@(DuplexConnection ConnData
cData' NonEmpty RcvQueue
rqs NonEmpty SndQueue
_) = do
            Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnData -> Bool
ratchetSyncSendProhibited ConnData
cData') (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT (String -> SMPAgentError
A_QUEUE String
"ratchet is not synchronized")
            VersionRangeSMPC
clientVRange <- (Env -> VersionRangeSMPC)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> VersionRangeSMPC)
 -> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC)
-> (Env -> VersionRangeSMPC)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC
forall a b. (a -> b) -> a -> b
$ AgentConfig -> VersionRangeSMPC
smpClientVRange (AgentConfig -> VersionRangeSMPC)
-> (Env -> AgentConfig) -> Env -> VersionRangeSMPC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
            Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SMPQueueInfo
qInfo SMPQueueInfo -> VersionRangeSMPC -> Bool
forall v a. VersionI v a => a -> VersionRange v -> Bool
`isCompatible` VersionRangeSMPC
clientVRange) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION
            case (SMPServer, QueueId) -> NonEmpty RcvQueue -> Maybe RcvQueue
findRQ (SMPServer
smpServer, QueueId
senderId) NonEmpty RcvQueue
rqs of
              Just rq' :: RcvQueue
rq'@RcvQueue {QueueId
$sel:rcvId:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueId
rcvId :: QueueId
rcvId, $sel:e2ePrivKey:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> PrivateKey 'X25519
e2ePrivKey = PrivateKey 'X25519
dhPrivKey, $sel:smpClientVersion:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> VersionSMPC
smpClientVersion = VersionSMPC
cVer, $sel:status:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> QueueStatus
status = QueueStatus
status'}
                | QueueStatus
status' QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
New Bool -> Bool -> Bool
|| QueueStatus
status' QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
Confirmed -> do
                    RcvQueue
-> RcvSwitchStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkRQSwchStatus RcvQueue
rq RcvSwitchStatus
RSSendingQADD
                    ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId
"MSG <QKEY>:" ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId -> ConnId
logSecret' ConnId
srvMsgId ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId
" " ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> QueueId -> ConnId
logSecret QueueId
senderId
                    let dhSecret :: DhSecretX25519
dhSecret = PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecretX25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKeyX25519
dhPublicKey PrivateKey 'X25519
dhPrivKey
                    AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvQueue -> DhSecretX25519 -> VersionSMPC -> IO ()
setRcvQueueConfirmedE2E Connection
db RcvQueue
rq' DhSecretX25519
dhSecret (VersionSMPC -> IO ()) -> VersionSMPC -> IO ()
forall a b. (a -> b) -> a -> b
$ VersionSMPC -> VersionSMPC -> VersionSMPC
forall a. Ord a => a -> a -> a
min VersionSMPC
cVer VersionSMPC
cVer'
                    AgentClient
-> ConnId
-> ConnId
-> Maybe SMPServer
-> AgentCommand
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueCommand AgentClient
c ConnId
"" ConnId
connId (SMPServer -> Maybe SMPServer
forall a. a -> Maybe a
Just SMPServer
smpServer) (AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentCommand -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ InternalCommand -> AgentCommand
AInternalCommand (InternalCommand -> AgentCommand)
-> InternalCommand -> AgentCommand
forall a b. (a -> b) -> a -> b
$ QueueId -> SndPublicAuthKey -> InternalCommand
ICQSecure QueueId
rcvId SndPublicAuthKey
senderKey
                    ConnectionStats
cStats <- AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection 'CDuplex
conn'
                    AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ QueueDirection -> SwitchPhase -> ConnectionStats -> AEvent 'AEConn
SWITCH QueueDirection
QDRcv SwitchPhase
SPConfirmed ConnectionStats
cStats
                | Bool
otherwise -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. String -> AM a
qError String
"QKEY: queue already secured"
              Maybe RcvQueue
_ -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. String -> AM a
qError String
"QKEY: queue address not found in connection"
            where
              SMPQueueInfo VersionSMPC
cVer' SMPQueueAddress {SMPServer
$sel:smpServer:SMPQueueAddress :: SMPQueueAddress -> SMPServer
smpServer :: SMPServer
smpServer, QueueId
$sel:senderId:SMPQueueAddress :: SMPQueueAddress -> QueueId
senderId :: QueueId
senderId, PublicKeyX25519
$sel:dhPublicKey:SMPQueueAddress :: SMPQueueAddress -> PublicKeyX25519
dhPublicKey :: PublicKeyX25519
dhPublicKey} = SMPQueueInfo
qInfo

          -- processed by queue sender
          -- mark queue as Secured and to start sending messages to it
          qUseMsg :: SMP.MsgId -> NonEmpty ((SMPServer, SMP.SenderId), Bool) -> Connection 'CDuplex -> AM ()
          -- NOTE: does not yet support the change of the primary status during the rotation
          qUseMsg :: ConnId
-> NonEmpty ((SMPServer, QueueId), Bool)
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ()
qUseMsg ConnId
srvMsgId (((SMPServer, QueueId)
addr, Bool
_primary) :| [((SMPServer, QueueId), Bool)]
_) (DuplexConnection ConnData
cData' NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs) = do
            Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnData -> Bool
ratchetSyncSendProhibited ConnData
cData') (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 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT (String -> SMPAgentError
A_QUEUE String
"ratchet is not synchronized")
            case (SMPServer, QueueId) -> NonEmpty SndQueue -> Maybe SndQueue
forall q.
SMPQueue q =>
(SMPServer, QueueId) -> NonEmpty q -> Maybe q
findQ (SMPServer, QueueId)
addr NonEmpty SndQueue
sqs of
              Just sq' :: SndQueue
sq'@SndQueue {$sel:dbReplaceQueueId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> Maybe UserId
dbReplaceQueueId = Just UserId
replaceQId} -> do
                case (SndQueue -> Bool) -> NonEmpty SndQueue -> Maybe SndQueue
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((UserId
replaceQId UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
==) (UserId -> Bool) -> (SndQueue -> UserId) -> SndQueue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SndQueue -> UserId
forall q. SMPQueueRec q => q -> UserId
dbQId) NonEmpty SndQueue
sqs of
                  Just SndQueue
sq1 -> do
                    SndQueue
-> SndSwitchStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkSQSwchStatus SndQueue
sq1 SndSwitchStatus
SSSendingQKEY
                    ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId
"MSG <QUSE>:" ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId -> ConnId
logSecret' ConnId
srvMsgId ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId
" " ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> QueueId -> ConnId
logSecret ((SMPServer, QueueId) -> QueueId
forall a b. (a, b) -> b
snd (SMPServer, QueueId)
addr)
                    AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> SndQueue -> QueueStatus -> IO ()
setSndQueueStatus Connection
db SndQueue
sq' QueueStatus
Secured
                    let sq'' :: SndQueue
sq'' = (SndQueue
sq' :: SndQueue) {status = Secured}
                    -- sending QTEST to the new queue only, the old one will be removed if sent successfully
                    AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM (UserId, PQEncryption)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> ConnData
-> NonEmpty SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessages AgentClient
c ConnData
cData' [Item (NonEmpty SndQueue)
SndQueue
sq''] MsgFlags
SMP.noMsgFlags (AMessage -> AM (UserId, PQEncryption))
-> AMessage -> AM (UserId, PQEncryption)
forall a b. (a -> b) -> a -> b
$ NonEmpty (SMPServer, QueueId) -> AMessage
QTEST [(SMPServer, QueueId)
Item (NonEmpty (SMPServer, QueueId))
addr]
                    SndQueue
sq1' <- AgentClient -> (Connection -> IO SndQueue) -> AM SndQueue
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO SndQueue) -> AM SndQueue)
-> (Connection -> IO SndQueue) -> AM SndQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> SndQueue -> Maybe SndSwitchStatus -> IO SndQueue
setSndSwitchStatus Connection
db SndQueue
sq1 (Maybe SndSwitchStatus -> IO SndQueue)
-> Maybe SndSwitchStatus -> IO SndQueue
forall a b. (a -> b) -> a -> b
$ SndSwitchStatus -> Maybe SndSwitchStatus
forall a. a -> Maybe a
Just SndSwitchStatus
SSSendingQTEST
                    let sqs' :: NonEmpty SndQueue
sqs' = SndQueue -> NonEmpty SndQueue -> NonEmpty SndQueue
forall q. SMPQueueRec q => q -> NonEmpty q -> NonEmpty q
updatedQs SndQueue
sq1' NonEmpty SndQueue
sqs
                        conn' :: Connection 'CDuplex
conn' = ConnData
-> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection 'CDuplex
forall rq sq.
ConnData
-> NonEmpty rq -> NonEmpty sq -> Connection' 'CDuplex rq sq
DuplexConnection ConnData
cData' NonEmpty RcvQueue
rqs NonEmpty SndQueue
sqs'
                    ConnectionStats
cStats <- AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection 'CDuplex
conn'
                    AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ QueueDirection -> SwitchPhase -> ConnectionStats -> AEvent 'AEConn
SWITCH QueueDirection
QDSnd SwitchPhase
SPSecured ConnectionStats
cStats
                  Maybe SndQueue
_ -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. String -> AM a
qError String
"QUSE: switching SndQueue not found in connection"
              Maybe SndQueue
_ -> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. String -> AM a
qError String
"QUSE: switched queue address not found in connection"

          qError :: String -> AM a
          qError :: forall a. String -> AM a
qError = AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) a)
-> (String -> AgentErrorType)
-> String
-> ExceptT AgentErrorType (ReaderT Env IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPAgentError -> AgentErrorType
AGENT (SMPAgentError -> AgentErrorType)
-> (String -> SMPAgentError) -> String -> AgentErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SMPAgentError
A_QUEUE

          ereadyMsg :: CR.RatchetX448 -> Connection 'CDuplex -> AM ()
          ereadyMsg :: RatchetX448
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ()
ereadyMsg RatchetX448
rcPrev (DuplexConnection cData' :: ConnData
cData'@ConnData {UserId
$sel:lastExternalSndId:ConnData :: ConnData -> UserId
lastExternalSndId :: UserId
lastExternalSndId} NonEmpty RcvQueue
_ NonEmpty SndQueue
sqs) = do
            let CR.Ratchet {Maybe (SndRatchet 'X448)
rcSnd :: Maybe (SndRatchet 'X448)
$sel:rcSnd:Ratchet :: forall (a :: Algorithm). Ratchet a -> Maybe (SndRatchet a)
rcSnd} = RatchetX448
rcPrev
            -- if ratchet was initialized as receiving, it means EREADY wasn't sent on key negotiation
            Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (SndRatchet 'X448) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (SndRatchet 'X448)
rcSnd) (ExceptT AgentErrorType (ReaderT Env IO) ()
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AM (UserId, PQEncryption)
    -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM (UserId, PQEncryption)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$
              AgentClient
-> ConnData
-> NonEmpty SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessages' AgentClient
c ConnData
cData' NonEmpty SndQueue
sqs SMP.MsgFlags {$sel:notification:MsgFlags :: Bool
notification = Bool
True} (UserId -> AMessage
EREADY UserId
lastExternalSndId)

          smpInvitation :: SMP.MsgId -> Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM ()
          smpInvitation :: ConnId
-> Connection c
-> ConnectionRequestUri 'CMInvitation
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
smpInvitation ConnId
srvMsgId Connection c
conn' connReq :: ConnectionRequestUri 'CMInvitation
connReq@(CRInvitationUri ConnReqUriData
crData RcvE2ERatchetParamsUri 'X448
_) ConnId
cInfo = do
            ConnId
-> AgentClient
-> SMPServer
-> QueueId
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) (s :: ProtocolType).
MonadIO m =>
ConnId
-> AgentClient -> ProtocolServer s -> QueueId -> ConnId -> m ()
logServer ConnId
"<--" AgentClient
c ProtoServer BrokerMsg
SMPServer
srv QueueId
rId (ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ConnId -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId
"MSG <KEY>:" ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> ConnId -> ConnId
logSecret' ConnId
srvMsgId
            case Connection c
conn' of
              ContactConnection {} -> do
                -- show connection request even if invitaion via contact address is not compatible.
                -- in case invitation not compatible, assume there is no PQ encryption support.
                PQSupport
pqSupport <- ReaderT Env IO PQSupport
-> ExceptT AgentErrorType (ReaderT Env IO) PQSupport
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 PQSupport
 -> ExceptT AgentErrorType (ReaderT Env IO) PQSupport)
-> ReaderT Env IO PQSupport
-> ExceptT AgentErrorType (ReaderT Env IO) PQSupport
forall a b. (a -> b) -> a -> b
$ PQSupport
-> ((Compatible SMPQueueInfo,
     Compatible (RcvE2ERatchetParams 'X448), Compatible VersionSMPA)
    -> PQSupport)
-> Maybe
     (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
      Compatible VersionSMPA)
-> PQSupport
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PQSupport
PQSupportOff (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
 Compatible VersionSMPA)
-> PQSupport
forall {a} {s :: RatchetKEMState} {a :: Algorithm}.
(a, Compatible (E2ERatchetParams s a), Compatible VersionSMPA)
-> PQSupport
pqSupported (Maybe
   (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
    Compatible VersionSMPA)
 -> PQSupport)
-> ReaderT
     Env
     IO
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
-> ReaderT Env IO PQSupport
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConnectionRequestUri 'CMInvitation
-> ReaderT
     Env
     IO
     (Maybe
        (Compatible SMPQueueInfo, Compatible (RcvE2ERatchetParams 'X448),
         Compatible VersionSMPA))
compatibleInvitationUri ConnectionRequestUri 'CMInvitation
connReq
                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
                let newInv :: NewInvitation
newInv = NewInvitation {$sel:contactConnId:NewInvitation :: ConnId
contactConnId = ConnId
connId, ConnectionRequestUri 'CMInvitation
connReq :: ConnectionRequestUri 'CMInvitation
$sel:connReq:NewInvitation :: ConnectionRequestUri 'CMInvitation
connReq, $sel:recipientConnInfo:NewInvitation :: ConnId
recipientConnInfo = ConnId
cInfo}
                ConnId
invId <- AgentClient
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError ConnId)) -> AM ConnId)
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> TVar ChaChaDRG -> NewInvitation -> IO (Either StoreError ConnId)
createInvitation Connection
db TVar ChaChaDRG
g NewInvitation
newInv
                let srvs :: NonEmpty SMPServer
srvs = (SMPQueueUri -> SMPServer)
-> NonEmpty SMPQueueUri -> NonEmpty SMPServer
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map SMPQueueUri -> SMPServer
forall q. SMPQueue q => q -> SMPServer
qServer (NonEmpty SMPQueueUri -> NonEmpty SMPServer)
-> NonEmpty SMPQueueUri -> NonEmpty SMPServer
forall a b. (a -> b) -> a -> b
$ ConnReqUriData -> NonEmpty SMPQueueUri
crSmpQueues ConnReqUriData
crData
                AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId
-> PQSupport -> NonEmpty SMPServer -> ConnId -> AEvent 'AEConn
REQ ConnId
invId PQSupport
pqSupport NonEmpty SMPServer
srvs ConnId
cInfo
              Connection c
_ -> Text -> ExceptT AgentErrorType (ReaderT Env IO) ()
prohibited Text
"inv: sent to message conn"
            where
              pqSupported :: (a, Compatible (E2ERatchetParams s a), Compatible VersionSMPA)
-> PQSupport
pqSupported (a
_, Compatible (CR.E2ERatchetParams VersionE2E
v PublicKey a
_ PublicKey a
_ Maybe (RKEMParams s)
_), Compatible VersionSMPA
agentVersion) =
                PQSupport
PQSupportOn PQSupport -> PQSupport -> PQSupport
`CR.pqSupportAnd` VersionSMPA -> Maybe VersionE2E -> PQSupport
versionPQSupport_ VersionSMPA
agentVersion (VersionE2E -> Maybe VersionE2E
forall a. a -> Maybe a
Just VersionE2E
v)

          qDuplex :: Connection c -> String -> (Connection 'CDuplex -> AM a) -> AM a
          qDuplex :: forall a.
Connection c -> String -> (Connection 'CDuplex -> AM a) -> AM a
qDuplex Connection c
conn' String
name Connection 'CDuplex -> AM a
action = case Connection c
conn' of
            DuplexConnection {} -> Connection 'CDuplex -> AM a
action Connection c
Connection 'CDuplex
conn'
            Connection c
_ -> String -> AM a
forall a. String -> AM a
qError (String -> AM a) -> String -> AM a
forall a b. (a -> b) -> a -> b
$ String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": message must be sent to duplex connection"

          newRatchetKey :: CR.RcvE2ERatchetParams 'C.X448 -> Connection 'CDuplex -> AM ()
          newRatchetKey :: RcvE2ERatchetParams 'X448
-> Connection 'CDuplex
-> ExceptT AgentErrorType (ReaderT Env IO) ()
newRatchetKey e2eOtherPartyParams :: RcvE2ERatchetParams 'X448
e2eOtherPartyParams@(CR.E2ERatchetParams VersionE2E
e2eVersion PublicKey 'X448
k1Rcv PublicKey 'X448
k2Rcv Maybe (RKEMParams 'RKSProposed)
_) conn' :: Connection 'CDuplex
conn'@(DuplexConnection cData' :: ConnData
cData'@ConnData {UserId
$sel:lastExternalSndId:ConnData :: ConnData -> UserId
lastExternalSndId :: UserId
lastExternalSndId, PQSupport
$sel:pqSupport:ConnData :: ConnData -> PQSupport
pqSupport :: PQSupport
pqSupport} NonEmpty RcvQueue
_ NonEmpty SndQueue
sqs) =
            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 ExceptT AgentErrorType (ReaderT Env IO) Bool
ratchetExists (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
$ do
              AgentConfig {VersionRangeE2E
$sel:e2eEncryptVRange:AgentConfig :: AgentConfig -> VersionRangeE2E
e2eEncryptVRange :: VersionRangeE2E
e2eEncryptVRange} <- (Env -> AgentConfig)
-> ExceptT AgentErrorType (ReaderT Env IO) AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
              Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (VersionE2E
e2eVersion VersionE2E -> VersionRangeE2E -> Bool
forall v a. VersionI v a => a -> VersionRange v -> Bool
`isCompatible` VersionRangeE2E
e2eEncryptVRange) (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION)
              (PrivateKey 'X448, PrivateKey 'X448,
 Maybe (PrivRKEMParams 'RKSProposed))
keys <- AM
  (PrivateKey 'X448, PrivateKey 'X448,
   Maybe (PrivRKEMParams 'RKSProposed))
getSendRatchetKeys
              let rcVs :: RatchetVersions
rcVs = CR.RatchetVersions {$sel:current:RatchetVersions :: VersionE2E
current = VersionE2E
e2eVersion, $sel:maxSupported:RatchetVersions :: VersionE2E
maxSupported = VersionRangeE2E -> VersionE2E
forall v. VersionRange v -> Version v
maxVersion VersionRangeE2E
e2eEncryptVRange}
              RatchetVersions
-> (PrivateKey 'X448, PrivateKey 'X448,
    Maybe (PrivRKEMParams 'RKSProposed))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
initRatchet RatchetVersions
rcVs (PrivateKey 'X448, PrivateKey 'X448,
 Maybe (PrivRKEMParams 'RKSProposed))
keys
              ExceptT AgentErrorType (ReaderT Env IO) ()
notifyAgreed
            where
              rkHashRcv :: ConnId
rkHashRcv = PublicKey 'X448 -> PublicKey 'X448 -> ConnId
forall {a :: Algorithm} {a :: Algorithm}.
PublicKey a -> PublicKey a -> ConnId
rkHash PublicKey 'X448
k1Rcv PublicKey 'X448
k2Rcv
              rkHash :: PublicKey a -> PublicKey a -> ConnId
rkHash PublicKey a
k1 PublicKey a
k2 = ConnId -> ConnId
C.sha256Hash (ConnId -> ConnId) -> ConnId -> ConnId
forall a b. (a -> b) -> a -> b
$ PublicKey a -> ConnId
forall (a :: Algorithm). PublicKey a -> ConnId
C.pubKeyBytes PublicKey a
k1 ConnId -> ConnId -> ConnId
forall a. Semigroup a => a -> a -> a
<> PublicKey a -> ConnId
forall (a :: Algorithm). PublicKey a -> ConnId
C.pubKeyBytes PublicKey a
k2
              ratchetExists :: AM Bool
              ratchetExists :: ExceptT AgentErrorType (ReaderT Env IO) Bool
ratchetExists = AgentClient
-> (Connection -> IO Bool)
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO Bool)
 -> ExceptT AgentErrorType (ReaderT Env IO) Bool)
-> (Connection -> IO Bool)
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                Bool
exists <- Connection -> ConnId -> ConnId -> IO Bool
checkRatchetKeyHashExists Connection
db ConnId
connId ConnId
rkHashRcv
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> ConnId -> IO ()
addProcessedRatchetKeyHash Connection
db ConnId
connId ConnId
rkHashRcv
                Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
exists
              getSendRatchetKeys :: AM (C.PrivateKeyX448, C.PrivateKeyX448, Maybe CR.RcvPrivRKEMParams)
              getSendRatchetKeys :: AM
  (PrivateKey 'X448, PrivateKey 'X448,
   Maybe (PrivRKEMParams 'RKSProposed))
getSendRatchetKeys = case RatchetSyncState
rss of
                RatchetSyncState
RSOk -> AM
  (PrivateKey 'X448, PrivateKey 'X448,
   Maybe (PrivRKEMParams 'RKSProposed))
sendReplyKey -- receiving client
                RatchetSyncState
RSAllowed -> AM
  (PrivateKey 'X448, PrivateKey 'X448,
   Maybe (PrivRKEMParams 'RKSProposed))
sendReplyKey
                RatchetSyncState
RSRequired -> AM
  (PrivateKey 'X448, PrivateKey 'X448,
   Maybe (PrivRKEMParams 'RKSProposed))
sendReplyKey
                RatchetSyncState
RSStarted -> AgentClient
-> (Connection
    -> IO
         (Either
            StoreError
            (PrivateKey 'X448, PrivateKey 'X448,
             Maybe (PrivRKEMParams 'RKSProposed))))
-> AM
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed))
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c (Connection
-> ConnId
-> IO
     (Either
        StoreError
        (PrivateKey 'X448, PrivateKey 'X448,
         Maybe (PrivRKEMParams 'RKSProposed)))
`getRatchetX3dhKeys` ConnId
connId) -- initiating client
                RatchetSyncState
RSAgreed -> do
                  AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> ConnId -> RatchetSyncState -> IO ()
setConnRatchetSync Connection
db ConnId
connId RatchetSyncState
RSRequired
                  ExceptT AgentErrorType (ReaderT Env IO) ()
notifyRatchetSyncError
                  -- can communicate for other client to reset to RSRequired
                  -- - need to add new AgentMsgEnvelope, AgentMessage, AgentMessageType
                  -- - need to deduplicate on receiving side
                  AgentErrorType
-> AM
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed))
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType
 -> AM
      (PrivateKey 'X448, PrivateKey 'X448,
       Maybe (PrivRKEMParams 'RKSProposed)))
-> AgentErrorType
-> AM
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed))
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT (AgentCryptoError -> SMPAgentError
A_CRYPTO AgentCryptoError
RATCHET_SYNC)
                where
                  sendReplyKey :: AM
  (PrivateKey 'X448, PrivateKey 'X448,
   Maybe (PrivRKEMParams 'RKSProposed))
sendReplyKey = 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
                    (PrivateKey 'X448
pk1, PrivateKey 'X448
pk2, Maybe (PrivRKEMParams 'RKSProposed)
pKem, RcvE2ERatchetParams 'X448
e2eParams) <- IO
  (PrivateKey 'X448, PrivateKey 'X448,
   Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
forall a. IO a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (PrivateKey 'X448, PrivateKey 'X448,
    Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (PrivateKey 'X448, PrivateKey 'X448,
       Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448))
-> IO
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> VersionE2E
-> PQSupport
-> IO
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed), RcvE2ERatchetParams 'X448)
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> VersionE2E
-> PQSupport
-> IO
     (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed),
      E2ERatchetParams 'RKSProposed a)
CR.generateRcvE2EParams TVar ChaChaDRG
g VersionE2E
e2eVersion PQSupport
pqSupport
                    AgentClient
-> NonEmpty SndQueue
-> RcvE2ERatchetParams 'X448
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueRatchetKeyMsgs AgentClient
c NonEmpty SndQueue
sqs RcvE2ERatchetParams 'X448
e2eParams
                    (PrivateKey 'X448, PrivateKey 'X448,
 Maybe (PrivRKEMParams 'RKSProposed))
-> AM
     (PrivateKey 'X448, PrivateKey 'X448,
      Maybe (PrivRKEMParams 'RKSProposed))
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrivateKey 'X448
pk1, PrivateKey 'X448
pk2, Maybe (PrivRKEMParams 'RKSProposed)
pKem)
                  notifyRatchetSyncError :: ExceptT AgentErrorType (ReaderT Env IO) ()
notifyRatchetSyncError = do
                    let cData'' :: ConnData
cData'' = ConnData
cData' {ratchetSyncState = RSRequired} :: ConnData
                        conn'' :: Connection 'CDuplex
conn'' = ConnData -> Connection 'CDuplex -> Connection 'CDuplex
forall (d :: ConnType) rq sq.
ConnData -> Connection' d rq sq -> Connection' d rq sq
updateConnection ConnData
cData'' Connection 'CDuplex
conn'
                    ConnectionStats
cStats <- AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection 'CDuplex
conn''
                    AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ RatchetSyncState
-> Maybe AgentCryptoError -> ConnectionStats -> AEvent 'AEConn
RSYNC RatchetSyncState
RSRequired (AgentCryptoError -> Maybe AgentCryptoError
forall a. a -> Maybe a
Just AgentCryptoError
RATCHET_SYNC) ConnectionStats
cStats
              notifyAgreed :: AM ()
              notifyAgreed :: ExceptT AgentErrorType (ReaderT Env IO) ()
notifyAgreed = do
                let cData'' :: ConnData
cData'' = ConnData
cData' {ratchetSyncState = RSAgreed} :: ConnData
                    conn'' :: Connection 'CDuplex
conn'' = ConnData -> Connection 'CDuplex -> Connection 'CDuplex
forall (d :: ConnType) rq sq.
ConnData -> Connection' d rq sq -> Connection' d rq sq
updateConnection ConnData
cData'' Connection 'CDuplex
conn'
                ConnectionStats
cStats <- AgentClient -> Connection 'CDuplex -> AM ConnectionStats
forall (c :: ConnType).
AgentClient -> Connection c -> AM ConnectionStats
connectionStats AgentClient
c Connection 'CDuplex
conn''
                AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (e :: AEntity) (m :: * -> *).
(AEntityI e, MonadIO m) =>
AEvent e -> m ()
notify (AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AEvent 'AEConn -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ RatchetSyncState
-> Maybe AgentCryptoError -> ConnectionStats -> AEvent 'AEConn
RSYNC RatchetSyncState
RSAgreed Maybe AgentCryptoError
forall a. Maybe a
Nothing ConnectionStats
cStats
              recreateRatchet :: CR.Ratchet 'C.X448 -> AM ()
              recreateRatchet :: RatchetX448 -> ExceptT AgentErrorType (ReaderT Env IO) ()
recreateRatchet RatchetX448
rc = AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                Connection -> ConnId -> RatchetSyncState -> IO ()
setConnRatchetSync Connection
db ConnId
connId RatchetSyncState
RSAgreed
                Connection -> ConnId -> IO ()
deleteRatchet Connection
db ConnId
connId
                Connection -> ConnId -> RatchetX448 -> IO ()
createRatchet Connection
db ConnId
connId RatchetX448
rc
              -- compare public keys `k1` in AgentRatchetKey messages sent by self and other party
              -- to determine ratchet initilization ordering
              initRatchet :: CR.RatchetVersions -> (C.PrivateKeyX448, C.PrivateKeyX448, Maybe CR.RcvPrivRKEMParams) -> AM ()
              initRatchet :: RatchetVersions
-> (PrivateKey 'X448, PrivateKey 'X448,
    Maybe (PrivRKEMParams 'RKSProposed))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
initRatchet RatchetVersions
rcVs (PrivateKey 'X448
pk1, PrivateKey 'X448
pk2, Maybe (PrivRKEMParams 'RKSProposed)
pKem)
                | PublicKey 'X448 -> PublicKey 'X448 -> ConnId
forall {a :: Algorithm} {a :: Algorithm}.
PublicKey a -> PublicKey a -> ConnId
rkHash (PrivateKey 'X448 -> PublicKey 'X448
forall (a :: Algorithm). PrivateKey a -> PublicKey a
C.publicKey PrivateKey 'X448
pk1) (PrivateKey 'X448 -> PublicKey 'X448
forall (a :: Algorithm). PrivateKey a -> PublicKey a
C.publicKey PrivateKey 'X448
pk2) ConnId -> ConnId -> Bool
forall a. Ord a => a -> a -> Bool
<= ConnId
rkHashRcv = do
                    (RatchetInitParams, Maybe KEMKeyPair)
rcParams <- (CryptoError -> AgentErrorType)
-> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RatchetInitParams, Maybe KEMKeyPair)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError CryptoError -> AgentErrorType
cryptoError (ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (RatchetInitParams, Maybe KEMKeyPair))
-> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RatchetInitParams, Maybe KEMKeyPair)
forall a b. (a -> b) -> a -> b
$ PrivateKey 'X448
-> PrivateKey 'X448
-> Maybe (PrivRKEMParams 'RKSProposed)
-> RcvE2ERatchetParams 'X448
-> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
forall (s :: RatchetKEMState) (a :: Algorithm).
(RatchetKEMStateI s, DhAlgorithm a) =>
PrivateKey a
-> PrivateKey a
-> Maybe (PrivRKEMParams 'RKSProposed)
-> E2ERatchetParams s a
-> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
CR.pqX3dhRcv PrivateKey 'X448
pk1 PrivateKey 'X448
pk2 Maybe (PrivRKEMParams 'RKSProposed)
pKem RcvE2ERatchetParams 'X448
e2eOtherPartyParams
                    RatchetX448 -> ExceptT AgentErrorType (ReaderT Env IO) ()
recreateRatchet (RatchetX448 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> RatchetX448 -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ RatchetVersions
-> PrivateKey 'X448
-> (RatchetInitParams, Maybe KEMKeyPair)
-> PQSupport
-> RatchetX448
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
RatchetVersions
-> PrivateKey a
-> (RatchetInitParams, Maybe KEMKeyPair)
-> PQSupport
-> Ratchet a
CR.initRcvRatchet RatchetVersions
rcVs PrivateKey 'X448
pk2 (RatchetInitParams, Maybe KEMKeyPair)
rcParams PQSupport
pqSupport
                | Bool
otherwise = do
                    (PublicKey 'X448
_, PrivateKey 'X448
rcDHRs) <- STM (PublicKey 'X448, PrivateKey 'X448)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (PublicKey 'X448, PrivateKey 'X448)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKey 'X448, PrivateKey 'X448)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (PublicKey 'X448, PrivateKey 'X448))
-> (TVar ChaChaDRG -> STM (PublicKey 'X448, PrivateKey 'X448))
-> TVar ChaChaDRG
-> ExceptT
     AgentErrorType (ReaderT Env IO) (PublicKey 'X448, PrivateKey 'X448)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChaChaDRG -> STM (KeyPair 'X448)
TVar ChaChaDRG -> STM (PublicKey 'X448, PrivateKey 'X448)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair (TVar ChaChaDRG
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (PublicKey 'X448, PrivateKey 'X448))
-> ExceptT AgentErrorType (ReaderT Env IO) (TVar ChaChaDRG)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (PublicKey 'X448, PrivateKey 'X448)
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
                    (RatchetInitParams, Maybe KEMKeyPair)
rcParams <- (CryptoError -> AgentErrorType)
-> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RatchetInitParams, Maybe KEMKeyPair)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith CryptoError -> AgentErrorType
cryptoError (Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
 -> ExceptT
      AgentErrorType
      (ReaderT Env IO)
      (RatchetInitParams, Maybe KEMKeyPair))
-> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
-> ExceptT
     AgentErrorType
     (ReaderT Env IO)
     (RatchetInitParams, Maybe KEMKeyPair)
forall a b. (a -> b) -> a -> b
$ PrivateKey 'X448
-> PrivateKey 'X448
-> Maybe APrivRKEMParams
-> RcvE2ERatchetParams 'X448
-> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
forall (a :: Algorithm).
DhAlgorithm a =>
PrivateKey a
-> PrivateKey a
-> Maybe APrivRKEMParams
-> E2ERatchetParams 'RKSProposed a
-> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
CR.pqX3dhSnd PrivateKey 'X448
pk1 PrivateKey 'X448
pk2 (SRatchetKEMState 'RKSProposed
-> PrivRKEMParams 'RKSProposed -> APrivRKEMParams
forall (s :: RatchetKEMState).
RatchetKEMStateI s =>
SRatchetKEMState s -> PrivRKEMParams s -> APrivRKEMParams
CR.APRKP SRatchetKEMState 'RKSProposed
CR.SRKSProposed (PrivRKEMParams 'RKSProposed -> APrivRKEMParams)
-> Maybe (PrivRKEMParams 'RKSProposed) -> Maybe APrivRKEMParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PrivRKEMParams 'RKSProposed)
pKem) RcvE2ERatchetParams 'X448
e2eOtherPartyParams
                    RatchetX448 -> ExceptT AgentErrorType (ReaderT Env IO) ()
recreateRatchet (RatchetX448 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> RatchetX448 -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ RatchetVersions
-> PublicKey 'X448
-> PrivateKey 'X448
-> (RatchetInitParams, Maybe KEMKeyPair)
-> RatchetX448
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
RatchetVersions
-> PublicKey a
-> PrivateKey a
-> (RatchetInitParams, Maybe KEMKeyPair)
-> Ratchet a
CR.initSndRatchet RatchetVersions
rcVs PublicKey 'X448
k2Rcv PrivateKey 'X448
rcDHRs (RatchetInitParams, Maybe KEMKeyPair)
rcParams
                    AM (UserId, PQEncryption)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AM (UserId, PQEncryption)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (AMessage -> AM (UserId, PQEncryption))
-> AMessage
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient
-> ConnData
-> NonEmpty SndQueue
-> MsgFlags
-> AMessage
-> AM (UserId, PQEncryption)
enqueueMessages' AgentClient
c ConnData
cData' NonEmpty SndQueue
sqs SMP.MsgFlags {$sel:notification:MsgFlags :: Bool
notification = Bool
True} (AMessage -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AMessage -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ UserId -> AMessage
EREADY UserId
lastExternalSndId

          checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity
          checkMsgIntegrity :: UserId -> UserId -> ConnId -> ConnId -> MsgIntegrity
checkMsgIntegrity UserId
prevExtSndId UserId
extSndId ConnId
internalPrevMsgHash ConnId
receivedPrevMsgHash
            | UserId
extSndId UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== UserId
prevExtSndId UserId -> UserId -> UserId
forall a. Num a => a -> a -> a
+ UserId
1 Bool -> Bool -> Bool
&& ConnId
internalPrevMsgHash ConnId -> ConnId -> Bool
forall a. Eq a => a -> a -> Bool
== ConnId
receivedPrevMsgHash = MsgIntegrity
MsgOk
            | UserId
extSndId UserId -> UserId -> Bool
forall a. Ord a => a -> a -> Bool
< UserId
prevExtSndId = MsgErrorType -> MsgIntegrity
MsgError (MsgErrorType -> MsgIntegrity) -> MsgErrorType -> MsgIntegrity
forall a b. (a -> b) -> a -> b
$ UserId -> MsgErrorType
MsgBadId UserId
extSndId
            | UserId
extSndId UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== UserId
prevExtSndId = MsgErrorType -> MsgIntegrity
MsgError MsgErrorType
MsgDuplicate -- ? deduplicate
            | UserId
extSndId UserId -> UserId -> Bool
forall a. Ord a => a -> a -> Bool
> UserId
prevExtSndId UserId -> UserId -> UserId
forall a. Num a => a -> a -> a
+ UserId
1 = MsgErrorType -> MsgIntegrity
MsgError (MsgErrorType -> MsgIntegrity) -> MsgErrorType -> MsgIntegrity
forall a b. (a -> b) -> a -> b
$ UserId -> UserId -> MsgErrorType
MsgSkipped (UserId
prevExtSndId UserId -> UserId -> UserId
forall a. Num a => a -> a -> a
+ UserId
1) (UserId
extSndId UserId -> UserId -> UserId
forall a. Num a => a -> a -> a
- UserId
1)
            | ConnId
internalPrevMsgHash ConnId -> ConnId -> Bool
forall a. Eq a => a -> a -> Bool
/= ConnId
receivedPrevMsgHash = MsgErrorType -> MsgIntegrity
MsgError MsgErrorType
MsgBadHash
            | Bool
otherwise = MsgErrorType -> MsgIntegrity
MsgError MsgErrorType
MsgDuplicate -- this case is not possible

checkRQSwchStatus :: RcvQueue -> RcvSwitchStatus -> AM ()
checkRQSwchStatus :: RcvQueue
-> RcvSwitchStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkRQSwchStatus rq :: RcvQueue
rq@RcvQueue {Maybe RcvSwitchStatus
$sel:rcvSwchStatus:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> Maybe RcvSwitchStatus
rcvSwchStatus :: Maybe RcvSwitchStatus
rcvSwchStatus} RcvSwitchStatus
expected =
  Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe RcvSwitchStatus
rcvSwchStatus Maybe RcvSwitchStatus -> Maybe RcvSwitchStatus -> Bool
forall a. Eq a => a -> a -> Bool
== RcvSwitchStatus -> Maybe RcvSwitchStatus
forall a. a -> Maybe a
Just RcvSwitchStatus
expected) (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
$ RcvQueue
-> RcvSwitchStatus
-> Maybe RcvSwitchStatus
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall q a.
(SMPQueueRec q, Show a) =>
q -> a -> Maybe a -> ExceptT AgentErrorType (ReaderT Env IO) ()
switchStatusError RcvQueue
rq RcvSwitchStatus
expected Maybe RcvSwitchStatus
rcvSwchStatus
{-# INLINE checkRQSwchStatus #-}

checkSQSwchStatus :: SndQueue -> SndSwitchStatus -> AM ()
checkSQSwchStatus :: SndQueue
-> SndSwitchStatus -> ExceptT AgentErrorType (ReaderT Env IO) ()
checkSQSwchStatus sq :: SndQueue
sq@SndQueue {Maybe SndSwitchStatus
$sel:sndSwchStatus:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> Maybe SndSwitchStatus
sndSwchStatus :: Maybe SndSwitchStatus
sndSwchStatus} SndSwitchStatus
expected =
  Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe SndSwitchStatus
sndSwchStatus Maybe SndSwitchStatus -> Maybe SndSwitchStatus -> Bool
forall a. Eq a => a -> a -> Bool
== SndSwitchStatus -> Maybe SndSwitchStatus
forall a. a -> Maybe a
Just SndSwitchStatus
expected) (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
$ SndQueue
-> SndSwitchStatus
-> Maybe SndSwitchStatus
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall q a.
(SMPQueueRec q, Show a) =>
q -> a -> Maybe a -> ExceptT AgentErrorType (ReaderT Env IO) ()
switchStatusError SndQueue
sq SndSwitchStatus
expected Maybe SndSwitchStatus
sndSwchStatus
{-# INLINE checkSQSwchStatus #-}

switchStatusError :: (SMPQueueRec q, Show a) => q -> a -> Maybe a -> AM ()
switchStatusError :: forall q a.
(SMPQueueRec q, Show a) =>
q -> a -> Maybe a -> ExceptT AgentErrorType (ReaderT Env IO) ()
switchStatusError q
q a
expected Maybe a
actual =
  AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (String -> AgentErrorType)
-> String
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AgentErrorType
INTERNAL (String -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> String -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$
    (String
"unexpected switch status, queueId=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> QueueId -> String
forall a. Show a => a -> String
show (q -> QueueId
forall q. SMPQueue q => q -> QueueId
queueId q
q))
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (String
", expected=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
expected)
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (String
", actual=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe a -> String
forall a. Show a => a -> String
show Maybe a
actual)

-- used only in background
connectReplyQueues :: AgentClient -> ConnData -> ConnInfo -> Maybe SndQueue -> NonEmpty SMPQueueInfo -> AM ()
connectReplyQueues :: AgentClient
-> ConnData
-> ConnId
-> Maybe SndQueue
-> NonEmpty SMPQueueInfo
-> ExceptT AgentErrorType (ReaderT Env IO) ()
connectReplyQueues AgentClient
c cData :: ConnData
cData@ConnData {UserId
$sel:userId:ConnData :: ConnData -> UserId
userId :: UserId
userId, ConnId
$sel:connId:ConnData :: ConnData -> ConnId
connId :: ConnId
connId} ConnId
ownConnInfo Maybe SndQueue
sq_ (SMPQueueInfo
qInfo :| [SMPQueueInfo]
_) = do
  VersionRangeSMPC
clientVRange <- (Env -> VersionRangeSMPC)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> VersionRangeSMPC)
 -> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC)
-> (Env -> VersionRangeSMPC)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionRangeSMPC
forall a b. (a -> b) -> a -> b
$ AgentConfig -> VersionRangeSMPC
smpClientVRange (AgentConfig -> VersionRangeSMPC)
-> (Env -> AgentConfig) -> Env -> VersionRangeSMPC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  case SMPQueueInfo
qInfo SMPQueueInfo -> VersionRangeSMPC -> Maybe (Compatible SMPQueueInfo)
forall v a.
VersionI v a =>
a -> VersionRange v -> Maybe (Compatible a)
`proveCompatible` VersionRangeSMPC
clientVRange of
    Maybe (Compatible SMPQueueInfo)
Nothing -> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentErrorType -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_VERSION
    Just Compatible SMPQueueInfo
qInfo' -> do
      -- in case of SKEY retry the connection is already duplex
      SndQueue
sq' <- AM SndQueue
-> (SndQueue -> AM SndQueue) -> Maybe SndQueue -> AM SndQueue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AM SndQueue
upgradeConn SndQueue -> AM SndQueue
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SndQueue
sq_
      ExceptT AgentErrorType (ReaderT Env IO) Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT AgentErrorType (ReaderT Env IO) Bool
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> NetworkRequestMode
-> ConnData
-> SndQueue
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
agentSecureSndQueue AgentClient
c NetworkRequestMode
NRMBackground ConnData
cData SndQueue
sq'
      AgentClient
-> ConnData
-> SndQueue
-> ConnId
-> Maybe (SndE2ERatchetParams 'X448)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueConfirmation AgentClient
c ConnData
cData SndQueue
sq' ConnId
ownConnInfo Maybe (SndE2ERatchetParams 'X448)
forall a. Maybe a
Nothing
      where
        upgradeConn :: AM SndQueue
upgradeConn = do
          (NewSndQueue
sq, PublicKeyX25519
_) <- ReaderT Env IO (NewSndQueue, PublicKeyX25519)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (NewSndQueue, PublicKeyX25519)
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 (NewSndQueue, PublicKeyX25519)
 -> ExceptT
      AgentErrorType (ReaderT Env IO) (NewSndQueue, PublicKeyX25519))
-> ReaderT Env IO (NewSndQueue, PublicKeyX25519)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (NewSndQueue, PublicKeyX25519)
forall a b. (a -> b) -> a -> b
$ UserId
-> ConnId
-> Compatible SMPQueueInfo
-> Maybe APrivateAuthKey
-> ReaderT Env IO (NewSndQueue, PublicKeyX25519)
newSndQueue UserId
userId ConnId
connId Compatible SMPQueueInfo
qInfo' Maybe APrivateAuthKey
forall a. Maybe a
Nothing
          AgentClient
-> (Connection -> IO (Either StoreError SndQueue)) -> AM SndQueue
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError SndQueue)) -> AM SndQueue)
-> (Connection -> IO (Either StoreError SndQueue)) -> AM SndQueue
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
upgradeRcvConnToDuplex Connection
db ConnId
connId NewSndQueue
sq

secureConfirmQueueAsync :: AgentClient -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
secureConfirmQueueAsync :: AgentClient
-> ConnData
-> Maybe RcvQueue
-> SndQueue
-> SMPServerWithAuth
-> ConnId
-> Maybe (SndE2ERatchetParams 'X448)
-> SubscriptionMode
-> AM (Bool, Maybe ClientServiceId)
secureConfirmQueueAsync AgentClient
c ConnData
cData Maybe RcvQueue
rq_ SndQueue
sq SMPServerWithAuth
srv ConnId
connInfo Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_ SubscriptionMode
subMode = do
  Bool
sqSecured <- AgentClient
-> NetworkRequestMode
-> ConnData
-> SndQueue
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
agentSecureSndQueue AgentClient
c NetworkRequestMode
NRMBackground ConnData
cData SndQueue
sq
  (AgentMessage
qInfo, Maybe ClientServiceId
service) <- AgentClient
-> NetworkRequestMode
-> ConnData
-> Maybe RcvQueue
-> SndQueue
-> SMPServerWithAuth
-> ConnId
-> SubscriptionMode
-> AM (AgentMessage, Maybe ClientServiceId)
mkAgentConfirmation AgentClient
c NetworkRequestMode
NRMBackground ConnData
cData Maybe RcvQueue
rq_ SndQueue
sq SMPServerWithAuth
srv ConnId
connInfo SubscriptionMode
subMode
  AgentClient
-> ConnData
-> SndQueue
-> Maybe (SndE2ERatchetParams 'X448)
-> AgentMessage
-> ExceptT AgentErrorType (ReaderT Env IO) ()
storeConfirmation AgentClient
c ConnData
cData SndQueue
sq Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_ AgentMessage
qInfo
  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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> SndQueue -> ReaderT Env IO ()
submitPendingMsg AgentClient
c SndQueue
sq
  (Bool, Maybe ClientServiceId) -> AM (Bool, Maybe ClientServiceId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
sqSecured, Maybe ClientServiceId
service)

secureConfirmQueue :: AgentClient -> NetworkRequestMode -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
secureConfirmQueue :: AgentClient
-> NetworkRequestMode
-> ConnData
-> Maybe RcvQueue
-> SndQueue
-> SMPServerWithAuth
-> ConnId
-> Maybe (SndE2ERatchetParams 'X448)
-> SubscriptionMode
-> AM (Bool, Maybe ClientServiceId)
secureConfirmQueue AgentClient
c NetworkRequestMode
nm cData :: ConnData
cData@ConnData {ConnId
$sel:connId:ConnData :: ConnData -> ConnId
connId :: ConnId
connId, VersionSMPA
$sel:connAgentVersion:ConnData :: ConnData -> VersionSMPA
connAgentVersion :: VersionSMPA
connAgentVersion, PQSupport
$sel:pqSupport:ConnData :: ConnData -> PQSupport
pqSupport :: PQSupport
pqSupport} Maybe RcvQueue
rq_ SndQueue
sq SMPServerWithAuth
srv ConnId
connInfo Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_ SubscriptionMode
subMode = do
  Bool
sqSecured <- AgentClient
-> NetworkRequestMode
-> ConnData
-> SndQueue
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
agentSecureSndQueue AgentClient
c NetworkRequestMode
nm ConnData
cData SndQueue
sq
  (AgentMessage
qInfo, Maybe ClientServiceId
service) <- AgentClient
-> NetworkRequestMode
-> ConnData
-> Maybe RcvQueue
-> SndQueue
-> SMPServerWithAuth
-> ConnId
-> SubscriptionMode
-> AM (AgentMessage, Maybe ClientServiceId)
mkAgentConfirmation AgentClient
c NetworkRequestMode
nm ConnData
cData Maybe RcvQueue
rq_ SndQueue
sq SMPServerWithAuth
srv ConnId
connInfo SubscriptionMode
subMode
  ConnId
msg <- AgentMessage -> AM ConnId
mkConfirmation AgentMessage
qInfo
  ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient
-> NetworkRequestMode
-> SndQueue
-> ConnId
-> ExceptT AgentErrorType (ReaderT Env IO) (Maybe SMPServer)
sendConfirmation AgentClient
c NetworkRequestMode
nm SndQueue
sq ConnId
msg
  AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> SndQueue -> QueueStatus -> IO ()
setSndQueueStatus Connection
db SndQueue
sq QueueStatus
Confirmed
  (Bool, Maybe ClientServiceId) -> AM (Bool, Maybe ClientServiceId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
sqSecured, Maybe ClientServiceId
service)
  where
    mkConfirmation :: AgentMessage -> AM MsgBody
    mkConfirmation :: AgentMessage -> AM ConnId
mkConfirmation AgentMessage
aMessage = do
      VersionE2E
currentE2EVersion <- (Env -> VersionE2E)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionE2E
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> VersionE2E)
 -> ExceptT AgentErrorType (ReaderT Env IO) VersionE2E)
-> (Env -> VersionE2E)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionE2E
forall a b. (a -> b) -> a -> b
$ VersionRangeE2E -> VersionE2E
forall v. VersionRange v -> Version v
maxVersion (VersionRangeE2E -> VersionE2E)
-> (Env -> VersionRangeE2E) -> Env -> VersionE2E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentConfig -> VersionRangeE2E
e2eEncryptVRange (AgentConfig -> VersionRangeE2E)
-> (Env -> AgentConfig) -> Env -> VersionRangeE2E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
      AgentClient
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError ConnId)) -> AM ConnId)
-> (Connection -> IO (Either StoreError ConnId)) -> AM ConnId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ExceptT StoreError IO ConnId -> IO (Either StoreError ConnId)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO ConnId -> IO (Either StoreError ConnId))
-> ExceptT StoreError IO ConnId -> IO (Either StoreError ConnId)
forall a b. (a -> b) -> a -> b
$ do
        let agentMsgBody :: ConnId
agentMsgBody = AgentMessage -> ConnId
forall a. Encoding a => a -> ConnId
smpEncode AgentMessage
aMessage
        (InternalId
_, InternalSndId
internalSndId, ConnId
_) <- IO (Either StoreError (InternalId, InternalSndId, ConnId))
-> ExceptT StoreError IO (InternalId, InternalSndId, ConnId)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError (InternalId, InternalSndId, ConnId))
 -> ExceptT StoreError IO (InternalId, InternalSndId, ConnId))
-> IO (Either StoreError (InternalId, InternalSndId, ConnId))
-> ExceptT StoreError IO (InternalId, InternalSndId, ConnId)
forall a b. (a -> b) -> a -> b
$ Connection
-> ConnId
-> IO (Either StoreError (InternalId, InternalSndId, ConnId))
updateSndIds Connection
db ConnId
connId
        IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> InternalSndId -> ConnId -> IO ()
updateSndMsgHash Connection
db ConnId
connId InternalSndId
internalSndId (ConnId -> ConnId
C.sha256Hash ConnId
agentMsgBody)
        let pqEnc :: PQEncryption
pqEnc = PQSupport -> PQEncryption
CR.pqSupportToEnc PQSupport
pqSupport
        (ConnId
encConnInfo, PQEncryption
_) <- Connection
-> ConnData
-> ConnId
-> (VersionSMPA -> PQSupport -> Int)
-> Maybe PQEncryption
-> VersionE2E
-> ExceptT StoreError IO (ConnId, PQEncryption)
agentRatchetEncrypt Connection
db ConnData
cData ConnId
agentMsgBody VersionSMPA -> PQSupport -> Int
e2eEncConnInfoLength (PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just PQEncryption
pqEnc) VersionE2E
currentE2EVersion
        ConnId -> ExceptT StoreError IO ConnId
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnId -> ExceptT StoreError IO ConnId)
-> (AgentMsgEnvelope -> ConnId)
-> AgentMsgEnvelope
-> ExceptT StoreError IO ConnId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentMsgEnvelope -> ConnId
forall a. Encoding a => a -> ConnId
smpEncode (AgentMsgEnvelope -> ExceptT StoreError IO ConnId)
-> AgentMsgEnvelope -> ExceptT StoreError IO ConnId
forall a b. (a -> b) -> a -> b
$ AgentConfirmation {$sel:agentVersion:AgentConfirmation :: VersionSMPA
agentVersion = VersionSMPA
connAgentVersion, Maybe (SndE2ERatchetParams 'X448)
$sel:e2eEncryption_:AgentConfirmation :: Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_ :: Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_, ConnId
$sel:encConnInfo:AgentConfirmation :: ConnId
encConnInfo :: ConnId
encConnInfo}

agentSecureSndQueue :: AgentClient -> NetworkRequestMode -> ConnData -> SndQueue -> AM SndQueueSecured
agentSecureSndQueue :: AgentClient
-> NetworkRequestMode
-> ConnData
-> SndQueue
-> ExceptT AgentErrorType (ReaderT Env IO) Bool
agentSecureSndQueue AgentClient
c NetworkRequestMode
nm ConnData {VersionSMPA
$sel:connAgentVersion:ConnData :: ConnData -> VersionSMPA
connAgentVersion :: VersionSMPA
connAgentVersion} sq :: SndQueue
sq@SndQueue {Maybe QueueMode
$sel:queueMode:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> Maybe QueueMode
queueMode :: Maybe QueueMode
queueMode, QueueStatus
$sel:status:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> QueueStatus
status :: QueueStatus
status}
  | Bool
sndSecure Bool -> Bool -> Bool
&& QueueStatus
status QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
New = do
      AgentClient
-> NetworkRequestMode
-> SndQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
secureSndQueue AgentClient
c NetworkRequestMode
nm SndQueue
sq
      AgentClient
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a. AgentClient -> (Connection -> IO a) -> AM a
withStore' AgentClient
c ((Connection -> IO ())
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO ())
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> SndQueue -> QueueStatus -> IO ()
setSndQueueStatus Connection
db SndQueue
sq QueueStatus
Secured
      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
initiatorRatchetOnConf
  -- on repeat JOIN processing (e.g. previous attempt to create reply queue failed)
  | Bool
sndSecure Bool -> Bool -> Bool
&& QueueStatus
status QueueStatus -> QueueStatus -> Bool
forall a. Eq a => a -> a -> Bool
== QueueStatus
Secured = 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
initiatorRatchetOnConf
  | Bool
otherwise = 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
  where
    sndSecure :: Bool
sndSecure = Maybe QueueMode -> Bool
senderCanSecure Maybe QueueMode
queueMode
    initiatorRatchetOnConf :: Bool
initiatorRatchetOnConf = VersionSMPA
connAgentVersion VersionSMPA -> VersionSMPA -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMPA
ratchetOnConfSMPAgentVersion

mkAgentConfirmation :: AgentClient -> NetworkRequestMode -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM (AgentMessage, Maybe ClientServiceId)
mkAgentConfirmation :: AgentClient
-> NetworkRequestMode
-> ConnData
-> Maybe RcvQueue
-> SndQueue
-> SMPServerWithAuth
-> ConnId
-> SubscriptionMode
-> AM (AgentMessage, Maybe ClientServiceId)
mkAgentConfirmation AgentClient
c NetworkRequestMode
nm ConnData
cData Maybe RcvQueue
rq_ SndQueue
sq SMPServerWithAuth
srv ConnId
connInfo SubscriptionMode
subMode = do
  (SMPQueueInfo
qInfo, Maybe ClientServiceId
service) <- case Maybe RcvQueue
rq_ of
    Maybe RcvQueue
Nothing -> AgentClient
-> NetworkRequestMode
-> ConnData
-> SndQueue
-> SubscriptionMode
-> SMPServerWithAuth
-> AM (SMPQueueInfo, Maybe ClientServiceId)
createReplyQueue AgentClient
c NetworkRequestMode
nm ConnData
cData SndQueue
sq SubscriptionMode
subMode SMPServerWithAuth
srv
    Just rq :: RcvQueue
rq@RcvQueue {$sel:smpClientVersion:RcvQueue :: forall (q :: DBStored). StoredRcvQueue q -> VersionSMPC
smpClientVersion = VersionSMPC
v, Maybe (StoredClientService 'DBStored)
$sel:clientService:RcvQueue :: forall (q :: DBStored).
StoredRcvQueue q -> Maybe (StoredClientService q)
clientService :: Maybe (StoredClientService 'DBStored)
clientService} -> (SMPQueueInfo, Maybe ClientServiceId)
-> AM (SMPQueueInfo, Maybe ClientServiceId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VersionSMPC -> SMPQueueAddress -> SMPQueueInfo
SMPQueueInfo VersionSMPC
v (SMPQueueAddress -> SMPQueueInfo)
-> SMPQueueAddress -> SMPQueueInfo
forall a b. (a -> b) -> a -> b
$ RcvQueue -> SMPQueueAddress
rcvSMPQueueAddress RcvQueue
rq, StoredClientService 'DBStored -> ClientServiceId
forall (s :: DBStored). StoredClientService s -> DBEntityId' s
dbServiceId (StoredClientService 'DBStored -> ClientServiceId)
-> Maybe (StoredClientService 'DBStored) -> Maybe ClientServiceId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (StoredClientService 'DBStored)
clientService)
  (AgentMessage, Maybe ClientServiceId)
-> AM (AgentMessage, Maybe ClientServiceId)
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty SMPQueueInfo -> ConnId -> AgentMessage
AgentConnInfoReply (SMPQueueInfo
qInfo SMPQueueInfo -> [SMPQueueInfo] -> NonEmpty SMPQueueInfo
forall a. a -> [a] -> NonEmpty a
:| []) ConnId
connInfo, Maybe ClientServiceId
service)

enqueueConfirmation :: AgentClient -> ConnData -> SndQueue -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> AM ()
enqueueConfirmation :: AgentClient
-> ConnData
-> SndQueue
-> ConnId
-> Maybe (SndE2ERatchetParams 'X448)
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueConfirmation AgentClient
c ConnData
cData SndQueue
sq ConnId
connInfo Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_ = do
  AgentClient
-> ConnData
-> SndQueue
-> Maybe (SndE2ERatchetParams 'X448)
-> AgentMessage
-> ExceptT AgentErrorType (ReaderT Env IO) ()
storeConfirmation AgentClient
c ConnData
cData SndQueue
sq Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_ (AgentMessage -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> AgentMessage -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ ConnId -> AgentMessage
AgentConnInfo ConnId
connInfo
  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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> SndQueue -> ReaderT Env IO ()
submitPendingMsg AgentClient
c SndQueue
sq

storeConfirmation :: AgentClient -> ConnData -> SndQueue -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> AgentMessage -> AM ()
storeConfirmation :: AgentClient
-> ConnData
-> SndQueue
-> Maybe (SndE2ERatchetParams 'X448)
-> AgentMessage
-> ExceptT AgentErrorType (ReaderT Env IO) ()
storeConfirmation AgentClient
c cData :: ConnData
cData@ConnData {ConnId
$sel:connId:ConnData :: ConnData -> ConnId
connId :: ConnId
connId, PQSupport
$sel:pqSupport:ConnData :: ConnData -> PQSupport
pqSupport :: PQSupport
pqSupport, $sel:connAgentVersion:ConnData :: ConnData -> VersionSMPA
connAgentVersion = VersionSMPA
v} SndQueue
sq Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_ AgentMessage
agentMsg = do
  VersionE2E
currentE2EVersion <- (Env -> VersionE2E)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionE2E
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> VersionE2E)
 -> ExceptT AgentErrorType (ReaderT Env IO) VersionE2E)
-> (Env -> VersionE2E)
-> ExceptT AgentErrorType (ReaderT Env IO) VersionE2E
forall a b. (a -> b) -> a -> b
$ VersionRangeE2E -> VersionE2E
forall v. VersionRange v -> Version v
maxVersion (VersionRangeE2E -> VersionE2E)
-> (Env -> VersionRangeE2E) -> Env -> VersionE2E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentConfig -> VersionRangeE2E
e2eEncryptVRange (AgentConfig -> VersionRangeE2E)
-> (Env -> AgentConfig) -> Env -> VersionRangeE2E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  AgentClient
-> (Connection -> IO (Either StoreError ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError ()))
 -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (Connection -> IO (Either StoreError ()))
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ExceptT StoreError IO () -> IO (Either StoreError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO () -> IO (Either StoreError ()))
-> ExceptT StoreError IO () -> IO (Either StoreError ())
forall a b. (a -> b) -> a -> b
$ do
    InternalTs
internalTs <- IO InternalTs -> ExceptT StoreError IO InternalTs
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO InternalTs
getCurrentTime
    (InternalId
internalId, InternalSndId
internalSndId, ConnId
prevMsgHash) <- IO (Either StoreError (InternalId, InternalSndId, ConnId))
-> ExceptT StoreError IO (InternalId, InternalSndId, ConnId)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError (InternalId, InternalSndId, ConnId))
 -> ExceptT StoreError IO (InternalId, InternalSndId, ConnId))
-> IO (Either StoreError (InternalId, InternalSndId, ConnId))
-> ExceptT StoreError IO (InternalId, InternalSndId, ConnId)
forall a b. (a -> b) -> a -> b
$ Connection
-> ConnId
-> IO (Either StoreError (InternalId, InternalSndId, ConnId))
updateSndIds Connection
db ConnId
connId
    let agentMsgStr :: ConnId
agentMsgStr = AgentMessage -> ConnId
forall a. Encoding a => a -> ConnId
smpEncode AgentMessage
agentMsg
        internalHash :: ConnId
internalHash = ConnId -> ConnId
C.sha256Hash ConnId
agentMsgStr
        pqEnc :: PQEncryption
pqEnc = PQSupport -> PQEncryption
CR.pqSupportToEnc PQSupport
pqSupport
    (ConnId
encConnInfo, PQEncryption
pqEncryption) <- Connection
-> ConnData
-> ConnId
-> (VersionSMPA -> PQSupport -> Int)
-> Maybe PQEncryption
-> VersionE2E
-> ExceptT StoreError IO (ConnId, PQEncryption)
agentRatchetEncrypt Connection
db ConnData
cData ConnId
agentMsgStr VersionSMPA -> PQSupport -> Int
e2eEncConnInfoLength (PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just PQEncryption
pqEnc) VersionE2E
currentE2EVersion
    let msgBody :: ConnId
msgBody = AgentMsgEnvelope -> ConnId
forall a. Encoding a => a -> ConnId
smpEncode (AgentMsgEnvelope -> ConnId) -> AgentMsgEnvelope -> ConnId
forall a b. (a -> b) -> a -> b
$ AgentConfirmation {$sel:agentVersion:AgentConfirmation :: VersionSMPA
agentVersion = VersionSMPA
v, Maybe (SndE2ERatchetParams 'X448)
$sel:e2eEncryption_:AgentConfirmation :: Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_ :: Maybe (SndE2ERatchetParams 'X448)
e2eEncryption_, ConnId
$sel:encConnInfo:AgentConfirmation :: ConnId
encConnInfo :: ConnId
encConnInfo}
        msgType :: AgentMessageType
msgType = AgentMessage -> AgentMessageType
agentMessageType AgentMessage
agentMsg
        msgData :: SndMsgData
msgData = SndMsgData {InternalId
$sel:internalId:SndMsgData :: InternalId
internalId :: InternalId
internalId, InternalSndId
$sel:internalSndId:SndMsgData :: InternalSndId
internalSndId :: InternalSndId
internalSndId, InternalTs
$sel:internalTs:SndMsgData :: InternalTs
internalTs :: InternalTs
internalTs, AgentMessageType
$sel:msgType:SndMsgData :: AgentMessageType
msgType :: AgentMessageType
msgType, ConnId
$sel:msgBody:SndMsgData :: ConnId
msgBody :: ConnId
msgBody, PQEncryption
$sel:pqEncryption:SndMsgData :: PQEncryption
pqEncryption :: PQEncryption
pqEncryption, $sel:msgFlags:SndMsgData :: MsgFlags
msgFlags = SMP.MsgFlags {$sel:notification:MsgFlags :: Bool
notification = Bool
True}, ConnId
$sel:internalHash:SndMsgData :: ConnId
internalHash :: ConnId
internalHash, ConnId
$sel:prevMsgHash:SndMsgData :: ConnId
prevMsgHash :: ConnId
prevMsgHash, $sel:sndMsgPrepData_:SndMsgData :: Maybe SndMsgPrepData
sndMsgPrepData_ = Maybe SndMsgPrepData
forall a. Maybe a
Nothing}
    IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> SndMsgData -> IO ()
createSndMsg Connection
db ConnId
connId SndMsgData
msgData
    IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> SndQueue -> InternalId -> IO ()
createSndMsgDelivery Connection
db SndQueue
sq InternalId
internalId

enqueueRatchetKeyMsgs :: AgentClient -> NonEmpty SndQueue -> CR.RcvE2ERatchetParams 'C.X448 -> AM ()
enqueueRatchetKeyMsgs :: AgentClient
-> NonEmpty SndQueue
-> RcvE2ERatchetParams 'X448
-> ExceptT AgentErrorType (ReaderT Env IO) ()
enqueueRatchetKeyMsgs AgentClient
c (SndQueue
sq :| [SndQueue]
sqs) RcvE2ERatchetParams 'X448
e2eEncryption = do
  UserId
msgId <- AgentClient -> SndQueue -> RcvE2ERatchetParams 'X448 -> AM UserId
enqueueRatchetKey AgentClient
c SndQueue
sq RcvE2ERatchetParams 'X448
e2eEncryption
  (SndQueue -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> [SndQueue] -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> (SndQueue -> ReaderT Env IO ())
-> SndQueue
-> ExceptT AgentErrorType (ReaderT Env IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> UserId -> SndQueue -> ReaderT Env IO ()
enqueueSavedMessage AgentClient
c UserId
msgId) ([SndQueue] -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> [SndQueue] -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ (SndQueue -> Bool) -> [SndQueue] -> [SndQueue]
forall a. (a -> Bool) -> [a] -> [a]
filter SndQueue -> Bool
isActiveSndQ [SndQueue]
sqs

enqueueRatchetKey :: AgentClient -> SndQueue -> CR.RcvE2ERatchetParams 'C.X448 -> AM AgentMsgId
enqueueRatchetKey :: AgentClient -> SndQueue -> RcvE2ERatchetParams 'X448 -> AM UserId
enqueueRatchetKey AgentClient
c sq :: SndQueue
sq@SndQueue {ConnId
$sel:connId:SndQueue :: forall (q :: DBStored). StoredSndQueue q -> ConnId
connId :: ConnId
connId} RcvE2ERatchetParams 'X448
e2eEncryption = do
  VersionRange SMPAgentVersion
aVRange <- (Env -> VersionRange SMPAgentVersion)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (VersionRange SMPAgentVersion)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> VersionRange SMPAgentVersion)
 -> ExceptT
      AgentErrorType (ReaderT Env IO) (VersionRange SMPAgentVersion))
-> (Env -> VersionRange SMPAgentVersion)
-> ExceptT
     AgentErrorType (ReaderT Env IO) (VersionRange SMPAgentVersion)
forall a b. (a -> b) -> a -> b
$ AgentConfig -> VersionRange SMPAgentVersion
smpAgentVRange (AgentConfig -> VersionRange SMPAgentVersion)
-> (Env -> AgentConfig) -> Env -> VersionRange SMPAgentVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  InternalId
msgId <- VersionSMPA -> AM InternalId
storeRatchetKey (VersionSMPA -> AM InternalId) -> VersionSMPA -> AM InternalId
forall a b. (a -> b) -> a -> b
$ VersionRange SMPAgentVersion -> VersionSMPA
forall v. VersionRange v -> Version v
maxVersion VersionRange SMPAgentVersion
aVRange
  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 (ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ())
-> ReaderT Env IO () -> ExceptT AgentErrorType (ReaderT Env IO) ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> SndQueue -> ReaderT Env IO ()
submitPendingMsg AgentClient
c SndQueue
sq
  UserId -> AM UserId
forall a. a -> ExceptT AgentErrorType (ReaderT Env IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserId -> AM UserId) -> UserId -> AM UserId
forall a b. (a -> b) -> a -> b
$ InternalId -> UserId
unId InternalId
msgId
  where
    storeRatchetKey :: VersionSMPA -> AM InternalId
    storeRatchetKey :: VersionSMPA -> AM InternalId
storeRatchetKey VersionSMPA
agentVersion = AgentClient
-> (Connection -> IO (Either StoreError InternalId))
-> AM InternalId
forall a.
AgentClient -> (Connection -> IO (Either StoreError a)) -> AM a
withStore AgentClient
c ((Connection -> IO (Either StoreError InternalId))
 -> AM InternalId)
-> (Connection -> IO (Either StoreError InternalId))
-> AM InternalId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ExceptT StoreError IO InternalId
-> IO (Either StoreError InternalId)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO InternalId
 -> IO (Either StoreError InternalId))
-> ExceptT StoreError IO InternalId
-> IO (Either StoreError InternalId)
forall a b. (a -> b) -> a -> b
$ do
      InternalTs
internalTs <- IO InternalTs -> ExceptT StoreError IO InternalTs
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO InternalTs
getCurrentTime
      (InternalId
internalId, InternalSndId
internalSndId, ConnId
prevMsgHash) <- IO (Either StoreError (InternalId, InternalSndId, ConnId))
-> ExceptT StoreError IO (InternalId, InternalSndId, ConnId)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError (InternalId, InternalSndId, ConnId))
 -> ExceptT StoreError IO (InternalId, InternalSndId, ConnId))
-> IO (Either StoreError (InternalId, InternalSndId, ConnId))
-> ExceptT StoreError IO (InternalId, InternalSndId, ConnId)
forall a b. (a -> b) -> a -> b
$ Connection
-> ConnId
-> IO (Either StoreError (InternalId, InternalSndId, ConnId))
updateSndIds Connection
db ConnId
connId
      let agentMsg :: AgentMessage
agentMsg = ConnId -> AgentMessage
AgentRatchetInfo ConnId
""
          agentMsgStr :: ConnId
agentMsgStr = AgentMessage -> ConnId
forall a. Encoding a => a -> ConnId
smpEncode AgentMessage
agentMsg
          internalHash :: ConnId
internalHash = ConnId -> ConnId
C.sha256Hash ConnId
agentMsgStr
      let msgBody :: ConnId
msgBody = AgentMsgEnvelope -> ConnId
forall a. Encoding a => a -> ConnId
smpEncode (AgentMsgEnvelope -> ConnId) -> AgentMsgEnvelope -> ConnId
forall a b. (a -> b) -> a -> b
$ AgentRatchetKey {VersionSMPA
$sel:agentVersion:AgentConfirmation :: VersionSMPA
agentVersion :: VersionSMPA
agentVersion, RcvE2ERatchetParams 'X448
$sel:e2eEncryption:AgentConfirmation :: RcvE2ERatchetParams 'X448
e2eEncryption :: RcvE2ERatchetParams 'X448
e2eEncryption, $sel:info:AgentConfirmation :: ConnId
info = ConnId
agentMsgStr}
          msgType :: AgentMessageType
msgType = AgentMessage -> AgentMessageType
agentMessageType AgentMessage
agentMsg
          -- this message is e2e encrypted with queue key, not with double ratchet
          msgData :: SndMsgData
msgData = SndMsgData {InternalId
$sel:internalId:SndMsgData :: InternalId
internalId :: InternalId
internalId, InternalSndId
$sel:internalSndId:SndMsgData :: InternalSndId
internalSndId :: InternalSndId
internalSndId, InternalTs
$sel:internalTs:SndMsgData :: InternalTs
internalTs :: InternalTs
internalTs, AgentMessageType
$sel:msgType:SndMsgData :: AgentMessageType
msgType :: AgentMessageType
msgType, ConnId
$sel:msgBody:SndMsgData :: ConnId
msgBody :: ConnId
msgBody, $sel:pqEncryption:SndMsgData :: PQEncryption
pqEncryption = PQEncryption
PQEncOff, $sel:msgFlags:SndMsgData :: MsgFlags
msgFlags = SMP.MsgFlags {$sel:notification:MsgFlags :: Bool
notification = Bool
True}, ConnId
$sel:internalHash:SndMsgData :: ConnId
internalHash :: ConnId
internalHash, ConnId
$sel:prevMsgHash:SndMsgData :: ConnId
prevMsgHash :: ConnId
prevMsgHash, $sel:sndMsgPrepData_:SndMsgData :: Maybe SndMsgPrepData
sndMsgPrepData_ = Maybe SndMsgPrepData
forall a. Maybe a
Nothing}
      IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> SndMsgData -> IO ()
createSndMsg Connection
db ConnId
connId SndMsgData
msgData
      IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> SndQueue -> InternalId -> IO ()
createSndMsgDelivery Connection
db SndQueue
sq InternalId
internalId
      InternalId -> ExceptT StoreError IO InternalId
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InternalId
internalId

-- encoded AgentMessage -> encoded EncAgentMessage
agentRatchetEncrypt :: DB.Connection -> ConnData -> ByteString -> (VersionSMPA -> PQSupport -> Int) -> Maybe PQEncryption -> CR.VersionE2E -> ExceptT StoreError IO (ByteString, PQEncryption)
agentRatchetEncrypt :: Connection
-> ConnData
-> ConnId
-> (VersionSMPA -> PQSupport -> Int)
-> Maybe PQEncryption
-> VersionE2E
-> ExceptT StoreError IO (ConnId, PQEncryption)
agentRatchetEncrypt Connection
db ConnData
cData ConnId
msg VersionSMPA -> PQSupport -> Int
getPaddedLen Maybe PQEncryption
pqEnc_ VersionE2E
currentE2EVersion = do
  (MsgEncryptKeyX448
mek, Int
paddedLen, PQEncryption
pqEnc) <- Connection
-> ConnData
-> (VersionSMPA -> PQSupport -> Int)
-> Maybe PQEncryption
-> VersionE2E
-> ExceptT StoreError IO (MsgEncryptKeyX448, Int, PQEncryption)
agentRatchetEncryptHeader Connection
db ConnData
cData VersionSMPA -> PQSupport -> Int
getPaddedLen Maybe PQEncryption
pqEnc_ VersionE2E
currentE2EVersion
  ConnId
encMsg <- (CryptoError -> StoreError)
-> ExceptT CryptoError IO ConnId -> ExceptT StoreError IO ConnId
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (AgentErrorType -> StoreError
SEAgentError (AgentErrorType -> StoreError)
-> (CryptoError -> AgentErrorType) -> CryptoError -> StoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoError -> AgentErrorType
cryptoError) (ExceptT CryptoError IO ConnId -> ExceptT StoreError IO ConnId)
-> ExceptT CryptoError IO ConnId -> ExceptT StoreError IO ConnId
forall a b. (a -> b) -> a -> b
$ MsgEncryptKeyX448 -> Int -> ConnId -> ExceptT CryptoError IO ConnId
forall (a :: Algorithm).
AlgorithmI a =>
MsgEncryptKey a -> Int -> ConnId -> ExceptT CryptoError IO ConnId
CR.rcEncryptMsg MsgEncryptKeyX448
mek Int
paddedLen ConnId
msg
  (ConnId, PQEncryption)
-> ExceptT StoreError IO (ConnId, PQEncryption)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnId
encMsg, PQEncryption
pqEnc)

agentRatchetEncryptHeader :: DB.Connection -> ConnData -> (VersionSMPA -> PQSupport -> Int) -> Maybe PQEncryption -> CR.VersionE2E -> ExceptT StoreError IO (CR.MsgEncryptKeyX448, Int, PQEncryption)
agentRatchetEncryptHeader :: Connection
-> ConnData
-> (VersionSMPA -> PQSupport -> Int)
-> Maybe PQEncryption
-> VersionE2E
-> ExceptT StoreError IO (MsgEncryptKeyX448, Int, PQEncryption)
agentRatchetEncryptHeader Connection
db ConnData {ConnId
$sel:connId:ConnData :: ConnData -> ConnId
connId :: ConnId
connId, $sel:connAgentVersion:ConnData :: ConnData -> VersionSMPA
connAgentVersion = VersionSMPA
v, PQSupport
$sel:pqSupport:ConnData :: ConnData -> PQSupport
pqSupport :: PQSupport
pqSupport} VersionSMPA -> PQSupport -> Int
getPaddedLen Maybe PQEncryption
pqEnc_ VersionE2E
currentE2EVersion = do
  RatchetX448
rc <- IO (Either StoreError RatchetX448)
-> ExceptT StoreError IO RatchetX448
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError RatchetX448)
 -> ExceptT StoreError IO RatchetX448)
-> IO (Either StoreError RatchetX448)
-> ExceptT StoreError IO RatchetX448
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> IO (Either StoreError RatchetX448)
getRatchetForUpdate Connection
db ConnId
connId
  let paddedLen :: Int
paddedLen = VersionSMPA -> PQSupport -> Int
getPaddedLen VersionSMPA
v PQSupport
pqSupport
  (MsgEncryptKeyX448
mek, RatchetX448
rc') <- (CryptoError -> StoreError)
-> ExceptT CryptoError IO (MsgEncryptKeyX448, RatchetX448)
-> ExceptT StoreError IO (MsgEncryptKeyX448, RatchetX448)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (AgentErrorType -> StoreError
SEAgentError (AgentErrorType -> StoreError)
-> (CryptoError -> AgentErrorType) -> CryptoError -> StoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoError -> AgentErrorType
cryptoError) (ExceptT CryptoError IO (MsgEncryptKeyX448, RatchetX448)
 -> ExceptT StoreError IO (MsgEncryptKeyX448, RatchetX448))
-> ExceptT CryptoError IO (MsgEncryptKeyX448, RatchetX448)
-> ExceptT StoreError IO (MsgEncryptKeyX448, RatchetX448)
forall a b. (a -> b) -> a -> b
$ RatchetX448
-> Maybe PQEncryption
-> VersionE2E
-> ExceptT CryptoError IO (MsgEncryptKeyX448, RatchetX448)
forall (a :: Algorithm).
AlgorithmI a =>
Ratchet a
-> Maybe PQEncryption
-> VersionE2E
-> ExceptT CryptoError IO (MsgEncryptKey a, Ratchet a)
CR.rcEncryptHeader RatchetX448
rc Maybe PQEncryption
pqEnc_ VersionE2E
currentE2EVersion
  IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> RatchetX448 -> SkippedMsgDiff -> IO ()
updateRatchet Connection
db ConnId
connId RatchetX448
rc' SkippedMsgDiff
CR.SMDNoChange
  (MsgEncryptKeyX448, Int, PQEncryption)
-> ExceptT StoreError IO (MsgEncryptKeyX448, Int, PQEncryption)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MsgEncryptKeyX448
mek, Int
paddedLen, RatchetX448 -> PQEncryption
forall (a :: Algorithm). Ratchet a -> PQEncryption
CR.rcSndKEM RatchetX448
rc')

-- encoded EncAgentMessage -> encoded AgentMessage
agentRatchetDecrypt :: TVar ChaChaDRG -> DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO (ByteString, PQEncryption)
agentRatchetDecrypt :: TVar ChaChaDRG
-> Connection
-> ConnId
-> ConnId
-> ExceptT StoreError IO (ConnId, PQEncryption)
agentRatchetDecrypt TVar ChaChaDRG
g Connection
db ConnId
connId ConnId
encAgentMsg = do
  RatchetX448
rc <- IO (Either StoreError RatchetX448)
-> ExceptT StoreError IO RatchetX448
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError RatchetX448)
 -> ExceptT StoreError IO RatchetX448)
-> IO (Either StoreError RatchetX448)
-> ExceptT StoreError IO RatchetX448
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> IO (Either StoreError RatchetX448)
getRatchetForUpdate Connection
db ConnId
connId
  TVar ChaChaDRG
-> Connection
-> ConnId
-> RatchetX448
-> ConnId
-> ExceptT StoreError IO (ConnId, PQEncryption)
agentRatchetDecrypt' TVar ChaChaDRG
g Connection
db ConnId
connId RatchetX448
rc ConnId
encAgentMsg

agentRatchetDecrypt' :: TVar ChaChaDRG -> DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO (ByteString, PQEncryption)
agentRatchetDecrypt' :: TVar ChaChaDRG
-> Connection
-> ConnId
-> RatchetX448
-> ConnId
-> ExceptT StoreError IO (ConnId, PQEncryption)
agentRatchetDecrypt' TVar ChaChaDRG
g Connection
db ConnId
connId RatchetX448
rc ConnId
encAgentMsg = do
  SkippedMsgKeys
skipped <- IO SkippedMsgKeys -> ExceptT StoreError IO SkippedMsgKeys
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SkippedMsgKeys -> ExceptT StoreError IO SkippedMsgKeys)
-> IO SkippedMsgKeys -> ExceptT StoreError IO SkippedMsgKeys
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> IO SkippedMsgKeys
getSkippedMsgKeys Connection
db ConnId
connId
  (Either CryptoError ConnId
agentMsgBody_, RatchetX448
rc', SkippedMsgDiff
skippedDiff) <- (CryptoError -> StoreError)
-> ExceptT
     CryptoError
     IO
     (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff)
-> ExceptT
     StoreError
     IO
     (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (AgentErrorType -> StoreError
SEAgentError (AgentErrorType -> StoreError)
-> (CryptoError -> AgentErrorType) -> CryptoError -> StoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoError -> AgentErrorType
cryptoError) (ExceptT
   CryptoError
   IO
   (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff)
 -> ExceptT
      StoreError
      IO
      (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff))
-> ExceptT
     CryptoError
     IO
     (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff)
-> ExceptT
     StoreError
     IO
     (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> RatchetX448
-> SkippedMsgKeys
-> ConnId
-> ExceptT
     CryptoError
     IO
     (Either CryptoError ConnId, RatchetX448, SkippedMsgDiff)
forall (a :: Algorithm).
(AlgorithmI a, DhAlgorithm a) =>
TVar ChaChaDRG
-> Ratchet a
-> SkippedMsgKeys
-> ConnId
-> ExceptT CryptoError IO (DecryptResult a)
CR.rcDecrypt TVar ChaChaDRG
g RatchetX448
rc SkippedMsgKeys
skipped ConnId
encAgentMsg
  IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnId -> RatchetX448 -> SkippedMsgDiff -> IO ()
updateRatchet Connection
db ConnId
connId RatchetX448
rc' SkippedMsgDiff
skippedDiff
  Either StoreError (ConnId, PQEncryption)
-> ExceptT StoreError IO (ConnId, PQEncryption)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either StoreError (ConnId, PQEncryption)
 -> ExceptT StoreError IO (ConnId, PQEncryption))
-> Either StoreError (ConnId, PQEncryption)
-> ExceptT StoreError IO (ConnId, PQEncryption)
forall a b. (a -> b) -> a -> b
$ (CryptoError -> StoreError)
-> (ConnId -> (ConnId, PQEncryption))
-> Either CryptoError ConnId
-> Either StoreError (ConnId, PQEncryption)
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 (AgentErrorType -> StoreError
SEAgentError (AgentErrorType -> StoreError)
-> (CryptoError -> AgentErrorType) -> CryptoError -> StoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoError -> AgentErrorType
cryptoError) (,RatchetX448 -> PQEncryption
forall (a :: Algorithm). Ratchet a -> PQEncryption
CR.rcRcvKEM RatchetX448
rc') Either CryptoError ConnId
agentMsgBody_

newSndQueue :: UserId -> ConnId -> Compatible SMPQueueInfo -> Maybe (C.APrivateAuthKey) -> AM' (NewSndQueue, C.PublicKeyX25519)
newSndQueue :: UserId
-> ConnId
-> Compatible SMPQueueInfo
-> Maybe APrivateAuthKey
-> ReaderT Env IO (NewSndQueue, PublicKeyX25519)
newSndQueue UserId
userId ConnId
connId (Compatible (SMPQueueInfo VersionSMPC
smpClientVersion SMPQueueAddress {SMPServer
$sel:smpServer:SMPQueueAddress :: SMPQueueAddress -> SMPServer
smpServer :: SMPServer
smpServer, QueueId
$sel:senderId:SMPQueueAddress :: SMPQueueAddress -> QueueId
senderId :: QueueId
senderId, Maybe QueueMode
queueMode :: Maybe QueueMode
$sel:queueMode:SMPQueueAddress :: SMPQueueAddress -> Maybe QueueMode
queueMode, $sel:dhPublicKey:SMPQueueAddress :: SMPQueueAddress -> PublicKeyX25519
dhPublicKey = PublicKeyX25519
rcvE2ePubDhKey})) Maybe APrivateAuthKey
sndKey_ = do
  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
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
  APrivateAuthKey
sndPrivateKey <- ReaderT Env IO APrivateAuthKey
-> (APrivateAuthKey -> ReaderT Env IO APrivateAuthKey)
-> Maybe APrivateAuthKey
-> ReaderT Env IO APrivateAuthKey
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (STM APrivateAuthKey -> ReaderT Env IO APrivateAuthKey
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM APrivateAuthKey -> ReaderT Env IO APrivateAuthKey)
-> STM APrivateAuthKey -> ReaderT Env IO APrivateAuthKey
forall a b. (a -> b) -> a -> b
$ SAlgorithm a -> TVar ChaChaDRG -> STM APrivateAuthKey
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM APrivateAuthKey
C.generatePrivateAuthKey SAlgorithm a
a TVar ChaChaDRG
g) APrivateAuthKey -> ReaderT Env IO APrivateAuthKey
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe APrivateAuthKey
sndKey_
  (PublicKeyX25519
e2ePubKey, PrivateKey 'X25519
e2ePrivKey) <- STM (PublicKeyX25519, PrivateKey 'X25519)
-> ReaderT Env IO (PublicKeyX25519, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKeyX25519, PrivateKey 'X25519)
 -> ReaderT Env IO (PublicKeyX25519, PrivateKey 'X25519))
-> STM (PublicKeyX25519, PrivateKey 'X25519)
-> ReaderT Env IO (PublicKeyX25519, 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 sq :: NewSndQueue
sq =
        SndQueue
          { UserId
$sel:userId:SndQueue :: UserId
userId :: UserId
userId,
            ConnId
$sel:connId:SndQueue :: ConnId
connId :: ConnId
connId,
            $sel:server:SndQueue :: SMPServer
server = SMPServer
smpServer,
            $sel:sndId:SndQueue :: QueueId
sndId = QueueId
senderId,
            Maybe QueueMode
$sel:queueMode:SndQueue :: Maybe QueueMode
queueMode :: Maybe QueueMode
queueMode,
            APrivateAuthKey
$sel:sndPrivateKey:SndQueue :: APrivateAuthKey
sndPrivateKey :: APrivateAuthKey
sndPrivateKey,
            $sel:e2eDhSecret:SndQueue :: DhSecretX25519
e2eDhSecret = PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecretX25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKeyX25519
rcvE2ePubDhKey PrivateKey 'X25519
e2ePrivKey,
            $sel:e2ePubKey:SndQueue :: Maybe PublicKeyX25519
e2ePubKey = PublicKeyX25519 -> Maybe PublicKeyX25519
forall a. a -> Maybe a
Just PublicKeyX25519
e2ePubKey,
            -- setting status to Secured prevents SKEY when queue was already secured with LKEY
            $sel:status:SndQueue :: QueueStatus
status = if Maybe APrivateAuthKey -> Bool
forall a. Maybe a -> Bool
isJust Maybe APrivateAuthKey
sndKey_ then QueueStatus
Secured else QueueStatus
New,
            $sel:dbQueueId:SndQueue :: DBEntityId' 'DBNew
dbQueueId = DBEntityId' 'DBNew
DBNewEntity,
            $sel:primary:SndQueue :: Bool
primary = Bool
True,
            $sel:dbReplaceQueueId:SndQueue :: Maybe UserId
dbReplaceQueueId = Maybe UserId
forall a. Maybe a
Nothing,
            $sel:sndSwchStatus:SndQueue :: Maybe SndSwitchStatus
sndSwchStatus = Maybe SndSwitchStatus
forall a. Maybe a
Nothing,
            VersionSMPC
$sel:smpClientVersion:SndQueue :: VersionSMPC
smpClientVersion :: VersionSMPC
smpClientVersion
          }
  (NewSndQueue, PublicKeyX25519)
-> ReaderT Env IO (NewSndQueue, PublicKeyX25519)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewSndQueue
sq, PublicKeyX25519
e2ePubKey)

$(pure [])

instance FromJSON a => FromJSON (DatabaseDiff a) where
  parseJSON :: Value -> Parser (DatabaseDiff a)
parseJSON = $(JQ.mkParseJSON defaultJSON ''DatabaseDiff)

instance ToJSON a => ToJSON (DatabaseDiff a) where
  toEncoding :: DatabaseDiff a -> Encoding
toEncoding = $(JQ.mkToEncoding defaultJSON ''DatabaseDiff)
  toJSON :: DatabaseDiff a -> Value
toJSON = $(JQ.mkToJSON defaultJSON ''DatabaseDiff)