diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 4e3609256..95c74119c 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -11,6 +11,7 @@ module Simplex.Messaging.Agent.Store where import Data.Int (Int64) import Data.Kind import Data.Time.Clock (UTCTime) +import Data.Type.Equality import Simplex.Messaging.Agent.Transmission import Simplex.Messaging.Server.Transmission (Encoded, PublicKey, QueueId) @@ -54,11 +55,26 @@ data SConnType :: ConnType -> Type where SCSend :: SConnType CSend SCDuplex :: SConnType CDuplex +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 SCDuplex SCDuplex = Just Refl + testEquality _ _ = Nothing + data SomeConn where SomeConn :: SConnType d -> Connection d -> SomeConn +instance Eq SomeConn where + SomeConn d c == SomeConn d' c' = case testEquality d d' of + Just Refl -> c == c' + _ -> False + +deriving instance Show SomeConn + data MessageDelivery = MessageDelivery { connAlias :: ConnAlias, agentMsgId :: Int, @@ -96,6 +112,7 @@ class Monad m => MonadAgentStore s m where data StoreError = SEInternal | SENotFound + | SEBadConn | SEBadConnType ConnType | SEBadQueueStatus deriving (Eq, Show) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 5ce9bdd71..12ebbe276 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -227,18 +227,16 @@ insertSndConnection store connAlias sndQueueId = "INSERT INTO connections (conn_alias, receive_queue_id, send_queue_id) VALUES (?,NULL,?);" (Only connAlias :. Only sndQueueId) --- instance FromRow SomeConn where --- fromRow = - --- selectConnection :: MonadUnliftIO m => SQLiteStore -> ConnAlias -> m (Either StoreError SomeConn) --- selectConnection SQLiteStore {conn} connAlias = liftIO $ do --- DB.query --- conn --- "SELECT * FROM connections WHERE conn_alias = ?" --- connAlias --- >>= \case --- [Only someConn] -> return (Right someConn) --- _ -> return (Left SEInternal) +getConnection :: MonadUnliftIO m => SQLiteStore -> ConnAlias -> m (Either StoreError (Maybe QueueRowId, Maybe QueueRowId)) +getConnection SQLiteStore {conn} connAlias = liftIO $ do + r <- + DB.queryNamed + conn + "SELECT receive_queue_id, send_queue_id FROM connections WHERE conn_alias = :conn_alias" + [":conn_alias" := connAlias] + return $ case r of + [queueIds] -> Right queueIds + _ -> Left SEInternal instance MonadUnliftIO m => MonadAgentStore SQLiteStore m where addServer store smpServer = upsertServer store smpServer @@ -262,3 +260,19 @@ instance MonadUnliftIO m => MonadAgentStore SQLiteStore m where qId <- insertSndQueue st serverId sndQueue -- TODO test for duplicate connAlias insertSndConnection st connAlias qId return $ SendConnection connAlias sndQueue + + getConn :: SQLiteStore -> ConnAlias -> m (Either StoreError SomeConn) + getConn st connAlias = + getConnection st connAlias >>= \case + Left e -> return $ Left e + Right (Just rcvQId, Just sndQId) -> do + rcvQ <- getRcvQueue st rcvQId + sndQ <- getSndQueue st sndQId + return $ SomeConn SCDuplex <$> (DuplexConnection connAlias <$> rcvQ <*> sndQ) + Right (Just rcvQId, _) -> + getRcvQueue st rcvQId + >>= return . fmap (SomeConn SCReceive . ReceiveConnection connAlias) + Right (_, Just sndQId) -> + getSndQueue st sndQId + >>= return . fmap (SomeConn SCSend . SendConnection connAlias) + Right (_, _) -> return $ Left SEBadConn diff --git a/tests/AgentTests/SQLite.hs b/tests/AgentTests/SQLite.hs index 06607662b..bcde13419 100644 --- a/tests/AgentTests/SQLite.hs +++ b/tests/AgentTests/SQLite.hs @@ -27,7 +27,7 @@ storeTests = withStore do testCreateRcvConn :: SpecWith SQLiteStore testCreateRcvConn = do - it "should create receiver connection and return receiver connection data type" $ \store -> do + it "should create and get receive connection" $ \store -> do let rcvQueue = ReceiveQueue { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"), @@ -42,10 +42,12 @@ testCreateRcvConn = do } createRcvConn store "1" rcvQueue `shouldReturn` Right (ReceiveConnection "1" rcvQueue) + getConn store "1" + `shouldReturn` Right (SomeConn SCReceive $ ReceiveConnection "1" rcvQueue) testCreateSndConn :: SpecWith SQLiteStore testCreateSndConn = do - it "should create sender connection and return sender connection data type" $ \store -> do + it "should create and get send connection" $ \store -> do let sndQueue = SendQueue { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"), @@ -58,3 +60,5 @@ testCreateSndConn = do } createSndConn store "2" sndQueue `shouldReturn` Right (SendConnection "2" sndQueue) + getConn store "2" + `shouldReturn` Right (SomeConn SCSend $ SendConnection "2" sndQueue)