mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
core: add notes chat type (#3568)
* Add chat type "self"
* rename to Notes
* cover more things
* remove quote, tweak sql
* resolve comments
* constrain ACIQDirection to exclude CTLocal
* add CILocalRcv handling
* plug in migrations and tests
* cover more API, implement new folders
* working create/send/tail
* remove interaction with messages
* add note deletion (api-only)
* add folder deletion
* add getLocalChatItemIdByText
* add APICreateChatItem and files
* add protocol check for getFileTransfer protocol
* replace FTLocal with createLocalFile
* add chat previews
* add folder clear
* add reactions
* add read/unread
* add note updates
* resolve some comments
* remove local reactions
* remove folder names, deletion, add autocreate
* add file deletion check
* add preview pagination test
* add per-item file deletion check
* pull mkChatItem out of createLocal to prevent ci record updates
* use - as notes name
* bump migration ts
* update schema
* resolve comments
* add chat pagination test
* use chat queries from Direct instead
* evict note folders from createUserRecord
* switch to - for note folder chat type prefix and use empty name
* fix getLocalChatXxx
* add explicit createCCNoteFolder for tests
* use overloadedstrings for single-line queries
* add suggested chat list tests
* add notes chat to a user-creating test
* throw correct error for missing file
* remove unique check from schema
* add UndecidableInstances for ghc8.10
* switch to * for chat type sigil
* add file safety test
* add drop index
* remove indentation
* remove repeated folder
* remove redundant filter query, NoteFolderName
* don't attempt to cancel local files when deleting chat item
* rename function
* fix comment
* rename
* fix merge
* fix typo
* remove editable limit
* restore comment
* remove local file cancel
* Revert "remove editable limit"
This reverts commit 65df55caf8.
* refactor
---------
Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Alexander Bondarenko
GitHub
parent
5b7a09f488
commit
bc8a6f4833
20 changed files with 1000 additions and 68 deletions
|
|
@ -129,6 +129,7 @@ library
|
|||
Simplex.Chat.Migrations.M20231207_chat_list_pagination
|
||||
Simplex.Chat.Migrations.M20231214_item_content_tag
|
||||
Simplex.Chat.Migrations.M20231215_recreate_msg_deliveries
|
||||
Simplex.Chat.Migrations.M20240102_note_folders
|
||||
Simplex.Chat.Mobile
|
||||
Simplex.Chat.Mobile.File
|
||||
Simplex.Chat.Mobile.Shared
|
||||
|
|
@ -150,6 +151,7 @@ library
|
|||
Simplex.Chat.Store.Groups
|
||||
Simplex.Chat.Store.Messages
|
||||
Simplex.Chat.Store.Migrations
|
||||
Simplex.Chat.Store.NoteFolders
|
||||
Simplex.Chat.Store.Profiles
|
||||
Simplex.Chat.Store.Remote
|
||||
Simplex.Chat.Store.Shared
|
||||
|
|
@ -541,6 +543,7 @@ test-suite simplex-chat-test
|
|||
ChatTests.Direct
|
||||
ChatTests.Files
|
||||
ChatTests.Groups
|
||||
ChatTests.Local
|
||||
ChatTests.Profiles
|
||||
ChatTests.Utils
|
||||
JSONTests
|
||||
|
|
|
|||
|
|
@ -73,6 +73,7 @@ import Simplex.Chat.Store.Direct
|
|||
import Simplex.Chat.Store.Files
|
||||
import Simplex.Chat.Store.Groups
|
||||
import Simplex.Chat.Store.Messages
|
||||
import Simplex.Chat.Store.NoteFolders
|
||||
import Simplex.Chat.Store.Profiles
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
|
|
@ -465,6 +466,7 @@ processChatCommand' vr = \case
|
|||
ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure
|
||||
user <- withStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts
|
||||
when (auId == 1) $ withStore (\db -> createContact db user simplexContactProfile) `catchChatError` \_ -> pure ()
|
||||
withStore $ \db -> createNoteFolder db user
|
||||
storeServers user smpServers
|
||||
storeServers user xftpServers
|
||||
atomically . writeTVar u $ Just user
|
||||
|
|
@ -630,6 +632,9 @@ processChatCommand' vr = \case
|
|||
CTGroup -> do
|
||||
groupChat <- withStore (\db -> getGroupChat db vr user cId pagination search)
|
||||
pure $ CRApiChat user (AChat SCTGroup groupChat)
|
||||
CTLocal -> do
|
||||
localChat <- withStore (\db -> getLocalChat db user cId pagination search)
|
||||
pure $ CRApiChat user (AChat SCTLocal localChat)
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not implemented"
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIGetChatItems pagination search -> withUser $ \user -> do
|
||||
|
|
@ -761,6 +766,7 @@ processChatCommand' vr = \case
|
|||
void . withStore' $ \db -> createSndGroupInlineFT db m conn ft
|
||||
sendMemberFileInline m conn ft sharedMsgId
|
||||
processMember _ = pure ()
|
||||
CTLocal -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
where
|
||||
|
|
@ -792,6 +798,22 @@ processChatCommand' vr = \case
|
|||
unzipMaybe3 :: Maybe (a, b, c) -> (Maybe a, Maybe b, Maybe c)
|
||||
unzipMaybe3 (Just (a, b, c)) = (Just a, Just b, Just c)
|
||||
unzipMaybe3 _ = (Nothing, Nothing, Nothing)
|
||||
APICreateChatItem folderId (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user -> do
|
||||
forM_ quotedItemId_ $ \_ -> throwError $ ChatError $ CECommandError "not supported"
|
||||
nf <- withStore $ \db -> getNoteFolder db user folderId
|
||||
createdAt <- liftIO getCurrentTime
|
||||
let content = CISndMsgContent mc
|
||||
let cd = CDLocalSnd nf
|
||||
ciId <- createLocalChatItem user cd content createdAt
|
||||
ciFile_ <- forM file_ $ \cf@CryptoFile {filePath, cryptoArgs} -> do
|
||||
fsFilePath <- toFSFilePath filePath
|
||||
fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cryptoArgs
|
||||
chunkSize <- asks $ fileChunkSize . config
|
||||
withStore' $ \db -> do
|
||||
fileId <- createLocalFile CIFSSndStored db user nf ciId createdAt cf fileSize chunkSize
|
||||
pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal}
|
||||
let ci = mkChatItem cd ciId content ciFile_ Nothing Nothing Nothing False createdAt Nothing createdAt
|
||||
pure . CRNewChatItem user $ AChatItem SCTLocal SMDSnd (LocalChat nf) ci
|
||||
APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> withChatLock "updateChatItem" $ case cType of
|
||||
CTDirect -> do
|
||||
ct@Contact {contactId} <- withStore $ \db -> getContact db user chatId
|
||||
|
|
@ -837,6 +859,17 @@ processChatCommand' vr = \case
|
|||
else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
|
||||
_ -> throwChatError CEInvalidChatItemUpdate
|
||||
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
|
||||
CTLocal -> do
|
||||
(nf@NoteFolder {noteFolderId}, cci) <- withStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId
|
||||
case cci of
|
||||
CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent oldMC}
|
||||
| mc == oldMC -> pure $ CRChatItemNotChanged user (AChatItem SCTLocal SMDSnd (LocalChat nf) ci)
|
||||
| otherwise -> withStore' $ \db -> do
|
||||
currentTs <- getCurrentTime
|
||||
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
|
||||
ci' <- updateLocalChatItem' db user noteFolderId ci (CISndMsgContent mc)
|
||||
pure $ CRChatItemUpdated user (AChatItem SCTLocal SMDSnd (LocalChat nf) ci')
|
||||
_ -> throwChatError CEInvalidChatItemUpdate
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user -> withChatLock "deleteChatItem" $ case cType of
|
||||
|
|
@ -861,6 +894,9 @@ processChatCommand' vr = \case
|
|||
(SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms $ XMsgDel itemSharedMId Nothing
|
||||
delGroupChatItem user gInfo ci msgId Nothing
|
||||
(CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete
|
||||
CTLocal -> do
|
||||
(nf, CChatItem _ ci) <- withStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId
|
||||
deleteLocalCI user nf ci True False
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withChatLock "deleteChatItem" $ do
|
||||
|
|
@ -911,6 +947,7 @@ processChatCommand' vr = \case
|
|||
r = ACIReaction SCTGroup SMDSnd (GroupChat g) $ CIReaction CIGroupSnd ci' createdAt reaction
|
||||
pure $ CRChatItemReaction user add r
|
||||
_ -> throwChatError $ CECommandError "reaction not possible - no shared item ID"
|
||||
CTLocal -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
where
|
||||
|
|
@ -942,6 +979,10 @@ processChatCommand' vr = \case
|
|||
startProximateTimedItemThread user (ChatRef CTGroup chatId, itemId) deleteAt
|
||||
withStore' $ \db -> updateGroupChatItemsRead db userId chatId fromToIds
|
||||
ok user
|
||||
CTLocal -> do
|
||||
user <- withStore $ \db -> getUserByNoteFolderId db chatId
|
||||
withStore' $ \db -> updateLocalChatItemsRead db user chatId fromToIds
|
||||
ok user
|
||||
CTContactRequest -> pure $ chatCmdError Nothing "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError Nothing "not supported"
|
||||
APIChatUnread (ChatRef cType chatId) unreadChat -> withUser $ \user -> case cType of
|
||||
|
|
@ -955,6 +996,11 @@ processChatCommand' vr = \case
|
|||
Group {groupInfo} <- getGroup db vr user chatId
|
||||
liftIO $ updateGroupUnreadChat db user groupInfo unreadChat
|
||||
ok user
|
||||
CTLocal -> do
|
||||
withStore $ \db -> do
|
||||
nf <- getNoteFolder db user chatId
|
||||
liftIO $ updateNoteFolderUnreadChat db user nf unreadChat
|
||||
ok user
|
||||
_ -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIDeleteChat (ChatRef cType chatId) notify -> withUser $ \user@User {userId} -> case cType of
|
||||
CTDirect -> do
|
||||
|
|
@ -1012,8 +1058,9 @@ processChatCommand' vr = \case
|
|||
withStore' (\db -> setContactDeleted db user ct)
|
||||
`catchChatError` (toView . CRChatError (Just user))
|
||||
pure $ map aConnId conns
|
||||
CTLocal -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIClearChat (ChatRef cType chatId) -> withUser $ \user -> case cType of
|
||||
APIClearChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of
|
||||
CTDirect -> do
|
||||
ct <- withStore $ \db -> getContact db user chatId
|
||||
filesInfo <- withStore' $ \db -> getContactFileInfo db user ct
|
||||
|
|
@ -1028,6 +1075,14 @@ processChatCommand' vr = \case
|
|||
membersToDelete <- withStore' $ \db -> getGroupMembersForExpiration db user gInfo
|
||||
forM_ membersToDelete $ \m -> withStore' $ \db -> deleteGroupMember db user m
|
||||
pure $ CRChatCleared user (AChatInfo SCTGroup $ GroupChat gInfo)
|
||||
CTLocal -> do
|
||||
nf <- withStore $ \db -> getNoteFolder db user chatId
|
||||
filesInfo <- withStore' $ \db -> getNoteFolderFileInfo db user nf
|
||||
withChatLock "clearChat local" . procCmd $ do
|
||||
mapM_ (deleteFile user) filesInfo
|
||||
withStore' $ \db -> deleteNoteFolderFiles db userId nf
|
||||
withStore' $ \db -> deleteNoteFolderCIs db user nf
|
||||
pure $ CRChatCleared user (AChatInfo SCTLocal $ LocalChat nf)
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIAcceptContact incognito connReqId -> withUser $ \_ -> withChatLock "acceptContact" $ do
|
||||
|
|
@ -1513,6 +1568,11 @@ processChatCommand' vr = \case
|
|||
gId <- withStore $ \db -> getGroupIdByName db user name
|
||||
let chatRef = ChatRef CTGroup gId
|
||||
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc
|
||||
CTLocal
|
||||
| name == "" -> do
|
||||
folderId <- withStore (`getUserNoteFolderId` user)
|
||||
processChatCommand . APICreateChatItem folderId $ ComposedMessage Nothing Nothing mc
|
||||
| otherwise -> throwChatError $ CECommandError "not supported"
|
||||
_ -> throwChatError $ CECommandError "not supported"
|
||||
SendMemberContactMessage gName mName msg -> withUser $ \user -> do
|
||||
(gId, mId) <- getGroupAndMemberId user gName mName
|
||||
|
|
@ -1806,6 +1866,9 @@ processChatCommand' vr = \case
|
|||
quotedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId cName quotedMsg
|
||||
let mc = MCText msg
|
||||
processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc
|
||||
ClearNoteFolder -> withUser $ \user -> do
|
||||
folderId <- withStore (`getUserNoteFolderId` user)
|
||||
processChatCommand $ APIClearChat (ChatRef CTLocal folderId)
|
||||
LastChats count_ -> withUser' $ \user -> do
|
||||
let count = fromMaybe 5000 count_
|
||||
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db vr user False (PTLast count) clqNoFilters)
|
||||
|
|
@ -1841,7 +1904,9 @@ processChatCommand' vr = \case
|
|||
asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_
|
||||
SendFile chatName f -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCFile "")
|
||||
case chatRef of
|
||||
ChatRef CTLocal folderId -> processChatCommand . APICreateChatItem folderId $ ComposedMessage (Just f) Nothing (MCFile "")
|
||||
_ -> processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCFile "")
|
||||
SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
filePath <- toFSFilePath fPath
|
||||
|
|
@ -1913,6 +1978,8 @@ processChatCommand' vr = \case
|
|||
FileStatus fileId -> withUser $ \user -> do
|
||||
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
case file of
|
||||
Just CIFile {fileProtocol = FPLocal} ->
|
||||
throwChatError $ CECommandError "not supported for local files"
|
||||
Just CIFile {fileProtocol = FPXFTP} ->
|
||||
pure $ CRFileTransferStatusXFTP user ci
|
||||
_ -> do
|
||||
|
|
@ -2024,6 +2091,9 @@ processChatCommand' vr = \case
|
|||
ChatRef cType <$> case cType of
|
||||
CTDirect -> withStore $ \db -> getContactIdByName db user name
|
||||
CTGroup -> withStore $ \db -> getGroupIdByName db user name
|
||||
CTLocal
|
||||
| name == "" -> withStore (`getUserNoteFolderId` user)
|
||||
| otherwise -> throwChatError $ CECommandError "not supported"
|
||||
_ -> throwChatError $ CECommandError "not supported"
|
||||
checkChatStopped :: m ChatResponse -> m ChatResponse
|
||||
checkChatStopped a = asks agentAsync >>= readTVarIO >>= maybe a (const $ throwChatError CEChatNotStopped)
|
||||
|
|
@ -2057,11 +2127,13 @@ processChatCommand' vr = \case
|
|||
getSentChatItemIdByText user@User {userId, localDisplayName} (ChatRef cType cId) msg = case cType of
|
||||
CTDirect -> withStore $ \db -> getDirectChatItemIdByText db userId cId SMDSnd msg
|
||||
CTGroup -> withStore $ \db -> getGroupChatItemIdByText db user cId (Just localDisplayName) msg
|
||||
CTLocal -> withStore $ \db -> getLocalChatItemIdByText db user cId SMDSnd msg
|
||||
_ -> throwChatError $ CECommandError "not supported"
|
||||
getChatItemIdByText :: User -> ChatRef -> Text -> m Int64
|
||||
getChatItemIdByText user (ChatRef cType cId) msg = case cType of
|
||||
CTDirect -> withStore $ \db -> getDirectChatItemIdByText' db user cId msg
|
||||
CTGroup -> withStore $ \db -> getGroupChatItemIdByText' db user cId msg
|
||||
CTLocal -> withStore $ \db -> getLocalChatItemIdByText' db user cId msg
|
||||
_ -> throwChatError $ CECommandError "not supported"
|
||||
connectViaContact :: User -> IncognitoEnabled -> ConnectionRequestUri 'CMContact -> m ChatResponse
|
||||
connectViaContact user@User {userId} incognito cReq@(CRContactUri ConnReqUriData {crClientData}) = withChatLock "connectViaContact" $ do
|
||||
|
|
@ -2532,15 +2604,17 @@ deleteFile user fileInfo = deleteFile' user fileInfo False
|
|||
deleteFile' :: forall m. ChatMonad m => User -> CIFileInfo -> Bool -> m [ConnId]
|
||||
deleteFile' user ciFileInfo@CIFileInfo {filePath} sendCancel = do
|
||||
aConnIds <- cancelFile' user ciFileInfo sendCancel
|
||||
delete `catchChatError` (toView . CRChatError (Just user))
|
||||
forM_ filePath $ \fPath ->
|
||||
deleteFileLocally fPath `catchChatError` (toView . CRChatError (Just user))
|
||||
pure aConnIds
|
||||
|
||||
deleteFileLocally :: forall m. ChatMonad m => FilePath -> m ()
|
||||
deleteFileLocally fPath =
|
||||
withFilesFolder $ \filesFolder -> liftIO $ do
|
||||
let fsFilePath = filesFolder </> fPath
|
||||
removeFile fsFilePath `catchAll` \_ ->
|
||||
removePathForcibly fsFilePath `catchAll_` pure ()
|
||||
where
|
||||
delete :: m ()
|
||||
delete = withFilesFolder $ \filesFolder ->
|
||||
liftIO . forM_ filePath $ \fPath -> do
|
||||
let fsFilePath = filesFolder </> fPath
|
||||
removeFile fsFilePath `catchAll` \_ ->
|
||||
removePathForcibly fsFilePath `catchAll_` pure ()
|
||||
-- perform an action only if filesFolder is set (i.e. on mobile devices)
|
||||
withFilesFolder :: (FilePath -> m ()) -> m ()
|
||||
withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action
|
||||
|
|
@ -5893,10 +5967,10 @@ saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember@GroupMember {me
|
|||
throwError e
|
||||
_ -> throwError e
|
||||
|
||||
saveSndChatItem :: ChatMonad m => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> m (ChatItem c 'MDSnd)
|
||||
saveSndChatItem :: (ChatMonad m, ChatTypeI c) => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> m (ChatItem c 'MDSnd)
|
||||
saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothing Nothing Nothing False
|
||||
|
||||
saveSndChatItem' :: ChatMonad m => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CITimed -> Bool -> m (ChatItem c 'MDSnd)
|
||||
saveSndChatItem' :: (ChatMonad m, ChatTypeI c) => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CITimed -> Bool -> m (ChatItem c 'MDSnd)
|
||||
saveSndChatItem' user cd msg@SndMessage {sharedMsgId} content ciFile quotedItem itemTimed live = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
ciId <- withStore' $ \db -> do
|
||||
|
|
@ -5906,11 +5980,11 @@ saveSndChatItem' user cd msg@SndMessage {sharedMsgId} content ciFile quotedItem
|
|||
pure ciId
|
||||
pure $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemTimed live createdAt Nothing createdAt
|
||||
|
||||
saveRcvChatItem :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> m (ChatItem c 'MDRcv)
|
||||
saveRcvChatItem :: (ChatMonad m, ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> m (ChatItem c 'MDRcv)
|
||||
saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content =
|
||||
saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False
|
||||
|
||||
saveRcvChatItem' :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> m (ChatItem c 'MDRcv)
|
||||
saveRcvChatItem' :: (ChatMonad m, ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> m (ChatItem c 'MDRcv)
|
||||
saveRcvChatItem' user cd msg@RcvMessage {forwardedByMember} sharedMsgId_ brokerTs content ciFile itemTimed live = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
(ciId, quotedItem) <- withStore' $ \db -> do
|
||||
|
|
@ -5920,7 +5994,7 @@ saveRcvChatItem' user cd msg@RcvMessage {forwardedByMember} sharedMsgId_ brokerT
|
|||
pure (ciId, quotedItem)
|
||||
pure $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemTimed live brokerTs forwardedByMember createdAt
|
||||
|
||||
mkChatItem :: forall c d. MsgDirectionI d => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CITimed -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
|
||||
mkChatItem :: forall c d. (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CITimed -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
|
||||
mkChatItem cd ciId content file quotedItem sharedMsgId itemTimed live itemTs forwardedByMember currentTs =
|
||||
let itemText = ciContentToText content
|
||||
itemStatus = ciCreateStatus content
|
||||
|
|
@ -5944,6 +6018,14 @@ deleteGroupCI user gInfo ci@ChatItem {file} byUser timed byGroupMember_ deletedT
|
|||
where
|
||||
gItem = AChatItem SCTGroup msgDirection (GroupChat gInfo)
|
||||
|
||||
deleteLocalCI :: (ChatMonad m, MsgDirectionI d) => User -> NoteFolder -> ChatItem 'CTLocal d -> Bool -> Bool -> m ChatResponse
|
||||
deleteLocalCI user nf ci@ChatItem {file} byUser timed = do
|
||||
forM_ file $ \CIFile {fileSource} -> do
|
||||
forM_ (CF.filePath <$> fileSource) $ \fPath ->
|
||||
deleteFileLocally fPath `catchChatError` (toView . CRChatError (Just user))
|
||||
withStore' $ \db -> deleteLocalChatItem db user nf ci
|
||||
pure $ CRChatItemDeleted user (AChatItem SCTLocal msgDirection (LocalChat nf) ci) Nothing byUser timed
|
||||
|
||||
deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
|
||||
deleteCIFile user file_ =
|
||||
forM_ file_ $ \file -> do
|
||||
|
|
@ -6141,6 +6223,15 @@ createInternalItemsForChats user itemTs_ dirsCIContents = do
|
|||
let ci = mkChatItem cd ciId content Nothing Nothing Nothing Nothing False itemTs Nothing createdAt
|
||||
pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci
|
||||
|
||||
createLocalChatItem :: (MsgDirectionI d, ChatMonad m) => User -> ChatDirection 'CTLocal d -> CIContent d -> UTCTime -> m ChatItemId
|
||||
createLocalChatItem user cd content createdAt = do
|
||||
gVar <- asks random
|
||||
withStore $ \db -> do
|
||||
liftIO $ updateChatTs db user cd createdAt
|
||||
createWithRandomId gVar $ \sharedMsgId ->
|
||||
let smi_ = Just (SharedMsgId sharedMsgId)
|
||||
in createNewChatItem_ db user cd Nothing smi_ content (Nothing, Nothing, Nothing, Nothing, Nothing) Nothing False createdAt Nothing createdAt
|
||||
|
||||
getCreateActiveUser :: SQLiteStore -> Bool -> IO User
|
||||
getCreateActiveUser st testView = do
|
||||
user <-
|
||||
|
|
@ -6166,7 +6257,9 @@ getCreateActiveUser st testView = do
|
|||
putStrLn "chosen display name is already used by another profile on this device, choose another one"
|
||||
loop
|
||||
Left e -> putStrLn ("database error " <> show e) >> exitFailure
|
||||
Right user -> pure user
|
||||
Right user -> do
|
||||
void . withTransaction st $ \db -> runExceptT $ createNoteFolder db user
|
||||
pure user
|
||||
selectUser :: [User] -> IO User
|
||||
selectUser [user@User {userId}] = do
|
||||
withTransaction st (`setActiveUser` userId)
|
||||
|
|
@ -6312,6 +6405,7 @@ chatCommandP =
|
|||
"/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> stringP)),
|
||||
"/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal),
|
||||
"/_send " *> (APISendMessage <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))),
|
||||
"/_create *" *> (APICreateChatItem <$> A.decimal <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))),
|
||||
"/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP),
|
||||
"/_delete item " *> (APIDeleteChatItem <$> chatRefP <* A.space <*> A.decimal <* A.space <*> ciDeleteMode),
|
||||
"/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <* A.space <*> A.decimal <* A.space <*> A.decimal),
|
||||
|
|
@ -6420,6 +6514,7 @@ chatCommandP =
|
|||
("/leave " <|> "/l ") *> char_ '#' *> (LeaveGroup <$> displayName),
|
||||
("/delete #" <|> "/d #") *> (DeleteGroup <$> displayName),
|
||||
("/delete " <|> "/d ") *> char_ '@' *> (DeleteContact <$> displayName),
|
||||
"/clear *" $> ClearNoteFolder,
|
||||
"/clear #" *> (ClearGroup <$> displayName),
|
||||
"/clear " *> char_ '@' *> (ClearContact <$> displayName),
|
||||
("/members " <|> "/ms ") *> char_ '#' *> (ListMembers <$> displayName),
|
||||
|
|
@ -6453,6 +6548,7 @@ chatCommandP =
|
|||
("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeTill isSpace $> Nothing)),
|
||||
("/connect" <|> "/c") *> (AddContact <$> incognitoP),
|
||||
SendMessage <$> chatNameP <* A.space <*> msgTextP,
|
||||
"/* " *> (SendMessage (ChatName CTLocal "") <$> msgTextP),
|
||||
"@#" *> (SendMemberContactMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> msgTextP),
|
||||
"/live " *> (SendLiveMessage <$> chatNameP <*> (A.space *> msgTextP <|> pure "")),
|
||||
(">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv),
|
||||
|
|
@ -6543,7 +6639,7 @@ chatCommandP =
|
|||
incognitoOnOffP = (A.space *> "incognito=" *> onOffP) <|> pure False
|
||||
imagePrefix = (<>) <$> "data:" <*> ("image/png;base64," <|> "image/jpg;base64,")
|
||||
imageP = safeDecodeUtf8 <$> ((<>) <$> imagePrefix <*> (B64.encode <$> base64P))
|
||||
chatTypeP = A.char '@' $> CTDirect <|> A.char '#' $> CTGroup <|> A.char ':' $> CTContactConnection
|
||||
chatTypeP = A.char '@' $> CTDirect <|> A.char '#' $> CTGroup <|> A.char '*' $> CTLocal <|> A.char ':' $> CTContactConnection
|
||||
chatPaginationP =
|
||||
(CPLast <$ "count=" <*> A.decimal)
|
||||
<|> (CPAfter <$ "after=" <*> A.decimal <* A.space <* "count=" <*> A.decimal)
|
||||
|
|
@ -6616,7 +6712,10 @@ chatCommandP =
|
|||
" member" $> GRMember,
|
||||
" observer" $> GRObserver
|
||||
]
|
||||
chatNameP = ChatName <$> chatTypeP <*> displayName
|
||||
chatNameP =
|
||||
chatTypeP >>= \case
|
||||
CTLocal -> pure $ ChatName CTLocal ""
|
||||
ct -> ChatName ct <$> displayName
|
||||
chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayName
|
||||
chatRefP = ChatRef <$> chatTypeP <*> A.decimal
|
||||
msgCountP = A.space *> A.decimal <|> pure 10
|
||||
|
|
|
|||
|
|
@ -258,6 +258,7 @@ data ChatCommand
|
|||
| APIGetChatItems ChatPagination (Maybe String)
|
||||
| APIGetChatItemInfo ChatRef ChatItemId
|
||||
| APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage}
|
||||
| APICreateChatItem {noteFolderId :: NoteFolderId, composedMessage :: ComposedMessage}
|
||||
| APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent}
|
||||
| APIDeleteChatItem ChatRef ChatItemId CIDeleteMode
|
||||
| APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId
|
||||
|
|
@ -408,6 +409,7 @@ data ChatCommand
|
|||
| DeleteGroupLink GroupName
|
||||
| ShowGroupLink GroupName
|
||||
| SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, quotedMsg :: Text, message :: Text}
|
||||
| ClearNoteFolder
|
||||
| LastChats (Maybe Int) -- UserId (not used in UI)
|
||||
| LastMessages (Maybe ChatName) Int (Maybe String) -- UserId (not used in UI)
|
||||
| LastChatItemId (Maybe ChatName) Int -- UserId (not used in UI)
|
||||
|
|
|
|||
|
|
@ -10,11 +10,15 @@
|
|||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Messages where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad ((>=>))
|
||||
import Data.Aeson (FromJSON, ToJSON, (.:))
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Encoding as JE
|
||||
|
|
@ -25,6 +29,7 @@ import qualified Data.ByteString.Lazy as L
|
|||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Char (isSpace)
|
||||
import Data.Int (Int64)
|
||||
import Data.Kind (Constraint)
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
|
@ -34,6 +39,8 @@ import Data.Type.Equality
|
|||
import Data.Typeable (Typeable)
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import GHC.TypeLits (ErrorMessage (ShowType, type (:<>:)), TypeError)
|
||||
import qualified GHC.TypeLits as Type
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Protocol
|
||||
|
|
@ -47,7 +54,7 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextFie
|
|||
import Simplex.Messaging.Protocol (MsgBody)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
|
||||
|
||||
data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection
|
||||
data ChatType = CTDirect | CTGroup | CTLocal | CTContactRequest | CTContactConnection
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
data ChatName = ChatName {chatType :: ChatType, chatName :: Text}
|
||||
|
|
@ -57,6 +64,7 @@ chatTypeStr :: ChatType -> Text
|
|||
chatTypeStr = \case
|
||||
CTDirect -> "@"
|
||||
CTGroup -> "#"
|
||||
CTLocal -> "*"
|
||||
CTContactRequest -> "<@"
|
||||
CTContactConnection -> ":"
|
||||
|
||||
|
|
@ -69,6 +77,7 @@ data ChatRef = ChatRef ChatType Int64
|
|||
data ChatInfo (c :: ChatType) where
|
||||
DirectChat :: Contact -> ChatInfo 'CTDirect
|
||||
GroupChat :: GroupInfo -> ChatInfo 'CTGroup
|
||||
LocalChat :: NoteFolder -> ChatInfo 'CTLocal
|
||||
ContactRequest :: UserContactRequest -> ChatInfo 'CTContactRequest
|
||||
ContactConnection :: PendingContactConnection -> ChatInfo 'CTContactConnection
|
||||
|
||||
|
|
@ -84,6 +93,7 @@ chatInfoUpdatedAt :: ChatInfo c -> UTCTime
|
|||
chatInfoUpdatedAt = \case
|
||||
DirectChat Contact {updatedAt} -> updatedAt
|
||||
GroupChat GroupInfo {updatedAt} -> updatedAt
|
||||
LocalChat NoteFolder {updatedAt} -> updatedAt
|
||||
ContactRequest UserContactRequest {updatedAt} -> updatedAt
|
||||
ContactConnection PendingContactConnection {updatedAt} -> updatedAt
|
||||
|
||||
|
|
@ -91,6 +101,7 @@ chatInfoToRef :: ChatInfo c -> ChatRef
|
|||
chatInfoToRef = \case
|
||||
DirectChat Contact {contactId} -> ChatRef CTDirect contactId
|
||||
GroupChat GroupInfo {groupId} -> ChatRef CTGroup groupId
|
||||
LocalChat NoteFolder {noteFolderId} -> ChatRef CTLocal noteFolderId
|
||||
ContactRequest UserContactRequest {contactRequestId} -> ChatRef CTContactRequest contactRequestId
|
||||
ContactConnection PendingContactConnection {pccConnId} -> ChatRef CTContactConnection pccConnId
|
||||
|
||||
|
|
@ -102,6 +113,7 @@ chatInfoMembership = \case
|
|||
data JSONChatInfo
|
||||
= JCInfoDirect {contact :: Contact}
|
||||
| JCInfoGroup {groupInfo :: GroupInfo}
|
||||
| JCInfoLocal {noteFolder :: NoteFolder}
|
||||
| JCInfoContactRequest {contactRequest :: UserContactRequest}
|
||||
| JCInfoContactConnection {contactConnection :: PendingContactConnection}
|
||||
|
||||
|
|
@ -118,6 +130,7 @@ jsonChatInfo :: ChatInfo c -> JSONChatInfo
|
|||
jsonChatInfo = \case
|
||||
DirectChat c -> JCInfoDirect c
|
||||
GroupChat g -> JCInfoGroup g
|
||||
LocalChat l -> JCInfoLocal l
|
||||
ContactRequest g -> JCInfoContactRequest g
|
||||
ContactConnection c -> JCInfoContactConnection c
|
||||
|
||||
|
|
@ -129,6 +142,7 @@ jsonAChatInfo :: JSONChatInfo -> AChatInfo
|
|||
jsonAChatInfo = \case
|
||||
JCInfoDirect c -> AChatInfo SCTDirect $ DirectChat c
|
||||
JCInfoGroup g -> AChatInfo SCTGroup $ GroupChat g
|
||||
JCInfoLocal l -> AChatInfo SCTLocal $ LocalChat l
|
||||
JCInfoContactRequest g -> AChatInfo SCTContactRequest $ ContactRequest g
|
||||
JCInfoContactConnection c -> AChatInfo SCTContactConnection $ ContactConnection c
|
||||
|
||||
|
|
@ -168,6 +182,8 @@ data CIDirection (c :: ChatType) (d :: MsgDirection) where
|
|||
CIDirectRcv :: CIDirection 'CTDirect 'MDRcv
|
||||
CIGroupSnd :: CIDirection 'CTGroup 'MDSnd
|
||||
CIGroupRcv :: GroupMember -> CIDirection 'CTGroup 'MDRcv
|
||||
CILocalSnd :: CIDirection 'CTLocal 'MDSnd
|
||||
CILocalRcv :: CIDirection 'CTLocal 'MDRcv
|
||||
|
||||
deriving instance Show (CIDirection c d)
|
||||
|
||||
|
|
@ -180,6 +196,8 @@ data JSONCIDirection
|
|||
| JCIDirectRcv
|
||||
| JCIGroupSnd
|
||||
| JCIGroupRcv {groupMember :: GroupMember}
|
||||
| JCILocalSnd
|
||||
| JCILocalRcv
|
||||
deriving (Show)
|
||||
|
||||
jsonCIDirection :: CIDirection c d -> JSONCIDirection
|
||||
|
|
@ -188,6 +206,8 @@ jsonCIDirection = \case
|
|||
CIDirectRcv -> JCIDirectRcv
|
||||
CIGroupSnd -> JCIGroupSnd
|
||||
CIGroupRcv m -> JCIGroupRcv m
|
||||
CILocalSnd -> JCILocalSnd
|
||||
CILocalRcv -> JCILocalRcv
|
||||
|
||||
jsonACIDirection :: JSONCIDirection -> ACIDirection
|
||||
jsonACIDirection = \case
|
||||
|
|
@ -195,6 +215,8 @@ jsonACIDirection = \case
|
|||
JCIDirectRcv -> ACID SCTDirect SMDRcv CIDirectRcv
|
||||
JCIGroupSnd -> ACID SCTGroup SMDSnd CIGroupSnd
|
||||
JCIGroupRcv m -> ACID SCTGroup SMDRcv $ CIGroupRcv m
|
||||
JCILocalSnd -> ACID SCTLocal SMDSnd CILocalSnd
|
||||
JCILocalRcv -> ACID SCTLocal SMDRcv CILocalRcv
|
||||
|
||||
data CIReactionCount = CIReactionCount {reaction :: MsgReaction, userReacted :: Bool, totalReacted :: Int}
|
||||
deriving (Show)
|
||||
|
|
@ -235,6 +257,8 @@ data ChatDirection (c :: ChatType) (d :: MsgDirection) where
|
|||
CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv
|
||||
CDGroupSnd :: GroupInfo -> ChatDirection 'CTGroup 'MDSnd
|
||||
CDGroupRcv :: GroupInfo -> GroupMember -> ChatDirection 'CTGroup 'MDRcv
|
||||
CDLocalSnd :: NoteFolder -> ChatDirection 'CTLocal 'MDSnd
|
||||
CDLocalRcv :: NoteFolder -> ChatDirection 'CTLocal 'MDRcv
|
||||
|
||||
toCIDirection :: ChatDirection c d -> CIDirection c d
|
||||
toCIDirection = \case
|
||||
|
|
@ -242,6 +266,8 @@ toCIDirection = \case
|
|||
CDDirectRcv _ -> CIDirectRcv
|
||||
CDGroupSnd _ -> CIGroupSnd
|
||||
CDGroupRcv _ m -> CIGroupRcv m
|
||||
CDLocalSnd _ -> CILocalSnd
|
||||
CDLocalRcv _ -> CILocalRcv
|
||||
|
||||
toChatInfo :: ChatDirection c d -> ChatInfo c
|
||||
toChatInfo = \case
|
||||
|
|
@ -249,6 +275,8 @@ toChatInfo = \case
|
|||
CDDirectRcv c -> DirectChat c
|
||||
CDGroupSnd g -> GroupChat g
|
||||
CDGroupRcv g _ -> GroupChat g
|
||||
CDLocalSnd l -> LocalChat l
|
||||
CDLocalRcv l -> LocalChat l
|
||||
|
||||
data NewChatItem d = NewChatItem
|
||||
{ createdByMsgId :: Maybe MessageId,
|
||||
|
|
@ -323,10 +351,13 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
|
|||
}
|
||||
deriving (Show)
|
||||
|
||||
mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d
|
||||
mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d
|
||||
mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited itemTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt =
|
||||
let editable = case itemContent of
|
||||
CISndMsgContent _ -> diffUTCTime currentTs itemTs < nominalDay && isNothing itemDeleted
|
||||
CISndMsgContent _ ->
|
||||
case chatTypeI @c of
|
||||
SCTLocal -> isNothing itemDeleted
|
||||
_ -> diffUTCTime currentTs itemTs < nominalDay && isNothing itemDeleted
|
||||
_ -> False
|
||||
in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, itemTimed, itemLive, editable, forwardedByMember, createdAt, updatedAt}
|
||||
|
||||
|
|
@ -391,6 +422,12 @@ deriving instance Show ACIReaction
|
|||
|
||||
data JSONCIReaction c d = JSONCIReaction {chatInfo :: ChatInfo c, chatReaction :: CIReaction c d}
|
||||
|
||||
type family ChatTypeQuotable (a :: ChatType) :: Constraint where
|
||||
ChatTypeQuotable CTDirect = ()
|
||||
ChatTypeQuotable CTGroup = ()
|
||||
ChatTypeQuotable a =
|
||||
(Int ~ Bool, TypeError (Type.Text "ChatType " :<>: ShowType a :<>: Type.Text " cannot be quoted"))
|
||||
|
||||
data CIQDirection (c :: ChatType) where
|
||||
CIQDirectSnd :: CIQDirection 'CTDirect
|
||||
CIQDirectRcv :: CIQDirection 'CTDirect
|
||||
|
|
@ -399,7 +436,7 @@ data CIQDirection (c :: ChatType) where
|
|||
|
||||
deriving instance Show (CIQDirection c)
|
||||
|
||||
data ACIQDirection = forall c. ChatTypeI c => ACIQDirection (SChatType c) (CIQDirection c)
|
||||
data ACIQDirection = forall c. (ChatTypeI c, ChatTypeQuotable c) => ACIQDirection (SChatType c) (CIQDirection c)
|
||||
|
||||
jsonCIQDirection :: CIQDirection c -> Maybe JSONCIDirection
|
||||
jsonCIQDirection = \case
|
||||
|
|
@ -409,13 +446,15 @@ jsonCIQDirection = \case
|
|||
CIQGroupRcv (Just m) -> Just $ JCIGroupRcv m
|
||||
CIQGroupRcv Nothing -> Nothing
|
||||
|
||||
jsonACIQDirection :: Maybe JSONCIDirection -> ACIQDirection
|
||||
jsonACIQDirection :: Maybe JSONCIDirection -> Either String ACIQDirection
|
||||
jsonACIQDirection = \case
|
||||
Just JCIDirectSnd -> ACIQDirection SCTDirect CIQDirectSnd
|
||||
Just JCIDirectRcv -> ACIQDirection SCTDirect CIQDirectRcv
|
||||
Just JCIGroupSnd -> ACIQDirection SCTGroup CIQGroupSnd
|
||||
Just (JCIGroupRcv m) -> ACIQDirection SCTGroup $ CIQGroupRcv (Just m)
|
||||
Nothing -> ACIQDirection SCTGroup $ CIQGroupRcv Nothing
|
||||
Just JCIDirectSnd -> Right $ ACIQDirection SCTDirect CIQDirectSnd
|
||||
Just JCIDirectRcv -> Right $ ACIQDirection SCTDirect CIQDirectRcv
|
||||
Just JCIGroupSnd -> Right $ ACIQDirection SCTGroup CIQGroupSnd
|
||||
Just (JCIGroupRcv m) -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv (Just m)
|
||||
Nothing -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv Nothing
|
||||
Just JCILocalSnd -> Left "unquotable"
|
||||
Just JCILocalRcv -> Left "unquotable"
|
||||
|
||||
quoteMsgDirection :: CIQDirection c -> MsgDirection
|
||||
quoteMsgDirection = \case
|
||||
|
|
@ -434,7 +473,7 @@ data CIFile (d :: MsgDirection) = CIFile
|
|||
}
|
||||
deriving (Show)
|
||||
|
||||
data FileProtocol = FPSMP | FPXFTP
|
||||
data FileProtocol = FPSMP | FPXFTP | FPLocal
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
instance FromField FileProtocol where fromField = fromTextField_ textDecode
|
||||
|
|
@ -452,10 +491,12 @@ instance TextEncoding FileProtocol where
|
|||
textDecode = \case
|
||||
"smp" -> Just FPSMP
|
||||
"xftp" -> Just FPXFTP
|
||||
"local" -> Just FPLocal
|
||||
_ -> Nothing
|
||||
textEncode = \case
|
||||
FPSMP -> "smp"
|
||||
FPXFTP -> "xftp"
|
||||
FPLocal -> "local"
|
||||
|
||||
data CIFileStatus (d :: MsgDirection) where
|
||||
CIFSSndStored :: CIFileStatus 'MDSnd
|
||||
|
|
@ -721,6 +762,7 @@ type ChatItemTs = UTCTime
|
|||
data SChatType (c :: ChatType) where
|
||||
SCTDirect :: SChatType 'CTDirect
|
||||
SCTGroup :: SChatType 'CTGroup
|
||||
SCTLocal :: SChatType 'CTLocal
|
||||
SCTContactRequest :: SChatType 'CTContactRequest
|
||||
SCTContactConnection :: SChatType 'CTContactConnection
|
||||
|
||||
|
|
@ -729,6 +771,7 @@ deriving instance Show (SChatType c)
|
|||
instance TestEquality SChatType where
|
||||
testEquality SCTDirect SCTDirect = Just Refl
|
||||
testEquality SCTGroup SCTGroup = Just Refl
|
||||
testEquality SCTLocal SCTLocal = Just Refl
|
||||
testEquality SCTContactRequest SCTContactRequest = Just Refl
|
||||
testEquality SCTContactConnection SCTContactConnection = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
|
@ -742,6 +785,8 @@ instance ChatTypeI 'CTDirect where chatTypeI = SCTDirect
|
|||
|
||||
instance ChatTypeI 'CTGroup where chatTypeI = SCTGroup
|
||||
|
||||
instance ChatTypeI 'CTLocal where chatTypeI = SCTLocal
|
||||
|
||||
instance ChatTypeI 'CTContactRequest where chatTypeI = SCTContactRequest
|
||||
|
||||
instance ChatTypeI 'CTContactConnection where chatTypeI = SCTContactConnection
|
||||
|
|
@ -750,6 +795,7 @@ toChatType :: SChatType c -> ChatType
|
|||
toChatType = \case
|
||||
SCTDirect -> CTDirect
|
||||
SCTGroup -> CTGroup
|
||||
SCTLocal -> CTLocal
|
||||
SCTContactRequest -> CTContactRequest
|
||||
SCTContactConnection -> CTContactConnection
|
||||
|
||||
|
|
@ -757,6 +803,7 @@ aChatType :: ChatType -> AChatType
|
|||
aChatType = \case
|
||||
CTDirect -> ACT SCTDirect
|
||||
CTGroup -> ACT SCTGroup
|
||||
CTLocal -> ACT SCTLocal
|
||||
CTContactRequest -> ACT SCTContactRequest
|
||||
CTContactConnection -> ACT SCTContactConnection
|
||||
|
||||
|
|
@ -1045,7 +1092,7 @@ instance FromJSON ACIDirection where
|
|||
parseJSON v = jsonACIDirection <$> J.parseJSON v
|
||||
|
||||
instance ChatTypeI c => FromJSON (CIQDirection c) where
|
||||
parseJSON v = (\(ACIQDirection _ x) -> checkChatType x) . jsonACIQDirection <$?> J.parseJSON v
|
||||
parseJSON v = (jsonACIQDirection >=> \(ACIQDirection _ x) -> checkChatType x) <$?> J.parseJSON v
|
||||
|
||||
instance ToJSON (CIQDirection c) where
|
||||
toJSON = J.toJSON . jsonCIQDirection
|
||||
|
|
|
|||
42
src/Simplex/Chat/Migrations/M20240102_note_folders.hs
Normal file
42
src/Simplex/Chat/Migrations/M20240102_note_folders.hs
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20240102_note_folders where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20240102_note_folders :: Query
|
||||
m20240102_note_folders =
|
||||
[sql|
|
||||
CREATE TABLE note_folders (
|
||||
note_folder_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
chat_ts TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
favorite INTEGER NOT NULL DEFAULT 0,
|
||||
unread_chat INTEGER NOT NULL DEFAULT 0
|
||||
);
|
||||
|
||||
ALTER TABLE chat_items ADD COLUMN note_folder_id INTEGER DEFAULT NULL REFERENCES note_folders ON DELETE CASCADE;
|
||||
ALTER TABLE files ADD COLUMN note_folder_id INTEGER DEFAULT NULL REFERENCES note_folders ON DELETE CASCADE;
|
||||
|
||||
CREATE INDEX chat_items_note_folder_id ON chat_items(note_folder_id);
|
||||
CREATE INDEX files_note_folder_id ON files(note_folder_id);
|
||||
CREATE INDEX note_folders_user_id ON note_folders(user_id);
|
||||
|
||||
INSERT INTO note_folders (user_id) SELECT user_id FROM users;
|
||||
|]
|
||||
|
||||
down_m20240102_note_folders :: Query
|
||||
down_m20240102_note_folders =
|
||||
[sql|
|
||||
DROP INDEX chat_items_note_folder_id;
|
||||
DROP INDEX files_note_folder_id;
|
||||
DROP INDEX note_folders_user_id;
|
||||
|
||||
ALTER TABLE chat_items DROP COLUMN note_folder_id;
|
||||
ALTER TABLE files DROP COLUMN note_folder_id;
|
||||
|
||||
DROP TABLE note_folders;
|
||||
|]
|
||||
|
|
@ -189,7 +189,8 @@ CREATE TABLE files(
|
|||
agent_snd_file_deleted INTEGER DEFAULT 0 CHECK(agent_snd_file_deleted NOT NULL),
|
||||
protocol TEXT NOT NULL DEFAULT 'smp',
|
||||
file_crypto_key BLOB,
|
||||
file_crypto_nonce BLOB
|
||||
file_crypto_nonce BLOB,
|
||||
note_folder_id INTEGER DEFAULT NULL REFERENCES note_folders ON DELETE CASCADE
|
||||
);
|
||||
CREATE TABLE snd_files(
|
||||
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
|
||||
|
|
@ -368,7 +369,8 @@ CREATE TABLE chat_items(
|
|||
item_deleted_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
|
||||
item_deleted_ts TEXT,
|
||||
forwarded_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
|
||||
item_content_tag TEXT
|
||||
item_content_tag TEXT,
|
||||
note_folder_id INTEGER DEFAULT NULL REFERENCES note_folders ON DELETE CASCADE
|
||||
);
|
||||
CREATE TABLE chat_item_messages(
|
||||
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
|
||||
|
|
@ -547,6 +549,15 @@ CREATE TABLE IF NOT EXISTS "msg_deliveries"(
|
|||
agent_ack_cmd_id INTEGER, -- broker_ts for received, created_at for sent
|
||||
delivery_status TEXT -- MsgDeliveryStatus
|
||||
);
|
||||
CREATE TABLE note_folders(
|
||||
note_folder_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
chat_ts TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
favorite INTEGER NOT NULL DEFAULT 0,
|
||||
unread_chat INTEGER NOT NULL DEFAULT 0
|
||||
);
|
||||
CREATE INDEX contact_profiles_index ON contact_profiles(
|
||||
display_name,
|
||||
full_name
|
||||
|
|
@ -812,3 +823,6 @@ CREATE INDEX idx_msg_deliveries_agent_msg_id ON "msg_deliveries"(
|
|||
connection_id,
|
||||
agent_msg_id
|
||||
);
|
||||
CREATE INDEX chat_items_note_folder_id ON chat_items(note_folder_id);
|
||||
CREATE INDEX files_note_folder_id ON files(note_folder_id);
|
||||
CREATE INDEX note_folders_user_id ON note_folders(user_id);
|
||||
|
|
|
|||
|
|
@ -398,6 +398,7 @@ setUserChatsRead db User {userId} = do
|
|||
updatedAt <- getCurrentTime
|
||||
DB.execute db "UPDATE contacts SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND unread_chat = ?" (False, updatedAt, userId, True)
|
||||
DB.execute db "UPDATE groups SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND unread_chat = ?" (False, updatedAt, userId, True)
|
||||
DB.execute db "UPDATE note_folders SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND unread_chat = ?" (False, updatedAt, userId, True)
|
||||
DB.execute db "UPDATE chat_items SET item_status = ?, updated_at = ? WHERE user_id = ? AND item_status = ?" (CISRcvRead, updatedAt, userId, CISRcvNew)
|
||||
|
||||
updateContactStatus :: DB.Connection -> User -> Contact -> ContactStatus -> IO Contact
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
|
@ -72,7 +73,10 @@ module Simplex.Chat.Store.Files
|
|||
getSndFileTransfer,
|
||||
getSndFileTransfers,
|
||||
getContactFileInfo,
|
||||
getNoteFolderFileInfo,
|
||||
createLocalFile,
|
||||
getLocalCryptoFile,
|
||||
getLocalFileMeta,
|
||||
updateDirectCIFileStatus,
|
||||
)
|
||||
where
|
||||
|
|
@ -90,6 +94,7 @@ import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay)
|
|||
import Data.Type.Equality
|
||||
import Database.SQLite.Simple (Only (..), (:.) (..))
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Database.SQLite.Simple.ToField (ToField)
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Protocol
|
||||
|
|
@ -107,6 +112,7 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
|||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Protocol (SubscriptionMode (..))
|
||||
import Simplex.Messaging.Version (VersionRange)
|
||||
import System.FilePath (takeFileName)
|
||||
|
||||
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
|
||||
getLiveSndFileTransfers db User {userId} = do
|
||||
|
|
@ -839,18 +845,19 @@ getFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileT
|
|||
getFileTransfer db user@User {userId} fileId =
|
||||
fileTransfer =<< liftIO (getFileTransferRow_ db userId fileId)
|
||||
where
|
||||
fileTransfer :: [(Maybe Int64, Maybe Int64)] -> ExceptT StoreError IO FileTransfer
|
||||
fileTransfer [(Nothing, Just _)] = FTRcv <$> getRcvFileTransfer db user fileId
|
||||
fileTransfer :: [(Maybe Int64, Maybe Int64, FileProtocol)] -> ExceptT StoreError IO FileTransfer
|
||||
fileTransfer [(_, _, FPLocal)] = throwError $ SELocalFileNoTransfer fileId
|
||||
fileTransfer [(Nothing, Just _, _)] = FTRcv <$> getRcvFileTransfer db user fileId
|
||||
fileTransfer _ = do
|
||||
(ftm, fts) <- getSndFileTransfer db user fileId
|
||||
pure $ FTSnd {fileTransferMeta = ftm, sndFileTransfers = fts}
|
||||
|
||||
getFileTransferRow_ :: DB.Connection -> UserId -> Int64 -> IO [(Maybe Int64, Maybe Int64)]
|
||||
getFileTransferRow_ :: DB.Connection -> UserId -> Int64 -> IO [(Maybe Int64, Maybe Int64, FileProtocol)]
|
||||
getFileTransferRow_ db userId fileId =
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT s.file_id, r.file_id
|
||||
SELECT s.file_id, r.file_id, f.protocol
|
||||
FROM files f
|
||||
LEFT JOIN snd_files s ON s.file_id = f.file_id
|
||||
LEFT JOIN rcv_files r ON r.file_id = f.file_id
|
||||
|
|
@ -911,24 +918,70 @@ getFileTransferMeta_ db userId fileId =
|
|||
xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted, cryptoArgs}) <$> aSndFileId_
|
||||
in FileTransferMeta {fileId, xftpSndFile, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_}
|
||||
|
||||
createLocalFile :: ToField (CIFileStatus d) => CIFileStatus d -> DB.Connection -> User -> NoteFolder -> ChatItemId -> UTCTime -> CryptoFile -> Integer -> Integer -> IO Int64
|
||||
createLocalFile fileStatus db User {userId} NoteFolder {noteFolderId} chatItemId itemTs CryptoFile {filePath, cryptoArgs} fileSize fileChunkSize = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO files
|
||||
( user_id, note_folder_id, chat_item_id,
|
||||
file_name, file_path, file_size,
|
||||
file_crypto_key, file_crypto_nonce,
|
||||
chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at
|
||||
)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
( (userId, noteFolderId, chatItemId)
|
||||
:. (takeFileName filePath, filePath, fileSize)
|
||||
:. maybe (Nothing, Nothing) (\(CFArgs key nonce) -> (Just key, Just nonce)) cryptoArgs
|
||||
:. (fileChunkSize, Nothing :: Maybe InlineFileMode, fileStatus, FPLocal, itemTs, itemTs)
|
||||
)
|
||||
insertedRowId db
|
||||
|
||||
getLocalFileMeta :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalFileMeta
|
||||
getLocalFileMeta db userId fileId =
|
||||
ExceptT . firstRow localFileMeta (SEFileNotFound fileId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT file_name, file_size, file_path, file_crypto_key, file_crypto_nonce
|
||||
FROM files
|
||||
WHERE user_id = ? AND file_id = ?
|
||||
|]
|
||||
(userId, fileId)
|
||||
where
|
||||
localFileMeta :: (FilePath, Integer, FilePath, Maybe C.SbKey, Maybe C.CbNonce) -> LocalFileMeta
|
||||
localFileMeta (fileName, fileSize, filePath, fileKey, fileNonce) =
|
||||
let fileCryptoArgs = CFArgs <$> fileKey <*> fileNonce
|
||||
in LocalFileMeta {fileId, fileName, fileSize, filePath, fileCryptoArgs}
|
||||
|
||||
getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo]
|
||||
getContactFileInfo db User {userId} Contact {contactId} =
|
||||
map toFileInfo
|
||||
<$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ?") (userId, contactId)
|
||||
|
||||
getNoteFolderFileInfo :: DB.Connection -> User -> NoteFolder -> IO [CIFileInfo]
|
||||
getNoteFolderFileInfo db User {userId} NoteFolder {noteFolderId} =
|
||||
map toFileInfo
|
||||
<$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.note_folder_id = ?") (userId, noteFolderId)
|
||||
|
||||
getLocalCryptoFile :: DB.Connection -> UserId -> Int64 -> Bool -> ExceptT StoreError IO CryptoFile
|
||||
getLocalCryptoFile db userId fileId sent =
|
||||
liftIO (getFileTransferRow_ db userId fileId) >>= \case
|
||||
[(Nothing, Just _)] -> do
|
||||
[(Nothing, Just _, _)] -> do
|
||||
when sent $ throwError $ SEFileNotFound fileId
|
||||
RcvFileTransfer {fileStatus, cryptoArgs} <- getRcvFileTransfer_ db userId fileId
|
||||
case fileStatus of
|
||||
RFSComplete RcvFileInfo {filePath} -> pure $ CryptoFile filePath cryptoArgs
|
||||
_ -> throwError $ SEFileNotFound fileId
|
||||
_ -> do
|
||||
[(Just _, Nothing, _)] -> do
|
||||
unless sent $ throwError $ SEFileNotFound fileId
|
||||
FileTransferMeta {filePath, xftpSndFile} <- getFileTransferMeta_ db userId fileId
|
||||
pure $ CryptoFile filePath $ xftpSndFile >>= \XFTPSndFile {cryptoArgs} -> cryptoArgs
|
||||
[(Nothing, Nothing, FPLocal)] -> do
|
||||
LocalFileMeta {filePath, fileCryptoArgs} <- getLocalFileMeta db userId fileId
|
||||
pure $ CryptoFile filePath fileCryptoArgs
|
||||
_ -> throwError $ SEFileNotFound fileId
|
||||
|
||||
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> VersionRange -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
|
||||
updateDirectCIFileStatus db vr user fileId fileStatus = do
|
||||
|
|
|
|||
|
|
@ -34,9 +34,11 @@ module Simplex.Chat.Store.Messages
|
|||
createNewSndChatItem,
|
||||
createNewRcvChatItem,
|
||||
createNewChatItemNoMsg,
|
||||
createNewChatItem_,
|
||||
getChatPreviews,
|
||||
getDirectChat,
|
||||
getGroupChat,
|
||||
getLocalChat,
|
||||
getDirectChatItemsLast,
|
||||
getAllChatItems,
|
||||
getAChatItem,
|
||||
|
|
@ -52,12 +54,14 @@ module Simplex.Chat.Store.Messages
|
|||
updateGroupChatItemModerated,
|
||||
markGroupChatItemDeleted,
|
||||
markGroupChatItemBlocked,
|
||||
deleteLocalChatItem,
|
||||
updateDirectChatItemsRead,
|
||||
getDirectUnreadTimedItems,
|
||||
setDirectChatItemDeleteAt,
|
||||
updateGroupChatItemsRead,
|
||||
getGroupUnreadTimedItems,
|
||||
setGroupChatItemDeleteAt,
|
||||
updateLocalChatItemsRead,
|
||||
getChatRefViaItemId,
|
||||
getChatItemVersions,
|
||||
getDirectCIReactions,
|
||||
|
|
@ -77,10 +81,14 @@ module Simplex.Chat.Store.Messages
|
|||
getGroupMemberCIBySharedMsgId,
|
||||
getGroupChatItemByAgentMsgId,
|
||||
getGroupMemberChatItemLast,
|
||||
getLocalChatItem,
|
||||
updateLocalChatItem',
|
||||
getDirectChatItemIdByText,
|
||||
getDirectChatItemIdByText',
|
||||
getGroupChatItemIdByText,
|
||||
getGroupChatItemIdByText',
|
||||
getLocalChatItemIdByText,
|
||||
getLocalChatItemIdByText',
|
||||
getChatItemByFileId,
|
||||
getChatItemByGroupId,
|
||||
updateDirectChatItemStatus,
|
||||
|
|
@ -126,6 +134,7 @@ import Simplex.Chat.Messages.CIContent
|
|||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Store.Direct
|
||||
import Simplex.Chat.Store.Groups
|
||||
import Simplex.Chat.Store.NoteFolders
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserId)
|
||||
|
|
@ -322,6 +331,11 @@ updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirecti
|
|||
db
|
||||
"UPDATE groups SET chat_ts = ? WHERE user_id = ? AND group_id = ?"
|
||||
(chatTs, userId, groupId)
|
||||
LocalChat NoteFolder {noteFolderId} ->
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE note_folders SET chat_ts = ? WHERE user_id = ? AND note_folder_id = ?"
|
||||
(chatTs, userId, noteFolderId)
|
||||
_ -> pure ()
|
||||
|
||||
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId
|
||||
|
|
@ -340,7 +354,7 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon
|
|||
CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId)
|
||||
CIQGroupRcv Nothing -> (Just False, Nothing)
|
||||
|
||||
createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c))
|
||||
createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c))
|
||||
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live itemTs createdAt = do
|
||||
ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow timed live itemTs forwardedByMember createdAt
|
||||
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
|
||||
|
|
@ -370,13 +384,13 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q
|
|||
[sql|
|
||||
INSERT INTO chat_items (
|
||||
-- user and IDs
|
||||
user_id, created_by_msg_id, contact_id, group_id, group_member_id,
|
||||
user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id,
|
||||
-- meta
|
||||
item_sent, item_ts, item_content, item_content_tag, item_text, item_status, shared_msg_id,
|
||||
forwarded_by_group_member_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at,
|
||||
-- quote
|
||||
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
((userId, msgId_) :. idsRow :. itemRow :. quoteRow)
|
||||
ciId <- insertedRowId db
|
||||
|
|
@ -385,12 +399,14 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q
|
|||
where
|
||||
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe SharedMsgId, Maybe GroupMemberId) :. (UTCTime, UTCTime, Maybe Bool) :. (Maybe Int, Maybe UTCTime)
|
||||
itemRow = (msgDirection @d, itemTs, ciContent, toCIContentTag ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId, forwardedByMember) :. (createdAt, createdAt, justTrue live) :. ciTimedRow timed
|
||||
idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64)
|
||||
idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64)
|
||||
idsRow = case chatDirection of
|
||||
CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing)
|
||||
CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing)
|
||||
CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId)
|
||||
CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing)
|
||||
CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing)
|
||||
CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing)
|
||||
CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId, Nothing)
|
||||
CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing, Nothing)
|
||||
CDLocalRcv NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId)
|
||||
CDLocalSnd NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId)
|
||||
|
||||
ciTimedRow :: Maybe CITimed -> (Maybe Int, Maybe UTCTime)
|
||||
ciTimedRow (Just CITimed {ttl, deleteAt}) = (Just ttl, deleteAt)
|
||||
|
|
@ -399,7 +415,7 @@ ciTimedRow _ = (Nothing, Nothing)
|
|||
insertChatItemMessage_ :: DB.Connection -> ChatItemId -> MessageId -> UTCTime -> IO ()
|
||||
insertChatItemMessage_ db ciId msgId ts = DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (ciId, msgId, ts, ts)
|
||||
|
||||
getChatItemQuote_ :: DB.Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO (CIQuote c)
|
||||
getChatItemQuote_ :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO (CIQuote c)
|
||||
getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} =
|
||||
case chatDirection of
|
||||
CDDirectRcv Contact {contactId} -> getDirectChatItemQuote_ contactId (not sent)
|
||||
|
|
@ -466,15 +482,17 @@ getChatPreviews :: DB.Connection -> VersionRange -> User -> Bool -> PaginationBy
|
|||
getChatPreviews db vr user withPCC pagination query = do
|
||||
directChats <- findDirectChatPreviews_ db user pagination query
|
||||
groupChats <- findGroupChatPreviews_ db user pagination query
|
||||
localChats <- findLocalChatPreviews_ db user pagination query
|
||||
cReqChats <- getContactRequestChatPreviews_ db user pagination query
|
||||
connChats <- if withPCC then getContactConnectionChatPreviews_ db user pagination query else pure []
|
||||
let refs = sortTake $ concat [directChats, groupChats, cReqChats, connChats]
|
||||
let refs = sortTake $ concat [directChats, groupChats, localChats, cReqChats, connChats]
|
||||
mapM (runExceptT <$> getChatPreview) refs
|
||||
where
|
||||
ts :: AChatPreviewData -> UTCTime
|
||||
ts (ACPD _ cpd) = case cpd of
|
||||
(DirectChatPD t _ _ _) -> t
|
||||
(GroupChatPD t _ _ _) -> t
|
||||
(LocalChatPD t _ _ _) -> t
|
||||
(ContactRequestPD t _) -> t
|
||||
(ContactConnectionPD t _) -> t
|
||||
sortTake = case pagination of
|
||||
|
|
@ -485,12 +503,14 @@ getChatPreviews db vr user withPCC pagination query = do
|
|||
getChatPreview (ACPD cType cpd) = case cType of
|
||||
SCTDirect -> getDirectChatPreview_ db user cpd
|
||||
SCTGroup -> getGroupChatPreview_ db vr user cpd
|
||||
SCTLocal -> getLocalChatPreview_ db user cpd
|
||||
SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat
|
||||
SCTContactConnection -> let (ContactConnectionPD _ chat) = cpd in pure chat
|
||||
|
||||
data ChatPreviewData (c :: ChatType) where
|
||||
DirectChatPD :: UTCTime -> ContactId -> Maybe ChatItemId -> ChatStats -> ChatPreviewData 'CTDirect
|
||||
GroupChatPD :: UTCTime -> GroupId -> Maybe ChatItemId -> ChatStats -> ChatPreviewData 'CTGroup
|
||||
LocalChatPD :: UTCTime -> NoteFolderId -> Maybe ChatItemId -> ChatStats -> ChatPreviewData 'CTLocal
|
||||
ContactRequestPD :: UTCTime -> AChat -> ChatPreviewData 'CTContactRequest
|
||||
ContactConnectionPD :: UTCTime -> AChat -> ChatPreviewData 'CTContactConnection
|
||||
|
||||
|
|
@ -697,6 +717,123 @@ getGroupChatPreview_ db vr user (GroupChatPD _ groupId lastItemId_ stats) = do
|
|||
Nothing -> pure []
|
||||
pure $ AChat SCTGroup (Chat (GroupChat groupInfo) lastItem stats)
|
||||
|
||||
findLocalChatPreviews_ :: DB.Connection -> User -> PaginationByTime -> ChatListQuery -> IO [AChatPreviewData]
|
||||
findLocalChatPreviews_ db User {userId} pagination clq =
|
||||
map toPreview <$> getPreviews
|
||||
where
|
||||
toPreview :: (NoteFolderId, UTCTime, Maybe ChatItemId) :. ChatStatsRow -> AChatPreviewData
|
||||
toPreview ((noteFolderId, ts, lastItemId_) :. statsRow) =
|
||||
ACPD SCTLocal $ LocalChatPD ts noteFolderId lastItemId_ (toChatStats statsRow)
|
||||
baseQuery =
|
||||
[sql|
|
||||
SELECT nf.note_folder_id, nf.chat_ts as ts, LastItems.chat_item_id, COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), nf.unread_chat
|
||||
FROM note_folders nf
|
||||
LEFT JOIN (
|
||||
SELECT note_folder_id, chat_item_id, MAX(created_at)
|
||||
FROM chat_items
|
||||
GROUP BY note_folder_id
|
||||
) LastItems ON LastItems.note_folder_id = nf.note_folder_id
|
||||
LEFT JOIN (
|
||||
SELECT note_folder_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread
|
||||
FROM chat_items
|
||||
WHERE item_status = :rcv_new
|
||||
GROUP BY note_folder_id
|
||||
) ChatStats ON ChatStats.note_folder_id = nf.note_folder_id
|
||||
|]
|
||||
(pagQuery, pagParams) = paginationByTimeFilter pagination
|
||||
getPreviews = case clq of
|
||||
CLQFilters {favorite = False, unread = False} ->
|
||||
DB.queryNamed
|
||||
db
|
||||
( baseQuery
|
||||
<> [sql|
|
||||
WHERE nf.user_id = :user_id
|
||||
|]
|
||||
<> pagQuery
|
||||
)
|
||||
([":user_id" := userId, ":rcv_new" := CISRcvNew] <> pagParams)
|
||||
CLQFilters {favorite = True, unread = False} ->
|
||||
DB.queryNamed
|
||||
db
|
||||
( baseQuery
|
||||
<> [sql|
|
||||
WHERE nf.user_id = :user_id
|
||||
AND nf.favorite = 1
|
||||
|]
|
||||
<> pagQuery
|
||||
)
|
||||
([":user_id" := userId, ":rcv_new" := CISRcvNew] <> pagParams)
|
||||
CLQFilters {favorite = False, unread = True} ->
|
||||
DB.queryNamed
|
||||
db
|
||||
( baseQuery
|
||||
<> [sql|
|
||||
WHERE nf.user_id = :user_id
|
||||
AND (nf.unread_chat = 1 OR ChatStats.UnreadCount > 0)
|
||||
|]
|
||||
<> pagQuery
|
||||
)
|
||||
([":user_id" := userId, ":rcv_new" := CISRcvNew] <> pagParams)
|
||||
CLQFilters {favorite = True, unread = True} ->
|
||||
DB.queryNamed
|
||||
db
|
||||
( baseQuery
|
||||
<> [sql|
|
||||
WHERE nf.user_id = :user_id
|
||||
AND (nf.favorite = 1
|
||||
OR nf.unread_chat = 1 OR ChatStats.UnreadCount > 0)
|
||||
|]
|
||||
<> pagQuery
|
||||
)
|
||||
([":user_id" := userId, ":rcv_new" := CISRcvNew] <> pagParams)
|
||||
CLQSearch {} -> pure []
|
||||
|
||||
getLocalChatPreview_ :: DB.Connection -> User -> ChatPreviewData 'CTLocal -> ExceptT StoreError IO AChat
|
||||
getLocalChatPreview_ db user (LocalChatPD _ noteFolderId lastItemId_ stats) = do
|
||||
nf <- getNoteFolder db user noteFolderId
|
||||
lastItem <- case lastItemId_ of
|
||||
Just lastItemId -> (: []) <$> getLocalChatItem db user noteFolderId lastItemId
|
||||
Nothing -> pure []
|
||||
pure $ AChat SCTLocal (Chat (LocalChat nf) lastItem stats)
|
||||
|
||||
-- this function can be changed so it never fails, not only avoid failure on invalid json
|
||||
toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError (CChatItem 'CTLocal)
|
||||
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) =
|
||||
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
|
||||
where
|
||||
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
|
||||
chatItem itemContent = case (itemContent, itemStatus, fileStatus_) of
|
||||
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Just (AFS SMDSnd fileStatus)) ->
|
||||
Right $ cItem SMDSnd CILocalSnd ciStatus ciContent (maybeCIFile fileStatus)
|
||||
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Nothing) ->
|
||||
Right $ cItem SMDSnd CILocalSnd ciStatus ciContent Nothing
|
||||
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just (AFS SMDRcv fileStatus)) ->
|
||||
Right $ cItem SMDRcv CILocalRcv ciStatus ciContent (maybeCIFile fileStatus)
|
||||
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Nothing) ->
|
||||
Right $ cItem SMDRcv CILocalRcv ciStatus ciContent Nothing
|
||||
_ -> badItem
|
||||
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
|
||||
maybeCIFile fileStatus =
|
||||
case (fileId_, fileName_, fileSize_, fileProtocol_) of
|
||||
(Just fileId, Just fileName, Just fileSize, Just fileProtocol) ->
|
||||
let cfArgs = CFArgs <$> fileKey <*> fileNonce
|
||||
fileSource = (`CryptoFile` cfArgs) <$> filePath
|
||||
in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol}
|
||||
_ -> Nothing
|
||||
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTLocal d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTLocal
|
||||
cItem d chatDir ciStatus content file =
|
||||
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = Nothing, reactions = [], file}
|
||||
badItem = Left $ SEBadChatItem itemId
|
||||
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTLocal d
|
||||
ciMeta content status =
|
||||
let itemDeleted' = case itemDeleted of
|
||||
DBCINotDeleted -> Nothing
|
||||
_ -> Just (CIDeleted @'CTLocal deletedTs)
|
||||
itemEdited' = fromMaybe False itemEdited
|
||||
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
|
||||
|
||||
getContactRequestChatPreviews_ :: DB.Connection -> User -> PaginationByTime -> ChatListQuery -> IO [AChatPreviewData]
|
||||
getContactRequestChatPreviews_ db User {userId} pagination clq = case clq of
|
||||
CLQFilters {favorite = False, unread = False} -> query ""
|
||||
|
|
@ -967,11 +1104,86 @@ getGroupChatBefore_ db user@User {userId} g@GroupInfo {groupId} beforeChatItemId
|
|||
|]
|
||||
(userId, groupId, search, beforeChatItemTs, beforeChatItemTs, beforeChatItemId, count)
|
||||
|
||||
toChatItemRef :: (ChatItemId, Maybe Int64, Maybe Int64) -> Either StoreError (ChatRef, ChatItemId)
|
||||
getLocalChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTLocal)
|
||||
getLocalChat db user folderId pagination search_ = do
|
||||
let search = fromMaybe "" search_
|
||||
nf <- getNoteFolder db user folderId
|
||||
case pagination of
|
||||
CPLast count -> getLocalChatLast_ db user nf count search
|
||||
CPAfter afterId count -> getLocalChatAfter_ db user nf afterId count search
|
||||
CPBefore beforeId count -> getLocalChatBefore_ db user nf beforeId count search
|
||||
|
||||
getLocalChatLast_ :: DB.Connection -> User -> NoteFolder -> Int -> String -> ExceptT StoreError IO (Chat 'CTLocal)
|
||||
getLocalChatLast_ db user@User {userId} nf@NoteFolder {noteFolderId} count search = do
|
||||
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
|
||||
chatItemIds <- liftIO getLocalChatItemIdsLast_
|
||||
chatItems <- mapM (getLocalChatItem db user noteFolderId) chatItemIds
|
||||
pure $ Chat (LocalChat nf) (reverse chatItems) stats
|
||||
where
|
||||
getLocalChatItemIdsLast_ :: IO [ChatItemId]
|
||||
getLocalChatItemIdsLast_ =
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
|
||||
ORDER BY created_at DESC, chat_item_id DESC
|
||||
LIMIT ?
|
||||
|]
|
||||
(userId, noteFolderId, search, count)
|
||||
|
||||
getLocalChatAfter_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTLocal)
|
||||
getLocalChatAfter_ db user@User {userId} nf@NoteFolder {noteFolderId} afterChatItemId count search = do
|
||||
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
|
||||
chatItemIds <- liftIO getLocalChatItemIdsAfter_
|
||||
chatItems <- mapM (getLocalChatItem db user noteFolderId) chatItemIds
|
||||
pure $ Chat (LocalChat nf) chatItems stats
|
||||
where
|
||||
getLocalChatItemIdsAfter_ :: IO [ChatItemId]
|
||||
getLocalChatItemIdsAfter_ =
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
|
||||
AND chat_item_id > ?
|
||||
ORDER BY created_at ASC, chat_item_id ASC
|
||||
LIMIT ?
|
||||
|]
|
||||
(userId, noteFolderId, search, afterChatItemId, count)
|
||||
|
||||
getLocalChatBefore_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTLocal)
|
||||
getLocalChatBefore_ db user@User {userId} nf@NoteFolder {noteFolderId} beforeChatItemId count search = do
|
||||
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
|
||||
chatItemIds <- liftIO getLocalChatItemIdsBefore_
|
||||
chatItems <- mapM (getLocalChatItem db user noteFolderId) chatItemIds
|
||||
pure $ Chat (LocalChat nf) (reverse chatItems) stats
|
||||
where
|
||||
getLocalChatItemIdsBefore_ :: IO [ChatItemId]
|
||||
getLocalChatItemIdsBefore_ =
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
|
||||
AND chat_item_id < ?
|
||||
ORDER BY created_at DESC, chat_item_id DESC
|
||||
LIMIT ?
|
||||
|]
|
||||
(userId, noteFolderId, search, beforeChatItemId, count)
|
||||
|
||||
toChatItemRef :: (ChatItemId, Maybe Int64, Maybe Int64, Maybe Int64) -> Either StoreError (ChatRef, ChatItemId)
|
||||
toChatItemRef = \case
|
||||
(itemId, Just contactId, Nothing) -> Right (ChatRef CTDirect contactId, itemId)
|
||||
(itemId, Nothing, Just groupId) -> Right (ChatRef CTGroup groupId, itemId)
|
||||
(itemId, _, _) -> Left $ SEBadChatItem itemId
|
||||
(itemId, Just contactId, Nothing, Nothing) -> Right (ChatRef CTDirect contactId, itemId)
|
||||
(itemId, Nothing, Just groupId, Nothing) -> Right (ChatRef CTGroup groupId, itemId)
|
||||
(itemId, Nothing, Nothing, Just folderId) -> Right (ChatRef CTLocal folderId, itemId)
|
||||
(itemId, _, _, _) -> Left $ SEBadChatItem itemId
|
||||
|
||||
updateDirectChatItemsRead :: DB.Connection -> User -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO ()
|
||||
updateDirectChatItemsRead db User {userId} contactId itemsRange_ = do
|
||||
|
|
@ -1079,6 +1291,27 @@ setGroupChatItemDeleteAt db User {userId} groupId chatItemId deleteAt =
|
|||
"UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ?"
|
||||
(deleteAt, userId, groupId, chatItemId)
|
||||
|
||||
updateLocalChatItemsRead :: DB.Connection -> User -> NoteFolderId -> Maybe (ChatItemId, ChatItemId) -> IO ()
|
||||
updateLocalChatItemsRead db User {userId} noteFolderId itemsRange_ = do
|
||||
currentTs <- getCurrentTime
|
||||
case itemsRange_ of
|
||||
Just (fromItemId, toItemId) ->
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE chat_items SET item_status = ?, updated_at = ?
|
||||
WHERE user_id = ? AND note_folder_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ?
|
||||
|]
|
||||
(CISRcvRead, currentTs, userId, noteFolderId, fromItemId, toItemId, CISRcvNew)
|
||||
_ ->
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE chat_items SET item_status = ?, updated_at = ?
|
||||
WHERE user_id = ? AND note_folder_id = ? AND item_status = ?
|
||||
|]
|
||||
(CISRcvRead, currentTs, userId, noteFolderId, CISRcvNew)
|
||||
|
||||
type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol)
|
||||
|
||||
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool)
|
||||
|
|
@ -1204,7 +1437,7 @@ getAllChatItems db vr user@User {userId} pagination search_ = do
|
|||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id, contact_id, group_id
|
||||
SELECT chat_item_id, contact_id, group_id, note_folder_id
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND item_text LIKE '%' || ? || '%'
|
||||
ORDER BY item_ts DESC, chat_item_id DESC
|
||||
|
|
@ -1215,7 +1448,7 @@ getAllChatItems db vr user@User {userId} pagination search_ = do
|
|||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id, contact_id, group_id
|
||||
SELECT chat_item_id, contact_id, group_id, note_folder_id
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND item_text LIKE '%' || ? || '%'
|
||||
AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?))
|
||||
|
|
@ -1228,7 +1461,7 @@ getAllChatItems db vr user@User {userId} pagination search_ = do
|
|||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id, contact_id, group_id
|
||||
SELECT chat_item_id, contact_id, group_id, note_folder_id
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND item_text LIKE '%' || ? || '%'
|
||||
AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?))
|
||||
|
|
@ -1714,6 +1947,89 @@ getGroupChatItemIdByText' db User {userId} groupId msg =
|
|||
|]
|
||||
(userId, groupId, msg <> "%")
|
||||
|
||||
getLocalChatItem :: DB.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTLocal)
|
||||
getLocalChatItem db User {userId} folderId itemId = ExceptT $ do
|
||||
currentTs <- getCurrentTime
|
||||
firstRow' (toLocalChatItem currentTs) (SEChatItemNotFound itemId) getItem
|
||||
where
|
||||
getItem =
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
||||
-- CIFile
|
||||
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol
|
||||
FROM chat_items i
|
||||
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
||||
WHERE i.user_id = ? AND i.note_folder_id = ? AND i.chat_item_id = ?
|
||||
|]
|
||||
(userId, folderId, itemId)
|
||||
|
||||
getLocalChatItemIdByText :: DB.Connection -> User -> NoteFolderId -> SMsgDirection d -> Text -> ExceptT StoreError IO ChatItemId
|
||||
getLocalChatItemIdByText db User {userId} noteFolderId msgDir quotedMsg =
|
||||
ExceptT . firstRow fromOnly (SEChatItemNotFoundByText quotedMsg) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND note_folder_id = ? AND item_sent = ? AND item_text LIKE ?
|
||||
ORDER BY chat_item_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, noteFolderId, msgDir, quotedMsg <> "%")
|
||||
|
||||
getLocalChatItemIdByText' :: DB.Connection -> User -> NoteFolderId -> Text -> ExceptT StoreError IO ChatItemId
|
||||
getLocalChatItemIdByText' db User {userId} noteFolderId msg =
|
||||
ExceptT . firstRow fromOnly (SEChatItemNotFoundByText msg) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE ?
|
||||
ORDER BY chat_item_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, noteFolderId, msg <> "%")
|
||||
|
||||
updateLocalChatItem' :: forall d. MsgDirectionI d => DB.Connection -> User -> NoteFolderId -> ChatItem 'CTLocal d -> CIContent d -> IO (ChatItem 'CTLocal d)
|
||||
updateLocalChatItem' db User {userId} noteFolderId ci newContent = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let ci' = updatedChatItem ci newContent False currentTs
|
||||
liftIO $ updateLocalChatItem_ db userId noteFolderId ci'
|
||||
pure ci'
|
||||
|
||||
-- this function assumes that local item with correct chat direction already exists,
|
||||
-- it should be checked before calling it
|
||||
updateLocalChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> UserId -> NoteFolderId -> ChatItem 'CTLocal d -> IO ()
|
||||
updateLocalChatItem_ db userId noteFolderId ChatItem {meta, content} = do
|
||||
let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, updatedAt} = meta
|
||||
itemDeleted' = isJust itemDeleted
|
||||
itemDeletedTs' = itemDeletedTs =<< itemDeleted
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE chat_items
|
||||
SET item_content = ?, item_text = ?, item_status = ?, item_deleted = ?, item_deleted_ts = ?, item_edited = ?, updated_at = ?
|
||||
WHERE user_id = ? AND note_folder_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
((content, itemText, itemStatus, itemDeleted', itemDeletedTs', itemEdited, updatedAt) :. (userId, noteFolderId, itemId))
|
||||
|
||||
deleteLocalChatItem :: DB.Connection -> User -> NoteFolder -> ChatItem 'CTLocal d -> IO ()
|
||||
deleteLocalChatItem db User {userId} NoteFolder {noteFolderId} ci = do
|
||||
let itemId = chatItemId' ci
|
||||
deleteChatItemVersions_ db itemId
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM chat_items
|
||||
WHERE user_id = ? AND note_folder_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
(userId, noteFolderId, itemId)
|
||||
|
||||
getChatItemByFileId :: DB.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO AChatItem
|
||||
getChatItemByFileId db vr user@User {userId} fileId = do
|
||||
(chatRef, itemId) <-
|
||||
|
|
@ -1721,7 +2037,7 @@ getChatItemByFileId db vr user@User {userId} fileId = do
|
|||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT i.chat_item_id, i.contact_id, i.group_id
|
||||
SELECT i.chat_item_id, i.contact_id, i.group_id, i.note_folder_id
|
||||
FROM chat_items i
|
||||
JOIN files f ON f.chat_item_id = i.chat_item_id
|
||||
WHERE f.user_id = ? AND f.file_id = ?
|
||||
|
|
@ -1737,7 +2053,7 @@ getChatItemByGroupId db vr user@User {userId} groupId = do
|
|||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT i.chat_item_id, i.contact_id, i.group_id
|
||||
SELECT i.chat_item_id, i.contact_id, i.group_id, i.note_folder_id
|
||||
FROM chat_items i
|
||||
JOIN groups g ON g.chat_item_id = i.chat_item_id
|
||||
WHERE g.user_id = ? AND g.group_id = ?
|
||||
|
|
@ -1766,6 +2082,10 @@ getAChatItem db vr user chatRef itemId = case chatRef of
|
|||
gInfo <- getGroupInfo db vr user groupId
|
||||
(CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId
|
||||
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci
|
||||
ChatRef CTLocal folderId -> do
|
||||
nf <- getNoteFolder db user folderId
|
||||
CChatItem msgDir ci <- getLocalChatItem db user folderId itemId
|
||||
pure $ AChatItem SCTLocal msgDir (LocalChat nf) ci
|
||||
_ -> throwError $ SEChatItemNotFound itemId
|
||||
|
||||
getChatItemVersions :: DB.Connection -> ChatItemId -> IO [ChatItemVersion]
|
||||
|
|
|
|||
|
|
@ -94,6 +94,7 @@ import Simplex.Chat.Migrations.M20231126_remote_ctrl_address
|
|||
import Simplex.Chat.Migrations.M20231207_chat_list_pagination
|
||||
import Simplex.Chat.Migrations.M20231214_item_content_tag
|
||||
import Simplex.Chat.Migrations.M20231215_recreate_msg_deliveries
|
||||
import Simplex.Chat.Migrations.M20240102_note_folders
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
|
|
@ -187,7 +188,8 @@ schemaMigrations =
|
|||
("20231126_remote_ctrl_address", m20231126_remote_ctrl_address, Just down_m20231126_remote_ctrl_address),
|
||||
("20231207_chat_list_pagination", m20231207_chat_list_pagination, Just down_m20231207_chat_list_pagination),
|
||||
("20231214_item_content_tag", m20231214_item_content_tag, Just down_m20231214_item_content_tag),
|
||||
("20231215_recreate_msg_deliveries", m20231215_recreate_msg_deliveries, Just down_m20231215_recreate_msg_deliveries)
|
||||
("20231215_recreate_msg_deliveries", m20231215_recreate_msg_deliveries, Just down_m20231215_recreate_msg_deliveries),
|
||||
("20240102_note_folders", m20240102_note_folders, Just down_m20240102_note_folders)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
|
|
|||
69
src/Simplex/Chat/Store/NoteFolders.hs
Normal file
69
src/Simplex/Chat/Store/NoteFolders.hs
Normal file
|
|
@ -0,0 +1,69 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Chat.Store.NoteFolders where
|
||||
|
||||
import Control.Monad.Except (ExceptT (..), throwError)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Time (getCurrentTime)
|
||||
import Database.SQLite.Simple (Only (..))
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Store.Shared (StoreError (..))
|
||||
import Simplex.Chat.Types (NoteFolder (..), NoteFolderId, User (..))
|
||||
import Simplex.Messaging.Agent.Protocol (UserId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
|
||||
createNoteFolder :: DB.Connection -> User -> ExceptT StoreError IO ()
|
||||
createNoteFolder db User {userId} = do
|
||||
liftIO (DB.query db "SELECT note_folder_id FROM note_folders WHERE user_id = ? LIMIT 1" $ Only userId) >>= \case
|
||||
[] -> liftIO $ DB.execute db "INSERT INTO note_folders (user_id) VALUES (?)" (Only userId)
|
||||
Only noteFolderId : _ -> throwError $ SENoteFolderAlreadyExists noteFolderId
|
||||
|
||||
getUserNoteFolderId :: DB.Connection -> User -> ExceptT StoreError IO NoteFolderId
|
||||
getUserNoteFolderId db User {userId} =
|
||||
ExceptT . firstRow fromOnly SEUserNoteFolderNotFound $
|
||||
DB.query db "SELECT note_folder_id FROM note_folders WHERE user_id = ?" (Only userId)
|
||||
|
||||
getNoteFolder :: DB.Connection -> User -> NoteFolderId -> ExceptT StoreError IO NoteFolder
|
||||
getNoteFolder db User {userId} noteFolderId =
|
||||
ExceptT . firstRow toNoteFolder (SENoteFolderNotFound noteFolderId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
created_at, updated_at, chat_ts, favorite, unread_chat
|
||||
FROM note_folders
|
||||
WHERE user_id = ?
|
||||
AND note_folder_id = ?
|
||||
|]
|
||||
(userId, noteFolderId)
|
||||
where
|
||||
toNoteFolder (createdAt, updatedAt, chatTs, favorite, unread) =
|
||||
NoteFolder {noteFolderId, userId, createdAt, updatedAt, chatTs, favorite, unread}
|
||||
|
||||
updateNoteFolderUnreadChat :: DB.Connection -> User -> NoteFolder -> Bool -> IO ()
|
||||
updateNoteFolderUnreadChat db User {userId} NoteFolder {noteFolderId} unreadChat = do
|
||||
updatedAt <- getCurrentTime
|
||||
DB.execute db "UPDATE note_folders SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND note_folder_id = ?" (unreadChat, updatedAt, userId, noteFolderId)
|
||||
|
||||
deleteNoteFolderFiles :: DB.Connection -> UserId -> NoteFolder -> IO ()
|
||||
deleteNoteFolderFiles db userId NoteFolder {noteFolderId} = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM files
|
||||
WHERE user_id = ?
|
||||
AND chat_item_id IN (
|
||||
SELECT chat_item_id FROM chat_items WHERE user_id = ? AND note_folder_id = ?
|
||||
)
|
||||
|]
|
||||
(userId, userId, noteFolderId)
|
||||
|
||||
deleteNoteFolderCIs :: DB.Connection -> User -> NoteFolder -> IO ()
|
||||
deleteNoteFolderCIs db User {userId} NoteFolder {noteFolderId} =
|
||||
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND note_folder_id = ?" (userId, noteFolderId)
|
||||
|
|
@ -27,6 +27,7 @@ module Simplex.Chat.Store.Profiles
|
|||
getUserByARcvFileId,
|
||||
getUserByContactId,
|
||||
getUserByGroupId,
|
||||
getUserByNoteFolderId,
|
||||
getUserByFileId,
|
||||
getUserFileInfo,
|
||||
deleteUserRecord,
|
||||
|
|
@ -120,6 +121,7 @@ createUserRecordAt db (AgentUserId auId) Profile {displayName, fullName, image,
|
|||
(profileId, displayName, userId, True, currentTs, currentTs, currentTs)
|
||||
contactId <- insertedRowId db
|
||||
DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId)
|
||||
|
||||
pure $ toUser $ (userId, auId, contactId, profileId, activeUser, displayName, fullName, image, Nothing, userPreferences) :. (showNtfs, sendRcptsContacts, sendRcptsSmallGroups, Nothing, Nothing)
|
||||
|
||||
getUsersInfo :: DB.Connection -> IO [UserInfo]
|
||||
|
|
@ -200,6 +202,11 @@ getUserByGroupId db groupId =
|
|||
ExceptT . firstRow toUser (SEUserNotFoundByGroupId groupId) $
|
||||
DB.query db (userQuery <> " JOIN groups g ON g.user_id = u.user_id WHERE g.group_id = ?") (Only groupId)
|
||||
|
||||
getUserByNoteFolderId :: DB.Connection -> NoteFolderId -> ExceptT StoreError IO User
|
||||
getUserByNoteFolderId db contactId =
|
||||
ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $
|
||||
DB.query db (userQuery <> " JOIN note_folders nf ON nf.user_id = u.user_id WHERE nf.note_folder_id = ?") (Only contactId)
|
||||
|
||||
getUserByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO User
|
||||
getUserByFileId db fileId =
|
||||
ExceptT . firstRow toUser (SEUserNotFoundByFileId fileId) $
|
||||
|
|
|
|||
|
|
@ -69,6 +69,9 @@ data StoreError
|
|||
| SEDuplicateGroupMember
|
||||
| SEGroupAlreadyJoined
|
||||
| SEGroupInvitationNotFound
|
||||
| SENoteFolderAlreadyExists {noteFolderId :: NoteFolderId}
|
||||
| SENoteFolderNotFound {noteFolderId :: NoteFolderId}
|
||||
| SEUserNoteFolderNotFound
|
||||
| SESndFileNotFound {fileId :: FileTransferId}
|
||||
| SESndFileInvalid {fileId :: FileTransferId}
|
||||
| SERcvFileNotFound {fileId :: FileTransferId}
|
||||
|
|
@ -76,6 +79,7 @@ data StoreError
|
|||
| SEFileNotFound {fileId :: FileTransferId}
|
||||
| SERcvFileInvalid {fileId :: FileTransferId}
|
||||
| SERcvFileInvalidDescrPart
|
||||
| SELocalFileNoTransfer {fileId :: FileTransferId}
|
||||
| SESharedMsgIdNotFoundByFileId {fileId :: FileTransferId}
|
||||
| SEFileIdNotFoundBySharedMsgId {sharedMsgId :: SharedMsgId}
|
||||
| SESndFileNotFoundXFTP {agentSndFileId :: AgentSndFileId}
|
||||
|
|
|
|||
|
|
@ -1164,6 +1164,15 @@ data FileTransferMeta = FileTransferMeta
|
|||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data LocalFileMeta = LocalFileMeta
|
||||
{ fileId :: FileTransferId,
|
||||
fileName :: String,
|
||||
filePath :: String,
|
||||
fileSize :: Integer,
|
||||
fileCryptoArgs :: Maybe CryptoFileArgs
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data XFTPSndFile = XFTPSndFile
|
||||
{ agentSndFileId :: AgentSndFileId,
|
||||
privateSndFileDescr :: Maybe Text,
|
||||
|
|
@ -1528,6 +1537,20 @@ data XGrpMemIntroCont = XGrpMemIntroCont
|
|||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | Entity for local chats
|
||||
data NoteFolder = NoteFolder
|
||||
{ noteFolderId :: NoteFolderId,
|
||||
userId :: UserId,
|
||||
createdAt :: UTCTime,
|
||||
updatedAt :: UTCTime,
|
||||
chatTs :: UTCTime,
|
||||
favorite :: Bool,
|
||||
unread :: Bool
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type NoteFolderId = Int64
|
||||
|
||||
data ServerCfg p = ServerCfg
|
||||
{ server :: ProtoServerWithAuth p,
|
||||
preset :: Bool,
|
||||
|
|
@ -1634,6 +1657,8 @@ $(JQ.deriveJSON defaultJSON ''XFTPSndFile)
|
|||
|
||||
$(JQ.deriveJSON defaultJSON ''FileTransferMeta)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''LocalFileMeta)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "FT") ''FileTransfer)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''UserPwdHash)
|
||||
|
|
@ -1648,6 +1673,8 @@ $(JQ.deriveJSON defaultJSON ''Contact)
|
|||
|
||||
$(JQ.deriveJSON defaultJSON ''ContactRef)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''NoteFolder)
|
||||
|
||||
instance ProtocolTypeI p => ToJSON (ServerCfg p) where
|
||||
toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerCfg)
|
||||
toJSON = $(JQ.mkToJSON defaultJSON ''ServerCfg)
|
||||
|
|
|
|||
|
|
@ -396,6 +396,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
|||
toChatView :: AChat -> (Text, Text, Maybe ConnStatus)
|
||||
toChatView (AChat _ (Chat (DirectChat Contact {localDisplayName, activeConn}) items _)) = ("@" <> localDisplayName, toCIPreview items Nothing, connStatus <$> activeConn)
|
||||
toChatView (AChat _ (Chat (GroupChat GroupInfo {membership, localDisplayName}) items _)) = ("#" <> localDisplayName, toCIPreview items (Just membership), Nothing)
|
||||
toChatView (AChat _ (Chat (LocalChat _) items _)) = ("*", toCIPreview items Nothing, Nothing)
|
||||
toChatView (AChat _ (Chat (ContactRequest UserContactRequest {localDisplayName}) items _)) = ("<@" <> localDisplayName, toCIPreview items Nothing, Nothing)
|
||||
toChatView (AChat _ (Chat (ContactConnection PendingContactConnection {pccConnId, pccConnStatus}) items _)) = (":" <> T.pack (show pccConnId), toCIPreview items Nothing, Just pccConnStatus)
|
||||
toCIPreview :: [CChatItem c] -> Maybe GroupMember -> Text
|
||||
|
|
@ -554,7 +555,24 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember},
|
|||
from = ttyFromGroup g m
|
||||
where
|
||||
quote = maybe [] (groupQuote g) quotedItem
|
||||
_ -> []
|
||||
LocalChat _ -> case chatDir of
|
||||
CILocalSnd -> case content of
|
||||
CISndMsgContent mc -> hideLive meta $ withLocalFile to $ sndMsg to quote mc
|
||||
CISndGroupEvent {} -> showSndItemProhibited to
|
||||
_ -> showSndItem to
|
||||
where
|
||||
to = "* "
|
||||
CILocalRcv -> case content of
|
||||
CIRcvMsgContent mc -> withLocalFile from $ rcvMsg from quote mc
|
||||
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
|
||||
CIRcvGroupEvent {} -> showRcvItemProhibited from
|
||||
_ -> showRcvItem from
|
||||
where
|
||||
from = "* "
|
||||
where
|
||||
quote = []
|
||||
ContactRequest {} -> []
|
||||
ContactConnection {} -> []
|
||||
withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of
|
||||
Nothing -> item
|
||||
Just t -> item <> styled (colored Red) (" [" <> t <> "]")
|
||||
|
|
@ -563,6 +581,7 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember},
|
|||
Just _ -> item <> styled (colored Yellow) (" [>>]" :: String)
|
||||
withSndFile = withFile viewSentFileInvitation
|
||||
withRcvFile = withFile viewReceivedFileInvitation
|
||||
withLocalFile = withFile viewLocalFile
|
||||
withFile view dir l = maybe l (\f -> l <> view dir f ts tz meta) file
|
||||
sndMsg = msg viewSentMessage
|
||||
rcvMsg = msg viewReceivedMessage
|
||||
|
|
@ -706,8 +725,15 @@ viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md
|
|||
where
|
||||
from = ttyFromGroup g m
|
||||
reactionMsg mc = quoteText mc . ttyQuotedMember . Just $ sentByMember' g itemDir
|
||||
(LocalChat _, CILocalRcv) -> case ciMsgContent content of
|
||||
Just mc -> view from $ reactionMsg mc
|
||||
_ -> []
|
||||
where
|
||||
from = "* "
|
||||
reactionMsg mc = quoteText mc $ if toMsgDirection md == MDSnd then ">>" else ">"
|
||||
(_, CIDirectSnd) -> [sentText]
|
||||
(_, CIGroupSnd) -> [sentText]
|
||||
(_, CILocalSnd) -> [sentText]
|
||||
where
|
||||
view from msg
|
||||
| showReactions = viewReceivedReaction from msg reactionText ts tz sentAt
|
||||
|
|
@ -1569,6 +1595,11 @@ receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIF
|
|||
_ -> []
|
||||
receivingFile_' _ _ status _ = [plain status <> " receiving file"] -- shouldn't happen
|
||||
|
||||
viewLocalFile :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
||||
viewLocalFile to CIFile {fileId, fileSource} ts tz = case fileSource of
|
||||
Just (CryptoFile fPath _) -> sentWithTime_ ts tz [to <> fileTransferStr fileId fPath]
|
||||
_ -> const []
|
||||
|
||||
cryptoFileArgsStr :: Bool -> CryptoFileArgs -> ByteString
|
||||
cryptoFileArgsStr testView cfArgs@(CFArgs key nonce)
|
||||
| testView = LB.toStrict $ J.encode cfArgs
|
||||
|
|
@ -1875,6 +1906,7 @@ viewChatError logLevel testView = \case
|
|||
SEDuplicateGroupMessage {groupId, sharedMsgId}
|
||||
| testView -> ["duplicate group message, group id: " <> sShow groupId <> ", message id: " <> sShow sharedMsgId]
|
||||
| otherwise -> []
|
||||
SEUserNoteFolderNotFound -> ["no notes folder"]
|
||||
e -> ["chat db error: " <> sShow e]
|
||||
ChatErrorDatabase err -> case err of
|
||||
DBErrorEncrypted -> ["error: chat database is already encrypted"]
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ import ChatTests.ChatList
|
|||
import ChatTests.Direct
|
||||
import ChatTests.Files
|
||||
import ChatTests.Groups
|
||||
import ChatTests.Local
|
||||
import ChatTests.Profiles
|
||||
import Test.Hspec
|
||||
|
||||
|
|
@ -11,6 +12,7 @@ chatTests :: SpecWith FilePath
|
|||
chatTests = do
|
||||
describe "direct tests" chatDirectTests
|
||||
describe "group tests" chatGroupTests
|
||||
describe "local chats tests" chatLocalChatsTests
|
||||
describe "file tests" chatFileTests
|
||||
describe "profile tests" chatProfileTests
|
||||
describe "chat list pagination tests" chatListTests
|
||||
|
|
|
|||
|
|
@ -191,17 +191,23 @@ testPaginationAllChatTypes =
|
|||
connectUsers alice dan
|
||||
alice <##> dan
|
||||
|
||||
ts6 <- iso8601Show <$> getCurrentTime
|
||||
_ts6 <- iso8601Show <$> getCurrentTime
|
||||
|
||||
getChats_ alice "count=10" [("@dan", "hey"), ("#team", ""), (":3", ""), ("<@cath", ""), ("@bob", "hey")]
|
||||
getChats_ alice "count=3" [("@dan", "hey"), ("#team", ""), (":3", "")]
|
||||
-- * (notes)
|
||||
createCCNoteFolder alice
|
||||
alice /* "psst"
|
||||
|
||||
ts7 <- iso8601Show <$> getCurrentTime
|
||||
|
||||
getChats_ alice "count=10" [("*", "psst"), ("@dan", "hey"), ("#team", ""), (":3", ""), ("<@cath", ""), ("@bob", "hey")]
|
||||
getChats_ alice "count=3" [("*", "psst"), ("@dan", "hey"), ("#team", "")]
|
||||
getChats_ alice ("after=" <> ts2 <> " count=2") [(":3", ""), ("<@cath", "")]
|
||||
getChats_ alice ("before=" <> ts5 <> " count=2") [("#team", ""), (":3", "")]
|
||||
getChats_ alice ("after=" <> ts3 <> " count=10") [("@dan", "hey"), ("#team", ""), (":3", "")]
|
||||
getChats_ alice ("after=" <> ts3 <> " count=10") [("*", "psst"), ("@dan", "hey"), ("#team", ""), (":3", "")]
|
||||
getChats_ alice ("before=" <> ts4 <> " count=10") [(":3", ""), ("<@cath", ""), ("@bob", "hey")]
|
||||
getChats_ alice ("after=" <> ts1 <> " count=10") [("@dan", "hey"), ("#team", ""), (":3", ""), ("<@cath", ""), ("@bob", "hey")]
|
||||
getChats_ alice ("before=" <> ts6 <> " count=10") [("@dan", "hey"), ("#team", ""), (":3", ""), ("<@cath", ""), ("@bob", "hey")]
|
||||
getChats_ alice ("after=" <> ts6 <> " count=10") []
|
||||
getChats_ alice ("after=" <> ts1 <> " count=10") [("*", "psst"), ("@dan", "hey"), ("#team", ""), (":3", ""), ("<@cath", ""), ("@bob", "hey")]
|
||||
getChats_ alice ("before=" <> ts7 <> " count=10") [("*", "psst"), ("@dan", "hey"), ("#team", ""), (":3", ""), ("<@cath", ""), ("@bob", "hey")]
|
||||
getChats_ alice ("after=" <> ts7 <> " count=10") []
|
||||
getChats_ alice ("before=" <> ts1 <> " count=10") []
|
||||
|
||||
let queryFavorite = "{\"type\": \"filters\", \"favorite\": true, \"unread\": false}"
|
||||
|
|
|
|||
|
|
@ -1386,14 +1386,14 @@ testMultipleUserAddresses =
|
|||
cLinkAlisa <- getContactLink alice True
|
||||
bob ##> ("/c " <> cLinkAlisa)
|
||||
alice <#? bob
|
||||
alice #$> ("/_get chats 2 pcc=on", chats, [("<@bob", "")])
|
||||
alice #$> ("/_get chats 2 pcc=on", chats, [("<@bob", ""), ("*", "")])
|
||||
alice ##> "/ac bob"
|
||||
alice <## "bob (Bob): accepting contact request..."
|
||||
concurrently_
|
||||
(bob <## "alisa: contact is connected")
|
||||
(alice <## "bob (Bob): contact is connected")
|
||||
threadDelay 100000
|
||||
alice #$> ("/_get chats 2 pcc=on", chats, [("@bob", lastChatFeature)])
|
||||
alice #$> ("/_get chats 2 pcc=on", chats, [("@bob", lastChatFeature), ("*", "")])
|
||||
alice <##> bob
|
||||
|
||||
bob #> "@alice hey alice"
|
||||
|
|
@ -1424,7 +1424,7 @@ testMultipleUserAddresses =
|
|||
(cath <## "alisa: contact is connected")
|
||||
(alice <## "cath (Catherine): contact is connected")
|
||||
threadDelay 100000
|
||||
alice #$> ("/_get chats 2 pcc=on", chats, [("@cath", lastChatFeature), ("@bob", "hey")])
|
||||
alice #$> ("/_get chats 2 pcc=on", chats, [("@cath", lastChatFeature), ("@bob", "hey"), ("*", "")])
|
||||
alice <##> cath
|
||||
|
||||
-- first user doesn't have cath as contact
|
||||
|
|
|
|||
189
tests/ChatTests/Local.hs
Normal file
189
tests/ChatTests/Local.hs
Normal file
|
|
@ -0,0 +1,189 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PostfixOperators #-}
|
||||
|
||||
module ChatTests.Local where
|
||||
|
||||
import ChatClient
|
||||
import ChatTests.ChatList (getChats_)
|
||||
import ChatTests.Utils
|
||||
import Data.Time (getCurrentTime)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
import Simplex.Chat.Controller (ChatConfig (..), InlineFilesConfig (..), defaultInlineFilesConfig)
|
||||
import System.Directory (copyFile, doesFileExist)
|
||||
import System.FilePath ((</>))
|
||||
import Test.Hspec
|
||||
import UnliftIO.Async (concurrently_)
|
||||
|
||||
chatLocalChatsTests :: SpecWith FilePath
|
||||
chatLocalChatsTests = do
|
||||
describe "note folders" $ do
|
||||
it "create folders, add notes, read, search" testNotes
|
||||
it "switch users" testUserNotes
|
||||
it "preview pagination for notes" testPreviewsPagination
|
||||
it "chat pagination" testChatPagination
|
||||
it "stores files" testFiles
|
||||
it "deleting files does not interfere with other chat types" testOtherFiles
|
||||
|
||||
testNotes :: FilePath -> IO ()
|
||||
testNotes tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
createCCNoteFolder alice
|
||||
|
||||
alice ##> "/contacts"
|
||||
-- not a contact
|
||||
|
||||
alice /* "keep in mind"
|
||||
alice ##> "/tail"
|
||||
alice <# "* keep in mind"
|
||||
alice ##> "/chats"
|
||||
alice <# "* keep in mind"
|
||||
alice ##> "/? keep"
|
||||
alice <# "* keep in mind"
|
||||
|
||||
alice #$> ("/_read chat *1 from=1 to=100", id, "ok")
|
||||
alice ##> "/_unread chat *1 on"
|
||||
alice <## "ok"
|
||||
|
||||
alice ##> "/_delete item *1 1 internal"
|
||||
alice <## "message deleted"
|
||||
alice ##> "/tail"
|
||||
alice ##> "/chats"
|
||||
|
||||
alice /* "ahoy!"
|
||||
alice ##> "/_update item *1 1 text Greetings."
|
||||
alice ##> "/tail *"
|
||||
alice <# "* Greetings."
|
||||
|
||||
testUserNotes :: FilePath -> IO ()
|
||||
testUserNotes tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
createCCNoteFolder alice
|
||||
|
||||
alice /* "keep in mind"
|
||||
alice ##> "/tail"
|
||||
alice <# "* keep in mind"
|
||||
|
||||
alice ##> "/create user secret"
|
||||
alice <## "user profile: secret"
|
||||
alice <## "use /p <display name> to change it"
|
||||
alice <## "(the updated profile will be sent to all your contacts)"
|
||||
|
||||
alice ##> "/tail"
|
||||
|
||||
alice ##> "/_delete item *1 1 internal"
|
||||
alice <## "chat db error: SENoteFolderNotFound {noteFolderId = 1}"
|
||||
|
||||
testPreviewsPagination :: FilePath -> IO ()
|
||||
testPreviewsPagination tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
createCCNoteFolder alice
|
||||
|
||||
tsS <- iso8601Show <$> getCurrentTime
|
||||
alice /* "first"
|
||||
tsM <- iso8601Show <$> getCurrentTime
|
||||
alice /* "last"
|
||||
tsE <- iso8601Show <$> getCurrentTime
|
||||
|
||||
-- there's only one folder that got updated after tsM and before tsE
|
||||
getChats_ alice "count=3" [("*", "last")]
|
||||
getChats_ alice ("after=" <> tsE <> " count=10") []
|
||||
getChats_ alice ("after=" <> tsS <> " count=10") [("*", "last")]
|
||||
getChats_ alice ("before=" <> tsM <> " count=10") []
|
||||
getChats_ alice ("before=" <> tsE <> " count=10") [("*", "last")]
|
||||
getChats_ alice ("before=" <> tsS <> " count=10") []
|
||||
|
||||
testChatPagination :: FilePath -> IO ()
|
||||
testChatPagination tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
createCCNoteFolder alice
|
||||
|
||||
alice /* "hello world"
|
||||
alice /* "memento mori"
|
||||
alice /* "knock-knock"
|
||||
alice /* "who's there?"
|
||||
|
||||
alice #$> ("/_get chat *1 count=100", chat, [(1, "hello world"), (1, "memento mori"), (1, "knock-knock"), (1, "who's there?")])
|
||||
alice #$> ("/_get chat *1 count=1", chat, [(1, "who's there?")])
|
||||
alice #$> ("/_get chat *1 after=2 count=10", chat, [(1, "knock-knock"), (1, "who's there?")])
|
||||
alice #$> ("/_get chat *1 after=2 count=2", chat, [(1, "knock-knock"), (1, "who's there?")])
|
||||
alice #$> ("/_get chat *1 after=1 count=2", chat, [(1, "memento mori"), (1, "knock-knock")])
|
||||
alice #$> ("/_get chat *1 before=3 count=10", chat, [(1, "hello world"), (1, "memento mori")])
|
||||
alice #$> ("/_get chat *1 before=3 count=2", chat, [(1, "hello world"), (1, "memento mori")])
|
||||
alice #$> ("/_get chat *1 before=4 count=2", chat, [(1, "memento mori"), (1, "knock-knock")])
|
||||
|
||||
alice #$> ("/_get chat *1 count=10 search=k-k", chat, [(1, "knock-knock")])
|
||||
|
||||
testFiles :: FilePath -> IO ()
|
||||
testFiles tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
-- setup
|
||||
createCCNoteFolder alice
|
||||
let files = "./tests/tmp/app_files"
|
||||
alice ##> ("/_files_folder " <> files)
|
||||
alice <## "ok"
|
||||
|
||||
-- ui-like upload
|
||||
let source = "./tests/fixtures/test.jpg"
|
||||
let stored = files </> "test.jpg"
|
||||
copyFile source stored
|
||||
alice ##> "/_create *1 json {\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"hi myself\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}"
|
||||
alice <# "* hi myself"
|
||||
alice <# "* file 1 (test.jpg)"
|
||||
|
||||
alice ##> "/tail"
|
||||
alice <# "* hi myself"
|
||||
alice <# "* file 1 (test.jpg)"
|
||||
|
||||
alice ##> "/_get chat *1 count=100"
|
||||
r <- chatF <$> getTermLine alice
|
||||
r `shouldBe` [((1, "hi myself"), Just "test.jpg")]
|
||||
|
||||
alice ##> "/fs 1"
|
||||
alice <## "bad chat command: not supported for local files"
|
||||
|
||||
alice ##> "/fc 1"
|
||||
alice <## "chat db error: SELocalFileNoTransfer {fileId = 1}"
|
||||
|
||||
-- one more file
|
||||
let stored2 = files </> "another_test.jpg"
|
||||
copyFile source stored2
|
||||
alice ##> "/_create *1 json {\"filePath\": \"another_test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}"
|
||||
alice <# "* file 2 (another_test.jpg)"
|
||||
|
||||
alice ##> "/_delete item *1 2 internal"
|
||||
alice <## "message deleted"
|
||||
doesFileExist stored2 `shouldReturn` False
|
||||
doesFileExist stored `shouldReturn` True
|
||||
|
||||
alice ##> "/clear *"
|
||||
alice ##> "/fs 1"
|
||||
alice <## "chat db error: SEChatItemNotFoundByFileId {fileId = 1}"
|
||||
alice ##> "/tail"
|
||||
doesFileExist stored `shouldReturn` False
|
||||
|
||||
testOtherFiles :: FilePath -> IO ()
|
||||
testOtherFiles =
|
||||
testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do
|
||||
connectUsers alice bob
|
||||
createCCNoteFolder bob
|
||||
bob ##> "/_files_folder ./tests/tmp/"
|
||||
bob <## "ok"
|
||||
alice ##> "/_send @2 json {\"msgContent\":{\"type\":\"voice\", \"duration\":10, \"text\":\"\"}, \"filePath\":\"./tests/fixtures/test.jpg\"}"
|
||||
alice <# "@bob voice message (00:10)"
|
||||
alice <# "/f @bob ./tests/fixtures/test.jpg"
|
||||
-- below is not shown in "sent" mode
|
||||
-- alice <## "use /fc 1 to cancel sending"
|
||||
bob <# "alice> voice message (00:10)"
|
||||
bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
|
||||
-- below is not shown in "sent" mode
|
||||
-- bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||
bob <## "started receiving file 1 (test.jpg) from alice"
|
||||
concurrently_
|
||||
(alice <## "completed sending file 1 (test.jpg) to bob")
|
||||
(bob <## "completed receiving file 1 (test.jpg) from alice")
|
||||
|
||||
bob /* "test"
|
||||
bob ##> "/tail *"
|
||||
bob <# "* test"
|
||||
bob ##> "/clear *"
|
||||
bob ##> "/tail *"
|
||||
bob ##> "/fs 1"
|
||||
bob <## "receiving file 1 (test.jpg) complete, path: test.jpg"
|
||||
doesFileExist "./tests/tmp/test.jpg" `shouldReturn` True
|
||||
where
|
||||
cfg = testCfg {inlineFiles = defaultInlineFilesConfig {offerChunks = 100, sendChunks = 100, receiveChunks = 100}}
|
||||
|
|
@ -11,6 +11,7 @@ import Control.Concurrent (threadDelay)
|
|||
import Control.Concurrent.Async (concurrently_)
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad (unless, when)
|
||||
import Control.Monad.Except (runExceptT)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (isDigit)
|
||||
import Data.List (isPrefixOf, isSuffixOf)
|
||||
|
|
@ -20,6 +21,7 @@ import qualified Data.Text as T
|
|||
import Database.SQLite.Simple (Only (..))
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), InlineFilesConfig (..), defaultInlineFilesConfig)
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Store.NoteFolders (createNoteFolder)
|
||||
import Simplex.Chat.Store.Profiles (getUserContactProfiles)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
|
|
@ -287,6 +289,11 @@ cc <##.. ls = do
|
|||
unless prefix $ print ("expected to start from one of: " <> show ls, ", got: " <> l)
|
||||
prefix `shouldBe` True
|
||||
|
||||
(/*) :: HasCallStack => TestCC -> String -> IO ()
|
||||
cc /* note = do
|
||||
cc `send` ("/* " <> note)
|
||||
(dropTime <$> getTermLine cc) `shouldReturn` ("* " <> note)
|
||||
|
||||
data ConsoleResponse
|
||||
= ConsoleString String
|
||||
| WithTime String
|
||||
|
|
@ -462,6 +469,12 @@ withCCTransaction :: TestCC -> (DB.Connection -> IO a) -> IO a
|
|||
withCCTransaction cc action =
|
||||
withTransaction (chatStore $ chatController cc) $ \db -> action db
|
||||
|
||||
createCCNoteFolder :: TestCC -> IO ()
|
||||
createCCNoteFolder cc =
|
||||
withCCTransaction cc $ \db ->
|
||||
withCCUser cc $ \user ->
|
||||
runExceptT (createNoteFolder db user) >>= either (fail . show) pure
|
||||
|
||||
getProfilePictureByName :: TestCC -> String -> IO (Maybe String)
|
||||
getProfilePictureByName cc displayName =
|
||||
withTransaction (chatStore $ chatController cc) $ \db ->
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue