agent store: refactor addSndQueue

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)

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

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)
 

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