cli: option to auto-accept files (#2540)

* cli: option to auto-accept files

* auto-accept works

* test

* add missing field
This commit is contained in:
Evgeny Poberezkin
2023-06-16 13:43:06 +01:00
committed by GitHub
parent c29c3179a0
commit 46c6f5e615
6 changed files with 60 additions and 9 deletions
+17 -9
View File
@@ -112,6 +112,7 @@ defaultChatConfig =
fileChunkSize = 15780, -- do not change
xftpDescrPartSize = 14000,
inlineFiles = defaultInlineFilesConfig,
autoAcceptFileSize = 0,
xftpFileConfig = Just defaultXFTPFileConfig,
tempDir = Nothing,
showReactions = False,
@@ -158,9 +159,9 @@ createChatDatabase filePrefix key confirmMigrations = runExceptT $ 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, defaultServers, inlineFiles, tempDir} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize}, optFilesFolder, showReactions, allowInstantFiles} sendToast = do
let inlineFiles' = if allowInstantFiles then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles'}
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, tempDir} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize}, optFilesFolder, showReactions, allowInstantFiles, autoAcceptFileSize} sendToast = do
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize}
sendNotification = fromMaybe (const $ pure ()) sendToast
firstTime = dbNew chatStore
activeTo <- newTVarIO ActiveNone
@@ -3332,8 +3333,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc
timed_ = rcvContactCITimed ct itemTTL
live = fromMaybe False live_
ciFile_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) ciFile_ timed_ live
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
autoAcceptFile file_
whenContactNtfs user ct $ do
showMsgToast (c <> "> ") content formattedText
setActive $ ActiveC c
@@ -3344,6 +3346,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions})
pure ci
autoAcceptFile :: Maybe (RcvFileTransfer, CIFile 'MDRcv) -> m ()
autoAcceptFile = mapM_ $ \(ft, CIFile {fileSize}) -> do
ChatConfig {autoAcceptFileSize = sz} <- asks config
when (sz > fileSize) $ receiveFile' user ft Nothing Nothing >>= toView
messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> MsgMeta -> m ()
messageFileDescription ct@Contact {contactId} sharedMsgId fileDescr msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
@@ -3380,7 +3387,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
cancelGroupMessageFile _gInfo _m _sharedMsgId _msgMeta = do
pure ()
processFileInvitation :: Maybe FileInvitation -> MsgContent -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer) -> m (Maybe (CIFile 'MDRcv))
processFileInvitation :: Maybe FileInvitation -> MsgContent -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer) -> m (Maybe (RcvFileTransfer, CIFile 'MDRcv))
processFileInvitation fInv_ mc createRcvFT = forM fInv_ $ \fInv@FileInvitation {fileName, fileSize} -> do
ChatConfig {fileChunkSize} <- asks config
inline <- receiveInlineMode fInv (Just mc) fileChunkSize
@@ -3392,7 +3399,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
withStore' $ \db -> startRcvInlineFT db user ft fPath inline
pure (Just fPath, CIFSRcvAccepted)
_ -> pure (Nothing, CIFSRcvInvitation)
pure CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol}
pure (ft, CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol})
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m ()
messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
@@ -3503,8 +3510,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc
timed_ = rcvGroupCITimed gInfo itemTTL
live = fromMaybe False live_
ciFile_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) ciFile_ timed_ live
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
autoAcceptFile file_
let g = groupName' gInfo
whenGroupNtfs user gInfo $ do
showMsgToast ("#" <> g <> " " <> c <> "> ") content formattedText