message update and delete (#451)
* core: message update and delete, protocol and command syntax * edit logic wip * message updates * revert project.pbxproj * corrections, dependency, editable Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>
This commit is contained in:
committed by
GitHub
parent
319b4dc841
commit
3c81a44273
@@ -61,6 +61,8 @@ tests:
|
||||
- hspec == 2.7.*
|
||||
- network == 3.1.*
|
||||
- stm == 2.5.*
|
||||
ghc-options:
|
||||
- -threaded
|
||||
|
||||
ghc-options:
|
||||
# - -haddock
|
||||
|
||||
@@ -32,6 +32,7 @@ library
|
||||
Simplex.Chat.Migrations.M20220301_smp_servers
|
||||
Simplex.Chat.Migrations.M20220302_profile_images
|
||||
Simplex.Chat.Migrations.M20220304_msg_quotes
|
||||
Simplex.Chat.Migrations.M20220321_chat_item_edited
|
||||
Simplex.Chat.Mobile
|
||||
Simplex.Chat.Options
|
||||
Simplex.Chat.Protocol
|
||||
|
||||
@@ -215,6 +215,38 @@ processChatCommand = \case
|
||||
msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId}
|
||||
in sendNewGroupMsg user group (MCQuote QuotedMsg {msgRef, content} mc) mc (Just quotedItem)
|
||||
CTContactRequest -> pure $ chatCmdError "not supported"
|
||||
APIUpdateMessage cType chatId itemId mc -> withUser $ \user@User {userId} -> withChatLock $ case cType of
|
||||
CTDirect -> do
|
||||
(ct@Contact {contactId, localDisplayName = c}, ci) <- withStore $ \st -> (,) <$> getContact st userId chatId <*> getDirectChatItem st userId chatId itemId
|
||||
case ci of
|
||||
CChatItem SMDSnd ChatItem {meta = CIMeta {itemSharedMsgId}, content = ciContent} -> do
|
||||
case (ciContent, itemSharedMsgId) of
|
||||
(CISndMsgContent _, Just itemSharedMId) -> do
|
||||
SndMessage {msgId} <- sendDirectContactMessage ct (XMsgUpdate itemSharedMId mc)
|
||||
updCi <- withStore $ \st -> updateDirectChatItem st userId contactId itemId (CISndMsgContent mc) msgId
|
||||
setActive $ ActiveC c
|
||||
pure . CRChatItemUpdated $ AChatItem SCTDirect SMDSnd (DirectChat ct) updCi
|
||||
_ -> throwChatError CEInvalidMessageUpdate
|
||||
CChatItem SMDRcv _ -> throwChatError CEInvalidMessageUpdate
|
||||
CTGroup -> do
|
||||
Group gInfo@GroupInfo {groupId, localDisplayName = gName, membership} ms <- withStore $ \st -> getGroup st user chatId
|
||||
unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved
|
||||
ci <- withStore $ \st -> getGroupChatItem st user chatId itemId
|
||||
case ci of
|
||||
CChatItem SMDSnd ChatItem {meta = CIMeta {itemSharedMsgId}, content = ciContent} -> do
|
||||
case (ciContent, itemSharedMsgId) of
|
||||
(CISndMsgContent _, Just itemSharedMId) -> do
|
||||
SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgUpdate itemSharedMId mc)
|
||||
updCi <- withStore $ \st -> updateGroupChatItem st user groupId itemId (CISndMsgContent mc) msgId
|
||||
setActive $ ActiveG gName
|
||||
pure . CRChatItemUpdated $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) updCi
|
||||
_ -> throwChatError CEInvalidMessageUpdate
|
||||
CChatItem SMDRcv _ -> throwChatError CEInvalidMessageUpdate
|
||||
CTContactRequest -> pure $ chatCmdError "not supported"
|
||||
APIDeleteMessage cType _chatId _itemId _mode -> withUser $ \_user -> withChatLock $ case cType of
|
||||
CTDirect -> pure CRCmdOk
|
||||
CTGroup -> pure CRCmdOk
|
||||
CTContactRequest -> pure $ chatCmdError "not supported"
|
||||
APIChatRead cType chatId fromToIds -> withChatLock $ case cType of
|
||||
CTDirect -> withStore (\st -> updateDirectChatItemsRead st chatId fromToIds) $> CRCmdOk
|
||||
CTGroup -> withStore (\st -> updateGroupChatItemsRead st chatId fromToIds) $> CRCmdOk
|
||||
@@ -670,10 +702,10 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
withAckMessage agentConnId meta $ pure ()
|
||||
ackMsgDeliveryEvent conn meta
|
||||
SENT msgId ->
|
||||
-- ? updateDirectChatItem
|
||||
-- ? updateDirectChatItemStatus
|
||||
sentMsgDeliveryEvent conn msgId
|
||||
-- TODO print errors
|
||||
MERR _ _ -> pure () -- ? updateDirectChatItem
|
||||
MERR _ _ -> pure () -- ? updateDirectChatItemStatus
|
||||
ERR _ -> pure ()
|
||||
-- TODO add debugging output
|
||||
_ -> pure ()
|
||||
@@ -683,6 +715,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
withAckMessage agentConnId msgMeta $
|
||||
case chatMsgEvent of
|
||||
XMsgNew mc -> newContentMessage ct mc msg msgMeta
|
||||
XMsgUpdate sharedMsgId mContent -> messageUpdate ct sharedMsgId mContent msg msgMeta
|
||||
XFile fInv -> processFileInvitation ct fInv msg msgMeta
|
||||
XInfo p -> xInfo ct p
|
||||
XGrpInv gInv -> processGroupInvitation ct gInv
|
||||
@@ -728,8 +761,8 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
case chatItemId_ of
|
||||
Nothing -> pure ()
|
||||
Just chatItemId -> do
|
||||
chatItem <- withStore $ \st -> updateDirectChatItem st userId contactId chatItemId CISSndSent
|
||||
toView $ CRChatItemUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem)
|
||||
chatItem <- withStore $ \st -> updateDirectChatItemStatus st userId contactId chatItemId CISSndSent
|
||||
toView $ CRChatItemStatusUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem)
|
||||
END -> do
|
||||
toView $ CRContactAnotherClient ct
|
||||
showToast (c <> "> ") "connected to another client"
|
||||
@@ -747,8 +780,8 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
case chatItemId_ of
|
||||
Nothing -> pure ()
|
||||
Just chatItemId -> do
|
||||
chatItem <- withStore $ \st -> updateDirectChatItem st userId contactId chatItemId (agentErrToItemStatus err)
|
||||
toView $ CRChatItemUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem)
|
||||
chatItem <- withStore $ \st -> updateDirectChatItemStatus st userId contactId chatItemId (agentErrToItemStatus err)
|
||||
toView $ CRChatItemStatusUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem)
|
||||
ERR _ -> pure ()
|
||||
-- TODO add debugging output
|
||||
_ -> pure ()
|
||||
@@ -822,6 +855,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
withAckMessage agentConnId msgMeta $
|
||||
case chatMsgEvent of
|
||||
XMsgNew mc -> newGroupContentMessage gInfo m mc msg msgMeta
|
||||
XMsgUpdate sharedMsgId mContent -> groupMessageUpdate gInfo sharedMsgId mContent msg
|
||||
XFile fInv -> processGroupFileInvitation gInfo m fInv msg msgMeta
|
||||
XGrpMemNew memInfo -> xGrpMemNew gInfo m memInfo
|
||||
XGrpMemIntro memInfo -> xGrpMemIntro conn gInfo m memInfo
|
||||
@@ -1000,6 +1034,13 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
showMsgToast (c <> "> ") content formattedText
|
||||
setActive $ ActiveC c
|
||||
|
||||
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> m ()
|
||||
messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc RcvMessage {msgId} msgMeta = do
|
||||
updCi <- withStore $ \st -> updateDirectChatItemByMsgId st userId contactId sharedMsgId (CIRcvMsgContent mc) msgId
|
||||
toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) updCi
|
||||
checkIntegrity msgMeta $ toView . CRMsgIntegrityError
|
||||
setActive $ ActiveC c
|
||||
|
||||
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
|
||||
newGroupContentMessage gInfo m@GroupMember {localDisplayName = c} mc msg msgMeta = do
|
||||
let content = mcContent mc
|
||||
@@ -1009,6 +1050,13 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
showMsgToast ("#" <> g <> " " <> c <> "> ") content formattedText
|
||||
setActive $ ActiveG g
|
||||
|
||||
groupMessageUpdate :: GroupInfo -> SharedMsgId -> MsgContent -> RcvMessage -> m ()
|
||||
groupMessageUpdate gInfo@GroupInfo {groupId} sharedMsgId mc RcvMessage {msgId} = do
|
||||
updCi <- withStore $ \st -> updateGroupChatItemByMsgId st user groupId sharedMsgId (CIRcvMsgContent mc) msgId
|
||||
toView . CRChatItemUpdated $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) updCi
|
||||
let g = groupName' gInfo
|
||||
setActive $ ActiveG g
|
||||
|
||||
processFileInvitation :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> m ()
|
||||
processFileInvitation ct@Contact {localDisplayName = c} fInv msg msgMeta = do
|
||||
-- TODO chunk size has to be sent as part of invitation
|
||||
@@ -1396,8 +1444,9 @@ saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} MsgMeta {broker = (_, brok
|
||||
mkChatItem :: MsgDirectionI d => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIQuote c) -> Maybe SharedMsgId -> ChatItemTs -> UTCTime -> IO (ChatItem c d)
|
||||
mkChatItem cd ciId content quotedItem sharedMsgId itemTs createdAt = do
|
||||
tz <- getCurrentTimeZone
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let itemText = ciContentToText content
|
||||
meta = mkCIMeta ciId itemText ciStatusNew sharedMsgId tz itemTs createdAt
|
||||
meta = mkCIMeta ciId itemText ciStatusNew sharedMsgId False False tz currentTs itemTs createdAt
|
||||
pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem}
|
||||
|
||||
allowAgentConnection :: ChatMonad m => Connection -> ConfirmationId -> ChatMsgEvent -> m ()
|
||||
@@ -1517,6 +1566,8 @@ chatCommandP =
|
||||
<|> "/_get items count=" *> (APIGetChatItems <$> A.decimal)
|
||||
<|> "/_send " *> (APISendMessage <$> chatTypeP <*> A.decimal <* A.space <*> msgContentP)
|
||||
<|> "/_send_quote " *> (APISendMessageQuote <$> chatTypeP <*> A.decimal <* A.space <*> A.decimal <* A.space <*> msgContentP)
|
||||
<|> "/_update item " *> (APIUpdateMessage <$> chatTypeP <*> A.decimal <* A.space <*> A.decimal <* A.space <*> msgContentP)
|
||||
<|> "/_delete item " *> (APIDeleteMessage <$> chatTypeP <*> A.decimal <* A.space <*> A.decimal <* A.space <*> msgDeleteMode)
|
||||
<|> "/_read chat " *> (APIChatRead <$> chatTypeP <*> A.decimal <* A.space <*> ((,) <$> ("from=" *> A.decimal) <* A.space <*> ("to=" *> A.decimal)))
|
||||
<|> "/_delete " *> (APIDeleteChat <$> chatTypeP <*> A.decimal)
|
||||
<|> "/_accept " *> (APIAcceptContact <$> A.decimal)
|
||||
@@ -1578,6 +1629,7 @@ chatCommandP =
|
||||
msgContentP =
|
||||
"text " *> (MCText . safeDecodeUtf8 <$> A.takeByteString)
|
||||
<|> "json " *> (J.eitherDecodeStrict' <$?> A.takeByteString)
|
||||
msgDeleteMode = "broadcast" $> MDBroadcast <|> "internal" $> MDInternal
|
||||
displayName = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' '))
|
||||
sendMsgQuote msgDir = SendMessageQuote <$> displayName <* A.space <*> pure msgDir <*> quotedMsg <*> A.takeByteString
|
||||
quotedMsg = A.char '(' *> A.takeTill (== ')') <* A.char ')' <* optional A.space
|
||||
|
||||
@@ -81,6 +81,9 @@ data ChatController = ChatController
|
||||
data HelpSection = HSMain | HSFiles | HSGroups | HSMyAddress | HSMarkdown | HSQuotes
|
||||
deriving (Show, Generic)
|
||||
|
||||
data MsgDeleteMode = MDBroadcast | MDInternal
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON HelpSection where
|
||||
toJSON = J.genericToJSON . enumJSON $ dropPrefix "HS"
|
||||
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HS"
|
||||
@@ -94,6 +97,8 @@ data ChatCommand
|
||||
| APIGetChatItems Int
|
||||
| APISendMessage ChatType Int64 MsgContent
|
||||
| APISendMessageQuote ChatType Int64 ChatItemId MsgContent
|
||||
| APIUpdateMessage ChatType Int64 ChatItemId MsgContent
|
||||
| APIDeleteMessage ChatType Int64 ChatItemId MsgDeleteMode
|
||||
| APIChatRead ChatType Int64 (ChatItemId, ChatItemId)
|
||||
| APIDeleteChat ChatType Int64
|
||||
| APIAcceptContact Int64
|
||||
@@ -146,7 +151,9 @@ data ChatResponse
|
||||
| CRApiChat {chat :: AChat}
|
||||
| CRUserSMPServers {smpServers :: [SMPServer]}
|
||||
| CRNewChatItem {chatItem :: AChatItem}
|
||||
| CRChatItemStatusUpdated {chatItem :: AChatItem}
|
||||
| CRChatItemUpdated {chatItem :: AChatItem}
|
||||
| CRChatItemDeleted {chatItem :: AChatItem}
|
||||
| CRMsgIntegrityError {msgerror :: MsgErrorType} -- TODO make it chat item to support in mobile
|
||||
| CRCmdAccepted {corr :: CorrId}
|
||||
| CRCmdOk
|
||||
@@ -295,6 +302,7 @@ data ChatErrorType
|
||||
| CEFileRcvChunk {message :: String}
|
||||
| CEFileInternal {message :: String}
|
||||
| CEInvalidQuote
|
||||
| CEInvalidMessageUpdate
|
||||
| CEAgentVersion
|
||||
| CECommandError {message :: String}
|
||||
deriving (Show, Exception, Generic)
|
||||
|
||||
@@ -22,7 +22,7 @@ import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Time.Clock (UTCTime, diffUTCTime, nominalDay)
|
||||
import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime)
|
||||
import Data.Type.Equality
|
||||
import Data.Typeable (Typeable)
|
||||
@@ -206,15 +206,19 @@ data CIMeta (d :: MsgDirection) = CIMeta
|
||||
itemText :: Text,
|
||||
itemStatus :: CIStatus d,
|
||||
itemSharedMsgId :: Maybe SharedMsgId,
|
||||
itemDeleted :: Bool,
|
||||
itemEdited :: Bool,
|
||||
editable :: Bool,
|
||||
localItemTs :: ZonedTime,
|
||||
createdAt :: UTCTime
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
mkCIMeta :: ChatItemId -> Text -> CIStatus d -> Maybe SharedMsgId -> TimeZone -> ChatItemTs -> UTCTime -> CIMeta d
|
||||
mkCIMeta itemId itemText itemStatus itemSharedMsgId tz itemTs createdAt =
|
||||
mkCIMeta :: ChatItemId -> Text -> CIStatus d -> Maybe SharedMsgId -> Bool -> Bool -> TimeZone -> UTCTime -> ChatItemTs -> UTCTime -> CIMeta d
|
||||
mkCIMeta itemId itemText itemStatus itemSharedMsgId itemDeleted itemEdited tz currentTs itemTs createdAt =
|
||||
let localItemTs = utcToZonedTime tz itemTs
|
||||
in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, localItemTs, createdAt}
|
||||
editable = diffUTCTime currentTs itemTs < nominalDay
|
||||
in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, editable, localItemTs, createdAt}
|
||||
|
||||
instance ToJSON (CIMeta d) where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
@@ -343,6 +347,8 @@ type ChatItemTs = UTCTime
|
||||
data CIContent (d :: MsgDirection) where
|
||||
CISndMsgContent :: MsgContent -> CIContent 'MDSnd
|
||||
CIRcvMsgContent :: MsgContent -> CIContent 'MDRcv
|
||||
CISndMsgDeleted :: MsgContent -> CIContent 'MDSnd
|
||||
CIRcvMsgDeleted :: MsgContent -> CIContent 'MDRcv
|
||||
CISndFileInvitation :: FileTransferId -> FilePath -> CIContent 'MDSnd
|
||||
CIRcvFileInvitation :: RcvFileTransfer -> CIContent 'MDRcv
|
||||
|
||||
@@ -352,6 +358,8 @@ ciContentToText :: CIContent d -> Text
|
||||
ciContentToText = \case
|
||||
CISndMsgContent mc -> msgContentText mc
|
||||
CIRcvMsgContent mc -> msgContentText mc
|
||||
CISndMsgDeleted _ -> "this message is deleted"
|
||||
CIRcvMsgDeleted _ -> "this message is deleted"
|
||||
CISndFileInvitation fId fPath -> "you sent file #" <> T.pack (show fId) <> ": " <> T.pack fPath
|
||||
CIRcvFileInvitation RcvFileTransfer {fileInvitation = FileInvitation {fileName}} -> "file " <> T.pack fileName
|
||||
|
||||
@@ -379,6 +387,8 @@ instance FromField ACIContent where fromField = fromTextField_ $ fmap aciContent
|
||||
data JSONCIContent
|
||||
= JCISndMsgContent {msgContent :: MsgContent}
|
||||
| JCIRcvMsgContent {msgContent :: MsgContent}
|
||||
| JCISndMsgDeleted {msgContent :: MsgContent}
|
||||
| JCIRcvMsgDeleted {msgContent :: MsgContent}
|
||||
| JCISndFileInvitation {fileId :: FileTransferId, filePath :: FilePath}
|
||||
| JCIRcvFileInvitation {rcvFileTransfer :: RcvFileTransfer}
|
||||
deriving (Generic)
|
||||
@@ -394,6 +404,8 @@ jsonCIContent :: CIContent d -> JSONCIContent
|
||||
jsonCIContent = \case
|
||||
CISndMsgContent mc -> JCISndMsgContent mc
|
||||
CIRcvMsgContent mc -> JCIRcvMsgContent mc
|
||||
CISndMsgDeleted mc -> JCISndMsgDeleted mc
|
||||
CIRcvMsgDeleted mc -> JCIRcvMsgDeleted mc
|
||||
CISndFileInvitation fId fPath -> JCISndFileInvitation fId fPath
|
||||
CIRcvFileInvitation ft -> JCIRcvFileInvitation ft
|
||||
|
||||
@@ -401,6 +413,8 @@ aciContentJSON :: JSONCIContent -> ACIContent
|
||||
aciContentJSON = \case
|
||||
JCISndMsgContent mc -> ACIContent SMDSnd $ CISndMsgContent mc
|
||||
JCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc
|
||||
JCISndMsgDeleted mc -> ACIContent SMDSnd $ CISndMsgDeleted mc
|
||||
JCIRcvMsgDeleted mc -> ACIContent SMDRcv $ CIRcvMsgDeleted mc
|
||||
JCISndFileInvitation fId fPath -> ACIContent SMDSnd $ CISndFileInvitation fId fPath
|
||||
JCIRcvFileInvitation ft -> ACIContent SMDRcv $ CIRcvFileInvitation ft
|
||||
|
||||
@@ -408,6 +422,8 @@ aciContentJSON = \case
|
||||
data DBJSONCIContent
|
||||
= DBJCISndMsgContent {msgContent :: MsgContent}
|
||||
| DBJCIRcvMsgContent {msgContent :: MsgContent}
|
||||
| DBJCISndMsgDeleted {msgContent :: MsgContent}
|
||||
| DBJCIRcvMsgDeleted {msgContent :: MsgContent}
|
||||
| DBJCISndFileInvitation {fileId :: FileTransferId, filePath :: FilePath}
|
||||
| DBJCIRcvFileInvitation {rcvFileTransfer :: RcvFileTransfer}
|
||||
deriving (Generic)
|
||||
@@ -423,6 +439,8 @@ dbJsonCIContent :: CIContent d -> DBJSONCIContent
|
||||
dbJsonCIContent = \case
|
||||
CISndMsgContent mc -> DBJCISndMsgContent mc
|
||||
CIRcvMsgContent mc -> DBJCIRcvMsgContent mc
|
||||
CISndMsgDeleted mc -> DBJCISndMsgDeleted mc
|
||||
CIRcvMsgDeleted mc -> DBJCIRcvMsgDeleted mc
|
||||
CISndFileInvitation fId fPath -> DBJCISndFileInvitation fId fPath
|
||||
CIRcvFileInvitation ft -> DBJCIRcvFileInvitation ft
|
||||
|
||||
@@ -430,6 +448,8 @@ aciContentDBJSON :: DBJSONCIContent -> ACIContent
|
||||
aciContentDBJSON = \case
|
||||
DBJCISndMsgContent mc -> ACIContent SMDSnd $ CISndMsgContent mc
|
||||
DBJCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc
|
||||
DBJCISndMsgDeleted ciId -> ACIContent SMDSnd $ CISndMsgDeleted ciId
|
||||
DBJCIRcvMsgDeleted ciId -> ACIContent SMDRcv $ CIRcvMsgDeleted ciId
|
||||
DBJCISndFileInvitation fId fPath -> ACIContent SMDSnd $ CISndFileInvitation fId fPath
|
||||
DBJCIRcvFileInvitation ft -> ACIContent SMDRcv $ CIRcvFileInvitation ft
|
||||
|
||||
|
||||
12
src/Simplex/Chat/Migrations/M20220321_chat_item_edited.hs
Normal file
12
src/Simplex/Chat/Migrations/M20220321_chat_item_edited.hs
Normal file
@@ -0,0 +1,12 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20220321_chat_item_edited where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20220321_chat_item_edited :: Query
|
||||
m20220321_chat_item_edited =
|
||||
[sql|
|
||||
ALTER TABLE chat_items ADD COLUMN item_edited INTEGER; -- 1 for edited
|
||||
|]
|
||||
@@ -109,6 +109,8 @@ instance StrEncoding ChatMessage where
|
||||
|
||||
data ChatMsgEvent
|
||||
= XMsgNew MsgContainer
|
||||
| XMsgUpdate SharedMsgId MsgContent
|
||||
| XMsgDel SharedMsgId
|
||||
| XFile FileInvitation
|
||||
| XFileAcpt String
|
||||
| XInfo Profile
|
||||
@@ -232,6 +234,8 @@ instance FromField MsgContent where
|
||||
|
||||
data CMEventTag
|
||||
= XMsgNew_
|
||||
| XMsgUpdate_
|
||||
| XMsgDel_
|
||||
| XFile_
|
||||
| XFileAcpt_
|
||||
| XInfo_
|
||||
@@ -258,6 +262,8 @@ data CMEventTag
|
||||
instance StrEncoding CMEventTag where
|
||||
strEncode = \case
|
||||
XMsgNew_ -> "x.msg.new"
|
||||
XMsgUpdate_ -> "x.msg.update"
|
||||
XMsgDel_ -> "x.msg.del"
|
||||
XFile_ -> "x.file"
|
||||
XFileAcpt_ -> "x.file.acpt"
|
||||
XInfo_ -> "x.info"
|
||||
@@ -281,6 +287,8 @@ instance StrEncoding CMEventTag where
|
||||
XUnknown_ t -> encodeUtf8 t
|
||||
strDecode = \case
|
||||
"x.msg.new" -> Right XMsgNew_
|
||||
"x.msg.update" -> Right XMsgUpdate_
|
||||
"x.msg.del" -> Right XMsgDel_
|
||||
"x.file" -> Right XFile_
|
||||
"x.file.acpt" -> Right XFileAcpt_
|
||||
"x.info" -> Right XInfo_
|
||||
@@ -307,6 +315,8 @@ instance StrEncoding CMEventTag where
|
||||
toCMEventTag :: ChatMsgEvent -> CMEventTag
|
||||
toCMEventTag = \case
|
||||
XMsgNew _ -> XMsgNew_
|
||||
XMsgUpdate _ _ -> XMsgUpdate_
|
||||
XMsgDel _ -> XMsgDel_
|
||||
XFile _ -> XFile_
|
||||
XFileAcpt _ -> XFileAcpt_
|
||||
XInfo _ -> XInfo_
|
||||
@@ -350,7 +360,9 @@ appToChatMessage AppMessage {msgId, event, params} = do
|
||||
opt :: FromJSON a => J.Key -> Either String (Maybe a)
|
||||
opt key = JT.parseEither (.:? key) params
|
||||
msg = \case
|
||||
XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params
|
||||
XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params
|
||||
XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content"
|
||||
XMsgDel_ -> XMsgDel <$> p "msgId"
|
||||
XFile_ -> XFile <$> p "file"
|
||||
XFileAcpt_ -> XFileAcpt <$> p "fileName"
|
||||
XInfo_ -> XInfo <$> p "profile"
|
||||
@@ -382,6 +394,8 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p
|
||||
key .=? value = maybe id ((:) . (key .=)) value
|
||||
params = case chatMsgEvent of
|
||||
XMsgNew container -> msgContainerJSON container
|
||||
XMsgUpdate msgId' content -> o ["msgId" .= msgId', "content" .= content]
|
||||
XMsgDel msgId' -> o ["msgId" .= msgId']
|
||||
XFile fileInv -> o ["file" .= fileInv]
|
||||
XFileAcpt fileName -> o ["fileName" .= fileName]
|
||||
XInfo profile -> o ["profile" .= profile]
|
||||
|
||||
@@ -123,8 +123,12 @@ module Simplex.Chat.Store
|
||||
getGroupChatItem,
|
||||
getDirectChatItemIdByText,
|
||||
getGroupChatItemIdByText,
|
||||
updateDirectChatItemStatus,
|
||||
updateDirectChatItem,
|
||||
updateDirectChatItemByMsgId,
|
||||
updateDirectChatItemsRead,
|
||||
updateGroupChatItem,
|
||||
updateGroupChatItemByMsgId,
|
||||
updateGroupChatItemsRead,
|
||||
getSMPServers,
|
||||
overwriteSMPServers,
|
||||
@@ -148,7 +152,7 @@ import Data.Function (on)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find, sortBy, sortOn)
|
||||
import Data.Maybe (isJust, listToMaybe)
|
||||
import Data.Maybe (fromMaybe, isJust, listToMaybe)
|
||||
import Data.Ord (Down (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
@@ -168,6 +172,7 @@ import Simplex.Chat.Migrations.M20220224_messages_fks
|
||||
import Simplex.Chat.Migrations.M20220301_smp_servers
|
||||
import Simplex.Chat.Migrations.M20220302_profile_images
|
||||
import Simplex.Chat.Migrations.M20220304_msg_quotes
|
||||
import Simplex.Chat.Migrations.M20220321_chat_item_edited
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (eitherToMaybe)
|
||||
@@ -190,7 +195,8 @@ schemaMigrations =
|
||||
("20220224_messages_fks", m20220224_messages_fks),
|
||||
("20220301_smp_servers", m20220301_smp_servers),
|
||||
("20220302_profile_images", m20220302_profile_images),
|
||||
("20220304_msg_quotes", m20220304_msg_quotes)
|
||||
("20220304_msg_quotes", m20220304_msg_quotes),
|
||||
("20220321_chat_item_edited", m20220321_chat_item_edited)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@@ -2182,7 +2188,7 @@ createNewSndChatItem st user chatDirection SndMessage {msgId, sharedMsgId} ciCon
|
||||
quoteRow :: NewQuoteRow
|
||||
quoteRow = case quotedItem of
|
||||
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing)
|
||||
Just (CIQuote {chatDir, sharedMsgId = quotedSharedMsgId, sentAt, content}) ->
|
||||
Just CIQuote {chatDir, sharedMsgId = quotedSharedMsgId, sentAt, content} ->
|
||||
uncurry (quotedSharedMsgId,Just sentAt,Just content,,) $ case chatDir of
|
||||
CIQDirectSnd -> (Just True, Nothing)
|
||||
CIQDirectRcv -> (Just False, Nothing)
|
||||
@@ -2320,7 +2326,8 @@ chatItemTs (CChatItem _ ChatItem {meta = CIMeta {itemTs}}) = itemTs
|
||||
getDirectChatPreviews_ :: DB.Connection -> User -> IO [AChat]
|
||||
getDirectChatPreviews_ db User {userId} = do
|
||||
tz <- getCurrentTimeZone
|
||||
map (toDirectChatPreview tz)
|
||||
currentTs <- getCurrentTime
|
||||
map (toDirectChatPreview tz currentTs)
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
@@ -2333,7 +2340,7 @@ getDirectChatPreviews_ db User {userId} = do
|
||||
-- ChatStats
|
||||
COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0),
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
||||
-- DirectQuote
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||
FROM contacts ct
|
||||
@@ -2370,17 +2377,18 @@ getDirectChatPreviews_ db User {userId} = do
|
||||
|]
|
||||
(CISRcvNew, userId, ConnReady, ConnSndReady)
|
||||
where
|
||||
toDirectChatPreview :: TimeZone -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat
|
||||
toDirectChatPreview tz (contactRow :. connRow :. statsRow :. ciRow_) =
|
||||
toDirectChatPreview :: TimeZone -> UTCTime -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat
|
||||
toDirectChatPreview tz currentTs (contactRow :. connRow :. statsRow :. ciRow_) =
|
||||
let contact = toContact $ contactRow :. connRow
|
||||
ci_ = toDirectChatItemList tz ciRow_
|
||||
ci_ = toDirectChatItemList tz currentTs ciRow_
|
||||
stats = toChatStats statsRow
|
||||
in AChat SCTDirect $ Chat (DirectChat contact) ci_ stats
|
||||
|
||||
getGroupChatPreviews_ :: DB.Connection -> User -> IO [AChat]
|
||||
getGroupChatPreviews_ db User {userId, userContactId} = do
|
||||
tz <- getCurrentTimeZone
|
||||
map (toGroupChatPreview tz)
|
||||
currentTs <- getCurrentTime
|
||||
map (toGroupChatPreview tz currentTs)
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
@@ -2394,7 +2402,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
|
||||
-- ChatStats
|
||||
COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0),
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
||||
-- Maybe GroupMember - sender
|
||||
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
||||
m.member_status, m.invited_by, m.local_display_name, m.contact_id,
|
||||
@@ -2433,10 +2441,10 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
|
||||
|]
|
||||
(CISRcvNew, userId, userContactId)
|
||||
where
|
||||
toGroupChatPreview :: TimeZone -> GroupInfoRow :. ChatStatsRow :. MaybeGroupChatItemRow -> AChat
|
||||
toGroupChatPreview tz (groupInfoRow :. statsRow :. ciRow_) =
|
||||
toGroupChatPreview :: TimeZone -> UTCTime -> GroupInfoRow :. ChatStatsRow :. MaybeGroupChatItemRow -> AChat
|
||||
toGroupChatPreview tz currentTs (groupInfoRow :. statsRow :. ciRow_) =
|
||||
let groupInfo = toGroupInfo userContactId groupInfoRow
|
||||
ci_ = toGroupChatItemList tz userContactId ciRow_
|
||||
ci_ = toGroupChatItemList tz currentTs userContactId ciRow_
|
||||
stats = toChatStats statsRow
|
||||
in AChat SCTGroup $ Chat (GroupChat groupInfo) ci_ stats
|
||||
|
||||
@@ -2480,13 +2488,14 @@ getDirectChatLast_ db User {userId} contactId count = do
|
||||
getDirectChatItemsLast_ :: IO (Either StoreError [CChatItem 'CTDirect])
|
||||
getDirectChatItemsLast_ = do
|
||||
tz <- getCurrentTimeZone
|
||||
mapM (toDirectChatItem tz)
|
||||
currentTs <- getCurrentTime
|
||||
mapM (toDirectChatItem tz currentTs)
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
||||
-- DirectQuote
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||
FROM chat_items i
|
||||
@@ -2507,13 +2516,14 @@ getDirectChatAfter_ db User {userId} contactId afterChatItemId count = do
|
||||
getDirectChatItemsAfter_ :: IO (Either StoreError [CChatItem 'CTDirect])
|
||||
getDirectChatItemsAfter_ = do
|
||||
tz <- getCurrentTimeZone
|
||||
mapM (toDirectChatItem tz)
|
||||
currentTs <- getCurrentTime
|
||||
mapM (toDirectChatItem tz currentTs)
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
||||
-- DirectQuote
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||
FROM chat_items i
|
||||
@@ -2534,13 +2544,14 @@ getDirectChatBefore_ db User {userId} contactId beforeChatItemId count = do
|
||||
getDirectChatItemsBefore_ :: IO (Either StoreError [CChatItem 'CTDirect])
|
||||
getDirectChatItemsBefore_ = do
|
||||
tz <- getCurrentTimeZone
|
||||
mapM (toDirectChatItem tz)
|
||||
currentTs <- getCurrentTime
|
||||
mapM (toDirectChatItem tz currentTs)
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
||||
-- DirectQuote
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||
FROM chat_items i
|
||||
@@ -2633,13 +2644,14 @@ getGroupChatLast_ db user@User {userId, userContactId} groupId count = do
|
||||
getGroupChatItemsLast_ :: IO (Either StoreError [CChatItem 'CTGroup])
|
||||
getGroupChatItemsLast_ = do
|
||||
tz <- getCurrentTimeZone
|
||||
mapM (toGroupChatItem tz userContactId)
|
||||
currentTs <- getCurrentTime
|
||||
mapM (toGroupChatItem tz currentTs userContactId)
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
||||
-- GroupMember
|
||||
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
||||
m.member_status, m.invited_by, m.local_display_name, m.contact_id,
|
||||
@@ -2672,13 +2684,14 @@ getGroupChatAfter_ db user@User {userId, userContactId} groupId afterChatItemId
|
||||
getGroupChatItemsAfter_ :: IO (Either StoreError [CChatItem 'CTGroup])
|
||||
getGroupChatItemsAfter_ = do
|
||||
tz <- getCurrentTimeZone
|
||||
mapM (toGroupChatItem tz userContactId)
|
||||
currentTs <- getCurrentTime
|
||||
mapM (toGroupChatItem tz currentTs userContactId)
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
||||
-- GroupMember
|
||||
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
||||
m.member_status, m.invited_by, m.local_display_name, m.contact_id,
|
||||
@@ -2711,13 +2724,14 @@ getGroupChatBefore_ db user@User {userId, userContactId} groupId beforeChatItemI
|
||||
getGroupChatItemsBefore_ :: IO (Either StoreError [CChatItem 'CTGroup])
|
||||
getGroupChatItemsBefore_ = do
|
||||
tz <- getCurrentTimeZone
|
||||
mapM (toGroupChatItem tz userContactId)
|
||||
currentTs <- getCurrentTime
|
||||
mapM (toGroupChatItem tz currentTs userContactId)
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
||||
-- GroupMember
|
||||
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
||||
m.member_status, m.invited_by, m.local_display_name, m.contact_id,
|
||||
@@ -2810,8 +2824,8 @@ getChatItemIdByAgentMsgId st connId msgId =
|
||||
|]
|
||||
(connId, msgId)
|
||||
|
||||
updateDirectChatItem :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> UserId -> Int64 -> ChatItemId -> CIStatus d -> m (ChatItem 'CTDirect d)
|
||||
updateDirectChatItem st userId contactId itemId itemStatus =
|
||||
updateDirectChatItemStatus :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> UserId -> Int64 -> ChatItemId -> CIStatus d -> m (ChatItem 'CTDirect d)
|
||||
updateDirectChatItemStatus st userId contactId itemId itemStatus =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
ci <- ExceptT $ (correctDir =<<) <$> getDirectChatItem_ db userId contactId itemId
|
||||
currentTs <- liftIO getCurrentTime
|
||||
@@ -2821,6 +2835,50 @@ updateDirectChatItem st userId contactId itemId itemStatus =
|
||||
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
|
||||
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
|
||||
|
||||
updateDirectChatItem :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> UserId -> Int64 -> ChatItemId -> CIContent d -> MessageId -> m (ChatItem 'CTDirect d)
|
||||
updateDirectChatItem st userId contactId itemId newContent msgId =
|
||||
liftIOEither . withTransaction st $ \db -> updateDirectChatItem_ db userId contactId itemId newContent msgId
|
||||
|
||||
updateDirectChatItem_ :: forall d. (MsgDirectionI d) => DB.Connection -> UserId -> Int64 -> ChatItemId -> CIContent d -> MessageId -> IO (Either StoreError (ChatItem 'CTDirect d))
|
||||
updateDirectChatItem_ db userId contactId itemId newContent msgId = runExceptT $ do
|
||||
ci <- ExceptT $ (correctDir =<<) <$> getDirectChatItem_ db userId contactId itemId
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let newText = ciContentToText newContent
|
||||
liftIO $
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE chat_items
|
||||
SET item_content = ?, item_text = ?, item_edited = 1, updated_at = ?
|
||||
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
(newContent, newText, currentTs, userId, contactId, itemId)
|
||||
liftIO $ DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (itemId, msgId, currentTs, currentTs)
|
||||
pure ci {content = newContent, meta = (meta ci) {itemText = newText}, formattedText = parseMaybeMarkdownList newText}
|
||||
where
|
||||
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
|
||||
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
|
||||
|
||||
updateDirectChatItemByMsgId :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> UserId -> Int64 -> SharedMsgId -> CIContent d -> MessageId -> m (ChatItem 'CTDirect d)
|
||||
updateDirectChatItemByMsgId st userId contactId sharedMsgId newContent msgId =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
itemId <- ExceptT $ getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId
|
||||
liftIOEither $ updateDirectChatItem_ db userId contactId itemId newContent msgId
|
||||
|
||||
getDirectChatItemIdBySharedMsgId_ :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> IO (Either StoreError Int64)
|
||||
getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId =
|
||||
firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND contact_id = ? AND shared_msg_id = ?
|
||||
ORDER BY chat_item_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, contactId, sharedMsgId)
|
||||
|
||||
getDirectChatItem :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> ChatItemId -> m (CChatItem 'CTDirect)
|
||||
getDirectChatItem st userId contactId itemId =
|
||||
liftIOEither . withTransaction st $ \db -> getDirectChatItem_ db userId contactId itemId
|
||||
@@ -2828,7 +2886,8 @@ getDirectChatItem st userId contactId itemId =
|
||||
getDirectChatItem_ :: DB.Connection -> UserId -> Int64 -> ChatItemId -> IO (Either StoreError (CChatItem 'CTDirect))
|
||||
getDirectChatItem_ db userId contactId itemId = do
|
||||
tz <- getCurrentTimeZone
|
||||
join <$> firstRow (toDirectChatItem tz) (SEChatItemNotFound itemId) getItem
|
||||
currentTs <- getCurrentTime
|
||||
join <$> firstRow (toDirectChatItem tz currentTs) (SEChatItemNotFound itemId) getItem
|
||||
where
|
||||
getItem =
|
||||
DB.query
|
||||
@@ -2836,7 +2895,7 @@ getDirectChatItem_ db userId contactId itemId = do
|
||||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
||||
-- DirectQuote
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||
FROM chat_items i
|
||||
@@ -2860,19 +2919,67 @@ getDirectChatItemIdByText st userId contactId msgDir quotedMsg =
|
||||
|]
|
||||
(userId, contactId, msgDir, quotedMsg <> "%")
|
||||
|
||||
getGroupChatItem :: StoreMonad m => SQLiteStore -> User -> Int64 -> ChatItemId -> m (CChatItem 'CTGroup)
|
||||
getGroupChatItem st User {userId, userContactId} groupId itemId =
|
||||
liftIOEither . withTransaction st $ \db -> do
|
||||
tz <- getCurrentTimeZone
|
||||
join <$> firstRow (toGroupChatItem tz userContactId) (SEChatItemNotFound itemId) (getItem db)
|
||||
updateGroupChatItem :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> User -> Int64 -> ChatItemId -> CIContent d -> MessageId -> m (ChatItem 'CTGroup d)
|
||||
updateGroupChatItem st user groupId itemId newContent msgId =
|
||||
liftIOEither . withTransaction st $ \db -> updateGroupChatItem_ db user groupId itemId newContent msgId
|
||||
|
||||
updateGroupChatItem_ :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> MessageId -> IO (Either StoreError (ChatItem 'CTGroup d))
|
||||
updateGroupChatItem_ db user@User {userId} groupId itemId newContent msgId = runExceptT $ do
|
||||
ci <- ExceptT $ (correctDir =<<) <$> getGroupChatItem_ db user groupId itemId
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let newText = ciContentToText newContent
|
||||
liftIO $
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE chat_items
|
||||
SET item_content = ?, item_text = ?, item_edited = 1, updated_at = ?
|
||||
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
(newContent, newText, currentTs, userId, groupId, itemId)
|
||||
liftIO $ DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (itemId, msgId, currentTs, currentTs)
|
||||
pure ci {content = newContent, meta = (meta ci) {itemText = newText}, formattedText = parseMaybeMarkdownList newText}
|
||||
where
|
||||
getItem db =
|
||||
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
|
||||
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
|
||||
|
||||
updateGroupChatItemByMsgId :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> User -> Int64 -> SharedMsgId -> CIContent d -> MessageId -> m (ChatItem 'CTGroup d)
|
||||
updateGroupChatItemByMsgId st user groupId sharedMsgId newContent msgId =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
itemId <- ExceptT $ getGroupChatItemIdBySharedMsgId_ db user groupId sharedMsgId
|
||||
liftIOEither $ updateGroupChatItem_ db user groupId itemId newContent msgId
|
||||
|
||||
getGroupChatItemIdBySharedMsgId_ :: DB.Connection -> User -> Int64 -> SharedMsgId -> IO (Either StoreError Int64)
|
||||
getGroupChatItemIdBySharedMsgId_ db User {userId} groupId sharedMsgId =
|
||||
firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND group_id = ? AND shared_msg_id = ?
|
||||
ORDER BY chat_item_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, groupId, sharedMsgId)
|
||||
|
||||
getGroupChatItem :: StoreMonad m => SQLiteStore -> User -> Int64 -> ChatItemId -> m (CChatItem 'CTGroup)
|
||||
getGroupChatItem st user groupId itemId =
|
||||
liftIOEither . withTransaction st $ \db -> getGroupChatItem_ db user groupId itemId
|
||||
|
||||
getGroupChatItem_ :: DB.Connection -> User -> Int64 -> ChatItemId -> IO (Either StoreError (CChatItem 'CTGroup))
|
||||
getGroupChatItem_ db User {userId, userContactId} groupId itemId = do
|
||||
tz <- getCurrentTimeZone
|
||||
currentTs <- liftIO getCurrentTime
|
||||
join <$> firstRow (toGroupChatItem tz currentTs userContactId) (SEChatItemNotFound itemId) getItem
|
||||
where
|
||||
getItem =
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
||||
-- GroupMember
|
||||
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
||||
m.member_status, m.invited_by, m.local_display_name, m.contact_id,
|
||||
@@ -2967,9 +3074,9 @@ type ChatStatsRow = (Int, ChatItemId)
|
||||
toChatStats :: ChatStatsRow -> ChatStats
|
||||
toChatStats (unreadCount, minUnreadItemId) = ChatStats {unreadCount, minUnreadItemId}
|
||||
|
||||
type ChatItemRow = (Int64, ChatItemTs, ACIContent, Text, ACIStatus, Maybe SharedMsgId, UTCTime)
|
||||
type ChatItemRow = (Int64, ChatItemTs, ACIContent, Text, ACIStatus, Maybe SharedMsgId, Bool, Maybe Bool, UTCTime)
|
||||
|
||||
type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId, Maybe UTCTime)
|
||||
type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId, Maybe Bool, Maybe Bool, Maybe UTCTime)
|
||||
|
||||
type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool)
|
||||
|
||||
@@ -2990,8 +3097,8 @@ toQuote :: QuoteRow -> Maybe (CIQDirection c) -> Maybe (CIQuote c)
|
||||
toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir =
|
||||
CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent)
|
||||
|
||||
toDirectChatItem :: TimeZone -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
|
||||
toDirectChatItem tz ((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, createdAt) :. quoteRow) =
|
||||
toDirectChatItem :: TimeZone -> UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
|
||||
toDirectChatItem tz currentTs ((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt) :. quoteRow) =
|
||||
case (itemContent, itemStatus) of
|
||||
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus) -> Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent
|
||||
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus) -> Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent
|
||||
@@ -3002,12 +3109,12 @@ toDirectChatItem tz ((itemId, itemTs, itemContent, itemText, itemStatus, sharedM
|
||||
CChatItem d ChatItem {chatDir, meta = ciMeta ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow}
|
||||
badItem = Left $ SEBadChatItem itemId
|
||||
ciMeta :: CIStatus d -> CIMeta d
|
||||
ciMeta status = mkCIMeta itemId itemText status sharedMsgId tz itemTs createdAt
|
||||
ciMeta status = mkCIMeta itemId itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt
|
||||
|
||||
toDirectChatItemList :: TimeZone -> MaybeChatItemRow :. QuoteRow -> [CChatItem 'CTDirect]
|
||||
toDirectChatItemList tz ((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just createdAt) :. quoteRow) =
|
||||
either (const []) (: []) $ toDirectChatItem tz ((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, createdAt) :. quoteRow)
|
||||
toDirectChatItemList _ _ = []
|
||||
toDirectChatItemList :: TimeZone -> UTCTime -> MaybeChatItemRow :. QuoteRow -> [CChatItem 'CTDirect]
|
||||
toDirectChatItemList tz currentTs ((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt) :. quoteRow) =
|
||||
either (const []) (: []) $ toDirectChatItem tz currentTs ((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt) :. quoteRow)
|
||||
toDirectChatItemList _ _ _ = []
|
||||
|
||||
type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow
|
||||
|
||||
@@ -3021,8 +3128,8 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction
|
||||
direction (Just False) Nothing = Just $ CIQGroupRcv Nothing
|
||||
direction _ _ = Nothing
|
||||
|
||||
toGroupChatItem :: TimeZone -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow -> Either StoreError (CChatItem 'CTGroup)
|
||||
toGroupChatItem tz userContactId ((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, createdAt) :. memberRow_ :. quoteRow :. quotedMemberRow_) = do
|
||||
toGroupChatItem :: TimeZone -> UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow -> Either StoreError (CChatItem 'CTGroup)
|
||||
toGroupChatItem tz currentTs userContactId ((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt) :. memberRow_ :. quoteRow :. quotedMemberRow_) = do
|
||||
let member_ = toMaybeGroupMember userContactId memberRow_
|
||||
let quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_
|
||||
case (itemContent, itemStatus, member_) of
|
||||
@@ -3035,12 +3142,12 @@ toGroupChatItem tz userContactId ((itemId, itemTs, itemContent, itemText, itemSt
|
||||
CChatItem d ChatItem {chatDir, meta = ciMeta ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_}
|
||||
badItem = Left $ SEBadChatItem itemId
|
||||
ciMeta :: CIStatus d -> CIMeta d
|
||||
ciMeta status = mkCIMeta itemId itemText status sharedMsgId tz itemTs createdAt
|
||||
ciMeta status = mkCIMeta itemId itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt
|
||||
|
||||
toGroupChatItemList :: TimeZone -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup]
|
||||
toGroupChatItemList tz userContactId ((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just createdAt) :. memberRow_ :. quoteRow :. quotedMemberRow_) =
|
||||
either (const []) (: []) $ toGroupChatItem tz userContactId ((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, createdAt) :. memberRow_ :. quoteRow :. quotedMemberRow_)
|
||||
toGroupChatItemList _ _ _ = []
|
||||
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) :. memberRow_ :. quoteRow :. quotedMemberRow_) =
|
||||
either (const []) (: []) $ toGroupChatItem tz currentTs userContactId ((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt) :. memberRow_ :. quoteRow :. quotedMemberRow_)
|
||||
toGroupChatItemList _ _ _ _ = []
|
||||
|
||||
getSMPServers :: MonadUnliftIO m => SQLiteStore -> User -> m [SMPServer]
|
||||
getSMPServers st User {userId} =
|
||||
@@ -3160,6 +3267,7 @@ data StoreError
|
||||
| SEBadChatItem {itemId :: ChatItemId}
|
||||
| SEChatItemNotFound {itemId :: ChatItemId}
|
||||
| SEQuotedChatItemNotFound
|
||||
| SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId}
|
||||
deriving (Show, Exception, Generic)
|
||||
|
||||
instance ToJSON StoreError where
|
||||
|
||||
@@ -48,7 +48,9 @@ responseToView testView = \case
|
||||
CRApiChat chat -> if testView then testViewChat chat else [plain . bshow $ J.encode chat]
|
||||
CRUserSMPServers smpServers -> viewSMPServers smpServers testView
|
||||
CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item
|
||||
CRChatItemUpdated _ -> []
|
||||
CRChatItemStatusUpdated _ -> []
|
||||
CRChatItemUpdated (AChatItem _ _ chat item) -> viewMessageUpdate chat item
|
||||
CRChatItemDeleted _ -> [] -- TODO
|
||||
CRMsgIntegrityError mErr -> viewMsgIntegrityError mErr
|
||||
CRCmdAccepted _ -> []
|
||||
CRCmdOk -> ["ok"]
|
||||
@@ -166,11 +168,13 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem} = case chat of
|
||||
DirectChat c -> case chatDir of
|
||||
CIDirectSnd -> case content of
|
||||
CISndMsgContent mc -> viewSentMessage to quote mc meta
|
||||
CISndMsgDeleted _mc -> []
|
||||
CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta
|
||||
where
|
||||
to = ttyToContact' c
|
||||
CIDirectRcv -> case content of
|
||||
CIRcvMsgContent mc -> viewReceivedMessage from quote meta mc
|
||||
CIRcvMsgDeleted _mc -> []
|
||||
CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft
|
||||
where
|
||||
from = ttyFromContact' c
|
||||
@@ -179,33 +183,62 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem} = case chat of
|
||||
GroupChat g -> case chatDir of
|
||||
CIGroupSnd -> case content of
|
||||
CISndMsgContent mc -> viewSentMessage to quote mc meta
|
||||
CISndMsgDeleted _mc -> []
|
||||
CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta
|
||||
where
|
||||
to = ttyToGroup g
|
||||
CIGroupRcv m -> case content of
|
||||
CIRcvMsgContent mc -> viewReceivedMessage from quote meta mc
|
||||
CIRcvMsgDeleted _mc -> []
|
||||
CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft
|
||||
where
|
||||
from = ttyFromGroup' g m
|
||||
where
|
||||
quote = maybe [] (groupQuote g) quotedItem
|
||||
_ -> []
|
||||
where
|
||||
directQuote :: forall d'. MsgDirectionI d' => CIDirection 'CTDirect d' -> CIQuote 'CTDirect -> [StyledString]
|
||||
directQuote _ CIQuote {content = qmc, chatDir = qouteDir} =
|
||||
quoteText qmc $ if toMsgDirection (msgDirection @d') == quoteMsgDirection qouteDir then ">>" else ">"
|
||||
groupQuote :: GroupInfo -> CIQuote 'CTGroup -> [StyledString]
|
||||
groupQuote g CIQuote {content = qmc, chatDir = quoteDir} = quoteText qmc . ttyQuotedMember $ sentByMember g quoteDir
|
||||
sentByMember :: GroupInfo -> CIQDirection 'CTGroup -> Maybe GroupMember
|
||||
sentByMember GroupInfo {membership} = \case
|
||||
CIQGroupSnd -> Just membership
|
||||
CIQGroupRcv m -> m
|
||||
quoteText qmc sentBy = prependFirst (sentBy <> " ") $ msgPreview qmc
|
||||
msgPreview = msgPlain . preview . msgContentText
|
||||
|
||||
viewMessageUpdate :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> [StyledString]
|
||||
viewMessageUpdate chat ChatItem {chatDir, meta, content, quotedItem} = case chat of
|
||||
DirectChat Contact {localDisplayName = c} -> case chatDir of
|
||||
CIDirectRcv -> case content of
|
||||
CIRcvMsgContent mc -> viewReceivedMessage from quote meta mc
|
||||
_ -> []
|
||||
where
|
||||
preview t
|
||||
| T.length t <= 60 = t
|
||||
| otherwise = t <> "..."
|
||||
from = ttyFromContactEdited c
|
||||
quote = maybe [] (directQuote chatDir) quotedItem
|
||||
CIDirectSnd -> []
|
||||
GroupChat g -> case chatDir of
|
||||
CIGroupRcv GroupMember {localDisplayName = m} -> case content of
|
||||
CIRcvMsgContent mc -> viewReceivedMessage from quote meta mc
|
||||
_ -> []
|
||||
where
|
||||
from = ttyFromGroupEdited g m
|
||||
quote = maybe [] (groupQuote g) quotedItem
|
||||
CIGroupSnd -> []
|
||||
where
|
||||
_ -> []
|
||||
|
||||
directQuote :: forall d'. MsgDirectionI d' => CIDirection 'CTDirect d' -> CIQuote 'CTDirect -> [StyledString]
|
||||
directQuote _ CIQuote {content = qmc, chatDir = quoteDir} =
|
||||
quoteText qmc $ if toMsgDirection (msgDirection @d') == quoteMsgDirection quoteDir then ">>" else ">"
|
||||
|
||||
groupQuote :: GroupInfo -> CIQuote 'CTGroup -> [StyledString]
|
||||
groupQuote g CIQuote {content = qmc, chatDir = quoteDir} = quoteText qmc . ttyQuotedMember $ sentByMember g quoteDir
|
||||
|
||||
sentByMember :: GroupInfo -> CIQDirection 'CTGroup -> Maybe GroupMember
|
||||
sentByMember GroupInfo {membership} = \case
|
||||
CIQGroupSnd -> Just membership
|
||||
CIQGroupRcv m -> m
|
||||
|
||||
quoteText :: MsgContent -> StyledString -> [StyledString]
|
||||
quoteText qmc sentBy = prependFirst (sentBy <> " ") $ msgPreview qmc
|
||||
|
||||
msgPreview :: MsgContent -> [StyledString]
|
||||
msgPreview = msgPlain . preview . msgContentText
|
||||
where
|
||||
preview t
|
||||
| T.length t <= 60 = t
|
||||
| otherwise = t <> "..."
|
||||
|
||||
viewMsgIntegrityError :: MsgErrorType -> [StyledString]
|
||||
viewMsgIntegrityError err = msgError $ case err of
|
||||
@@ -552,6 +585,7 @@ viewChatError = \case
|
||||
CEFileRcvChunk e -> ["error receiving file: " <> plain e]
|
||||
CEFileInternal e -> ["file error: " <> plain e]
|
||||
CEInvalidQuote -> ["cannot reply to this message"]
|
||||
CEInvalidMessageUpdate -> ["cannot update this message"]
|
||||
CEAgentVersion -> ["unsupported agent version"]
|
||||
CECommandError e -> ["bad chat command: " <> plain e]
|
||||
-- e -> ["chat error: " <> sShow e]
|
||||
@@ -602,6 +636,9 @@ ttyToContact c = styled (colored Cyan) $ "@" <> c <> " "
|
||||
ttyFromContact :: ContactName -> StyledString
|
||||
ttyFromContact c = ttyFrom $ c <> "> "
|
||||
|
||||
ttyFromContactEdited :: ContactName -> StyledString
|
||||
ttyFromContactEdited c = ttyFrom $ c <> "> [edited] "
|
||||
|
||||
ttyToContact' :: Contact -> StyledString
|
||||
ttyToContact' Contact {localDisplayName = c} = ttyToContact c
|
||||
|
||||
@@ -633,6 +670,9 @@ ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullN
|
||||
ttyFromGroup :: GroupInfo -> ContactName -> StyledString
|
||||
ttyFromGroup GroupInfo {localDisplayName = g} c = ttyFrom $ "#" <> g <> " " <> c <> "> "
|
||||
|
||||
ttyFromGroupEdited :: GroupInfo -> ContactName -> StyledString
|
||||
ttyFromGroupEdited GroupInfo {localDisplayName = g} c = ttyFrom $ "#" <> g <> " " <> c <> "> [edited] "
|
||||
|
||||
ttyFrom :: Text -> StyledString
|
||||
ttyFrom = styled $ colored Yellow
|
||||
|
||||
|
||||
@@ -36,6 +36,7 @@ packages:
|
||||
#
|
||||
extra-deps:
|
||||
- cryptostore-0.2.1.0@sha256:9896e2984f36a1c8790f057fd5ce3da4cbcaf8aa73eb2d9277916886978c5b19,3881
|
||||
- network-3.1.2.7@sha256:e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568,4888
|
||||
- simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079
|
||||
- tls-1.5.7@sha256:1cc30253a9696b65a9cafc0317fbf09f7dcea15e3a145ed6c9c0e28c632fa23a,6991
|
||||
# below hackage dependancies are to update Aeson to 2.0.3
|
||||
|
||||
@@ -35,6 +35,7 @@ chatTests = do
|
||||
describe "direct messages" $ do
|
||||
it "add contact and send/receive message" testAddContact
|
||||
it "direct message quoted replies" testDirectMessageQuotedReply
|
||||
it "direct message update" testDirectMessageUpdate
|
||||
describe "chat groups" $ do
|
||||
it "add contacts, create group and send/receive messages" testGroup
|
||||
it "create and join group with 4 members" testGroup2
|
||||
@@ -44,6 +45,7 @@ chatTests = do
|
||||
it "remove contact from group and add again" testGroupRemoveAdd
|
||||
it "list groups containing group invitations" testGroupList
|
||||
it "group message quoted replies" testGroupMessageQuotedReply
|
||||
it "group message update" testGroupMessageUpdate
|
||||
describe "user profiles" $ do
|
||||
it "update user profiles and notify contacts" testUpdateProfile
|
||||
it "update user profile with image" testUpdateProfileImage
|
||||
@@ -150,6 +152,59 @@ testDirectMessageQuotedReply = do
|
||||
bob #$> ("/_get chat @2 count=1", chat', [((1, "will tell more"), Just (1, "all good - you?"))])
|
||||
alice #$> ("/_get chat @2 count=1", chat', [((0, "will tell more"), Just (0, "all good - you?"))])
|
||||
|
||||
testDirectMessageUpdate :: IO ()
|
||||
testDirectMessageUpdate = do
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice bob -> do
|
||||
connectUsers alice bob
|
||||
|
||||
-- msg id 1
|
||||
alice #> "@bob hello 🙂"
|
||||
bob <# "alice> hello 🙂"
|
||||
|
||||
-- msg id 2
|
||||
bob `send` "> @alice (hello) hi alice"
|
||||
bob <# "@alice > hello 🙂"
|
||||
bob <## " hi alice"
|
||||
alice <# "bob> > hello 🙂"
|
||||
alice <## " hi alice"
|
||||
|
||||
alice #$> ("/_get chat @2 count=100", chat', [((1, "hello 🙂"), Nothing), ((0, "hi alice"), Just (1, "hello 🙂"))])
|
||||
bob #$> ("/_get chat @2 count=100", chat', [((0, "hello 🙂"), Nothing), ((1, "hi alice"), Just (0, "hello 🙂"))])
|
||||
|
||||
alice ##> "/_update item @2 1 text hey 👋"
|
||||
bob <# "alice> [edited] hey 👋"
|
||||
|
||||
alice #$> ("/_get chat @2 count=100", chat', [((1, "hey 👋"), Nothing), ((0, "hi alice"), Just (1, "hello 🙂"))])
|
||||
bob #$> ("/_get chat @2 count=100", chat', [((0, "hey 👋"), Nothing), ((1, "hi alice"), Just (0, "hello 🙂"))])
|
||||
|
||||
-- msg id 3
|
||||
bob `send` "> @alice (hey) hey alice"
|
||||
bob <# "@alice > hey 👋"
|
||||
bob <## " hey alice"
|
||||
alice <# "bob> > hey 👋"
|
||||
alice <## " hey alice"
|
||||
|
||||
alice #$> ("/_get chat @2 count=100", chat', [((1, "hey 👋"), Nothing), ((0, "hi alice"), Just (1, "hello 🙂")), ((0, "hey alice"), Just (1, "hey 👋"))])
|
||||
bob #$> ("/_get chat @2 count=100", chat', [((0, "hey 👋"), Nothing), ((1, "hi alice"), Just (0, "hello 🙂")), ((1, "hey alice"), Just (0, "hey 👋"))])
|
||||
|
||||
alice ##> "/_update item @2 1 text greetings 🤝"
|
||||
bob <# "alice> [edited] greetings 🤝"
|
||||
|
||||
alice #$> ("/_get chat @2 count=100", chat', [((1, "greetings 🤝"), Nothing), ((0, "hi alice"), Just (1, "hello 🙂")), ((0, "hey alice"), Just (1, "hey 👋"))])
|
||||
bob #$> ("/_get chat @2 count=100", chat', [((0, "greetings 🤝"), Nothing), ((1, "hi alice"), Just (0, "hello 🙂")), ((1, "hey alice"), Just (0, "hey 👋"))])
|
||||
|
||||
bob ##> "/_update item @2 2 text hey Alice"
|
||||
alice <# "bob> [edited] > hello 🙂"
|
||||
alice <## " hey Alice"
|
||||
|
||||
bob ##> "/_update item @2 3 text greetings Alice"
|
||||
alice <# "bob> [edited] > hey 👋"
|
||||
alice <## " greetings Alice"
|
||||
|
||||
alice #$> ("/_get chat @2 count=100", chat', [((1, "greetings 🤝"), Nothing), ((0, "hey Alice"), Just (1, "hello 🙂")), ((0, "greetings Alice"), Just (1, "hey 👋"))])
|
||||
bob #$> ("/_get chat @2 count=100", chat', [((0, "greetings 🤝"), Nothing), ((1, "hey Alice"), Just (0, "hello 🙂")), ((1, "greetings Alice"), Just (0, "hey 👋"))])
|
||||
|
||||
testGroup :: IO ()
|
||||
testGroup =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
@@ -619,7 +674,7 @@ testGroupMessageQuotedReply =
|
||||
cath #$> ("/_get chat #1 count=1", chat', [((1, "hi there!"), Just (0, "hello, all good, you?"))])
|
||||
alice #$> ("/_get chat #1 count=1", chat', [((0, "hi there!"), Just (0, "hello, all good, you?"))])
|
||||
bob #$> ("/_get chat #1 count=1", chat', [((0, "hi there!"), Just (1, "hello, all good, you?"))])
|
||||
alice `send ` "> #team (will tell) go on"
|
||||
alice `send` "> #team (will tell) go on"
|
||||
alice <# "#team > bob will tell more"
|
||||
alice <## " go on"
|
||||
concurrently_
|
||||
@@ -632,6 +687,66 @@ testGroupMessageQuotedReply =
|
||||
cath <## " go on"
|
||||
)
|
||||
|
||||
testGroupMessageUpdate :: IO ()
|
||||
testGroupMessageUpdate = do
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
alice #> "#team hello!"
|
||||
concurrently_
|
||||
(bob <# "#team alice> hello!")
|
||||
(cath <# "#team alice> hello!")
|
||||
|
||||
alice ##> "/_update item #1 1 text hey 👋"
|
||||
concurrently_
|
||||
(bob <# "#team alice> [edited] hey 👋")
|
||||
(cath <# "#team alice> [edited] hey 👋")
|
||||
|
||||
alice #$> ("/_get chat #1 count=100", chat', [((1, "hey 👋"), Nothing)])
|
||||
bob #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing)])
|
||||
cath #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing)])
|
||||
|
||||
threadDelay 1000000
|
||||
bob `send` "> #team @alice (hey) hi alice"
|
||||
bob <# "#team > alice hey 👋"
|
||||
bob <## " hi alice"
|
||||
concurrently_
|
||||
( do
|
||||
alice <# "#team bob> > alice hey 👋"
|
||||
alice <## " hi alice"
|
||||
)
|
||||
( do
|
||||
cath <# "#team bob> > alice hey 👋"
|
||||
cath <## " hi alice"
|
||||
)
|
||||
|
||||
alice #$> ("/_get chat #1 count=100", chat', [((1, "hey 👋"), Nothing), ((0, "hi alice"), Just (1, "hey 👋"))])
|
||||
bob #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing), ((1, "hi alice"), Just (0, "hey 👋"))])
|
||||
cath #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing), ((0, "hi alice"), Just (0, "hey 👋"))])
|
||||
|
||||
alice ##> "/_update item #1 1 text greetings 🤝"
|
||||
concurrently_
|
||||
(bob <# "#team alice> [edited] greetings 🤝")
|
||||
(cath <# "#team alice> [edited] greetings 🤝")
|
||||
|
||||
threadDelay 1000000
|
||||
cath `send` "> #team @alice (greetings) greetings!"
|
||||
cath <# "#team > alice greetings 🤝"
|
||||
cath <## " greetings!"
|
||||
concurrently_
|
||||
( do
|
||||
alice <# "#team cath> > alice greetings 🤝"
|
||||
alice <## " greetings!"
|
||||
)
|
||||
( do
|
||||
bob <# "#team cath> > alice greetings 🤝"
|
||||
bob <## " greetings!"
|
||||
)
|
||||
|
||||
alice #$> ("/_get chat #1 count=100", chat', [((1, "greetings 🤝"), Nothing), ((0, "hi alice"), Just (1, "hey 👋")), ((0, "greetings!"), Just (1, "greetings 🤝"))])
|
||||
bob #$> ("/_get chat #1 count=100", chat', [((0, "greetings 🤝"), Nothing), ((1, "hi alice"), Just (0, "hey 👋")), ((0, "greetings!"), Just (0, "greetings 🤝"))])
|
||||
cath #$> ("/_get chat #1 count=100", chat', [((0, "greetings 🤝"), Nothing), ((0, "hi alice"), Just (0, "hey 👋")), ((1, "greetings!"), Just (0, "greetings 🤝"))])
|
||||
|
||||
testUpdateProfile :: IO ()
|
||||
testUpdateProfile =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
|
||||
Reference in New Issue
Block a user