diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 1201e06ee..3b1ce4115 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -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 " - -- 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, diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 57e14dda0..37594e95c 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -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 " $ \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 (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 " $ \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 " $ \smp -> sendSMPMessage smp (Just sndPrivateKey) sndId msg diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index b1a42e0da..ff8144204 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 85d6efd10..573da9f78 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -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) diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index b01f6c598..f0ff453c1 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -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