diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 306a3cb09..bd7f52039 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -100,7 +100,7 @@ class Monad m => MonadAgentStore s m where getConn :: s -> ConnAlias -> m (Either StoreError SomeConn) deleteConn :: s -> ConnAlias -> m (Either StoreError ()) addSndQueue :: s -> ConnAlias -> SendQueue -> m (Either StoreError ()) - addRcvQueue :: s -> ConnAlias -> SendQueue -> m (Either StoreError ()) + addRcvQueue :: s -> ConnAlias -> ReceiveQueue -> m (Either StoreError ()) removeSndAuth :: s -> ConnAlias -> m (Either StoreError ()) updateQueueStatus :: s -> ConnAlias -> QueueDirection -> QueueStatus -> m (Either StoreError ()) createMsg :: s -> ConnAlias -> QueueDirection -> AMessage -> m (Either StoreError MessageDelivery) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index a301561c6..540303772 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -96,8 +96,8 @@ insertWithLock st tableLock queryStr q = do DB.execute c queryStr q DB.lastInsertRowId c -updateWithLock :: (MonadUnliftIO m, ToRow q) => SQLiteStore -> (SQLiteStore -> TMVar ()) -> DB.Query -> q -> m () -updateWithLock st tableLock queryStr q = do +executeWithLock :: (MonadUnliftIO m, ToRow q) => SQLiteStore -> (SQLiteStore -> TMVar ()) -> DB.Query -> q -> m () +executeWithLock st tableLock queryStr q = do withLock st tableLock $ \c -> liftIO $ do DB.execute c queryStr q @@ -210,7 +210,7 @@ insertRcvConnection store connAlias rcvQueueId = updateRcvConnectionWithSndQueue :: MonadUnliftIO m => SQLiteStore -> ConnAlias -> QueueRowId -> m () updateRcvConnectionWithSndQueue store connAlias sndQueueId = - updateWithLock + executeWithLock store connectionsLock [s| @@ -247,6 +247,18 @@ insertSndConnection store connAlias sndQueueId = "INSERT INTO connections (conn_alias, receive_queue_id, send_queue_id) VALUES (?,NULL,?);" (Only connAlias :. Only sndQueueId) +updateSndConnectionWithRcvQueue :: MonadUnliftIO m => SQLiteStore -> ConnAlias -> QueueRowId -> m () +updateSndConnectionWithRcvQueue store connAlias rcvQueueId = + executeWithLock + store + connectionsLock + [s| + UPDATE connections + SET receive_queue_id = ? + WHERE conn_alias = ?; + |] + (Only rcvQueueId :. Only connAlias) + getConnection :: MonadUnliftIO m => SQLiteStore -> ConnAlias -> m (Either StoreError (Maybe QueueRowId, Maybe QueueRowId)) getConnection SQLiteStore {conn} connAlias = liftIO $ do r <- @@ -316,3 +328,22 @@ instance MonadUnliftIO m => MonadAgentStore SQLiteStore m where updateConn servId = insertSndQueue st servId sndQueue >>= updateRcvConnectionWithSndQueue st connAlias + + -- TODO make transactional + addRcvQueue :: SQLiteStore -> ConnAlias -> ReceiveQueue -> m (Either StoreError ()) + addRcvQueue st connAlias rcvQueue = + getConn st connAlias + >>= either (return . Left) checkUpdateConn + where + checkUpdateConn :: SomeConn -> m (Either StoreError ()) + checkUpdateConn = \case + SomeConn SCDuplex _ -> return $ Left (SEBadConnType CDuplex) + SomeConn SCReceive _ -> return $ Left (SEBadConnType CReceive) + SomeConn SCSend _ -> + upsertServer st (server (rcvQueue :: ReceiveQueue)) + >>= either (return . Left) (fmap Right . updateConn) + + updateConn :: SMPServerId -> m () + updateConn servId = + insertRcvQueue st servId rcvQueue + >>= updateSndConnectionWithRcvQueue st connAlias diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs index 661242517..f17236e9f 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs @@ -19,7 +19,6 @@ servers = ) |] --- TODO unique constraints on (server_id, rcv_id) and (server_id, snd_id) receiveQueues :: Query receiveQueues = [s| @@ -50,7 +49,8 @@ sendQueues = encrypt_key BLOB NOT NULL, sign_key BLOB NOT NULL, status TEXT NOT NULL, - ack_mode INTEGER NOT NULL + ack_mode INTEGER NOT NULL, + UNIQUE (server_id, snd_id) ) |] diff --git a/tests/AgentTests/SQLite.hs b/tests/AgentTests/SQLite.hs index 48a7b6acc..a9d37132d 100644 --- a/tests/AgentTests/SQLite.hs +++ b/tests/AgentTests/SQLite.hs @@ -25,6 +25,7 @@ storeTests = withStore do describe "createRcvConn" testCreateRcvConn describe "createSndConn" testCreateSndConn describe "addSndQueue" testAddSndQueue + describe "addRcvQueue" testAddRcvQueue testCreateRcvConn :: SpecWith SQLiteStore testCreateRcvConn = do @@ -62,7 +63,7 @@ testCreateRcvConn = do testCreateSndConn :: SpecWith SQLiteStore testCreateSndConn = do - it "should create and get send connection" $ \store -> do + it "should create send connection and add receive queue" $ \store -> do let sndQueue = SendQueue { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"), @@ -77,6 +78,22 @@ testCreateSndConn = do `shouldReturn` Right (SendConnection "2" sndQueue) getConn store "2" `shouldReturn` Right (SomeConn SCSend $ SendConnection "2" sndQueue) + let rcvQueue = + ReceiveQueue + { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"), + rcvId = "2345", + rcvPrivateKey = "abcd", + sndId = Just "2345", + sndKey = Nothing, + decryptKey = "dcba", + verifyKey = Nothing, + status = New, + ackMode = AckMode On + } + addRcvQueue store "2" rcvQueue + `shouldReturn` Right () + getConn store "2" + `shouldReturn` Right (SomeConn SCDuplex $ DuplexConnection "2" rcvQueue sndQueue) testAddSndQueue :: SpecWith SQLiteStore testAddSndQueue = do @@ -104,3 +121,62 @@ testAddSndQueue = do } addSndQueue store "3" anotherSndQueue `shouldReturn` Left (SEBadConnType CSend) + let rcvQueue = + ReceiveQueue + { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"), + rcvId = "6789", + rcvPrivateKey = "abcd", + sndId = Just "6789", + sndKey = Nothing, + decryptKey = "dcba", + verifyKey = Nothing, + status = New, + ackMode = AckMode On + } + _ <- addRcvQueue store "3" rcvQueue + addSndQueue store "3" anotherSndQueue + `shouldReturn` Left (SEBadConnType CDuplex) + +testAddRcvQueue :: SpecWith SQLiteStore +testAddRcvQueue = do + it "should return error on attempts to add receive queue to ReceiveConnection or DuplexConnection" $ \store -> do + let rcvQueue = + ReceiveQueue + { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"), + rcvId = "3456", + rcvPrivateKey = "abcd", + sndId = Just "3456", + sndKey = Nothing, + decryptKey = "dcba", + verifyKey = Nothing, + status = New, + ackMode = AckMode On + } + _ <- createRcvConn store "4" rcvQueue + let anotherRcvQueue = + ReceiveQueue + { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"), + rcvId = "4567", + rcvPrivateKey = "abcd", + sndId = Just "4567", + sndKey = Nothing, + decryptKey = "dcba", + verifyKey = Nothing, + status = New, + ackMode = AckMode On + } + addRcvQueue store "4" anotherRcvQueue + `shouldReturn` Left (SEBadConnType CReceive) + let sndQueue = + SendQueue + { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"), + sndId = "3456", + sndPrivateKey = "abcd", + encryptKey = "dcba", + signKey = "edcb", + status = New, + ackMode = AckMode On + } + _ <- addSndQueue store "4" sndQueue + addRcvQueue store "4" anotherRcvQueue + `shouldReturn` Left (SEBadConnType CDuplex)