diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index ae43c2ac0e..764170f276 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -64,7 +64,7 @@ import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout) import Text.Read (readMaybe) import UnliftIO.Async import UnliftIO.Concurrent (forkIO, threadDelay) -import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getFileSize, getHomeDirectory, getTemporaryDirectory) +import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getFileSize, getHomeDirectory, getTemporaryDirectory, removeFile, removePathForcibly) import qualified UnliftIO.Exception as E import UnliftIO.IO (hClose, hSeek, hTell) import UnliftIO.STM @@ -118,7 +118,8 @@ newChatController chatStore user cfg@ChatConfig {agentConfig = aCfg, tbqSize} Ch chatLock <- newTMVarIO () sndFiles <- newTVarIO M.empty rcvFiles <- newTVarIO M.empty - pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, config, sendNotification} + filesFolder <- newTVarIO Nothing + pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, config, sendNotification, filesFolder} where resolveServers :: IO (NonEmpty SMPServer) resolveServers = case user of @@ -172,6 +173,11 @@ processChatCommand = \case asks agentAsync >>= readTVarIO >>= \case Just _ -> pure CRChatRunning _ -> startChatController user $> CRChatStarted + SetFilesFolder filesFolder' -> withUser' $ \_ -> do + createDirectoryIfMissing True filesFolder' + ff <- asks filesFolder + atomically . writeTVar ff $ Just filesFolder' + pure CRCmdOk APIGetChats -> CRApiChats <$> withUser (\user -> withStore (`getChatPreviews` user)) APIGetChat cType cId pagination -> withUser $ \user -> case cType of CTDirect -> CRApiChat . AChat SCTDirect <$> withStore (\st -> getDirectChat st user cId pagination) @@ -291,13 +297,15 @@ processChatCommand = \case CTContactRequest -> pure $ chatCmdError "not supported" APIDeleteChatItem cType chatId itemId mode -> withUser $ \user@User {userId} -> withChatLock $ case cType of CTDirect -> do - (ct@Contact {localDisplayName = c}, CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}}) <- withStore $ \st -> (,) <$> getContact st userId chatId <*> getDirectChatItem st userId chatId itemId + (ct@Contact {localDisplayName = c}, CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file}) <- withStore $ \st -> (,) <$> getContact st userId chatId <*> getDirectChatItem st userId chatId itemId case (mode, msgDir, itemSharedMsgId) of (CIDMInternal, _, _) -> do + deleteFile file toCi <- withStore $ \st -> deleteDirectChatItemInternal st userId ct itemId pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do SndMessage {msgId} <- sendDirectContactMessage ct (XMsgDel itemSharedMId) + deleteFile file toCi <- withStore $ \st -> deleteDirectChatItemSndBroadcast st userId ct itemId msgId setActive $ ActiveC c pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi @@ -317,6 +325,10 @@ processChatCommand = \case pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi (CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete CTContactRequest -> pure $ chatCmdError "not supported" + where + deleteFile :: MsgDirectionI d => Maybe (CIFile d) -> m () + deleteFile (Just CIFile {fileId, filePath, fileStatus}) = deleteFiles [(fileId, filePath, AFS msgDirection fileStatus)] + deleteFile Nothing = pure () APIChatRead cType chatId fromToIds -> withChatLock $ case cType of CTDirect -> withStore (\st -> updateDirectChatItemsRead st chatId fromToIds) $> CRCmdOk CTGroup -> withStore (\st -> updateGroupChatItemsRead st chatId fromToIds) $> CRCmdOk @@ -326,8 +338,10 @@ processChatCommand = \case ct@Contact {localDisplayName} <- withStore $ \st -> getContact st userId chatId withStore (\st -> getContactGroupNames st userId ct) >>= \case [] -> do + files <- withStore $ \st -> getContactFiles st userId ct conns <- withStore $ \st -> getContactConnections st userId ct withChatLock . procCmd $ do + deleteFiles files withAgent $ \a -> forM_ conns $ \conn -> deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure () withStore $ \st -> deleteContact st userId ct @@ -641,8 +655,9 @@ processChatCommand = \case cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft checkSndFile :: FilePath -> m (Integer, Integer) checkSndFile f = do - unlessM (doesFileExist f) . throwChatError $ CEFileNotFound f - (,) <$> getFileSize f <*> asks (fileChunkSize . config) + fsFilePath <- toFSFilePath f + unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f + (,) <$> getFileSize fsFilePath <*> asks (fileChunkSize . config) updateProfile :: User -> Profile -> m ChatResponse updateProfile user@User {profile = p} p'@Profile {displayName} | p' == p = pure CRUserProfileNoChange @@ -660,6 +675,33 @@ processChatCommand = \case let s = connStatus $ activeConn (ct :: Contact) in s == ConnReady || s == ConnSndReady +-- mobile clients use file paths relative to app directory (e.g. for the reason ios app directory changes on updates), +-- so we have to differentiate between the file path stored in db and communicated with frontend, and the file path +-- used during file transfer for actual operations with file system +toFSFilePath :: ChatMonad m => FilePath -> m FilePath +toFSFilePath f = do + ff <- asks filesFolder + readTVarIO ff >>= \case + Nothing -> pure f + Just filesFolder -> pure $ filesFolder <> "/" <> f + +deleteFiles :: ChatMonad m => [(Int64, Maybe FilePath, ACIFileStatus)] -> m () +deleteFiles files = do + ff <- asks filesFolder + readTVarIO ff >>= \case + Nothing -> pure () -- only delete files if filesFolder is set (i.e. on mobile devices) + Just filesFolder -> + forM_ files $ \(fileId, filePath_, status) -> do + case status of + AFS _ CIFSRcvTransfer -> closeFileHandle fileId rcvFiles + _ -> pure () + case filePath_ of + Just filePath -> do + let fsFilePath = filesFolder <> "/" <> filePath + removeFile fsFilePath `E.catch` \(_ :: E.SomeException) -> + removePathForcibly fsFilePath `E.catch` \(_ :: E.SomeException) -> pure () + Nothing -> pure () + acceptFileReceive :: forall m. ChatMonad m => User -> RcvFileTransfer -> Maybe FilePath -> m FilePath acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName = fName, fileConnReq}, fileStatus, senderDisplayName, grpMemberId} filePath_ = do unless (fileStatus == RFSNew) . throwChatError $ CEFileAlreadyReceiving fName @@ -697,10 +739,17 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = F getRcvFilePath :: Maybe FilePath -> String -> m FilePath getRcvFilePath fPath_ fn = case fPath_ of Nothing -> do - dir <- (`combine` "Downloads") <$> getHomeDirectory - ifM (doesDirectoryExist dir) (pure dir) getTemporaryDirectory - >>= (`uniqueCombine` fn) - >>= createEmptyFile + ff <- asks filesFolder + readTVarIO ff >>= \case + Nothing -> do + dir <- (`combine` "Downloads") <$> getHomeDirectory + ifM (doesDirectoryExist dir) (pure dir) getTemporaryDirectory + >>= (`uniqueCombine` fn) + >>= createEmptyFile + Just filesFolder -> + filesFolder `uniqueCombine` fn + >>= createEmptyFile + >>= pure <$> takeFileName Just fPath -> ifM (doesDirectoryExist fPath) @@ -1109,11 +1158,12 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage then badRcvFileChunk ft "incorrect chunk size" else do appendFileChunk ft chunkNo chunk - withStore $ \st -> do + ci <- withStore $ \st -> do updateRcvFileStatus st ft FSComplete updateCIFileStatus st userId fileId CIFSRcvComplete deleteRcvFileChunks st ft - toView $ CRRcvFileComplete ft + getChatItemByFileId st user fileId + toView $ CRRcvFileComplete ci closeFileHandle fileId rcvFiles withAgent (`deleteConnection` agentConnId) RcvChunkDuplicate -> pure () @@ -1239,6 +1289,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemId}} <- withStore $ \st -> getDirectChatItemBySharedMsgId st userId contactId sharedMsgId case msgDir of SMDRcv -> do + -- TODO either allow to locally delete items that were broadcast deleted by sender, or delete attached files toCi <- withStore $ \st -> deleteDirectChatItemRcvBroadcast st userId ct itemId msgId toView $ CRChatItemDeleted (AChatItem SCTDirect SMDRcv (DirectChat ct) deletedItem) toCi checkIntegrity msgMeta $ toView . CRMsgIntegrityError @@ -1516,11 +1567,12 @@ sendFileChunkNo ft@SndFileTransfer {agentConnId = AgentConnId acId} chunkNo = do withStore $ \st -> updateSndFileChunkMsg st ft chunkNo msgId readFileChunk :: ChatMonad m => SndFileTransfer -> Integer -> m ByteString -readFileChunk SndFileTransfer {fileId, filePath, chunkSize} chunkNo = - read_ `E.catch` (throwChatError . CEFileRead filePath . (show :: E.SomeException -> String)) +readFileChunk SndFileTransfer {fileId, filePath, chunkSize} chunkNo = do + fsFilePath <- toFSFilePath filePath + read_ fsFilePath `E.catch` (throwChatError . CEFileRead filePath . (show :: E.SomeException -> String)) where - read_ = do - h <- getFileHandle fileId filePath sndFiles ReadMode + read_ fsFilePath = do + h <- getFileHandle fileId fsFilePath sndFiles ReadMode pos <- hTell h let pos' = (chunkNo - 1) * chunkSize when (pos /= pos') $ hSeek h AbsoluteSeek pos' @@ -1548,12 +1600,14 @@ parseFileChunk msg = appendFileChunk :: ChatMonad m => RcvFileTransfer -> Integer -> ByteString -> m () appendFileChunk ft@RcvFileTransfer {fileId, fileStatus} chunkNo chunk = case fileStatus of - RFSConnected RcvFileInfo {filePath} -> append_ filePath + RFSConnected RcvFileInfo {filePath} -> do + fsFilePath <- toFSFilePath filePath + append_ filePath fsFilePath RFSCancelled _ -> pure () _ -> throwChatError $ CEFileInternal "receiving file transfer not in progress" where - append_ fPath = do - h <- getFileHandle fileId fPath rcvFiles AppendMode + append_ fPath fPathUsed = do + h <- getFileHandle fileId fPathUsed rcvFiles AppendMode E.try (liftIO $ B.hPut h chunk >> hFlush h) >>= \case Left (e :: E.SomeException) -> throwChatError . CEFileWrite fPath $ show e Right () -> withStore $ \st -> updatedRcvFileChunkStored st ft chunkNo @@ -1815,6 +1869,7 @@ chatCommandP = ("/user " <|> "/u ") *> (CreateActiveUser <$> userProfile) <|> ("/user" <|> "/u") $> ShowActiveUser <|> "/_start" $> StartChat + <|> "/_files_folder " *> (SetFilesFolder <$> filePath) <|> "/_get chats" $> APIGetChats <|> "/_get chat " *> (APIGetChat <$> chatTypeP <*> A.decimal <* A.space <*> chatPaginationP) <|> "/_get items count=" *> (APIGetChatItems <$> A.decimal) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 1842b632c9..dcd334c610 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -77,7 +77,8 @@ data ChatController = ChatController chatLock :: TMVar (), sndFiles :: TVar (Map Int64 Handle), rcvFiles :: TVar (Map Int64 Handle), - config :: ChatConfig + config :: ChatConfig, + filesFolder :: TVar (Maybe FilePath) -- path to files folder for mobile apps } data HelpSection = HSMain | HSFiles | HSGroups | HSMyAddress | HSMarkdown | HSMessages @@ -91,6 +92,7 @@ data ChatCommand = ShowActiveUser | CreateActiveUser Profile | StartChat + | SetFilesFolder FilePath | APIGetChats | APIGetChat ChatType Int64 ChatPagination | APIGetChatItems Int @@ -200,7 +202,7 @@ data ChatResponse | CRRcvFileAccepted {fileTransfer :: RcvFileTransfer, filePath :: FilePath} | CRRcvFileAcceptedSndCancelled {rcvFileTransfer :: RcvFileTransfer} | CRRcvFileStart {rcvFileTransfer :: RcvFileTransfer} - | CRRcvFileComplete {rcvFileTransfer :: RcvFileTransfer} + | CRRcvFileComplete {chatItem :: AChatItem} | CRRcvFileCancelled {rcvFileTransfer :: RcvFileTransfer} | CRRcvFileSndCancelled {rcvFileTransfer :: RcvFileTransfer} | CRSndFileStart {sndFileTransfer :: SndFileTransfer} diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 9869b3692c..64d6587834 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Simplex.Chat.Mobile where @@ -48,7 +49,7 @@ cChatRecvMsg cc = deRefStablePtr cc >>= chatRecvMsg >>= newCAString mobileChatOpts :: ChatOpts mobileChatOpts = ChatOpts - { dbFilePrefix = "simplex_v1", -- two database files will be created: simplex_v1_chat.db and simplex_v1_agent.db + { dbFilePrefix = undefined, smpServers = [], logConnections = False, logAgent = False, diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 19a7cfefb3..ba2219bf4d 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -115,6 +115,7 @@ module Simplex.Chat.Store updateFileTransferChatItemId, getFileTransfer, getFileTransferProgress, + getContactFiles, createNewSndMessage, createSndMsgDelivery, createNewMessageAndRcvMsgDelivery, @@ -135,6 +136,7 @@ module Simplex.Chat.Store getGroupChatItemBySharedMsgId, getDirectChatItemIdByText, getGroupChatItemIdByText, + getChatItemByFileId, updateDirectChatItemStatus, updateDirectChatItem, deleteDirectChatItemInternal, @@ -2214,6 +2216,19 @@ getFileTransferMeta_ db userId fileId = fileTransferMeta (fileName, fileSize, chunkSize, filePath, cancelled_) = FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, cancelled = fromMaybe False cancelled_} +getContactFiles :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> m [(Int64, Maybe FilePath, ACIFileStatus)] +getContactFiles st userId Contact {contactId} = + liftIO . withTransaction st $ \db -> + DB.query + db + [sql| + SELECT f.file_id, f.file_path, f.ci_file_status + FROM chat_items i + JOIN files f ON f.chat_item_id = i.chat_item_id + WHERE i.user_id = ? AND i.contact_id = ? + |] + (userId, contactId) + createNewSndMessage :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage) -> m SndMessage createNewSndMessage st gVar connOrGroupId mkMessage = liftIOEither . withTransaction st $ \db -> @@ -3367,6 +3382,35 @@ getGroupChatItemIdByText st User {userId, localDisplayName = userName} groupId c |] (userId, groupId, cName, quotedMsg <> "%") +getChatItemByFileId :: StoreMonad m => SQLiteStore -> User -> Int64 -> m AChatItem +getChatItemByFileId st user@User {userId} fileId = do + liftIOEither . withTransaction st $ \db -> runExceptT $ do + r <- ExceptT $ getChatItemIdByFileId_ db userId fileId + case r of + (itemId, Just contactId, Nothing) -> do + ct <- ExceptT $ getContact_ db userId contactId + (CChatItem msgDir ci) <- ExceptT $ getDirectChatItem_ db userId contactId itemId + pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci + (itemId, Nothing, Just groupId) -> do + gInfo <- ExceptT $ getGroupInfo_ db user groupId + (CChatItem msgDir ci) <- ExceptT $ getGroupChatItem_ db user groupId itemId + pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci + _ -> throwError $ SEChatItemNotFoundByFileId fileId + +getChatItemIdByFileId_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError (ChatItemId, Maybe Int64, Maybe Int64)) +getChatItemIdByFileId_ db userId fileId = + firstRow id (SEChatItemNotFoundByFileId fileId) $ + DB.query + db + [sql| + SELECT i.chat_item_id, i.contact_id, i.group_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 = ? + LIMIT 1 + |] + (userId, fileId) + updateDirectChatItemsRead :: (StoreMonad m) => SQLiteStore -> Int64 -> (ChatItemId, ChatItemId) -> m () updateDirectChatItemsRead st contactId (fromItemId, toItemId) = do currentTs <- liftIO getCurrentTime @@ -3608,6 +3652,7 @@ data StoreError | SEChatItemNotFound {itemId :: ChatItemId} | SEQuotedChatItemNotFound | SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId} + | SEChatItemNotFoundByFileId {fileId :: FileTransferId} deriving (Show, Exception, Generic) instance ToJSON StoreError where diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index c1d1d73a47..9a725a9936 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -100,7 +100,7 @@ responseToView testView = \case CRContactsMerged intoCt mergedCt -> viewContactsMerged intoCt mergedCt CRReceivedContactRequest UserContactRequest {localDisplayName = c, profile} -> viewReceivedContactRequest c profile CRRcvFileStart ft -> receivingFile_ "started" ft - CRRcvFileComplete ft -> receivingFile_ "completed" ft + CRRcvFileComplete ci -> receivingFile_' "completed" ci CRRcvFileSndCancelled ft -> viewRcvFileSndCancelled ft CRSndFileStart ft -> sendingFile_ "started" ft CRSndFileComplete ft -> sendingFile_ "completed" ft @@ -548,6 +548,13 @@ humanReadableSize size mB = kB * 1024 gB = mB * 1024 +receivingFile_' :: StyledString -> AChatItem -> [StyledString] +receivingFile_' status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectRcv}) = + [status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyContact c] +receivingFile_' status (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupRcv GroupMember {localDisplayName = m}}) = + [status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyContact m] +receivingFile_' status _ = [status <> " receiving file"] -- shouldn't happen + receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString] receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} = [status <> " receiving " <> rcvFile ft <> " from " <> ttyContact c] diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index f6875594e5..7abf2f6b56 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -66,6 +66,7 @@ chatTests = do describe "messages with files" $ do it "send and receive message with file" testMessageWithFile it "send and receive image" testSendImage + it "send and receive image with files folders (for mobile)" testSendImageWithFilesFolders it "send and receive image with text and quote" testSendImageWithTextAndQuote it "send and receive image to group" testGroupSendImage it "send and receive image with text and quote to group" testGroupSendImageWithTextAndQuote @@ -1261,6 +1262,42 @@ testSendImage = dest `shouldBe` src alice #$> ("/_get chat @2 count=100", chatF, [((1, ""), Just "./tests/fixtures/test.jpg")]) bob #$> ("/_get chat @2 count=100", chatF, [((0, ""), Just "./tests/tmp/test.jpg")]) + -- deleting contact without files folder set should not remove file + bob ##> "/d alice" + bob <## "alice: contact is deleted" + fileExists <- doesFileExist "./tests/tmp/test.jpg" + fileExists `shouldBe` True + +testSendImageWithFilesFolders :: IO () +testSendImageWithFilesFolders = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + connectUsers alice bob + alice #$> ("/_files_folder ./tests/fixtures", id, "ok") + bob #$> ("/_files_folder ./tests/tmp", id, "ok") + alice ##> "/_send @2 file test.jpg json {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}" + alice <# "/f @bob test.jpg" + alice <## "use /fc 1 to cancel sending" + bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)" + bob <## "use /fr 1 [