mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01: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
committed by
GitHub
GitHub
parent
5b7a09f488
commit
bc8a6f4833
+116
-17
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user