From 435ea9a45356d4eb48879c541149efbf0532dccd Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 8 Mar 2024 13:38:48 +0000 Subject: [PATCH] core: api to pass additional information with standalone file URI (#3873) * xftp: redirect for descriptions with more than one chunk * handle errors * core: api to pass additional information with standalone file URI * cleanup * test info with large file * Apply suggestions from code review Co-authored-by: Evgeny Poberezkin * remove db-mediated client data * refactor * fix --------- Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> --- src/Simplex/Chat.hs | 38 ++++++++-------- src/Simplex/Chat/Controller.hs | 2 + src/Simplex/Chat/View.hs | 1 + tests/ChatTests/Files.hs | 80 +++++++++++++++++++++++++++++++--- 4 files changed, 97 insertions(+), 24 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 2f6eb0c910..21be1b1f86 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -2008,6 +2008,7 @@ processChatCommand' vr = \case when (fileSize > toInteger maxFileSizeHard) $ throwChatError $ CEFileSize filePath (_, _, fileTransferMeta) <- xftpSndFileTransfer_ user file fileSize 1 Nothing pure CRSndStandaloneFileCreated {user, fileTransferMeta} + APIStandaloneFileInfo FileDescriptionURI {clientData} -> pure . CRStandaloneFileInfo $ clientData >>= J.decodeStrict . encodeUtf8 APIDownloadStandaloneFile userId uri file -> withUserId userId $ \user -> do ft <- receiveViaURI user uri file pure $ CRRcvStandaloneFileCreated user ft @@ -3271,13 +3272,15 @@ processAgentMsgSndFile _corrId aFileId msg = 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 + case rfds of + [] -> sendFileError "no receiver descriptions" fileId vr ft + rfd : _ -> case [fd | fd@(FD.ValidFileDescription FD.FileDescription {chunks = [_]}) <- rfds] of + [] -> case xftpRedirectFor of + Nothing -> xftpSndFileRedirect user fileId rfd >>= toView . CRSndFileRedirectStartXFTP user ft + Just _ -> sendFileError "Prohibit chaining redirects" fileId vr ft + rfds' -> do -- we have 1 chunk - use it as URI whether it is redirect or not + ft' <- maybe (pure ft) (\fId -> withStore $ \db -> getFileTransferMeta db user fId) xftpRedirectFor + toView $ CRSndStandaloneFileComplete user ft' $ map (decodeLatin1 . strEncode . FD.fileDescriptionURI) rfds' Just (AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) -> case (msgId_, itemDeleted) of (Just sharedMsgId, Nothing) -> do @@ -3319,19 +3322,11 @@ processAgentMsgSndFile _corrId aFileId msg = SFERR e | temporaryAgentError e -> throwChatError $ CEXFTPSndFile fileId (AgentSndFileId aFileId) e - | otherwise -> do - ci <- withStore $ \db -> do - liftIO $ updateFileCancelled db user fileId CIFSSndError - lookupChatItemByFileId db vr user fileId - withAgent (`xftpDeleteSndFileInternal` aFileId) - toView $ CRSndFileError user ci ft + | otherwise -> + sendFileError (tshow e) fileId vr 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 @@ -3346,6 +3341,14 @@ processAgentMsgSndFile _corrId aFileId msg = case L.nonEmpty fds of Just fds' -> loopSend fds' Nothing -> pure msgDeliveryId + sendFileError :: Text -> Int64 -> VersionRange -> FileTransferMeta -> m () + sendFileError err fileId vr ft = do + logError $ "Sent file error: " <> err + ci <- withStore $ \db -> do + liftIO $ updateFileCancelled db user fileId CIFSSndError + lookupChatItemByFileId db vr user fileId + withAgent (`xftpDeleteSndFileInternal` aFileId) + toView $ CRSndFileError user ci ft splitFileDescr :: ChatMonad m => RcvFileDescrText -> m (NonEmpty FileDescr) splitFileDescr rfdText = do @@ -6783,6 +6786,7 @@ chatCommandP = "/stop remote ctrl" $> StopRemoteCtrl, "/delete remote ctrl " *> (DeleteRemoteCtrl <$> A.decimal), "/_upload " *> (APIUploadStandaloneFile <$> A.decimal <* A.space <*> cryptoFileP), + "/_download info " *> (APIStandaloneFileInfo <$> strP), "/_download " *> (APIDownloadStandaloneFile <$> A.decimal <* A.space <*> strP_ <*> cryptoFileP), ("/quit" <|> "/q" <|> "/exit") $> QuitChat, ("/version" <|> "/v") $> ShowVersion, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index c482825e18..9c85d90b43 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -455,6 +455,7 @@ data ChatCommand | DeleteRemoteCtrl RemoteCtrlId -- Remove all local data associated with a remote controller session | APIUploadStandaloneFile UserId CryptoFile | APIDownloadStandaloneFile UserId FileDescriptionURI CryptoFile + | APIStandaloneFileInfo FileDescriptionURI | QuitChat | ShowVersion | DebugLocks @@ -594,6 +595,7 @@ data ChatResponse | CRRcvFileAccepted {user :: User, chatItem :: AChatItem} | CRRcvFileAcceptedSndCancelled {user :: User, rcvFileTransfer :: RcvFileTransfer} | CRRcvFileDescrNotReady {user :: User, chatItem :: AChatItem} + | CRStandaloneFileInfo {fileMeta :: Maybe J.Value} | 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} diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 667613ba6a..7648cba32a 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -218,6 +218,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRSndFileError u (Just ci) _ -> ttyUser u $ uploadingFile "error" ci CRSndFileRcvCancelled u _ ft@SndFileTransfer {recipientDisplayName = c} -> ttyUser u [ttyContact c <> " cancelled receiving " <> sndFile ft] + CRStandaloneFileInfo info_ -> maybe ["no file information in URI"] (\j -> [plain . LB.toStrict $ J.encode j]) info_ CRContactConnecting u _ -> ttyUser u [] CRContactConnected u ct userCustomProfile -> ttyUser u $ viewContactConnected ct userCustomProfile testView CRContactAnotherClient u c -> ttyUser u [ttyContact' c <> ": contact is connected to another client"] diff --git a/tests/ChatTests/Files.hs b/tests/ChatTests/Files.hs index 3aa345773e..1e72df9156 100644 --- a/tests/ChatTests/Files.hs +++ b/tests/ChatTests/Files.hs @@ -13,6 +13,7 @@ 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 +import Network.HTTP.Types.URI (urlEncode) import Simplex.Chat (roundedFDCount) import Simplex.Chat.Controller (ChatConfig (..)) import Simplex.Chat.Mobile.File @@ -52,7 +53,9 @@ chatFileTests = do 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 small standalone file with extra information" testXFTPStandaloneSmallInfo it "send and receive large standalone file" testXFTPStandaloneLarge + it "send and receive large standalone file with extra information" testXFTPStandaloneLargeInfo it "send and receive large standalone file using relative paths" testXFTPStandaloneRelativePaths xit "removes sent file from server" testXFTPStandaloneCancelSnd -- no error shown in tests it "removes received temporary files" testXFTPStandaloneCancelRcv @@ -848,11 +851,11 @@ 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)" + src ##> "/_upload 1 ./tests/fixtures/logo.jpg" + src <## "started standalone uploading file 1 (logo.jpg)" -- silent progress events threadDelay 250000 - src <## "file 1 (test.jpg) upload complete. download with:" + src <## "file 1 (logo.jpg) upload complete. download with:" -- file description fits, enjoy the direct URIs _uri1 <- getTermLine src _uri2 <- getTermLine src @@ -860,13 +863,43 @@ testXFTPStandaloneSmall = testChat2 aliceProfile aliceDesktopProfile $ \src dst _uri4 <- getTermLine src logNote "receiving" - let dstFile = "./tests/tmp/test.jpg" + let dstFile = "./tests/tmp/logo.jpg" dst ##> ("/_download 1 " <> uri3 <> " " <> dstFile) - dst <## "started standalone receiving file 1 (test.jpg)" + dst <## "started standalone receiving file 1 (logo.jpg)" -- silent progress events threadDelay 250000 - dst <## "completed standalone receiving file 1 (test.jpg)" - srcBody <- B.readFile "./tests/fixtures/test.jpg" + dst <## "completed standalone receiving file 1 (logo.jpg)" + srcBody <- B.readFile "./tests/fixtures/logo.jpg" + B.readFile dstFile `shouldReturn` srcBody + +testXFTPStandaloneSmallInfo :: HasCallStack => FilePath -> IO () +testXFTPStandaloneSmallInfo = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do + withXFTPServer $ do + logNote "sending" + src ##> "/_upload 1 ./tests/fixtures/logo.jpg" + src <## "started standalone uploading file 1 (logo.jpg)" + -- silent progress events + threadDelay 250000 + src <## "file 1 (logo.jpg) upload complete. download with:" + -- file description fits, enjoy the direct URIs + _uri1 <- getTermLine src + _uri2 <- getTermLine src + uri3 <- getTermLine src + _uri4 <- getTermLine src + let uri = uri3 <> "&data=" <> B.unpack (urlEncode False . LB.toStrict . J.encode $ J.object ["secret" J..= J.String "*********"]) + + logNote "info" + dst ##> ("/_download info " <> uri) + dst <## "{\"secret\":\"*********\"}" + + logNote "receiving" + let dstFile = "./tests/tmp/logo.jpg" + dst ##> ("/_download 1 " <> uri <> " " <> dstFile) -- download sucessfully discarded extra info + dst <## "started standalone receiving file 1 (logo.jpg)" + -- silent progress events + threadDelay 250000 + dst <## "completed standalone receiving file 1 (logo.jpg)" + srcBody <- B.readFile "./tests/fixtures/logo.jpg" B.readFile dstFile `shouldReturn` srcBody testXFTPStandaloneLarge :: HasCallStack => FilePath -> IO () @@ -896,6 +929,39 @@ testXFTPStandaloneLarge = testChat2 aliceProfile aliceDesktopProfile $ \src dst srcBody <- B.readFile "./tests/tmp/testfile.in" B.readFile dstFile `shouldReturn` srcBody +testXFTPStandaloneLargeInfo :: HasCallStack => FilePath -> IO () +testXFTPStandaloneLargeInfo = 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:" + uri1 <- getTermLine src + _uri2 <- getTermLine src + _uri3 <- getTermLine src + _uri4 <- getTermLine src + let uri = uri1 <> "&data=" <> B.unpack (urlEncode False . LB.toStrict . J.encode $ J.object ["secret" J..= J.String "*********"]) + + logNote "info" + dst ##> ("/_download info " <> uri) + dst <## "{\"secret\":\"*********\"}" + + 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