diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 95c74119c..306a3cb09 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -99,8 +99,8 @@ class Monad m => MonadAgentStore s m where createSndConn :: s -> ConnAlias -> SendQueue -> m (Either StoreError (Connection CSend)) getConn :: s -> ConnAlias -> m (Either StoreError SomeConn) deleteConn :: s -> ConnAlias -> m (Either StoreError ()) - addSndQueue :: s -> ConnAlias -> SendQueue -> m (Either StoreError (Connection CDuplex)) - addRcvQueue :: s -> ConnAlias -> SendQueue -> m (Either StoreError (Connection CDuplex)) + addSndQueue :: s -> ConnAlias -> SendQueue -> m (Either StoreError ()) + addRcvQueue :: s -> ConnAlias -> SendQueue -> 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 408a9a9dc..a301561c6 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -153,6 +154,7 @@ instance ToRow ReceiveQueue where instance FromRow ReceiveQueue where fromRow = ReceiveQueue undefined <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field +-- TODO refactor into a single query with join getRcvQueue :: MonadUnliftIO m => SQLiteStore -> QueueRowId -> m (Either StoreError ReceiveQueue) getRcvQueue st@SQLiteStore {conn} queueRowId = liftIO $ do r <- @@ -169,6 +171,7 @@ getRcvQueue st@SQLiteStore {conn} queueRowId = liftIO $ do (\srv -> (rcvQueue {server = srv} :: ReceiveQueue)) <$$> getServer st serverId _ -> return (Left SENotFound) +-- TODO refactor into a single query with join getSndQueue :: MonadUnliftIO m => SQLiteStore -> QueueRowId -> m (Either StoreError SendQueue) getSndQueue st@SQLiteStore {conn} queueRowId = liftIO $ do r <- @@ -278,6 +281,7 @@ instance MonadUnliftIO m => MonadAgentStore SQLiteStore m where insertSndConnection st connAlias qId return $ SendConnection connAlias sndQueue + -- TODO refactor ito a single query with join, and parse as `Only connAlias :. rcvQueue :. sndQueue` getConn :: SQLiteStore -> ConnAlias -> m (Either StoreError SomeConn) getConn st connAlias = getConnection st connAlias >>= \case @@ -295,26 +299,20 @@ instance MonadUnliftIO m => MonadAgentStore SQLiteStore m where Right (_, _) -> return $ Left SEBadConn -- TODO make transactional - addSndQueue :: SQLiteStore -> ConnAlias -> SendQueue -> m (Either StoreError (Connection CDuplex)) - addSndQueue st connAlias sndQueue = do - serverId <- upsertServer st (server (sndQueue :: SendQueue)) - case serverId of - Left e -> return $ Left e - Right servId -> do - conn <- getConnection st connAlias - case conn of - Left e -> return $ Left e - Right (Just _, Just _) -> return $ Left (SEBadConnType CDuplex) - Right (_, Just _) -> return $ Left (SEBadConnType CSend) - Right (Just _, _) -> do -- Add send queue only if connection is ReceiveConnection - qId <- insertSndQueue st servId sndQueue - _ <- updateRcvConnectionWithSndQueue st connAlias qId - updatedConn <- getConnection st connAlias - case updatedConn of - Left e -> return $ Left e - Right (Just rcvQId, Just sndQId) -> do - rcvQ <- getRcvQueue st rcvQId - sndQ <- getSndQueue st sndQId - return $ DuplexConnection connAlias <$> rcvQ <*> sndQ - Right (_, _) -> return $ Left SEBadConn - Right (_, _) -> return $ Left SEBadConn + addSndQueue :: SQLiteStore -> ConnAlias -> SendQueue -> m (Either StoreError ()) + addSndQueue st connAlias sndQueue = + getConn st connAlias + >>= either (return . Left) checkUpdateConn + where + checkUpdateConn :: SomeConn -> m (Either StoreError ()) + checkUpdateConn = \case + SomeConn SCDuplex _ -> return $ Left (SEBadConnType CDuplex) + SomeConn SCSend _ -> return $ Left (SEBadConnType CSend) + SomeConn SCReceive _ -> + upsertServer st (server (sndQueue :: SendQueue)) + >>= either (return . Left) (fmap Right . updateConn) + + updateConn :: SMPServerId -> m () + updateConn servId = + insertSndQueue st servId sndQueue + >>= updateRcvConnectionWithSndQueue st connAlias diff --git a/tests/AgentTests/SQLite.hs b/tests/AgentTests/SQLite.hs index f14e55d20..48a7b6acc 100644 --- a/tests/AgentTests/SQLite.hs +++ b/tests/AgentTests/SQLite.hs @@ -56,7 +56,7 @@ testCreateRcvConn = do ackMode = AckMode On } addSndQueue store "1" sndQueue - `shouldReturn` Right (DuplexConnection "1" rcvQueue sndQueue) + `shouldReturn` Right () getConn store "1" `shouldReturn` Right (SomeConn SCDuplex $ DuplexConnection "1" rcvQueue sndQueue) diff --git a/tests/Test.hs b/tests/Test.hs index 6404e5ca8..3b2e915c8 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -6,5 +6,5 @@ import Test.Hspec main :: IO () main = hspec do - -- describe "SMP server" serverTests + describe "SMP server" serverTests describe "SMP client agent" agentTests