mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-08-29 07:48:25 +00:00
agent: delay connection deletion to finish delivery of pending messages (#1015)
* agent: delay connection deletion to finish delivery of pending messages (wip) * fixes, test * notify, test * add tests * comment * add test * timeout * test timeout * up * more tests * rename --------- Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
This commit is contained in:
spaced4ndy
co-authored by
Evgeny Poberezkin
Evgeny Poberezkin
parent
c9ec7ea274
commit
294d7ec8dd
@@ -103,6 +103,7 @@ library
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
|
||||
Simplex.Messaging.Agent.TRcvQueues
|
||||
Simplex.Messaging.Client
|
||||
Simplex.Messaging.Client.Agent
|
||||
|
||||
@@ -141,7 +141,7 @@ import qualified Data.Text as T
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Clock.System (systemToUTCTime)
|
||||
import Data.Word (Word16)
|
||||
import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFilesInternal, deleteSndFileRemote, deleteSndFilesRemote, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile')
|
||||
import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile')
|
||||
import Simplex.FileTransfer.Description (ValidFileDescription)
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..))
|
||||
import Simplex.FileTransfer.Util (removePath)
|
||||
@@ -242,12 +242,12 @@ switchConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -
|
||||
switchConnectionAsync c = withAgentEnv c .: switchConnectionAsync' c
|
||||
|
||||
-- | Delete SMP agent connection (DEL command) asynchronously, no synchronous response
|
||||
deleteConnectionAsync :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
|
||||
deleteConnectionAsync c = withAgentEnv c . deleteConnectionAsync' c
|
||||
deleteConnectionAsync :: AgentErrorMonad m => AgentClient -> Bool -> ConnId -> m ()
|
||||
deleteConnectionAsync c waitDelivery = withAgentEnv c . deleteConnectionAsync' c waitDelivery
|
||||
|
||||
-- | Delete SMP agent connections using batch commands asynchronously, no synchronous response
|
||||
deleteConnectionsAsync :: AgentErrorMonad m => AgentClient -> [ConnId] -> m ()
|
||||
deleteConnectionsAsync c = withAgentEnv c . deleteConnectionsAsync' c
|
||||
deleteConnectionsAsync :: AgentErrorMonad m => AgentClient -> Bool -> [ConnId] -> m ()
|
||||
deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync' c waitDelivery
|
||||
|
||||
-- | Create SMP agent connection (NEW command)
|
||||
createConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> m (ConnId, ConnectionRequestUri c)
|
||||
@@ -541,7 +541,7 @@ createUser' c smp xftp = do
|
||||
deleteUser' :: AgentMonad m => AgentClient -> UserId -> Bool -> m ()
|
||||
deleteUser' c userId delSMPQueues = do
|
||||
if delSMPQueues
|
||||
then withStore c (`setUserDeleted` userId) >>= deleteConnectionsAsync_ delUser c
|
||||
then withStore c (`setUserDeleted` userId) >>= deleteConnectionsAsync_ delUser c False
|
||||
else withStore c (`deleteUserRecord` userId)
|
||||
atomically $ TM.delete userId $ smpServers c
|
||||
where
|
||||
@@ -613,21 +613,21 @@ ackMessageAsync' c corrId connId msgId rcptInfo_ = do
|
||||
(RcvQueue {server}, _) <- withStoreCtx "ackMessageAsync': setMsgUserAck" c $ \db -> setMsgUserAck db connId mId
|
||||
enqueueCommand c corrId connId (Just server) . AClientCommand $ APC SAEConn $ ACK msgId rcptInfo_
|
||||
|
||||
deleteConnectionAsync' :: forall m. AgentMonad m => AgentClient -> ConnId -> m ()
|
||||
deleteConnectionAsync' c connId = deleteConnectionsAsync' c [connId]
|
||||
deleteConnectionAsync' :: forall m. AgentMonad m => AgentClient -> Bool -> ConnId -> m ()
|
||||
deleteConnectionAsync' c waitDelivery connId = deleteConnectionsAsync' c waitDelivery [connId]
|
||||
|
||||
deleteConnectionsAsync' :: AgentMonad m => AgentClient -> [ConnId] -> m ()
|
||||
deleteConnectionsAsync' :: AgentMonad m => AgentClient -> Bool -> [ConnId] -> m ()
|
||||
deleteConnectionsAsync' = deleteConnectionsAsync_ $ pure ()
|
||||
|
||||
deleteConnectionsAsync_ :: forall m. AgentMonad m => m () -> AgentClient -> [ConnId] -> m ()
|
||||
deleteConnectionsAsync_ onSuccess c connIds = case connIds of
|
||||
deleteConnectionsAsync_ :: forall m. AgentMonad m => m () -> AgentClient -> Bool -> [ConnId] -> m ()
|
||||
deleteConnectionsAsync_ onSuccess c waitDelivery connIds = case connIds of
|
||||
[] -> onSuccess
|
||||
_ -> do
|
||||
(_, rqs, connIds') <- prepareDeleteConnections_ getConns c connIds
|
||||
withStore' c $ forM_ connIds' . setConnDeleted
|
||||
(_, rqs, connIds') <- prepareDeleteConnections_ getConns c waitDelivery connIds
|
||||
withStore' c $ \db -> forM_ connIds' $ setConnDeleted db waitDelivery
|
||||
void . forkIO $
|
||||
withLock (deleteLock c) "deleteConnectionsAsync" $
|
||||
deleteConnQueues c True rqs >> onSuccess
|
||||
deleteConnQueues c waitDelivery True rqs >> onSuccess
|
||||
|
||||
-- | Add connection to the new receive queue
|
||||
switchConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> m ConnectionStats
|
||||
@@ -712,7 +712,7 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo subMode srv
|
||||
Right _ -> pure connId'
|
||||
Left e -> do
|
||||
-- possible improvement: recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md
|
||||
withStore' c (`deleteConn` connId')
|
||||
void $ withStore' c $ \db -> deleteConn db Nothing connId'
|
||||
throwError e
|
||||
joinConnSrv c userId connId enableNtfs (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) cInfo subMode srv = do
|
||||
aVRange <- asks $ smpAgentVRange . config
|
||||
@@ -1452,19 +1452,23 @@ disableConn c connId = do
|
||||
|
||||
-- Unlike deleteConnectionsAsync, this function does not mark connections as deleted in case of deletion failure.
|
||||
deleteConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnections' = deleteConnections_ getConns False
|
||||
deleteConnections' = deleteConnections_ getConns False False
|
||||
|
||||
deleteDeletedConns :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
|
||||
deleteDeletedConns = deleteConnections_ getDeletedConns True
|
||||
deleteDeletedConns = deleteConnections_ getDeletedConns True False
|
||||
|
||||
deleteDeletedWaitingDeliveryConns :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
|
||||
deleteDeletedWaitingDeliveryConns = deleteConnections_ getConns True True
|
||||
|
||||
prepareDeleteConnections_ ::
|
||||
forall m.
|
||||
AgentMonad m =>
|
||||
(DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]) ->
|
||||
AgentClient ->
|
||||
Bool ->
|
||||
[ConnId] ->
|
||||
m (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
|
||||
prepareDeleteConnections_ getConnections c connIds = do
|
||||
prepareDeleteConnections_ getConnections c waitDelivery connIds = do
|
||||
conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (`getConnections` connIds)
|
||||
let (errs, cs) = M.mapEither id conns
|
||||
errs' = M.map (Left . storeError) errs
|
||||
@@ -1472,19 +1476,27 @@ prepareDeleteConnections_ getConnections c connIds = do
|
||||
rqs = concat $ M.elems rcvQs
|
||||
connIds' = M.keys rcvQs
|
||||
forM_ connIds' $ disableConn c
|
||||
withStore' c $ forM_ (M.keys delRs) . deleteConn
|
||||
-- ! 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)
|
||||
deliveryTimeout <- if waitDelivery then asks (Just . connDeleteDeliveryTimeout . config) else pure Nothing
|
||||
rs' <- catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) (M.keys delRs))
|
||||
forM_ rs' $ \cId -> notify ("", cId, APC SAEConn DEL_CONN)
|
||||
pure (errs' <> delRs, rqs, connIds')
|
||||
where
|
||||
rcvQueues :: SomeConn -> Either (Either AgentErrorType ()) [RcvQueue]
|
||||
rcvQueues (SomeConn _ conn) = case connRcvQueues conn of
|
||||
[] -> Left $ Right ()
|
||||
rqs -> Right rqs
|
||||
notify = atomically . writeTBQueue (subQ c)
|
||||
|
||||
deleteConnQueues :: forall m. AgentMonad m => AgentClient -> Bool -> [RcvQueue] -> m (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnQueues c ntf rqs = do
|
||||
deleteConnQueues :: forall m. AgentMonad m => AgentClient -> Bool -> Bool -> [RcvQueue] -> m (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnQueues c waitDelivery ntf rqs = do
|
||||
rs <- connResults <$> (deleteQueueRecs =<< deleteQueues c rqs)
|
||||
let connIds = M.keys $ M.filter isRight rs
|
||||
rs' <- rights <$> withStoreBatch' c (\db -> map (\cId -> deleteConn db cId $> cId) connIds)
|
||||
deliveryTimeout <- if waitDelivery then asks (Just . connDeleteDeliveryTimeout . config) else pure Nothing
|
||||
rs' <- catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) connIds)
|
||||
forM_ rs' $ \cId -> notify ("", cId, APC SAEConn DEL_CONN)
|
||||
pure rs
|
||||
where
|
||||
@@ -1527,13 +1539,14 @@ deleteConnections_ ::
|
||||
AgentMonad m =>
|
||||
(DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]) ->
|
||||
Bool ->
|
||||
Bool ->
|
||||
AgentClient ->
|
||||
[ConnId] ->
|
||||
m (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnections_ _ _ _ [] = pure M.empty
|
||||
deleteConnections_ getConnections ntf c connIds = do
|
||||
(rs, rqs, _) <- prepareDeleteConnections_ getConnections c connIds
|
||||
rcvRs <- deleteConnQueues c ntf rqs
|
||||
deleteConnections_ _ _ _ _ [] = pure M.empty
|
||||
deleteConnections_ getConnections ntf waitDelivery c connIds = do
|
||||
(rs, rqs, _) <- prepareDeleteConnections_ getConnections c waitDelivery connIds
|
||||
rcvRs <- deleteConnQueues c waitDelivery ntf rqs
|
||||
let rs' = M.union rs rcvRs
|
||||
notifyResultError rs'
|
||||
pure rs'
|
||||
@@ -1862,6 +1875,7 @@ cleanupManager c@AgentClient {subQ} = do
|
||||
deleteConns =
|
||||
withLock (deleteLock c) "cleanupManager" $ do
|
||||
void $ withStore' c getDeletedConnIds >>= deleteDeletedConns c
|
||||
void $ withStore' c getDeletedWaitingDeliveryConnIds >>= deleteDeletedWaitingDeliveryConns c
|
||||
withStore' c deleteUsersWithoutConns >>= mapM_ (notify "" . DEL_USER)
|
||||
deleteRcvFilesExpired = do
|
||||
rcvFilesTTL <- asks $ rcvFilesTTL . config
|
||||
|
||||
@@ -93,6 +93,7 @@ data AgentConfig = AgentConfig
|
||||
reconnectInterval :: RetryInterval,
|
||||
messageRetryInterval :: RetryInterval2,
|
||||
messageTimeout :: NominalDiffTime,
|
||||
connDeleteDeliveryTimeout :: NominalDiffTime,
|
||||
helloTimeout :: NominalDiffTime,
|
||||
quotaExceededTimeout :: NominalDiffTime,
|
||||
initialCleanupDelay :: Int64,
|
||||
@@ -161,6 +162,7 @@ defaultAgentConfig =
|
||||
reconnectInterval = defaultReconnectInterval,
|
||||
messageRetryInterval = defaultMessageRetryInterval,
|
||||
messageTimeout = 2 * nominalDay,
|
||||
connDeleteDeliveryTimeout = 2 * nominalDay,
|
||||
helloTimeout = 2 * nominalDay,
|
||||
quotaExceededTimeout = 7 * nominalDay,
|
||||
initialCleanupDelay = 30 * 1000000, -- 30 seconds
|
||||
|
||||
@@ -60,6 +60,7 @@ module Simplex.Messaging.Agent.Store.SQLite
|
||||
setConnDeleted,
|
||||
setConnAgentVersion,
|
||||
getDeletedConnIds,
|
||||
getDeletedWaitingDeliveryConnIds,
|
||||
setConnRatchetSync,
|
||||
addProcessedRatchetKeyHash,
|
||||
checkRatchetKeyHashExists,
|
||||
@@ -241,7 +242,7 @@ import Data.List (foldl', intercalate, sortBy)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust, listToMaybe, catMaybes)
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe)
|
||||
import Data.Ord (Down (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
@@ -602,12 +603,32 @@ getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do
|
||||
DB.query db (rcvQueueQuery <> " WHERE q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (host, port, rcvId)
|
||||
(rq,) <$> ExceptT (getConn db connId)
|
||||
|
||||
deleteConn :: DB.Connection -> ConnId -> IO ()
|
||||
deleteConn db connId =
|
||||
DB.executeNamed
|
||||
db
|
||||
"DELETE FROM connections WHERE conn_id = :conn_id;"
|
||||
[":conn_id" := connId]
|
||||
-- | Deletes connection, optionally checking for pending snd message deliveries; returns connection id if it was deleted
|
||||
deleteConn :: DB.Connection -> Maybe NominalDiffTime -> ConnId -> IO (Maybe ConnId)
|
||||
deleteConn db waitDeliveryTimeout_ connId = case waitDeliveryTimeout_ of
|
||||
Nothing -> delete
|
||||
Just timeout ->
|
||||
ifM
|
||||
checkNoPendingDeliveries_
|
||||
delete
|
||||
( ifM
|
||||
(checkWaitDeliveryTimeout_ timeout)
|
||||
delete
|
||||
(pure Nothing)
|
||||
)
|
||||
where
|
||||
delete = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId) $> Just connId
|
||||
checkNoPendingDeliveries_ = do
|
||||
r :: (Maybe Int64) <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query db "SELECT 1 FROM snd_message_deliveries WHERE conn_id = ? AND failed = 0 LIMIT 1" (Only connId)
|
||||
pure $ isNothing r
|
||||
checkWaitDeliveryTimeout_ timeout = do
|
||||
cutoffTs <- addUTCTime (-timeout) <$> getCurrentTime
|
||||
r :: (Maybe Int64) <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query db "SELECT 1 FROM connections WHERE conn_id = ? AND deleted_at_wait_delivery < ? LIMIT 1" (connId, cutoffTs)
|
||||
pure $ isJust r
|
||||
|
||||
upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
|
||||
upgradeRcvConnToDuplex db connId sq =
|
||||
@@ -1912,8 +1933,13 @@ getConnData db connId' =
|
||||
cData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, deleted, ratchetSyncState) =
|
||||
(ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, lastExternalSndId, deleted, ratchetSyncState}, cMode)
|
||||
|
||||
setConnDeleted :: DB.Connection -> ConnId -> IO ()
|
||||
setConnDeleted db connId = DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
|
||||
setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO ()
|
||||
setConnDeleted db waitDelivery connId
|
||||
| waitDelivery = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE connections SET deleted_at_wait_delivery = ? WHERE conn_id = ?" (currentTs, connId)
|
||||
| otherwise =
|
||||
DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
|
||||
|
||||
setConnAgentVersion :: DB.Connection -> ConnId -> Version -> IO ()
|
||||
setConnAgentVersion db connId aVersion =
|
||||
@@ -1922,6 +1948,10 @@ setConnAgentVersion db connId aVersion =
|
||||
getDeletedConnIds :: DB.Connection -> IO [ConnId]
|
||||
getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True)
|
||||
|
||||
getDeletedWaitingDeliveryConnIds :: DB.Connection -> IO [ConnId]
|
||||
getDeletedWaitingDeliveryConnIds db =
|
||||
map fromOnly <$> DB.query_ db "SELECT conn_id FROM connections WHERE deleted_at_wait_delivery IS NOT NULL"
|
||||
|
||||
setConnRatchetSync :: DB.Connection -> ConnId -> RatchetSyncState -> IO ()
|
||||
setConnRatchetSync db connId ratchetSyncState =
|
||||
DB.execute db "UPDATE connections SET ratchet_sync_state = ? WHERE conn_id = ?" (ratchetSyncState, connId)
|
||||
@@ -2267,17 +2297,18 @@ createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redire
|
||||
forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId
|
||||
pure dstEntityId
|
||||
where
|
||||
dummyDst = FileDescription
|
||||
{ party = SFRecipient,
|
||||
size,
|
||||
digest,
|
||||
redirect = Nothing,
|
||||
-- updated later with updateRcvFileRedirect
|
||||
key = C.unsafeSbKey $ B.replicate 32 '#',
|
||||
nonce = C.cbNonce "",
|
||||
chunkSize = FileSize 0,
|
||||
chunks = []
|
||||
}
|
||||
dummyDst =
|
||||
FileDescription
|
||||
{ party = SFRecipient,
|
||||
size,
|
||||
digest,
|
||||
redirect = Nothing,
|
||||
-- updated later with updateRcvFileRedirect
|
||||
key = C.unsafeSbKey $ B.replicate 32 '#',
|
||||
nonce = C.cbNonce "",
|
||||
chunkSize = FileSize 0,
|
||||
chunks = []
|
||||
}
|
||||
|
||||
insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> IO (Either StoreError (RcvFileId, DBRcvFileId))
|
||||
insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ = runExceptT $ do
|
||||
@@ -2346,10 +2377,11 @@ getRcvFile db rcvFileId = runExceptT $ do
|
||||
toFile ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, saveKey_, saveNonce_, status, deleted, redirectDbId, redirectEntityId, redirectSize_, redirectDigest_)) =
|
||||
let cfArgs = CFArgs <$> saveKey_ <*> saveNonce_
|
||||
saveFile = CryptoFile savePath cfArgs
|
||||
redirect = RcvFileRedirect
|
||||
<$> redirectDbId
|
||||
<*> redirectEntityId
|
||||
<*> (RedirectFileInfo <$> redirectSize_ <*> redirectDigest_)
|
||||
redirect =
|
||||
RcvFileRedirect
|
||||
<$> redirectDbId
|
||||
<*> redirectEntityId
|
||||
<*> (RedirectFileInfo <$> redirectSize_ <*> redirectDigest_)
|
||||
in RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, redirect, prefixPath, tmpPath, saveFile, status, deleted, chunks = []}
|
||||
getChunks :: RcvFileId -> UserId -> FilePath -> IO [RcvFileChunk]
|
||||
getChunks rcvFileEntityId userId fileTmpPath = do
|
||||
|
||||
@@ -69,6 +69,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
@@ -106,7 +107,8 @@ schemaMigrations =
|
||||
("m20231222_command_created_at", m20231222_command_created_at, Just down_m20231222_command_created_at),
|
||||
("m20231225_failed_work_items", m20231225_failed_work_items, Just down_m20231225_failed_work_items),
|
||||
("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes),
|
||||
("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect)
|
||||
("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect),
|
||||
("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
+18
@@ -0,0 +1,18 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20240223_connections_wait_delivery :: Query
|
||||
m20240223_connections_wait_delivery =
|
||||
[sql|
|
||||
ALTER TABLE connections ADD COLUMN deleted_at_wait_delivery TEXT;
|
||||
|]
|
||||
|
||||
down_m20240223_connections_wait_delivery :: Query
|
||||
down_m20240223_connections_wait_delivery =
|
||||
[sql|
|
||||
ALTER TABLE connections DROP COLUMN deleted_at_wait_delivery;
|
||||
|]
|
||||
@@ -26,7 +26,8 @@ CREATE TABLE connections(
|
||||
deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL),
|
||||
user_id INTEGER CHECK(user_id NOT NULL)
|
||||
REFERENCES users ON DELETE CASCADE,
|
||||
ratchet_sync_state TEXT NOT NULL DEFAULT 'ok'
|
||||
ratchet_sync_state TEXT NOT NULL DEFAULT 'ok',
|
||||
deleted_at_wait_delivery TEXT
|
||||
) WITHOUT ROWID;
|
||||
CREATE TABLE rcv_queues(
|
||||
host TEXT NOT NULL,
|
||||
|
||||
@@ -52,7 +52,7 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime)
|
||||
import Data.Type.Equality
|
||||
import qualified Database.SQLite.Simple as SQL
|
||||
import SMPAgentClient
|
||||
import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerV7, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
|
||||
import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, withSmpServerV7)
|
||||
import Simplex.Messaging.Agent
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore)
|
||||
@@ -67,7 +67,7 @@ import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolS
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport (ATransport (..), basicAuthSMPVersion, authCmdsSMPVersion, currentServerSMPRelayVersion)
|
||||
import Simplex.Messaging.Transport (ATransport (..), authCmdsSMPVersion, basicAuthSMPVersion, currentServerSMPRelayVersion)
|
||||
import Simplex.Messaging.Version
|
||||
import System.Directory (copyFile, renameFile)
|
||||
import Test.Hspec
|
||||
@@ -147,7 +147,7 @@ agentCfgVPrev =
|
||||
}
|
||||
|
||||
agentCfgV7 :: AgentConfig
|
||||
agentCfgV7 =
|
||||
agentCfgV7 =
|
||||
agentCfg
|
||||
{ sndAuthAlg = C.AuthAlg C.SX25519,
|
||||
smpCfg = smpCfgV7,
|
||||
@@ -271,6 +271,16 @@ functionalAPITests t = do
|
||||
withSmpServer t testAcceptContactAsync
|
||||
it "should delete connections using async command when server connection fails" $
|
||||
testDeleteConnectionAsync t
|
||||
it "delete waiting for delivery - should delete connection immediately if there are no pending messages" $
|
||||
testDeleteConnectionAsyncWaitDeliveryNoPending t
|
||||
it "delete waiting for delivery - should delete connection after waiting for delivery to complete" $
|
||||
testDeleteConnectionAsyncWaitDelivery t
|
||||
it "delete waiting for delivery - should delete connection if message can't be delivered due to AUTH error" $
|
||||
testDeleteConnectionAsyncWaitDeliveryAUTHErr t
|
||||
it "delete waiting for delivery - should delete connection by timeout even if message wasn't delivered" $
|
||||
testDeleteConnectionAsyncWaitDeliveryTimeout t
|
||||
it "delete waiting for delivery - should delete connection by timeout, message in progress can be delivered" $
|
||||
testDeleteConnectionAsyncWaitDeliveryTimeout2 t
|
||||
it "join connection when reply queue creation fails" $
|
||||
testJoinConnectionAsyncReplyError t
|
||||
describe "Users" $ do
|
||||
@@ -381,7 +391,7 @@ testRatchetMatrix2 t runTest = do
|
||||
pendingV "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 3 runTest
|
||||
pendingV "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 3 runTest
|
||||
where
|
||||
pendingV =
|
||||
pendingV =
|
||||
let vr = e2eEncryptVRange agentCfg
|
||||
in if minVersion vr == maxVersion vr then xit else it
|
||||
|
||||
@@ -1428,7 +1438,7 @@ testAsyncCommands =
|
||||
]
|
||||
ackMessageAsync alice "7" bobId (baseId + 4) Nothing
|
||||
get alice =##> \case ("7", _, OK) -> True; _ -> False
|
||||
deleteConnectionAsync alice bobId
|
||||
deleteConnectionAsync alice False bobId
|
||||
get alice =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bobId; _ -> False
|
||||
get alice =##> \case ("", c, DEL_CONN) -> c == bobId; _ -> False
|
||||
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
||||
@@ -1498,7 +1508,7 @@ testDeleteConnectionAsync t = do
|
||||
(bId3, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe
|
||||
pure ([bId1, bId2, bId3] :: [ConnId])
|
||||
runRight_ $ do
|
||||
deleteConnectionsAsync a connIds
|
||||
deleteConnectionsAsync a False connIds
|
||||
get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False
|
||||
get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False
|
||||
get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False
|
||||
@@ -1508,6 +1518,232 @@ testDeleteConnectionAsync t = do
|
||||
liftIO $ noMessages a "nothing else should be delivered to alice"
|
||||
disconnectAgentClient a
|
||||
|
||||
testDeleteConnectionAsyncWaitDeliveryNoPending :: ATransport -> IO ()
|
||||
testDeleteConnectionAsyncWaitDeliveryNoPending t = do
|
||||
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
|
||||
(aliceId, bobId) <- makeConnection alice bob
|
||||
|
||||
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
|
||||
get alice ##> ("", bobId, SENT $ baseId + 1)
|
||||
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
||||
ackMessage bob aliceId (baseId + 1) Nothing
|
||||
|
||||
2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
||||
get bob ##> ("", aliceId, SENT $ baseId + 2)
|
||||
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
||||
ackMessage alice bobId (baseId + 2) Nothing
|
||||
|
||||
deleteConnectionsAsync alice True [bobId]
|
||||
get alice =##> \case ("", cId, DEL_RCVQ _ _ Nothing) -> cId == bobId; _ -> False
|
||||
get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False
|
||||
|
||||
3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
|
||||
get bob ##> ("", aliceId, MERR (baseId + 3) (SMP AUTH))
|
||||
|
||||
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
||||
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
||||
|
||||
disconnectAgentClient alice
|
||||
disconnectAgentClient bob
|
||||
where
|
||||
baseId = 3
|
||||
msgId = subtract baseId
|
||||
|
||||
testDeleteConnectionAsyncWaitDelivery :: ATransport -> IO ()
|
||||
testDeleteConnectionAsyncWaitDelivery t = do
|
||||
alice <- getSMPAgentClient' 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB
|
||||
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
(aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
|
||||
(aliceId, bobId) <- makeConnection alice bob
|
||||
|
||||
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
|
||||
get alice ##> ("", bobId, SENT $ baseId + 1)
|
||||
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
||||
ackMessage bob aliceId (baseId + 1) Nothing
|
||||
|
||||
2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
||||
get bob ##> ("", aliceId, SENT $ baseId + 2)
|
||||
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
||||
ackMessage alice bobId (baseId + 2) Nothing
|
||||
|
||||
pure (aliceId, bobId)
|
||||
|
||||
runRight_ $ do
|
||||
("", "", DOWN _ _) <- nGet alice
|
||||
("", "", DOWN _ _) <- nGet bob
|
||||
3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
|
||||
4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
|
||||
deleteConnectionsAsync alice True [bobId]
|
||||
get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
|
||||
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
||||
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
||||
|
||||
withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
|
||||
get alice ##> ("", bobId, SENT $ baseId + 3)
|
||||
get alice ##> ("", bobId, SENT $ baseId + 4)
|
||||
get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False
|
||||
|
||||
liftIO $
|
||||
getInAnyOrder
|
||||
bob
|
||||
[ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False,
|
||||
\case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False
|
||||
]
|
||||
ackMessage bob aliceId (baseId + 3) Nothing
|
||||
get bob =##> \case ("", c, Msg "message 1") -> c == aliceId; _ -> False
|
||||
ackMessage bob aliceId (baseId + 4) Nothing
|
||||
|
||||
-- queue wasn't deleted (DEL never reached server, see DEL_RCVQ with error), so bob can send message
|
||||
5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
|
||||
get bob ##> ("", aliceId, SENT $ baseId + 5)
|
||||
|
||||
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
||||
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
||||
|
||||
disconnectAgentClient alice
|
||||
disconnectAgentClient bob
|
||||
where
|
||||
baseId = 3
|
||||
msgId = subtract baseId
|
||||
|
||||
testDeleteConnectionAsyncWaitDeliveryAUTHErr :: ATransport -> IO ()
|
||||
testDeleteConnectionAsyncWaitDeliveryAUTHErr t = do
|
||||
alice <- getSMPAgentClient' 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB
|
||||
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
(_aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
|
||||
(aliceId, bobId) <- makeConnection alice bob
|
||||
|
||||
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
|
||||
get alice ##> ("", bobId, SENT $ baseId + 1)
|
||||
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
||||
ackMessage bob aliceId (baseId + 1) Nothing
|
||||
|
||||
2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
||||
get bob ##> ("", aliceId, SENT $ baseId + 2)
|
||||
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
||||
ackMessage alice bobId (baseId + 2) Nothing
|
||||
|
||||
deleteConnectionsAsync bob False [aliceId]
|
||||
get bob =##> \case ("", cId, DEL_RCVQ _ _ Nothing) -> cId == aliceId; _ -> False
|
||||
get bob =##> \case ("", cId, DEL_CONN) -> cId == aliceId; _ -> False
|
||||
|
||||
pure (aliceId, bobId)
|
||||
|
||||
runRight_ $ do
|
||||
("", "", DOWN _ _) <- nGet alice
|
||||
3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
|
||||
4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
|
||||
deleteConnectionsAsync alice True [bobId]
|
||||
get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
|
||||
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
||||
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
||||
|
||||
withSmpServerStoreLogOn t testPort $ \_ -> do
|
||||
get alice ##> ("", bobId, MERR (baseId + 3) (SMP AUTH))
|
||||
get alice ##> ("", bobId, MERR (baseId + 4) (SMP AUTH))
|
||||
get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False
|
||||
|
||||
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
||||
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
||||
|
||||
disconnectAgentClient alice
|
||||
disconnectAgentClient bob
|
||||
where
|
||||
baseId = 3
|
||||
msgId = subtract baseId
|
||||
|
||||
testDeleteConnectionAsyncWaitDeliveryTimeout :: ATransport -> IO ()
|
||||
testDeleteConnectionAsyncWaitDeliveryTimeout t = do
|
||||
alice <- getSMPAgentClient' 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB
|
||||
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
(aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
|
||||
(aliceId, bobId) <- makeConnection alice bob
|
||||
|
||||
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
|
||||
get alice ##> ("", bobId, SENT $ baseId + 1)
|
||||
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
||||
ackMessage bob aliceId (baseId + 1) Nothing
|
||||
|
||||
2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
||||
get bob ##> ("", aliceId, SENT $ baseId + 2)
|
||||
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
||||
ackMessage alice bobId (baseId + 2) Nothing
|
||||
|
||||
pure (aliceId, bobId)
|
||||
|
||||
runRight_ $ do
|
||||
("", "", DOWN _ _) <- nGet alice
|
||||
("", "", DOWN _ _) <- nGet bob
|
||||
3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
|
||||
4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
|
||||
deleteConnectionsAsync alice True [bobId]
|
||||
get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
|
||||
get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False
|
||||
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
||||
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
||||
|
||||
withSmpServerStoreLogOn t testPort $ \_ -> do
|
||||
nGet bob =##> \case ("", "", UP _ [cId]) -> cId == aliceId; _ -> False
|
||||
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
||||
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
||||
|
||||
disconnectAgentClient alice
|
||||
disconnectAgentClient bob
|
||||
where
|
||||
baseId = 3
|
||||
msgId = subtract baseId
|
||||
|
||||
testDeleteConnectionAsyncWaitDeliveryTimeout2 :: ATransport -> IO ()
|
||||
testDeleteConnectionAsyncWaitDeliveryTimeout2 t = do
|
||||
alice <- getSMPAgentClient' 1 agentCfg {connDeleteDeliveryTimeout = 2, messageRetryInterval = fastMessageRetryInterval, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB
|
||||
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
(aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
|
||||
(aliceId, bobId) <- makeConnection alice bob
|
||||
|
||||
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
|
||||
get alice ##> ("", bobId, SENT $ baseId + 1)
|
||||
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
||||
ackMessage bob aliceId (baseId + 1) Nothing
|
||||
|
||||
2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
||||
get bob ##> ("", aliceId, SENT $ baseId + 2)
|
||||
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
||||
ackMessage alice bobId (baseId + 2) Nothing
|
||||
|
||||
pure (aliceId, bobId)
|
||||
|
||||
runRight_ $ do
|
||||
("", "", DOWN _ _) <- nGet alice
|
||||
("", "", DOWN _ _) <- nGet bob
|
||||
3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
|
||||
4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
|
||||
deleteConnectionsAsync alice True [bobId]
|
||||
get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
|
||||
get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False
|
||||
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
||||
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
||||
|
||||
withSmpServerStoreLogOn t testPort $ \_ -> do
|
||||
get alice ##> ("", bobId, SENT $ baseId + 3)
|
||||
-- "message 1" not delivered
|
||||
|
||||
liftIO $
|
||||
getInAnyOrder
|
||||
bob
|
||||
[ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False,
|
||||
\case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False
|
||||
]
|
||||
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
||||
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
||||
|
||||
disconnectAgentClient alice
|
||||
disconnectAgentClient bob
|
||||
where
|
||||
baseId = 3
|
||||
msgId = subtract baseId
|
||||
|
||||
testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO ()
|
||||
testJoinConnectionAsyncReplyError t = do
|
||||
let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]}
|
||||
@@ -1714,7 +1950,7 @@ testSwitchDelete servers = do
|
||||
stats <- switchConnectionAsync a "" bId
|
||||
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
||||
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
||||
deleteConnectionAsync a bId
|
||||
deleteConnectionAsync a False bId
|
||||
get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False
|
||||
get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False
|
||||
get a =##> \case ("", c, DEL_CONN) -> c == bId; _ -> False
|
||||
|
||||
@@ -312,8 +312,8 @@ testDeleteRcvConn =
|
||||
Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
|
||||
getConn db "conn1"
|
||||
`shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq))
|
||||
deleteConn db "conn1"
|
||||
`shouldReturn` ()
|
||||
deleteConn db Nothing "conn1"
|
||||
`shouldReturn` Just "conn1"
|
||||
getConn db "conn1"
|
||||
`shouldReturn` Left SEConnNotFound
|
||||
|
||||
@@ -324,8 +324,8 @@ testDeleteSndConn =
|
||||
Right (_, sq) <- createSndConn db g cData1 sndQueue1
|
||||
getConn db "conn1"
|
||||
`shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq))
|
||||
deleteConn db "conn1"
|
||||
`shouldReturn` ()
|
||||
deleteConn db Nothing "conn1"
|
||||
`shouldReturn` Just "conn1"
|
||||
getConn db "conn1"
|
||||
`shouldReturn` Left SEConnNotFound
|
||||
|
||||
@@ -337,8 +337,8 @@ testDeleteDuplexConn =
|
||||
Right sq <- upgradeRcvConnToDuplex db "conn1" sndQueue1
|
||||
getConn db "conn1"
|
||||
`shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
|
||||
deleteConn db "conn1"
|
||||
`shouldReturn` ()
|
||||
deleteConn db Nothing "conn1"
|
||||
`shouldReturn` Just "conn1"
|
||||
getConn db "conn1"
|
||||
`shouldReturn` Left SEConnNotFound
|
||||
|
||||
|
||||
Reference in New Issue
Block a user