mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-08-28 20:08:16 +00:00
ACK command, ackMessage, do not send ACK to SMP server on MSG (after the initial handshake) (#187)
This commit is contained in:
Evgeny Poberezkin
@@ -46,6 +46,7 @@ module Simplex.Messaging.Agent
|
||||
acceptConnection,
|
||||
subscribeConnection,
|
||||
sendMessage,
|
||||
ackMessage,
|
||||
suspendConnection,
|
||||
deleteConnection,
|
||||
)
|
||||
@@ -146,6 +147,9 @@ subscribeConnection c = withAgentEnv c . subscribeConnection' c
|
||||
sendMessage :: AgentErrorMonad m => AgentClient -> ConnId -> MsgBody -> m AgentMsgId
|
||||
sendMessage c = withAgentEnv c .: sendMessage' c
|
||||
|
||||
ackMessage :: AgentErrorMonad m => AgentClient -> ConnId -> AgentMsgId -> m ()
|
||||
ackMessage c = withAgentEnv c .: ackMessage' c
|
||||
|
||||
-- | Suspend SMP agent connection (OFF command)
|
||||
suspendConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
|
||||
suspendConnection c = withAgentEnv c . suspendConnection' c
|
||||
@@ -236,6 +240,7 @@ processCommand c (connId, cmd) = case cmd of
|
||||
ACPT confId ownConnInfo -> acceptConnection' c connId confId ownConnInfo $> (connId, OK)
|
||||
SUB -> subscribeConnection' c connId $> (connId, OK)
|
||||
SEND msgBody -> (connId,) . MID <$> sendMessage' c connId msgBody
|
||||
ACK msgId -> ackMessage' c connId msgId $> (connId, OK)
|
||||
OFF -> suspendConnection' c connId $> (connId, OK)
|
||||
DEL -> deleteConnection' c connId $> (connId, OK)
|
||||
|
||||
@@ -426,6 +431,20 @@ runSrvMsgDelivery c@AgentClient {subQ} srv = do
|
||||
notify :: ConnId -> ACommand 'Agent -> m ()
|
||||
notify connId cmd = atomically $ writeTBQueue subQ ("", connId, cmd)
|
||||
|
||||
ackMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> AgentMsgId -> m ()
|
||||
ackMessage' c connId msgId = do
|
||||
withStore (`getConn` connId) >>= \case
|
||||
SomeConn _ (DuplexConnection _ rq _) -> ack rq
|
||||
SomeConn _ (RcvConnection _ rq) -> ack rq
|
||||
_ -> throwError $ CONN SIMPLEX
|
||||
where
|
||||
ack :: RcvQueue -> m ()
|
||||
ack rq = do
|
||||
let mId = InternalId msgId
|
||||
withStore $ \st -> checkRcvMsg st connId mId
|
||||
sendAck c rq
|
||||
withStore $ \st -> updateRcvMsgAck st connId mId
|
||||
|
||||
-- | Suspend SMP agent connection (OFF command) in Reader monad
|
||||
suspendConnection' :: AgentMonad m => AgentClient -> ConnId -> m ()
|
||||
suspendConnection' c connId =
|
||||
@@ -491,14 +510,12 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
|
||||
let msgHash = C.sha256Hash msg
|
||||
case parseSMPMessage msg of
|
||||
Left e -> notify $ ERR e
|
||||
Right (SMPConfirmation senderKey cInfo) -> smpConfirmation senderKey cInfo
|
||||
Right (SMPConfirmation senderKey cInfo) -> smpConfirmation senderKey cInfo >> sendAck c rq
|
||||
Right SMPMessage {agentMessage, senderMsgId, senderTimestamp, previousMsgHash} ->
|
||||
case agentMessage of
|
||||
HELLO verifyKey _ -> helloMsg verifyKey msgBody
|
||||
REPLY qInfo -> replyMsg qInfo
|
||||
HELLO verifyKey _ -> helloMsg verifyKey msgBody >> sendAck c rq
|
||||
REPLY qInfo -> replyMsg qInfo >> sendAck c rq
|
||||
A_MSG body -> agentClientMsg previousMsgHash (senderMsgId, senderTimestamp) (srvMsgId, srvTs) body msgHash
|
||||
sendAck c rq
|
||||
return ()
|
||||
SMP.END -> do
|
||||
removeSubscription c connId
|
||||
logServer "<--" c srv rId "END"
|
||||
|
||||
@@ -172,7 +172,7 @@ data ACommand (p :: AParty) where
|
||||
SENT :: AgentMsgId -> ACommand Agent
|
||||
MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent
|
||||
MSG :: MsgMeta -> MsgBody -> ACommand Agent
|
||||
-- ACK :: AgentMsgId -> ACommand Client
|
||||
ACK :: AgentMsgId -> ACommand Client
|
||||
-- RCVD :: AgentMsgId -> ACommand Agent
|
||||
OFF :: ACommand Client
|
||||
DEL :: ACommand Client
|
||||
@@ -469,6 +469,7 @@ commandP =
|
||||
<|> "SENT " *> sentResp
|
||||
<|> "MERR " *> msgErrResp
|
||||
<|> "MSG " *> message
|
||||
<|> "ACK " *> ackCmd
|
||||
<|> "OFF" $> ACmd SClient OFF
|
||||
<|> "DEL" $> ACmd SClient DEL
|
||||
<|> "ERR " *> agentError
|
||||
@@ -485,6 +486,7 @@ commandP =
|
||||
sentResp = ACmd SAgent . SENT <$> A.decimal
|
||||
msgErrResp = ACmd SAgent <$> (MERR <$> A.decimal <* A.space <*> agentErrorTypeP)
|
||||
message = ACmd SAgent <$> (MSG <$> msgMetaP <* A.space <*> A.takeByteString)
|
||||
ackCmd = ACmd SClient . ACK <$> A.decimal
|
||||
msgMetaP = do
|
||||
integrity <- msgIntegrityP
|
||||
recipient <- " R=" *> partyMeta A.decimal
|
||||
@@ -526,6 +528,7 @@ serializeCommand = \case
|
||||
MERR mId e -> "MERR " <> bshow mId <> " " <> serializeAgentError e
|
||||
MSG msgMeta msgBody ->
|
||||
"MSG " <> serializeMsgMeta msgMeta <> " " <> serializeBinary msgBody
|
||||
ACK mId -> "ACK " <> bshow mId
|
||||
OFF -> "OFF"
|
||||
DEL -> "DEL"
|
||||
CON -> "CON"
|
||||
|
||||
@@ -60,6 +60,8 @@ class Monad m => MonadAgentStore s m where
|
||||
getPendingMsgData :: s -> ConnId -> InternalId -> m (SndQueue, MsgBody)
|
||||
getPendingMsgs :: s -> ConnId -> m [PendingMsg]
|
||||
getMsg :: s -> ConnId -> InternalId -> m Msg
|
||||
checkRcvMsg :: s -> ConnId -> InternalId -> m ()
|
||||
updateRcvMsgAck :: s -> ConnId -> InternalId -> m ()
|
||||
|
||||
-- * Queue types
|
||||
|
||||
|
||||
@@ -437,7 +437,35 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
|
||||
<$> DB.query db "SELECT internal_id FROM snd_messages WHERE conn_alias = ? AND snd_status = ?" (connId, SndMsgCreated)
|
||||
|
||||
getMsg :: SQLiteStore -> ConnId -> InternalId -> m Msg
|
||||
getMsg _st _connAlias _id = throwError SENotImplemented
|
||||
getMsg _st _connId _id = throwError SENotImplemented
|
||||
|
||||
checkRcvMsg :: SQLiteStore -> ConnId -> InternalId -> m ()
|
||||
checkRcvMsg st connId msgId =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
hasMsg
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_alias, internal_id
|
||||
FROM rcv_messages
|
||||
WHERE conn_alias = ? AND internal_id = ?
|
||||
|]
|
||||
(connId, msgId)
|
||||
where
|
||||
hasMsg :: [(ConnId, InternalId)] -> Either StoreError ()
|
||||
hasMsg r = if null r then Left SEMsgNotFound else Right ()
|
||||
|
||||
updateRcvMsgAck :: SQLiteStore -> ConnId -> InternalId -> m ()
|
||||
updateRcvMsgAck st connId msgId =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE rcv_messages
|
||||
SET rcv_status = ?, ack_brocker_ts = datetime('now')
|
||||
WHERE conn_alias = ? AND internal_id = ?
|
||||
|]
|
||||
(AcknowledgedToBroker, connId, msgId)
|
||||
|
||||
-- * Auxiliary helpers
|
||||
|
||||
|
||||
@@ -111,13 +111,17 @@ testDuplexConnection _ alice bob = do
|
||||
alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", MID 2)
|
||||
alice <# ("", "bob", SENT 2)
|
||||
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
|
||||
bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)
|
||||
bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False
|
||||
bob #: ("13", "alice", "ACK 2") #> ("13", "alice", OK)
|
||||
bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 3)
|
||||
bob <# ("", "alice", SENT 3)
|
||||
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
|
||||
alice #: ("3a", "bob", "ACK 3") #> ("3a", "bob", OK)
|
||||
bob #: ("15", "alice", "SEND 9\nmessage 1") #> ("15", "alice", MID 4)
|
||||
bob <# ("", "alice", SENT 4)
|
||||
alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> False
|
||||
alice #: ("4a", "bob", "ACK 4") #> ("4a", "bob", OK)
|
||||
alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
|
||||
bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", MID 5)
|
||||
bob <# ("", "alice", MERR 5 (SMP AUTH))
|
||||
@@ -140,13 +144,17 @@ testDuplexConnRandomIds _ alice bob = do
|
||||
alice #: ("3", bobConn, "SEND :how are you?") #> ("3", bobConn, MID 2)
|
||||
alice <# ("", bobConn, SENT 2)
|
||||
bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False
|
||||
bob #: ("12", aliceConn, "ACK 1") #> ("12", aliceConn, OK)
|
||||
bob <#= \case ("", c, Msg "how are you?") -> c == aliceConn; _ -> False
|
||||
bob #: ("13", aliceConn, "ACK 2") #> ("13", aliceConn, OK)
|
||||
bob #: ("14", aliceConn, "SEND 9\nhello too") #> ("14", aliceConn, MID 3)
|
||||
bob <# ("", aliceConn, SENT 3)
|
||||
alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False
|
||||
alice #: ("3a", bobConn, "ACK 3") #> ("3a", bobConn, OK)
|
||||
bob #: ("15", aliceConn, "SEND 9\nmessage 1") #> ("15", aliceConn, MID 4)
|
||||
bob <# ("", aliceConn, SENT 4)
|
||||
alice <#= \case ("", c, Msg "message 1") -> c == bobConn; _ -> False
|
||||
alice #: ("4a", bobConn, "ACK 4") #> ("4a", bobConn, OK)
|
||||
alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)
|
||||
bob #: ("17", aliceConn, "SEND 9\nmessage 3") #> ("17", aliceConn, MID 5)
|
||||
bob <# ("", aliceConn, MERR 5 (SMP AUTH))
|
||||
@@ -161,12 +169,15 @@ testSubscription _ alice1 alice2 bob = do
|
||||
bob #: ("13", "alice", "SEND 11\nhello again") #> ("13", "alice", MID 2)
|
||||
bob <# ("", "alice", SENT 2)
|
||||
alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
|
||||
alice1 #: ("1", "bob", "ACK 1") #> ("1", "bob", OK)
|
||||
alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
|
||||
alice1 #: ("2", "bob", "ACK 2") #> ("2", "bob", OK)
|
||||
alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK)
|
||||
alice1 <# ("", "bob", END)
|
||||
bob #: ("14", "alice", "SEND 2\nhi") #> ("14", "alice", MID 3)
|
||||
bob <# ("", "alice", SENT 3)
|
||||
alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False
|
||||
alice2 #: ("22", "bob", "ACK 3") #> ("22", "bob", OK)
|
||||
alice1 #:# "nothing else should be delivered to alice1"
|
||||
|
||||
testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
|
||||
@@ -185,6 +196,7 @@ testMsgDeliveryServerRestart t alice bob = do
|
||||
bob #: ("1", "alice", "SEND 2\nhi") #> ("1", "alice", MID 1)
|
||||
bob <# ("", "alice", SENT 1)
|
||||
alice <#= \case ("", "bob", Msg "hi") -> True; _ -> False
|
||||
alice #: ("11", "bob", "ACK 1") #> ("11", "bob", OK)
|
||||
alice #:# "nothing else delivered before the server is killed"
|
||||
|
||||
alice <# ("", "bob", DOWN)
|
||||
@@ -196,6 +208,7 @@ testMsgDeliveryServerRestart t alice bob = do
|
||||
bob <# ("", "alice", SENT 2)
|
||||
alice <# ("", "bob", UP)
|
||||
alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
|
||||
alice #: ("12", "bob", "ACK 2") #> ("12", "bob", OK)
|
||||
|
||||
removeFile testStoreLogFile
|
||||
where
|
||||
@@ -209,6 +222,7 @@ testMsgDeliveryAgentRestart t bob = do
|
||||
alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 1)
|
||||
alice <# ("", "bob", SENT 1)
|
||||
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
|
||||
bob #: ("11", "alice", "ACK 1") #> ("11", "alice", OK)
|
||||
bob #:# "nothing else delivered before the server is down"
|
||||
|
||||
bob <# ("", "alice", DOWN)
|
||||
@@ -226,6 +240,7 @@ testMsgDeliveryAgentRestart t bob = do
|
||||
_ -> False
|
||||
bob <# ("", "alice", UP)
|
||||
bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
|
||||
bob #: ("12", "alice", "ACK 2") #> ("12", "alice", OK)
|
||||
|
||||
removeFile testStoreLogFile
|
||||
removeFile testDB
|
||||
|
||||
@@ -65,13 +65,17 @@ testAgentClient = do
|
||||
2 <- sendMessage alice bobId "how are you?"
|
||||
get alice ##> ("", bobId, SENT 2)
|
||||
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
||||
ackMessage bob aliceId 1
|
||||
get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
|
||||
ackMessage bob aliceId 2
|
||||
3 <- sendMessage bob aliceId "hello too"
|
||||
get bob ##> ("", aliceId, SENT 3)
|
||||
4 <- sendMessage bob aliceId "message 1"
|
||||
get bob ##> ("", aliceId, SENT 4)
|
||||
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
||||
ackMessage alice bobId 3
|
||||
get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
|
||||
ackMessage alice bobId 4
|
||||
suspendConnection alice bobId
|
||||
5 <- sendMessage bob aliceId "message 2"
|
||||
get bob ##> ("", aliceId, MERR 5 (SMP AUTH))
|
||||
@@ -152,6 +156,8 @@ exchangeGreetings alice bobId bob aliceId = do
|
||||
1 <- sendMessage alice bobId "hello"
|
||||
get alice ##> ("", bobId, SENT 1)
|
||||
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
||||
ackMessage bob aliceId 1
|
||||
2 <- sendMessage bob aliceId "hello too"
|
||||
get bob ##> ("", aliceId, SENT 2)
|
||||
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
||||
ackMessage alice bobId 2
|
||||
|
||||
Reference in New Issue
Block a user