mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-08-28 13:44:26 +00:00
agent store: settle naming of Rcv and Snd entities (#55)
This commit is contained in:
Efim Poberezkin
@@ -147,8 +147,9 @@ processCommand c@AgentClient {sndQ} (corrId, connAlias, cmd) =
|
||||
subscribeConnection =
|
||||
withStore (`getConn` connAlias) >>= \case
|
||||
SomeConn _ (DuplexConnection _ rq _) -> subscribe rq
|
||||
SomeConn _ (ReceiveConnection _ rq) -> subscribe rq
|
||||
-- TODO possibly there should be a separate error type trying to send the message to the connection without ReceiveQueue
|
||||
SomeConn _ (RcvConnection _ rq) -> subscribe rq
|
||||
-- TODO possibly there should be a separate error type trying
|
||||
-- TODO to send the message to the connection without RcvQueue
|
||||
_ -> throwError PROHIBITED
|
||||
where
|
||||
subscribe rq = subscribeQueue c rq connAlias >> respond OK
|
||||
@@ -157,8 +158,9 @@ processCommand c@AgentClient {sndQ} (corrId, connAlias, cmd) =
|
||||
sendMessage msgBody =
|
||||
withStore (`getConn` connAlias) >>= \case
|
||||
SomeConn _ (DuplexConnection _ _ sq) -> sendMsg sq
|
||||
SomeConn _ (SendConnection _ sq) -> sendMsg sq
|
||||
-- TODO possibly there should be a separate error type trying to send the message to the connection without SendQueue
|
||||
SomeConn _ (SndConnection _ sq) -> sendMsg sq
|
||||
-- TODO possibly there should be a separate error type trying
|
||||
-- TODO to send the message to the connection without SndQueue
|
||||
_ -> throwError PROHIBITED -- NOT_READY ?
|
||||
where
|
||||
sendMsg sq = do
|
||||
@@ -171,7 +173,7 @@ processCommand c@AgentClient {sndQ} (corrId, connAlias, cmd) =
|
||||
suspendConnection =
|
||||
withStore (`getConn` connAlias) >>= \case
|
||||
SomeConn _ (DuplexConnection _ rq _) -> suspend rq
|
||||
SomeConn _ (ReceiveConnection _ rq) -> suspend rq
|
||||
SomeConn _ (RcvConnection _ rq) -> suspend rq
|
||||
_ -> throwError PROHIBITED
|
||||
where
|
||||
suspend rq = suspendQueue c rq >> respond OK
|
||||
@@ -180,7 +182,7 @@ processCommand c@AgentClient {sndQ} (corrId, connAlias, cmd) =
|
||||
deleteConnection =
|
||||
withStore (`getConn` connAlias) >>= \case
|
||||
SomeConn _ (DuplexConnection _ rq _) -> delete rq
|
||||
SomeConn _ (ReceiveConnection _ rq) -> delete rq
|
||||
SomeConn _ (RcvConnection _ rq) -> delete rq
|
||||
_ -> throwError PROHIBITED
|
||||
where
|
||||
delete rq = do
|
||||
@@ -189,7 +191,7 @@ processCommand c@AgentClient {sndQ} (corrId, connAlias, cmd) =
|
||||
withStore (`deleteConn` connAlias)
|
||||
respond OK
|
||||
|
||||
sendReplyQInfo :: SMPServer -> SendQueue -> m ()
|
||||
sendReplyQInfo :: SMPServer -> SndQueue -> m ()
|
||||
sendReplyQInfo srv sq = do
|
||||
(rq, qInfo) <- newReceiveQueue c srv connAlias
|
||||
withStore $ \st -> upgradeSndConnToDuplex st connAlias rq
|
||||
@@ -208,7 +210,7 @@ subscriber c@AgentClient {msgQ} = forever $ do
|
||||
|
||||
processSMPTransmission :: forall m. AgentMonad m => AgentClient -> SMPServerTransmission -> m ()
|
||||
processSMPTransmission c@AgentClient {sndQ} (srv, rId, cmd) = do
|
||||
rq@ReceiveQueue {connAlias, decryptKey, status} <- withStore $ \st -> getRcvQueue st srv rId
|
||||
rq@RcvQueue {connAlias, decryptKey, status} <- withStore $ \st -> getRcvQueue st srv rId
|
||||
case cmd of
|
||||
SMP.MSG srvMsgId srvTs msgBody -> do
|
||||
-- TODO deduplicate with previously received
|
||||
@@ -239,7 +241,7 @@ processSMPTransmission c@AgentClient {sndQ} (srv, rId, cmd) = do
|
||||
sendAck c rq
|
||||
REPLY qInfo -> do
|
||||
logServer "<--" c srv rId "MSG <REPLY>"
|
||||
-- TODO move senderKey inside SendQueue
|
||||
-- TODO move senderKey inside SndQueue
|
||||
(sq, senderKey, verifyKey) <- newSendQueue qInfo connAlias
|
||||
withStore $ \st -> upgradeRcvConnToDuplex st connAlias sq
|
||||
connectToSendQueue c sq senderKey verifyKey
|
||||
@@ -274,7 +276,7 @@ processSMPTransmission c@AgentClient {sndQ} (srv, rId, cmd) = do
|
||||
notify :: ConnAlias -> ACommand 'Agent -> m ()
|
||||
notify connAlias msg = atomically $ writeTBQueue sndQ ("", connAlias, msg)
|
||||
|
||||
connectToSendQueue :: AgentMonad m => AgentClient -> SendQueue -> SenderPublicKey -> VerificationKey -> m ()
|
||||
connectToSendQueue :: AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> VerificationKey -> m ()
|
||||
connectToSendQueue c sq senderKey verifyKey = do
|
||||
sendConfirmation c sq senderKey
|
||||
withStore $ \st -> setSndQueueStatus st sq Confirmed
|
||||
@@ -285,13 +287,13 @@ decryptMessage :: (MonadUnliftIO m, MonadError AgentErrorType m) => DecryptionKe
|
||||
decryptMessage decryptKey msg = liftError CRYPTO $ C.decrypt decryptKey msg
|
||||
|
||||
newSendQueue ::
|
||||
(MonadUnliftIO m, MonadReader Env m) => SMPQueueInfo -> ConnAlias -> m (SendQueue, SenderPublicKey, VerificationKey)
|
||||
(MonadUnliftIO m, MonadReader Env m) => SMPQueueInfo -> ConnAlias -> m (SndQueue, SenderPublicKey, VerificationKey)
|
||||
newSendQueue (SMPQueueInfo smpServer senderId encryptKey) connAlias = do
|
||||
size <- asks $ rsaKeySize . config
|
||||
(senderKey, sndPrivateKey) <- liftIO $ C.generateKeyPair size
|
||||
(verifyKey, signKey) <- liftIO $ C.generateKeyPair size
|
||||
let sndQueue =
|
||||
SendQueue
|
||||
SndQueue
|
||||
{ server = smpServer,
|
||||
sndId = senderId,
|
||||
connAlias,
|
||||
|
||||
@@ -145,7 +145,7 @@ withLogSMP c srv qId cmdStr action = do
|
||||
logServer "<--" c srv qId "OK"
|
||||
return res
|
||||
|
||||
newReceiveQueue :: AgentMonad m => AgentClient -> SMPServer -> ConnAlias -> m (ReceiveQueue, SMPQueueInfo)
|
||||
newReceiveQueue :: AgentMonad m => AgentClient -> SMPServer -> ConnAlias -> m (RcvQueue, SMPQueueInfo)
|
||||
newReceiveQueue c srv connAlias = do
|
||||
size <- asks $ rsaKeySize . config
|
||||
(recipientKey, rcvPrivateKey) <- liftIO $ C.generateKeyPair size
|
||||
@@ -154,7 +154,7 @@ newReceiveQueue c srv connAlias = do
|
||||
logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sId]
|
||||
(encryptKey, decryptKey) <- liftIO $ C.generateKeyPair size
|
||||
let rq =
|
||||
ReceiveQueue
|
||||
RcvQueue
|
||||
{ server = srv,
|
||||
rcvId,
|
||||
connAlias,
|
||||
@@ -168,14 +168,14 @@ newReceiveQueue c srv connAlias = do
|
||||
addSubscription c rq connAlias
|
||||
return (rq, SMPQueueInfo srv sId encryptKey)
|
||||
|
||||
subscribeQueue :: AgentMonad m => AgentClient -> ReceiveQueue -> ConnAlias -> m ()
|
||||
subscribeQueue c rq@ReceiveQueue {server, rcvPrivateKey, rcvId} connAlias = do
|
||||
subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnAlias -> m ()
|
||||
subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connAlias = do
|
||||
withLogSMP c server rcvId "SUB" $ \smp ->
|
||||
subscribeSMPQueue smp rcvPrivateKey rcvId
|
||||
addSubscription c rq connAlias
|
||||
|
||||
addSubscription :: MonadUnliftIO m => AgentClient -> ReceiveQueue -> ConnAlias -> m ()
|
||||
addSubscription c ReceiveQueue {server} connAlias = atomically $ do
|
||||
addSubscription :: MonadUnliftIO m => AgentClient -> RcvQueue -> ConnAlias -> m ()
|
||||
addSubscription c RcvQueue {server} connAlias = atomically $ do
|
||||
modifyTVar (subscrConns c) $ M.insert connAlias server
|
||||
modifyTVar (subscrSrvrs c) $ M.alter (Just . addSub) server
|
||||
where
|
||||
@@ -206,8 +206,8 @@ showServer srv = B.pack $ host srv <> maybe "" (":" <>) (port srv)
|
||||
logSecret :: ByteString -> ByteString
|
||||
logSecret bs = encode $ B.take 3 bs
|
||||
|
||||
sendConfirmation :: forall m. AgentMonad m => AgentClient -> SendQueue -> SenderPublicKey -> m ()
|
||||
sendConfirmation c SendQueue {server, sndId, encryptKey} senderKey = do
|
||||
sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> m ()
|
||||
sendConfirmation c SndQueue {server, sndId, encryptKey} senderKey = do
|
||||
msg <- mkConfirmation
|
||||
withLogSMP c server sndId "SEND <KEY>" $ \smp ->
|
||||
sendSMPMessage smp Nothing sndId msg
|
||||
@@ -217,8 +217,8 @@ sendConfirmation c SendQueue {server, sndId, encryptKey} senderKey = do
|
||||
let msg = serializeSMPMessage $ SMPConfirmation senderKey
|
||||
liftError CRYPTO $ C.encrypt encryptKey msg
|
||||
|
||||
sendHello :: forall m. AgentMonad m => AgentClient -> SendQueue -> VerificationKey -> m ()
|
||||
sendHello c SendQueue {server, sndId, sndPrivateKey, encryptKey} verifyKey = do
|
||||
sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> VerificationKey -> m ()
|
||||
sendHello c SndQueue {server, sndId, sndPrivateKey, encryptKey} verifyKey = do
|
||||
msg <- mkHello $ AckMode On
|
||||
withLogSMP c server sndId "SEND <HELLO> (retrying)" $
|
||||
send 20 msg
|
||||
@@ -235,28 +235,28 @@ sendHello c SendQueue {server, sndId, sndPrivateKey, encryptKey} verifyKey = do
|
||||
send (retry - 1) msg smp
|
||||
e -> throwE e
|
||||
|
||||
secureQueue :: AgentMonad m => AgentClient -> ReceiveQueue -> SenderPublicKey -> m ()
|
||||
secureQueue c ReceiveQueue {server, rcvId, rcvPrivateKey} senderKey =
|
||||
secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m ()
|
||||
secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey =
|
||||
withLogSMP c server rcvId "KEY <key>" $ \smp ->
|
||||
secureSMPQueue smp rcvPrivateKey rcvId senderKey
|
||||
|
||||
sendAck :: AgentMonad m => AgentClient -> ReceiveQueue -> m ()
|
||||
sendAck c ReceiveQueue {server, rcvId, rcvPrivateKey} =
|
||||
sendAck :: AgentMonad m => AgentClient -> RcvQueue -> m ()
|
||||
sendAck c RcvQueue {server, rcvId, rcvPrivateKey} =
|
||||
withLogSMP c server rcvId "ACK" $ \smp ->
|
||||
ackSMPMessage smp rcvPrivateKey rcvId
|
||||
|
||||
suspendQueue :: AgentMonad m => AgentClient -> ReceiveQueue -> m ()
|
||||
suspendQueue c ReceiveQueue {server, rcvId, rcvPrivateKey} =
|
||||
suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
|
||||
suspendQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
|
||||
withLogSMP c server rcvId "OFF" $ \smp ->
|
||||
suspendSMPQueue smp rcvPrivateKey rcvId
|
||||
|
||||
deleteQueue :: AgentMonad m => AgentClient -> ReceiveQueue -> m ()
|
||||
deleteQueue c ReceiveQueue {server, rcvId, rcvPrivateKey} =
|
||||
deleteQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
|
||||
deleteQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
|
||||
withLogSMP c server rcvId "DEL" $ \smp ->
|
||||
deleteSMPQueue smp rcvPrivateKey rcvId
|
||||
|
||||
sendAgentMessage :: AgentMonad m => AgentClient -> SendQueue -> AMessage -> m ()
|
||||
sendAgentMessage c SendQueue {server, sndId, sndPrivateKey, encryptKey} agentMsg = do
|
||||
sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> AMessage -> m ()
|
||||
sendAgentMessage c SndQueue {server, sndId, sndPrivateKey, encryptKey} agentMsg = do
|
||||
msg <- mkAgentMessage encryptKey agentMsg
|
||||
withLogSMP c server sndId "SEND <message>" $ \smp ->
|
||||
sendSMPMessage smp (Just sndPrivateKey) sndId msg
|
||||
|
||||
@@ -29,15 +29,15 @@ import Simplex.Messaging.Types
|
||||
-- | Store class type. Defines store access methods for implementations.
|
||||
class Monad m => MonadAgentStore s m where
|
||||
-- Queue and Connection management
|
||||
createRcvConn :: s -> ReceiveQueue -> m ()
|
||||
createSndConn :: s -> SendQueue -> m ()
|
||||
createRcvConn :: s -> RcvQueue -> m ()
|
||||
createSndConn :: s -> SndQueue -> m ()
|
||||
getConn :: s -> ConnAlias -> m SomeConn
|
||||
getRcvQueue :: s -> SMPServer -> SMP.RecipientId -> m ReceiveQueue
|
||||
getRcvQueue :: s -> SMPServer -> SMP.RecipientId -> m RcvQueue
|
||||
deleteConn :: s -> ConnAlias -> m ()
|
||||
upgradeRcvConnToDuplex :: s -> ConnAlias -> SendQueue -> m ()
|
||||
upgradeSndConnToDuplex :: s -> ConnAlias -> ReceiveQueue -> m ()
|
||||
setRcvQueueStatus :: s -> ReceiveQueue -> QueueStatus -> m ()
|
||||
setSndQueueStatus :: s -> SendQueue -> QueueStatus -> m ()
|
||||
upgradeRcvConnToDuplex :: s -> ConnAlias -> SndQueue -> m ()
|
||||
upgradeSndConnToDuplex :: s -> ConnAlias -> RcvQueue -> m ()
|
||||
setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m ()
|
||||
setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m ()
|
||||
|
||||
-- Msg management
|
||||
createRcvMsg :: s -> ConnAlias -> MsgBody -> ExternalSndId -> ExternalSndTs -> BrokerId -> BrokerTs -> m ()
|
||||
@@ -47,7 +47,7 @@ class Monad m => MonadAgentStore s m where
|
||||
-- * Queue types
|
||||
|
||||
-- | A receive queue. SMP queue through which the agent receives messages from a sender.
|
||||
data ReceiveQueue = ReceiveQueue
|
||||
data RcvQueue = RcvQueue
|
||||
{ server :: SMPServer,
|
||||
rcvId :: SMP.RecipientId,
|
||||
connAlias :: ConnAlias,
|
||||
@@ -61,7 +61,7 @@ data ReceiveQueue = ReceiveQueue
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | A send queue. SMP queue through which the agent sends messages to a recipient.
|
||||
data SendQueue = SendQueue
|
||||
data SndQueue = SndQueue
|
||||
{ server :: SMPServer,
|
||||
sndId :: SMP.SenderId,
|
||||
connAlias :: ConnAlias,
|
||||
@@ -75,30 +75,30 @@ data SendQueue = SendQueue
|
||||
-- * Connection types
|
||||
|
||||
-- | Type of a connection.
|
||||
data ConnType = CReceive | CSend | CDuplex deriving (Eq, Show)
|
||||
data ConnType = CRcv | CSnd | CDuplex deriving (Eq, Show)
|
||||
|
||||
-- | Connection of a specific type.
|
||||
--
|
||||
-- - ReceiveConnection is a connection that only has a receive queue set up,
|
||||
-- - RcvConnection is a connection that only has a receive queue set up,
|
||||
-- typically created by a recipient initiating a duplex connection.
|
||||
--
|
||||
-- - SendConnection is a connection that only has a send queue set up, typically
|
||||
-- - SndConnection is a connection that only has a send queue set up, typically
|
||||
-- created by a sender joining a duplex connection through a recipient's invitation.
|
||||
--
|
||||
-- - DuplexConnection is a connection that has both receive and send queues set up,
|
||||
-- typically created by upgrading a receive or a send connection with a missing queue.
|
||||
data Connection (d :: ConnType) where
|
||||
ReceiveConnection :: ConnAlias -> ReceiveQueue -> Connection CReceive
|
||||
SendConnection :: ConnAlias -> SendQueue -> Connection CSend
|
||||
DuplexConnection :: ConnAlias -> ReceiveQueue -> SendQueue -> Connection CDuplex
|
||||
RcvConnection :: ConnAlias -> RcvQueue -> Connection CRcv
|
||||
SndConnection :: ConnAlias -> SndQueue -> Connection CSnd
|
||||
DuplexConnection :: ConnAlias -> RcvQueue -> SndQueue -> Connection CDuplex
|
||||
|
||||
deriving instance Eq (Connection d)
|
||||
|
||||
deriving instance Show (Connection d)
|
||||
|
||||
data SConnType :: ConnType -> Type where
|
||||
SCReceive :: SConnType CReceive
|
||||
SCSend :: SConnType CSend
|
||||
SCRcv :: SConnType CRcv
|
||||
SCSnd :: SConnType CSnd
|
||||
SCDuplex :: SConnType CDuplex
|
||||
|
||||
deriving instance Eq (SConnType d)
|
||||
@@ -106,8 +106,8 @@ deriving instance Eq (SConnType d)
|
||||
deriving instance Show (SConnType d)
|
||||
|
||||
instance TestEquality SConnType where
|
||||
testEquality SCReceive SCReceive = Just Refl
|
||||
testEquality SCSend SCSend = Just Refl
|
||||
testEquality SCRcv SCRcv = Just Refl
|
||||
testEquality SCSnd SCSnd = Just Refl
|
||||
testEquality SCDuplex SCDuplex = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
||||
@@ -137,7 +137,7 @@ data RcvMsg = RcvMsg
|
||||
externalSndTs :: ExternalSndTs,
|
||||
brokerId :: BrokerId,
|
||||
brokerTs :: BrokerTs,
|
||||
rcvStatus :: RcvStatus,
|
||||
rcvMsgStatus :: RcvMsgStatus,
|
||||
-- | Timestamp of acknowledgement to broker, corresponds to `AcknowledgedToBroker` status.
|
||||
-- Do not mix up with `brokerTs` - timestamp created at broker after it receives the message from sender.
|
||||
ackBrokerTs :: AckBrokerTs,
|
||||
@@ -158,7 +158,7 @@ type BrokerId = MsgId
|
||||
|
||||
type BrokerTs = UTCTime
|
||||
|
||||
data RcvStatus
|
||||
data RcvMsgStatus
|
||||
= Received
|
||||
| AcknowledgedToBroker
|
||||
| AcknowledgedToSender
|
||||
@@ -173,7 +173,7 @@ data SndMsg = SndMsg
|
||||
{ msgBase :: MsgBase,
|
||||
-- | Id of the message sent / to be sent, as in its number in order of sending.
|
||||
internalSndId :: InternalSndId,
|
||||
sndStatus :: SndStatus,
|
||||
sndMsgStatus :: SndMsgStatus,
|
||||
-- | Timestamp of the message received by broker, corresponds to `Sent` status.
|
||||
sentTs :: SentTs,
|
||||
-- | Timestamp of the message received by recipient, corresponds to `Delivered` status.
|
||||
@@ -183,7 +183,7 @@ data SndMsg = SndMsg
|
||||
|
||||
type InternalSndId = Int64
|
||||
|
||||
data SndStatus
|
||||
data SndMsgStatus
|
||||
= Created
|
||||
| Sent
|
||||
| Delivered
|
||||
@@ -210,6 +210,7 @@ type InternalTs = UTCTime
|
||||
|
||||
-- * Store errors
|
||||
|
||||
-- TODO revise
|
||||
data StoreError
|
||||
= SEInternal
|
||||
| SENotFound
|
||||
|
||||
@@ -53,12 +53,12 @@ newSQLiteStore dbFilename = do
|
||||
return SQLiteStore {dbFilename, dbConn}
|
||||
|
||||
instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteStore m where
|
||||
createRcvConn :: SQLiteStore -> ReceiveQueue -> m ()
|
||||
createRcvConn :: SQLiteStore -> RcvQueue -> m ()
|
||||
createRcvConn SQLiteStore {dbConn} rcvQueue =
|
||||
liftIO $
|
||||
createRcvQueueAndConn dbConn rcvQueue
|
||||
|
||||
createSndConn :: SQLiteStore -> SendQueue -> m ()
|
||||
createSndConn :: SQLiteStore -> SndQueue -> m ()
|
||||
createSndConn SQLiteStore {dbConn} sndQueue =
|
||||
liftIO $
|
||||
createSndQueueAndConn dbConn sndQueue
|
||||
@@ -70,11 +70,11 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
|
||||
retrieveConnQueues dbConn connAlias
|
||||
case queues of
|
||||
(Just rcvQ, Just sndQ) -> return $ SomeConn SCDuplex (DuplexConnection connAlias rcvQ sndQ)
|
||||
(Just rcvQ, Nothing) -> return $ SomeConn SCReceive (ReceiveConnection connAlias rcvQ)
|
||||
(Nothing, Just sndQ) -> return $ SomeConn SCSend (SendConnection connAlias sndQ)
|
||||
(Just rcvQ, Nothing) -> return $ SomeConn SCRcv (RcvConnection connAlias rcvQ)
|
||||
(Nothing, Just sndQ) -> return $ SomeConn SCSnd (SndConnection connAlias sndQ)
|
||||
_ -> throwError SEBadConn
|
||||
|
||||
getRcvQueue :: SQLiteStore -> SMPServer -> SMP.RecipientId -> m ReceiveQueue
|
||||
getRcvQueue :: SQLiteStore -> SMPServer -> SMP.RecipientId -> m RcvQueue
|
||||
getRcvQueue SQLiteStore {dbConn} SMPServer {host, port} rcvId = do
|
||||
rcvQueue <-
|
||||
liftIO $
|
||||
@@ -88,22 +88,22 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
|
||||
liftIO $
|
||||
deleteConnCascade dbConn connAlias
|
||||
|
||||
upgradeRcvConnToDuplex :: SQLiteStore -> ConnAlias -> SendQueue -> m ()
|
||||
upgradeRcvConnToDuplex :: SQLiteStore -> ConnAlias -> SndQueue -> m ()
|
||||
upgradeRcvConnToDuplex SQLiteStore {dbConn} connAlias sndQueue =
|
||||
liftIOEither $
|
||||
updateRcvConnWithSndQueue dbConn connAlias sndQueue
|
||||
|
||||
upgradeSndConnToDuplex :: SQLiteStore -> ConnAlias -> ReceiveQueue -> m ()
|
||||
upgradeSndConnToDuplex :: SQLiteStore -> ConnAlias -> RcvQueue -> m ()
|
||||
upgradeSndConnToDuplex SQLiteStore {dbConn} connAlias rcvQueue =
|
||||
liftIOEither $
|
||||
updateSndConnWithRcvQueue dbConn connAlias rcvQueue
|
||||
|
||||
setRcvQueueStatus :: SQLiteStore -> ReceiveQueue -> QueueStatus -> m ()
|
||||
setRcvQueueStatus :: SQLiteStore -> RcvQueue -> QueueStatus -> m ()
|
||||
setRcvQueueStatus SQLiteStore {dbConn} rcvQueue status =
|
||||
liftIO $
|
||||
updateRcvQueueStatus dbConn rcvQueue status
|
||||
|
||||
setSndQueueStatus :: SQLiteStore -> SendQueue -> QueueStatus -> m ()
|
||||
setSndQueueStatus :: SQLiteStore -> SndQueue -> QueueStatus -> m ()
|
||||
setSndQueueStatus SQLiteStore {dbConn} sndQueue status =
|
||||
liftIO $
|
||||
updateSndQueueStatus dbConn sndQueue status
|
||||
@@ -135,9 +135,9 @@ instance ToField QueueStatus where toField = toField . show
|
||||
|
||||
instance FromField QueueStatus where fromField = fromFieldToReadable_
|
||||
|
||||
instance ToField RcvStatus where toField = toField . show
|
||||
instance ToField RcvMsgStatus where toField = toField . show
|
||||
|
||||
instance ToField SndStatus where toField = toField . show
|
||||
instance ToField SndMsgStatus where toField = toField . show
|
||||
|
||||
fromFieldToReadable_ :: forall a. (Read a, E.Typeable a) => Field -> Ok a
|
||||
fromFieldToReadable_ = \case
|
||||
@@ -177,15 +177,15 @@ upsertServer_ dbConn SMPServer {host, port, keyHash} = do
|
||||
|
||||
-- * createRcvConn helpers
|
||||
|
||||
createRcvQueueAndConn :: DB.Connection -> ReceiveQueue -> IO ()
|
||||
createRcvQueueAndConn :: DB.Connection -> RcvQueue -> IO ()
|
||||
createRcvQueueAndConn dbConn rcvQueue =
|
||||
DB.withTransaction dbConn $ do
|
||||
upsertServer_ dbConn (server (rcvQueue :: ReceiveQueue))
|
||||
upsertServer_ dbConn (server (rcvQueue :: RcvQueue))
|
||||
insertRcvQueue_ dbConn rcvQueue
|
||||
insertRcvConnection_ dbConn rcvQueue
|
||||
|
||||
insertRcvQueue_ :: DB.Connection -> ReceiveQueue -> IO ()
|
||||
insertRcvQueue_ dbConn ReceiveQueue {..} = do
|
||||
insertRcvQueue_ :: DB.Connection -> RcvQueue -> IO ()
|
||||
insertRcvQueue_ dbConn RcvQueue {..} = do
|
||||
let port_ = serializePort_ $ port server
|
||||
DB.executeNamed
|
||||
dbConn
|
||||
@@ -207,8 +207,8 @@ insertRcvQueue_ dbConn ReceiveQueue {..} = do
|
||||
":status" := status
|
||||
]
|
||||
|
||||
insertRcvConnection_ :: DB.Connection -> ReceiveQueue -> IO ()
|
||||
insertRcvConnection_ dbConn ReceiveQueue {server, rcvId, connAlias} = do
|
||||
insertRcvConnection_ :: DB.Connection -> RcvQueue -> IO ()
|
||||
insertRcvConnection_ dbConn RcvQueue {server, rcvId, connAlias} = do
|
||||
let port_ = serializePort_ $ port server
|
||||
DB.executeNamed
|
||||
dbConn
|
||||
@@ -224,15 +224,15 @@ insertRcvConnection_ dbConn ReceiveQueue {server, rcvId, connAlias} = do
|
||||
|
||||
-- * createSndConn helpers
|
||||
|
||||
createSndQueueAndConn :: DB.Connection -> SendQueue -> IO ()
|
||||
createSndQueueAndConn :: DB.Connection -> SndQueue -> IO ()
|
||||
createSndQueueAndConn dbConn sndQueue =
|
||||
DB.withTransaction dbConn $ do
|
||||
upsertServer_ dbConn (server (sndQueue :: SendQueue))
|
||||
upsertServer_ dbConn (server (sndQueue :: SndQueue))
|
||||
insertSndQueue_ dbConn sndQueue
|
||||
insertSndConnection_ dbConn sndQueue
|
||||
|
||||
insertSndQueue_ :: DB.Connection -> SendQueue -> IO ()
|
||||
insertSndQueue_ dbConn SendQueue {..} = do
|
||||
insertSndQueue_ :: DB.Connection -> SndQueue -> IO ()
|
||||
insertSndQueue_ dbConn SndQueue {..} = do
|
||||
let port_ = serializePort_ $ port server
|
||||
DB.executeNamed
|
||||
dbConn
|
||||
@@ -252,8 +252,8 @@ insertSndQueue_ dbConn SendQueue {..} = do
|
||||
":status" := status
|
||||
]
|
||||
|
||||
insertSndConnection_ :: DB.Connection -> SendQueue -> IO ()
|
||||
insertSndConnection_ dbConn SendQueue {server, sndId, connAlias} = do
|
||||
insertSndConnection_ :: DB.Connection -> SndQueue -> IO ()
|
||||
insertSndConnection_ dbConn SndQueue {server, sndId, connAlias} = do
|
||||
let port_ = serializePort_ $ port server
|
||||
DB.executeNamed
|
||||
dbConn
|
||||
@@ -269,7 +269,7 @@ insertSndConnection_ dbConn SendQueue {server, sndId, connAlias} = do
|
||||
|
||||
-- * getConn helpers
|
||||
|
||||
retrieveConnQueues :: DB.Connection -> ConnAlias -> IO (Maybe ReceiveQueue, Maybe SendQueue)
|
||||
retrieveConnQueues :: DB.Connection -> ConnAlias -> IO (Maybe RcvQueue, Maybe SndQueue)
|
||||
retrieveConnQueues dbConn connAlias =
|
||||
DB.withTransaction -- Avoid inconsistent state between queue reads
|
||||
dbConn
|
||||
@@ -277,13 +277,13 @@ retrieveConnQueues dbConn connAlias =
|
||||
|
||||
-- Separate transactionless version of retrieveConnQueues to be reused in other functions that already wrap
|
||||
-- multiple statements in transaction - otherwise they'd be attempting to start a transaction within a transaction
|
||||
retrieveConnQueues_ :: DB.Connection -> ConnAlias -> IO (Maybe ReceiveQueue, Maybe SendQueue)
|
||||
retrieveConnQueues_ :: DB.Connection -> ConnAlias -> IO (Maybe RcvQueue, Maybe SndQueue)
|
||||
retrieveConnQueues_ dbConn connAlias = do
|
||||
rcvQ <- retrieveRcvQueueByConnAlias_ dbConn connAlias
|
||||
sndQ <- retrieveSndQueueByConnAlias_ dbConn connAlias
|
||||
return (rcvQ, sndQ)
|
||||
|
||||
retrieveRcvQueueByConnAlias_ :: DB.Connection -> ConnAlias -> IO (Maybe ReceiveQueue)
|
||||
retrieveRcvQueueByConnAlias_ :: DB.Connection -> ConnAlias -> IO (Maybe RcvQueue)
|
||||
retrieveRcvQueueByConnAlias_ dbConn connAlias = do
|
||||
r <-
|
||||
DB.queryNamed
|
||||
@@ -300,10 +300,10 @@ retrieveRcvQueueByConnAlias_ dbConn connAlias = do
|
||||
case r of
|
||||
[(keyHash, host, port, rcvId, cAlias, rcvPrivateKey, sndId, sndKey, decryptKey, verifyKey, status)] -> do
|
||||
let srv = SMPServer host (deserializePort_ port) keyHash
|
||||
return . Just $ ReceiveQueue srv rcvId cAlias rcvPrivateKey sndId sndKey decryptKey verifyKey status
|
||||
return . Just $ RcvQueue srv rcvId cAlias rcvPrivateKey sndId sndKey decryptKey verifyKey status
|
||||
_ -> return Nothing
|
||||
|
||||
retrieveSndQueueByConnAlias_ :: DB.Connection -> ConnAlias -> IO (Maybe SendQueue)
|
||||
retrieveSndQueueByConnAlias_ :: DB.Connection -> ConnAlias -> IO (Maybe SndQueue)
|
||||
retrieveSndQueueByConnAlias_ dbConn connAlias = do
|
||||
r <-
|
||||
DB.queryNamed
|
||||
@@ -320,12 +320,12 @@ retrieveSndQueueByConnAlias_ dbConn connAlias = do
|
||||
case r of
|
||||
[(keyHash, host, port, sndId, cAlias, sndPrivateKey, encryptKey, signKey, status)] -> do
|
||||
let srv = SMPServer host (deserializePort_ port) keyHash
|
||||
return . Just $ SendQueue srv sndId cAlias sndPrivateKey encryptKey signKey status
|
||||
return . Just $ SndQueue srv sndId cAlias sndPrivateKey encryptKey signKey status
|
||||
_ -> return Nothing
|
||||
|
||||
-- * getRcvQueue helper
|
||||
|
||||
retrieveRcvQueue :: DB.Connection -> HostName -> Maybe ServiceName -> SMP.RecipientId -> IO (Maybe ReceiveQueue)
|
||||
retrieveRcvQueue :: DB.Connection -> HostName -> Maybe ServiceName -> SMP.RecipientId -> IO (Maybe RcvQueue)
|
||||
retrieveRcvQueue dbConn host port rcvId = do
|
||||
r <-
|
||||
DB.queryNamed
|
||||
@@ -342,7 +342,7 @@ retrieveRcvQueue dbConn host port rcvId = do
|
||||
case r of
|
||||
[(keyHash, hst, prt, rId, connAlias, rcvPrivateKey, sndId, sndKey, decryptKey, verifyKey, status)] -> do
|
||||
let srv = SMPServer hst (deserializePort_ prt) keyHash
|
||||
return . Just $ ReceiveQueue srv rId connAlias rcvPrivateKey sndId sndKey decryptKey verifyKey status
|
||||
return . Just $ RcvQueue srv rId connAlias rcvPrivateKey sndId sndKey decryptKey verifyKey status
|
||||
_ -> return Nothing
|
||||
|
||||
-- * deleteConn helper
|
||||
@@ -356,22 +356,22 @@ deleteConnCascade dbConn connAlias =
|
||||
|
||||
-- * upgradeRcvConnToDuplex helpers
|
||||
|
||||
updateRcvConnWithSndQueue :: DB.Connection -> ConnAlias -> SendQueue -> IO (Either StoreError ())
|
||||
updateRcvConnWithSndQueue :: DB.Connection -> ConnAlias -> SndQueue -> IO (Either StoreError ())
|
||||
updateRcvConnWithSndQueue dbConn connAlias sndQueue =
|
||||
DB.withTransaction dbConn $ do
|
||||
queues <- retrieveConnQueues_ dbConn connAlias
|
||||
case queues of
|
||||
(Just _rcvQ, Nothing) -> do
|
||||
upsertServer_ dbConn (server (sndQueue :: SendQueue))
|
||||
upsertServer_ dbConn (server (sndQueue :: SndQueue))
|
||||
insertSndQueue_ dbConn sndQueue
|
||||
updateConnWithSndQueue_ dbConn connAlias sndQueue
|
||||
return $ Right ()
|
||||
(Nothing, Just _sndQ) -> return $ Left (SEBadConnType CSend)
|
||||
(Nothing, Just _sndQ) -> return $ Left (SEBadConnType CSnd)
|
||||
(Just _rcvQ, Just _sndQ) -> return $ Left (SEBadConnType CDuplex)
|
||||
_ -> return $ Left SEBadConn
|
||||
|
||||
updateConnWithSndQueue_ :: DB.Connection -> ConnAlias -> SendQueue -> IO ()
|
||||
updateConnWithSndQueue_ dbConn connAlias SendQueue {server, sndId} = do
|
||||
updateConnWithSndQueue_ :: DB.Connection -> ConnAlias -> SndQueue -> IO ()
|
||||
updateConnWithSndQueue_ dbConn connAlias SndQueue {server, sndId} = do
|
||||
let port_ = serializePort_ $ port server
|
||||
DB.executeNamed
|
||||
dbConn
|
||||
@@ -384,22 +384,22 @@ updateConnWithSndQueue_ dbConn connAlias SendQueue {server, sndId} = do
|
||||
|
||||
-- * upgradeSndConnToDuplex helpers
|
||||
|
||||
updateSndConnWithRcvQueue :: DB.Connection -> ConnAlias -> ReceiveQueue -> IO (Either StoreError ())
|
||||
updateSndConnWithRcvQueue :: DB.Connection -> ConnAlias -> RcvQueue -> IO (Either StoreError ())
|
||||
updateSndConnWithRcvQueue dbConn connAlias rcvQueue =
|
||||
DB.withTransaction dbConn $ do
|
||||
queues <- retrieveConnQueues_ dbConn connAlias
|
||||
case queues of
|
||||
(Nothing, Just _sndQ) -> do
|
||||
upsertServer_ dbConn (server (rcvQueue :: ReceiveQueue))
|
||||
upsertServer_ dbConn (server (rcvQueue :: RcvQueue))
|
||||
insertRcvQueue_ dbConn rcvQueue
|
||||
updateConnWithRcvQueue_ dbConn connAlias rcvQueue
|
||||
return $ Right ()
|
||||
(Just _rcvQ, Nothing) -> return $ Left (SEBadConnType CReceive)
|
||||
(Just _rcvQ, Nothing) -> return $ Left (SEBadConnType CRcv)
|
||||
(Just _rcvQ, Just _sndQ) -> return $ Left (SEBadConnType CDuplex)
|
||||
_ -> return $ Left SEBadConn
|
||||
|
||||
updateConnWithRcvQueue_ :: DB.Connection -> ConnAlias -> ReceiveQueue -> IO ()
|
||||
updateConnWithRcvQueue_ dbConn connAlias ReceiveQueue {server, rcvId} = do
|
||||
updateConnWithRcvQueue_ :: DB.Connection -> ConnAlias -> RcvQueue -> IO ()
|
||||
updateConnWithRcvQueue_ dbConn connAlias RcvQueue {server, rcvId} = do
|
||||
let port_ = serializePort_ $ port server
|
||||
DB.executeNamed
|
||||
dbConn
|
||||
@@ -413,8 +413,8 @@ updateConnWithRcvQueue_ dbConn connAlias ReceiveQueue {server, rcvId} = do
|
||||
-- * setRcvQueueStatus helper
|
||||
|
||||
-- ? throw error if queue doesn't exist?
|
||||
updateRcvQueueStatus :: DB.Connection -> ReceiveQueue -> QueueStatus -> IO ()
|
||||
updateRcvQueueStatus dbConn ReceiveQueue {rcvId, server = SMPServer {host, port}} status =
|
||||
updateRcvQueueStatus :: DB.Connection -> RcvQueue -> QueueStatus -> IO ()
|
||||
updateRcvQueueStatus dbConn RcvQueue {rcvId, server = SMPServer {host, port}} status =
|
||||
DB.executeNamed
|
||||
dbConn
|
||||
[sql|
|
||||
@@ -427,8 +427,8 @@ updateRcvQueueStatus dbConn ReceiveQueue {rcvId, server = SMPServer {host, port}
|
||||
-- * setSndQueueStatus helper
|
||||
|
||||
-- ? throw error if queue doesn't exist?
|
||||
updateSndQueueStatus :: DB.Connection -> SendQueue -> QueueStatus -> IO ()
|
||||
updateSndQueueStatus dbConn SendQueue {sndId, server = SMPServer {host, port}} status =
|
||||
updateSndQueueStatus :: DB.Connection -> SndQueue -> QueueStatus -> IO ()
|
||||
updateSndQueueStatus dbConn SndQueue {sndId, server = SMPServer {host, port}} status =
|
||||
DB.executeNamed
|
||||
dbConn
|
||||
[sql|
|
||||
@@ -461,7 +461,7 @@ insertRcvMsg dbConn connAlias msgBody externalSndId externalSndTs brokerId broke
|
||||
insertRcvMsgDetails_ dbConn connAlias internalRcvId internalId externalSndId externalSndTs brokerId brokerTs
|
||||
updateLastInternalIdsRcv_ dbConn connAlias internalId internalRcvId
|
||||
return $ Right ()
|
||||
(Nothing, Just _sndQ) -> return $ Left (SEBadConnType CSend)
|
||||
(Nothing, Just _sndQ) -> return $ Left (SEBadConnType CSnd)
|
||||
_ -> return $ Left SEBadConn
|
||||
|
||||
retrieveLastInternalIdsRcv_ :: DB.Connection -> ConnAlias -> IO (InternalId, InternalRcvId)
|
||||
@@ -555,7 +555,7 @@ insertSndMsg dbConn connAlias msgBody =
|
||||
insertSndMsgDetails_ dbConn connAlias internalSndId internalId
|
||||
updateLastInternalIdsSnd_ dbConn connAlias internalId internalSndId
|
||||
return $ Right ()
|
||||
(Just _rcvQ, Nothing) -> return $ Left (SEBadConnType CReceive)
|
||||
(Just _rcvQ, Nothing) -> return $ Left (SEBadConnType CRcv)
|
||||
_ -> return $ Left SEBadConn
|
||||
|
||||
retrieveLastInternalIdsSnd_ :: DB.Connection -> ConnAlias -> IO (InternalId, InternalSndId)
|
||||
|
||||
@@ -53,23 +53,23 @@ storeTests = withStore do
|
||||
describe "createSndConn" testCreateSndConn
|
||||
describe "getRcvQueue" testGetRcvQueue
|
||||
describe "deleteConn" do
|
||||
describe "rcv" testDeleteRcvConn
|
||||
describe "snd" testDeleteSndConn
|
||||
describe "duplex" testDeleteDuplexConn
|
||||
describe "RcvConnection" testDeleteRcvConn
|
||||
describe "SndConnection" testDeleteSndConn
|
||||
describe "DuplexConnection" testDeleteDuplexConn
|
||||
describe "upgradeRcvConnToDuplex" testUpgradeRcvConnToDuplex
|
||||
describe "upgradeSndConnToDuplex" testUpgradeSndConnToDuplex
|
||||
describe "set queue status" do
|
||||
describe "setRcvQueueStatus" testSetRcvQueueStatus
|
||||
describe "setSndQueueStatus" testSetSndQueueStatus
|
||||
describe "duplex connection" testSetQueueStatusDuplex
|
||||
xdescribe "rcv queue doesn't exist" testSetRcvQueueStatusNoQueue
|
||||
xdescribe "snd queue doesn't exist" testSetSndQueueStatusNoQueue
|
||||
describe "DuplexConnection" testSetQueueStatusDuplex
|
||||
xdescribe "RcvQueue doesn't exist" testSetRcvQueueStatusNoQueue
|
||||
xdescribe "SndQueue doesn't exist" testSetSndQueueStatusNoQueue
|
||||
describe "createRcvMsg" do
|
||||
describe "rcv queue exists" testCreateRcvMsg
|
||||
describe "rcv queue doesn't exist" testCreateRcvMsgNoQueue
|
||||
describe "RcvQueue exists" testCreateRcvMsg
|
||||
describe "RcvQueue doesn't exist" testCreateRcvMsgNoQueue
|
||||
describe "createSndMsg" do
|
||||
describe "snd queue exists" testCreateSndMsg
|
||||
describe "snd queue doesn't exist" testCreateSndMsgNoQueue
|
||||
describe "SndQueue exists" testCreateSndMsg
|
||||
describe "SndQueue doesn't exist" testCreateSndMsgNoQueue
|
||||
|
||||
testForeignKeysEnabled :: SpecWith SQLiteStore
|
||||
testForeignKeysEnabled = do
|
||||
@@ -84,9 +84,9 @@ testForeignKeysEnabled = do
|
||||
DB.execute_ (dbConn store) inconsistentQuery
|
||||
`shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint)
|
||||
|
||||
rcvQueue1 :: ReceiveQueue
|
||||
rcvQueue1 :: RcvQueue
|
||||
rcvQueue1 =
|
||||
ReceiveQueue
|
||||
RcvQueue
|
||||
{ server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"),
|
||||
rcvId = "1234",
|
||||
connAlias = "conn1",
|
||||
@@ -98,9 +98,9 @@ rcvQueue1 =
|
||||
status = New
|
||||
}
|
||||
|
||||
sndQueue1 :: SendQueue
|
||||
sndQueue1 :: SndQueue
|
||||
sndQueue1 =
|
||||
SendQueue
|
||||
SndQueue
|
||||
{ server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"),
|
||||
sndId = "3456",
|
||||
connAlias = "conn1",
|
||||
@@ -112,11 +112,11 @@ sndQueue1 =
|
||||
|
||||
testCreateRcvConn :: SpecWith SQLiteStore
|
||||
testCreateRcvConn = do
|
||||
it "should create receive connection and add send queue" $ \store -> do
|
||||
it "should create RcvConnection and add SndQueue" $ \store -> do
|
||||
createRcvConn store rcvQueue1
|
||||
`returnsResult` ()
|
||||
getConn store "conn1"
|
||||
`returnsResult` SomeConn SCReceive (ReceiveConnection "conn1" rcvQueue1)
|
||||
`returnsResult` SomeConn SCRcv (RcvConnection "conn1" rcvQueue1)
|
||||
upgradeRcvConnToDuplex store "conn1" sndQueue1
|
||||
`returnsResult` ()
|
||||
getConn store "conn1"
|
||||
@@ -124,11 +124,11 @@ testCreateRcvConn = do
|
||||
|
||||
testCreateSndConn :: SpecWith SQLiteStore
|
||||
testCreateSndConn = do
|
||||
it "should create send connection and add receive queue" $ \store -> do
|
||||
it "should create SndConnection and add RcvQueue" $ \store -> do
|
||||
createSndConn store sndQueue1
|
||||
`returnsResult` ()
|
||||
getConn store "conn1"
|
||||
`returnsResult` SomeConn SCSend (SendConnection "conn1" sndQueue1)
|
||||
`returnsResult` SomeConn SCSnd (SndConnection "conn1" sndQueue1)
|
||||
upgradeSndConnToDuplex store "conn1" rcvQueue1
|
||||
`returnsResult` ()
|
||||
getConn store "conn1"
|
||||
@@ -136,7 +136,7 @@ testCreateSndConn = do
|
||||
|
||||
testGetRcvQueue :: SpecWith SQLiteStore
|
||||
testGetRcvQueue = do
|
||||
it "should get receive queue" $ \store -> do
|
||||
it "should get RcvQueue" $ \store -> do
|
||||
let smpServer = SMPServer "smp.simplex.im" (Just "5223") (Just "1234")
|
||||
let recipientId = "1234"
|
||||
createRcvConn store rcvQueue1
|
||||
@@ -146,11 +146,11 @@ testGetRcvQueue = do
|
||||
|
||||
testDeleteRcvConn :: SpecWith SQLiteStore
|
||||
testDeleteRcvConn = do
|
||||
it "should create receive connection and delete it" $ \store -> do
|
||||
it "should create RcvConnection and delete it" $ \store -> do
|
||||
createRcvConn store rcvQueue1
|
||||
`returnsResult` ()
|
||||
getConn store "conn1"
|
||||
`returnsResult` SomeConn SCReceive (ReceiveConnection "conn1" rcvQueue1)
|
||||
`returnsResult` SomeConn SCRcv (RcvConnection "conn1" rcvQueue1)
|
||||
deleteConn store "conn1"
|
||||
`returnsResult` ()
|
||||
-- TODO check queues are deleted as well
|
||||
@@ -159,11 +159,11 @@ testDeleteRcvConn = do
|
||||
|
||||
testDeleteSndConn :: SpecWith SQLiteStore
|
||||
testDeleteSndConn = do
|
||||
it "should create send connection and delete it" $ \store -> do
|
||||
it "should create SndConnection and delete it" $ \store -> do
|
||||
createSndConn store sndQueue1
|
||||
`returnsResult` ()
|
||||
getConn store "conn1"
|
||||
`returnsResult` SomeConn SCSend (SendConnection "conn1" sndQueue1)
|
||||
`returnsResult` SomeConn SCSnd (SndConnection "conn1" sndQueue1)
|
||||
deleteConn store "conn1"
|
||||
`returnsResult` ()
|
||||
-- TODO check queues are deleted as well
|
||||
@@ -172,7 +172,7 @@ testDeleteSndConn = do
|
||||
|
||||
testDeleteDuplexConn :: SpecWith SQLiteStore
|
||||
testDeleteDuplexConn = do
|
||||
it "should create duplex connection and delete it" $ \store -> do
|
||||
it "should create DuplexConnection and delete it" $ \store -> do
|
||||
createRcvConn store rcvQueue1
|
||||
`returnsResult` ()
|
||||
upgradeRcvConnToDuplex store "conn1" sndQueue1
|
||||
@@ -187,11 +187,11 @@ testDeleteDuplexConn = do
|
||||
|
||||
testUpgradeRcvConnToDuplex :: SpecWith SQLiteStore
|
||||
testUpgradeRcvConnToDuplex = do
|
||||
it "should throw error on attempts to add send queue to SendConnection or DuplexConnection" $ \store -> do
|
||||
it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" $ \store -> do
|
||||
createSndConn store sndQueue1
|
||||
`returnsResult` ()
|
||||
let anotherSndQueue =
|
||||
SendQueue
|
||||
SndQueue
|
||||
{ server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"),
|
||||
sndId = "2345",
|
||||
connAlias = "conn1",
|
||||
@@ -201,7 +201,7 @@ testUpgradeRcvConnToDuplex = do
|
||||
status = New
|
||||
}
|
||||
upgradeRcvConnToDuplex store "conn1" anotherSndQueue
|
||||
`throwsError` SEBadConnType CSend
|
||||
`throwsError` SEBadConnType CSnd
|
||||
upgradeSndConnToDuplex store "conn1" rcvQueue1
|
||||
`returnsResult` ()
|
||||
upgradeRcvConnToDuplex store "conn1" anotherSndQueue
|
||||
@@ -209,11 +209,11 @@ testUpgradeRcvConnToDuplex = do
|
||||
|
||||
testUpgradeSndConnToDuplex :: SpecWith SQLiteStore
|
||||
testUpgradeSndConnToDuplex = do
|
||||
it "should throw error on attempts to add receive queue to ReceiveConnection or DuplexConnection" $ \store -> do
|
||||
it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" $ \store -> do
|
||||
createRcvConn store rcvQueue1
|
||||
`returnsResult` ()
|
||||
let anotherRcvQueue =
|
||||
ReceiveQueue
|
||||
RcvQueue
|
||||
{ server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"),
|
||||
rcvId = "3456",
|
||||
connAlias = "conn1",
|
||||
@@ -225,7 +225,7 @@ testUpgradeSndConnToDuplex = do
|
||||
status = New
|
||||
}
|
||||
upgradeSndConnToDuplex store "conn1" anotherRcvQueue
|
||||
`throwsError` SEBadConnType CReceive
|
||||
`throwsError` SEBadConnType CRcv
|
||||
upgradeRcvConnToDuplex store "conn1" sndQueue1
|
||||
`returnsResult` ()
|
||||
upgradeSndConnToDuplex store "conn1" anotherRcvQueue
|
||||
@@ -233,31 +233,31 @@ testUpgradeSndConnToDuplex = do
|
||||
|
||||
testSetRcvQueueStatus :: SpecWith SQLiteStore
|
||||
testSetRcvQueueStatus = do
|
||||
it "should update status of receive queue" $ \store -> do
|
||||
it "should update status of RcvQueue" $ \store -> do
|
||||
createRcvConn store rcvQueue1
|
||||
`returnsResult` ()
|
||||
getConn store "conn1"
|
||||
`returnsResult` SomeConn SCReceive (ReceiveConnection "conn1" rcvQueue1)
|
||||
`returnsResult` SomeConn SCRcv (RcvConnection "conn1" rcvQueue1)
|
||||
setRcvQueueStatus store rcvQueue1 Confirmed
|
||||
`returnsResult` ()
|
||||
getConn store "conn1"
|
||||
`returnsResult` SomeConn SCReceive (ReceiveConnection "conn1" rcvQueue1 {status = Confirmed})
|
||||
`returnsResult` SomeConn SCRcv (RcvConnection "conn1" rcvQueue1 {status = Confirmed})
|
||||
|
||||
testSetSndQueueStatus :: SpecWith SQLiteStore
|
||||
testSetSndQueueStatus = do
|
||||
it "should update status of send queue" $ \store -> do
|
||||
it "should update status of SndQueue" $ \store -> do
|
||||
createSndConn store sndQueue1
|
||||
`returnsResult` ()
|
||||
getConn store "conn1"
|
||||
`returnsResult` SomeConn SCSend (SendConnection "conn1" sndQueue1)
|
||||
`returnsResult` SomeConn SCSnd (SndConnection "conn1" sndQueue1)
|
||||
setSndQueueStatus store sndQueue1 Confirmed
|
||||
`returnsResult` ()
|
||||
getConn store "conn1"
|
||||
`returnsResult` SomeConn SCSend (SendConnection "conn1" sndQueue1 {status = Confirmed})
|
||||
`returnsResult` SomeConn SCSnd (SndConnection "conn1" sndQueue1 {status = Confirmed})
|
||||
|
||||
testSetQueueStatusDuplex :: SpecWith SQLiteStore
|
||||
testSetQueueStatusDuplex = do
|
||||
it "should update statuses of receive and send queues in duplex connection" $ \store -> do
|
||||
it "should update statuses of RcvQueue and SndQueue in DuplexConnection" $ \store -> do
|
||||
createRcvConn store rcvQueue1
|
||||
`returnsResult` ()
|
||||
upgradeRcvConnToDuplex store "conn1" sndQueue1
|
||||
@@ -278,19 +278,19 @@ testSetQueueStatusDuplex = do
|
||||
|
||||
testSetRcvQueueStatusNoQueue :: SpecWith SQLiteStore
|
||||
testSetRcvQueueStatusNoQueue = do
|
||||
it "should throw error on attempt to update status of nonexistent receive queue" $ \store -> do
|
||||
it "should throw error on attempt to update status of nonexistent RcvQueue" $ \store -> do
|
||||
setRcvQueueStatus store rcvQueue1 Confirmed
|
||||
`throwsError` SEInternal
|
||||
|
||||
testSetSndQueueStatusNoQueue :: SpecWith SQLiteStore
|
||||
testSetSndQueueStatusNoQueue = do
|
||||
it "should throw error on attempt to update status of nonexistent send queue" $ \store -> do
|
||||
it "should throw error on attempt to update status of nonexistent SndQueue" $ \store -> do
|
||||
setSndQueueStatus store sndQueue1 Confirmed
|
||||
`throwsError` SEInternal
|
||||
|
||||
testCreateRcvMsg :: SpecWith SQLiteStore
|
||||
testCreateRcvMsg = do
|
||||
it "should create a rcv message" $ \store -> do
|
||||
it "should create a RcvMsg" $ \store -> do
|
||||
createRcvConn store rcvQueue1
|
||||
`returnsResult` ()
|
||||
-- TODO getMsg to check message
|
||||
@@ -300,18 +300,18 @@ testCreateRcvMsg = do
|
||||
|
||||
testCreateRcvMsgNoQueue :: SpecWith SQLiteStore
|
||||
testCreateRcvMsgNoQueue = do
|
||||
it "should throw error on attempt to create a rcv message w/t a rcv queue" $ \store -> do
|
||||
it "should throw error on attempt to create a RcvMsg w/t a RcvQueue" $ \store -> do
|
||||
let ts = UTCTime (fromGregorian 2021 02 24) (secondsToDiffTime 0)
|
||||
createRcvMsg store "conn1" (encodeUtf8 "Hello world!") 1 ts "1" ts
|
||||
`throwsError` SEBadConn
|
||||
createSndConn store sndQueue1
|
||||
`returnsResult` ()
|
||||
createRcvMsg store "conn1" (encodeUtf8 "Hello world!") 1 ts "1" ts
|
||||
`throwsError` SEBadConnType CSend
|
||||
`throwsError` SEBadConnType CSnd
|
||||
|
||||
testCreateSndMsg :: SpecWith SQLiteStore
|
||||
testCreateSndMsg = do
|
||||
it "should create a snd message" $ \store -> do
|
||||
it "should create a SndMsg" $ \store -> do
|
||||
createSndConn store sndQueue1
|
||||
`returnsResult` ()
|
||||
-- TODO getMsg to check message
|
||||
@@ -320,10 +320,10 @@ testCreateSndMsg = do
|
||||
|
||||
testCreateSndMsgNoQueue :: SpecWith SQLiteStore
|
||||
testCreateSndMsgNoQueue = do
|
||||
it "should throw error on attempt to create a snd message w/t a snd queue" $ \store -> do
|
||||
it "should throw error on attempt to create a SndMsg w/t a SndQueue" $ \store -> do
|
||||
createSndMsg store "conn1" (encodeUtf8 "Hello world!")
|
||||
`throwsError` SEBadConn
|
||||
createRcvConn store rcvQueue1
|
||||
`returnsResult` ()
|
||||
createSndMsg store "conn1" (encodeUtf8 "Hello world!")
|
||||
`throwsError` SEBadConnType CReceive
|
||||
`throwsError` SEBadConnType CRcv
|
||||
|
||||
Reference in New Issue
Block a user