mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
core: bulk forward missing files error handling (#4860)
* add types * wip dump * collect errors * Update src/Simplex/Chat/View.hs Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> * test with not received files * remove ciFileLoaded * undo refactoring * test for skipping missing file with text * add test for empty message * remove fdescribes * copy or cleanup files after collecting errors and forward reqs * don't forward w/t content * translate CIFSRcvAborted into FFENotAccepted * refactor * refactor --------- Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com> Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Diogo
GitHub
parent
acf2f1fbbe
commit
46d774a822
5 changed files with 190 additions and 120 deletions
|
|
@ -980,47 +980,70 @@ processChatCommand' vr = \case
|
|||
throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed")
|
||||
when (add && length rs >= maxMsgReactions) $
|
||||
throwChatError (CECommandError "too many reactions")
|
||||
APIForwardChatItems (ChatRef toCType toChatId) (ChatRef fromCType fromChatId) itemIds itemTTL -> withUser $ \user -> case toCType of
|
||||
APIForwardChatItems (ChatRef toCType toChatId) (ChatRef fromCType fromChatId) itemIds itemTTL ignoreMissingFiles -> withUser $ \user -> case toCType of
|
||||
CTDirect -> do
|
||||
cmrs <- prepareForward user
|
||||
case L.nonEmpty cmrs of
|
||||
Just cmrs' ->
|
||||
withContactLock "forwardChatItem, to contact" toChatId $
|
||||
sendContactContentMessages user toChatId False itemTTL cmrs'
|
||||
Nothing -> throwChatError $ CEInternalError "no chat items to forward"
|
||||
cmrs <- prepareForwardOrFail user
|
||||
withContactLock "forwardChatItem, to contact" toChatId $
|
||||
sendContactContentMessages user toChatId False itemTTL cmrs
|
||||
CTGroup -> do
|
||||
cmrs <- prepareForward user
|
||||
case L.nonEmpty cmrs of
|
||||
Just cmrs' ->
|
||||
withGroupLock "forwardChatItem, to group" toChatId $
|
||||
sendGroupContentMessages user toChatId False itemTTL cmrs'
|
||||
Nothing -> throwChatError $ CEInternalError "no chat items to forward"
|
||||
cmrs <- prepareForwardOrFail user
|
||||
withGroupLock "forwardChatItem, to group" toChatId $
|
||||
sendGroupContentMessages user toChatId False itemTTL cmrs
|
||||
CTLocal -> do
|
||||
cmrs <- prepareForward user
|
||||
case L.nonEmpty cmrs of
|
||||
Just cmrs' ->
|
||||
createNoteFolderContentItems user toChatId cmrs'
|
||||
Nothing -> throwChatError $ CEInternalError "no chat items to forward"
|
||||
cmrs <- prepareForwardOrFail user
|
||||
createNoteFolderContentItems user toChatId cmrs
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
where
|
||||
prepareForward :: User -> CM [ComposeMessageReq]
|
||||
prepareForwardOrFail :: User -> CM (NonEmpty ComposeMessageReq)
|
||||
prepareForwardOrFail user = do
|
||||
(errs, cmrs) <- partitionEithers . L.toList <$> prepareForward user
|
||||
case sortOn fst errs of
|
||||
[] -> case L.nonEmpty (catMaybes cmrs) of
|
||||
Nothing -> throwChatError $ CEInternalError "no chat items to forward"
|
||||
Just cmrs' -> do
|
||||
-- copy forwarded files, in case originals are deleted
|
||||
withFilesFolder $ \filesFolder -> do
|
||||
let toFolder cf@CryptoFile {filePath} = cf {filePath = filesFolder </> filePath} :: CryptoFile
|
||||
forM_ cmrs' $ \case
|
||||
(_, Just (fromCF, toCF)) ->
|
||||
liftIOEither $ runExceptT $ withExceptT (ChatError . CEInternalError . show) $
|
||||
copyCryptoFile (toFolder fromCF) (toFolder toCF)
|
||||
_ -> pure ()
|
||||
pure $ L.map fst cmrs'
|
||||
errs'@((err, _) : _) -> do
|
||||
-- cleanup files
|
||||
withFilesFolder $ \filesFolder ->
|
||||
forM_ cmrs $ \case
|
||||
Just (_, Just (_, CryptoFile {filePath = toFPath})) -> do
|
||||
let fsToPath = filesFolder </> toFPath
|
||||
removeFile fsToPath `catchChatError` \e ->
|
||||
logError ("prepareForwardOrFail: failed to clean up " <> tshow fsToPath <> ": " <> tshow e)
|
||||
_ -> pure ()
|
||||
throwChatError $ case err of
|
||||
FFENotAccepted _ -> CEForwardFilesNotAccepted files msgCount
|
||||
FFEInProgress -> CEForwardFilesInProgress filesCount msgCount
|
||||
FFEMissing -> CEForwardFilesMissing filesCount msgCount
|
||||
FFEFailed -> CEForwardFilesFailed filesCount msgCount
|
||||
where
|
||||
msgCount = foldl' (\cnt (_, hasContent) -> if hasContent then cnt + 1 else cnt) 0 errs'
|
||||
filesCount = foldl' (\cnt (e, _) -> if err == e then cnt + 1 else cnt) 0 errs'
|
||||
files = foldl' (\ftIds -> \case (FFENotAccepted ftId, _) -> ftId : ftIds; _ -> ftIds) [] errs'
|
||||
prepareForward :: User -> CM (NonEmpty (Either (ForwardFileError, Bool) (Maybe (ComposeMessageReq, Maybe (CryptoFile, CryptoFile)))))
|
||||
prepareForward user = case fromCType of
|
||||
CTDirect -> withContactLock "forwardChatItem, from contact" fromChatId $ do
|
||||
ct <- withFastStore $ \db -> getContact db vr user fromChatId
|
||||
(errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getDirectCI db) (L.toList itemIds))
|
||||
unless (null errs) $ toView $ CRChatErrors (Just user) errs
|
||||
items <- withFastStore $ \db -> mapM (getDirectChatItem db user fromChatId) itemIds
|
||||
mapM (ciComposeMsgReq ct) items
|
||||
where
|
||||
getDirectCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTDirect))
|
||||
getDirectCI db itemId = runExceptT . withExceptT ChatErrorStore $ getDirectChatItem db user fromChatId itemId
|
||||
ciComposeMsgReq :: Contact -> CChatItem 'CTDirect -> CM ComposeMessageReq
|
||||
ciComposeMsgReq :: Contact -> CChatItem 'CTDirect -> CM (Either (ForwardFileError, Bool) (Maybe (ComposeMessageReq, Maybe (CryptoFile, CryptoFile))))
|
||||
ciComposeMsgReq ct (CChatItem _ ci) = do
|
||||
(mc, mDir) <- forwardMC ci
|
||||
file <- forwardCryptoFile ci
|
||||
let itemId = chatItemId' ci
|
||||
ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) mDir (Just fromChatId) (Just itemId))
|
||||
pure (ComposedMessage file Nothing mc, ciff)
|
||||
fc <- forwardContent ci mc
|
||||
forM fc $ \mcFile -> forM mcFile $ \(mc'', file_) -> do
|
||||
let itemId = chatItemId' ci
|
||||
ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) mDir (Just fromChatId) (Just itemId))
|
||||
pure ((ComposedMessage (snd <$> file_) Nothing mc'', ciff), file_)
|
||||
where
|
||||
forwardName :: Contact -> ContactName
|
||||
forwardName Contact {profile = LocalProfile {displayName, localAlias}}
|
||||
|
|
@ -1028,35 +1051,31 @@ processChatCommand' vr = \case
|
|||
| otherwise = displayName
|
||||
CTGroup -> withGroupLock "forwardChatItem, from group" fromChatId $ do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db vr user fromChatId
|
||||
(errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db) (L.toList itemIds))
|
||||
unless (null errs) $ toView $ CRChatErrors (Just user) errs
|
||||
items <- withFastStore $ \db -> mapM (getGroupChatItem db user fromChatId) itemIds
|
||||
mapM (ciComposeMsgReq gInfo) items
|
||||
where
|
||||
getGroupCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup))
|
||||
getGroupCI db itemId = runExceptT . withExceptT ChatErrorStore $ getGroupChatItem db user fromChatId itemId
|
||||
ciComposeMsgReq :: GroupInfo -> CChatItem 'CTGroup -> CM ComposeMessageReq
|
||||
ciComposeMsgReq :: GroupInfo -> CChatItem 'CTGroup -> CM (Either (ForwardFileError, Bool) (Maybe (ComposeMessageReq, Maybe (CryptoFile, CryptoFile))))
|
||||
ciComposeMsgReq gInfo (CChatItem _ ci) = do
|
||||
(mc, mDir) <- forwardMC ci
|
||||
file <- forwardCryptoFile ci
|
||||
let itemId = chatItemId' ci
|
||||
ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) mDir (Just fromChatId) (Just itemId))
|
||||
pure (ComposedMessage file Nothing mc, ciff)
|
||||
fc <- forwardContent ci mc
|
||||
forM fc $ \mcFile -> forM mcFile $ \(mc'', file_) -> do
|
||||
let itemId = chatItemId' ci
|
||||
ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) mDir (Just fromChatId) (Just itemId))
|
||||
pure ((ComposedMessage (snd <$> file_) Nothing mc'', ciff), file_)
|
||||
where
|
||||
forwardName :: GroupInfo -> ContactName
|
||||
forwardName GroupInfo {groupProfile = GroupProfile {displayName}} = displayName
|
||||
CTLocal -> do
|
||||
(errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getLocalCI db) (L.toList itemIds))
|
||||
unless (null errs) $ toView $ CRChatErrors (Just user) errs
|
||||
items <- withFastStore $ \db -> mapM (getLocalChatItem db user fromChatId) itemIds
|
||||
mapM ciComposeMsgReq items
|
||||
where
|
||||
getLocalCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTLocal))
|
||||
getLocalCI db itemId = runExceptT . withExceptT ChatErrorStore $ getLocalChatItem db user fromChatId itemId
|
||||
ciComposeMsgReq :: CChatItem 'CTLocal -> CM ComposeMessageReq
|
||||
ciComposeMsgReq :: CChatItem 'CTLocal -> CM (Either (ForwardFileError, Bool) (Maybe (ComposeMessageReq, Maybe (CryptoFile, CryptoFile))))
|
||||
ciComposeMsgReq (CChatItem _ ci) = do
|
||||
(mc, _) <- forwardMC ci
|
||||
file <- forwardCryptoFile ci
|
||||
let ciff = forwardCIFF ci Nothing
|
||||
pure (ComposedMessage file Nothing mc, ciff)
|
||||
fc <- forwardContent ci mc
|
||||
forM fc $ \mcFile -> forM mcFile $ \(mc'', file_) -> do
|
||||
let ciff = forwardCIFF ci Nothing
|
||||
pure ((ComposedMessage (snd <$> file_) Nothing mc'', ciff), file_)
|
||||
CTContactRequest -> throwChatError $ CECommandError "not supported"
|
||||
CTContactConnection -> throwChatError $ CECommandError "not supported"
|
||||
where
|
||||
|
|
@ -1070,48 +1089,53 @@ processChatCommand' vr = \case
|
|||
Nothing -> ciff
|
||||
Just CIFFUnknown -> ciff
|
||||
Just prevCIFF -> Just prevCIFF
|
||||
forwardCryptoFile :: ChatItem c d -> CM (Maybe CryptoFile)
|
||||
forwardCryptoFile ChatItem {file = Nothing} = pure Nothing
|
||||
forwardCryptoFile ChatItem {file = Just ciFile} = case ciFile of
|
||||
CIFile {fileName, fileSource = Just fromCF@CryptoFile {filePath}} ->
|
||||
chatReadVar filesFolder >>= \case
|
||||
Nothing ->
|
||||
ifM (doesFileExist filePath) (pure $ Just fromCF) (pure Nothing)
|
||||
Just filesFolder -> do
|
||||
let fsFromPath = filesFolder </> filePath
|
||||
ifM
|
||||
(doesFileExist fsFromPath)
|
||||
( do
|
||||
fsNewPath <- liftIO $ filesFolder `uniqueCombine` fileName
|
||||
liftIO $ B.writeFile fsNewPath "" -- create empty file
|
||||
encrypt <- chatReadVar encryptLocalFiles
|
||||
cfArgs <- if encrypt then Just <$> (atomically . CF.randomArgs =<< asks random) else pure Nothing
|
||||
let toCF = CryptoFile fsNewPath cfArgs
|
||||
-- to keep forwarded file in case original is deleted
|
||||
liftIOEither $ runExceptT $ withExceptT (ChatError . CEInternalError . show) $ copyCryptoFile (fromCF {filePath = fsFromPath} :: CryptoFile) toCF
|
||||
pure $ Just (toCF {filePath = takeFileName fsNewPath} :: CryptoFile)
|
||||
)
|
||||
(pure Nothing)
|
||||
_ -> pure Nothing
|
||||
copyCryptoFile :: CryptoFile -> CryptoFile -> ExceptT CF.FTCryptoError IO ()
|
||||
copyCryptoFile fromCF@CryptoFile {filePath = fsFromPath, cryptoArgs = fromArgs} toCF@CryptoFile {cryptoArgs = toArgs} = do
|
||||
fromSizeFull <- getFileSize fsFromPath
|
||||
let fromSize = fromSizeFull - maybe 0 (const $ toInteger C.authTagSize) fromArgs
|
||||
CF.withFile fromCF ReadMode $ \fromH ->
|
||||
CF.withFile toCF WriteMode $ \toH -> do
|
||||
copyChunks fromH toH fromSize
|
||||
forM_ fromArgs $ \_ -> CF.hGetTag fromH
|
||||
forM_ toArgs $ \_ -> liftIO $ CF.hPutTag toH
|
||||
forwardContent :: ChatItem c d -> MsgContent -> CM (Either (ForwardFileError, Bool) (Maybe (MsgContent, Maybe (CryptoFile, CryptoFile))))
|
||||
forwardContent ChatItem {file = Nothing} mc = pure $ Right $ Just (mc, Nothing)
|
||||
forwardContent ChatItem {file = Just ciFile} mc = case ciFile of
|
||||
CIFile {fileId, fileName, fileStatus, fileSource = Just fromCF@CryptoFile {filePath}} -> case ciFileForwardError fileId fileStatus of
|
||||
Just e -> pure $ ignoreOrError e
|
||||
Nothing ->
|
||||
chatReadVar filesFolder >>= \case
|
||||
Nothing ->
|
||||
ifM (doesFileExist filePath) (pure $ Right $ Just (mc, Just (fromCF, fromCF))) (pure $ ignoreOrError FFEMissing)
|
||||
Just filesFolder ->
|
||||
ifM (doesFileExist $ filesFolder </> filePath) forwardedFile (pure $ ignoreOrError FFEMissing)
|
||||
where
|
||||
forwardedFile = do
|
||||
fsNewPath <- liftIO $ filesFolder `uniqueCombine` fileName
|
||||
liftIO $ B.writeFile fsNewPath "" -- create empty file
|
||||
encrypt <- chatReadVar encryptLocalFiles
|
||||
cfArgs <- if encrypt then Just <$> (atomically . CF.randomArgs =<< asks random) else pure Nothing
|
||||
let toCF = CryptoFile fsNewPath cfArgs
|
||||
pure $ Right $ Just (mc, Just (fromCF, toCF {filePath = takeFileName fsNewPath} :: CryptoFile))
|
||||
_ -> pure $ ignoreOrError FFEMissing
|
||||
where
|
||||
copyChunks :: CF.CryptoFileHandle -> CF.CryptoFileHandle -> Integer -> ExceptT CF.FTCryptoError IO ()
|
||||
copyChunks r w size = do
|
||||
let chSize = min size U.chunkSize
|
||||
chSize' = fromIntegral chSize
|
||||
size' = size - chSize
|
||||
ch <- liftIO $ CF.hGet r chSize'
|
||||
when (B.length ch /= chSize') $ throwError $ CF.FTCEFileIOError "encrypting file: unexpected EOF"
|
||||
liftIO . CF.hPut w $ LB.fromStrict ch
|
||||
when (size' > 0) $ copyChunks r w size'
|
||||
ignoreOrError err = if ignoreMissingFiles then Right (newContent mc) else Left (err, hasContent mc)
|
||||
where
|
||||
newContent mc' = case mc' of
|
||||
MCImage {} -> Just (mc', Nothing)
|
||||
_ | msgContentText mc' /= "" -> Just (MCText $ msgContentText mc', Nothing)
|
||||
_ -> Nothing
|
||||
hasContent mc' = isJust $ newContent mc'
|
||||
copyCryptoFile :: CryptoFile -> CryptoFile -> ExceptT CF.FTCryptoError IO ()
|
||||
copyCryptoFile fromCF@CryptoFile {filePath = fsFromPath, cryptoArgs = fromArgs} toCF@CryptoFile {cryptoArgs = toArgs} = do
|
||||
fromSizeFull <- getFileSize fsFromPath
|
||||
let fromSize = fromSizeFull - maybe 0 (const $ toInteger C.authTagSize) fromArgs
|
||||
CF.withFile fromCF ReadMode $ \fromH ->
|
||||
CF.withFile toCF WriteMode $ \toH -> do
|
||||
copyChunks fromH toH fromSize
|
||||
forM_ fromArgs $ \_ -> CF.hGetTag fromH
|
||||
forM_ toArgs $ \_ -> liftIO $ CF.hPutTag toH
|
||||
where
|
||||
copyChunks :: CF.CryptoFileHandle -> CF.CryptoFileHandle -> Integer -> ExceptT CF.FTCryptoError IO ()
|
||||
copyChunks r w size = do
|
||||
let chSize = min size U.chunkSize
|
||||
chSize' = fromIntegral chSize
|
||||
size' = size - chSize
|
||||
ch <- liftIO $ CF.hGet r chSize'
|
||||
when (B.length ch /= chSize') $ throwError $ CF.FTCEFileIOError "encrypting file: unexpected EOF"
|
||||
liftIO . CF.hPut w $ LB.fromStrict ch
|
||||
when (size' > 0) $ copyChunks r w size'
|
||||
APIUserRead userId -> withUserId userId $ \user -> withFastStore' (`setUserChatsRead` user) >> ok user
|
||||
UserRead -> withUser $ \User {userId} -> processChatCommand $ APIUserRead userId
|
||||
APIChatRead chatRef@(ChatRef cType chatId) fromToIds -> withUser $ \_ -> case cType of
|
||||
|
|
@ -1831,17 +1855,17 @@ processChatCommand' vr = \case
|
|||
contactId <- withFastStore $ \db -> getContactIdByName db user fromContactName
|
||||
forwardedItemId <- withFastStore $ \db -> getDirectChatItemIdByText' db user contactId forwardedMsg
|
||||
toChatRef <- getChatRef user toChatName
|
||||
processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTDirect contactId) (forwardedItemId :| []) Nothing
|
||||
processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTDirect contactId) (forwardedItemId :| []) Nothing True
|
||||
ForwardGroupMessage toChatName fromGroupName fromMemberName_ forwardedMsg -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user fromGroupName
|
||||
forwardedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId fromMemberName_ forwardedMsg
|
||||
toChatRef <- getChatRef user toChatName
|
||||
processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTGroup groupId) (forwardedItemId :| []) Nothing
|
||||
processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTGroup groupId) (forwardedItemId :| []) Nothing True
|
||||
ForwardLocalMessage toChatName forwardedMsg -> withUser $ \user -> do
|
||||
folderId <- withFastStore (`getUserNoteFolderId` user)
|
||||
forwardedItemId <- withFastStore $ \db -> getLocalChatItemIdByText' db user folderId forwardedMsg
|
||||
toChatRef <- getChatRef user toChatName
|
||||
processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId) (forwardedItemId :| []) Nothing
|
||||
processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId) (forwardedItemId :| []) Nothing True
|
||||
SendMessage (ChatName cType name) msg -> withUser $ \user -> do
|
||||
let mc = MCText msg
|
||||
case cType of
|
||||
|
|
@ -3332,9 +3356,10 @@ deleteFilesLocally files =
|
|||
delete fPath =
|
||||
removeFile fPath `catchAll` \_ ->
|
||||
removePathForcibly fPath `catchAll_` pure ()
|
||||
-- perform an action only if filesFolder is set (i.e. on mobile devices)
|
||||
withFilesFolder :: (FilePath -> CM ()) -> CM ()
|
||||
withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action
|
||||
|
||||
-- perform an action only if filesFolder is set (i.e. on mobile devices)
|
||||
withFilesFolder :: (FilePath -> CM ()) -> CM ()
|
||||
withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action
|
||||
|
||||
updateCallItemStatus :: User -> Contact -> Call -> WebRTCCallStatus -> Maybe MessageId -> CM ()
|
||||
updateCallItemStatus user ct@Contact {contactId} Call {chatItemId} receivedStatus msgId_ = do
|
||||
|
|
@ -7888,7 +7913,7 @@ chatCommandP =
|
|||
"/_delete item " *> (APIDeleteChatItem <$> chatRefP <*> _strP <* A.space <*> ciDeleteMode),
|
||||
"/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <*> _strP),
|
||||
"/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> jsonP),
|
||||
"/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP),
|
||||
"/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP <*> (" ignore_files=" *> onOffP <|> pure False)),
|
||||
"/_read user " *> (APIUserRead <$> A.decimal),
|
||||
"/read user" $> UserRead,
|
||||
"/_read chat " *> (APIChatRead <$> chatRefP <*> optional (A.space *> ((,) <$> ("from=" *> A.decimal) <* A.space <*> ("to=" *> A.decimal)))),
|
||||
|
|
|
|||
|
|
@ -298,7 +298,7 @@ data ChatCommand
|
|||
| APIDeleteChatItem ChatRef (NonEmpty ChatItemId) CIDeleteMode
|
||||
| APIDeleteMemberChatItem GroupId (NonEmpty ChatItemId)
|
||||
| APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction}
|
||||
| APIForwardChatItems {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int}
|
||||
| APIForwardChatItems {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int, ignoreMissingFiles :: Bool}
|
||||
| APIUserRead UserId
|
||||
| UserRead
|
||||
| APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId))
|
||||
|
|
@ -1178,6 +1178,10 @@ data ChatErrorType
|
|||
| CEFallbackToSMPProhibited {fileId :: FileTransferId}
|
||||
| CEInlineFileProhibited {fileId :: FileTransferId}
|
||||
| CEInvalidQuote
|
||||
| CEForwardFilesNotAccepted {files :: [FileTransferId], msgCount :: Int} -- contentCount is the count of messages if files are ignored
|
||||
| CEForwardFilesInProgress {filesCount :: Int, msgCount :: Int}
|
||||
| CEForwardFilesMissing {filesCount :: Int, msgCount :: Int}
|
||||
| CEForwardFilesFailed {filesCount :: Int, msgCount :: Int}
|
||||
| CEInvalidForward
|
||||
| CEInvalidChatItemUpdate
|
||||
| CEInvalidChatItemDelete
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing)
|
|||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time.Clock (UTCTime, diffUTCTime, nominalDay, NominalDiffTime)
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, nominalDay)
|
||||
import Data.Type.Equality
|
||||
import Data.Typeable (Typeable)
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
|
|
@ -577,23 +577,26 @@ ciFileEnded = \case
|
|||
CIFSRcvWarning {} -> False
|
||||
CIFSInvalid {} -> True
|
||||
|
||||
ciFileLoaded :: CIFileStatus d -> Bool
|
||||
ciFileLoaded = \case
|
||||
CIFSSndStored -> True
|
||||
CIFSSndTransfer {} -> True
|
||||
CIFSSndComplete -> True
|
||||
CIFSSndCancelled -> True
|
||||
CIFSSndError {} -> True
|
||||
CIFSSndWarning {} -> True
|
||||
CIFSRcvInvitation -> False
|
||||
CIFSRcvAccepted -> False
|
||||
CIFSRcvTransfer {} -> False
|
||||
CIFSRcvAborted -> False
|
||||
CIFSRcvCancelled -> False
|
||||
CIFSRcvComplete -> True
|
||||
CIFSRcvError {} -> False
|
||||
CIFSRcvWarning {} -> False
|
||||
CIFSInvalid {} -> False
|
||||
data ForwardFileError = FFENotAccepted FileTransferId | FFEInProgress | FFEFailed | FFEMissing
|
||||
deriving (Eq, Ord)
|
||||
|
||||
ciFileForwardError :: FileTransferId -> CIFileStatus d -> Maybe ForwardFileError
|
||||
ciFileForwardError fId = \case
|
||||
CIFSSndStored -> Nothing
|
||||
CIFSSndTransfer {} -> Nothing
|
||||
CIFSSndComplete -> Nothing
|
||||
CIFSSndCancelled -> Nothing
|
||||
CIFSSndError {} -> Nothing
|
||||
CIFSSndWarning {} -> Nothing
|
||||
CIFSRcvInvitation -> Just $ FFENotAccepted fId
|
||||
CIFSRcvAccepted -> Just FFEInProgress
|
||||
CIFSRcvTransfer {} -> Just FFEInProgress
|
||||
CIFSRcvAborted -> Just $ FFENotAccepted fId
|
||||
CIFSRcvCancelled -> Just FFEFailed -- ?
|
||||
CIFSRcvComplete -> Nothing
|
||||
CIFSRcvError {} -> Just FFEFailed
|
||||
CIFSRcvWarning {} -> Just FFEFailed
|
||||
CIFSInvalid {} -> Just FFEFailed -- ?
|
||||
|
||||
data ACIFileStatus = forall d. MsgDirectionI d => AFS (SMsgDirection d) (CIFileStatus d)
|
||||
|
||||
|
|
|
|||
|
|
@ -2034,7 +2034,11 @@ viewChatError isCmd logLevel testView = \case
|
|||
CEFallbackToSMPProhibited fileId -> ["recipient tried to accept file " <> sShow fileId <> " via old protocol, prohibited"]
|
||||
CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."]
|
||||
CEInvalidQuote -> ["cannot reply to this message"]
|
||||
CEInvalidForward -> ["cannot forward this message"]
|
||||
CEInvalidForward -> ["cannot forward message(s)"]
|
||||
CEForwardFilesNotAccepted files msgCount -> [plain $ "Some files are not accepted: " <> intercalate ", " (map show files), showForwardMsgCount msgCount]
|
||||
CEForwardFilesInProgress cnt msgCount -> [plain $ "Still receiving " <> show cnt <> " file(s)", showForwardMsgCount msgCount]
|
||||
CEForwardFilesMissing cnt msgCount -> [plain $ show cnt <> " file(s) are missing", showForwardMsgCount msgCount]
|
||||
CEForwardFilesFailed cnt msgCount -> [plain $ show cnt <> " file(s) failed", showForwardMsgCount msgCount]
|
||||
CEInvalidChatItemUpdate -> ["cannot update this item"]
|
||||
CEInvalidChatItemDelete -> ["cannot delete this item"]
|
||||
CEHasCurrentCall -> ["call already in progress"]
|
||||
|
|
@ -2053,6 +2057,9 @@ viewChatError isCmd logLevel testView = \case
|
|||
CEPeerChatVRangeIncompatible -> ["peer chat protocol version range incompatible"]
|
||||
CEInternalError e -> ["internal chat error: " <> plain e]
|
||||
CEException e -> ["exception: " <> plain e]
|
||||
where
|
||||
showForwardMsgCount 0 = "No other messages to forward"
|
||||
showForwardMsgCount msgCount = plain $ "Use ignore_files to forward " <> show msgCount <> " message(s)"
|
||||
-- e -> ["chat error: " <> sShow e]
|
||||
ChatErrorStore err -> case err of
|
||||
SEDuplicateName -> ["this display name is already used by user, contact or group"]
|
||||
|
|
|
|||
|
|
@ -671,6 +671,8 @@ testMultiForwardFiles =
|
|||
\alice bob cath -> withXFTPServer $ do
|
||||
setRelativePaths alice "./tests/tmp/alice_app_files" "./tests/tmp/alice_xftp"
|
||||
copyFile "./tests/fixtures/test.jpg" "./tests/tmp/alice_app_files/test.jpg"
|
||||
copyFile "./tests/fixtures/test.jpg" "./tests/tmp/alice_app_files/test_3.jpg"
|
||||
copyFile "./tests/fixtures/test.jpg" "./tests/tmp/alice_app_files/test_4.jpg"
|
||||
copyFile "./tests/fixtures/test.pdf" "./tests/tmp/alice_app_files/test.pdf"
|
||||
setRelativePaths bob "./tests/tmp/bob_app_files" "./tests/tmp/bob_xftp"
|
||||
setRelativePaths cath "./tests/tmp/cath_app_files" "./tests/tmp/cath_xftp"
|
||||
|
|
@ -688,7 +690,10 @@ testMultiForwardFiles =
|
|||
let cm1 = "{\"msgContent\": {\"type\": \"text\", \"text\": \"message without file\"}}"
|
||||
cm2 = "{\"filePath\": \"test.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"sending file 1\"}}"
|
||||
cm3 = "{\"filePath\": \"test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"sending file 2\"}}"
|
||||
alice ##> ("/_send @2 json [" <> cm1 <> "," <> cm2 <> "," <> cm3 <> "]")
|
||||
cm4 = "{\"filePath\": \"test_4.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"sending file 3\"}}"
|
||||
cm5 = "{\"filePath\": \"test_3.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"file\"}}"
|
||||
|
||||
alice ##> ("/_send @2 json [" <> cm1 <> "," <> cm2 <> "," <> cm3 <> "," <> cm4 <> "," <> cm5 <> "]")
|
||||
|
||||
alice <# "@bob message without file"
|
||||
|
||||
|
|
@ -700,6 +705,13 @@ testMultiForwardFiles =
|
|||
alice <# "/f @bob test.pdf"
|
||||
alice <## "use /fc 2 to cancel sending"
|
||||
|
||||
alice <# "@bob sending file 3"
|
||||
alice <# "/f @bob test_4.jpg"
|
||||
alice <## "use /fc 3 to cancel sending"
|
||||
|
||||
alice <# "/f @bob test_3.jpg"
|
||||
alice <## "use /fc 4 to cancel sending"
|
||||
|
||||
bob <# "alice> message without file"
|
||||
|
||||
bob <# "alice> sending file 1"
|
||||
|
|
@ -710,8 +722,17 @@ testMultiForwardFiles =
|
|||
bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)"
|
||||
bob <## "use /fr 2 [<dir>/ | <path>] to receive it"
|
||||
|
||||
bob <# "alice> sending file 3"
|
||||
bob <# "alice> sends file test_4.jpg (136.5 KiB / 139737 bytes)"
|
||||
bob <## "use /fr 3 [<dir>/ | <path>] to receive it"
|
||||
|
||||
bob <# "alice> sends file test_3.jpg (136.5 KiB / 139737 bytes)"
|
||||
bob <## "use /fr 4 [<dir>/ | <path>] to receive it"
|
||||
|
||||
alice <## "completed uploading file 1 (test.jpg) for bob"
|
||||
alice <## "completed uploading file 2 (test.pdf) for bob"
|
||||
alice <## "completed uploading file 3 (test_4.jpg) for bob"
|
||||
alice <## "completed uploading file 4 (test_3.jpg) for bob"
|
||||
|
||||
bob ##> "/fr 1"
|
||||
bob
|
||||
|
|
@ -720,6 +741,11 @@ testMultiForwardFiles =
|
|||
]
|
||||
bob <## "completed receiving file 1 (test.jpg) from alice"
|
||||
|
||||
-- try to forward file without receiving 2nd file
|
||||
let msgId1 = (read msgIdZero :: Int) + 1
|
||||
bob ##> ("/_forward @3 @2 " <> show msgId1 <> "," <> show (msgId1 + 1) <> "," <> show (msgId1 + 2) <> "," <> show (msgId1 + 3) <> "," <> show (msgId1 + 4) <> "," <> show (msgId1 + 5))
|
||||
bob <### ["3 file(s) are missing", "Use ignore_files to forward 2 message(s)"]
|
||||
|
||||
bob ##> "/fr 2"
|
||||
bob
|
||||
<### [ "saving file 2 from alice to test.pdf",
|
||||
|
|
@ -736,8 +762,7 @@ testMultiForwardFiles =
|
|||
dest2 `shouldBe` src2
|
||||
|
||||
-- forward file
|
||||
let msgId1 = (read msgIdZero :: Int) + 1
|
||||
bob ##> ("/_forward @3 @2 " <> show msgId1 <> "," <> show (msgId1 + 1) <> "," <> show (msgId1 + 2) <> "," <> show (msgId1 + 3))
|
||||
bob ##> ("/_forward @3 @2 " <> show msgId1 <> "," <> show (msgId1 + 1) <> "," <> show (msgId1 + 2) <> "," <> show (msgId1 + 3) <> "," <> show (msgId1 + 4) <> "," <> show (msgId1 + 5) <> " ignore_files=on")
|
||||
|
||||
-- messages printed for bob
|
||||
bob <# "@cath <- you @alice"
|
||||
|
|
@ -749,12 +774,15 @@ testMultiForwardFiles =
|
|||
bob <# "@cath <- @alice"
|
||||
bob <## " sending file 1"
|
||||
bob <# "/f @cath test_1.jpg"
|
||||
bob <## "use /fc 3 to cancel sending"
|
||||
bob <## "use /fc 5 to cancel sending"
|
||||
|
||||
bob <# "@cath <- @alice"
|
||||
bob <## " sending file 2"
|
||||
bob <# "/f @cath test_1.pdf"
|
||||
bob <## "use /fc 4 to cancel sending"
|
||||
bob <## "use /fc 6 to cancel sending"
|
||||
|
||||
bob <# "@cath <- @alice"
|
||||
bob <## " sending file 3"
|
||||
|
||||
-- messages printed for cath
|
||||
cath <# "bob> -> forwarded"
|
||||
|
|
@ -773,9 +801,12 @@ testMultiForwardFiles =
|
|||
cath <# "bob> sends file test_1.pdf (266.0 KiB / 272376 bytes)"
|
||||
cath <## "use /fr 2 [<dir>/ | <path>] to receive it"
|
||||
|
||||
cath <# "bob> -> forwarded"
|
||||
cath <## " sending file 3" -- No file sent here
|
||||
|
||||
-- file transfer
|
||||
bob <## "completed uploading file 3 (test_1.jpg) for cath"
|
||||
bob <## "completed uploading file 4 (test_1.pdf) for cath"
|
||||
bob <## "completed uploading file 5 (test_1.jpg) for cath"
|
||||
bob <## "completed uploading file 6 (test_1.pdf) for cath"
|
||||
|
||||
cath ##> "/fr 1"
|
||||
cath
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue