diff --git a/simplex-chat.cabal b/simplex-chat.cabal index e9036ea604..f831bf540c 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -32,6 +32,7 @@ library Simplex.Chat.Call Simplex.Chat.Controller Simplex.Chat.Core + Simplex.Chat.Files Simplex.Chat.Help Simplex.Chat.Markdown Simplex.Chat.Messages @@ -131,6 +132,7 @@ library Simplex.Chat.Remote.Discovery Simplex.Chat.Remote.Multicast Simplex.Chat.Remote.Protocol + Simplex.Chat.Remote.Transport Simplex.Chat.Remote.Types Simplex.Chat.Store Simplex.Chat.Store.Connections diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index e8049dcbb5..e46a426d8c 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -55,6 +55,7 @@ import qualified Database.SQLite.Simple as SQL import Simplex.Chat.Archive import Simplex.Chat.Call import Simplex.Chat.Controller +import Simplex.Chat.Files import Simplex.Chat.Markdown import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent @@ -104,7 +105,7 @@ import Simplex.Messaging.Transport.Client (defaultSocksProxy) import Simplex.Messaging.Util import Simplex.Messaging.Version import System.Exit (exitFailure, exitSuccess) -import System.FilePath (combine, splitExtensions, takeFileName, (>)) +import System.FilePath (takeFileName, (>)) import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout) import System.Random (randomRIO) import Text.Read (readMaybe) @@ -213,6 +214,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen currentCalls <- atomically TM.empty localDeviceName <- newTVarIO "" -- TODO set in config remoteHostSessions <- atomically TM.empty + remoteHostsFolder <- newTVarIO Nothing remoteCtrlSession <- newTVarIO Nothing filesFolder <- newTVarIO optFilesFolder chatStoreChanged <- newTVarIO False @@ -246,6 +248,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen currentCalls, localDeviceName, remoteHostSessions, + remoteHostsFolder, remoteCtrlSession, config, filesFolder, @@ -394,7 +397,7 @@ execChatCommand rh s = do case parseChatCommand s of Left e -> pure $ chatCmdError u e Right cmd -> case rh of - Just remoteHostId | allowRemoteCommand cmd -> execRemoteCommand u remoteHostId s + Just remoteHostId | allowRemoteCommand cmd -> execRemoteCommand u remoteHostId cmd s _ -> execChatCommand_ u cmd execChatCommand' :: ChatMonad' m => ChatCommand -> m ChatResponse @@ -403,8 +406,8 @@ execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` c execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse execChatCommand_ u cmd = handleCommandError u $ processChatCommand cmd -execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> ByteString -> m ChatResponse -execRemoteCommand u rhId s = handleCommandError u $ getRemoteHostSession rhId >>= \rh -> processRemoteCommand rhId rh s +execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> ChatCommand -> ByteString -> m ChatResponse +execRemoteCommand u rhId cmd s = handleCommandError u $ getRemoteHostSession rhId >>= \rh -> processRemoteCommand rhId rh cmd s handleCommandError :: ChatMonad' m => Maybe User -> ExceptT ChatError m ChatResponse -> m ChatResponse handleCommandError u a = either (CRChatCmdError u) id <$> (runExceptT a `E.catch` (pure . Left . mkChatError)) @@ -542,6 +545,10 @@ processChatCommand = \case createDirectoryIfMissing True ff asks filesFolder >>= atomically . (`writeTVar` Just ff) ok_ + SetRemoteHostsFolder rf -> do + createDirectoryIfMissing True rf + chatWriteVar remoteHostsFolder $ Just rf + ok_ APISetXFTPConfig cfg -> do asks userXFTPFileConfig >>= atomically . (`writeTVar` cfg) ok_ @@ -1795,15 +1802,15 @@ processChatCommand = \case asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_ SendFile chatName f -> withUser $ \user -> do chatRef <- getChatRef user chatName - processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCFile "") - SendImage chatName f -> withUser $ \user -> do + processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCFile "") + SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do chatRef <- getChatRef user chatName - filePath <- toFSFilePath f - unless (any (`isSuffixOf` map toLower f) imageExtensions) $ throwChatError CEFileImageType {filePath} + filePath <- toFSFilePath fPath + unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath} fileSize <- getFileSize filePath unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath} -- TODO include file description for preview - processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCImage "" fixedImagePreview) + processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCImage "" fixedImagePreview) ForwardFile chatName fileId -> forwardFile chatName fileId SendFile ForwardImage chatName fileId -> forwardFile chatName fileId SendImage SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO" @@ -1905,19 +1912,21 @@ processChatCommand = \case let pref = uncurry TimedMessagesGroupPreference $ maybe (FEOff, Just 86400) (\ttl -> (FEOn, Just ttl)) ttl_ updateGroupProfileByName gName $ \p -> p {groupPreferences = Just . setGroupPreference' SGFTimedMessages pref $ groupPreferences p} - SetLocalDeviceName name -> withUser $ \_ -> chatWriteVar localDeviceName name >> ok_ + SetLocalDeviceName name -> withUser_ $ chatWriteVar localDeviceName name >> ok_ CreateRemoteHost -> CRRemoteHostCreated <$> createRemoteHost ListRemoteHosts -> CRRemoteHostList <$> listRemoteHosts StartRemoteHost rh -> startRemoteHost rh >> ok_ StopRemoteHost rh -> closeRemoteHostSession rh >> ok_ DeleteRemoteHost rh -> deleteRemoteHost rh >> ok_ - StartRemoteCtrl -> startRemoteCtrl (execChatCommand Nothing) >> ok_ - RegisterRemoteCtrl oob -> CRRemoteCtrlRegistered <$> withStore' (`insertRemoteCtrl` oob) - AcceptRemoteCtrl rc -> acceptRemoteCtrl rc >> ok_ - RejectRemoteCtrl rc -> rejectRemoteCtrl rc >> ok_ - StopRemoteCtrl -> stopRemoteCtrl >> ok_ - ListRemoteCtrls -> CRRemoteCtrlList <$> listRemoteCtrls - DeleteRemoteCtrl rc -> deleteRemoteCtrl rc >> ok_ + StoreRemoteFile rh encrypted_ localPath -> CRRemoteFileStored rh <$> storeRemoteFile rh encrypted_ localPath + GetRemoteFile rh rf -> getRemoteFile rh rf >> ok_ + StartRemoteCtrl -> withUser_ $ startRemoteCtrl (execChatCommand Nothing) >> ok_ + RegisterRemoteCtrl oob -> withUser_ $ CRRemoteCtrlRegistered <$> withStore' (`insertRemoteCtrl` oob) + AcceptRemoteCtrl rc -> withUser_ $ acceptRemoteCtrl rc >> ok_ + RejectRemoteCtrl rc -> withUser_ $ rejectRemoteCtrl rc >> ok_ + StopRemoteCtrl -> withUser_ $ stopRemoteCtrl >> ok_ + ListRemoteCtrls -> withUser_ $ CRRemoteCtrlList <$> listRemoteCtrls + DeleteRemoteCtrl rc -> withUser_ $ deleteRemoteCtrl rc >> ok_ QuitChat -> liftIO exitSuccess ShowVersion -> do let versionInfo = coreVersionInfo $(simplexmqCommitQ) @@ -2173,14 +2182,14 @@ processChatCommand = \case withServerProtocol p action = case userProtocol p of Just Dict -> action _ -> throwChatError $ CEServerProtocol $ AProtocolType p - forwardFile :: ChatName -> FileTransferId -> (ChatName -> FilePath -> ChatCommand) -> m ChatResponse + forwardFile :: ChatName -> FileTransferId -> (ChatName -> CryptoFile -> ChatCommand) -> m ChatResponse forwardFile chatName fileId sendCommand = withUser $ \user -> do withStore (\db -> getFileTransfer db user fileId) >>= \case - FTRcv RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}} -> forward filePath - FTSnd {fileTransferMeta = FileTransferMeta {filePath}} -> forward filePath + FTRcv RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}, cryptoArgs} -> forward filePath cryptoArgs + FTSnd {fileTransferMeta = FileTransferMeta {filePath, xftpSndFile}} -> forward filePath $ xftpSndFile >>= \f -> f.cryptoArgs _ -> throwChatError CEFileNotReceived {fileId} where - forward = processChatCommand . sendCommand chatName + forward path cfArgs = processChatCommand . sendCommand chatName $ CryptoFile path cfArgs getGroupAndMemberId :: User -> GroupName -> ContactName -> m (GroupId, GroupMemberId) getGroupAndMemberId user gName groupMemberName = withStore $ \db -> do @@ -2575,10 +2584,9 @@ startReceivingFile user fileId = do getRcvFilePath :: forall m. ChatMonad m => FileTransferId -> Maybe FilePath -> String -> Bool -> m FilePath getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of Nothing -> - asks filesFolder >>= readTVarIO >>= \case - Nothing -> do - dir <- (`combine` "Downloads") <$> getHomeDirectory - ifM (doesDirectoryExist dir) (pure dir) getChatTempDirectory + chatReadVar filesFolder >>= \case + Nothing -> + getDefaultFilesFolder >>= (`uniqueCombine` fn) >>= createEmptyFile Just filesFolder -> @@ -2607,18 +2615,6 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of getTmpHandle :: FilePath -> m Handle getTmpHandle fPath = openFile fPath AppendMode `catchThrow` (ChatError . CEFileInternal . show) -uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath -uniqueCombine filePath fileName = tryCombine (0 :: Int) - where - tryCombine n = - let (name, ext) = splitExtensions fileName - suffix = if n == 0 then "" else "_" <> show n - f = filePath `combine` (name <> suffix <> ext) - in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f) - -getChatTempDirectory :: ChatMonad m => m FilePath -getChatTempDirectory = chatReadVar tempDirectory >>= maybe getTemporaryDirectory pure - acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> Maybe IncognitoProfile -> m Contact acceptContactRequest user UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange, localDisplayName = cName, profileId, profile = cp, userContactLinkId, xContactId} incognitoProfile = do subMode <- chatReadVar subscriptionMode @@ -5575,6 +5571,9 @@ withUser :: ChatMonad m => (User -> m ChatResponse) -> m ChatResponse withUser action = withUser' $ \user -> ifM chatStarted (action user) (throwChatError CEChatNotStarted) +withUser_ :: ChatMonad m => m ChatResponse -> m ChatResponse +withUser_ = withUser . const + withUserId :: ChatMonad m => UserId -> (User -> m ChatResponse) -> m ChatResponse withUserId userId action = withUser $ \user -> do checkSameUser userId user @@ -5635,6 +5634,7 @@ chatCommandP = "/_resubscribe all" $> ResubscribeAllConnections, "/_temp_folder " *> (SetTempFolder <$> filePath), ("/_files_folder " <|> "/files_folder ") *> (SetFilesFolder <$> filePath), + "/remote_hosts_folder " *> (SetRemoteHostsFolder <$> filePath), "/_xftp " *> (APISetXFTPConfig <$> ("on " *> (Just <$> jsonP) <|> ("off" $> Nothing))), "/xftp " *> (APISetXFTPConfig <$> ("on" *> (Just <$> xftpCfgP) <|> ("off" $> Nothing))), "/_files_encrypt " *> (APISetEncryptLocalFiles <$> onOffP), @@ -5809,8 +5809,8 @@ chatCommandP = "/show" *> (ShowLiveItems <$> (A.space *> onOffP <|> pure True)), "/show " *> (ShowChatItem . Just <$> A.decimal), "/item info " *> (ShowChatItemInfo <$> chatNameP <* A.space <*> msgTextP), - ("/file " <|> "/f ") *> (SendFile <$> chatNameP' <* A.space <*> filePath), - ("/image " <|> "/img ") *> (SendImage <$> chatNameP' <* A.space <*> filePath), + ("/file " <|> "/f ") *> (SendFile <$> chatNameP' <* A.space <*> cryptoFileP), + ("/image " <|> "/img ") *> (SendImage <$> chatNameP' <* A.space <*> cryptoFileP), ("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal), ("/image_forward " <|> "/imgf ") *> (ForwardImage <$> chatNameP' <* A.space <*> A.decimal), ("/fdescription " <|> "/fd") *> (SendFileDescription <$> chatNameP' <* A.space <*> filePath), @@ -5858,6 +5858,8 @@ chatCommandP = "/start remote host " *> (StartRemoteHost <$> A.decimal), "/stop remote host " *> (StopRemoteHost <$> A.decimal), "/delete remote host " *> (DeleteRemoteHost <$> A.decimal), + "/store remote file " *> (StoreRemoteFile <$> A.decimal <*> optional (" encrypt=" *> onOffP) <* A.space <*> filePath), + "/get remote file " *> (GetRemoteFile <$> A.decimal <* A.space <*> jsonP), "/start remote ctrl" $> StartRemoteCtrl, "/register remote ctrl " *> (RegisterRemoteCtrl <$> (RemoteCtrlOOB <$> strP <* A.space <*> textP)), "/_register remote ctrl " *> (RegisterRemoteCtrl <$> jsonP), @@ -5932,6 +5934,10 @@ chatCommandP = msgTextP = jsonP <|> textP stringP = T.unpack . safeDecodeUtf8 <$> A.takeByteString filePath = stringP + cryptoFileP = do + cfArgs <- optional $ CFArgs <$> (" key=" *> strP <* A.space) <*> (" nonce=" *> strP) + path <- filePath + pure $ CryptoFile path cfArgs memberRole = A.choice [ " owner" $> GROwner, diff --git a/src/Simplex/Chat/Archive.hs b/src/Simplex/Chat/Archive.hs index e0de971bda..dd098e016d 100644 --- a/src/Simplex/Chat/Archive.hs +++ b/src/Simplex/Chat/Archive.hs @@ -9,6 +9,7 @@ module Simplex.Chat.Archive importArchive, deleteStorage, sqlCipherExport, + archiveFilesFolder, ) where diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 66ab513a0d..bc4cfaaf89 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -178,6 +178,7 @@ data ChatController = ChatController currentCalls :: TMap ContactId Call, localDeviceName :: TVar Text, remoteHostSessions :: TMap RemoteHostId RemoteHostSession, -- All the active remote hosts + remoteHostsFolder :: TVar (Maybe FilePath), -- folder for remote hosts data remoteCtrlSession :: TVar (Maybe RemoteCtrlSession), -- Supervisor process for hosted controllers config :: ChatConfig, filesFolder :: TVar (Maybe FilePath), -- path to files folder for mobile apps, @@ -224,6 +225,7 @@ data ChatCommand | ResubscribeAllConnections | SetTempFolder FilePath | SetFilesFolder FilePath + | SetRemoteHostsFolder FilePath | APISetXFTPConfig (Maybe XFTPFileConfig) | APISetEncryptLocalFiles Bool | SetContactMergeEnabled Bool @@ -393,8 +395,8 @@ data ChatCommand | ShowChatItem (Maybe ChatItemId) -- UserId (not used in UI) | ShowChatItemInfo ChatName Text | ShowLiveItems Bool - | SendFile ChatName FilePath - | SendImage ChatName FilePath + | SendFile ChatName CryptoFile + | SendImage ChatName CryptoFile | ForwardFile ChatName FileTransferId | ForwardImage ChatName FileTransferId | SendFileDescription ChatName FilePath @@ -419,6 +421,8 @@ data ChatCommand -- | SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host | StopRemoteHost RemoteHostId -- ^ Shut down a running session | DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data + | StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath} + | GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile} | StartRemoteCtrl -- ^ Start listening for announcements from all registered controllers | RegisterRemoteCtrl RemoteCtrlOOB -- ^ Register OOB data for satellite discovery and handshake | ListRemoteCtrls @@ -440,22 +444,27 @@ allowRemoteCommand = \case StartChat {} -> False APIStopChat -> False APIActivateChat -> False - APISuspendChat {} -> False - SetTempFolder {} -> False + APISuspendChat _ -> False + SetTempFolder _ -> False QuitChat -> False CreateRemoteHost -> False ListRemoteHosts -> False - StartRemoteHost {} -> False + StartRemoteHost _ -> False -- SwitchRemoteHost {} -> False - StopRemoteHost {} -> False - DeleteRemoteHost {} -> False + StoreRemoteFile {} -> False + GetRemoteFile {} -> False + StopRemoteHost _ -> False + DeleteRemoteHost _ -> False RegisterRemoteCtrl {} -> False StartRemoteCtrl -> False ListRemoteCtrls -> False - AcceptRemoteCtrl {} -> False - RejectRemoteCtrl {} -> False + AcceptRemoteCtrl _ -> False + RejectRemoteCtrl _ -> False StopRemoteCtrl -> False - DeleteRemoteCtrl {} -> False + DeleteRemoteCtrl _ -> False + ExecChatStoreSQL _ -> False + ExecAgentStoreSQL _ -> False + SlowSQLQueries -> False _ -> True data ChatResponse @@ -627,6 +636,7 @@ data ChatResponse | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]} | CRRemoteHostConnected {remoteHost :: RemoteHostInfo} | CRRemoteHostStopped {remoteHostId :: RemoteHostId} + | CRRemoteFileStored {remoteHostId :: RemoteHostId, remoteFileSource :: CryptoFile} | CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]} | CRRemoteCtrlRegistered {remoteCtrl :: RemoteCtrlInfo} | CRRemoteCtrlAnnounce {fingerprint :: C.KeyHash} -- unregistered fingerprint, needs confirmation diff --git a/src/Simplex/Chat/Files.hs b/src/Simplex/Chat/Files.hs new file mode 100644 index 0000000000..845b237cdf --- /dev/null +++ b/src/Simplex/Chat/Files.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} + +module Simplex.Chat.Files where + +import Control.Monad.IO.Class +import Simplex.Chat.Controller +import Simplex.Messaging.Util (ifM) +import System.FilePath (splitExtensions, combine) +import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, getHomeDirectory, doesDirectoryExist) + +uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath +uniqueCombine fPath fName = tryCombine (0 :: Int) + where + tryCombine n = + let (name, ext) = splitExtensions fName + suffix = if n == 0 then "" else "_" <> show n + f = fPath `combine` (name <> suffix <> ext) + in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f) + +getChatTempDirectory :: ChatMonad m => m FilePath +getChatTempDirectory = chatReadVar tempDirectory >>= maybe getTemporaryDirectory pure + +getDefaultFilesFolder :: ChatMonad m => m FilePath +getDefaultFilesFolder = do + dir <- (`combine` "Downloads") <$> getHomeDirectory + ifM (doesDirectoryExist dir) (pure dir) getChatTempDirectory diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 2718b088ba..8ea33e0abb 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -24,6 +24,7 @@ import qualified Data.Aeson.TH as JQ import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Char (isSpace) import Data.Int (Int64) import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text) @@ -53,7 +54,7 @@ data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection data ChatName = ChatName {chatType :: ChatType, chatName :: Text} deriving (Show) -chatTypeStr :: ChatType -> String +chatTypeStr :: ChatType -> Text chatTypeStr = \case CTDirect -> "@" CTGroup -> "#" @@ -61,7 +62,7 @@ chatTypeStr = \case CTContactConnection -> ":" chatNameStr :: ChatName -> String -chatNameStr (ChatName cType name) = chatTypeStr cType <> T.unpack name +chatNameStr (ChatName cType name) = T.unpack $ chatTypeStr cType <> if T.any isSpace name then "'" <> name <> "'" else name data ChatRef = ChatRef ChatType Int64 deriving (Eq, Show, Ord) diff --git a/src/Simplex/Chat/Mobile/File.hs b/src/Simplex/Chat/Mobile/File.hs index 99860bbfa3..1da64a3044 100644 --- a/src/Simplex/Chat/Mobile/File.hs +++ b/src/Simplex/Chat/Mobile/File.hs @@ -99,7 +99,7 @@ chatEncryptFile fromPath toPath = either WFError WFResult <$> runCatchExceptT encrypt where encrypt = do - cfArgs <- liftIO $ CF.randomArgs + cfArgs <- liftIO CF.randomArgs encryptFile fromPath toPath cfArgs pure cfArgs diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index c195b4631d..5344c4bea6 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -16,7 +16,7 @@ import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class -import Control.Monad.Reader (asks) +import Control.Monad.Reader import Control.Monad.STM (retry) import Crypto.Random (getRandomBytes) import qualified Data.Aeson as J @@ -34,21 +34,35 @@ import Data.Word (Word32) import Network.HTTP2.Server (responseStreaming) import qualified Network.HTTP.Types as N import Network.Socket (SockAddr (..), hostAddressToTuple) +import Simplex.Chat.Archive (archiveFilesFolder) import Simplex.Chat.Controller +import Simplex.Chat.Files +import Simplex.Chat.Messages (chatNameStr) import qualified Simplex.Chat.Remote.Discovery as Discovery import Simplex.Chat.Remote.Protocol +import Simplex.Chat.Remote.Transport import Simplex.Chat.Remote.Types +import Simplex.Chat.Store.Files import Simplex.Chat.Store.Remote +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types (User (..)) +import Simplex.Chat.Util (encryptFile) +import Simplex.FileTransfer.Description (FileDigest (..)) 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.String (StrEncoding (..)) -import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..)) -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Transport.HTTP2.File (hSendFile) -import Simplex.Messaging.Util (ifM, liftEitherError, liftEitherWith, liftError, liftIOEither, tryAllErrors, tshow, ($>>=)) -import System.FilePath ((>)) +import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..)) +import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Util (ifM, liftEitherError, liftEitherWith, liftError, liftIOEither, tryAllErrors, tshow, ($>>=), (<$$>)) +import System.FilePath ((>), takeFileName) import UnliftIO +import UnliftIO.Directory (copyFile, createDirectoryIfMissing, renameFile) +import Data.Functor (($>)) +import Control.Applicative ((<|>)) -- * Desktop side @@ -110,7 +124,7 @@ startRemoteHost rhId = do toView $ CRRemoteHostConnected RemoteHostInfo { remoteHostId = rhId, storePath = storePath, - displayName = remoteDeviceName remoteHostClient, + displayName = hostDeviceName remoteHostClient, remoteCtrlOOB = RemoteCtrlOOB {fingerprint, displayName=rcName}, sessionActive = True } @@ -178,9 +192,57 @@ deleteRemoteHost rhId = do Nothing -> logWarn "Local file store not available while deleting remote host" withStore' (`deleteRemoteHostRecord` rhId) -processRemoteCommand :: ChatMonad m => RemoteHostId -> RemoteHostSession -> ByteString -> m ChatResponse -processRemoteCommand remoteHostId RemoteHostSession {remoteHostClient = Just rhc} s = liftRH remoteHostId $ remoteSend rhc s -processRemoteCommand _ _ _ = pure $ chatCmdError Nothing "remote command sent before session started" +storeRemoteFile :: forall m. ChatMonad m => RemoteHostId -> Maybe Bool -> FilePath -> m CryptoFile +storeRemoteFile rhId encrypted_ localPath = do + RemoteHostSession {remoteHostClient, storePath} <- getRemoteHostSession rhId + case remoteHostClient of + Nothing -> throwError $ ChatErrorRemoteHost rhId RHMissing + Just c@RemoteHostClient {encryptHostFiles} -> do + let encrypt = fromMaybe encryptHostFiles encrypted_ + cf@CryptoFile {filePath} <- if encrypt then encryptLocalFile else pure $ CF.plain localPath + filePath' <- liftRH rhId $ remoteStoreFile c filePath (takeFileName localPath) + hf_ <- chatReadVar remoteHostsFolder + forM_ hf_ $ \hf -> do + let rhf = hf > storePath > archiveFilesFolder + hPath = rhf > takeFileName filePath' + createDirectoryIfMissing True rhf + (if encrypt then renameFile else copyFile) filePath hPath + pure (cf :: CryptoFile) {filePath = filePath'} + where + encryptLocalFile :: m CryptoFile + encryptLocalFile = do + tmpDir <- getChatTempDirectory + createDirectoryIfMissing True tmpDir + tmpFile <- tmpDir `uniqueCombine` takeFileName localPath + cfArgs <- liftIO CF.randomArgs + liftError (ChatError . CEFileWrite tmpFile) $ encryptFile localPath tmpFile cfArgs + pure $ CryptoFile tmpFile $ Just cfArgs + +getRemoteFile :: ChatMonad m => RemoteHostId -> RemoteFile -> m () +getRemoteFile rhId rf = do + RemoteHostSession {remoteHostClient, storePath} <- getRemoteHostSession rhId + case remoteHostClient of + Nothing -> throwError $ ChatErrorRemoteHost rhId RHMissing + Just c -> do + dir <- (> storePath > archiveFilesFolder) <$> (maybe getDefaultFilesFolder pure =<< chatReadVar remoteHostsFolder) + createDirectoryIfMissing True dir + liftRH rhId $ remoteGetFile c dir rf + +processRemoteCommand :: ChatMonad m => RemoteHostId -> RemoteHostSession -> ChatCommand -> ByteString -> m ChatResponse +processRemoteCommand remoteHostId RemoteHostSession {remoteHostClient = Just rhc} cmd s = case cmd of + SendFile chatName f -> sendFile "/f" chatName f + SendImage chatName f -> sendFile "/img" chatName f + _ -> liftRH remoteHostId $ remoteSend rhc s + where + sendFile cmdName chatName (CryptoFile path cfArgs) = do + -- don't encrypt in host if already encrypted locally + CryptoFile path' cfArgs' <- storeRemoteFile remoteHostId (cfArgs $> False) path + let f = CryptoFile path' (cfArgs <|> cfArgs') -- use local or host encryption + liftRH remoteHostId $ remoteSend rhc $ B.unwords [cmdName, B.pack (chatNameStr chatName), cryptoFileStr f] + cryptoFileStr CryptoFile {filePath, cryptoArgs} = + maybe "" (\(CFArgs key nonce) -> "key=" <> strEncode key <> " nonce=" <> strEncode nonce <> " ") cryptoArgs + <> encodeUtf8 (T.pack filePath) +processRemoteCommand _ _ _ _ = pure $ chatCmdError Nothing "remote command sent before session started" liftRH :: ChatMonad m => RemoteHostId -> ExceptT RemoteProtocolError IO a -> m a liftRH rhId = liftError (ChatErrorRemoteHost rhId . RHProtocolError) @@ -218,20 +280,24 @@ handleRemoteCommand :: forall m . ChatMonad m => (ByteString -> m ChatResponse) handleRemoteCommand execChatCommand remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do logDebug "handleRemoteCommand" liftRC (tryRemoteError parseRequest) >>= \case - Right (getNext, rc) -> processCommand getNext rc `catchAny` (reply . RRProtocolError . RPEException . tshow) + Right (getNext, rc) -> do + chatReadVar currentUser >>= \case + Nothing -> replyError $ ChatError CENoActiveUser + Just user -> processCommand user getNext rc `catchChatError` replyError Left e -> reply $ RRProtocolError e where parseRequest :: ExceptT RemoteProtocolError IO (GetChunk, RemoteCommand) parseRequest = do (header, getNext) <- parseHTTP2Body request reqBody (getNext,) <$> liftEitherWith (RPEInvalidJSON . T.pack) (J.eitherDecodeStrict' header) - processCommand :: GetChunk -> RemoteCommand -> m () - processCommand getNext = \case + replyError = reply . RRChatResponse . CRChatCmdError Nothing + processCommand :: User -> GetChunk -> RemoteCommand -> m () + processCommand user getNext = \case RCHello {deviceName = desktopName} -> handleHello desktopName >>= reply RCSend {command} -> handleSend execChatCommand command >>= reply RCRecv {wait = time} -> handleRecv time remoteOutputQ >>= reply - RCStoreFile {fileSize, encrypt} -> handleStoreFile fileSize encrypt getNext >>= reply - RCGetFile {filePath} -> handleGetFile filePath replyWith + RCStoreFile {fileName, fileSize, fileDigest} -> handleStoreFile fileName fileSize fileDigest getNext >>= reply + RCGetFile {file} -> handleGetFile user file replyWith reply :: RemoteResponse -> m () reply = (`replyWith` \_ -> pure ()) replyWith :: Respond m @@ -258,7 +324,8 @@ handleHello :: ChatMonad m => Text -> m RemoteResponse handleHello desktopName = do logInfo $ "Hello from " <> tshow desktopName mobileName <- chatReadVar localDeviceName - pure RRHello {encoding = localEncoding, deviceName = mobileName} + encryptFiles <- chatReadVar encryptLocalFiles + pure RRHello {encoding = localEncoding, deviceName = mobileName, encryptFiles} handleSend :: ChatMonad m => (ByteString -> m ChatResponse) -> Text -> m RemoteResponse handleSend execChatCommand command = do @@ -272,20 +339,36 @@ handleRecv time events = do logDebug $ "Recv: " <> tshow time RRChatEvent <$> (timeout time . atomically $ readTBQueue events) -handleStoreFile :: ChatMonad m => Word32 -> Maybe Bool -> GetChunk -> m RemoteResponse -handleStoreFile _fileSize _encrypt _getNext = error "TODO" <$ logError "TODO: handleStoreFile" +-- TODO this command could remember stored files and return IDs to allow removing files that are not needed. +-- Also, there should be some process removing unused files uploaded to remote host (possibly, all unused files). +handleStoreFile :: forall m. ChatMonad m => FilePath -> Word32 -> FileDigest -> GetChunk -> m RemoteResponse +handleStoreFile fileName fileSize fileDigest getChunk = + either RRProtocolError RRFileStored <$> (chatReadVar filesFolder >>= storeFile) + where + storeFile :: Maybe FilePath -> m (Either RemoteProtocolError FilePath) + storeFile = \case + Just ff -> takeFileName <$$> storeFileTo ff + Nothing -> storeFileTo =<< getDefaultFilesFolder + storeFileTo :: FilePath -> m (Either RemoteProtocolError FilePath) + storeFileTo dir = liftRC . tryRemoteError $ do + filePath <- dir `uniqueCombine` fileName + receiveRemoteFile getChunk fileSize fileDigest filePath + pure filePath -handleGetFile :: ChatMonad m => FilePath -> Respond m -> m () -handleGetFile path reply = do - logDebug $ "GetFile: " <> tshow path - withFile path ReadMode $ \h -> do - fileSize' <- hFileSize h - when (fileSize' > toInteger (maxBound :: Word32)) $ throwIO RPEFileTooLarge - let fileSize = fromInteger fileSize' - reply RRFile {fileSize} $ \send -> hSendFile h send fileSize +handleGetFile :: ChatMonad m => User -> RemoteFile -> Respond m -> m () +handleGetFile User {userId} RemoteFile{userId = commandUserId, fileId, sent, fileSource = cf'@CryptoFile {filePath}} reply = do + logDebug $ "GetFile: " <> tshow filePath + unless (userId == commandUserId) $ throwChatError $ CEDifferentActiveUser {commandUserId, activeUserId = userId} + path <- maybe filePath (> filePath) <$> chatReadVar filesFolder + withStore $ \db -> do + cf <- getLocalCryptoFile db commandUserId fileId sent + unless (cf == cf') $ throwError $ SEFileNotFound fileId + liftRC (tryRemoteError $ getFileInfo path) >>= \case + Left e -> reply (RRProtocolError e) $ \_ -> pure () + Right (fileSize, fileDigest) -> + withFile path ReadMode $ \h -> + reply RRFile {fileSize, fileDigest} $ \send -> hSendFile h send fileSize --- TODO the problem with this code was that it wasn't clear where the recursion can happen, --- by splitting receiving and processing to two functions it becomes clear discoverRemoteCtrls :: ChatMonad m => TM.TMap C.KeyHash TransportHost -> m () discoverRemoteCtrls discovered = Discovery.withListener $ receive >=> process where diff --git a/src/Simplex/Chat/Remote/Protocol.hs b/src/Simplex/Chat/Remote/Protocol.hs index aa4ebe5952..2deb177775 100644 --- a/src/Simplex/Chat/Remote/Protocol.hs +++ b/src/Simplex/Chat/Remote/Protocol.hs @@ -20,7 +20,7 @@ import Data.Aeson.TH (deriveJSON) import qualified Data.Aeson.Types as JT import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder, word32BE, lazyByteString) -import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy as LB import Data.String (fromString) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) @@ -28,34 +28,35 @@ import Data.Word (Word32) import qualified Network.HTTP.Types as N import qualified Network.HTTP2.Client as H import Network.Transport.Internal (decodeWord32) -import Simplex.Chat.Controller (ChatResponse) +import Simplex.Chat.Controller +import Simplex.Chat.Remote.Transport import Simplex.Chat.Remote.Types -import Simplex.Messaging.Crypto.File (CryptoFile) +import Simplex.FileTransfer.Description (FileDigest (..)) +import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag) import Simplex.Messaging.Transport.Buffer (getBuffered) import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect) -import Simplex.Messaging.Transport.HTTP2.File (hReceiveFile, hSendFile) -import Simplex.Messaging.Util (liftEitherError, liftEitherWith, tshow, whenM) -import System.FilePath ((>)) +import Simplex.Messaging.Transport.HTTP2.File (hSendFile) +import Simplex.Messaging.Util (liftEitherError, liftEitherWith, tshow) +import System.FilePath ((>), takeFileName) import UnliftIO -import UnliftIO.Directory (doesFileExist, getFileSize) data RemoteCommand = RCHello {deviceName :: Text} | RCSend {command :: Text} -- TODO maybe ChatCommand here? | RCRecv {wait :: Int} -- this wait should be less than HTTP timeout | -- local file encryption is determined by the host, but can be overridden for videos - RCStoreFile {fileSize :: Word32, encrypt :: Maybe Bool} -- requires attachment - | RCGetFile {filePath :: FilePath} + RCStoreFile {fileName :: String, fileSize :: Word32, fileDigest :: FileDigest} -- requires attachment + | RCGetFile {file :: RemoteFile} deriving (Show) data RemoteResponse - = RRHello {encoding :: PlatformEncoding, deviceName :: Text} + = RRHello {encoding :: PlatformEncoding, deviceName :: Text, encryptFiles :: Bool} | RRChatResponse {chatResponse :: ChatResponse} | RRChatEvent {chatEvent :: Maybe ChatResponse} -- ^ 'Nothing' on poll timeout - | RRFileStored {fileSource :: CryptoFile} - | RRFile {fileSize :: Word32} -- provides attachment + | RRFileStored {filePath :: String} + | RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest | RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- ^ The protocol error happened on the server side deriving (Show) @@ -67,14 +68,13 @@ $(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse) createRemoteHostClient :: HTTP2Client -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient createRemoteHostClient httpClient desktopName = do - logInfo "Sending initial hello" - (_getNext, rr) <- sendRemoteCommand httpClient localEncoding Nothing RCHello {deviceName = desktopName} - case rr of - rrh@RRHello {encoding, deviceName = mobileName} -> do - logInfo $ "Got initial hello: " <> tshow rrh + logDebug "Sending initial hello" + sendRemoteCommand' httpClient localEncoding Nothing RCHello {deviceName = desktopName} >>= \case + RRHello {encoding, deviceName = mobileName, encryptFiles} -> do + logDebug "Got initial hello" when (encoding == PEKotlin && localEncoding == PESwift) $ throwError RPEIncompatibleEncoding - pure RemoteHostClient {remoteEncoding = encoding, remoteDeviceName = mobileName, httpClient} - _ -> throwError $ RPEUnexpectedResponse $ tshow rr + pure RemoteHostClient {hostEncoding = encoding, hostDeviceName = mobileName, httpClient, encryptHostFiles = encryptFiles} + r -> badResponse r closeRemoteHostClient :: MonadIO m => RemoteHostClient -> m () closeRemoteHostClient RemoteHostClient {httpClient} = liftIO $ closeHTTP2Client httpClient @@ -82,48 +82,37 @@ closeRemoteHostClient RemoteHostClient {httpClient} = liftIO $ closeHTTP2Client -- ** Commands remoteSend :: RemoteHostClient -> ByteString -> ExceptT RemoteProtocolError IO ChatResponse -remoteSend RemoteHostClient {httpClient, remoteEncoding} cmd = do - (_getNext, rr) <- sendRemoteCommand httpClient remoteEncoding Nothing RCSend {command = decodeUtf8 cmd} - case rr of +remoteSend RemoteHostClient {httpClient, hostEncoding} cmd = + sendRemoteCommand' httpClient hostEncoding Nothing RCSend {command = decodeUtf8 cmd} >>= \case RRChatResponse cr -> pure cr - _ -> throwError $ RPEUnexpectedResponse $ tshow rr + r -> badResponse r remoteRecv :: RemoteHostClient -> Int -> ExceptT RemoteProtocolError IO (Maybe ChatResponse) -remoteRecv RemoteHostClient {httpClient, remoteEncoding} ms = do - (_getNext, rr) <- sendRemoteCommand httpClient remoteEncoding Nothing RCRecv {wait=ms} - case rr of +remoteRecv RemoteHostClient {httpClient, hostEncoding} ms = + sendRemoteCommand' httpClient hostEncoding Nothing RCRecv {wait = ms} >>= \case RRChatEvent cr_ -> pure cr_ - _ -> throwError $ RPEUnexpectedResponse $ tshow rr + r -> badResponse r -remoteStoreFile :: RemoteHostClient -> FilePath -> Maybe Bool -> ExceptT RemoteProtocolError IO CryptoFile -remoteStoreFile RemoteHostClient {httpClient, remoteEncoding} localPath encrypt = do - (_getNext, rr) <- withFile localPath ReadMode $ \h -> do - fileSize' <- hFileSize h - when (fileSize' > toInteger (maxBound :: Word32)) $ throwError RPEFileTooLarge - let fileSize = fromInteger fileSize' - sendRemoteCommand httpClient remoteEncoding (Just (h, fileSize)) RCStoreFile {encrypt, fileSize} - case rr of - RRFileStored {fileSource} -> pure fileSource - _ -> throwError $ RPEUnexpectedResponse $ tshow rr +remoteStoreFile :: RemoteHostClient -> FilePath -> FilePath -> ExceptT RemoteProtocolError IO FilePath +remoteStoreFile RemoteHostClient {httpClient, hostEncoding} localPath fileName = do + (fileSize, fileDigest) <- getFileInfo localPath + let send h = sendRemoteCommand' httpClient hostEncoding (Just (h, fileSize)) RCStoreFile {fileName, fileSize, fileDigest} + withFile localPath ReadMode send >>= \case + RRFileStored {filePath = filePath'} -> pure filePath' + r -> badResponse r --- TODO this should work differently for CLI and UI clients --- CLI - potentially, create new unique names and report them as created --- UI - always use the same names and report error if file already exists --- alternatively, CLI should also use a fixed folder for remote session --- Possibly, path in the database should be optional and CLI commands should allow configuring it per session or use temp or download folder -remoteGetFile :: RemoteHostClient -> FilePath -> FilePath -> ExceptT RemoteProtocolError IO FilePath -remoteGetFile RemoteHostClient {httpClient, remoteEncoding} baseDir filePath = do - (getNext, rr) <- sendRemoteCommand httpClient remoteEncoding Nothing RCGetFile {filePath} - expectedSize <- case rr of - RRFile {fileSize} -> pure fileSize - _ -> throwError $ RPEUnexpectedResponse $ tshow rr - whenM (liftIO $ doesFileExist localFile) $ throwError RPEStoredFileExists - rc <- liftIO $ withFile localFile WriteMode $ \h -> hReceiveFile getNext h expectedSize - when (rc /= 0) $ throwError RPEInvalidSize - whenM ((== expectedSize) . fromIntegral <$> getFileSize localFile) $ throwError RPEInvalidSize - pure localFile - where - localFile = baseDir > filePath +remoteGetFile :: RemoteHostClient -> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO () +remoteGetFile RemoteHostClient {httpClient, hostEncoding} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} = + sendRemoteCommand httpClient hostEncoding Nothing RCGetFile {file = rf} >>= \case + (getChunk, RRFile {fileSize, fileDigest}) -> do + -- TODO we could optimize by checking size and hash before receiving the file + let localPath = destDir > takeFileName filePath + receiveRemoteFile getChunk fileSize fileDigest localPath + (_, r) -> badResponse r + +-- TODO validate there is no attachment +sendRemoteCommand' :: HTTP2Client -> PlatformEncoding -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO RemoteResponse +sendRemoteCommand' http remoteEncoding attachment_ rc = snd <$> sendRemoteCommand http remoteEncoding attachment_ rc sendRemoteCommand :: HTTP2Client -> PlatformEncoding -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO (Int -> IO ByteString, RemoteResponse) sendRemoteCommand http remoteEncoding attachment_ rc = do @@ -139,6 +128,12 @@ sendRemoteCommand http remoteEncoding attachment_ rc = do Just (h, sz) -> hSendFile h send sz flush +badResponse :: RemoteResponse -> ExceptT RemoteProtocolError IO a +badResponse = \case + RRProtocolError e -> throwError e + -- TODO handle chat errors? + r -> throwError $ RPEUnexpectedResponse $ tshow r + -- * Transport-level wrappers convertJSON :: PlatformEncoding -> PlatformEncoding -> J.Value -> J.Value @@ -183,7 +178,7 @@ pattern OwsfTag = (SingleFieldJSONTag, J.Bool True) -- | Convert a command or a response into 'Builder'. sizePrefixedEncode :: J.ToJSON a => a -> Builder -sizePrefixedEncode value = word32BE (fromIntegral $ BL.length json) <> lazyByteString json +sizePrefixedEncode value = word32BE (fromIntegral $ LB.length json) <> lazyByteString json where json = J.encode value diff --git a/src/Simplex/Chat/Remote/Transport.hs b/src/Simplex/Chat/Remote/Transport.hs new file mode 100644 index 0000000000..bf798444c0 --- /dev/null +++ b/src/Simplex/Chat/Remote/Transport.hs @@ -0,0 +1,27 @@ +module Simplex.Chat.Remote.Transport where + +import Control.Monad +import Control.Monad.Except +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.Word (Word32) +import Simplex.FileTransfer.Description (FileDigest (..)) +import Simplex.Chat.Remote.Types +import qualified Simplex.Messaging.Crypto.Lazy as LC +import Simplex.Messaging.Transport.HTTP2.File (hReceiveFile) +import UnliftIO +import UnliftIO.Directory (getFileSize) + +receiveRemoteFile :: (Int -> IO ByteString) -> Word32 -> FileDigest -> FilePath -> ExceptT RemoteProtocolError IO () +receiveRemoteFile getChunk fileSize fileDigest toPath = do + diff <- liftIO $ withFile toPath WriteMode $ \h -> hReceiveFile getChunk h fileSize + unless (diff == 0) $ throwError RPEFileSize + digest <- liftIO $ LC.sha512Hash <$> LB.readFile toPath + unless (FileDigest digest == fileDigest) $ throwError RPEFileDigest + +getFileInfo :: FilePath -> ExceptT RemoteProtocolError IO (Word32, FileDigest) +getFileInfo filePath = do + fileDigest <- liftIO $ FileDigest . LC.sha512Hash <$> LB.readFile filePath + fileSize' <- getFileSize filePath + when (fileSize' > toInteger (maxBound :: Word32)) $ throwError RPEFileSize + pure (fromInteger fileSize', fileDigest) diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index d16955199e..6611d04471 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -10,14 +10,16 @@ import qualified Data.Aeson.TH as J import Data.Int (Int64) import Data.Text (Text) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.File (CryptoFile) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) import UnliftIO data RemoteHostClient = RemoteHostClient - { remoteEncoding :: PlatformEncoding, - remoteDeviceName :: Text, - httpClient :: HTTP2Client + { hostEncoding :: PlatformEncoding, + hostDeviceName :: Text, + httpClient :: HTTP2Client, + encryptHostFiles :: Bool } data RemoteHostSession = RemoteHostSession @@ -32,7 +34,8 @@ data RemoteProtocolError | RPEIncompatibleEncoding | RPEUnexpectedFile | RPENoFile - | RPEFileTooLarge + | RPEFileSize + | RPEFileDigest | RPEUnexpectedResponse {response :: Text} -- ^ Wrong response received for the command sent | RPEStoredFileExists -- ^ A file already exists in the destination position | RPEHTTP2 {http2Error :: Text} @@ -87,7 +90,14 @@ data RemoteCtrlInfo = RemoteCtrlInfo } deriving (Show) --- TODO: put into a proper place +data RemoteFile = RemoteFile + { userId :: Int64, + fileId :: Int64, + sent :: Bool, + fileSource :: CryptoFile + } + deriving (Show) + data PlatformEncoding = PESwift | PEKotlin @@ -122,3 +132,5 @@ $(J.deriveJSON defaultJSON ''RemoteHostInfo) $(J.deriveJSON defaultJSON ''RemoteCtrl) $(J.deriveJSON defaultJSON ''RemoteCtrlInfo) + +$(J.deriveJSON defaultJSON ''RemoteFile) diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs index a710696dad..95e586919d 100644 --- a/src/Simplex/Chat/Store/Files.hs +++ b/src/Simplex/Chat/Store/Files.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -71,6 +72,7 @@ module Simplex.Chat.Store.Files getSndFileTransfer, getSndFileTransfers, getContactFileInfo, + getLocalCryptoFile, updateDirectCIFileStatus, ) where @@ -602,7 +604,10 @@ getRcvFileTransferById db fileId = do (user,) <$> getRcvFileTransfer db user fileId getRcvFileTransfer :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO RcvFileTransfer -getRcvFileTransfer db User {userId} fileId = do +getRcvFileTransfer db User {userId} = getRcvFileTransfer_ db userId + +getRcvFileTransfer_ :: DB.Connection -> UserId -> FileTransferId -> ExceptT StoreError IO RcvFileTransfer +getRcvFileTransfer_ db userId fileId = do rftRow <- ExceptT . firstRow id (SERcvFileNotFound fileId) $ DB.query @@ -808,25 +813,26 @@ getFileTransferProgress db user fileId = do getFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransfer getFileTransfer db user@User {userId} fileId = - fileTransfer =<< liftIO getFileTransferRow + fileTransfer =<< liftIO (getFileTransferRow_ db userId fileId) where fileTransfer :: [(Maybe Int64, Maybe Int64)] -> ExceptT StoreError IO FileTransfer fileTransfer [(Nothing, Just _)] = FTRcv <$> getRcvFileTransfer db user fileId fileTransfer _ = do (ftm, fts) <- getSndFileTransfer db user fileId pure $ FTSnd {fileTransferMeta = ftm, sndFileTransfers = fts} - getFileTransferRow :: IO [(Maybe Int64, Maybe Int64)] - getFileTransferRow = - DB.query - db - [sql| - SELECT s.file_id, r.file_id - FROM files f - LEFT JOIN snd_files s ON s.file_id = f.file_id - LEFT JOIN rcv_files r ON r.file_id = f.file_id - WHERE user_id = ? AND f.file_id = ? - |] - (userId, fileId) + +getFileTransferRow_ :: DB.Connection -> UserId -> Int64 -> IO [(Maybe Int64, Maybe Int64)] +getFileTransferRow_ db userId fileId = + DB.query + db + [sql| + SELECT s.file_id, r.file_id + FROM files f + LEFT JOIN snd_files s ON s.file_id = f.file_id + LEFT JOIN rcv_files r ON r.file_id = f.file_id + WHERE user_id = ? AND f.file_id = ? + |] + (userId, fileId) getSndFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer]) getSndFileTransfer db user fileId = do @@ -861,7 +867,10 @@ getSndFileTransfers_ db userId fileId = Nothing -> Left $ SESndFileInvalid fileId getFileTransferMeta :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransferMeta -getFileTransferMeta db User {userId} fileId = +getFileTransferMeta db User {userId} = getFileTransferMeta_ db userId + +getFileTransferMeta_ :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO FileTransferMeta +getFileTransferMeta_ db userId fileId = ExceptT . firstRow fileTransferMeta (SEFileNotFound fileId) $ DB.query db @@ -883,6 +892,20 @@ getContactFileInfo db User {userId} Contact {contactId} = map toFileInfo <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ?") (userId, contactId) +getLocalCryptoFile :: DB.Connection -> UserId -> Int64 -> Bool -> ExceptT StoreError IO CryptoFile +getLocalCryptoFile db userId fileId sent = + liftIO (getFileTransferRow_ db userId fileId) >>= \case + [(Nothing, Just _)] -> do + when sent $ throwError $ SEFileNotFound fileId + RcvFileTransfer {fileStatus, cryptoArgs} <- getRcvFileTransfer_ db userId fileId + case fileStatus of + RFSComplete RcvFileInfo {filePath} -> pure $ CryptoFile filePath cryptoArgs + _ -> throwError $ SEFileNotFound fileId + _ -> do + unless sent $ throwError $ SEFileNotFound fileId + FileTransferMeta {filePath, xftpSndFile} <- getFileTransferMeta_ db userId fileId + pure $ CryptoFile filePath $ xftpSndFile >>= \f -> f.cryptoArgs + updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem updateDirectCIFileStatus db user fileId fileStatus = do aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 2a3b74da37..9ae00159b7 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -14,6 +14,7 @@ module Simplex.Chat.View where import qualified Data.Aeson as J import qualified Data.Aeson.TH as JQ import qualified Data.ByteString.Char8 as B +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isSpace, toUpper) import Data.Function (on) @@ -76,7 +77,7 @@ serializeChatResponse :: (Maybe RemoteHostId, Maybe User) -> CurrentTime -> Time serializeChatResponse user_ ts tz remoteHost_ = unlines . map unStyle . responseToView user_ defaultChatConfig False ts tz remoteHost_ responseToView :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> [StyledString] -responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showReceipts, testView} liveItems ts tz outputRH = \case +responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showReceipts, testView} liveItems ts tz outputRH = \case CRActiveUser User {profile} -> viewUserProfile $ fromLocalProfile profile CRUsersList users -> viewUsersList users CRChatStarted -> ["chat started"] @@ -185,10 +186,10 @@ responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showRecei CRContactUpdated {user = u, fromContact = c, toContact = c'} -> ttyUser u $ viewContactUpdated c c' <> viewContactPrefsUpdated u c c' CRContactsMerged u intoCt mergedCt ct' -> ttyUser u $ viewContactsMerged intoCt mergedCt ct' CRReceivedContactRequest u UserContactRequest {localDisplayName = c, profile} -> ttyUser u $ viewReceivedContactRequest c profile - CRRcvFileStart u ci -> ttyUser u $ receivingFile_' testView "started" ci - CRRcvFileComplete u ci -> ttyUser u $ receivingFile_' testView "completed" ci + CRRcvFileStart u ci -> ttyUser u $ receivingFile_' hu testView "started" ci + CRRcvFileComplete u ci -> ttyUser u $ receivingFile_' hu testView "completed" ci CRRcvFileSndCancelled u _ ft -> ttyUser u $ viewRcvFileSndCancelled ft - CRRcvFileError u ci e -> ttyUser u $ receivingFile_' testView "error" ci <> [sShow e] + CRRcvFileError u ci e -> ttyUser u $ receivingFile_' hu testView "error" ci <> [sShow e] CRSndFileStart u _ ft -> ttyUser u $ sendingFile_ "started" ft CRSndFileComplete u _ ft -> ttyUser u $ sendingFile_ "completed" ft CRSndFileStartXFTP {} -> [] @@ -272,6 +273,9 @@ responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showRecei CRRemoteHostList hs -> viewRemoteHosts hs CRRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} -> ["remote host " <> sShow rhId <> " connected"] CRRemoteHostStopped rhId -> ["remote host " <> sShow rhId <> " stopped"] + CRRemoteFileStored rhId (CryptoFile filePath cfArgs_) -> + [plain $ "file " <> filePath <> " stored on remote host " <> show rhId] + <> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_ CRRemoteCtrlList cs -> viewRemoteCtrls cs CRRemoteCtrlRegistered RemoteCtrlInfo {remoteCtrlId = rcId} -> ["remote controller " <> sShow rcId <> " registered"] CRRemoteCtrlAnnounce fingerprint -> ["remote controller announced", "connection code:", plain $ strEncode fingerprint] @@ -1493,18 +1497,25 @@ savingFile' (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileSource ["saving file " <> sShow fileId <> fileFrom chat chatDir <> " to " <> plain filePath] savingFile' _ = ["saving file"] -- shouldn't happen -receivingFile_' :: Bool -> String -> AChatItem -> [StyledString] -receivingFile_' testView status (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileName, fileSource = Just (CryptoFile _ cfArgs_)}, chatDir}) = - [plain status <> " receiving " <> fileTransferStr fileId fileName <> fileFrom chat chatDir] <> cfArgsStr cfArgs_ +receivingFile_' :: (Maybe RemoteHostId, Maybe User) -> Bool -> String -> AChatItem -> [StyledString] +receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileName, fileSource = Just f@(CryptoFile _ cfArgs_)}, chatDir}) = + [plain status <> " receiving " <> fileTransferStr fileId fileName <> fileFrom chat chatDir] <> cfArgsStr cfArgs_ <> getRemoteFileStr where - cfArgsStr (Just cfArgs@(CFArgs key nonce)) = [plain s | status == "completed"] - where - s = - if testView - then LB.toStrict $ J.encode cfArgs - else "encryption key: " <> strEncode key <> ", nonce: " <> strEncode nonce + cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"] cfArgsStr _ = [] -receivingFile_' _ status _ = [plain status <> " receiving file"] -- shouldn't happen + getRemoteFileStr = case hu of + (Just rhId, Just User {userId}) | status == "completed" -> + [ "File received to connected remote host " <> sShow rhId, + "To download to this device use:", + highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f})) + ] + _ -> [] +receivingFile_' _ _ status _ = [plain status <> " receiving file"] -- shouldn't happen + +cryptoFileArgsStr :: Bool -> CryptoFileArgs -> ByteString +cryptoFileArgsStr testView cfArgs@(CFArgs key nonce) + | testView = LB.toStrict $ J.encode cfArgs + | otherwise = "encryption key: " <> strEncode key <> ", nonce: " <> strEncode nonce fileFrom :: ChatInfo c -> CIDirection c d -> StyledString fileFrom (DirectChat ct) CIDirectRcv = " from " <> ttyContact' ct @@ -1818,8 +1829,8 @@ viewChatError logLevel = \case Nothing -> "" cId :: Connection -> StyledString cId conn = sShow conn.connId - ChatErrorRemoteCtrl todo'rc -> [sShow todo'rc] - ChatErrorRemoteHost remoteHostId todo'rh -> [sShow remoteHostId, sShow todo'rh] + ChatErrorRemoteCtrl e -> [plain $ "remote controller error: " <> show e] + ChatErrorRemoteHost rhId e -> [plain $ "remote host " <> show rhId <> " error: " <> show e] where fileNotFound fileId = ["file " <> sShow fileId <> " not found"] sqliteError' = \case diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index 452f9ca21d..be1d3c1a2e 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -9,7 +9,9 @@ import ChatClient import ChatTests.Utils import Control.Logger.Simple import Control.Monad +import qualified Data.Aeson as J import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy.Char8 as LB import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M import Network.HTTP.Types (ok200) @@ -17,10 +19,14 @@ import qualified Network.HTTP2.Client as C import qualified Network.HTTP2.Server as S import qualified Network.Socket as N import qualified Network.TLS as TLS +import Simplex.Chat.Archive (archiveFilesFolder) +import Simplex.Chat.Controller (ChatConfig (..), XFTPFileConfig (..)) import qualified Simplex.Chat.Controller as Controller +import Simplex.Chat.Mobile.File import Simplex.Chat.Remote.Types import qualified Simplex.Chat.Remote.Discovery as Discovery import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) import Simplex.Messaging.Encoding.String import qualified Simplex.Messaging.Transport as Transport import Simplex.Messaging.Transport.Client (TransportHost (..)) @@ -28,7 +34,7 @@ import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Response (..), closeHTTP2Client, sendRequest) import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..)) import Simplex.Messaging.Util -import System.FilePath (makeRelative, (>)) +import System.FilePath ((>)) import Test.Hspec import UnliftIO import UnliftIO.Concurrent @@ -41,7 +47,9 @@ remoteTests = describe "Remote" $ do it "performs protocol handshake" remoteHandshakeTest it "performs protocol handshake (again)" remoteHandshakeTest -- leaking servers regression check it "sends messages" remoteMessageTest - xit "sends files" remoteFileTest + describe "remote files" $ do + it "store/get/send/receive files" remoteStoreFileTest + it "should sends files from CLI wihtout /store" remoteCLIFileTest -- * Low-level TLS with ephemeral credentials @@ -159,32 +167,158 @@ remoteMessageTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mob threadDelay 1000000 logNote "done" -remoteFileTest :: (HasCallStack) => FilePath -> IO () -remoteFileTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do +remoteStoreFileTest :: HasCallStack => FilePath -> IO () +remoteStoreFileTest = + testChatCfg3 cfg aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> + withXFTPServer $ do + let mobileFiles = "./tests/tmp/mobile_files" + mobile ##> ("/_files_folder " <> mobileFiles) + mobile <## "ok" + let desktopFiles = "./tests/tmp/desktop_files" + desktop ##> ("/_files_folder " <> desktopFiles) + desktop <## "ok" + let desktopHostFiles = "./tests/tmp/remote_hosts_data" + desktop ##> ("/remote_hosts_folder " <> desktopHostFiles) + desktop <## "ok" + let bobFiles = "./tests/tmp/bob_files" + bob ##> ("/_files_folder " <> bobFiles) + bob <## "ok" + startRemote mobile desktop + contactBob desktop bob + rhs <- readTVarIO (Controller.remoteHostSessions $ chatController desktop) + desktopHostStore <- case M.lookup 1 rhs of + Just RemoteHostSession {storePath} -> pure $ desktopHostFiles > storePath > archiveFilesFolder + _ -> fail "Host session 1 should be started" + desktop ##> "/store remote file 1 tests/fixtures/test.pdf" + desktop <## "file test.pdf stored on remote host 1" + src <- B.readFile "tests/fixtures/test.pdf" + B.readFile (mobileFiles > "test.pdf") `shouldReturn` src + B.readFile (desktopHostStore > "test.pdf") `shouldReturn` src + desktop ##> "/store remote file 1 tests/fixtures/test.pdf" + desktop <## "file test_1.pdf stored on remote host 1" + B.readFile (mobileFiles > "test_1.pdf") `shouldReturn` src + B.readFile (desktopHostStore > "test_1.pdf") `shouldReturn` src + desktop ##> "/store remote file 1 encrypt=on tests/fixtures/test.pdf" + desktop <## "file test_2.pdf stored on remote host 1" + Just cfArgs@(CFArgs key nonce) <- J.decode . LB.pack <$> getTermLine desktop + chatReadFile (mobileFiles > "test_2.pdf") (strEncode key) (strEncode nonce) `shouldReturn` Right (LB.fromStrict src) + chatReadFile (desktopHostStore > "test_2.pdf") (strEncode key) (strEncode nonce) `shouldReturn` Right (LB.fromStrict src) + + removeFile (desktopHostStore > "test_1.pdf") + removeFile (desktopHostStore > "test_2.pdf") + + -- cannot get file before it is used + desktop ##> "/get remote file 1 {\"userId\": 1, \"fileId\": 1, \"sent\": true, \"fileSource\": {\"filePath\": \"test_1.pdf\"}}" + hostError desktop "SEFileNotFound" + -- send file not encrypted locally on mobile host + desktop ##> "/_send @2 json {\"filePath\": \"test_1.pdf\", \"msgContent\": {\"type\": \"file\", \"text\": \"sending a file\"}}" + desktop <# "@bob sending a file" + desktop <# "/f @bob test_1.pdf" + desktop <## "use /fc 1 to cancel sending" + bob <# "alice> sending a file" + bob <# "alice> sends file test_1.pdf (266.0 KiB / 272376 bytes)" + bob <## "use /fr 1 [