core: message statuses for sending proxies (#4161)

* core: delivery path

* update simplexmq

* via proxy snd flags

* error statuses

* rework errors

* proxy expired errors

* corrections

* move backwards compatibile parser to new type

* update simplexmq

* names

* refactor, style

* simplexmq

* refactor

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
This commit is contained in:
spaced4ndy
2024-05-15 15:30:05 +04:00
committed by GitHub
parent 3129602a78
commit 4c0d47bbd4
10 changed files with 191 additions and 57 deletions

View File

@@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package
type: git
location: https://github.com/simplex-chat/simplexmq.git
tag: f51cf1deacd14aced88652ccfa06a746999e2ac6
tag: 2d2cc86bd82a5c604901ae813a6cbcc21f3e2024
source-repository-package
type: git

View File

@@ -1,5 +1,5 @@
{
"https://github.com/simplex-chat/simplexmq.git"."f51cf1deacd14aced88652ccfa06a746999e2ac6" = "1q1lcjbapq0mrz0z99shajn364jf7j2j6gm5qir2h230l5fg6mih";
"https://github.com/simplex-chat/simplexmq.git"."2d2cc86bd82a5c604901ae813a6cbcc21f3e2024" = "0gny4qywp2hda9fqs5gm3zkr8vd4jriy3iqp7ap7bwc12is6n8zw";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";

View File

@@ -143,6 +143,7 @@ library
Simplex.Chat.Migrations.M20240402_item_forwarded
Simplex.Chat.Migrations.M20240430_ui_theme
Simplex.Chat.Migrations.M20240501_chat_deleted
Simplex.Chat.Migrations.M20240510_chat_items_via_proxy
Simplex.Chat.Mobile
Simplex.Chat.Mobile.File
Simplex.Chat.Mobile.Shared

View File

@@ -100,7 +100,7 @@ import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), Migrati
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import Simplex.Messaging.Client (defaultNetworkConfig)
import Simplex.Messaging.Client (ProxyClientError (..), defaultNetworkConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
@@ -113,6 +113,7 @@ import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (TransportError (..))
import Simplex.Messaging.Transport.Client (defaultSocksProxy)
import Simplex.Messaging.Util
import Simplex.Messaging.Version
@@ -699,10 +700,7 @@ processChatCommand' vr = \case
(,) <$> getAChatItem db vr user chatRef itemId <*> liftIO (getChatItemVersions db itemId)
let itemVersions = if null versions then maybeToList $ mkItemVersion ci else versions
memberDeliveryStatuses <- case (cType, dir) of
(SCTGroup, SMDSnd) -> do
withStore' (`getGroupSndStatuses` itemId) >>= \case
[] -> pure Nothing
memStatuses -> pure $ Just $ map (uncurry MemberDeliveryStatus) memStatuses
(SCTGroup, SMDSnd) -> L.nonEmpty <$> withStore' (`getGroupSndStatuses` itemId)
_ -> pure Nothing
forwardedFromChatItem <- getForwardedFromItem user ci
pure $ CRChatItemInfo user aci ChatItemInfo {itemVersions, memberDeliveryStatuses, forwardedFromChatItem}
@@ -3896,7 +3894,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
withAckMessage' agentConnId meta $
void $
saveDirectRcvMSG conn meta msgBody
SENT msgId ->
SENT msgId _proxy ->
sentMsgDeliveryEvent conn msgId
OK ->
-- [async agent commands] continuation on receiving OK
@@ -4029,10 +4027,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
notifyMemberConnected gInfo m $ Just ct
let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo
when (memberCategory m == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True
SENT msgId -> do
SENT msgId proxy -> do
sentMsgDeliveryEvent conn msgId
checkSndInlineFTComplete conn msgId
updateDirectItemStatus ct conn msgId $ CISSndSent SSPComplete
ci_ <- withStore $ \db -> do
ci_ <- updateDirectItemStatus' db ct conn msgId (CISSndSent SSPComplete)
forM ci_ $ \ci -> liftIO $ setDirectSndChatItemViaProxy db user ct ci (isJust proxy)
forM_ ci_ $ \ci -> toView $ CRChatItemStatusUpdated user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
SWITCH qd phase cStats -> do
toView $ CRContactSwitch user ct (SwitchProgress qd phase cStats)
when (phase `elem` [SPStarted, SPCompleted]) $ case qd of
@@ -4067,13 +4068,15 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
OK ->
-- [async agent commands] continuation on receiving OK
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
MWARN msgId err ->
updateDirectItemStatus ct conn msgId (CISSndWarning $ agentSndError err)
MERR msgId err -> do
updateDirectItemStatus ct conn msgId $ agentErrToItemStatus err
updateDirectItemStatus ct conn msgId (CISSndError $ agentSndError err)
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
incAuthErrCounter connEntity conn err
MERRS msgIds err -> do
-- error cannot be AUTH error here
updateDirectItemsStatus ct conn (L.toList msgIds) $ agentErrToItemStatus err
updateDirectItemsStatus ct conn (L.toList msgIds) (CISSndError $ agentSndError err)
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
ERR err -> do
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
@@ -4411,10 +4414,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
RCVD msgMeta msgRcpt ->
withAckMessage' agentConnId msgMeta $
groupMsgReceived gInfo m conn msgMeta msgRcpt
SENT msgId -> do
SENT msgId proxy -> do
sentMsgDeliveryEvent conn msgId
checkSndInlineFTComplete conn msgId
updateGroupItemStatus gInfo m conn msgId $ CISSndSent SSPComplete
updateGroupItemStatus gInfo m conn msgId (CISSndSent SSPComplete) (Just $ isJust proxy)
SWITCH qd phase cStats -> do
toView $ CRGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats)
when (phase `elem` [SPStarted, SPCompleted]) $ case qd of
@@ -4450,13 +4453,15 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
OK ->
-- [async agent commands] continuation on receiving OK
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
MWARN msgId err ->
withStore' $ \db -> updateGroupItemErrorStatus db msgId (groupMemberId' m) (CISSndWarning $ agentSndError err)
MERR msgId err -> do
withStore' $ \db -> updateGroupItemErrorStatus db msgId (groupMemberId' m) $ agentErrToItemStatus err
withStore' $ \db -> updateGroupItemErrorStatus db msgId (groupMemberId' m) (CISSndError $ agentSndError err)
-- group errors are silenced to reduce load on UI event log
-- toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
incAuthErrCounter connEntity conn err
MERRS msgIds err -> do
let newStatus = agentErrToItemStatus err
let newStatus = CISSndError $ agentSndError err
-- error cannot be AUTH error here
withStore' $ \db -> forM_ msgIds $ \msgId ->
updateGroupItemErrorStatus db msgId (groupMemberId' m) newStatus `catchAll_` pure ()
@@ -4517,7 +4522,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
toView $ CRSndFileStart user ci ft
sendFileChunk user ft
SENT msgId -> do
SENT msgId _proxy -> do
withStore' $ \db -> updateSndFileChunkSent db ft msgId
unless (fileStatus == FSCancelled) $ sendFileChunk user ft
MERR _ err -> do
@@ -4729,9 +4734,21 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
sentMsgDeliveryEvent Connection {connId} msgId =
withStore' $ \db -> updateSndMsgDeliveryStatus db connId msgId MDSSndSent
agentErrToItemStatus :: AgentErrorType -> CIStatus 'MDSnd
agentErrToItemStatus (SMP _ AUTH) = CISSndErrorAuth
agentErrToItemStatus err = CISSndError . T.unpack . safeDecodeUtf8 $ strEncode err
agentSndError :: AgentErrorType -> SndError
agentSndError = \case
SMP _ AUTH -> SndErrAuth
SMP _ QUOTA -> SndErrQuota
BROKER _ e -> brokerError SndErrRelay e
SMP proxySrv (SMP.PROXY (SMP.BROKER e)) -> brokerError (SndErrProxy proxySrv) e
AP.PROXY proxySrv _ (ProxyProtocolError (SMP.PROXY (SMP.BROKER e))) -> brokerError (SndErrProxyRelay proxySrv) e
e -> SndErrOther . safeDecodeUtf8 $ strEncode e
where
brokerError srvErr = \case
NETWORK -> SndErrExpired
TIMEOUT -> SndErrExpired
HOST -> srvErr SrvErrHost
SMP.TRANSPORT TEVersion -> srvErr SrvErrVersion
e -> srvErr . SrvErrOther . safeDecodeUtf8 $ strEncode e
badRcvFileChunk :: RcvFileTransfer -> String -> CM ()
badRcvFileChunk ft err =
@@ -6060,7 +6077,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure ()
forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do
withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus
updateGroupItemStatus gInfo m conn agentMsgId $ CISSndRcvd msgRcptStatus SSPComplete
updateGroupItemStatus gInfo m conn agentMsgId (CISSndRcvd msgRcptStatus SSPComplete) Nothing
updateDirectItemsStatus :: Contact -> Connection -> [AgentMsgId] -> CIStatus 'MDSnd -> CM ()
updateDirectItemsStatus ct conn msgIds newStatus = do
@@ -6097,11 +6114,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
| otherwise -> updateGroupSndStatus db itemId groupMemberId newStatus $> True
_ -> pure False
updateGroupItemStatus :: GroupInfo -> GroupMember -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> CM ()
updateGroupItemStatus gInfo@GroupInfo {groupId} GroupMember {groupMemberId} Connection {connId} msgId newMemStatus =
updateGroupItemStatus :: GroupInfo -> GroupMember -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> Maybe Bool -> CM ()
updateGroupItemStatus gInfo@GroupInfo {groupId} GroupMember {groupMemberId} Connection {connId} msgId newMemStatus viaProxy_ =
withStore' (\db -> getGroupChatItemByAgentMsgId db user groupId connId msgId) >>= \case
Just (CChatItem SMDSnd ChatItem {meta = CIMeta {itemStatus = CISSndRcvd _ SSPComplete}}) -> pure ()
Just (CChatItem SMDSnd ChatItem {meta = CIMeta {itemId, itemStatus}}) -> do
forM_ viaProxy_ $ \viaProxy -> withStore' $ \db -> setGroupSndViaProxy db itemId groupMemberId viaProxy
memStatusChanged <- updateGroupMemSndStatus itemId groupMemberId newMemStatus
when memStatusChanged $ do
memStatusCounts <- withStore' (`getGroupSndStatusCounts` itemId)
@@ -6724,7 +6742,7 @@ mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ChatItemId
mkChatItem cd ciId content file quotedItem sharedMsgId itemForwarded itemTimed live itemTs forwardedByMember currentTs =
let itemText = ciContentToText content
itemStatus = ciCreateStatus content
meta = mkCIMeta ciId content itemText itemStatus sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) currentTs itemTs forwardedByMember currentTs currentTs
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) currentTs itemTs forwardedByMember currentTs currentTs
in ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file}
deleteDirectCI :: MsgDirectionI d => User -> Contact -> ChatItem 'CTDirect d -> Bool -> Bool -> CM ChatResponse

View File

@@ -29,6 +29,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isSpace)
import Data.Int (Int64)
import Data.Kind (Constraint)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
@@ -345,6 +346,7 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
itemTs :: ChatItemTs,
itemText :: Text,
itemStatus :: CIStatus d,
sentViaProxy :: Maybe Bool,
itemSharedMsgId :: Maybe SharedMsgId,
itemForwarded :: Maybe CIForwardedFrom,
itemDeleted :: Maybe (CIDeleted c),
@@ -359,8 +361,8 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
}
deriving (Show)
mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d
mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt =
mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d
mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt =
let deletable = case itemContent of
CISndMsgContent _ ->
case chatTypeI @c of
@@ -368,7 +370,7 @@ mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemForwarded it
_ -> diffUTCTime currentTs itemTs < nominalDay && isNothing itemDeleted
_ -> False
editable = deletable && isNothing itemForwarded
in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, deletable, editable, forwardedByMember, createdAt, updatedAt}
in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, deletable, editable, forwardedByMember, createdAt, updatedAt}
dummyMeta :: ChatItemId -> UTCTime -> Text -> CIMeta c 'MDSnd
dummyMeta itemId ts itemText =
@@ -377,6 +379,7 @@ dummyMeta itemId ts itemText =
itemTs = ts,
itemText,
itemStatus = CISSndNew,
sentViaProxy = Nothing,
itemSharedMsgId = Nothing,
itemForwarded = Nothing,
itemDeleted = Nothing,
@@ -683,8 +686,9 @@ data CIStatus (d :: MsgDirection) where
CISSndNew :: CIStatus 'MDSnd
CISSndSent :: SndCIStatusProgress -> CIStatus 'MDSnd
CISSndRcvd :: MsgReceiptStatus -> SndCIStatusProgress -> CIStatus 'MDSnd
CISSndErrorAuth :: CIStatus 'MDSnd
CISSndError :: String -> CIStatus 'MDSnd
CISSndErrorAuth :: CIStatus 'MDSnd -- deprecated
CISSndError :: SndError -> CIStatus 'MDSnd
CISSndWarning :: SndError -> CIStatus 'MDSnd
CISRcvNew :: CIStatus 'MDRcv
CISRcvRead :: CIStatus 'MDRcv
CISInvalid :: Text -> CIStatus 'MDSnd
@@ -703,7 +707,8 @@ instance MsgDirectionI d => StrEncoding (CIStatus d) where
CISSndSent sndProgress -> "snd_sent " <> strEncode sndProgress
CISSndRcvd msgRcptStatus sndProgress -> "snd_rcvd " <> strEncode msgRcptStatus <> " " <> strEncode sndProgress
CISSndErrorAuth -> "snd_error_auth"
CISSndError e -> "snd_error " <> encodeUtf8 (T.pack e)
CISSndError sndErr -> "snd_error " <> strEncode sndErr
CISSndWarning sndErr -> "snd_warning " <> strEncode sndErr
CISRcvNew -> "rcv_new"
CISRcvRead -> "rcv_read"
CISInvalid {} -> "invalid"
@@ -721,17 +726,68 @@ instance StrEncoding ACIStatus where
"snd_sent" -> ACIStatus SMDSnd . CISSndSent <$> ((A.space *> strP) <|> pure SSPComplete)
"snd_rcvd" -> ACIStatus SMDSnd <$> (CISSndRcvd <$> (A.space *> strP) <*> ((A.space *> strP) <|> pure SSPComplete))
"snd_error_auth" -> pure $ ACIStatus SMDSnd CISSndErrorAuth
"snd_error" -> ACIStatus SMDSnd . CISSndError . T.unpack . safeDecodeUtf8 <$> (A.space *> A.takeByteString)
"snd_error" -> ACIStatus SMDSnd . CISSndError <$> (A.space *> strP)
"snd_warning" -> ACIStatus SMDSnd . CISSndWarning <$> (A.space *> strP)
"rcv_new" -> pure $ ACIStatus SMDRcv CISRcvNew
"rcv_read" -> pure $ ACIStatus SMDRcv CISRcvRead
_ -> fail "bad status"
-- see serverHostError in agent
data SndError
= SndErrAuth
| SndErrQuota
| SndErrExpired -- TIMEOUT/NETWORK errors
| SndErrRelay {srvError :: SrvError} -- BROKER errors (other than TIMEOUT/NETWORK)
| SndErrProxy {proxyServer :: String, srvError :: SrvError} -- SMP PROXY errors
| SndErrProxyRelay {proxyServer :: String, srvError :: SrvError} -- PROXY BROKER errors
| SndErrOther {sndError :: Text} -- other errors
deriving (Eq, Show)
data SrvError
= SrvErrHost
| SrvErrVersion
| SrvErrOther {srvError :: Text}
deriving (Eq, Show)
instance StrEncoding SndError where
strEncode = \case
SndErrAuth -> "auth"
SndErrQuota -> "quota"
SndErrExpired -> "expired"
SndErrRelay srvErr -> "relay " <> strEncode srvErr
SndErrProxy proxy srvErr -> "proxy " <> encodeUtf8 (T.pack proxy) <> " " <> strEncode srvErr
SndErrProxyRelay proxy srvErr -> "proxy_relay " <> encodeUtf8 (T.pack proxy) <> " " <> strEncode srvErr
SndErrOther e -> "other " <> encodeUtf8 e
strP =
A.takeWhile1 (/= ' ') >>= \case
"auth" -> pure SndErrAuth
"quota" -> pure SndErrQuota
"expired" -> pure SndErrExpired
"relay" -> SndErrRelay <$> (A.space *> strP)
"proxy" -> SndErrProxy . T.unpack . safeDecodeUtf8 <$> (A.space *> A.takeWhile1 (/= ' ') <* A.space) <*> strP
"proxy_relay" -> SndErrProxyRelay . T.unpack . safeDecodeUtf8 <$> (A.space *> A.takeWhile1 (/= ' ') <* A.space) <*> strP
"other" -> SndErrOther . safeDecodeUtf8 <$> (A.space *> A.takeByteString)
s -> SndErrOther . safeDecodeUtf8 . (s <>) <$> A.takeByteString -- for backward compatibility with `CISSndError String`
instance StrEncoding SrvError where
strEncode = \case
SrvErrHost -> "host"
SrvErrVersion -> "version"
SrvErrOther e -> "other " <> encodeUtf8 e
strP =
A.takeWhile1 (/= ' ') >>= \case
"host" -> pure SrvErrHost
"version" -> pure SrvErrVersion
"other" -> SrvErrOther . safeDecodeUtf8 <$> (A.space *> A.takeByteString)
_ -> fail "bad SrvError"
data JSONCIStatus
= JCISSndNew
| JCISSndSent {sndProgress :: SndCIStatusProgress}
| JCISSndRcvd {msgRcptStatus :: MsgReceiptStatus, sndProgress :: SndCIStatusProgress}
| JCISSndErrorAuth
| JCISSndError {agentError :: String}
| JCISSndErrorAuth -- deprecated
| JCISSndError {agentError :: SndError}
| JCISSndWarning {agentError :: SndError}
| JCISRcvNew
| JCISRcvRead
| JCISInvalid {text :: Text}
@@ -743,7 +799,8 @@ jsonCIStatus = \case
CISSndSent sndProgress -> JCISSndSent sndProgress
CISSndRcvd msgRcptStatus sndProgress -> JCISSndRcvd msgRcptStatus sndProgress
CISSndErrorAuth -> JCISSndErrorAuth
CISSndError e -> JCISSndError e
CISSndError sndErr -> JCISSndError sndErr
CISSndWarning sndErr -> JCISSndWarning sndErr
CISRcvNew -> JCISRcvNew
CISRcvRead -> JCISRcvRead
CISInvalid text -> JCISInvalid text
@@ -754,7 +811,8 @@ jsonACIStatus = \case
JCISSndSent sndProgress -> ACIStatus SMDSnd $ CISSndSent sndProgress
JCISSndRcvd msgRcptStatus sndProgress -> ACIStatus SMDSnd $ CISSndRcvd msgRcptStatus sndProgress
JCISSndErrorAuth -> ACIStatus SMDSnd CISSndErrorAuth
JCISSndError e -> ACIStatus SMDSnd $ CISSndError e
JCISSndError sndErr -> ACIStatus SMDSnd $ CISSndError sndErr
JCISSndWarning sndErr -> ACIStatus SMDSnd $ CISSndWarning sndErr
JCISRcvNew -> ACIStatus SMDRcv CISRcvNew
JCISRcvRead -> ACIStatus SMDRcv CISRcvRead
JCISInvalid text -> ACIStatus SMDSnd $ CISInvalid text
@@ -1041,7 +1099,7 @@ instance TextEncoding CIForwardedFromTag where
data ChatItemInfo = ChatItemInfo
{ itemVersions :: [ChatItemVersion],
memberDeliveryStatuses :: Maybe [MemberDeliveryStatus],
memberDeliveryStatuses :: Maybe (NonEmpty MemberDeliveryStatus),
forwardedFromChatItem :: Maybe AChatItem
}
deriving (Show)
@@ -1070,7 +1128,8 @@ mkItemVersion ChatItem {content, meta} = version <$> ciMsgContent content
data MemberDeliveryStatus = MemberDeliveryStatus
{ groupMemberId :: GroupMemberId,
memberDeliveryStatus :: CIStatus 'MDSnd
memberDeliveryStatus :: CIStatus 'MDSnd,
sentViaProxy :: Maybe Bool
}
deriving (Eq, Show)
@@ -1108,6 +1167,10 @@ $(JQ.deriveJSON defaultJSON ''CITimed)
$(JQ.deriveJSON (enumJSON $ dropPrefix "SSP") ''SndCIStatusProgress)
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "SrvErr") ''SrvError)
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "SndErr") ''SndError)
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCIS") ''JSONCIStatus)
instance MsgDirectionI d => FromJSON (CIStatus d) where

View File

@@ -0,0 +1,20 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20240510_chat_items_via_proxy where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20240510_chat_items_via_proxy :: Query
m20240510_chat_items_via_proxy =
[sql|
ALTER TABLE chat_items ADD COLUMN via_proxy INTEGER;
ALTER TABLE group_snd_item_statuses ADD COLUMN via_proxy INTEGER;
|]
down_m20240510_chat_items_via_proxy :: Query
down_m20240510_chat_items_via_proxy =
[sql|
ALTER TABLE chat_items DROP COLUMN via_proxy;
ALTER TABLE group_snd_item_statuses DROP COLUMN via_proxy;
|]

View File

@@ -392,7 +392,8 @@ CREATE TABLE chat_items(
fwd_from_msg_dir INTEGER,
fwd_from_contact_id INTEGER REFERENCES contacts ON DELETE SET NULL,
fwd_from_group_id INTEGER REFERENCES groups ON DELETE SET NULL,
fwd_from_chat_item_id INTEGER REFERENCES chat_items ON DELETE SET NULL
fwd_from_chat_item_id INTEGER REFERENCES chat_items ON DELETE SET NULL,
via_proxy INTEGER
);
CREATE TABLE chat_item_messages(
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
@@ -503,6 +504,8 @@ CREATE TABLE group_snd_item_statuses(
group_snd_item_status TEXT NOT NULL,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
,
via_proxy INTEGER
);
CREATE TABLE IF NOT EXISTS "sent_probes"(
sent_probe_id INTEGER PRIMARY KEY,

View File

@@ -95,6 +95,7 @@ module Simplex.Chat.Store.Messages
lookupChatItemByFileId,
getChatItemByGroupId,
updateDirectChatItemStatus,
setDirectSndChatItemViaProxy,
getTimedItems,
getChatItemTTL,
setChatItemTTL,
@@ -108,6 +109,7 @@ module Simplex.Chat.Store.Messages
createGroupSndStatus,
getGroupSndStatus,
updateGroupSndStatus,
setGroupSndViaProxy,
getGroupSndStatuses,
getGroupSndStatusCounts,
getGroupHistoryItems,
@@ -806,7 +808,7 @@ getLocalChatPreview_ db user (LocalChatPD _ noteFolderId lastItemId_ stats) = do
-- this function can be changed so it never fails, not only avoid failure on invalid json
toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError (CChatItem 'CTLocal)
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) =
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@@ -839,7 +841,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
_ -> Just (CIDeleted @CTLocal deletedTs)
itemEdited' = fromMaybe False itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt
in mkCIMeta itemId content itemText status sentViaProxy sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@@ -1407,7 +1409,7 @@ type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool)
type ChatItemForwardedFromRow = (Maybe CIForwardedFromTag, Maybe Text, Maybe MsgDirection, Maybe Int64, Maybe Int64, Maybe Int64)
type ChatItemRow =
(Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe SharedMsgId)
(Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe Bool, Maybe SharedMsgId)
:. (Int, Maybe UTCTime, Maybe Bool, UTCTime, UTCTime)
:. ChatItemForwardedFromRow
:. ChatItemModeRow
@@ -1426,7 +1428,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir
-- this function can be changed so it never fails, not only avoid failure on invalid json
toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) =
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@@ -1459,7 +1461,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
_ -> Just (CIDeleted @CTDirect deletedTs)
itemEdited' = fromMaybe False itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt
in mkCIMeta itemId content itemText status sentViaProxy sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@@ -1483,7 +1485,7 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction
-- this function can be changed so it never fails, not only avoid failure on invalid json
toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. Only (Maybe GroupMemberId) :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. Only forwardedByMember :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. Only forwardedByMember :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
member_ = toMaybeGroupMember userContactId memberRow_
@@ -1521,7 +1523,7 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
_ -> Just (maybe (CIDeleted @CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
itemEdited' = fromMaybe False itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt
in mkCIMeta itemId content itemText status sentViaProxy sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@@ -1600,6 +1602,11 @@ updateDirectChatItemStatus db user@User {userId} ct@Contact {contactId} itemId i
liftIO $ DB.execute db "UPDATE chat_items SET item_status = ?, updated_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" (itemStatus, currentTs, userId, contactId, itemId)
pure ci {meta = (meta ci) {itemStatus}}
setDirectSndChatItemViaProxy :: DB.Connection -> User -> Contact -> ChatItem 'CTDirect 'MDSnd -> Bool -> IO (ChatItem 'CTDirect 'MDSnd)
setDirectSndChatItemViaProxy db User {userId} Contact {contactId} ci viaProxy = do
DB.execute db "UPDATE chat_items SET via_proxy = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" (viaProxy, userId, contactId, chatItemId' ci)
pure ci {meta = (meta ci) {sentViaProxy = Just viaProxy}}
updateDirectChatItem :: MsgDirectionI d => DB.Connection -> User -> Contact -> ChatItemId -> CIContent d -> Bool -> Bool -> Maybe CITimed -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTDirect d)
updateDirectChatItem db user ct@Contact {contactId} itemId newContent edited live timed_ msgId_ = do
ci <- liftEither . correctDir =<< getDirectCIWithReactions db user ct itemId
@@ -1758,7 +1765,7 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
[sql|
SELECT
-- ChatItem
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id,
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live,
@@ -2001,7 +2008,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
[sql|
SELECT
-- ChatItem
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id,
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live,
@@ -2105,7 +2112,7 @@ getLocalChatItem db User {userId} folderId itemId = ExceptT $ do
[sql|
SELECT
-- ChatItem
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id,
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live,
@@ -2538,16 +2545,31 @@ updateGroupSndStatus db itemId memberId status = do
|]
(status, currentTs, itemId, memberId)
getGroupSndStatuses :: DB.Connection -> ChatItemId -> IO [(GroupMemberId, CIStatus 'MDSnd)]
getGroupSndStatuses db itemId =
DB.query
setGroupSndViaProxy :: DB.Connection -> ChatItemId -> GroupMemberId -> Bool -> IO ()
setGroupSndViaProxy db itemId memberId viaProxy =
DB.execute
db
[sql|
SELECT group_member_id, group_snd_item_status
FROM group_snd_item_statuses
WHERE chat_item_id = ?
UPDATE group_snd_item_statuses
SET via_proxy = ?
WHERE chat_item_id = ? AND group_member_id = ?
|]
(Only itemId)
(viaProxy, itemId, memberId)
getGroupSndStatuses :: DB.Connection -> ChatItemId -> IO [MemberDeliveryStatus]
getGroupSndStatuses db itemId =
map memStatus
<$> DB.query
db
[sql|
SELECT group_member_id, group_snd_item_status, via_proxy
FROM group_snd_item_statuses
WHERE chat_item_id = ?
|]
(Only itemId)
where
memStatus (groupMemberId, memberDeliveryStatus, sentViaProxy) =
MemberDeliveryStatus {groupMemberId, memberDeliveryStatus, sentViaProxy}
getGroupSndStatusCounts :: DB.Connection -> ChatItemId -> IO [(CIStatus 'MDSnd, Int)]
getGroupSndStatusCounts db itemId =

View File

@@ -107,6 +107,7 @@ import Simplex.Chat.Migrations.M20240324_custom_data
import Simplex.Chat.Migrations.M20240402_item_forwarded
import Simplex.Chat.Migrations.M20240430_ui_theme
import Simplex.Chat.Migrations.M20240501_chat_deleted
import Simplex.Chat.Migrations.M20240510_chat_items_via_proxy
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@@ -213,7 +214,8 @@ schemaMigrations =
("20240324_custom_data", m20240324_custom_data, Just down_m20240324_custom_data),
("20240402_item_forwarded", m20240402_item_forwarded, Just down_m20240402_item_forwarded),
("20240430_ui_theme", m20240430_ui_theme, Just down_m20240430_ui_theme),
("20240501_chat_deleted", m20240501_chat_deleted, Just down_m20240501_chat_deleted)
("20240501_chat_deleted", m20240501_chat_deleted, Just down_m20240501_chat_deleted),
("20240510_chat_items_via_proxy", m20240510_chat_items_via_proxy, Just down_m20240510_chat_items_via_proxy)
]
-- | The list of migrations in ascending order by date

View File

@@ -37,6 +37,7 @@ import Simplex.Chat.Types
import Simplex.FileTransfer.Description (kb, mb)
import Simplex.FileTransfer.Server (runXFTPServerBlocking)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration)
import Simplex.FileTransfer.Transport (supportedFileServerVRange)
import Simplex.Messaging.Agent (disposeAgentClient)
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol (currentSMPAgentVersion, duplexHandshakeSMPAgentVersion, pqdrSMPAgentVersion, supportedSMPAgentVRange)
@@ -44,6 +45,7 @@ import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), closeSQLiteStore)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Client (ProtocolClientConfig (..), defaultNetworkConfig)
import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
import Simplex.Messaging.Crypto.Ratchet (supportedE2EEncryptVRange)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Server (runSMPServerBlocking)
@@ -427,7 +429,9 @@ serverCfg =
smpServerVRange = supportedServerSMPRelayVRange,
transportConfig = defaultTransportServerConfig,
smpHandshakeTimeout = 1000000,
controlPort = Nothing
controlPort = Nothing,
smpAgentCfg = defaultSMPClientAgentConfig,
allowSMPProxy = False
}
withSmpServer :: IO () -> IO ()
@@ -458,6 +462,7 @@ xftpServerConfig =
caCertificateFile = "tests/fixtures/tls/ca.crt",
privateKeyFile = "tests/fixtures/tls/server.key",
certificateFile = "tests/fixtures/tls/server.crt",
xftpServerVRange = supportedFileServerVRange,
logStatsInterval = Nothing,
logStatsStartTime = 0,
serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",