mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-06-29 04:39:53 +00:00
core: support encrypted local files (#2989)
* core: support encrypted local files * add migration * update agent api, chat api * fix query, exported functions to read/write files * update simplexmq * remove formatting changes * test, fix file size * reduce diff Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> * fail when receiving SMP files with local encryption * update simplexmq * remove style changes --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
parent
1c90eb0a2e
commit
0b214acf97
22 changed files with 390 additions and 147 deletions
|
@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
|
||||||
source-repository-package
|
source-repository-package
|
||||||
type: git
|
type: git
|
||||||
location: https://github.com/simplex-chat/simplexmq.git
|
location: https://github.com/simplex-chat/simplexmq.git
|
||||||
tag: 4c0b8a31d20870a23e120e243359901d8240f922
|
tag: 5dc3d739b206edc2b4706ba0eef64ad4492e68e6
|
||||||
|
|
||||||
source-repository-package
|
source-repository-package
|
||||||
type: git
|
type: git
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
{
|
{
|
||||||
"https://github.com/simplex-chat/simplexmq.git"."4c0b8a31d20870a23e120e243359901d8240f922" = "0lrgfm8di0x4rmidqp7k2fw29yaal6467nmb85lwk95yz602906z";
|
"https://github.com/simplex-chat/simplexmq.git"."5dc3d739b206edc2b4706ba0eef64ad4492e68e6" = "0nzp0ijmw7ppmzjj72hf0b8jkyg8lwwy92hc1649xk3hnrj48wfz";
|
||||||
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
|
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
|
||||||
"https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
|
"https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
|
||||||
"https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";
|
"https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.35.0.
|
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
|
@ -10,7 +10,7 @@ category: Web, System, Services, Cryptography
|
||||||
homepage: https://github.com/simplex-chat/simplex-chat#readme
|
homepage: https://github.com/simplex-chat/simplex-chat#readme
|
||||||
author: simplex.chat
|
author: simplex.chat
|
||||||
maintainer: chat@simplex.chat
|
maintainer: chat@simplex.chat
|
||||||
copyright: 2020-23 simplex.chat
|
copyright: 2020-22 simplex.chat
|
||||||
license: AGPL-3
|
license: AGPL-3
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
|
@ -108,7 +108,10 @@ library
|
||||||
Simplex.Chat.Migrations.M20230705_delivery_receipts
|
Simplex.Chat.Migrations.M20230705_delivery_receipts
|
||||||
Simplex.Chat.Migrations.M20230721_group_snd_item_statuses
|
Simplex.Chat.Migrations.M20230721_group_snd_item_statuses
|
||||||
Simplex.Chat.Migrations.M20230814_indexes
|
Simplex.Chat.Migrations.M20230814_indexes
|
||||||
|
Simplex.Chat.Migrations.M20230827_file_encryption
|
||||||
Simplex.Chat.Mobile
|
Simplex.Chat.Mobile
|
||||||
|
Simplex.Chat.Mobile.File
|
||||||
|
Simplex.Chat.Mobile.Shared
|
||||||
Simplex.Chat.Mobile.WebRTC
|
Simplex.Chat.Mobile.WebRTC
|
||||||
Simplex.Chat.Options
|
Simplex.Chat.Options
|
||||||
Simplex.Chat.ProfileGenerator
|
Simplex.Chat.ProfileGenerator
|
||||||
|
|
|
@ -1,4 +1,3 @@
|
||||||
{-# LANGUAGE BangPatterns #-}
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
@ -86,6 +85,8 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||||
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
|
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
|
||||||
import Simplex.Messaging.Client (defaultNetworkConfig)
|
import Simplex.Messaging.Client (defaultNetworkConfig)
|
||||||
import qualified Simplex.Messaging.Crypto as C
|
import qualified Simplex.Messaging.Crypto as C
|
||||||
|
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||||
|
import qualified Simplex.Messaging.Crypto.File as CF
|
||||||
import Simplex.Messaging.Encoding
|
import Simplex.Messaging.Encoding
|
||||||
import Simplex.Messaging.Encoding.String
|
import Simplex.Messaging.Encoding.String
|
||||||
import Simplex.Messaging.Parsers (base64P)
|
import Simplex.Messaging.Parsers (base64P)
|
||||||
|
@ -562,8 +563,9 @@ processChatCommand = \case
|
||||||
SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline
|
SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline
|
||||||
SendFileXFTP -> xftpSndFileTransfer user file fileSize 1 $ CGContact ct
|
SendFileXFTP -> xftpSndFileTransfer user file fileSize 1 $ CGContact ct
|
||||||
where
|
where
|
||||||
smpSndFileTransfer :: FilePath -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
smpSndFileTransfer :: CryptoFile -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||||
smpSndFileTransfer file fileSize fileInline = do
|
smpSndFileTransfer (CryptoFile _ (Just _)) _ _ = throwChatError $ CEFileInternal "locally encrypted files can't be sent via SMP" -- can only happen if XFTP is disabled
|
||||||
|
smpSndFileTransfer (CryptoFile file Nothing) fileSize fileInline = do
|
||||||
(agentConnId_, fileConnReq) <-
|
(agentConnId_, fileConnReq) <-
|
||||||
if isJust fileInline
|
if isJust fileInline
|
||||||
then pure (Nothing, Nothing)
|
then pure (Nothing, Nothing)
|
||||||
|
@ -576,7 +578,8 @@ processChatCommand = \case
|
||||||
fileStatus <- case fileInline of
|
fileStatus <- case fileInline of
|
||||||
Just IFMSent -> createSndDirectInlineFT db ct ft $> CIFSSndTransfer 0 1
|
Just IFMSent -> createSndDirectInlineFT db ct ft $> CIFSSndTransfer 0 1
|
||||||
_ -> pure CIFSSndStored
|
_ -> pure CIFSSndStored
|
||||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus, fileProtocol = FPSMP}
|
let fileSource = Just $ CF.plain file
|
||||||
|
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol = FPSMP}
|
||||||
pure (fileInvitation, ciFile, ft)
|
pure (fileInvitation, ciFile, ft)
|
||||||
prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> m (MsgContainer, Maybe (CIQuote 'CTDirect))
|
prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> m (MsgContainer, Maybe (CIQuote 'CTDirect))
|
||||||
prepareMsg fInv_ timed_ = case quotedItemId_ of
|
prepareMsg fInv_ timed_ = case quotedItemId_ of
|
||||||
|
@ -625,15 +628,17 @@ processChatCommand = \case
|
||||||
SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline
|
SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline
|
||||||
SendFileXFTP -> xftpSndFileTransfer user file fileSize n $ CGGroup g
|
SendFileXFTP -> xftpSndFileTransfer user file fileSize n $ CGGroup g
|
||||||
where
|
where
|
||||||
smpSndFileTransfer :: FilePath -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
smpSndFileTransfer :: CryptoFile -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||||
smpSndFileTransfer file fileSize fileInline = do
|
smpSndFileTransfer (CryptoFile _ (Just _)) _ _ = throwChatError $ CEFileInternal "locally encrypted files can't be sent via SMP" -- can only happen if XFTP is disabled
|
||||||
|
smpSndFileTransfer (CryptoFile file Nothing) fileSize fileInline = do
|
||||||
let fileName = takeFileName file
|
let fileName = takeFileName file
|
||||||
fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline, fileDescr = Nothing}
|
fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline, fileDescr = Nothing}
|
||||||
fileStatus = if fileInline == Just IFMSent then CIFSSndTransfer 0 1 else CIFSSndStored
|
fileStatus = if fileInline == Just IFMSent then CIFSSndTransfer 0 1 else CIFSSndStored
|
||||||
chSize <- asks $ fileChunkSize . config
|
chSize <- asks $ fileChunkSize . config
|
||||||
withStore' $ \db -> do
|
withStore' $ \db -> do
|
||||||
ft@FileTransferMeta {fileId} <- createSndGroupFileTransfer db userId gInfo file fileInvitation chSize
|
ft@FileTransferMeta {fileId} <- createSndGroupFileTransfer db userId gInfo file fileInvitation chSize
|
||||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus, fileProtocol = FPSMP}
|
let fileSource = Just $ CF.plain file
|
||||||
|
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol = FPSMP}
|
||||||
pure (fileInvitation, ciFile, ft)
|
pure (fileInvitation, ciFile, ft)
|
||||||
sendGroupFileInline :: [GroupMember] -> SharedMsgId -> FileTransferMeta -> m ()
|
sendGroupFileInline :: [GroupMember] -> SharedMsgId -> FileTransferMeta -> m ()
|
||||||
sendGroupFileInline ms sharedMsgId ft@FileTransferMeta {fileInline} =
|
sendGroupFileInline ms sharedMsgId ft@FileTransferMeta {fileInline} =
|
||||||
|
@ -688,17 +693,19 @@ processChatCommand = \case
|
||||||
qText = msgContentText qmc
|
qText = msgContentText qmc
|
||||||
qFileName = maybe qText (T.pack . (fileName :: CIFile d -> String)) ciFile_
|
qFileName = maybe qText (T.pack . (fileName :: CIFile d -> String)) ciFile_
|
||||||
qTextOrFile = if T.null qText then qFileName else qText
|
qTextOrFile = if T.null qText then qFileName else qText
|
||||||
xftpSndFileTransfer :: User -> FilePath -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||||
xftpSndFileTransfer user file fileSize n contactOrGroup = do
|
xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do
|
||||||
let fileName = takeFileName file
|
let fileName = takeFileName filePath
|
||||||
fileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
|
fileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
|
||||||
fInv = xftpFileInvitation fileName fileSize fileDescr
|
fInv = xftpFileInvitation fileName fileSize fileDescr
|
||||||
fsFilePath <- toFSFilePath file
|
fsFilePath <- toFSFilePath filePath
|
||||||
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) fsFilePath (roundedFDCount n)
|
let srcFile = CryptoFile fsFilePath cfArgs
|
||||||
|
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n)
|
||||||
-- TODO CRSndFileStart event for XFTP
|
-- TODO CRSndFileStart event for XFTP
|
||||||
chSize <- asks $ fileChunkSize . config
|
chSize <- asks $ fileChunkSize . config
|
||||||
ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup file fInv (AgentSndFileId aFileId) chSize
|
ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup file fInv (AgentSndFileId aFileId) chSize
|
||||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored, fileProtocol = FPXFTP}
|
let fileSource = Just $ CryptoFile filePath cfArgs
|
||||||
|
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP}
|
||||||
case contactOrGroup of
|
case contactOrGroup of
|
||||||
CGContact Contact {activeConn} -> withStore' $ \db -> createSndFTDescrXFTP db user Nothing activeConn ft fileDescr
|
CGContact Contact {activeConn} -> withStore' $ \db -> createSndFTDescrXFTP db user Nothing activeConn ft fileDescr
|
||||||
CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user))
|
CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user))
|
||||||
|
@ -1613,26 +1620,40 @@ processChatCommand = \case
|
||||||
asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_
|
asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_
|
||||||
SendFile chatName f -> withUser $ \user -> do
|
SendFile chatName f -> withUser $ \user -> do
|
||||||
chatRef <- getChatRef user chatName
|
chatRef <- getChatRef user chatName
|
||||||
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCFile "")
|
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCFile "")
|
||||||
SendImage chatName f -> withUser $ \user -> do
|
SendImage chatName f -> withUser $ \user -> do
|
||||||
chatRef <- getChatRef user chatName
|
chatRef <- getChatRef user chatName
|
||||||
filePath <- toFSFilePath f
|
filePath <- toFSFilePath f
|
||||||
unless (any ((`isSuffixOf` map toLower f)) imageExtensions) $ throwChatError CEFileImageType {filePath}
|
unless (any (`isSuffixOf` map toLower f) imageExtensions) $ throwChatError CEFileImageType {filePath}
|
||||||
fileSize <- getFileSize filePath
|
fileSize <- getFileSize filePath
|
||||||
unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
|
unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
|
||||||
-- TODO include file description for preview
|
-- TODO include file description for preview
|
||||||
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCImage "" fixedImagePreview)
|
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCImage "" fixedImagePreview)
|
||||||
ForwardFile chatName fileId -> forwardFile chatName fileId SendFile
|
ForwardFile chatName fileId -> forwardFile chatName fileId SendFile
|
||||||
ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
|
ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
|
||||||
SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO"
|
SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO"
|
||||||
ReceiveFile fileId rcvInline_ filePath_ -> withUser $ \_ ->
|
ReceiveFile fileId encrypted rcvInline_ filePath_ -> withUser $ \_ ->
|
||||||
withChatLock "receiveFile" . procCmd $ do
|
withChatLock "receiveFile" . procCmd $ do
|
||||||
(user, ft) <- withStore $ \db -> getRcvFileTransferById db fileId
|
(user, ft) <- withStore (`getRcvFileTransferById` fileId)
|
||||||
receiveFile' user ft rcvInline_ filePath_
|
ft' <- if encrypted then encryptLocalFile ft else pure ft
|
||||||
SetFileToReceive fileId -> withUser $ \_ -> do
|
receiveFile' user ft' rcvInline_ filePath_
|
||||||
|
where
|
||||||
|
encryptLocalFile ft@RcvFileTransfer {xftpRcvFile} = case xftpRcvFile of
|
||||||
|
Nothing -> throwChatError $ CEFileInternal "locally encrypted files can't be received via SMP"
|
||||||
|
Just f -> do
|
||||||
|
cfArgs <- liftIO $ CF.randomArgs
|
||||||
|
withStore' $ \db -> setFileCryptoArgs db fileId cfArgs
|
||||||
|
pure ft {xftpRcvFile = Just ((f :: XFTPRcvFile) {cryptoArgs = Just cfArgs})}
|
||||||
|
SetFileToReceive fileId encrypted -> withUser $ \_ -> do
|
||||||
withChatLock "setFileToReceive" . procCmd $ do
|
withChatLock "setFileToReceive" . procCmd $ do
|
||||||
withStore' (`setRcvFileToReceive` fileId)
|
cfArgs <- if encrypted then fileCryptoArgs else pure Nothing
|
||||||
|
withStore' $ \db -> setRcvFileToReceive db fileId cfArgs
|
||||||
ok_
|
ok_
|
||||||
|
where
|
||||||
|
fileCryptoArgs = do
|
||||||
|
(_, RcvFileTransfer {xftpRcvFile = f}) <- withStore (`getRcvFileTransferById` fileId)
|
||||||
|
unless (isJust f) $ throwChatError $ CEFileInternal "locally encrypted files can't be received via SMP"
|
||||||
|
liftIO $ Just <$> CF.randomArgs
|
||||||
CancelFile fileId -> withUser $ \user@User {userId} ->
|
CancelFile fileId -> withUser $ \user@User {userId} ->
|
||||||
withChatLock "cancelFile" . procCmd $
|
withChatLock "cancelFile" . procCmd $
|
||||||
withStore (\db -> getFileTransfer db user fileId) >>= \case
|
withStore (\db -> getFileTransfer db user fileId) >>= \case
|
||||||
|
@ -1829,18 +1850,19 @@ processChatCommand = \case
|
||||||
contactMember Contact {contactId} =
|
contactMember Contact {contactId} =
|
||||||
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
|
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
|
||||||
cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft
|
cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft
|
||||||
checkSndFile :: MsgContent -> FilePath -> Integer -> m (Integer, SendFileMode)
|
checkSndFile :: MsgContent -> CryptoFile -> Integer -> m (Integer, SendFileMode)
|
||||||
checkSndFile mc f n = do
|
checkSndFile mc (CryptoFile f cfArgs) n = do
|
||||||
fsFilePath <- toFSFilePath f
|
fsFilePath <- toFSFilePath f
|
||||||
unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f
|
unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f
|
||||||
ChatConfig {fileChunkSize, inlineFiles} <- asks config
|
ChatConfig {fileChunkSize, inlineFiles} <- asks config
|
||||||
xftpCfg <- readTVarIO =<< asks userXFTPFileConfig
|
xftpCfg <- readTVarIO =<< asks userXFTPFileConfig
|
||||||
fileSize <- getFileSize fsFilePath
|
fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cfArgs
|
||||||
when (fromInteger fileSize > maxFileSize) $ throwChatError $ CEFileSize f
|
when (fromInteger fileSize > maxFileSize) $ throwChatError $ CEFileSize f
|
||||||
let chunks = - ((- fileSize) `div` fileChunkSize)
|
let chunks = -((-fileSize) `div` fileChunkSize)
|
||||||
fileInline = inlineFileMode mc inlineFiles chunks n
|
fileInline = inlineFileMode mc inlineFiles chunks n
|
||||||
fileMode = case xftpCfg of
|
fileMode = case xftpCfg of
|
||||||
Just cfg
|
Just cfg
|
||||||
|
| isJust cfArgs -> SendFileXFTP
|
||||||
| fileInline == Just IFMSent || fileSize < minFileSize cfg || n <= 0 -> SendFileSMP fileInline
|
| fileInline == Just IFMSent || fileSize < minFileSize cfg || n <= 0 -> SendFileSMP fileInline
|
||||||
| otherwise -> SendFileXFTP
|
| otherwise -> SendFileXFTP
|
||||||
_ -> SendFileSMP fileInline
|
_ -> SendFileSMP fileInline
|
||||||
|
@ -1867,17 +1889,17 @@ processChatCommand = \case
|
||||||
summary <- foldM (processAndCount user' logLevel) (UserProfileUpdateSummary 0 0 0 []) contacts
|
summary <- foldM (processAndCount user' logLevel) (UserProfileUpdateSummary 0 0 0 []) contacts
|
||||||
pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary
|
pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary
|
||||||
where
|
where
|
||||||
processAndCount user' ll (!s@UserProfileUpdateSummary {notChanged, updateSuccesses, updateFailures, changedContacts = cts}) ct = do
|
processAndCount user' ll s@UserProfileUpdateSummary {notChanged, updateSuccesses, updateFailures, changedContacts = cts} ct = do
|
||||||
let mergedProfile = userProfileToSend user Nothing $ Just ct
|
let mergedProfile = userProfileToSend user Nothing $ Just ct
|
||||||
ct' = updateMergedPreferences user' ct
|
ct' = updateMergedPreferences user' ct
|
||||||
mergedProfile' = userProfileToSend user' Nothing $ Just ct'
|
mergedProfile' = userProfileToSend user' Nothing $ Just ct'
|
||||||
if mergedProfile' == mergedProfile
|
if mergedProfile' == mergedProfile
|
||||||
then pure s {notChanged = notChanged + 1}
|
then pure s {notChanged = notChanged + 1}
|
||||||
else
|
else
|
||||||
let cts' = if mergedPreferences ct == mergedPreferences ct' then cts else ct' : cts
|
let cts' = if mergedPreferences ct == mergedPreferences ct' then cts else ct' : cts
|
||||||
in (notifyContact mergedProfile' ct' $> s {updateSuccesses = updateSuccesses + 1, changedContacts = cts'})
|
in (notifyContact mergedProfile' ct' $> s {updateSuccesses = updateSuccesses + 1, changedContacts = cts'})
|
||||||
`catchChatError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> s {updateFailures = updateFailures + 1, changedContacts = cts'}
|
`catchChatError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> s {updateFailures = updateFailures + 1, changedContacts = cts'}
|
||||||
where
|
where
|
||||||
notifyContact mergedProfile' ct' = do
|
notifyContact mergedProfile' ct' = do
|
||||||
void $ sendDirectContactMessage ct' (XInfo mergedProfile')
|
void $ sendDirectContactMessage ct' (XInfo mergedProfile')
|
||||||
when (directOrUsed ct') $ createSndFeatureItems user' ct ct'
|
when (directOrUsed ct') $ createSndFeatureItems user' ct ct'
|
||||||
|
@ -2214,7 +2236,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||||
filePath <- getRcvFilePath fileId filePath_ fName True
|
filePath <- getRcvFilePath fileId filePath_ fName True
|
||||||
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath
|
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath
|
||||||
-- XFTP
|
-- XFTP
|
||||||
(Just _xftpRcvFile, _) -> do
|
(Just XFTPRcvFile {cryptoArgs}, _) -> do
|
||||||
filePath <- getRcvFilePath fileId filePath_ fName False
|
filePath <- getRcvFilePath fileId filePath_ fName False
|
||||||
(ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do
|
(ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do
|
||||||
-- marking file as accepted and reading description in the same transaction
|
-- marking file as accepted and reading description in the same transaction
|
||||||
|
@ -2222,7 +2244,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||||
ci <- xftpAcceptRcvFT db user fileId filePath
|
ci <- xftpAcceptRcvFT db user fileId filePath
|
||||||
rfd <- getRcvFileDescrByFileId db fileId
|
rfd <- getRcvFileDescrByFileId db fileId
|
||||||
pure (ci, rfd)
|
pure (ci, rfd)
|
||||||
receiveViaCompleteFD user fileId rfd
|
receiveViaCompleteFD user fileId rfd cryptoArgs
|
||||||
pure ci
|
pure ci
|
||||||
-- group & direct file protocol
|
-- group & direct file protocol
|
||||||
_ -> do
|
_ -> do
|
||||||
|
@ -2265,11 +2287,11 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||||
|| (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks)
|
|| (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks)
|
||||||
)
|
)
|
||||||
|
|
||||||
receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> RcvFileDescr -> m ()
|
receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> RcvFileDescr -> Maybe CryptoFileArgs -> m ()
|
||||||
receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} =
|
receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} cfArgs =
|
||||||
when fileDescrComplete $ do
|
when fileDescrComplete $ do
|
||||||
rd <- parseFileDescription fileDescrText
|
rd <- parseFileDescription fileDescrText
|
||||||
aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd
|
aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd cfArgs
|
||||||
startReceivingFile user fileId
|
startReceivingFile user fileId
|
||||||
withStoreCtx' (Just "receiveViaCompleteFD, updateRcvFileAgentId") $ \db -> updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId)
|
withStoreCtx' (Just "receiveViaCompleteFD, updateRcvFileAgentId") $ \db -> updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId)
|
||||||
|
|
||||||
|
@ -2535,7 +2557,7 @@ cleanupManager = do
|
||||||
`catchChatError` (toView . CRChatError (Just user))
|
`catchChatError` (toView . CRChatError (Just user))
|
||||||
cleanupMessages = do
|
cleanupMessages = do
|
||||||
ts <- liftIO getCurrentTime
|
ts <- liftIO getCurrentTime
|
||||||
let cutoffTs = addUTCTime (- (30 * nominalDay)) ts
|
let cutoffTs = addUTCTime (-(30 * nominalDay)) ts
|
||||||
withStoreCtx' (Just "cleanupManager, deleteOldMessages") (`deleteOldMessages` cutoffTs)
|
withStoreCtx' (Just "cleanupManager, deleteOldMessages") (`deleteOldMessages` cutoffTs)
|
||||||
|
|
||||||
startProximateTimedItemThread :: ChatMonad m => User -> (ChatRef, ChatItemId) -> UTCTime -> m ()
|
startProximateTimedItemThread :: ChatMonad m => User -> (ChatRef, ChatItemId) -> UTCTime -> m ()
|
||||||
|
@ -3567,14 +3589,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||||
processFDMessage fileId fileDescr = do
|
processFDMessage fileId fileDescr = do
|
||||||
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
|
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
|
||||||
unless (rcvFileCompleteOrCancelled ft) $ do
|
unless (rcvFileCompleteOrCancelled ft) $ do
|
||||||
(rfd, RcvFileTransfer {fileStatus}) <- withStore $ \db -> do
|
(rfd, RcvFileTransfer {fileStatus, xftpRcvFile}) <- withStore $ \db -> do
|
||||||
rfd <- appendRcvFD db userId fileId fileDescr
|
rfd <- appendRcvFD db userId fileId fileDescr
|
||||||
-- reading second time in the same transaction as appending description
|
-- reading second time in the same transaction as appending description
|
||||||
-- to prevent race condition with accept
|
-- to prevent race condition with accept
|
||||||
ft' <- getRcvFileTransfer db user fileId
|
ft' <- getRcvFileTransfer db user fileId
|
||||||
pure (rfd, ft')
|
pure (rfd, ft')
|
||||||
case fileStatus of
|
case (fileStatus, xftpRcvFile) of
|
||||||
RFSAccepted _ -> receiveViaCompleteFD user fileId rfd
|
(RFSAccepted _, Just XFTPRcvFile {cryptoArgs}) -> receiveViaCompleteFD user fileId rfd cryptoArgs
|
||||||
_ -> pure ()
|
_ -> pure ()
|
||||||
|
|
||||||
cancelMessageFile :: Contact -> SharedMsgId -> MsgMeta -> m ()
|
cancelMessageFile :: Contact -> SharedMsgId -> MsgMeta -> m ()
|
||||||
|
@ -3600,7 +3622,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||||
withStore' $ \db -> startRcvInlineFT db user ft fPath inline
|
withStore' $ \db -> startRcvInlineFT db user ft fPath inline
|
||||||
pure (Just fPath, CIFSRcvAccepted)
|
pure (Just fPath, CIFSRcvAccepted)
|
||||||
_ -> pure (Nothing, CIFSRcvInvitation)
|
_ -> pure (Nothing, CIFSRcvInvitation)
|
||||||
pure (ft, CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol})
|
let fileSource = CF.plain <$> filePath
|
||||||
|
pure (ft, CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol})
|
||||||
|
|
||||||
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m ()
|
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
|
messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
|
||||||
|
@ -3817,7 +3840,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||||
inline <- receiveInlineMode fInv Nothing fileChunkSize
|
inline <- receiveInlineMode fInv Nothing fileChunkSize
|
||||||
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv inline fileChunkSize
|
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv inline fileChunkSize
|
||||||
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
||||||
ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
|
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
|
||||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
|
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
|
||||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
|
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
|
||||||
whenContactNtfs user ct $ do
|
whenContactNtfs user ct $ do
|
||||||
|
@ -3831,7 +3854,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||||
inline <- receiveInlineMode fInv Nothing fileChunkSize
|
inline <- receiveInlineMode fInv Nothing fileChunkSize
|
||||||
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
|
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
|
||||||
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
||||||
ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
|
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
|
||||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
|
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
|
||||||
groupMsgToView gInfo m ci msgMeta
|
groupMsgToView gInfo m ci msgMeta
|
||||||
let g = groupName' gInfo
|
let g = groupName' gInfo
|
||||||
|
@ -4737,10 +4760,9 @@ deleteGroupCI user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUse
|
||||||
pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi byUser timed
|
pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi byUser timed
|
||||||
|
|
||||||
deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
|
deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
|
||||||
deleteCIFile user file =
|
deleteCIFile user file_ =
|
||||||
forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do
|
forM_ file_ $ \file -> do
|
||||||
let fileInfo = CIFileInfo {fileId, fileStatus = Just $ AFS msgDirection fileStatus, filePath}
|
fileAgentConnIds <- deleteFile' user (mkCIFileInfo file) True
|
||||||
fileAgentConnIds <- deleteFile' user fileInfo True
|
|
||||||
deleteAgentConnectionsAsync user fileAgentConnIds
|
deleteAgentConnectionsAsync user fileAgentConnIds
|
||||||
|
|
||||||
markDirectCIDeleted :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> MessageId -> Bool -> UTCTime -> m ChatResponse
|
markDirectCIDeleted :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> MessageId -> Bool -> UTCTime -> m ChatResponse
|
||||||
|
@ -4764,10 +4786,9 @@ markGroupCIDeleted user gInfo@GroupInfo {groupId} ci@(CChatItem _ ChatItem {file
|
||||||
gItem (CChatItem msgDir ci') = AChatItem SCTGroup msgDir (GroupChat gInfo) ci'
|
gItem (CChatItem msgDir ci') = AChatItem SCTGroup msgDir (GroupChat gInfo) ci'
|
||||||
|
|
||||||
cancelCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
|
cancelCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
|
||||||
cancelCIFile user file =
|
cancelCIFile user file_ =
|
||||||
forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do
|
forM_ file_ $ \file -> do
|
||||||
let fileInfo = CIFileInfo {fileId, fileStatus = Just $ AFS msgDirection fileStatus, filePath}
|
fileAgentConnIds <- cancelFile' user (mkCIFileInfo file) True
|
||||||
fileAgentConnIds <- cancelFile' user fileInfo True
|
|
||||||
deleteAgentConnectionsAsync user fileAgentConnIds
|
deleteAgentConnectionsAsync user fileAgentConnIds
|
||||||
|
|
||||||
createAgentConnectionAsync :: forall m c. (ChatMonad m, ConnectionModeI c) => User -> CommandFunction -> Bool -> SConnectionMode c -> m (CommandId, ConnId)
|
createAgentConnectionAsync :: forall m c. (ChatMonad m, ConnectionModeI c) => User -> CommandFunction -> Bool -> SConnectionMode c -> m (CommandId, ConnId)
|
||||||
|
@ -5000,7 +5021,7 @@ withAgent :: ChatMonad m => (AgentClient -> ExceptT AgentErrorType m a) -> m a
|
||||||
withAgent action =
|
withAgent action =
|
||||||
asks smpAgent
|
asks smpAgent
|
||||||
>>= runExceptT . action
|
>>= runExceptT . action
|
||||||
>>= liftEither . first (\e -> ChatErrorAgent e Nothing)
|
>>= liftEither . first (`ChatErrorAgent` Nothing)
|
||||||
|
|
||||||
withStore' :: ChatMonad m => (DB.Connection -> IO a) -> m a
|
withStore' :: ChatMonad m => (DB.Connection -> IO a) -> m a
|
||||||
withStore' action = withStore $ liftIO . action
|
withStore' action = withStore $ liftIO . action
|
||||||
|
@ -5235,8 +5256,8 @@ chatCommandP =
|
||||||
("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal),
|
("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal),
|
||||||
("/image_forward " <|> "/imgf ") *> (ForwardImage <$> chatNameP' <* A.space <*> A.decimal),
|
("/image_forward " <|> "/imgf ") *> (ForwardImage <$> chatNameP' <* A.space <*> A.decimal),
|
||||||
("/fdescription " <|> "/fd") *> (SendFileDescription <$> chatNameP' <* A.space <*> filePath),
|
("/fdescription " <|> "/fd") *> (SendFileDescription <$> chatNameP' <* A.space <*> filePath),
|
||||||
("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> optional (" inline=" *> onOffP) <*> optional (A.space *> filePath)),
|
("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> (" encrypt=" *> onOffP <|> pure False) <*> optional (" inline=" *> onOffP) <*> optional (A.space *> filePath)),
|
||||||
"/_set_file_to_receive " *> (SetFileToReceive <$> A.decimal),
|
"/_set_file_to_receive " *> (SetFileToReceive <$> A.decimal <*> (" encrypt=" *> onOffP <|> pure False)),
|
||||||
("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal),
|
("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal),
|
||||||
("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal),
|
("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal),
|
||||||
"/simplex" *> (ConnectSimplex <$> incognitoP),
|
"/simplex" *> (ConnectSimplex <$> incognitoP),
|
||||||
|
|
|
@ -66,7 +66,7 @@ sendComposedMessage cc = sendComposedMessage' cc . contactId'
|
||||||
|
|
||||||
sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
|
sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
|
||||||
sendComposedMessage' cc ctId quotedItemId msgContent = do
|
sendComposedMessage' cc ctId quotedItemId msgContent = do
|
||||||
let cm = ComposedMessage {filePath = Nothing, quotedItemId, msgContent}
|
let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent}
|
||||||
sendChatCmd cc (APISendMessage (ChatRef CTDirect ctId) False Nothing cm) >>= \case
|
sendChatCmd cc (APISendMessage (ChatRef CTDirect ctId) False Nothing cm) >>= \case
|
||||||
CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
|
CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
|
||||||
r -> putStrLn $ "unexpected send message response: " <> show r
|
r -> putStrLn $ "unexpected send message response: " <> show r
|
||||||
|
|
|
@ -22,8 +22,9 @@ import Control.Monad.Except
|
||||||
import Control.Monad.IO.Unlift
|
import Control.Monad.IO.Unlift
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Crypto.Random (ChaChaDRG)
|
import Crypto.Random (ChaChaDRG)
|
||||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?))
|
||||||
import qualified Data.Aeson as J
|
import qualified Data.Aeson as J
|
||||||
|
import qualified Data.Aeson.Types as JT
|
||||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||||
import Data.ByteString.Char8 (ByteString)
|
import Data.ByteString.Char8 (ByteString)
|
||||||
import qualified Data.ByteString.Char8 as B
|
import qualified Data.ByteString.Char8 as B
|
||||||
|
@ -54,16 +55,18 @@ import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig)
|
||||||
import Simplex.Messaging.Agent.Lock
|
import Simplex.Messaging.Agent.Lock
|
||||||
import Simplex.Messaging.Agent.Protocol
|
import Simplex.Messaging.Agent.Protocol
|
||||||
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration)
|
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration)
|
||||||
|
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
|
||||||
import qualified Simplex.Messaging.Crypto as C
|
import qualified Simplex.Messaging.Crypto as C
|
||||||
|
import Simplex.Messaging.Crypto.File (CryptoFile (..))
|
||||||
|
import qualified Simplex.Messaging.Crypto.File as CF
|
||||||
import Simplex.Messaging.Encoding.String
|
import Simplex.Messaging.Encoding.String
|
||||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
|
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
|
||||||
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
|
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
|
||||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType, CorrId, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SProtocolType, UserProtocol, XFTPServerWithAuth)
|
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType, CorrId, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SProtocolType, UserProtocol, XFTPServerWithAuth)
|
||||||
import Simplex.Messaging.TMap (TMap)
|
import Simplex.Messaging.TMap (TMap)
|
||||||
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
|
|
||||||
import Simplex.Messaging.Transport (simplexMQVersion)
|
import Simplex.Messaging.Transport (simplexMQVersion)
|
||||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||||
import Simplex.Messaging.Util (allFinally, catchAllErrors, tryAllErrors)
|
import Simplex.Messaging.Util (allFinally, catchAllErrors, tryAllErrors, (<$$>))
|
||||||
import System.IO (Handle)
|
import System.IO (Handle)
|
||||||
import System.Mem.Weak (Weak)
|
import System.Mem.Weak (Weak)
|
||||||
import UnliftIO.STM
|
import UnliftIO.STM
|
||||||
|
@ -387,8 +390,8 @@ data ChatCommand
|
||||||
| ForwardFile ChatName FileTransferId
|
| ForwardFile ChatName FileTransferId
|
||||||
| ForwardImage ChatName FileTransferId
|
| ForwardImage ChatName FileTransferId
|
||||||
| SendFileDescription ChatName FilePath
|
| SendFileDescription ChatName FilePath
|
||||||
| ReceiveFile {fileId :: FileTransferId, fileInline :: Maybe Bool, filePath :: Maybe FilePath}
|
| ReceiveFile {fileId :: FileTransferId, storeEncrypted :: Bool, fileInline :: Maybe Bool, filePath :: Maybe FilePath}
|
||||||
| SetFileToReceive FileTransferId
|
| SetFileToReceive {fileId :: FileTransferId, storeEncrypted :: Bool}
|
||||||
| CancelFile FileTransferId
|
| CancelFile FileTransferId
|
||||||
| FileStatus FileTransferId
|
| FileStatus FileTransferId
|
||||||
| ShowProfile -- UserId (not used in UI)
|
| ShowProfile -- UserId (not used in UI)
|
||||||
|
@ -723,11 +726,24 @@ data UserProfileUpdateSummary = UserProfileUpdateSummary
|
||||||
instance ToJSON UserProfileUpdateSummary where toEncoding = J.genericToEncoding J.defaultOptions
|
instance ToJSON UserProfileUpdateSummary where toEncoding = J.genericToEncoding J.defaultOptions
|
||||||
|
|
||||||
data ComposedMessage = ComposedMessage
|
data ComposedMessage = ComposedMessage
|
||||||
{ filePath :: Maybe FilePath,
|
{ fileSource :: Maybe CryptoFile,
|
||||||
quotedItemId :: Maybe ChatItemId,
|
quotedItemId :: Maybe ChatItemId,
|
||||||
msgContent :: MsgContent
|
msgContent :: MsgContent
|
||||||
}
|
}
|
||||||
deriving (Show, Generic, FromJSON)
|
deriving (Show, Generic)
|
||||||
|
|
||||||
|
-- This instance is needed for backward compatibility, can be removed in v6.0
|
||||||
|
instance FromJSON ComposedMessage where
|
||||||
|
parseJSON (J.Object v) = do
|
||||||
|
fileSource <-
|
||||||
|
(v .:? "fileSource") >>= \case
|
||||||
|
Nothing -> CF.plain <$$> (v .:? "filePath")
|
||||||
|
f -> pure f
|
||||||
|
quotedItemId <- v .:? "quotedItemId"
|
||||||
|
msgContent <- v .: "msgContent"
|
||||||
|
pure ComposedMessage {fileSource, quotedItemId, msgContent}
|
||||||
|
parseJSON invalid =
|
||||||
|
JT.prependFailure "bad ComposedMessage, " (JT.typeMismatch "Object" invalid)
|
||||||
|
|
||||||
instance ToJSON ComposedMessage where
|
instance ToJSON ComposedMessage where
|
||||||
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
|
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
|
||||||
|
|
|
@ -37,6 +37,8 @@ import Simplex.Chat.Protocol
|
||||||
import Simplex.Chat.Types
|
import Simplex.Chat.Types
|
||||||
import Simplex.Chat.Types.Preferences
|
import Simplex.Chat.Types.Preferences
|
||||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptStatus (..))
|
import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptStatus (..))
|
||||||
|
import Simplex.Messaging.Crypto.File (CryptoFile (..))
|
||||||
|
import qualified Simplex.Messaging.Crypto.File as CF
|
||||||
import Simplex.Messaging.Encoding.String
|
import Simplex.Messaging.Encoding.String
|
||||||
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON)
|
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON)
|
||||||
import Simplex.Messaging.Protocol (MsgBody)
|
import Simplex.Messaging.Protocol (MsgBody)
|
||||||
|
@ -459,7 +461,7 @@ data CIFile (d :: MsgDirection) = CIFile
|
||||||
{ fileId :: Int64,
|
{ fileId :: Int64,
|
||||||
fileName :: String,
|
fileName :: String,
|
||||||
fileSize :: Integer,
|
fileSize :: Integer,
|
||||||
filePath :: Maybe FilePath, -- local file path
|
fileSource :: Maybe CryptoFile, -- local file path with optional key and nonce
|
||||||
fileStatus :: CIFileStatus d,
|
fileStatus :: CIFileStatus d,
|
||||||
fileProtocol :: FileProtocol
|
fileProtocol :: FileProtocol
|
||||||
}
|
}
|
||||||
|
@ -631,6 +633,14 @@ data CIFileInfo = CIFileInfo
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
|
mkCIFileInfo :: MsgDirectionI d => CIFile d -> CIFileInfo
|
||||||
|
mkCIFileInfo CIFile {fileId, fileStatus, fileSource} =
|
||||||
|
CIFileInfo
|
||||||
|
{ fileId,
|
||||||
|
fileStatus = Just $ AFS msgDirection fileStatus,
|
||||||
|
filePath = CF.filePath <$> fileSource
|
||||||
|
}
|
||||||
|
|
||||||
data CIStatus (d :: MsgDirection) where
|
data CIStatus (d :: MsgDirection) where
|
||||||
CISSndNew :: CIStatus 'MDSnd
|
CISSndNew :: CIStatus 'MDSnd
|
||||||
CISSndSent :: SndCIStatusProgress -> CIStatus 'MDSnd
|
CISSndSent :: SndCIStatusProgress -> CIStatus 'MDSnd
|
||||||
|
|
|
@ -50,7 +50,7 @@ instance FromField AMsgDirection where fromField = fromIntField_ $ fmap fromMsgD
|
||||||
|
|
||||||
instance ToField MsgDirection where toField = toField . msgDirectionInt
|
instance ToField MsgDirection where toField = toField . msgDirectionInt
|
||||||
|
|
||||||
fromIntField_ :: (Typeable a) => (Int64 -> Maybe a) -> Field -> Ok a
|
fromIntField_ :: Typeable a => (Int64 -> Maybe a) -> Field -> Ok a
|
||||||
fromIntField_ fromInt = \case
|
fromIntField_ fromInt = \case
|
||||||
f@(Field (SQLInteger i) _) ->
|
f@(Field (SQLInteger i) _) ->
|
||||||
case fromInt i of
|
case fromInt i of
|
||||||
|
|
20
src/Simplex/Chat/Migrations/M20230827_file_encryption.hs
Normal file
20
src/Simplex/Chat/Migrations/M20230827_file_encryption.hs
Normal file
|
@ -0,0 +1,20 @@
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
|
||||||
|
module Simplex.Chat.Migrations.M20230827_file_encryption where
|
||||||
|
|
||||||
|
import Database.SQLite.Simple (Query)
|
||||||
|
import Database.SQLite.Simple.QQ (sql)
|
||||||
|
|
||||||
|
m20230827_file_encryption :: Query
|
||||||
|
m20230827_file_encryption =
|
||||||
|
[sql|
|
||||||
|
ALTER TABLE files ADD COLUMN file_crypto_key BLOB;
|
||||||
|
ALTER TABLE files ADD COLUMN file_crypto_nonce BLOB;
|
||||||
|
|]
|
||||||
|
|
||||||
|
down_m20230827_file_encryption :: Query
|
||||||
|
down_m20230827_file_encryption =
|
||||||
|
[sql|
|
||||||
|
ALTER TABLE files DROP COLUMN file_crypto_key;
|
||||||
|
ALTER TABLE files DROP COLUMN file_crypto_nonce;
|
||||||
|
|]
|
|
@ -204,7 +204,9 @@ CREATE TABLE files(
|
||||||
agent_snd_file_id BLOB NULL,
|
agent_snd_file_id BLOB NULL,
|
||||||
private_snd_file_descr TEXT NULL,
|
private_snd_file_descr TEXT NULL,
|
||||||
agent_snd_file_deleted INTEGER DEFAULT 0 CHECK(agent_snd_file_deleted NOT NULL),
|
agent_snd_file_deleted INTEGER DEFAULT 0 CHECK(agent_snd_file_deleted NOT NULL),
|
||||||
protocol TEXT NOT NULL DEFAULT 'smp'
|
protocol TEXT NOT NULL DEFAULT 'smp',
|
||||||
|
file_crypto_key BLOB,
|
||||||
|
file_crypto_nonce BLOB
|
||||||
);
|
);
|
||||||
CREATE TABLE snd_files(
|
CREATE TABLE snd_files(
|
||||||
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
|
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
|
||||||
|
|
|
@ -35,6 +35,8 @@ import GHC.Generics (Generic)
|
||||||
import Simplex.Chat
|
import Simplex.Chat
|
||||||
import Simplex.Chat.Controller
|
import Simplex.Chat.Controller
|
||||||
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
|
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
|
||||||
|
import Simplex.Chat.Mobile.File
|
||||||
|
import Simplex.Chat.Mobile.Shared
|
||||||
import Simplex.Chat.Mobile.WebRTC
|
import Simplex.Chat.Mobile.WebRTC
|
||||||
import Simplex.Chat.Options
|
import Simplex.Chat.Options
|
||||||
import Simplex.Chat.Store
|
import Simplex.Chat.Store
|
||||||
|
@ -69,6 +71,10 @@ foreign export ccall "chat_encrypt_media" cChatEncryptMedia :: CString -> Ptr Wo
|
||||||
|
|
||||||
foreign export ccall "chat_decrypt_media" cChatDecryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
|
foreign export ccall "chat_decrypt_media" cChatDecryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
|
||||||
|
|
||||||
|
foreign export ccall "chat_write_file" cChatWriteFile :: CString -> Ptr Word8 -> CInt -> IO CJSONString
|
||||||
|
|
||||||
|
foreign export ccall "chat_read_file" cChatReadFile :: CString -> CString -> CString -> IO (Ptr Word8)
|
||||||
|
|
||||||
-- | check / migrate database and initialize chat controller on success
|
-- | check / migrate database and initialize chat controller on success
|
||||||
cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
|
cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
|
||||||
cChatMigrateInit fp key conf ctrl = do
|
cChatMigrateInit fp key conf ctrl = do
|
||||||
|
@ -151,8 +157,6 @@ defaultMobileConfig =
|
||||||
logLevel = CLLError
|
logLevel = CLLError
|
||||||
}
|
}
|
||||||
|
|
||||||
type CJSONString = CString
|
|
||||||
|
|
||||||
getActiveUser_ :: SQLiteStore -> IO (Maybe User)
|
getActiveUser_ :: SQLiteStore -> IO (Maybe User)
|
||||||
getActiveUser_ st = find activeUser <$> withTransaction st getUsers
|
getActiveUser_ st = find activeUser <$> withTransaction st getUsers
|
||||||
|
|
||||||
|
|
83
src/Simplex/Chat/Mobile/File.hs
Normal file
83
src/Simplex/Chat/Mobile/File.hs
Normal file
|
@ -0,0 +1,83 @@
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
|
module Simplex.Chat.Mobile.File
|
||||||
|
( cChatWriteFile,
|
||||||
|
cChatReadFile,
|
||||||
|
WriteFileResult (..),
|
||||||
|
ReadFileResult (..),
|
||||||
|
chatWriteFile,
|
||||||
|
chatReadFile,
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Control.Monad.Except
|
||||||
|
import Data.Aeson (ToJSON)
|
||||||
|
import qualified Data.Aeson as J
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
|
import qualified Data.ByteString as B
|
||||||
|
import qualified Data.ByteString.Lazy as LB
|
||||||
|
import qualified Data.ByteString.Lazy.Char8 as LB'
|
||||||
|
import Data.Int (Int64)
|
||||||
|
import Data.Word (Word8)
|
||||||
|
import Foreign.C
|
||||||
|
import Foreign.Marshal.Alloc (mallocBytes)
|
||||||
|
import Foreign.Ptr
|
||||||
|
import GHC.Generics (Generic)
|
||||||
|
import Simplex.Chat.Mobile.Shared
|
||||||
|
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||||
|
import qualified Simplex.Messaging.Crypto.File as CF
|
||||||
|
import Simplex.Messaging.Encoding.String
|
||||||
|
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
|
||||||
|
|
||||||
|
data WriteFileResult
|
||||||
|
= WFResult {cryptoArgs :: CryptoFileArgs}
|
||||||
|
| WFError {writeError :: String}
|
||||||
|
deriving (Generic)
|
||||||
|
|
||||||
|
instance ToJSON WriteFileResult where toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "WF"
|
||||||
|
|
||||||
|
cChatWriteFile :: CString -> Ptr Word8 -> CInt -> IO CJSONString
|
||||||
|
cChatWriteFile cPath ptr len = do
|
||||||
|
path <- peekCAString cPath
|
||||||
|
s <- getByteString ptr len
|
||||||
|
r <- chatWriteFile path s
|
||||||
|
newCAString $ LB'.unpack $ J.encode r
|
||||||
|
|
||||||
|
chatWriteFile :: FilePath -> ByteString -> IO WriteFileResult
|
||||||
|
chatWriteFile path s = do
|
||||||
|
cfArgs <- CF.randomArgs
|
||||||
|
let file = CryptoFile path $ Just cfArgs
|
||||||
|
either (WFError . show) (\_ -> WFResult cfArgs)
|
||||||
|
<$> runExceptT (CF.writeFile file $ LB.fromStrict s)
|
||||||
|
|
||||||
|
data ReadFileResult
|
||||||
|
= RFResult {fileSize :: Int64}
|
||||||
|
| RFError {readError :: String}
|
||||||
|
deriving (Generic)
|
||||||
|
|
||||||
|
instance ToJSON ReadFileResult where toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RF"
|
||||||
|
|
||||||
|
cChatReadFile :: CString -> CString -> CString -> IO (Ptr Word8)
|
||||||
|
cChatReadFile cPath cKey cNonce = do
|
||||||
|
path <- peekCAString cPath
|
||||||
|
key <- B.packCString cKey
|
||||||
|
nonce <- B.packCString cNonce
|
||||||
|
(r, s) <- chatReadFile path key nonce
|
||||||
|
let r' = LB.toStrict (J.encode r) <> "\NUL"
|
||||||
|
ptr <- mallocBytes $ B.length r' + B.length s
|
||||||
|
putByteString ptr r'
|
||||||
|
unless (B.null s) $ putByteString (ptr `plusPtr` B.length r') s
|
||||||
|
pure ptr
|
||||||
|
|
||||||
|
chatReadFile :: FilePath -> ByteString -> ByteString -> IO (ReadFileResult, ByteString)
|
||||||
|
chatReadFile path keyStr nonceStr = do
|
||||||
|
either ((,"") . RFError) (\s -> (RFResult $ LB.length s, LB.toStrict s)) <$> runExceptT readFile_
|
||||||
|
where
|
||||||
|
readFile_ :: ExceptT String IO LB.ByteString
|
||||||
|
readFile_ = do
|
||||||
|
key <- liftEither $ strDecode keyStr
|
||||||
|
nonce <- liftEither $ strDecode nonceStr
|
||||||
|
let file = CryptoFile path $ Just $ CFArgs key nonce
|
||||||
|
withExceptT show $ CF.readFile file
|
19
src/Simplex/Chat/Mobile/Shared.hs
Normal file
19
src/Simplex/Chat/Mobile/Shared.hs
Normal file
|
@ -0,0 +1,19 @@
|
||||||
|
module Simplex.Chat.Mobile.Shared where
|
||||||
|
|
||||||
|
import qualified Data.ByteString as B
|
||||||
|
import Data.ByteString.Internal (ByteString (PS), memcpy)
|
||||||
|
import Foreign.C (CInt, CString)
|
||||||
|
import Foreign (Ptr, Word8, newForeignPtr_, plusPtr)
|
||||||
|
import Foreign.ForeignPtr.Unsafe
|
||||||
|
|
||||||
|
type CJSONString = CString
|
||||||
|
|
||||||
|
getByteString :: Ptr Word8 -> CInt -> IO ByteString
|
||||||
|
getByteString ptr len = do
|
||||||
|
fp <- newForeignPtr_ ptr
|
||||||
|
pure $ PS fp 0 $ fromIntegral len
|
||||||
|
|
||||||
|
putByteString :: Ptr Word8 -> ByteString -> IO ()
|
||||||
|
putByteString ptr bs@(PS fp offset _) = do
|
||||||
|
let p = unsafeForeignPtrToPtr fp `plusPtr` offset
|
||||||
|
memcpy ptr p $ B.length bs
|
|
@ -12,16 +12,15 @@ import Control.Monad.Except
|
||||||
import qualified Crypto.Cipher.Types as AES
|
import qualified Crypto.Cipher.Types as AES
|
||||||
import Data.Bifunctor (bimap)
|
import Data.Bifunctor (bimap)
|
||||||
import qualified Data.ByteArray as BA
|
import qualified Data.ByteArray as BA
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.ByteString.Base64.URL as U
|
import qualified Data.ByteString.Base64.URL as U
|
||||||
import Data.ByteString.Internal (ByteString (PS), memcpy)
|
|
||||||
import Data.Either (fromLeft)
|
import Data.Either (fromLeft)
|
||||||
import Data.Word (Word8)
|
import Data.Word (Word8)
|
||||||
import Foreign.C (CInt, CString, newCAString)
|
import Foreign.C (CInt, CString, newCAString)
|
||||||
import Foreign.ForeignPtr (newForeignPtr_)
|
import Foreign.Ptr (Ptr)
|
||||||
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
|
|
||||||
import Foreign.Ptr (Ptr, plusPtr)
|
|
||||||
import qualified Simplex.Messaging.Crypto as C
|
import qualified Simplex.Messaging.Crypto as C
|
||||||
|
import Simplex.Chat.Mobile.Shared
|
||||||
|
|
||||||
cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
|
cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
|
||||||
cChatEncryptMedia = cTransformMedia chatEncryptMedia
|
cChatEncryptMedia = cTransformMedia chatEncryptMedia
|
||||||
|
@ -32,16 +31,10 @@ cChatDecryptMedia = cTransformMedia chatDecryptMedia
|
||||||
cTransformMedia :: (ByteString -> ByteString -> ExceptT String IO ByteString) -> CString -> Ptr Word8 -> CInt -> IO CString
|
cTransformMedia :: (ByteString -> ByteString -> ExceptT String IO ByteString) -> CString -> Ptr Word8 -> CInt -> IO CString
|
||||||
cTransformMedia f cKey cFrame cFrameLen = do
|
cTransformMedia f cKey cFrame cFrameLen = do
|
||||||
key <- B.packCString cKey
|
key <- B.packCString cKey
|
||||||
frame <- getFrame
|
frame <- getByteString cFrame cFrameLen
|
||||||
runExceptT (f key frame >>= liftIO . putFrame) >>= newCAString . fromLeft ""
|
runExceptT (f key frame >>= liftIO . putFrame) >>= newCAString . fromLeft ""
|
||||||
where
|
where
|
||||||
getFrame = do
|
putFrame s = when (B.length s < fromIntegral cFrameLen) $ putByteString cFrame s
|
||||||
fp <- newForeignPtr_ cFrame
|
|
||||||
pure $ PS fp 0 $ fromIntegral cFrameLen
|
|
||||||
putFrame bs@(PS fp offset _) = do
|
|
||||||
let len = B.length bs
|
|
||||||
p = unsafeForeignPtrToPtr fp `plusPtr` offset
|
|
||||||
when (len <= fromIntegral cFrameLen) $ memcpy cFrame p len
|
|
||||||
{-# INLINE cTransformMedia #-}
|
{-# INLINE cTransformMedia #-}
|
||||||
|
|
||||||
chatEncryptMedia :: ByteString -> ByteString -> ExceptT String IO ByteString
|
chatEncryptMedia :: ByteString -> ByteString -> ExceptT String IO ByteString
|
||||||
|
|
|
@ -56,6 +56,7 @@ module Simplex.Chat.Store.Files
|
||||||
startRcvInlineFT,
|
startRcvInlineFT,
|
||||||
xftpAcceptRcvFT,
|
xftpAcceptRcvFT,
|
||||||
setRcvFileToReceive,
|
setRcvFileToReceive,
|
||||||
|
setFileCryptoArgs,
|
||||||
getRcvFilesToReceive,
|
getRcvFilesToReceive,
|
||||||
setRcvFTAgentDeleted,
|
setRcvFTAgentDeleted,
|
||||||
updateRcvFileStatus,
|
updateRcvFileStatus,
|
||||||
|
@ -84,18 +85,21 @@ import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay)
|
||||||
import Data.Type.Equality
|
import Data.Type.Equality
|
||||||
import Database.SQLite.Simple (Only (..), (:.) (..))
|
import Database.SQLite.Simple (Only (..), (:.) (..))
|
||||||
import Database.SQLite.Simple.QQ (sql)
|
import Database.SQLite.Simple.QQ (sql)
|
||||||
|
import Simplex.Chat.Messages
|
||||||
|
import Simplex.Chat.Messages.CIContent
|
||||||
|
import Simplex.Chat.Protocol
|
||||||
import Simplex.Chat.Store.Direct
|
import Simplex.Chat.Store.Direct
|
||||||
import Simplex.Chat.Store.Messages
|
import Simplex.Chat.Store.Messages
|
||||||
import Simplex.Chat.Store.Profiles
|
import Simplex.Chat.Store.Profiles
|
||||||
import Simplex.Chat.Store.Shared
|
import Simplex.Chat.Store.Shared
|
||||||
import Simplex.Chat.Messages
|
|
||||||
import Simplex.Chat.Messages.CIContent
|
|
||||||
import Simplex.Chat.Protocol
|
|
||||||
import Simplex.Chat.Types
|
import Simplex.Chat.Types
|
||||||
import Simplex.Chat.Util (week)
|
import Simplex.Chat.Util (week)
|
||||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
|
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
|
||||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||||
|
import qualified Simplex.Messaging.Crypto as C
|
||||||
|
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||||
|
import qualified Simplex.Messaging.Crypto.File as CF
|
||||||
|
|
||||||
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
|
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
|
||||||
getLiveSndFileTransfers db User {userId} = do
|
getLiveSndFileTransfers db User {userId} = do
|
||||||
|
@ -257,14 +261,14 @@ getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMs
|
||||||
(\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, recipientDisplayName = n, connId, agentConnId})
|
(\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, recipientDisplayName = n, connId, agentConnId})
|
||||||
<$> (contactName_ <|> memberName_)
|
<$> (contactName_ <|> memberName_)
|
||||||
|
|
||||||
createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> FilePath -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta
|
createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> CryptoFile -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta
|
||||||
createSndFileTransferXFTP db User {userId} contactOrGroup filePath FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do
|
createSndFileTransferXFTP db User {userId} contactOrGroup (CryptoFile filePath cryptoArgs) FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do
|
||||||
currentTs <- getCurrentTime
|
currentTs <- getCurrentTime
|
||||||
let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False}
|
let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False, cryptoArgs}
|
||||||
DB.execute
|
DB.execute
|
||||||
db
|
db
|
||||||
"INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_size, chunk_size, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
|
"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, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs))
|
(contactAndGroupIds contactOrGroup :. (userId, fileName, filePath, CF.fileKey <$> cryptoArgs, CF.fileNonce <$> cryptoArgs, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs))
|
||||||
fileId <- insertedRowId db
|
fileId <- insertedRowId db
|
||||||
pure FileTransferMeta {fileId, xftpSndFile, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False}
|
pure FileTransferMeta {fileId, xftpSndFile, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False}
|
||||||
|
|
||||||
|
@ -479,7 +483,8 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File
|
||||||
currentTs <- liftIO getCurrentTime
|
currentTs <- liftIO getCurrentTime
|
||||||
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
|
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
|
||||||
let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_
|
let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_
|
||||||
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_
|
-- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it
|
||||||
|
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False, cryptoArgs = Nothing}) <$> rfd_
|
||||||
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
|
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
|
||||||
fileId <- liftIO $ do
|
fileId <- liftIO $ do
|
||||||
DB.execute
|
DB.execute
|
||||||
|
@ -499,7 +504,8 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD
|
||||||
currentTs <- liftIO getCurrentTime
|
currentTs <- liftIO getCurrentTime
|
||||||
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
|
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
|
||||||
let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_
|
let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_
|
||||||
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_
|
-- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it
|
||||||
|
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False, cryptoArgs = Nothing}) <$> rfd_
|
||||||
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
|
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
|
||||||
fileId <- liftIO $ do
|
fileId <- liftIO $ do
|
||||||
DB.execute
|
DB.execute
|
||||||
|
@ -600,7 +606,7 @@ getRcvFileTransfer db User {userId} fileId = do
|
||||||
[sql|
|
[sql|
|
||||||
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
|
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
|
||||||
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
|
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
|
||||||
f.file_path, r.file_inline, r.rcv_file_inline, r.agent_rcv_file_id, r.agent_rcv_file_deleted, c.connection_id, c.agent_conn_id
|
f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline, r.agent_rcv_file_id, r.agent_rcv_file_deleted, c.connection_id, c.agent_conn_id
|
||||||
FROM rcv_files r
|
FROM rcv_files r
|
||||||
JOIN files f USING (file_id)
|
JOIN files f USING (file_id)
|
||||||
LEFT JOIN connections c ON r.file_id = c.rcv_file_id
|
LEFT JOIN connections c ON r.file_id = c.rcv_file_id
|
||||||
|
@ -614,9 +620,9 @@ getRcvFileTransfer db User {userId} fileId = do
|
||||||
where
|
where
|
||||||
rcvFileTransfer ::
|
rcvFileTransfer ::
|
||||||
Maybe RcvFileDescr ->
|
Maybe RcvFileDescr ->
|
||||||
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, Bool) :. (Maybe Int64, Maybe AgentConnId) ->
|
(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
|
ExceptT StoreError IO RcvFileTransfer
|
||||||
rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileInline, rcvFileInline, agentRcvFileId, agentRcvFileDeleted) :. (connId_, agentConnId_)) =
|
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_ of
|
||||||
Nothing -> throwError $ SERcvFileInvalid fileId
|
Nothing -> throwError $ SERcvFileInvalid fileId
|
||||||
Just name -> do
|
Just name -> do
|
||||||
|
@ -629,7 +635,8 @@ getRcvFileTransfer db User {userId} fileId = do
|
||||||
where
|
where
|
||||||
ft senderDisplayName fileStatus =
|
ft senderDisplayName fileStatus =
|
||||||
let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
|
let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
|
||||||
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted}) <$> rfd_
|
cryptoArgs = CFArgs <$> fileKey <*> fileNonce
|
||||||
|
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted, cryptoArgs}) <$> rfd_
|
||||||
in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId}
|
in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId}
|
||||||
rfi = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_
|
rfi = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_
|
||||||
rfi_ = case (filePath_, connId_, agentConnId_) of
|
rfi_ = case (filePath_, connId_, agentConnId_) of
|
||||||
|
@ -683,13 +690,21 @@ acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do
|
||||||
"UPDATE rcv_files SET rcv_file_inline = ?, file_status = ?, updated_at = ? WHERE file_id = ?"
|
"UPDATE rcv_files SET rcv_file_inline = ?, file_status = ?, updated_at = ? WHERE file_id = ?"
|
||||||
(rcvFileInline, FSAccepted, currentTs, fileId)
|
(rcvFileInline, FSAccepted, currentTs, fileId)
|
||||||
|
|
||||||
setRcvFileToReceive :: DB.Connection -> FileTransferId -> IO ()
|
setRcvFileToReceive :: DB.Connection -> FileTransferId -> Maybe CryptoFileArgs -> IO ()
|
||||||
setRcvFileToReceive db fileId = do
|
setRcvFileToReceive db fileId cfArgs_ = do
|
||||||
currentTs <- getCurrentTime
|
currentTs <- getCurrentTime
|
||||||
|
DB.execute db "UPDATE rcv_files SET to_receive = 1, updated_at = ? WHERE file_id = ?" (currentTs, fileId)
|
||||||
|
forM_ cfArgs_ $ \cfArgs -> setFileCryptoArgs_ db fileId cfArgs currentTs
|
||||||
|
|
||||||
|
setFileCryptoArgs :: DB.Connection -> FileTransferId -> CryptoFileArgs -> IO ()
|
||||||
|
setFileCryptoArgs db fileId cfArgs = setFileCryptoArgs_ db fileId cfArgs =<< getCurrentTime
|
||||||
|
|
||||||
|
setFileCryptoArgs_ :: DB.Connection -> FileTransferId -> CryptoFileArgs -> UTCTime -> IO ()
|
||||||
|
setFileCryptoArgs_ db fileId (CFArgs key nonce) currentTs =
|
||||||
DB.execute
|
DB.execute
|
||||||
db
|
db
|
||||||
"UPDATE rcv_files SET to_receive = 1, updated_at = ? WHERE file_id = ?"
|
"UPDATE files SET file_crypto_key = ?, file_crypto_nonce = ?, updated_at = ? WHERE file_id = ?"
|
||||||
(currentTs, fileId)
|
(key, nonce, currentTs, fileId)
|
||||||
|
|
||||||
getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer]
|
getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer]
|
||||||
getRcvFilesToReceive db user@User {userId} = do
|
getRcvFilesToReceive db user@User {userId} = do
|
||||||
|
@ -842,15 +857,16 @@ getFileTransferMeta db User {userId} fileId =
|
||||||
DB.query
|
DB.query
|
||||||
db
|
db
|
||||||
[sql|
|
[sql|
|
||||||
SELECT file_name, file_size, chunk_size, file_path, 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
|
||||||
FROM files
|
FROM files
|
||||||
WHERE user_id = ? AND file_id = ?
|
WHERE user_id = ? AND file_id = ?
|
||||||
|]
|
|]
|
||||||
(userId, fileId)
|
(userId, fileId)
|
||||||
where
|
where
|
||||||
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool) -> FileTransferMeta
|
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, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) =
|
fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileKey, fileNonce, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) =
|
||||||
let xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted}) <$> aSndFileId_
|
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, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_}
|
||||||
|
|
||||||
getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo]
|
getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo]
|
||||||
|
|
|
@ -13,7 +13,6 @@
|
||||||
module Simplex.Chat.Store.Messages
|
module Simplex.Chat.Store.Messages
|
||||||
( getContactConnIds_,
|
( getContactConnIds_,
|
||||||
getDirectChatReactions_,
|
getDirectChatReactions_,
|
||||||
toDirectChatItem,
|
|
||||||
|
|
||||||
-- * Message and chat item functions
|
-- * Message and chat item functions
|
||||||
deleteContactCIs,
|
deleteContactCIs,
|
||||||
|
@ -122,6 +121,8 @@ import Simplex.Chat.Types
|
||||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserId)
|
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserId)
|
||||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow)
|
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow)
|
||||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||||
|
import qualified Simplex.Messaging.Crypto as C
|
||||||
|
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||||
import Simplex.Messaging.Util (eitherToMaybe)
|
import Simplex.Messaging.Util (eitherToMaybe)
|
||||||
import UnliftIO.STM
|
import UnliftIO.STM
|
||||||
|
|
||||||
|
@ -483,7 +484,7 @@ getDirectChatPreviews_ db user@User {userId} = do
|
||||||
-- ChatItem
|
-- ChatItem
|
||||||
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
||||||
-- CIFile
|
-- CIFile
|
||||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol,
|
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
|
||||||
-- DirectQuote
|
-- DirectQuote
|
||||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||||
FROM contacts ct
|
FROM contacts ct
|
||||||
|
@ -548,7 +549,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
|
||||||
-- ChatItem
|
-- ChatItem
|
||||||
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
||||||
-- CIFile
|
-- CIFile
|
||||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol,
|
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
|
||||||
-- Maybe GroupMember - sender
|
-- Maybe GroupMember - sender
|
||||||
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
||||||
m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
|
m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
|
||||||
|
@ -669,7 +670,7 @@ getDirectChatItemsLast db User {userId} contactId count search = ExceptT $ do
|
||||||
-- ChatItem
|
-- ChatItem
|
||||||
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
||||||
-- CIFile
|
-- CIFile
|
||||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol,
|
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
|
||||||
-- DirectQuote
|
-- DirectQuote
|
||||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||||
FROM chat_items i
|
FROM chat_items i
|
||||||
|
@ -698,7 +699,7 @@ getDirectChatAfter_ db User {userId} ct@Contact {contactId} afterChatItemId coun
|
||||||
-- ChatItem
|
-- ChatItem
|
||||||
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
||||||
-- CIFile
|
-- CIFile
|
||||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol,
|
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
|
||||||
-- DirectQuote
|
-- DirectQuote
|
||||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||||
FROM chat_items i
|
FROM chat_items i
|
||||||
|
@ -728,7 +729,7 @@ getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId co
|
||||||
-- ChatItem
|
-- ChatItem
|
||||||
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
||||||
-- CIFile
|
-- CIFile
|
||||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol,
|
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
|
||||||
-- DirectQuote
|
-- DirectQuote
|
||||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||||
FROM chat_items i
|
FROM chat_items i
|
||||||
|
@ -950,7 +951,7 @@ type ChatStatsRow = (Int, ChatItemId, Bool)
|
||||||
toChatStats :: ChatStatsRow -> ChatStats
|
toChatStats :: ChatStatsRow -> ChatStats
|
||||||
toChatStats (unreadCount, minUnreadItemId, unreadChat) = ChatStats {unreadCount, minUnreadItemId, unreadChat}
|
toChatStats (unreadCount, minUnreadItemId, unreadChat) = ChatStats {unreadCount, minUnreadItemId, unreadChat}
|
||||||
|
|
||||||
type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe ACIFileStatus, Maybe FileProtocol)
|
type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol)
|
||||||
|
|
||||||
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool)
|
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool)
|
||||||
|
|
||||||
|
@ -971,7 +972,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir
|
||||||
|
|
||||||
-- this function can be changed so it never fails, not only avoid failure on invalid json
|
-- this function can be changed so it never fails, not only avoid failure on invalid json
|
||||||
toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
|
toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
|
||||||
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. quoteRow) =
|
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) =
|
||||||
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
|
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
|
||||||
where
|
where
|
||||||
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
|
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
|
||||||
|
@ -988,7 +989,10 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
|
||||||
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
|
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
|
||||||
maybeCIFile fileStatus =
|
maybeCIFile fileStatus =
|
||||||
case (fileId_, fileName_, fileSize_, fileProtocol_) of
|
case (fileId_, fileName_, fileSize_, fileProtocol_) of
|
||||||
(Just fileId, Just fileName, Just fileSize, Just fileProtocol) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol}
|
(Just fileId, Just fileName, Just fileSize, Just fileProtocol) ->
|
||||||
|
let cfArgs = CFArgs <$> fileKey <*> fileNonce
|
||||||
|
fileSource = (`CryptoFile` cfArgs) <$> filePath
|
||||||
|
in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol}
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect
|
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect
|
||||||
cItem d chatDir ciStatus content file =
|
cItem d chatDir ciStatus content file =
|
||||||
|
@ -1021,7 +1025,7 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction
|
||||||
|
|
||||||
-- this function can be changed so it never fails, not only avoid failure on invalid json
|
-- this function can be changed so it never fails, not only avoid failure on invalid json
|
||||||
toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
|
toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
|
||||||
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
|
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
|
||||||
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
|
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
|
||||||
where
|
where
|
||||||
member_ = toMaybeGroupMember userContactId memberRow_
|
member_ = toMaybeGroupMember userContactId memberRow_
|
||||||
|
@ -1041,7 +1045,10 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
|
||||||
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
|
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
|
||||||
maybeCIFile fileStatus =
|
maybeCIFile fileStatus =
|
||||||
case (fileId_, fileName_, fileSize_, fileProtocol_) of
|
case (fileId_, fileName_, fileSize_, fileProtocol_) of
|
||||||
(Just fileId, Just fileName, Just fileSize, Just fileProtocol) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol}
|
(Just fileId, Just fileName, Just fileSize, Just fileProtocol) ->
|
||||||
|
let cfArgs = CFArgs <$> fileKey <*> fileNonce
|
||||||
|
fileSource = (`CryptoFile` cfArgs) <$> filePath
|
||||||
|
in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol}
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup
|
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup
|
||||||
cItem d chatDir ciStatus content file =
|
cItem d chatDir ciStatus content file =
|
||||||
|
@ -1141,7 +1148,7 @@ updateDirectChatItemStatus db user@User {userId} contactId itemId itemStatus = d
|
||||||
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
|
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
|
||||||
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
|
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
|
||||||
|
|
||||||
updateDirectChatItem :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> Bool -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTDirect d)
|
updateDirectChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> Bool -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTDirect d)
|
||||||
updateDirectChatItem db user contactId itemId newContent live msgId_ = do
|
updateDirectChatItem db user contactId itemId newContent live msgId_ = do
|
||||||
ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId
|
ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId
|
||||||
liftIO $ updateDirectChatItem' db user contactId ci newContent live msgId_
|
liftIO $ updateDirectChatItem' db user contactId ci newContent live msgId_
|
||||||
|
@ -1149,7 +1156,7 @@ updateDirectChatItem db user contactId itemId newContent live msgId_ = do
|
||||||
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
|
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
|
||||||
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
|
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
|
||||||
|
|
||||||
updateDirectChatItem' :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItem 'CTDirect d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTDirect d)
|
updateDirectChatItem' :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTDirect d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTDirect d)
|
||||||
updateDirectChatItem' db User {userId} contactId ci newContent live msgId_ = do
|
updateDirectChatItem' db User {userId} contactId ci newContent live msgId_ = do
|
||||||
currentTs <- liftIO getCurrentTime
|
currentTs <- liftIO getCurrentTime
|
||||||
let ci' = updatedChatItem ci newContent live currentTs
|
let ci' = updatedChatItem ci newContent live currentTs
|
||||||
|
@ -1294,7 +1301,7 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
|
||||||
-- ChatItem
|
-- ChatItem
|
||||||
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
||||||
-- CIFile
|
-- CIFile
|
||||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol,
|
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
|
||||||
-- DirectQuote
|
-- DirectQuote
|
||||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||||
FROM chat_items i
|
FROM chat_items i
|
||||||
|
@ -1469,7 +1476,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
|
||||||
-- ChatItem
|
-- ChatItem
|
||||||
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
|
||||||
-- CIFile
|
-- CIFile
|
||||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol,
|
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
|
||||||
-- GroupMember
|
-- GroupMember
|
||||||
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
||||||
m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
|
m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
|
||||||
|
|
|
@ -76,6 +76,7 @@ import Simplex.Chat.Migrations.M20230621_chat_item_moderations
|
||||||
import Simplex.Chat.Migrations.M20230705_delivery_receipts
|
import Simplex.Chat.Migrations.M20230705_delivery_receipts
|
||||||
import Simplex.Chat.Migrations.M20230721_group_snd_item_statuses
|
import Simplex.Chat.Migrations.M20230721_group_snd_item_statuses
|
||||||
import Simplex.Chat.Migrations.M20230814_indexes
|
import Simplex.Chat.Migrations.M20230814_indexes
|
||||||
|
import Simplex.Chat.Migrations.M20230827_file_encryption
|
||||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||||
|
|
||||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||||
|
@ -151,7 +152,8 @@ schemaMigrations =
|
||||||
("20230621_chat_item_moderations", m20230621_chat_item_moderations, Just down_m20230621_chat_item_moderations),
|
("20230621_chat_item_moderations", m20230621_chat_item_moderations, Just down_m20230621_chat_item_moderations),
|
||||||
("20230705_delivery_receipts", m20230705_delivery_receipts, Just down_m20230705_delivery_receipts),
|
("20230705_delivery_receipts", m20230705_delivery_receipts, Just down_m20230705_delivery_receipts),
|
||||||
("20230721_group_snd_item_statuses", m20230721_group_snd_item_statuses, Just down_m20230721_group_snd_item_statuses),
|
("20230721_group_snd_item_statuses", m20230721_group_snd_item_statuses, Just down_m20230721_group_snd_item_statuses),
|
||||||
("20230814_indexes", m20230814_indexes, Just down_m20230814_indexes)
|
("20230814_indexes", m20230814_indexes, Just down_m20230814_indexes),
|
||||||
|
("20230827_file_encryption", m20230827_file_encryption, Just down_m20230827_file_encryption)
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | The list of migrations in ascending order by date
|
-- | The list of migrations in ascending order by date
|
||||||
|
|
|
@ -42,6 +42,7 @@ import Simplex.Chat.Types.Preferences
|
||||||
import Simplex.Chat.Types.Util
|
import Simplex.Chat.Types.Util
|
||||||
import Simplex.FileTransfer.Description (FileDigest)
|
import Simplex.FileTransfer.Description (FileDigest)
|
||||||
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
|
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
|
||||||
|
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
|
||||||
import Simplex.Messaging.Encoding.String
|
import Simplex.Messaging.Encoding.String
|
||||||
import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON)
|
import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON)
|
||||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
|
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
|
||||||
|
@ -345,11 +346,12 @@ data ChatSettings = ChatSettings
|
||||||
instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOptions
|
instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOptions
|
||||||
|
|
||||||
defaultChatSettings :: ChatSettings
|
defaultChatSettings :: ChatSettings
|
||||||
defaultChatSettings = ChatSettings
|
defaultChatSettings =
|
||||||
{ enableNtfs = True,
|
ChatSettings
|
||||||
sendRcpts = Nothing,
|
{ enableNtfs = True,
|
||||||
favorite = False
|
sendRcpts = Nothing,
|
||||||
}
|
favorite = False
|
||||||
|
}
|
||||||
|
|
||||||
pattern DisableNtfs :: ChatSettings
|
pattern DisableNtfs :: ChatSettings
|
||||||
pattern DisableNtfs <- ChatSettings {enableNtfs = False}
|
pattern DisableNtfs <- ChatSettings {enableNtfs = False}
|
||||||
|
@ -953,7 +955,8 @@ instance ToJSON RcvFileTransfer where toEncoding = J.genericToEncoding J.default
|
||||||
data XFTPRcvFile = XFTPRcvFile
|
data XFTPRcvFile = XFTPRcvFile
|
||||||
{ rcvFileDescription :: RcvFileDescr,
|
{ rcvFileDescription :: RcvFileDescr,
|
||||||
agentRcvFileId :: Maybe AgentRcvFileId,
|
agentRcvFileId :: Maybe AgentRcvFileId,
|
||||||
agentRcvFileDeleted :: Bool
|
agentRcvFileDeleted :: Bool,
|
||||||
|
cryptoArgs :: Maybe CryptoFileArgs
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Generic)
|
deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
|
@ -1108,7 +1111,8 @@ instance ToJSON FileTransferMeta where toEncoding = J.genericToEncoding J.defaul
|
||||||
data XFTPSndFile = XFTPSndFile
|
data XFTPSndFile = XFTPSndFile
|
||||||
{ agentSndFileId :: AgentSndFileId,
|
{ agentSndFileId :: AgentSndFileId,
|
||||||
privateSndFileDescr :: Maybe Text,
|
privateSndFileDescr :: Maybe Text,
|
||||||
agentSndFileDeleted :: Bool
|
agentSndFileDeleted :: Bool,
|
||||||
|
cryptoArgs :: Maybe CryptoFileArgs
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Generic)
|
deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
|
|
|
@ -50,6 +50,7 @@ import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..))
|
||||||
import Simplex.Messaging.Agent.Protocol
|
import Simplex.Messaging.Agent.Protocol
|
||||||
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
|
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
|
||||||
import qualified Simplex.Messaging.Crypto as C
|
import qualified Simplex.Messaging.Crypto as C
|
||||||
|
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||||
import Simplex.Messaging.Encoding
|
import Simplex.Messaging.Encoding
|
||||||
import Simplex.Messaging.Encoding.String
|
import Simplex.Messaging.Encoding.String
|
||||||
import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON)
|
import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON)
|
||||||
|
@ -160,7 +161,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
||||||
CRRcvFileDescrReady _ _ -> []
|
CRRcvFileDescrReady _ _ -> []
|
||||||
CRRcvFileDescrNotReady _ _ -> []
|
CRRcvFileDescrNotReady _ _ -> []
|
||||||
CRRcvFileProgressXFTP {} -> []
|
CRRcvFileProgressXFTP {} -> []
|
||||||
CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci
|
CRRcvFileAccepted u ci -> ttyUser u $ savingFile' testView ci
|
||||||
CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft
|
CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft
|
||||||
CRSndFileCancelled u _ ftm fts -> ttyUser u $ viewSndFileCancelled ftm fts
|
CRSndFileCancelled u _ ftm fts -> ttyUser u $ viewSndFileCancelled ftm fts
|
||||||
CRRcvFileCancelled u _ ft -> ttyUser u $ receivingFile_ "cancelled" ft
|
CRRcvFileCancelled u _ ft -> ttyUser u $ receivingFile_ "cancelled" ft
|
||||||
|
@ -251,7 +252,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
||||||
CRSQLResult rows -> map plain rows
|
CRSQLResult rows -> map plain rows
|
||||||
CRSlowSQLQueries {chatQueries, agentQueries} ->
|
CRSlowSQLQueries {chatQueries, agentQueries} ->
|
||||||
let viewQuery SlowSQLQuery {query, queryStats = SlowQueryStats {count, timeMax, timeAvg}} =
|
let viewQuery SlowSQLQuery {query, queryStats = SlowQueryStats {count, timeMax, timeAvg}} =
|
||||||
"count: " <> sShow count
|
("count: " <> sShow count)
|
||||||
<> (" :: max: " <> sShow timeMax <> " ms")
|
<> (" :: max: " <> sShow timeMax <> " ms")
|
||||||
<> (" :: avg: " <> sShow timeAvg <> " ms")
|
<> (" :: avg: " <> sShow timeAvg <> " ms")
|
||||||
<> (" :: " <> plain (T.unwords $ T.lines query))
|
<> (" :: " <> plain (T.unwords $ T.lines query))
|
||||||
|
@ -274,7 +275,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
||||||
<> ("pending subscriptions: " : map sShow pendingSubscriptions)
|
<> ("pending subscriptions: " : map sShow pendingSubscriptions)
|
||||||
CRConnectionDisabled entity -> viewConnectionEntityDisabled entity
|
CRConnectionDisabled entity -> viewConnectionEntityDisabled entity
|
||||||
CRAgentRcvQueueDeleted acId srv aqId err_ ->
|
CRAgentRcvQueueDeleted acId srv aqId err_ ->
|
||||||
[ "completed deleting rcv queue, agent connection id: " <> sShow acId
|
[ ("completed deleting rcv queue, agent connection id: " <> sShow acId)
|
||||||
<> (", server: " <> sShow srv)
|
<> (", server: " <> sShow srv)
|
||||||
<> (", agent queue id: " <> sShow aqId)
|
<> (", agent queue id: " <> sShow aqId)
|
||||||
<> maybe "" (\e -> ", error: " <> sShow e) err_
|
<> maybe "" (\e -> ", error: " <> sShow e) err_
|
||||||
|
@ -327,7 +328,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
||||||
Just CIQuote {chatDir = quoteDir, content} ->
|
Just CIQuote {chatDir = quoteDir, content} ->
|
||||||
Just (msgDirectionInt $ quoteMsgDirection quoteDir, msgContentText content)
|
Just (msgDirectionInt $ quoteMsgDirection quoteDir, msgContentText content)
|
||||||
fPath = case file of
|
fPath = case file of
|
||||||
Just CIFile {filePath = Just fp} -> Just fp
|
Just CIFile {fileSource = Just (CryptoFile fp _)} -> Just fp
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
testViewItem :: CChatItem c -> Maybe GroupMember -> Text
|
testViewItem :: CChatItem c -> Maybe GroupMember -> Text
|
||||||
testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText}}) membership_ =
|
testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText}}) membership_ =
|
||||||
|
@ -950,7 +951,8 @@ viewNetworkConfig NetworkConfig {socksProxy, tcpTimeout} =
|
||||||
|
|
||||||
viewContactInfo :: Contact -> ConnectionStats -> Maybe Profile -> [StyledString]
|
viewContactInfo :: Contact -> ConnectionStats -> Maybe Profile -> [StyledString]
|
||||||
viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}} stats incognitoProfile =
|
viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}} stats incognitoProfile =
|
||||||
["contact ID: " <> sShow contactId] <> viewConnectionStats stats
|
["contact ID: " <> sShow contactId]
|
||||||
|
<> viewConnectionStats stats
|
||||||
<> maybe [] (\l -> ["contact address: " <> (plain . strEncode) l]) contactLink
|
<> maybe [] (\l -> ["contact address: " <> (plain . strEncode) l]) contactLink
|
||||||
<> maybe
|
<> maybe
|
||||||
["you've shared main profile with this contact"]
|
["you've shared main profile with this contact"]
|
||||||
|
@ -1269,8 +1271,8 @@ viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <
|
||||||
| otherwise = ""
|
| otherwise = ""
|
||||||
|
|
||||||
viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
||||||
viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} ts tz = case filePath of
|
viewSentFileInvitation to CIFile {fileId, fileSource, fileStatus} ts tz = case fileSource of
|
||||||
Just fPath -> sentWithTime_ ts tz $ ttySentFile fPath
|
Just (CryptoFile fPath _) -> sentWithTime_ ts tz $ ttySentFile fPath
|
||||||
_ -> const []
|
_ -> const []
|
||||||
where
|
where
|
||||||
ttySentFile fPath = ["/f " <> to <> ttyFilePath fPath] <> cancelSending
|
ttySentFile fPath = ["/f " <> to <> ttyFilePath fPath] <> cancelSending
|
||||||
|
@ -1338,14 +1340,20 @@ humanReadableSize size
|
||||||
mB = kB * 1024
|
mB = kB * 1024
|
||||||
gB = mB * 1024
|
gB = mB * 1024
|
||||||
|
|
||||||
savingFile' :: AChatItem -> [StyledString]
|
savingFile' :: Bool -> AChatItem -> [StyledString]
|
||||||
savingFile' (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, filePath = Just filePath}, chatDir = CIDirectRcv}) =
|
savingFile' testView (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileSource = Just (CryptoFile filePath cfArgs_)}, chatDir}) =
|
||||||
["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
|
let from = case (chat, chatDir) of
|
||||||
savingFile' (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, filePath = Just filePath}, chatDir = CIGroupRcv GroupMember {localDisplayName = m}}) =
|
(DirectChat Contact {localDisplayName = c}, CIDirectRcv) -> " from " <> ttyContact c
|
||||||
["saving file " <> sShow fileId <> " from " <> ttyContact m <> " to " <> plain filePath]
|
(_, CIGroupRcv GroupMember {localDisplayName = m}) -> " from " <> ttyContact m
|
||||||
savingFile' (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, filePath = Just filePath}}) =
|
_ -> ""
|
||||||
["saving file " <> sShow fileId <> " to " <> plain filePath]
|
in ["saving file " <> sShow fileId <> from <> " to " <> plain filePath] <> cfArgsStr
|
||||||
savingFile' _ = ["saving file"] -- shouldn't happen
|
where
|
||||||
|
cfArgsStr = case cfArgs_ of
|
||||||
|
Just cfArgs@(CFArgs key nonce)
|
||||||
|
| testView -> [plain $ LB.unpack $ J.encode cfArgs]
|
||||||
|
| otherwise -> [plain $ "encryption key: " <> strEncode key <> ", nonce: " <> strEncode nonce]
|
||||||
|
_ -> []
|
||||||
|
savingFile' _ _ = ["saving file"] -- shouldn't happen
|
||||||
|
|
||||||
receivingFile_' :: StyledString -> AChatItem -> [StyledString]
|
receivingFile_' :: StyledString -> AChatItem -> [StyledString]
|
||||||
receivingFile_' status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectRcv}) =
|
receivingFile_' status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectRcv}) =
|
||||||
|
@ -1397,7 +1405,7 @@ viewFileTransferStatus (FTRcv ft@RcvFileTransfer {fileId, fileInvitation = FileI
|
||||||
RFSCancelled Nothing -> "cancelled"
|
RFSCancelled Nothing -> "cancelled"
|
||||||
|
|
||||||
viewFileTransferStatusXFTP :: AChatItem -> [StyledString]
|
viewFileTransferStatusXFTP :: AChatItem -> [StyledString]
|
||||||
viewFileTransferStatusXFTP (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName, fileSize, fileStatus, filePath}}) =
|
viewFileTransferStatusXFTP (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName, fileSize, fileStatus, fileSource}}) =
|
||||||
case fileStatus of
|
case fileStatus of
|
||||||
CIFSSndStored -> ["sending " <> fstr <> " just started"]
|
CIFSSndStored -> ["sending " <> fstr <> " just started"]
|
||||||
CIFSSndTransfer progress total -> ["sending " <> fstr <> " in progress " <> fileProgressXFTP progress total fileSize]
|
CIFSSndTransfer progress total -> ["sending " <> fstr <> " in progress " <> fileProgressXFTP progress total fileSize]
|
||||||
|
@ -1407,7 +1415,7 @@ viewFileTransferStatusXFTP (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId
|
||||||
CIFSRcvInvitation -> ["receiving " <> fstr <> " not accepted yet, use " <> highlight ("/fr " <> show fileId) <> " to receive file"]
|
CIFSRcvInvitation -> ["receiving " <> fstr <> " not accepted yet, use " <> highlight ("/fr " <> show fileId) <> " to receive file"]
|
||||||
CIFSRcvAccepted -> ["receiving " <> fstr <> " just started"]
|
CIFSRcvAccepted -> ["receiving " <> fstr <> " just started"]
|
||||||
CIFSRcvTransfer progress total -> ["receiving " <> fstr <> " progress " <> fileProgressXFTP progress total fileSize]
|
CIFSRcvTransfer progress total -> ["receiving " <> fstr <> " progress " <> fileProgressXFTP progress total fileSize]
|
||||||
CIFSRcvComplete -> ["receiving " <> fstr <> " complete" <> maybe "" (\fp -> ", path: " <> plain fp) filePath]
|
CIFSRcvComplete -> ["receiving " <> fstr <> " complete" <> maybe "" (\(CryptoFile fp _) -> ", path: " <> plain fp) fileSource]
|
||||||
CIFSRcvCancelled -> ["receiving " <> fstr <> " cancelled"]
|
CIFSRcvCancelled -> ["receiving " <> fstr <> " cancelled"]
|
||||||
CIFSRcvError -> ["receiving " <> fstr <> " error"]
|
CIFSRcvError -> ["receiving " <> fstr <> " error"]
|
||||||
CIFSInvalid text -> [fstr <> " invalid status: " <> plain text]
|
CIFSInvalid text -> [fstr <> " invalid status: " <> plain text]
|
||||||
|
|
|
@ -49,7 +49,7 @@ extra-deps:
|
||||||
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
|
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
|
||||||
# - ../simplexmq
|
# - ../simplexmq
|
||||||
- github: simplex-chat/simplexmq
|
- github: simplex-chat/simplexmq
|
||||||
commit: 4c0b8a31d20870a23e120e243359901d8240f922
|
commit: 5dc3d739b206edc2b4706ba0eef64ad4492e68e6
|
||||||
- github: kazu-yamamoto/http2
|
- github: kazu-yamamoto/http2
|
||||||
commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
|
commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
|
||||||
# - ../direct-sqlcipher
|
# - ../direct-sqlcipher
|
||||||
|
|
|
@ -249,7 +249,7 @@ getTermLine cc =
|
||||||
Just s -> do
|
Just s -> do
|
||||||
-- remove condition to always echo virtual terminal
|
-- remove condition to always echo virtual terminal
|
||||||
when (printOutput cc) $ do
|
when (printOutput cc) $ do
|
||||||
-- when True $ do
|
-- when True $ do
|
||||||
name <- userName cc
|
name <- userName cc
|
||||||
putStrLn $ name <> ": " <> s
|
putStrLn $ name <> ": " <> s
|
||||||
pure s
|
pure s
|
||||||
|
|
|
@ -8,14 +8,19 @@ import ChatClient
|
||||||
import ChatTests.Utils
|
import ChatTests.Utils
|
||||||
import Control.Concurrent (threadDelay)
|
import Control.Concurrent (threadDelay)
|
||||||
import Control.Concurrent.Async (concurrently_)
|
import Control.Concurrent.Async (concurrently_)
|
||||||
|
import qualified Data.Aeson as J
|
||||||
import qualified Data.ByteString.Char8 as B
|
import qualified Data.ByteString.Char8 as B
|
||||||
|
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||||
import Simplex.Chat (roundedFDCount)
|
import Simplex.Chat (roundedFDCount)
|
||||||
import Simplex.Chat.Controller (ChatConfig (..), InlineFilesConfig (..), XFTPFileConfig (..), defaultInlineFilesConfig)
|
import Simplex.Chat.Controller (ChatConfig (..), InlineFilesConfig (..), XFTPFileConfig (..), defaultInlineFilesConfig)
|
||||||
|
import Simplex.Chat.Mobile.File
|
||||||
import Simplex.Chat.Options (ChatOpts (..))
|
import Simplex.Chat.Options (ChatOpts (..))
|
||||||
import Simplex.FileTransfer.Client.Main (xftpClientCLI)
|
import Simplex.FileTransfer.Client.Main (xftpClientCLI)
|
||||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
|
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
|
||||||
|
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||||
|
import Simplex.Messaging.Encoding.String
|
||||||
import Simplex.Messaging.Util (unlessM)
|
import Simplex.Messaging.Util (unlessM)
|
||||||
import System.Directory (copyFile, doesFileExist)
|
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist, getFileSize)
|
||||||
import System.Environment (withArgs)
|
import System.Environment (withArgs)
|
||||||
import System.IO.Silently (capture_)
|
import System.IO.Silently (capture_)
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
@ -59,6 +64,7 @@ chatFileTests = do
|
||||||
describe "file transfer over XFTP" $ do
|
describe "file transfer over XFTP" $ do
|
||||||
it "round file description count" $ const testXFTPRoundFDCount
|
it "round file description count" $ const testXFTPRoundFDCount
|
||||||
it "send and receive file" testXFTPFileTransfer
|
it "send and receive file" testXFTPFileTransfer
|
||||||
|
it "send and receive locally encrypted files" testXFTPFileTransferEncrypted
|
||||||
it "send and receive file, accepting after upload" testXFTPAcceptAfterUpload
|
it "send and receive file, accepting after upload" testXFTPAcceptAfterUpload
|
||||||
it "send and receive file in group" testXFTPGroupFileTransfer
|
it "send and receive file in group" testXFTPGroupFileTransfer
|
||||||
it "delete uploaded file" testXFTPDeleteUploadedFile
|
it "delete uploaded file" testXFTPDeleteUploadedFile
|
||||||
|
@ -1013,6 +1019,35 @@ testXFTPFileTransfer =
|
||||||
where
|
where
|
||||||
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
|
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
|
||||||
|
|
||||||
|
testXFTPFileTransferEncrypted :: HasCallStack => FilePath -> IO ()
|
||||||
|
testXFTPFileTransferEncrypted =
|
||||||
|
testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do
|
||||||
|
src <- B.readFile "./tests/fixtures/test.pdf"
|
||||||
|
srcLen <- getFileSize "./tests/fixtures/test.pdf"
|
||||||
|
let srcPath = "./tests/tmp/alice/test.pdf"
|
||||||
|
createDirectoryIfMissing True "./tests/tmp/alice/"
|
||||||
|
createDirectoryIfMissing True "./tests/tmp/bob/"
|
||||||
|
WFResult cfArgs <- chatWriteFile srcPath src
|
||||||
|
let fileJSON = LB.unpack $ J.encode $ CryptoFile srcPath $ Just cfArgs
|
||||||
|
withXFTPServer $ do
|
||||||
|
connectUsers alice bob
|
||||||
|
alice ##> ("/_send @2 json {\"msgContent\":{\"type\":\"file\", \"text\":\"\"}, \"fileSource\": " <> fileJSON <> "}")
|
||||||
|
alice <# "/f @bob ./tests/tmp/alice/test.pdf"
|
||||||
|
alice <## "use /fc 1 to cancel sending"
|
||||||
|
bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)"
|
||||||
|
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||||
|
bob ##> "/fr 1 encrypt=on ./tests/tmp/bob/"
|
||||||
|
bob <## "saving file 1 from alice to ./tests/tmp/bob/test.pdf"
|
||||||
|
Just (CFArgs key nonce) <- J.decode . LB.pack <$> getTermLine bob
|
||||||
|
alice <## "completed uploading file 1 (test.pdf) for bob"
|
||||||
|
bob <## "started receiving file 1 (test.pdf) from alice"
|
||||||
|
bob <## "completed receiving file 1 (test.pdf) from alice"
|
||||||
|
(RFResult destLen, dest) <- chatReadFile "./tests/tmp/bob/test.pdf" (strEncode key) (strEncode nonce)
|
||||||
|
fromIntegral destLen `shouldBe` srcLen
|
||||||
|
dest `shouldBe` src
|
||||||
|
where
|
||||||
|
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
|
||||||
|
|
||||||
testXFTPAcceptAfterUpload :: HasCallStack => FilePath -> IO ()
|
testXFTPAcceptAfterUpload :: HasCallStack => FilePath -> IO ()
|
||||||
testXFTPAcceptAfterUpload =
|
testXFTPAcceptAfterUpload =
|
||||||
testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do
|
testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do
|
||||||
|
@ -1447,7 +1482,7 @@ startFileTransfer alice bob =
|
||||||
startFileTransfer' alice bob "test.jpg" "136.5 KiB / 139737 bytes"
|
startFileTransfer' alice bob "test.jpg" "136.5 KiB / 139737 bytes"
|
||||||
|
|
||||||
startFileTransfer' :: HasCallStack => TestCC -> TestCC -> String -> String -> IO ()
|
startFileTransfer' :: HasCallStack => TestCC -> TestCC -> String -> String -> IO ()
|
||||||
startFileTransfer' cc1 cc2 fileName fileSize = startFileTransferWithDest' cc1 cc2 fileName fileSize $ Just "./tests/tmp"
|
startFileTransfer' cc1 cc2 fName fSize = startFileTransferWithDest' cc1 cc2 fName fSize $ Just "./tests/tmp"
|
||||||
|
|
||||||
checkPartialTransfer :: HasCallStack => String -> IO ()
|
checkPartialTransfer :: HasCallStack => String -> IO ()
|
||||||
checkPartialTransfer fileName = do
|
checkPartialTransfer fileName = do
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue