mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-24 08:45:31 +00:00
core: allow admins/owners delete member messages (#1869)
* core: allow admins/owners delete member messages * allow message deletion to admins/owners * deleted by types, schema * check role * fix test, view * view, tests * comment * test timed deletion events * refactor * refactor * refactor --------- Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
a018e4a581
commit
9e4499de6d
@@ -203,6 +203,7 @@ data ChatCommand
|
||||
| APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, composedMessage :: ComposedMessage}
|
||||
| APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent}
|
||||
| APIDeleteChatItem ChatRef ChatItemId CIDeleteMode
|
||||
| APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId
|
||||
| APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId))
|
||||
| APIChatUnread ChatRef Bool
|
||||
| APIDeleteChat ChatRef
|
||||
@@ -297,6 +298,7 @@ data ChatCommand
|
||||
| SendMessageQuote {contactName :: ContactName, msgDir :: AMsgDirection, quotedMsg :: ByteString, message :: ByteString}
|
||||
| SendMessageBroadcast ByteString -- UserId (not used in UI)
|
||||
| DeleteMessage ChatName ByteString
|
||||
| DeleteMemberMessage GroupName ContactName ByteString
|
||||
| EditMessage {chatName :: ChatName, editedMsg :: ByteString, message :: ByteString}
|
||||
| UpdateLiveMessage {chatName :: ChatName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: ByteString}
|
||||
| APINewGroup UserId GroupProfile
|
||||
@@ -657,7 +659,7 @@ data ChatErrorType
|
||||
| CEContactNotReady {contact :: Contact}
|
||||
| CEContactDisabled {contact :: Contact}
|
||||
| CEConnectionDisabled {connection :: Connection}
|
||||
| CEGroupUserRole {requiredRole :: GroupMemberRole}
|
||||
| CEGroupUserRole {groupInfo :: GroupInfo, requiredRole :: GroupMemberRole}
|
||||
| CEContactIncognitoCantInvite
|
||||
| CEGroupIncognitoCantInvite
|
||||
| CEGroupContactRole {contactName :: ContactName}
|
||||
|
||||
@@ -19,6 +19,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
@@ -121,7 +122,7 @@ instance ToJSON AChatInfo where
|
||||
|
||||
data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
|
||||
{ chatDir :: CIDirection c d,
|
||||
meta :: CIMeta d,
|
||||
meta :: CIMeta c d,
|
||||
content :: CIContent d,
|
||||
formattedText :: Maybe MarkdownList,
|
||||
quotedItem :: Maybe (CIQuote c),
|
||||
@@ -183,6 +184,26 @@ chatItemTs' ChatItem {meta = CIMeta {itemTs}} = itemTs
|
||||
chatItemTimed :: ChatItem c d -> Maybe CITimed
|
||||
chatItemTimed ChatItem {meta = CIMeta {itemTimed}} = itemTimed
|
||||
|
||||
data CIDeletedState = CIDeletedState
|
||||
{ markedDeleted :: Bool,
|
||||
deletedByMember :: Maybe GroupMember
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
chatItemDeletedState :: ChatItem c d -> Maybe CIDeletedState
|
||||
chatItemDeletedState ChatItem {meta = CIMeta {itemDeleted}, content} =
|
||||
ciDeletedToDeletedState <$> itemDeleted
|
||||
where
|
||||
ciDeletedToDeletedState cid =
|
||||
case content of
|
||||
CISndModerated -> CIDeletedState {markedDeleted = False, deletedByMember = byMember cid}
|
||||
CIRcvModerated -> CIDeletedState {markedDeleted = False, deletedByMember = byMember cid}
|
||||
_ -> CIDeletedState {markedDeleted = True, deletedByMember = byMember cid}
|
||||
byMember :: CIDeleted c -> Maybe GroupMember
|
||||
byMember = \case
|
||||
CIModerated m -> Just m
|
||||
CIDeleted -> Nothing
|
||||
|
||||
data ChatDirection (c :: ChatType) (d :: MsgDirection) where
|
||||
CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd
|
||||
CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv
|
||||
@@ -277,13 +298,13 @@ instance MsgDirectionI d => ToJSON (JSONAnyChatItem c d) where
|
||||
toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
-- This type is not saved to DB, so all JSON encodings are platform-specific
|
||||
data CIMeta (d :: MsgDirection) = CIMeta
|
||||
data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
|
||||
{ itemId :: ChatItemId,
|
||||
itemTs :: ChatItemTs,
|
||||
itemText :: Text,
|
||||
itemStatus :: CIStatus d,
|
||||
itemSharedMsgId :: Maybe SharedMsgId,
|
||||
itemDeleted :: Bool,
|
||||
itemDeleted :: Maybe (CIDeleted c),
|
||||
itemEdited :: Bool,
|
||||
itemTimed :: Maybe CITimed,
|
||||
itemLive :: Maybe Bool,
|
||||
@@ -294,15 +315,15 @@ data CIMeta (d :: MsgDirection) = CIMeta
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Bool -> Bool -> Maybe CITimed -> Maybe Bool -> TimeZone -> UTCTime -> ChatItemTs -> UTCTime -> UTCTime -> CIMeta d
|
||||
mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> TimeZone -> UTCTime -> ChatItemTs -> UTCTime -> UTCTime -> CIMeta c d
|
||||
mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited itemTimed itemLive tz currentTs itemTs createdAt updatedAt =
|
||||
let localItemTs = utcToZonedTime tz itemTs
|
||||
editable = case itemContent of
|
||||
CISndMsgContent _ -> diffUTCTime currentTs itemTs < nominalDay && not itemDeleted
|
||||
CISndMsgContent _ -> diffUTCTime currentTs itemTs < nominalDay && isNothing itemDeleted
|
||||
_ -> False
|
||||
in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, itemTimed, itemLive, editable, localItemTs, createdAt, updatedAt}
|
||||
|
||||
instance ToJSON (CIMeta d) where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
instance ToJSON (CIMeta c d) where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
data CITimed = CITimed
|
||||
{ ttl :: Int, -- seconds
|
||||
@@ -629,6 +650,8 @@ data CIContent (d :: MsgDirection) where
|
||||
CISndGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvChatFeatureRejected :: ChatFeature -> CIContent 'MDRcv
|
||||
CIRcvGroupFeatureRejected :: GroupFeature -> CIContent 'MDRcv
|
||||
CISndModerated :: CIContent 'MDSnd
|
||||
CIRcvModerated :: CIContent 'MDRcv
|
||||
-- ^ This type is used both in API and in DB, so we use different JSON encodings for the database and for the API
|
||||
-- ! ^ Nested sum types also have to use different encodings for database and API
|
||||
-- ! ^ to avoid breaking cross-platform compatibility, see RcvGroupEvent and SndGroupEvent
|
||||
@@ -661,6 +684,7 @@ ciRequiresAttention content = case msgDirection @d of
|
||||
CIRcvGroupFeature {} -> False
|
||||
CIRcvChatFeatureRejected _ -> True
|
||||
CIRcvGroupFeatureRejected _ -> True
|
||||
CIRcvModerated -> True
|
||||
|
||||
ciCreateStatus :: forall d. MsgDirectionI d => CIContent d -> CIStatus d
|
||||
ciCreateStatus content = case msgDirection @d of
|
||||
@@ -820,6 +844,8 @@ ciContentToText = \case
|
||||
CISndGroupFeature feature pref param -> groupPrefStateText feature pref param
|
||||
CIRcvChatFeatureRejected feature -> chatFeatureNameText feature <> ": received, prohibited"
|
||||
CIRcvGroupFeatureRejected feature -> groupFeatureNameText feature <> ": received, prohibited"
|
||||
CISndModerated -> ciModeratedText
|
||||
CIRcvModerated -> ciModeratedText
|
||||
|
||||
msgIntegrityError :: MsgErrorType -> Text
|
||||
msgIntegrityError = \case
|
||||
@@ -830,10 +856,13 @@ msgIntegrityError = \case
|
||||
MsgBadHash -> "incorrect message hash"
|
||||
MsgDuplicate -> "duplicate message ID"
|
||||
|
||||
msgDirToDeletedContent_ :: SMsgDirection d -> CIDeleteMode -> CIContent d
|
||||
msgDirToDeletedContent_ msgDir mode = case msgDir of
|
||||
SMDRcv -> CIRcvDeleted mode
|
||||
SMDSnd -> CISndDeleted mode
|
||||
msgDirToModeratedContent_ :: SMsgDirection d -> CIContent d
|
||||
msgDirToModeratedContent_ = \case
|
||||
SMDRcv -> CIRcvModerated
|
||||
SMDSnd -> CISndModerated
|
||||
|
||||
ciModeratedText :: Text
|
||||
ciModeratedText = "moderated"
|
||||
|
||||
-- platform independent
|
||||
instance ToField (CIContent d) where
|
||||
@@ -878,6 +907,8 @@ data JSONCIContent
|
||||
| JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| JCIRcvChatFeatureRejected {feature :: ChatFeature}
|
||||
| JCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
|
||||
| JCISndModerated
|
||||
| JCIRcvModerated
|
||||
deriving (Generic)
|
||||
|
||||
instance FromJSON JSONCIContent where
|
||||
@@ -910,6 +941,8 @@ jsonCIContent = \case
|
||||
CISndGroupFeature groupFeature preference param -> JCISndGroupFeature {groupFeature, preference, param}
|
||||
CIRcvChatFeatureRejected feature -> JCIRcvChatFeatureRejected {feature}
|
||||
CIRcvGroupFeatureRejected groupFeature -> JCIRcvGroupFeatureRejected {groupFeature}
|
||||
CISndModerated -> JCISndModerated
|
||||
CIRcvModerated -> JCISndModerated
|
||||
|
||||
aciContentJSON :: JSONCIContent -> ACIContent
|
||||
aciContentJSON = \case
|
||||
@@ -934,6 +967,8 @@ aciContentJSON = \case
|
||||
JCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
|
||||
JCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
|
||||
JCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
|
||||
JCISndModerated -> ACIContent SMDSnd CISndModerated
|
||||
JCIRcvModerated -> ACIContent SMDRcv CIRcvModerated
|
||||
|
||||
-- platform independent
|
||||
data DBJSONCIContent
|
||||
@@ -958,6 +993,8 @@ data DBJSONCIContent
|
||||
| DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| DBJCIRcvChatFeatureRejected {feature :: ChatFeature}
|
||||
| DBJCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
|
||||
| DBJCISndModerated
|
||||
| DBJCIRcvModerated
|
||||
deriving (Generic)
|
||||
|
||||
instance FromJSON DBJSONCIContent where
|
||||
@@ -990,6 +1027,8 @@ dbJsonCIContent = \case
|
||||
CISndGroupFeature groupFeature preference param -> DBJCISndGroupFeature {groupFeature, preference, param}
|
||||
CIRcvChatFeatureRejected feature -> DBJCIRcvChatFeatureRejected {feature}
|
||||
CIRcvGroupFeatureRejected groupFeature -> DBJCIRcvGroupFeatureRejected {groupFeature}
|
||||
CISndModerated -> DBJCISndModerated
|
||||
CIRcvModerated -> DBJCIRcvModerated
|
||||
|
||||
aciContentDBJSON :: DBJSONCIContent -> ACIContent
|
||||
aciContentDBJSON = \case
|
||||
@@ -1014,6 +1053,8 @@ aciContentDBJSON = \case
|
||||
DBJCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
|
||||
DBJCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
|
||||
DBJCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
|
||||
DBJCISndModerated -> ACIContent SMDSnd CISndModerated
|
||||
DBJCIRcvModerated -> ACIContent SMDRcv CIRcvModerated
|
||||
|
||||
data CICallStatus
|
||||
= CISCallPending
|
||||
@@ -1241,3 +1282,27 @@ checkDirection :: forall t d d'. (MsgDirectionI d, MsgDirectionI d') => t d' ->
|
||||
checkDirection x = case testEquality (msgDirection @d) (msgDirection @d') of
|
||||
Just Refl -> Right x
|
||||
Nothing -> Left "bad direction"
|
||||
|
||||
data CIDeleted (c :: ChatType) where
|
||||
CIDeleted :: CIDeleted c
|
||||
CIModerated :: GroupMember -> CIDeleted 'CTGroup
|
||||
|
||||
deriving instance Show (CIDeleted c)
|
||||
|
||||
instance ToJSON (CIDeleted d) where
|
||||
toJSON = J.toJSON . jsonCIDeleted
|
||||
toEncoding = J.toEncoding . jsonCIDeleted
|
||||
|
||||
data JSONCIDeleted
|
||||
= JCIDDeleted
|
||||
| JCIDModerated {byGroupMember :: GroupMember}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON JSONCIDeleted where
|
||||
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCID"
|
||||
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCID"
|
||||
|
||||
jsonCIDeleted :: CIDeleted d -> JSONCIDeleted
|
||||
jsonCIDeleted = \case
|
||||
CIDeleted -> JCIDDeleted
|
||||
CIModerated m -> JCIDModerated m
|
||||
|
||||
@@ -0,0 +1,14 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20230206_item_deleted_by_group_member_id :: Query
|
||||
m20230206_item_deleted_by_group_member_id =
|
||||
[sql|
|
||||
ALTER TABLE chat_items ADD COLUMN item_deleted_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL;
|
||||
|
||||
CREATE INDEX idx_chat_items_item_deleted_by_group_member_id ON chat_items(item_deleted_by_group_member_id);
|
||||
|]
|
||||
@@ -372,7 +372,8 @@ CREATE TABLE chat_items(
|
||||
item_edited INTEGER,
|
||||
timed_ttl INTEGER,
|
||||
timed_delete_at TEXT,
|
||||
item_live INTEGER
|
||||
item_live INTEGER,
|
||||
item_deleted_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL
|
||||
);
|
||||
CREATE TABLE chat_item_messages(
|
||||
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
|
||||
@@ -546,3 +547,6 @@ CREATE TABLE IF NOT EXISTS "smp_servers"(
|
||||
UNIQUE(user_id, host, port)
|
||||
);
|
||||
CREATE INDEX idx_smp_servers_user_id ON smp_servers(user_id);
|
||||
CREATE INDEX idx_chat_items_item_deleted_by_group_member_id ON chat_items(
|
||||
item_deleted_by_group_member_id
|
||||
);
|
||||
|
||||
@@ -180,7 +180,7 @@ instance StrEncoding AChatMessage where
|
||||
data ChatMsgEvent (e :: MsgEncoding) where
|
||||
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
|
||||
XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, ttl :: Maybe Int, live :: Maybe Bool} -> ChatMsgEvent 'Json
|
||||
XMsgDel :: SharedMsgId -> ChatMsgEvent 'Json
|
||||
XMsgDel :: SharedMsgId -> Maybe MemberId -> ChatMsgEvent 'Json
|
||||
XMsgDeleted :: ChatMsgEvent 'Json
|
||||
XFile :: FileInvitation -> ChatMsgEvent 'Json -- TODO discontinue
|
||||
XFileAcpt :: String -> ChatMsgEvent 'Json -- direct file protocol
|
||||
@@ -558,7 +558,7 @@ toCMEventTag :: ChatMsgEvent e -> CMEventTag e
|
||||
toCMEventTag msg = case msg of
|
||||
XMsgNew _ -> XMsgNew_
|
||||
XMsgUpdate {} -> XMsgUpdate_
|
||||
XMsgDel _ -> XMsgDel_
|
||||
XMsgDel {} -> XMsgDel_
|
||||
XMsgDeleted -> XMsgDeleted_
|
||||
XFile _ -> XFile_
|
||||
XFileAcpt _ -> XFileAcpt_
|
||||
@@ -643,7 +643,7 @@ appJsonToCM AppMessageJson {msgId, event, params} = do
|
||||
msg = \case
|
||||
XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params
|
||||
XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" <*> opt "ttl" <*> opt "live"
|
||||
XMsgDel_ -> XMsgDel <$> p "msgId"
|
||||
XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId"
|
||||
XMsgDeleted_ -> pure XMsgDeleted
|
||||
XFile_ -> XFile <$> p "file"
|
||||
XFileAcpt_ -> XFileAcpt <$> p "fileName"
|
||||
@@ -696,7 +696,7 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = case encoding @e of
|
||||
params = \case
|
||||
XMsgNew container -> msgContainerJSON container
|
||||
XMsgUpdate msgId' content ttl live -> o $ ("ttl" .=? ttl) $ ("live" .=? live) ["msgId" .= msgId', "content" .= content]
|
||||
XMsgDel msgId' -> o ["msgId" .= msgId']
|
||||
XMsgDel msgId' memberId -> o $ ("memberId" .=? memberId) ["msgId" .= msgId']
|
||||
XMsgDeleted -> JM.empty
|
||||
XFile fileInv -> o ["file" .= fileInv]
|
||||
XFileAcpt fileName -> o ["fileName" .= fileName]
|
||||
|
||||
+102
-34
@@ -208,6 +208,7 @@ module Simplex.Chat.Store
|
||||
getDirectChatItemByAgentMsgId,
|
||||
getGroupChatItem,
|
||||
getGroupChatItemBySharedMsgId,
|
||||
getGroupMemberCIBySharedMsgId,
|
||||
getDirectChatItemIdByText,
|
||||
getGroupChatItemIdByText,
|
||||
getChatItemByFileId,
|
||||
@@ -220,6 +221,7 @@ module Simplex.Chat.Store
|
||||
markDirectChatItemDeleted,
|
||||
updateGroupChatItem,
|
||||
deleteGroupChatItem,
|
||||
updateGroupChatItemModerated,
|
||||
markGroupChatItemDeleted,
|
||||
updateDirectChatItemsRead,
|
||||
getDirectUnreadTimedItems,
|
||||
@@ -338,6 +340,7 @@ import Simplex.Chat.Migrations.M20230111_users_agent_user_id
|
||||
import Simplex.Chat.Migrations.M20230117_fkey_indexes
|
||||
import Simplex.Chat.Migrations.M20230118_recreate_smp_servers
|
||||
import Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx
|
||||
import Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (week)
|
||||
@@ -402,7 +405,8 @@ schemaMigrations =
|
||||
("20230111_users_agent_user_id", m20230111_users_agent_user_id),
|
||||
("20230117_fkey_indexes", m20230117_fkey_indexes),
|
||||
("20230118_recreate_smp_servers", m20230118_recreate_smp_servers),
|
||||
("20230129_drop_chat_items_group_idx", m20230129_drop_chat_items_group_idx)
|
||||
("20230129_drop_chat_items_group_idx", m20230129_drop_chat_items_group_idx),
|
||||
("20230206_item_deleted_by_group_member_id", m20230206_item_deleted_by_group_member_id)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@@ -3511,7 +3515,11 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
|
||||
-- quoted GroupMember
|
||||
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
|
||||
rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id,
|
||||
rp.display_name, rp.full_name, rp.image, rp.local_alias, rp.preferences
|
||||
rp.display_name, rp.full_name, rp.image, rp.local_alias, rp.preferences,
|
||||
-- deleted by GroupMember
|
||||
dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category,
|
||||
dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id,
|
||||
dbp.display_name, dbp.full_name, dbp.image, dbp.local_alias, dbp.preferences
|
||||
FROM groups g
|
||||
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
|
||||
JOIN group_members mu ON mu.group_id = g.group_id
|
||||
@@ -3535,6 +3543,8 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
|
||||
LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.group_id = i.group_id
|
||||
LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id
|
||||
LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id)
|
||||
LEFT JOIN group_members dbm ON dbm.group_member_id = i.item_deleted_by_group_member_id
|
||||
LEFT JOIN contact_profiles dbp ON dbp.contact_profile_id = COALESCE(dbm.member_profile_id, dbm.contact_profile_id)
|
||||
WHERE g.user_id = ? AND mu.contact_id = ?
|
||||
ORDER BY i.item_ts DESC
|
||||
|]
|
||||
@@ -4001,6 +4011,7 @@ updatedChatItem ci@ChatItem {meta = meta@CIMeta {itemStatus, itemEdited, itemTim
|
||||
updateDirectChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> UserId -> Int64 -> ChatItem 'CTDirect d -> Maybe MessageId -> IO ()
|
||||
updateDirectChatItem_ db userId contactId ChatItem {meta, content} msgId_ = do
|
||||
let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta
|
||||
itemDeleted' = isJust itemDeleted
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
@@ -4008,7 +4019,7 @@ updateDirectChatItem_ db userId contactId ChatItem {meta, content} msgId_ = do
|
||||
SET item_content = ?, item_text = ?, item_status = ?, item_deleted = ?, item_edited = ?, item_live = ?, updated_at = ?, timed_ttl = ?, timed_delete_at = ?
|
||||
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
((content, itemText, itemStatus, itemDeleted, itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, contactId, itemId))
|
||||
((content, itemText, itemStatus, itemDeleted', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, contactId, itemId))
|
||||
forM_ msgId_ $ \msgId -> liftIO $ insertChatItemMessage_ db itemId msgId updatedAt
|
||||
|
||||
deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO ()
|
||||
@@ -4050,7 +4061,7 @@ markDirectChatItemDeleted db User {userId} ct@Contact {contactId} (CChatItem msg
|
||||
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
(currentTs, userId, contactId, itemId)
|
||||
pure $ AChatItem SCTDirect msgDir (DirectChat ct) (ci {meta = (meta ci) {itemDeleted = True, editable = False}})
|
||||
pure $ AChatItem SCTDirect msgDir (DirectChat ct) (ci {meta = (meta ci) {itemDeleted = Just (CIDeleted @'CTDirect), editable = False}})
|
||||
|
||||
getDirectChatItemBySharedMsgId :: DB.Connection -> User -> ContactId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTDirect)
|
||||
getDirectChatItemBySharedMsgId db user@User {userId} contactId sharedMsgId = do
|
||||
@@ -4126,6 +4137,7 @@ updateGroupChatItem db user groupId ci newContent live msgId_ = do
|
||||
updateGroupChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> Maybe MessageId -> IO ()
|
||||
updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ = do
|
||||
let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta
|
||||
itemDeleted' = isJust itemDeleted
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
@@ -4133,7 +4145,7 @@ updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ =
|
||||
SET item_content = ?, item_text = ?, item_status = ?, item_deleted = ?, item_deleted = 0, item_edited = ?, item_live = ?, updated_at = ?, timed_ttl = ?, timed_delete_at = ?
|
||||
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
((content, itemText, itemStatus, itemDeleted, itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId))
|
||||
((content, itemText, itemStatus, itemDeleted', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId))
|
||||
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt
|
||||
|
||||
deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO ()
|
||||
@@ -4148,20 +4160,41 @@ deleteGroupChatItem db User {userId} GroupInfo {groupId} (CChatItem _ ci) = do
|
||||
|]
|
||||
(userId, groupId, itemId)
|
||||
|
||||
markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> IO AChatItem
|
||||
markGroupChatItemDeleted db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) msgId = do
|
||||
updateGroupChatItemModerated :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> GroupMember -> IO AChatItem
|
||||
updateGroupChatItemModerated db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) m@GroupMember {groupMemberId} = do
|
||||
currentTs <- getCurrentTime
|
||||
let toContent = msgDirToModeratedContent_ msgDir
|
||||
toText = ciModeratedText
|
||||
itemId = chatItemId' ci
|
||||
deleteChatItemMessages_ db itemId
|
||||
liftIO $
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE chat_items
|
||||
SET item_deleted = 1, item_deleted_by_group_member_id = ?, item_content = ?, item_text = ?, updated_at = ?
|
||||
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
(groupMemberId, toContent, toText, currentTs, userId, groupId, itemId)
|
||||
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated m)}, formattedText = Nothing})
|
||||
|
||||
markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> IO AChatItem
|
||||
markGroupChatItemDeleted db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) msgId byGroupMember_ = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let itemId = chatItemId' ci
|
||||
(deletedByGroupMemberId, ciDeleted) = case byGroupMember_ of
|
||||
Just m@GroupMember {groupMemberId} -> (Just groupMemberId, CIModerated m)
|
||||
_ -> (Nothing, CIDeleted)
|
||||
insertChatItemMessage_ db itemId msgId currentTs
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE chat_items
|
||||
SET item_deleted = 1, updated_at = ?
|
||||
SET item_deleted = 1, item_deleted_by_group_member_id = ?, updated_at = ?
|
||||
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
(currentTs, userId, groupId, itemId)
|
||||
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {meta = (meta ci) {itemDeleted = True, editable = False}})
|
||||
(deletedByGroupMemberId, currentTs, userId, groupId, itemId)
|
||||
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {meta = (meta ci) {itemDeleted = Just ciDeleted, editable = False}})
|
||||
|
||||
getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup)
|
||||
getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do
|
||||
@@ -4170,15 +4203,34 @@ getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId shared
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ?
|
||||
ORDER BY chat_item_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
SELECT chat_item_id
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ?
|
||||
ORDER BY chat_item_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, groupId, groupMemberId, sharedMsgId)
|
||||
getGroupChatItem db user groupId itemId
|
||||
|
||||
getGroupMemberCIBySharedMsgId :: DB.Connection -> User -> GroupId -> MemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup)
|
||||
getGroupMemberCIBySharedMsgId db user@User {userId} groupId memberId sharedMsgId = do
|
||||
itemId <-
|
||||
ExceptT . firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT i.chat_item_id
|
||||
FROM chat_items i
|
||||
JOIN group_members m ON m.group_id = i.group_id
|
||||
AND ((i.group_member_id IS NULL AND m.member_category = ?)
|
||||
OR i.group_member_id = m.group_member_id)
|
||||
WHERE i.user_id = ? AND i.group_id = ? AND m.member_id = ? AND i.shared_msg_id = ?
|
||||
ORDER BY i.chat_item_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(GCUserMember, userId, groupId, memberId, sharedMsgId)
|
||||
getGroupChatItem db user groupId itemId
|
||||
|
||||
getGroupChatItem :: DB.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTGroup)
|
||||
getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
|
||||
tz <- getCurrentTimeZone
|
||||
@@ -4203,7 +4255,11 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
|
||||
-- quoted GroupMember
|
||||
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
|
||||
rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id,
|
||||
rp.display_name, rp.full_name, rp.image, rp.local_alias, rp.preferences
|
||||
rp.display_name, rp.full_name, rp.image, rp.local_alias, rp.preferences,
|
||||
-- deleted by GroupMember
|
||||
dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category,
|
||||
dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id,
|
||||
dbp.display_name, dbp.full_name, dbp.image, dbp.local_alias, dbp.preferences
|
||||
FROM chat_items i
|
||||
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
||||
LEFT JOIN group_members m ON m.group_member_id = i.group_member_id
|
||||
@@ -4211,6 +4267,8 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
|
||||
LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.group_id = i.group_id
|
||||
LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id
|
||||
LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id)
|
||||
LEFT JOIN group_members dbm ON dbm.group_member_id = i.item_deleted_by_group_member_id
|
||||
LEFT JOIN contact_profiles dbp ON dbp.contact_profile_id = COALESCE(dbm.member_profile_id, dbm.contact_profile_id)
|
||||
WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id = ?
|
||||
|]
|
||||
(userId, groupId, itemId)
|
||||
@@ -4482,8 +4540,11 @@ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStat
|
||||
cItem d chatDir ciStatus content file =
|
||||
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, file}
|
||||
badItem = Left $ SEBadChatItem itemId
|
||||
ciMeta :: CIContent d -> CIStatus d -> CIMeta d
|
||||
ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) ciTimed itemLive tz currentTs itemTs createdAt updatedAt
|
||||
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d
|
||||
ciMeta content status =
|
||||
let itemDeleted' = if itemDeleted then Just (CIDeleted @'CTDirect) else Nothing
|
||||
itemEdited' = fromMaybe False itemEdited
|
||||
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive tz currentTs itemTs createdAt updatedAt
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
|
||||
|
||||
@@ -4494,7 +4555,7 @@ toDirectChatItemList _ _ _ = []
|
||||
|
||||
type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow
|
||||
|
||||
type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow
|
||||
type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow
|
||||
|
||||
toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup)
|
||||
toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_
|
||||
@@ -4504,19 +4565,20 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction
|
||||
direction (Just False) Nothing = Just $ CIQGroupRcv Nothing
|
||||
direction _ _ = Nothing
|
||||
|
||||
toGroupChatItem :: TimeZone -> UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow -> Either StoreError (CChatItem 'CTGroup)
|
||||
toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. memberRow_ :. quoteRow :. quotedMemberRow_) = do
|
||||
toGroupChatItem :: TimeZone -> UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
|
||||
toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
|
||||
let member_ = toMaybeGroupMember userContactId memberRow_
|
||||
let quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_
|
||||
quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_
|
||||
deletedByGroupMember_ = toMaybeGroupMember userContactId deletedByGroupMemberRow_
|
||||
case (itemContent, itemStatus, member_, fileStatus_) of
|
||||
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Just (AFS SMDSnd fileStatus)) ->
|
||||
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ (maybeCIFile fileStatus)
|
||||
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ (maybeCIFile fileStatus) deletedByGroupMember_
|
||||
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Nothing) ->
|
||||
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ Nothing
|
||||
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ Nothing deletedByGroupMember_
|
||||
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv fileStatus)) ->
|
||||
Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ (maybeCIFile fileStatus)
|
||||
Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ (maybeCIFile fileStatus) deletedByGroupMember_
|
||||
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Nothing) ->
|
||||
Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ Nothing
|
||||
Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ Nothing deletedByGroupMember_
|
||||
_ -> badItem
|
||||
where
|
||||
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
|
||||
@@ -4524,18 +4586,24 @@ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemT
|
||||
case (fileId_, fileName_, fileSize_) of
|
||||
(Just fileId, Just fileName, Just fileSize) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus}
|
||||
_ -> Nothing
|
||||
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe GroupMember -> Maybe (CIFile d) -> CChatItem 'CTGroup
|
||||
cItem d chatDir ciStatus content quotedMember_ file =
|
||||
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, file}
|
||||
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe GroupMember -> Maybe (CIFile d) -> Maybe GroupMember -> CChatItem 'CTGroup
|
||||
cItem d chatDir ciStatus content quotedMember_ file deletedByGroupMember_ =
|
||||
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus deletedByGroupMember_, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, file}
|
||||
badItem = Left $ SEBadChatItem itemId
|
||||
ciMeta :: CIContent d -> CIStatus d -> CIMeta d
|
||||
ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) ciTimed itemLive tz currentTs itemTs createdAt updatedAt
|
||||
ciMeta :: CIContent d -> CIStatus d -> Maybe GroupMember -> CIMeta 'CTGroup d
|
||||
ciMeta content status deletedByGroupMember_ =
|
||||
let itemDeleted' =
|
||||
if itemDeleted
|
||||
then Just (maybe (CIDeleted @'CTGroup) CIModerated deletedByGroupMember_)
|
||||
else Nothing
|
||||
itemEdited' = fromMaybe False itemEdited
|
||||
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive tz currentTs itemTs createdAt updatedAt
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
|
||||
|
||||
toGroupChatItemList :: TimeZone -> UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup]
|
||||
toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_) =
|
||||
either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_)
|
||||
toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) =
|
||||
either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_)
|
||||
toGroupChatItemList _ _ _ _ = []
|
||||
|
||||
getSMPServers :: DB.Connection -> User -> IO [ServerCfg]
|
||||
|
||||
+48
-37
@@ -19,7 +19,7 @@ import Data.Function (on)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (isJust, isNothing, mapMaybe)
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (DiffTime, UTCTime)
|
||||
@@ -84,7 +84,7 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
|
||||
CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId]
|
||||
CRChatItemStatusUpdated u _ -> ttyUser u []
|
||||
CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted chat item $ viewItemUpdate chat item liveItems ts
|
||||
CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted chat deletedItem $ viewItemDelete chat deletedItem (isJust toItem) byUser timed ts
|
||||
CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts testView
|
||||
CRChatItemDeletedNotFound u Contact {localDisplayName = c} _ -> ttyUser u [ttyFrom $ c <> "> [deleted - original message not found]"]
|
||||
CRBroadcastSent u mc n t -> ttyUser u $ viewSentBroadcast mc n ts t
|
||||
CRMsgIntegrityError u mErr -> ttyUser u $ viewMsgIntegrityError mErr
|
||||
@@ -266,7 +266,7 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
|
||||
Just CIFile {filePath = Just fp} -> Just fp
|
||||
_ -> Nothing
|
||||
testViewItem :: CChatItem c -> Text
|
||||
testViewItem (CChatItem _ ChatItem {meta = CIMeta {itemText, itemDeleted}}) = itemText <> if itemDeleted then " [marked deleted]" else ""
|
||||
testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText}}) = itemText <> maybe "" (\t -> " [" <> t <> "]") (chatItemDeletedText ci)
|
||||
viewErrorsSummary :: [a] -> StyledString -> [StyledString]
|
||||
viewErrorsSummary summary s = [ttyError (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)" | not (null summary)]
|
||||
contactList :: [ContactRef] -> String
|
||||
@@ -276,6 +276,15 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
|
||||
| muted chat chatItem = []
|
||||
| otherwise = s
|
||||
|
||||
chatItemDeletedText :: ChatItem c d -> Maybe Text
|
||||
chatItemDeletedText ci = deletedStateToText <$> chatItemDeletedState ci
|
||||
where
|
||||
deletedStateToText = \CIDeletedState {markedDeleted, deletedByMember} ->
|
||||
if markedDeleted
|
||||
then "marked deleted" <> byMember deletedByMember
|
||||
else "deleted" <> byMember deletedByMember
|
||||
byMember m_ = maybe "" (\GroupMember {localDisplayName = m} -> " by " <> m) m_
|
||||
|
||||
viewUsersList :: [UserInfo] -> [StyledString]
|
||||
viewUsersList = map userInfo . sortOn ldn
|
||||
where
|
||||
@@ -316,7 +325,7 @@ viewChats ts = concatMap chatPreview . reverse
|
||||
_ -> []
|
||||
|
||||
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> [StyledString]
|
||||
viewChatItem chat ChatItem {chatDir, meta = meta@CIMeta {itemDeleted}, content, quotedItem, file} doShow ts =
|
||||
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemDeleted}, content, quotedItem, file} doShow ts =
|
||||
withItemDeleted <$> case chat of
|
||||
DirectChat c -> case chatDir of
|
||||
CIDirectSnd -> case content of
|
||||
@@ -352,7 +361,7 @@ viewChatItem chat ChatItem {chatDir, meta = meta@CIMeta {itemDeleted}, content,
|
||||
quote = maybe [] (groupQuote g) quotedItem
|
||||
_ -> []
|
||||
where
|
||||
withItemDeleted item = if itemDeleted then item <> styled (colored Red) (" [marked deleted]" :: String) else item
|
||||
withItemDeleted item = if isJust itemDeleted then item <> styled (colored Red) (T.unpack $ maybe "" (\t -> " [" <> t <> "]") (chatItemDeletedText ci)) else item
|
||||
withSndFile = withFile viewSentFileInvitation
|
||||
withRcvFile = withFile viewReceivedFileInvitation
|
||||
withFile view dir l = maybe l (\f -> l <> view dir f ts meta) file
|
||||
@@ -404,23 +413,28 @@ viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemEdited, itemLive}
|
||||
quote = maybe [] (groupQuote g) quotedItem
|
||||
_ -> []
|
||||
|
||||
hideLive :: CIMeta d -> [StyledString] -> [StyledString]
|
||||
hideLive :: CIMeta с d -> [StyledString] -> [StyledString]
|
||||
hideLive CIMeta {itemLive = Just True} _ = []
|
||||
hideLive _ s = s
|
||||
|
||||
viewItemDelete :: ChatInfo c -> ChatItem c d -> Bool -> Bool -> Bool -> CurrentTime -> [StyledString]
|
||||
viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} markedDeleted byUser timed ts
|
||||
| timed = []
|
||||
| byUser = if markedDeleted then ["message marked deleted"] else ["message deleted"]
|
||||
viewItemDelete :: ChatInfo c -> ChatItem c d -> Maybe AChatItem -> Bool -> Bool -> CurrentTime -> Bool -> [StyledString]
|
||||
viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} toItem byUser timed ts testView
|
||||
| timed = [plain ("timed message deleted: " <> T.unpack (ciContentToText deletedContent)) | testView]
|
||||
| byUser = [plain $ "message " <> T.unpack (fromMaybe "deleted" deletedText_)] -- deletedText_ Nothing should be impossible here
|
||||
| otherwise = case chat of
|
||||
DirectChat c -> case (chatDir, deletedContent) of
|
||||
(CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c markedDeleted) [] mc ts meta
|
||||
(CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts meta
|
||||
_ -> prohibited
|
||||
GroupChat g -> case (chatDir, deletedContent) of
|
||||
(CIGroupRcv m, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromGroupDeleted g m markedDeleted) [] mc ts meta
|
||||
GroupChat g@GroupInfo {membership} -> case (chatDir, deletedContent) of
|
||||
(CIGroupRcv m, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts meta
|
||||
(CIGroupSnd, CISndMsgContent mc) -> viewReceivedMessage (ttyFromGroupDeleted g membership deletedText_) [] mc ts meta
|
||||
_ -> prohibited
|
||||
_ -> prohibited
|
||||
where
|
||||
deletedText_ :: Maybe Text
|
||||
deletedText_ = case toItem of
|
||||
Nothing -> Just "deleted"
|
||||
Just (AChatItem _ _ _ ci) -> chatItemDeletedText ci
|
||||
prohibited = [styled (colored Red) ("[unexpected message deletion, please report to developers]" :: String)]
|
||||
|
||||
directQuote :: forall d'. MsgDirectionI d' => CIDirection 'CTDirect d' -> CIQuote 'CTDirect -> [StyledString]
|
||||
@@ -445,7 +459,7 @@ msgPreview = msgPlain . preview . msgContentText
|
||||
| T.length t <= 120 = t
|
||||
| otherwise = T.take 120 t <> "..."
|
||||
|
||||
viewRcvIntegrityError :: StyledString -> MsgErrorType -> CurrentTime -> CIMeta 'MDRcv -> [StyledString]
|
||||
viewRcvIntegrityError :: StyledString -> MsgErrorType -> CurrentTime -> CIMeta с 'MDRcv -> [StyledString]
|
||||
viewRcvIntegrityError from msgErr ts meta = receivedWithTime_ ts from [] meta (viewMsgIntegrityError msgErr) False
|
||||
|
||||
viewMsgIntegrityError :: MsgErrorType -> [StyledString]
|
||||
@@ -929,22 +943,22 @@ viewContactUpdated
|
||||
where
|
||||
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
|
||||
|
||||
viewReceivedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString]
|
||||
viewReceivedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta c d -> [StyledString]
|
||||
viewReceivedMessage = viewReceivedMessage_ False
|
||||
|
||||
viewReceivedUpdatedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString]
|
||||
viewReceivedUpdatedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta c d -> [StyledString]
|
||||
viewReceivedUpdatedMessage = viewReceivedMessage_ True
|
||||
|
||||
viewReceivedMessage_ :: Bool -> StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString]
|
||||
viewReceivedMessage_ :: Bool -> StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta c d -> [StyledString]
|
||||
viewReceivedMessage_ updated from quote mc ts meta = receivedWithTime_ ts from quote meta (ttyMsgContent mc) updated
|
||||
|
||||
receivedWithTime_ :: CurrentTime -> StyledString -> [StyledString] -> CIMeta d -> [StyledString] -> Bool -> [StyledString]
|
||||
receivedWithTime_ :: CurrentTime -> StyledString -> [StyledString] -> CIMeta c d -> [StyledString] -> Bool -> [StyledString]
|
||||
receivedWithTime_ ts from quote CIMeta {localItemTs, itemId, itemEdited, itemDeleted, itemLive} styledMsg updated = do
|
||||
prependFirst (ttyMsgTime ts localItemTs <> " " <> from) (quote <> prependFirst (indent <> live) styledMsg)
|
||||
where
|
||||
indent = if null quote then "" else " "
|
||||
live
|
||||
| itemEdited || itemDeleted = ""
|
||||
| itemEdited || isJust itemDeleted = ""
|
||||
| otherwise = case itemLive of
|
||||
Just True
|
||||
| updated -> ttyFrom "[LIVE] "
|
||||
@@ -963,12 +977,12 @@ ttyMsgTime ts t =
|
||||
else "%H:%M"
|
||||
in styleTime $ formatTime defaultTimeLocale fmt localTime
|
||||
|
||||
viewSentMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString]
|
||||
viewSentMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta c d -> [StyledString]
|
||||
viewSentMessage to quote mc ts meta@CIMeta {itemEdited, itemDeleted, itemLive} = sentWithTime_ ts (prependFirst to $ quote <> prependFirst (indent <> live) (ttyMsgContent mc)) meta
|
||||
where
|
||||
indent = if null quote then "" else " "
|
||||
live
|
||||
| itemEdited || itemDeleted = ""
|
||||
| itemEdited || isJust itemDeleted = ""
|
||||
| otherwise = case itemLive of
|
||||
Just True -> ttyTo "[LIVE started] "
|
||||
Just False -> ttyTo "[LIVE] "
|
||||
@@ -977,7 +991,7 @@ viewSentMessage to quote mc ts meta@CIMeta {itemEdited, itemDeleted, itemLive} =
|
||||
viewSentBroadcast :: MsgContent -> Int -> CurrentTime -> ZonedTime -> [StyledString]
|
||||
viewSentBroadcast mc n ts t = prependFirst (highlight' "/feed" <> " (" <> sShow n <> ") " <> ttyMsgTime ts t <> " ") (ttyMsgContent mc)
|
||||
|
||||
viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> CIMeta d -> [StyledString]
|
||||
viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> CIMeta c d -> [StyledString]
|
||||
viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} ts = case filePath of
|
||||
Just fPath -> sentWithTime_ ts $ ttySentFile fPath
|
||||
_ -> const []
|
||||
@@ -987,7 +1001,7 @@ viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} ts = case filePa
|
||||
CIFSSndTransfer -> []
|
||||
_ -> ["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"]
|
||||
|
||||
sentWithTime_ :: CurrentTime -> [StyledString] -> CIMeta d -> [StyledString]
|
||||
sentWithTime_ :: CurrentTime -> [StyledString] -> CIMeta c d -> [StyledString]
|
||||
sentWithTime_ ts styledMsg CIMeta {localItemTs} =
|
||||
prependFirst (ttyMsgTime ts localItemTs <> " ") styledMsg
|
||||
|
||||
@@ -1018,7 +1032,7 @@ sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
sndFile :: SndFileTransfer -> StyledString
|
||||
sndFile SndFileTransfer {fileId, fileName} = fileTransferStr fileId fileName
|
||||
|
||||
viewReceivedFileInvitation :: StyledString -> CIFile d -> CurrentTime -> CIMeta d -> [StyledString]
|
||||
viewReceivedFileInvitation :: StyledString -> CIFile d -> CurrentTime -> CIMeta c d -> [StyledString]
|
||||
viewReceivedFileInvitation from file ts meta = receivedWithTime_ ts from [] meta (receivedFileInvitation_ file) False
|
||||
|
||||
receivedFileInvitation_ :: CIFile d -> [StyledString]
|
||||
@@ -1199,9 +1213,10 @@ viewChatError logLevel = \case
|
||||
CEConnectionDisabled Connection {connId, connType} -> [plain $ "connection " <> textEncode connType <> " (" <> tshow connId <> ") is disabled" | logLevel <= CLLWarning]
|
||||
CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"]
|
||||
CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"]
|
||||
CEGroupUserRole role -> case role of
|
||||
GRAuthor -> ["you don't have permission to send messages to this group"]
|
||||
_ -> ["you have insufficient permissions for this action, the required role is " <> plain (strEncode role)]
|
||||
CEGroupUserRole g role ->
|
||||
(: []) . (ttyGroup' g <>) $ case role of
|
||||
GRAuthor -> ": you don't have permission to send messages"
|
||||
_ -> ": you have insufficient permissions for this action, the required role is " <> plain (strEncode role)
|
||||
CEContactIncognitoCantInvite -> ["you're using your main profile for this group - prohibited to invite contacts to whom you are connected incognito"]
|
||||
CEGroupIncognitoCantInvite -> ["you've connected to this group using an incognito profile - prohibited to invite contacts"]
|
||||
CEGroupContactRole c -> ["contact " <> ttyContact c <> " has insufficient permissions for this group action"]
|
||||
@@ -1356,11 +1371,9 @@ ttyFromContact ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (c
|
||||
ttyFromContactEdited :: Contact -> StyledString
|
||||
ttyFromContactEdited ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (c <> "> [edited] ")
|
||||
|
||||
ttyFromContactDeleted :: Contact -> Bool -> StyledString
|
||||
ttyFromContactDeleted ct@Contact {localDisplayName = c} markedDeleted =
|
||||
ctIncognito ct <> ttyFrom (c <> "> " <> deleted)
|
||||
where
|
||||
deleted = if markedDeleted then "[marked deleted] " else "[deleted] "
|
||||
ttyFromContactDeleted :: Contact -> Maybe Text -> StyledString
|
||||
ttyFromContactDeleted ct@Contact {localDisplayName = c} deletedText_ =
|
||||
ctIncognito ct <> ttyFrom (c <> "> " <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
|
||||
|
||||
ttyGroup :: GroupName -> StyledString
|
||||
ttyGroup g = styled (colored Blue) $ "#" <> g
|
||||
@@ -1383,11 +1396,9 @@ ttyFromGroup g m = membershipIncognito g <> ttyFrom (fromGroup_ g m)
|
||||
ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString
|
||||
ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ")
|
||||
|
||||
ttyFromGroupDeleted :: GroupInfo -> GroupMember -> Bool -> StyledString
|
||||
ttyFromGroupDeleted g m markedDeleted =
|
||||
membershipIncognito g <> ttyFrom (fromGroup_ g m <> deleted)
|
||||
where
|
||||
deleted = if markedDeleted then "[marked deleted] " else "[deleted] "
|
||||
ttyFromGroupDeleted :: GroupInfo -> GroupMember -> Maybe Text -> StyledString
|
||||
ttyFromGroupDeleted g m deletedText_ =
|
||||
membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
|
||||
|
||||
fromGroup_ :: GroupInfo -> GroupMember -> Text
|
||||
fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} =
|
||||
|
||||
Reference in New Issue
Block a user