core: only send voice messages without acceptance (#1444)

* core: only send voice messages without acceptance

* remove some unnecessary changes

* update

* refactor receiveInlineMode
This commit is contained in:
Evgeny Poberezkin 2022-11-26 22:39:56 +00:00 committed by GitHub
parent ade8c97b16
commit 7f0355ec67
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
9 changed files with 98 additions and 58 deletions

View file

@ -132,8 +132,9 @@ createChatDatabase filePrefix key yesToMigrations = do
pure ChatDatabase {chatStore, agentStore}
newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> IO ChatController
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, tbqSize, defaultServers} ChatOpts {smpServers, networkConfig, logConnections, logServerHosts} sendToast = do
let config = cfg {subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers}
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, tbqSize, defaultServers, inlineFiles} ChatOpts {smpServers, networkConfig, logConnections, logServerHosts, allowInstantFiles} sendToast = do
let inlineFiles' = if allowInstantFiles then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
config = cfg {subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles'}
sendNotification = fromMaybe (const $ pure ()) sendToast
firstTime = dbNew chatStore
activeTo <- newTVarIO ActiveNone
@ -305,7 +306,7 @@ processChatCommand = \case
where
setupSndFileTransfer :: Contact -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
setupSndFileTransfer ct = forM file_ $ \file -> do
(fileSize, chSize, fileInline) <- checkSndFile file 1
(fileSize, chSize, fileInline) <- checkSndFile mc file 1
(agentConnId_, fileConnReq) <-
if isJust fileInline
then pure (Nothing, Nothing)
@ -351,7 +352,7 @@ processChatCommand = \case
where
setupSndFileTransfer :: GroupInfo -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
setupSndFileTransfer gInfo n = forM file_ $ \file -> do
(fileSize, chSize, fileInline) <- checkSndFile file $ fromIntegral n
(fileSize, chSize, fileInline) <- checkSndFile mc file $ fromIntegral n
let fileName = takeFileName file
fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Nothing, fileInline}
fileStatus = if fileInline == Just IFMSent then CIFSSndTransfer else CIFSSndStored
@ -1160,18 +1161,18 @@ processChatCommand = \case
contactMember Contact {contactId} =
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft
checkSndFile :: FilePath -> Integer -> m (Integer, Integer, Maybe InlineFileMode)
checkSndFile f n = do
checkSndFile :: MsgContent -> FilePath -> Integer -> m (Integer, Integer, Maybe InlineFileMode)
checkSndFile mc f n = do
fsFilePath <- toFSFilePath f
unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f
ChatConfig {fileChunkSize, inlineFiles} <- asks config
fileSize <- getFileSize fsFilePath
let chunks = - ((- fileSize) `div` fileChunkSize)
pure (fileSize, fileChunkSize, inlineFileMode inlineFiles chunks n)
inlineFileMode InlineFilesConfig {offerChunks, sendChunks, totalSendChunks} chunks n
pure (fileSize, fileChunkSize, inlineFileMode mc inlineFiles chunks n)
inlineFileMode mc InlineFilesConfig {offerChunks, sendChunks, totalSendChunks} chunks n
| chunks > offerChunks = Nothing
| chunks > sendChunks || chunks * n > totalSendChunks = Just IFMOffer
| otherwise = Just IFMSent
| chunks <= sendChunks && chunks * n <= totalSendChunks && isVoice mc = Just IFMSent
| otherwise = Just IFMOffer
updateProfile :: User -> Profile -> m ChatResponse
updateProfile user@User {profile = p@LocalProfile {profileId, localAlias}} p'@Profile {displayName}
| p' == fromLocalProfile p = pure CRUserProfileNoChange
@ -2200,7 +2201,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
case featureProhibited forContact ct content of
Just f -> void $ newChatItem (CIRcvChatFeatureRejected f) Nothing
_ -> do
ciFile_ <- processFileInvitation fileInvitation_ $ \db -> createRcvFileTransfer db userId ct
ciFile_ <- processFileInvitation fileInvitation_ content $ \db -> createRcvFileTransfer db userId ct
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) ciFile_
when (enableNtfs chatSettings) $ showMsgToast (c <> "> ") content formattedText
setActive $ ActiveC c
@ -2210,10 +2211,10 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
pure ci
processFileInvitation :: Maybe FileInvitation -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer) -> m (Maybe (CIFile 'MDRcv))
processFileInvitation fInv_ createRcvFT = forM fInv_ $ \fInv@FileInvitation {fileName, fileSize} -> do
processFileInvitation :: Maybe FileInvitation -> MsgContent -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer) -> m (Maybe (CIFile 'MDRcv))
processFileInvitation fInv_ mc createRcvFT = forM fInv_ $ \fInv@FileInvitation {fileName, fileSize} -> do
chSize <- asks $ fileChunkSize . config
inline <- receiveInlineMode fInv chSize
inline <- receiveInlineMode fInv (Just mc) chSize
ft@RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvFT db fInv inline chSize
(filePath, fileStatus) <- case inline of
Just IFMSent -> do
@ -2265,7 +2266,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
case groupFeatureProhibited gInfo content of
Just f -> void $ newChatItem (CIRcvChatFeatureRejected f) Nothing
_ -> do
ciFile_ <- processFileInvitation fInv_ $ \db -> createRcvGroupFileTransfer db userId m
ciFile_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) ciFile_
let g = groupName' gInfo
when (enableNtfs chatSettings) $ showMsgToast ("#" <> g <> " " <> c <> "> ") content formattedText
@ -2318,7 +2319,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
processFileInvitation' ct@Contact {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
chSize <- asks $ fileChunkSize . config
inline <- receiveInlineMode fInv chSize
inline <- receiveInlineMode fInv Nothing chSize
RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvFileTransfer db userId ct fInv inline chSize
let ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation}
ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvMsgContent $ MCFile "") ciFile
@ -2330,7 +2331,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> MsgMeta -> m ()
processGroupFileInvitation' gInfo m@GroupMember {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg msgMeta = do
chSize <- asks $ fileChunkSize . config
inline <- receiveInlineMode fInv chSize
inline <- receiveInlineMode fInv Nothing chSize
RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvGroupFileTransfer db userId m fInv inline chSize
let ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation}
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvMsgContent $ MCFile "") ciFile
@ -2339,11 +2340,13 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
showToast ("#" <> g <> " " <> c <> "> ") "wants to send a file"
setActive $ ActiveG g
receiveInlineMode :: FileInvitation -> Integer -> m (Maybe InlineFileMode)
receiveInlineMode FileInvitation {fileSize, fileInline} chSize = case fileInline of
inline@(Just _) -> do
rcvChunks <- asks $ receiveChunks . inlineFiles . config
pure $ if fileSize <= rcvChunks * chSize then inline else Nothing
receiveInlineMode :: FileInvitation -> Maybe MsgContent -> Integer -> m (Maybe InlineFileMode)
receiveInlineMode FileInvitation {fileSize, fileInline} mc_ chSize = case fileInline of
Just mode -> do
InlineFilesConfig {receiveChunks, receiveInstant} <- asks $ inlineFiles . config
pure $ if fileSize <= receiveChunks * chSize then inline' receiveInstant else Nothing
where
inline' receiveInstant = if mode == IFMOffer || (receiveInstant && maybe False isVoice mc_) then fileInline else Nothing
_ -> pure Nothing
xFileCancel :: Contact -> SharedMsgId -> MsgMeta -> m ()
@ -2408,6 +2411,9 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
receiveInlineChunk ft chunk meta
receiveInlineChunk :: RcvFileTransfer -> FileChunk -> MsgMeta -> m ()
receiveInlineChunk RcvFileTransfer {fileId, fileStatus = RFSNew} FileChunk {chunkNo} _
| chunkNo == 1 = throwChatError $ CEFileLargeSentInline fileId
| otherwise = pure ()
receiveInlineChunk ft chunk meta = do
case chunk of
FileChunk {chunkNo} -> when (chunkNo == 1) $ startReceivingFile ft

View file

@ -81,7 +81,8 @@ data InlineFilesConfig = InlineFilesConfig
{ offerChunks :: Integer,
sendChunks :: Integer,
totalSendChunks :: Integer,
receiveChunks :: Integer
receiveChunks :: Integer,
receiveInstant :: Bool
}
defaultInlineFilesConfig :: InlineFilesConfig
@ -90,7 +91,8 @@ defaultInlineFilesConfig =
{ offerChunks = 15, -- max when chunks are offered / received with the option - limited to 255 on the encoding level
sendChunks = 6, -- max per file when chunks will be sent inline without acceptance
totalSendChunks = 30, -- max per conversation when chunks will be sent inline without acceptance
receiveChunks = 8 -- max when chunks are accepted
receiveChunks = 8, -- max when chunks are accepted
receiveInstant = True -- allow receiving instant files, within receiveChunks limit
}
data ActiveTo = ActiveNone | ActiveC ContactName | ActiveG GroupName
@ -534,6 +536,7 @@ data ChatErrorType
| CEFileImageType {filePath :: FilePath}
| CEFileImageSize {filePath :: FilePath}
| CEFileNotReceived {fileId :: FileTransferId}
| CEFileLargeSentInline {fileId :: FileTransferId}
| CEInvalidQuote
| CEInvalidChatItemUpdate
| CEInvalidChatItemDelete

View file

@ -129,6 +129,7 @@ mobileChatOpts =
chatCmd = "",
chatCmdDelay = 3,
chatServerPort = Nothing,
allowInstantFiles = True,
maintenance = True
}

View file

@ -34,6 +34,7 @@ data ChatOpts = ChatOpts
chatCmd :: String,
chatCmdDelay :: Int,
chatServerPort :: Maybe String,
allowInstantFiles :: Bool,
maintenance :: Bool
}
@ -126,6 +127,12 @@ chatOpts appDir defaultDbFileName = do
<> help "Run chat server on specified port"
<> value Nothing
)
allowInstantFiles <-
switch
( long "--allow-instant-files"
<> short 'f'
<> help "Send and receive instant files without acceptance"
)
maintenance <-
switch
( long "maintenance"
@ -144,6 +151,7 @@ chatOpts appDir defaultDbFileName = do
chatCmd,
chatCmdDelay,
chatServerPort,
allowInstantFiles,
maintenance
}
where

View file

@ -265,6 +265,7 @@ cmToQuotedMsg = \case
_ -> Nothing
data MsgContentTag = MCText_ | MCLink_ | MCImage_ | MCVoice_ | MCFile_ | MCUnknown_ Text
deriving (Eq)
instance StrEncoding MsgContentTag where
strEncode = \case
@ -341,6 +342,11 @@ durationText duration =
| n <= 9 = '0' : show n
| otherwise = show n
isVoice :: MsgContent -> Bool
isVoice = \case
MCVoice {} -> True
_ -> False
msgContentTag :: MsgContent -> MsgContentTag
msgContentTag = \case
MCText _ -> MCText_

View file

@ -1083,6 +1083,7 @@ viewChatError = \case
CEFileImageType _ -> ["image type must be jpg, send as a file using " <> highlight' "/f"]
CEFileImageSize _ -> ["max image size: " <> sShow maxImageSize <> " bytes, resize it or send as a file using " <> highlight' "/f"]
CEFileNotReceived fileId -> ["file " <> sShow fileId <> " not received"]
CEFileLargeSentInline _ -> ["A small file sent without acceptance - you can enable receiving such files automatically with -f option."]
CEInvalidQuote -> ["cannot reply to this message"]
CEInvalidChatItemUpdate -> ["cannot update this item"]
CEInvalidChatItemDelete -> ["cannot delete this item"]

View file

@ -59,6 +59,7 @@ testOpts =
chatCmd = "",
chatCmdDelay = 3,
chatServerPort = Nothing,
allowInstantFiles = True,
maintenance = False
}

View file

@ -1595,9 +1595,12 @@ testInlineFileTransfer =
connectUsers alice bob
bob ##> "/_files_folder ./tests/tmp/"
bob <## "ok"
alice #> "/f @bob ./tests/fixtures/test.jpg"
alice ##> "/_send @2 json {\"msgContent\":{\"type\":\"voice\", \"duration\":10, \"text\":\"\"}, \"filePath\":\"./tests/fixtures/test.jpg\"}"
alice <# "@bob voice message (00:10)"
alice <# "/f @bob ./tests/fixtures/test.jpg"
-- below is not shown in "sent" mode
-- alice <## "use /fc 1 to cancel sending"
bob <# "alice> voice message (00:10)"
bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
-- below is not shown in "sent" mode
-- bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
@ -1617,18 +1620,21 @@ testSmallInlineFileTransfer =
connectUsers alice bob
bob ##> "/_files_folder ./tests/tmp/"
bob <## "ok"
alice #> "/f @bob ./tests/fixtures/test.txt"
alice ##> "/_send @2 json {\"msgContent\":{\"type\":\"voice\", \"duration\":10, \"text\":\"\"}, \"filePath\":\"./tests/fixtures/logo.jpg\"}"
alice <# "@bob voice message (00:10)"
alice <# "/f @bob ./tests/fixtures/logo.jpg"
-- below is not shown in "sent" mode
-- alice <## "use /fc 1 to cancel sending"
bob <# "alice> sends file test.txt (11 bytes / 11 bytes)"
bob <# "alice> voice message (00:10)"
bob <# "alice> sends file logo.jpg (31.3 KiB / 32080 bytes)"
-- below is not shown in "sent" mode
-- bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
bob <## "started receiving file 1 (test.txt) from alice"
bob <## "started receiving file 1 (logo.jpg) from alice"
concurrently_
(alice <## "completed sending file 1 (test.txt) to bob")
(bob <## "completed receiving file 1 (test.txt) from alice")
src <- B.readFile "./tests/fixtures/test.txt"
dest <- B.readFile "./tests/tmp/test.txt"
(alice <## "completed sending file 1 (logo.jpg) to bob")
(bob <## "completed receiving file 1 (logo.jpg) from alice")
src <- B.readFile "./tests/fixtures/logo.jpg"
dest <- B.readFile "./tests/tmp/logo.jpg"
dest `shouldBe` src
testReceiveInline :: IO ()
@ -1791,29 +1797,33 @@ testInlineGroupFileTransfer =
bob <## "ok"
cath ##> "/_files_folder ./tests/tmp/cath/"
cath <## "ok"
alice #> "/f #team ./tests/fixtures/test.jpg"
alice ##> "/_send #1 json {\"msgContent\":{\"type\":\"voice\", \"duration\":10, \"text\":\"\"}, \"filePath\":\"./tests/fixtures/logo.jpg\"}"
alice <# "#team voice message (00:10)"
alice <# "/f #team ./tests/fixtures/logo.jpg"
-- below is not shown in "sent" mode
-- alice <## "use /fc 1 to cancel sending"
concurrentlyN_
[ do
alice
<### [ "completed sending file 1 (test.jpg) to bob",
"completed sending file 1 (test.jpg) to cath"
<### [ "completed sending file 1 (logo.jpg) to bob",
"completed sending file 1 (logo.jpg) to cath"
]
alice ##> "/fs 1"
alice <##. "sending file 1 (test.jpg) complete",
alice <##. "sending file 1 (logo.jpg) complete",
do
bob <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
bob <## "started receiving file 1 (test.jpg) from alice"
bob <## "completed receiving file 1 (test.jpg) from alice",
bob <# "#team alice> voice message (00:10)"
bob <# "#team alice> sends file logo.jpg (31.3 KiB / 32080 bytes)"
bob <## "started receiving file 1 (logo.jpg) from alice"
bob <## "completed receiving file 1 (logo.jpg) from alice",
do
cath <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
cath <## "started receiving file 1 (test.jpg) from alice"
cath <## "completed receiving file 1 (test.jpg) from alice"
cath <# "#team alice> voice message (00:10)"
cath <# "#team alice> sends file logo.jpg (31.3 KiB / 32080 bytes)"
cath <## "started receiving file 1 (logo.jpg) from alice"
cath <## "completed receiving file 1 (logo.jpg) from alice"
]
src <- B.readFile "./tests/fixtures/test.jpg"
dest1 <- B.readFile "./tests/tmp/bob/test.jpg"
dest2 <- B.readFile "./tests/tmp/cath/test.jpg"
src <- B.readFile "./tests/fixtures/logo.jpg"
dest1 <- B.readFile "./tests/tmp/bob/logo.jpg"
dest2 <- B.readFile "./tests/tmp/cath/logo.jpg"
dest1 `shouldBe` src
dest2 `shouldBe` src
where
@ -1828,29 +1838,33 @@ testSmallInlineGroupFileTransfer =
bob <## "ok"
cath ##> "/_files_folder ./tests/tmp/cath/"
cath <## "ok"
alice #> "/f #team ./tests/fixtures/test.txt"
alice ##> "/_send #1 json {\"msgContent\":{\"type\":\"voice\", \"duration\":10, \"text\":\"\"}, \"filePath\":\"./tests/fixtures/logo.jpg\"}"
alice <# "#team voice message (00:10)"
alice <# "/f #team ./tests/fixtures/logo.jpg"
-- below is not shown in "sent" mode
-- alice <## "use /fc 1 to cancel sending"
concurrentlyN_
[ do
alice
<### [ "completed sending file 1 (test.txt) to bob",
"completed sending file 1 (test.txt) to cath"
<### [ "completed sending file 1 (logo.jpg) to bob",
"completed sending file 1 (logo.jpg) to cath"
]
alice ##> "/fs 1"
alice <##. "sending file 1 (test.txt) complete",
alice <##. "sending file 1 (logo.jpg) complete",
do
bob <# "#team alice> sends file test.txt (11 bytes / 11 bytes)"
bob <## "started receiving file 1 (test.txt) from alice"
bob <## "completed receiving file 1 (test.txt) from alice",
bob <# "#team alice> voice message (00:10)"
bob <# "#team alice> sends file logo.jpg (31.3 KiB / 32080 bytes)"
bob <## "started receiving file 1 (logo.jpg) from alice"
bob <## "completed receiving file 1 (logo.jpg) from alice",
do
cath <# "#team alice> sends file test.txt (11 bytes / 11 bytes)"
cath <## "started receiving file 1 (test.txt) from alice"
cath <## "completed receiving file 1 (test.txt) from alice"
cath <# "#team alice> voice message (00:10)"
cath <# "#team alice> sends file logo.jpg (31.3 KiB / 32080 bytes)"
cath <## "started receiving file 1 (logo.jpg) from alice"
cath <## "completed receiving file 1 (logo.jpg) from alice"
]
src <- B.readFile "./tests/fixtures/test.txt"
dest1 <- B.readFile "./tests/tmp/bob/test.txt"
dest2 <- B.readFile "./tests/tmp/cath/test.txt"
src <- B.readFile "./tests/fixtures/logo.jpg"
dest1 <- B.readFile "./tests/tmp/bob/logo.jpg"
dest2 <- B.readFile "./tests/tmp/cath/logo.jpg"
dest1 `shouldBe` src
dest2 `shouldBe` src

BIN
tests/fixtures/logo.jpg vendored Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 31 KiB