diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 803589241..9e2b86319 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -133,6 +133,7 @@ library Simplex.Chat.Migrations.M20240104_members_profile_update Simplex.Chat.Migrations.M20240115_block_member_for_all Simplex.Chat.Migrations.M20240122_indexes + Simplex.Chat.Migrations.M20240214_redirect_file_id Simplex.Chat.Mobile Simplex.Chat.Mobile.File Simplex.Chat.Mobile.Shared diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index da9ea544c..85cd5ee44 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -81,7 +82,8 @@ import Simplex.Chat.Types.Util import Simplex.Chat.Util (encryptFile, shuffle) import Simplex.FileTransfer.Client.Main (maxFileSize) import Simplex.FileTransfer.Client.Presets (defaultXFTPServers) -import Simplex.FileTransfer.Description (ValidFileDescription, gb, kb, mb) +import Simplex.FileTransfer.Description (FileDescriptionURI (..), ValidFileDescription, gb, kb, mb) +import qualified Simplex.FileTransfer.Description as FD import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI) import Simplex.Messaging.Agent as Agent import Simplex.Messaging.Agent.Client (AgentStatsKey (..), SubInfo (..), agentClientStore, getAgentWorkersDetails, getAgentWorkersSummary, temporaryAgentError) @@ -770,28 +772,18 @@ processChatCommand' vr = \case CTContactConnection -> pure $ chatCmdError (Just user) "not supported" where xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) - xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do - let fileName = takeFileName filePath - fileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} - fInv = xftpFileInvitation fileName fileSize fileDescr - fsFilePath <- toFSFilePath filePath - let srcFile = CryptoFile fsFilePath cfArgs - aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n) - -- TODO CRSndFileStart event for XFTP - chSize <- asks $ fileChunkSize . config - ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup file fInv (AgentSndFileId aFileId) chSize - let fileSource = Just $ CryptoFile filePath cfArgs - ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP} + xftpSndFileTransfer user file fileSize n contactOrGroup = do + (fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n $ Just contactOrGroup case contactOrGroup of CGContact Contact {activeConn} -> forM_ activeConn $ \conn -> - withStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft fileDescr + withStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft dummyFileDescr CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user)) where -- we are not sending files to pending members, same as with inline files saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} = when ((connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn)) $ withStore' $ - \db -> createSndFTDescrXFTP db user (Just m) conn ft fileDescr + \db -> createSndFTDescrXFTP db user (Just m) conn ft dummyFileDescr saveMemberFD _ = pure () pure (fInv, ciFile, ft) unzipMaybe3 :: Maybe (a, b, c) -> (Maybe a, Maybe b, Maybe c) @@ -1959,16 +1951,16 @@ processChatCommand' vr = \case | otherwise -> do fileAgentConnIds <- cancelSndFile user ftm fts True deleteAgentConnectionsAsync user fileAgentConnIds - sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId - withStore (\db -> getChatRefByFileId db user fileId) >>= \case - ChatRef CTDirect contactId -> do - contact <- withStore $ \db -> getContact db user contactId + withStore (\db -> liftIO $ lookupChatRefByFileId db user fileId) >>= \case + Nothing -> pure () + Just (ChatRef CTDirect contactId) -> do + (contact, sharedMsgId) <- withStore $ \db -> (,) <$> getContact db user contactId <*> getSharedMsgIdByFileId db userId fileId void . sendDirectContactMessage contact $ XFileCancel sharedMsgId - ChatRef CTGroup groupId -> do - Group gInfo ms <- withStore $ \db -> getGroup db vr user groupId + Just (ChatRef CTGroup groupId) -> do + (Group gInfo ms, sharedMsgId) <- withStore $ \db -> (,) <$> getGroup db vr user groupId <*> getSharedMsgIdByFileId db userId fileId void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId - _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" - ci <- withStore $ \db -> getChatItemByFileId db vr user fileId + Just _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" + ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId pure $ CRSndFileCancelled user ci ftm fts where fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} = @@ -1979,7 +1971,7 @@ processChatCommand' vr = \case | otherwise -> case xftpRcvFile of Nothing -> do cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user) - ci <- withStore $ \db -> getChatItemByFileId db vr user fileId + ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId pure $ CRRcvFileCancelled user ci ftr Just XFTPRcvFile {agentRcvFileId} -> do forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do @@ -1992,18 +1984,21 @@ processChatCommand' vr = \case updateCIFileStatus db user fileId CIFSRcvInvitation updateRcvFileStatus db fileId FSNew updateRcvFileAgentId db fileId Nothing - getChatItemByFileId db vr user fileId + lookupChatItemByFileId db vr user fileId pure $ CRRcvFileCancelled user ci ftr 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 + withStore (\db -> lookupChatItemByFileId db vr user fileId) >>= \case + Nothing -> do fileStatus <- withStore $ \db -> getFileTransferProgress db user fileId pure $ CRFileTransferStatus user fileStatus + Just ci@(AChatItem _ _ _ ChatItem {file}) -> case file of + Just CIFile {fileProtocol = FPLocal} -> + throwChatError $ CECommandError "not supported for local files" + Just CIFile {fileProtocol = FPXFTP} -> + pure $ CRFileTransferStatusXFTP user ci + _ -> do + fileStatus <- withStore $ \db -> getFileTransferProgress db user fileId + pure $ CRFileTransferStatus user fileStatus ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile) UpdateProfile displayName fullName -> withUser $ \user@User {profile} -> do let p = (fromLocalProfile profile :: Profile) {displayName = displayName, fullName = fullName} @@ -2058,6 +2053,13 @@ processChatCommand' vr = \case StopRemoteCtrl -> withUser_ $ stopRemoteCtrl >> ok_ ListRemoteCtrls -> withUser_ $ CRRemoteCtrlList <$> listRemoteCtrls DeleteRemoteCtrl rc -> withUser_ $ deleteRemoteCtrl rc >> ok_ + APIUploadStandaloneFile userId file -> withUserId userId $ \user -> do + fileSize <- liftIO $ CF.getFileContentsSize file + (_, _, fileTransferMeta) <- xftpSndFileTransfer_ user file fileSize 1 Nothing + pure CRSndStandaloneFileCreated {user, fileTransferMeta} + APIDownloadStandaloneFile userId uri file -> withUserId userId $ \user -> do + ft <- receiveViaURI user uri file + pure $ CRRcvStandaloneFileCreated user ft QuitChat -> liftIO exitSuccess ShowVersion -> do -- simplexmqCommitQ makes iOS builds crash m( @@ -2811,6 +2813,19 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} startReceivingFile user fileId withStoreCtx' (Just "receiveViaCompleteFD, updateRcvFileAgentId") $ \db -> updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId) +receiveViaURI :: ChatMonad m => User -> FileDescriptionURI -> CryptoFile -> m RcvFileTransfer +receiveViaURI user@User {userId} FileDescriptionURI {description} cf@CryptoFile {cryptoArgs} = do + fileId <- withStore $ \db -> createRcvStandaloneFileTransfer db userId cf fileSize chunkSize + aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) description cryptoArgs + withStore $ \db -> do + liftIO $ do + updateRcvFileStatus db fileId FSConnected + updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1 + updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId) + getRcvFileTransfer db user fileId + where + FD.ValidFileDescription FD.FileDescription {size = FD.FileSize fileSize, chunkSize = FD.FileSize chunkSize} = description + startReceivingFile :: ChatMonad m => User -> FileTransferId -> m () startReceivingFile user fileId = do vr <- chatVersionRange @@ -3276,7 +3291,7 @@ processAgentMsgSndFile _corrId aFileId msg = where process :: User -> m () process user = do - (ft@FileTransferMeta {fileId, cancelled}, sfts) <- withStore $ \db -> do + (ft@FileTransferMeta {fileId, xftpRedirectFor, cancelled}, sfts) <- withStore $ \db -> do fileId <- getXFTPSndFileDBId db user $ AgentSndFileId aFileId getSndFileTransfer db user fileId vr <- chatVersionRange @@ -3285,61 +3300,76 @@ processAgentMsgSndFile _corrId aFileId msg = let status = CIFSSndTransfer {sndProgress, sndTotal} ci <- withStore $ \db -> do liftIO $ updateCIFileStatus db user fileId status - getChatItemByFileId db vr user fileId + lookupChatItemByFileId db vr user fileId toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal SFDONE sndDescr rfds -> do withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr) - ci@(AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) <- - withStore $ \db -> getChatItemByFileId db vr user fileId - case (msgId_, itemDeleted) of - (Just sharedMsgId, Nothing) -> do - when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send" - -- TODO either update database status or move to SFPROG - toView $ CRSndFileProgressXFTP user ci ft 1 1 - case (rfds, sfts, d, cInfo) of - (rfd : extraRFDs, sft : _, SMDSnd, DirectChat ct) -> do - withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) - msgDeliveryId <- sendFileDescription sft rfd sharedMsgId $ sendDirectContactMessage ct - withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId - withAgent (`xftpDeleteSndFileInternal` aFileId) - (_, _, SMDSnd, GroupChat g@GroupInfo {groupId}) -> do - ms <- withStore' $ \db -> getGroupMembers db user g - let rfdsMemberFTs = zip rfds $ memberFTs ms - extraRFDs = drop (length rfdsMemberFTs) rfds - withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) - forM_ rfdsMemberFTs $ \mt -> sendToMember mt `catchChatError` (toView . CRChatError (Just user)) - ci' <- withStore $ \db -> do - liftIO $ updateCIFileStatus db user fileId CIFSSndComplete - getChatItemByFileId db vr user fileId - withAgent (`xftpDeleteSndFileInternal` aFileId) - toView $ CRSndFileCompleteXFTP user ci' ft - where - memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)] - memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts') + ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId + case ci of + Nothing -> do + withAgent (`xftpDeleteSndFileInternal` aFileId) + withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText rfds) + case mapMaybe fileDescrURI rfds of + [] -> case rfds of + [] -> logError "File sent without receiver descriptions" -- should not happen + (rfd : _) -> xftpSndFileRedirect user fileId rfd >>= toView . CRSndFileRedirectStartXFTP user ft + uris -> do + ft' <- maybe (pure ft) (\fId -> withStore $ \db -> getFileTransferMeta db user fId) xftpRedirectFor + toView $ CRSndStandaloneFileComplete user ft' uris + Just (AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) -> + case (msgId_, itemDeleted) of + (Just sharedMsgId, Nothing) -> do + when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send" + -- TODO either update database status or move to SFPROG + toView $ CRSndFileProgressXFTP user ci ft 1 1 + case (rfds, sfts, d, cInfo) of + (rfd : extraRFDs, sft : _, SMDSnd, DirectChat ct) -> do + withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) + msgDeliveryId <- sendFileDescription sft rfd sharedMsgId $ sendDirectContactMessage ct + withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId + withAgent (`xftpDeleteSndFileInternal` aFileId) + (_, _, SMDSnd, GroupChat g@GroupInfo {groupId}) -> do + ms <- withStore' $ \db -> getGroupMembers db user g + let rfdsMemberFTs = zip rfds $ memberFTs ms + extraRFDs = drop (length rfdsMemberFTs) rfds + withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) + forM_ rfdsMemberFTs $ \mt -> sendToMember mt `catchChatError` (toView . CRChatError (Just user)) + ci' <- withStore $ \db -> do + liftIO $ updateCIFileStatus db user fileId CIFSSndComplete + getChatItemByFileId db vr user fileId + withAgent (`xftpDeleteSndFileInternal` aFileId) + toView $ CRSndFileCompleteXFTP user ci' ft where - mConns' = mapMaybe useMember ms - sfts' = mapMaybe (\sft@SndFileTransfer {groupMemberId} -> (,sft) <$> groupMemberId) sfts - useMember GroupMember {groupMemberId, activeConn = Just conn@Connection {connStatus}} - | (connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn) = Just (groupMemberId, conn) - | otherwise = Nothing - useMember _ = Nothing - sendToMember :: (ValidFileDescription 'FRecipient, (Connection, SndFileTransfer)) -> m () - sendToMember (rfd, (conn, sft)) = - void $ sendFileDescription sft rfd sharedMsgId $ \msg' -> sendDirectMessage conn msg' $ GroupId groupId - _ -> pure () - _ -> pure () -- TODO error? + memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)] + memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts') + where + mConns' = mapMaybe useMember ms + sfts' = mapMaybe (\sft@SndFileTransfer {groupMemberId} -> (,sft) <$> groupMemberId) sfts + useMember GroupMember {groupMemberId, activeConn = Just conn@Connection {connStatus}} + | (connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn) = Just (groupMemberId, conn) + | otherwise = Nothing + useMember _ = Nothing + sendToMember :: (ValidFileDescription 'FRecipient, (Connection, SndFileTransfer)) -> m () + sendToMember (rfd, (conn, sft)) = + void $ sendFileDescription sft rfd sharedMsgId $ \msg' -> sendDirectMessage conn msg' $ GroupId groupId + _ -> pure () + _ -> pure () -- TODO error? SFERR e | temporaryAgentError e -> throwChatError $ CEXFTPSndFile fileId (AgentSndFileId aFileId) e | otherwise -> do ci <- withStore $ \db -> do liftIO $ updateFileCancelled db user fileId CIFSSndError - getChatItemByFileId db vr user fileId + lookupChatItemByFileId db vr user fileId withAgent (`xftpDeleteSndFileInternal` aFileId) - toView $ CRSndFileError user ci + toView $ CRSndFileError user ci ft where fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text fileDescrText = safeDecodeUtf8 . strEncode + fileDescrURI :: ValidFileDescription 'FRecipient -> Maybe T.Text + fileDescrURI vfd = if T.length uri < FD.qrSizeLimit then Just uri else Nothing + where + uri = decodeLatin1 . strEncode $ FD.fileDescriptionURI vfd sendFileDescription :: SndFileTransfer -> ValidFileDescription 'FRecipient -> SharedMsgId -> (ChatMsgEvent 'Json -> m (SndMessage, Int64)) -> m Int64 sendFileDescription sft rfd msgId sendMsg = do let rfdText = fileDescrText rfd @@ -3387,30 +3417,30 @@ processAgentMsgRcvFile _corrId aFileId msg = let status = CIFSRcvTransfer {rcvProgress, rcvTotal} ci <- withStore $ \db -> do liftIO $ updateCIFileStatus db user fileId status - getChatItemByFileId db vr user fileId - toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal + lookupChatItemByFileId db vr user fileId + toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal ft RFDONE xftpPath -> case liveRcvFileTransferPath ft of Nothing -> throwChatError $ CEInternalError "no target path for received XFTP file" Just targetPath -> do fsTargetPath <- toFSFilePath targetPath renameFile xftpPath fsTargetPath - ci <- withStore $ \db -> do + ci_ <- withStore $ \db -> do liftIO $ do updateRcvFileStatus db fileId FSComplete updateCIFileStatus db user fileId CIFSRcvComplete - getChatItemByFileId db vr user fileId + lookupChatItemByFileId db vr user fileId agentXFTPDeleteRcvFile aFileId fileId - toView $ CRRcvFileComplete user ci + toView $ maybe (CRRcvStandaloneFileComplete user fsTargetPath ft) (CRRcvFileComplete user) ci_ RFERR e | temporaryAgentError e -> throwChatError $ CEXFTPRcvFile fileId (AgentRcvFileId aFileId) e | otherwise -> do ci <- withStore $ \db -> do liftIO $ updateFileCancelled db user fileId CIFSRcvError - getChatItemByFileId db vr user fileId + lookupChatItemByFileId db vr user fileId agentXFTPDeleteRcvFile aFileId fileId - toView $ CRRcvFileError user ci e + toView $ CRRcvFileError user ci e ft processAgentMessageConn :: forall m. ChatMonad m => VersionRange -> User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m () processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do @@ -4089,10 +4119,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = case err of SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ do ci <- withStore $ \db -> do - getChatRefByFileId db user fileId >>= \case - ChatRef CTDirect _ -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled + liftIO (lookupChatRefByFileId db user fileId) >>= \case + Just (ChatRef CTDirect _) -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled _ -> pure () - getChatItemByFileId db vr user fileId + lookupChatItemByFileId db vr user fileId toView $ CRSndFileRcvCancelled user ci ft _ -> throwChatError $ CEFileSend fileId err MSG meta _ _ -> withAckMessage' agentConnId conn meta $ pure () @@ -6274,12 +6304,19 @@ agentXFTPDeleteRcvFile aFileId fileId = do withStore' $ \db -> setRcvFTAgentDeleted db fileId agentXFTPDeleteSndFileRemote :: ChatMonad m => User -> XFTPSndFile -> FileTransferId -> m () -agentXFTPDeleteSndFileRemote user XFTPSndFile {agentSndFileId = AgentSndFileId aFileId, privateSndFileDescr, agentSndFileDeleted} fileId = - unless agentSndFileDeleted $ - forM_ privateSndFileDescr $ \sfdText -> do - sd <- parseFileDescription sfdText - withAgent $ \a -> xftpDeleteSndFileRemote a (aUserId user) aFileId sd - withStore' $ \db -> setSndFTAgentDeleted db user fileId +agentXFTPDeleteSndFileRemote user sndFile fileId = do + -- the agent doesn't know about redirect, delete explicitly + redirect_ <- withStore' $ \db -> lookupFileTransferRedirectMeta db user fileId + forM_ redirect_ $ \FileTransferMeta {fileId = fileIdRedirect, xftpSndFile = sndFileRedirect_} -> + mapM_ (handleError (const $ pure ()) . remove fileIdRedirect) sndFileRedirect_ + remove fileId sndFile + where + remove fId XFTPSndFile {agentSndFileId = AgentSndFileId aFileId, privateSndFileDescr, agentSndFileDeleted} = + unless agentSndFileDeleted $ do + forM_ privateSndFileDescr $ \sfdText -> do + sd <- parseFileDescription sfdText + withAgent $ \a -> xftpDeleteSndFileRemote a (aUserId user) aFileId sd + withStore' $ \db -> setSndFTAgentDeleted db user fId userProfileToSend :: User -> Maybe Profile -> Maybe Contact -> Bool -> Profile userProfileToSend user@User {profile = p} incognitoProfile ct inGroup = do @@ -6750,6 +6787,8 @@ chatCommandP = "/list remote ctrls" $> ListRemoteCtrls, "/stop remote ctrl" $> StopRemoteCtrl, "/delete remote ctrl " *> (DeleteRemoteCtrl <$> A.decimal), + "/_upload " *> (APIUploadStandaloneFile <$> A.decimal <* A.space <*> cryptoFileP), + "/_download " *> (APIDownloadStandaloneFile <$> A.decimal <* A.space <*> strP_ <*> cryptoFileP), ("/quit" <|> "/q" <|> "/exit") $> QuitChat, ("/version" <|> "/v") $> ShowVersion, "/debug locks" $> DebugLocks, @@ -6937,3 +6976,29 @@ mkValidName = reverse . dropWhile isSpace . fst3 . foldl' addChar ("", '\NUL', 0 | isPunctuation prev = validFirstChar || isSpace c || (punct < 3 && isPunctuation c) | otherwise = validFirstChar || isSpace c || isMark c || isPunctuation c validFirstChar = isLetter c || isNumber c || isSymbol c + +xftpSndFileTransfer_ :: ChatMonad m => User -> CryptoFile -> Integer -> Int -> Maybe ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) +xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup_ = do + let fileName = takeFileName filePath + fInv = xftpFileInvitation fileName fileSize dummyFileDescr + fsFilePath <- toFSFilePath filePath + let srcFile = CryptoFile fsFilePath cfArgs + aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n) + -- TODO CRSndFileStart event for XFTP + chSize <- asks $ fileChunkSize . config + ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup_ file fInv (AgentSndFileId aFileId) Nothing chSize + let fileSource = Just $ CryptoFile filePath cfArgs + ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP} + pure (fInv, ciFile, ft) + +xftpSndFileRedirect :: ChatMonad m => User -> FileTransferId -> ValidFileDescription 'FRecipient -> m FileTransferMeta +xftpSndFileRedirect user ftId vfd = do + let fileName = "redirect.yaml" + file = CryptoFile fileName Nothing + fInv = xftpFileInvitation fileName (fromIntegral $ B.length $ strEncode vfd) dummyFileDescr + aFileId <- withAgent $ \a -> xftpSendDescription a (aUserId user) vfd (roundedFDCount 1) + chSize <- asks $ fileChunkSize . config + withStore' $ \db -> createSndFileTransferXFTP db user Nothing file fInv (AgentSndFileId aFileId) (Just ftId) chSize + +dummyFileDescr :: FileDescr +dummyFileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index f3193648e..249c66afc 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -59,6 +59,7 @@ import Simplex.Chat.Remote.Types import Simplex.Chat.Store (AutoAccept, StoreError (..), UserContactLink, UserMsgReceiptSettings) import Simplex.Chat.Types import Simplex.Chat.Types.Preferences +import Simplex.FileTransfer.Description (FileDescriptionURI) import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo) import Simplex.Messaging.Agent.Client (AgentLocks, AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig) @@ -453,6 +454,8 @@ data ChatCommand | ListRemoteCtrls | StopRemoteCtrl -- Stop listening for announcements or terminate an active session | DeleteRemoteCtrl RemoteCtrlId -- Remove all local data associated with a remote controller session + | APIUploadStandaloneFile UserId CryptoFile + | APIDownloadStandaloneFile UserId FileDescriptionURI CryptoFile | QuitChat | ShowVersion | DebugLocks @@ -593,21 +596,26 @@ data ChatResponse | CRRcvFileAccepted {user :: User, chatItem :: AChatItem} | CRRcvFileAcceptedSndCancelled {user :: User, rcvFileTransfer :: RcvFileTransfer} | CRRcvFileDescrNotReady {user :: User, chatItem :: AChatItem} - | CRRcvFileStart {user :: User, chatItem :: AChatItem} - | CRRcvFileProgressXFTP {user :: User, chatItem :: AChatItem, receivedSize :: Int64, totalSize :: Int64} + | CRRcvStandaloneFileCreated {user :: User, rcvFileTransfer :: RcvFileTransfer} -- returned by _download + | CRRcvFileStart {user :: User, chatItem :: AChatItem} -- sent by chats + | CRRcvFileProgressXFTP {user :: User, chatItem_ :: Maybe AChatItem, receivedSize :: Int64, totalSize :: Int64, rcvFileTransfer :: RcvFileTransfer} | CRRcvFileComplete {user :: User, chatItem :: AChatItem} - | CRRcvFileCancelled {user :: User, chatItem :: AChatItem, rcvFileTransfer :: RcvFileTransfer} + | CRRcvStandaloneFileComplete {user :: User, targetPath :: FilePath, rcvFileTransfer :: RcvFileTransfer} + | CRRcvFileCancelled {user :: User, chatItem_ :: Maybe AChatItem, rcvFileTransfer :: RcvFileTransfer} | CRRcvFileSndCancelled {user :: User, chatItem :: AChatItem, rcvFileTransfer :: RcvFileTransfer} - | CRRcvFileError {user :: User, chatItem :: AChatItem, agentError :: AgentErrorType} + | CRRcvFileError {user :: User, chatItem_ :: Maybe AChatItem, agentError :: AgentErrorType, rcvFileTransfer :: RcvFileTransfer} | CRSndFileStart {user :: User, chatItem :: AChatItem, sndFileTransfer :: SndFileTransfer} | CRSndFileComplete {user :: User, chatItem :: AChatItem, sndFileTransfer :: SndFileTransfer} - | CRSndFileRcvCancelled {user :: User, chatItem :: AChatItem, sndFileTransfer :: SndFileTransfer} - | CRSndFileCancelled {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta, sndFileTransfers :: [SndFileTransfer]} - | CRSndFileStartXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta} - | CRSndFileProgressXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta, sentSize :: Int64, totalSize :: Int64} + | CRSndFileRcvCancelled {user :: User, chatItem_ :: Maybe AChatItem, sndFileTransfer :: SndFileTransfer} + | CRSndFileCancelled {user :: User, chatItem_ :: Maybe AChatItem, fileTransferMeta :: FileTransferMeta, sndFileTransfers :: [SndFileTransfer]} + | CRSndStandaloneFileCreated {user :: User, fileTransferMeta :: FileTransferMeta} -- returned by _upload + | CRSndFileStartXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta} -- not used + | CRSndFileProgressXFTP {user :: User, chatItem_ :: Maybe AChatItem, fileTransferMeta :: FileTransferMeta, sentSize :: Int64, totalSize :: Int64} + | CRSndFileRedirectStartXFTP {user :: User, fileTransferMeta :: FileTransferMeta, redirectMeta :: FileTransferMeta} | CRSndFileCompleteXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta} - | CRSndFileCancelledXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta} - | CRSndFileError {user :: User, chatItem :: AChatItem} + | CRSndStandaloneFileComplete {user :: User, fileTransferMeta :: FileTransferMeta, rcvURIs :: [Text]} + | CRSndFileCancelledXFTP {user :: User, chatItem_ :: Maybe AChatItem, fileTransferMeta :: FileTransferMeta} + | CRSndFileError {user :: User, chatItem_ :: Maybe AChatItem, fileTransferMeta :: FileTransferMeta} | CRUserProfileUpdated {user :: User, fromProfile :: Profile, toProfile :: Profile, updateSummary :: UserProfileUpdateSummary} | CRUserProfileImage {user :: User, profile :: Profile} | CRContactAliasUpdated {user :: User, toContact :: Contact} diff --git a/src/Simplex/Chat/Migrations/M20240214_redirect_file_id.hs b/src/Simplex/Chat/Migrations/M20240214_redirect_file_id.hs new file mode 100644 index 000000000..da8f4d413 --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20240214_redirect_file_id.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20240214_redirect_file_id where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20240214_redirect_file_id :: Query +m20240214_redirect_file_id = + [sql| +ALTER TABLE files ADD COLUMN redirect_file_id INTEGER REFERENCES files ON DELETE CASCADE; + +CREATE INDEX idx_files_redirect_file_id on files(redirect_file_id); +|] + +down_m20240214_redirect_file_id :: Query +down_m20240214_redirect_file_id = + [sql| +DROP INDEX idx_files_redirect_file_id; + +ALTER TABLE files DROP COLUMN redirect_file_id; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index efed6d168..b5726cae2 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -193,7 +193,8 @@ CREATE TABLE files( protocol TEXT NOT NULL DEFAULT 'smp', file_crypto_key BLOB, file_crypto_nonce BLOB, - note_folder_id INTEGER DEFAULT NULL REFERENCES note_folders ON DELETE CASCADE + note_folder_id INTEGER DEFAULT NULL REFERENCES note_folders ON DELETE CASCADE, + redirect_file_id INTEGER REFERENCES files ON DELETE CASCADE ); CREATE TABLE snd_files( file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE, @@ -854,3 +855,4 @@ CREATE INDEX idx_chat_items_notes_item_status on chat_items( note_folder_id, item_status ); +CREATE INDEX idx_files_redirect_file_id on files(redirect_file_id); diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs index bc5cec333..c44c652f9 100644 --- a/src/Simplex/Chat/Store/Files.hs +++ b/src/Simplex/Chat/Store/Files.hs @@ -39,6 +39,7 @@ module Simplex.Chat.Store.Files getGroupFileIdBySharedMsgId, getDirectFileIdBySharedMsgId, getChatRefByFileId, + lookupChatRefByFileId, updateSndFileStatus, createSndFileChunk, updateSndFileChunkMsg, @@ -46,6 +47,7 @@ module Simplex.Chat.Store.Files deleteSndFileChunks, createRcvFileTransfer, createRcvGroupFileTransfer, + createRcvStandaloneFileTransfer, appendRcvFD, getRcvFileDescrByRcvFileId, getRcvFileDescrBySndFileId, @@ -70,6 +72,7 @@ module Simplex.Chat.Store.Files getFileTransfer, getFileTransferProgress, getFileTransferMeta, + lookupFileTransferRedirectMeta, getSndFileTransfer, getSndFileTransfers, getContactFileInfo, @@ -86,12 +89,14 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Data.Either (rights) +import Data.Functor ((<&>)) import Data.Int (Int64) import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Text (Text) import Data.Time (addUTCTime) import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay) import Data.Type.Equality +import Data.Word (Word32) import Database.SQLite.Simple (Only (..), (:.) (..)) import Database.SQLite.Simple.QQ (sql) import Database.SQLite.Simple.ToField (ToField) @@ -184,7 +189,7 @@ createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitatio db "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" (fileId, fileStatus, fileInline, connId, currentTs, currentTs) - pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} + pure FileTransferMeta {fileId, xftpSndFile = Nothing, xftpRedirectFor = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> SubscriptionMode -> IO () createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) subMode = do @@ -204,7 +209,7 @@ createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation "INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)" ((userId, groupId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs)) fileId <- insertedRowId db - pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} + pure FileTransferMeta {fileId, xftpSndFile = Nothing, xftpRedirectFor = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> SubscriptionMode -> IO () createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} subMode = do @@ -277,16 +282,16 @@ getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMs (\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, recipientDisplayName = n, connId, agentConnId}) <$> (contactName_ <|> memberName_) -createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> CryptoFile -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta -createSndFileTransferXFTP db User {userId} contactOrGroup (CryptoFile filePath cryptoArgs) FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do +createSndFileTransferXFTP :: DB.Connection -> User -> Maybe ContactOrGroup -> CryptoFile -> FileInvitation -> AgentSndFileId -> Maybe FileTransferId -> Integer -> IO FileTransferMeta +createSndFileTransferXFTP db User {userId} contactOrGroup_ (CryptoFile filePath cryptoArgs) FileInvitation {fileName, fileSize} agentSndFileId xftpRedirectFor chunkSize = do currentTs <- getCurrentTime let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False, cryptoArgs} DB.execute db - "INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_crypto_key, file_crypto_nonce, file_size, chunk_size, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)" - (contactAndGroupIds contactOrGroup :. (userId, fileName, filePath, CF.fileKey <$> cryptoArgs, CF.fileNonce <$> cryptoArgs, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs)) + "INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_crypto_key, file_crypto_nonce, file_size, chunk_size, redirect_file_id, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" + (maybe (Nothing, Nothing) contactAndGroupIds contactOrGroup_ :. (userId, fileName, filePath, CF.fileKey <$> cryptoArgs, CF.fileNonce <$> cryptoArgs, fileSize, chunkSize) :. (xftpRedirectFor, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs)) fileId <- insertedRowId db - pure FileTransferMeta {fileId, xftpSndFile, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False} + pure FileTransferMeta {fileId, xftpSndFile, xftpRedirectFor, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False} createSndFTDescrXFTP :: DB.Connection -> User -> Maybe GroupMember -> Connection -> FileTransferMeta -> FileDescr -> IO () createSndFTDescrXFTP db User {userId} m Connection {connId} FileTransferMeta {fileId} FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do @@ -421,11 +426,14 @@ getDirectFileIdBySharedMsgId db User {userId} Contact {contactId} sharedMsgId = (userId, contactId, sharedMsgId) getChatRefByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO ChatRef -getChatRefByFileId db User {userId} fileId = - liftIO getChatRef >>= \case - [(Just contactId, Nothing)] -> pure $ ChatRef CTDirect contactId - [(Nothing, Just groupId)] -> pure $ ChatRef CTGroup groupId - _ -> throwError $ SEInternalError "could not retrieve chat ref by file id" +getChatRefByFileId db user fileId = liftIO (lookupChatRefByFileId db user fileId) >>= maybe (throwError $ SEInternalError "could not retrieve chat ref by file id") pure + +lookupChatRefByFileId :: DB.Connection -> User -> Int64 -> IO (Maybe ChatRef) +lookupChatRefByFileId db User {userId} fileId = + getChatRef <&> \case + [(Just contactId, Nothing)] -> Just $ ChatRef CTDirect contactId + [(Nothing, Just groupId)] -> Just $ ChatRef CTGroup groupId + _ -> Nothing where getChatRef = DB.query @@ -536,6 +544,23 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, rfdId, currentTs, currentTs) pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId, cryptoArgs = Nothing} +createRcvStandaloneFileTransfer :: DB.Connection -> UserId -> CryptoFile -> Int64 -> Word32 -> ExceptT StoreError IO Int64 +createRcvStandaloneFileTransfer db userId (CryptoFile filePath cfArgs_) fileSize chunkSize = do + currentTs <- liftIO getCurrentTime + fileId <- liftIO $ do + DB.execute + db + "INSERT INTO files (user_id, file_name, file_path, file_size, chunk_size, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" + (userId, takeFileName filePath, filePath, fileSize, chunkSize, CIFSRcvInvitation, FPXFTP, currentTs, currentTs) + insertedRowId db + liftIO . forM_ cfArgs_ $ \cfArgs -> setFileCryptoArgs_ db fileId cfArgs currentTs + liftIO $ + DB.execute + db + "INSERT INTO rcv_files (file_id, file_status, created_at, updated_at) VALUES (?,?,?,?)" + (fileId, FSNew, currentTs, currentTs) + pure fileId + createRcvFD_ :: DB.Connection -> UserId -> UTCTime -> FileDescr -> ExceptT StoreError IO RcvFileDescr createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do when (fileDescrPartNo /= 0) $ throwError SERcvFileInvalidDescrPart @@ -662,9 +687,9 @@ getRcvFileTransfer_ db userId fileId = do (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, Bool) :. (Maybe Int64, Maybe AgentConnId) -> ExceptT StoreError IO RcvFileTransfer rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, agentRcvFileDeleted) :. (connId_, agentConnId_)) = - case contactName_ <|> memberName_ of + case contactName_ <|> memberName_ <|> standaloneName_ of Nothing -> throwError $ SERcvFileInvalid fileId - Just name -> do + Just name -> case fileStatus' of FSNew -> pure $ ft name RFSNew FSAccepted -> ft name . RFSAccepted <$> rfi @@ -672,6 +697,9 @@ getRcvFileTransfer_ db userId fileId = do FSComplete -> ft name . RFSComplete <$> rfi FSCancelled -> ft name . RFSCancelled <$> rfi_ where + standaloneName_ = case (connId_, agentRcvFileId, filePath_) of + (Nothing, Just _, Just _) -> Just "" -- filePath marks files that are accepted from contact or, in this case, set by createRcvDirectFileTransfer + _ -> Nothing ft senderDisplayName fileStatus = let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing} cryptoArgs = CFArgs <$> fileKey <*> fileNonce @@ -906,17 +934,22 @@ getFileTransferMeta_ db userId fileId = DB.query db [sql| - SELECT file_name, file_size, chunk_size, file_path, file_crypto_key, file_crypto_nonce, file_inline, agent_snd_file_id, agent_snd_file_deleted, private_snd_file_descr, cancelled + SELECT file_name, file_size, chunk_size, file_path, file_crypto_key, file_crypto_nonce, file_inline, agent_snd_file_id, agent_snd_file_deleted, private_snd_file_descr, cancelled, redirect_file_id FROM files WHERE user_id = ? AND file_id = ? |] (userId, fileId) where - fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool) -> FileTransferMeta - fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileKey, fileNonce, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) = + fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool, Maybe FileTransferId) -> FileTransferMeta + fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileKey, fileNonce, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_, xftpRedirectFor) = let cryptoArgs = CFArgs <$> fileKey <*> fileNonce xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted, cryptoArgs}) <$> aSndFileId_ - in FileTransferMeta {fileId, xftpSndFile, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_} + in FileTransferMeta {fileId, xftpSndFile, xftpRedirectFor, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_} + +lookupFileTransferRedirectMeta :: DB.Connection -> User -> Int64 -> IO [FileTransferMeta] +lookupFileTransferRedirectMeta db User {userId} fileId = do + redirects <- DB.query db "SELECT file_id FROM files WHERE user_id = ? AND redirect_file_id = ?" (userId, fileId) + rights <$> mapM (runExceptT . getFileTransferMeta_ db userId . fromOnly) redirects 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 diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 891e9887e..96b6a1eaf 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -92,6 +92,7 @@ module Simplex.Chat.Store.Messages getLocalChatItemIdByText, getLocalChatItemIdByText', getChatItemByFileId, + lookupChatItemByFileId, getChatItemByGroupId, updateDirectChatItemStatus, getTimedItems, @@ -2085,6 +2086,12 @@ getChatItemByFileId db vr user@User {userId} fileId = do (userId, fileId) getAChatItem db vr user chatRef itemId +lookupChatItemByFileId :: DB.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO (Maybe AChatItem) +lookupChatItemByFileId db vr user fileId = do + fmap Just (getChatItemByFileId db vr user fileId) `catchError` \case + SEChatItemNotFoundByFileId {} -> pure Nothing + e -> throwError e + getChatItemByGroupId :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO AChatItem getChatItemByGroupId db vr user@User {userId} groupId = do (chatRef, itemId) <- diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs index 2f5e61a5e..832f07dcb 100644 --- a/src/Simplex/Chat/Store/Migrations.hs +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -98,6 +98,7 @@ import Simplex.Chat.Migrations.M20240102_note_folders import Simplex.Chat.Migrations.M20240104_members_profile_update import Simplex.Chat.Migrations.M20240115_block_member_for_all import Simplex.Chat.Migrations.M20240122_indexes +import Simplex.Chat.Migrations.M20240214_redirect_file_id import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -195,7 +196,8 @@ schemaMigrations = ("20240102_note_folders", m20240102_note_folders, Just down_m20240102_note_folders), ("20240104_members_profile_update", m20240104_members_profile_update, Just down_m20240104_members_profile_update), ("20240115_block_member_for_all", m20240115_block_member_for_all, Just down_m20240115_block_member_for_all), - ("20240122_indexes", m20240122_indexes, Just down_m20240122_indexes) + ("20240122_indexes", m20240122_indexes, Just down_m20240122_indexes), + ("20240214_redirect_file_id", m20240214_redirect_file_id, Just down_m20240214_redirect_file_id) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index e65e1a916..c340130f8 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -1210,6 +1210,7 @@ data FileTransfer data FileTransferMeta = FileTransferMeta { fileId :: FileTransferId, xftpSndFile :: Maybe XFTPSndFile, + xftpRedirectFor :: Maybe FileTransferId, fileName :: String, filePath :: String, fileSize :: Integer, diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 8b51ca728..b6bb7807c 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -198,17 +198,24 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRGroupMemberUpdated {} -> [] CRContactsMerged u intoCt mergedCt ct' -> ttyUser u $ viewContactsMerged intoCt mergedCt ct' CRReceivedContactRequest u UserContactRequest {localDisplayName = c, profile} -> ttyUser u $ viewReceivedContactRequest c profile + CRRcvStandaloneFileCreated u ft -> ttyUser u $ receivingFileStandalone "started" ft CRRcvFileStart u ci -> ttyUser u $ receivingFile_' hu testView "started" ci CRRcvFileComplete u ci -> ttyUser u $ receivingFile_' hu testView "completed" ci + CRRcvStandaloneFileComplete u _ ft -> ttyUser u $ receivingFileStandalone "completed" ft CRRcvFileSndCancelled u _ ft -> ttyUser u $ viewRcvFileSndCancelled ft - CRRcvFileError u ci e -> ttyUser u $ receivingFile_' hu testView "error" ci <> [sShow e] + CRRcvFileError u (Just ci) e _ -> ttyUser u $ receivingFile_' hu testView "error" ci <> [sShow e] + CRRcvFileError u Nothing e ft -> ttyUser u $ receivingFileStandalone "error" ft <> [sShow e] CRSndFileStart u _ ft -> ttyUser u $ sendingFile_ "started" ft CRSndFileComplete u _ ft -> ttyUser u $ sendingFile_ "completed" ft + CRSndStandaloneFileCreated u ft -> ttyUser u $ uploadingFileStandalone "started" ft CRSndFileStartXFTP {} -> [] CRSndFileProgressXFTP {} -> [] + CRSndFileRedirectStartXFTP u ft ftRedirect -> ttyUser u $ standaloneUploadRedirect ft ftRedirect + CRSndStandaloneFileComplete u ft uris -> ttyUser u $ standaloneUploadComplete ft uris CRSndFileCompleteXFTP u ci _ -> ttyUser u $ uploadingFile "completed" ci CRSndFileCancelledXFTP {} -> [] - CRSndFileError u ci -> ttyUser u $ uploadingFile "error" ci + CRSndFileError u Nothing ft -> ttyUser u $ uploadingFileStandalone "error" ft + CRSndFileError u (Just ci) _ -> ttyUser u $ uploadingFile "error" ci CRSndFileRcvCancelled u _ ft@SndFileTransfer {recipientDisplayName = c} -> ttyUser u [ttyContact c <> " cancelled receiving " <> sndFile ft] CRContactConnecting u _ -> ttyUser u [] @@ -1558,11 +1565,26 @@ sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} = [status <> " sending " <> sndFile ft <> " to " <> ttyContact c] uploadingFile :: StyledString -> AChatItem -> [StyledString] -uploadingFile status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectSnd}) = - [status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyContact c] -uploadingFile status (AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd}) = - [status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyGroup' g] -uploadingFile status _ = [status <> " uploading file"] -- shouldn't happen +uploadingFile status = \case + AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectSnd} -> + [status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyContact c] + AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd} -> + [status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyGroup' g] + _ -> [status <> " uploading file"] + +uploadingFileStandalone :: StyledString -> FileTransferMeta -> [StyledString] +uploadingFileStandalone status FileTransferMeta {fileId, fileName} = [status <> " standalone uploading " <> fileTransferStr fileId fileName] + +standaloneUploadRedirect :: FileTransferMeta -> FileTransferMeta -> [StyledString] +standaloneUploadRedirect FileTransferMeta {fileId, fileName} FileTransferMeta {fileId = redirectId} = + [fileTransferStr fileId fileName <> " uploaded, preparing redirect file " <> sShow redirectId] + +standaloneUploadComplete :: FileTransferMeta -> [Text] -> [StyledString] +standaloneUploadComplete FileTransferMeta {fileId, fileName} = \case + [] -> [fileTransferStr fileId fileName <> " upload complete."] + uris -> + fileTransferStr fileId fileName <> " upload complete. download with:" + : map plain uris sndFile :: SndFileTransfer -> StyledString sndFile SndFileTransfer {fileId, fileName} = fileTransferStr fileId fileName @@ -1608,7 +1630,11 @@ receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIF highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f})) ] _ -> [] -receivingFile_' _ _ status _ = [plain status <> " receiving file"] -- shouldn't happen +receivingFile_' _ _ status _ = [plain status <> " receiving file"] + +receivingFileStandalone :: String -> RcvFileTransfer -> [StyledString] +receivingFileStandalone status RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} = + [plain status <> " standalone receiving " <> fileTransferStr fileId fileName] viewLocalFile :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString] viewLocalFile to CIFile {fileId, fileSource} ts tz = case fileSource of @@ -1627,7 +1653,7 @@ fileFrom _ _ = "" receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString] receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} = - [status <> " receiving " <> rcvFile ft <> " from " <> ttyContact c] + [status <> " receiving " <> rcvFile ft <> if c == "" then "" else " from " <> ttyContact c] rcvFile :: RcvFileTransfer -> StyledString rcvFile RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} = fileTransferStr fileId fileName diff --git a/tests/ChatTests/Files.hs b/tests/ChatTests/Files.hs index a6b0f56ba..7a3536b1e 100644 --- a/tests/ChatTests/Files.hs +++ b/tests/ChatTests/Files.hs @@ -9,6 +9,7 @@ import ChatClient import ChatTests.Utils import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_) +import Control.Logger.Simple import qualified Data.Aeson as J import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB @@ -77,6 +78,11 @@ chatFileTests = do it "cancel receiving file, repeat receive" testXFTPCancelRcvRepeat it "should accept file automatically with CLI option" testAutoAcceptFile it "should prohibit file transfers in groups based on preference" testProhibitFiles + describe "file transfer over XFTP without chat items" $ do + it "send and receive small standalone file" testXFTPStandaloneSmall + it "send and receive large standalone file" testXFTPStandaloneLarge + xit "removes sent file from server" testXFTPStandaloneCancelSnd -- no error shown in tests + it "removes received temporary files" testXFTPStandaloneCancelRcv runTestFileTransfer :: HasCallStack => TestCC -> TestCC -> IO () runTestFileTransfer alice bob = do @@ -1545,6 +1551,116 @@ testProhibitFiles = where cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"} +testXFTPStandaloneSmall :: HasCallStack => FilePath -> IO () +testXFTPStandaloneSmall = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do + withXFTPServer $ do + logNote "sending" + src ##> "/_upload 1 ./tests/fixtures/test.jpg" + src <## "started standalone uploading file 1 (test.jpg)" + -- silent progress events + threadDelay 250000 + src <## "file 1 (test.jpg) upload complete. download with:" + -- file description fits, enjoy the direct URIs + _uri1 <- getTermLine src + _uri2 <- getTermLine src + uri3 <- getTermLine src + _uri4 <- getTermLine src + + logNote "receiving" + let dstFile = "./tests/tmp/test.jpg" + dst ##> ("/_download 1 " <> uri3 <> " " <> dstFile) + dst <## "started standalone receiving file 1 (test.jpg)" + -- silent progress events + threadDelay 250000 + dst <## "completed standalone receiving file 1 (test.jpg)" + srcBody <- B.readFile "./tests/fixtures/test.jpg" + B.readFile dstFile `shouldReturn` srcBody + +testXFTPStandaloneLarge :: HasCallStack => FilePath -> IO () +testXFTPStandaloneLarge = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do + withXFTPServer $ do + xftpCLI ["rand", "./tests/tmp/testfile.in", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile.in"] + + logNote "sending" + src ##> "/_upload 1 ./tests/tmp/testfile.in" + src <## "started standalone uploading file 1 (testfile.in)" + -- silent progress events + threadDelay 250000 + src <## "file 1 (testfile.in) uploaded, preparing redirect file 2" + src <## "file 1 (testfile.in) upload complete. download with:" + uri <- getTermLine src + _uri2 <- getTermLine src + _uri3 <- getTermLine src + _uri4 <- getTermLine src + + logNote "receiving" + let dstFile = "./tests/tmp/testfile.out" + dst ##> ("/_download 1 " <> uri <> " " <> dstFile) + dst <## "started standalone receiving file 1 (testfile.out)" + -- silent progress events + threadDelay 250000 + dst <## "completed standalone receiving file 1 (testfile.out)" + srcBody <- B.readFile "./tests/tmp/testfile.in" + B.readFile dstFile `shouldReturn` srcBody + +testXFTPStandaloneCancelSnd :: HasCallStack => FilePath -> IO () +testXFTPStandaloneCancelSnd = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do + withXFTPServer $ do + xftpCLI ["rand", "./tests/tmp/testfile.in", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile.in"] + + logNote "sending" + src ##> "/_upload 1 ./tests/tmp/testfile.in" + src <## "started standalone uploading file 1 (testfile.in)" + -- silent progress events + threadDelay 250000 + src <## "file 1 (testfile.in) uploaded, preparing redirect file 2" + src <## "file 1 (testfile.in) upload complete. download with:" + uri <- getTermLine src + _uri2 <- getTermLine src + _uri3 <- getTermLine src + _uri4 <- getTermLine src + + logNote "cancelling" + src ##> "/fc 1" + src <## "cancelled sending file 1 (testfile.in)" + threadDelay 1000000 + + logNote "trying to receive cancelled" + dst ##> ("/_download 1 " <> uri <> " " <> "./tests/tmp/should.not.extist") + dst <## "started standalone receiving file 1 (should.not.extist)" + threadDelay 100000 + logWarn "no error?" + dst <## "error receiving file 1 (should.not.extist)" + dst <## "INTERNAL {internalErr = \"XFTP {xftpErr = AUTH}\"}" + +testXFTPStandaloneCancelRcv :: HasCallStack => FilePath -> IO () +testXFTPStandaloneCancelRcv = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do + withXFTPServer $ do + xftpCLI ["rand", "./tests/tmp/testfile.in", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile.in"] + + logNote "sending" + src ##> "/_upload 1 ./tests/tmp/testfile.in" + src <## "started standalone uploading file 1 (testfile.in)" + -- silent progress events + threadDelay 250000 + src <## "file 1 (testfile.in) uploaded, preparing redirect file 2" + src <## "file 1 (testfile.in) upload complete. download with:" + uri <- getTermLine src + _uri2 <- getTermLine src + _uri3 <- getTermLine src + _uri4 <- getTermLine src + + logNote "receiving" + let dstFile = "./tests/tmp/testfile.out" + dst ##> ("/_download 1 " <> uri <> " " <> dstFile) + dst <## "started standalone receiving file 1 (testfile.out)" + threadDelay 25000 -- give workers some time to avoid internal errors from starting tasks + logNote "cancelling" + dst ##> "/fc 1" + dst <## "cancelled receiving file 1 (testfile.out)" + threadDelay 25000 + doesFileExist dstFile `shouldReturn` False + startFileTransfer :: HasCallStack => TestCC -> TestCC -> IO () startFileTransfer alice bob = startFileTransfer' alice bob "test.jpg" "136.5 KiB / 139737 bytes" diff --git a/tests/ChatTests/Local.hs b/tests/ChatTests/Local.hs index 1d0c540d7..4467ae937 100644 --- a/tests/ChatTests/Local.hs +++ b/tests/ChatTests/Local.hs @@ -152,7 +152,7 @@ testFiles tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do alice ##> "/clear *" alice ##> "/fs 1" - alice <## "chat db error: SEChatItemNotFoundByFileId {fileId = 1}" + alice <## "file 1 not found" alice ##> "/tail" doesFileExist stored `shouldReturn` False