From c031d51b3eb975b8c85ce2d09a600acb98964e16 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 14 Mar 2023 17:52:45 +0000 Subject: [PATCH 1/3] xftp: use agent servers in experimental send, refactor decryption --- simplexmq.cabal | 1 + src/Simplex/FileTransfer/Agent.hs | 43 ++++++------------------- src/Simplex/FileTransfer/Client/Main.hs | 33 +++++++------------ src/Simplex/FileTransfer/Crypto.hs | 42 ++++++++++++++++++++++++ 4 files changed, 64 insertions(+), 55 deletions(-) create mode 100644 src/Simplex/FileTransfer/Crypto.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index dad233141..cd0da9b3c 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -40,6 +40,7 @@ library Simplex.FileTransfer.Client.Agent Simplex.FileTransfer.Client.Main Simplex.FileTransfer.Client.Presets + Simplex.FileTransfer.Crypto Simplex.FileTransfer.Description Simplex.FileTransfer.Protocol Simplex.FileTransfer.Server diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index b485f2844..a71026dcb 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -25,17 +25,15 @@ import Control.Monad import Control.Monad.Except import Control.Monad.Reader import Crypto.Random (ChaChaDRG, randomBytesGenerate) -import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Base64.URL as U import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LB -import Data.Int (Int64) import Data.List (isSuffixOf, partition) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as L import Simplex.FileTransfer.Client.Main (CLIError, SendOptions (..), cliSendFile) +import Simplex.FileTransfer.Crypto import Simplex.FileTransfer.Description import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI) import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) @@ -46,12 +44,10 @@ import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store.SQLite -import qualified Simplex.Messaging.Crypto.Lazy as LC -import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (XFTPServer) +import Simplex.Messaging.Protocol (XFTPServer, XFTPServerWithAuth) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (liftIOEither, tshow) +import Simplex.Messaging.Util (liftError, liftIOEither, tshow) import System.FilePath (takeFileName, ()) import UnliftIO import UnliftIO.Concurrent @@ -174,7 +170,7 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting chunkPaths <- getChunkPaths chunks encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths - decrypt encSize chunkPaths + void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure savePath forM_ tmpPath removePath withStore' c (`updateRcvFileComplete` rcvFileId) notify RFDONE @@ -192,38 +188,19 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do pure $ path : ps getChunkPaths (RcvFileChunk {chunkTmpPath = Nothing} : _cs) = throwError $ INTERNAL "no chunk path" - -- TODO refactor with decrypt in CLI, streaming decryption - decrypt :: Int64 -> [FilePath] -> m () - decrypt encSize chunkPaths = do - lazyChunks <- liftIO $ readChunks chunkPaths - (authOk, f) <- liftEither . first cryptoError $ LC.sbDecryptTailTag key nonce (encSize - authTagSize) lazyChunks - let (fileHdr, f') = LB.splitAt 1024 f - -- withFile encPath ReadMode $ \r -> do - -- fileHdr <- liftIO $ B.hGet r 1024 - case A.parse smpP $ LB.toStrict fileHdr of - -- TODO XFTP errors - A.Fail _ _ e -> throwError $ INTERNAL $ "Invalid file header: " <> e - A.Partial _ -> throwError $ INTERNAL "Invalid file header" - A.Done rest FileHeader {fileName = _fn} -> do - -- ? check file name match - liftIO $ LB.writeFile savePath $ LB.fromStrict rest <> f' - unless authOk $ do - removeFile savePath - throwError $ INTERNAL "Error decrypting file: incorrect auth tag" - readChunks :: [FilePath] -> IO LB.ByteString - readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) "" sendFileExperimental :: forall m. AgentMonad m => AgentClient -> UserId -> FilePath -> Int -> Maybe FilePath -> m SndFileId -sendFileExperimental AgentClient {subQ} _userId filePath numRecipients xftpWorkPath = do +sendFileExperimental AgentClient {subQ, xftpServers} userId filePath numRecipients xftpWorkPath = do g <- asks idsDrg sndFileId <- liftIO $ randomId g 12 - void $ forkIO $ sendCLI sndFileId + xftpSrvs <- atomically $ TM.lookup userId xftpServers + void $ forkIO $ sendCLI sndFileId $ maybe [] L.toList xftpSrvs pure sndFileId where randomId :: TVar ChaChaDRG -> Int -> IO ByteString randomId gVar n = U.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n) - sendCLI :: SndFileId -> m () - sendCLI sndFileId = do + sendCLI :: SndFileId -> [XFTPServerWithAuth] -> m () + sendCLI sndFileId xftpSrvs = do let fileName = takeFileName filePath workPath <- maybe getTemporaryDirectory pure xftpWorkPath outputDir <- uniqueCombine workPath $ fileName <> ".descr" @@ -235,7 +212,7 @@ sendFileExperimental AgentClient {subQ} _userId filePath numRecipients xftpWorkP { filePath, outputDir = Just outputDir, numRecipients, - xftpServers = [], + xftpServers = xftpSrvs, retryCount = 3, tempPath = Just tempPath, verbose = False diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 6ac46ae61..b2ef99be6 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -44,6 +44,7 @@ import Options.Applicative import Simplex.FileTransfer.Client import Simplex.FileTransfer.Client.Agent import Simplex.FileTransfer.Client.Presets +import Simplex.FileTransfer.Crypto import Simplex.FileTransfer.Description import Simplex.FileTransfer.Protocol import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) @@ -88,6 +89,13 @@ fileSizeLen = 8 newtype CLIError = CLIError String deriving (Eq, Show, Exception) +cliCryptoError :: FTCryptoError -> CLIError +cliCryptoError = \case + FTCEDecryptionError e -> CLIError $ "Error decrypting file: " <> show e + FTCEInvalidHeader e -> CLIError $ "Invalid file header: " <> e + FTCEInvalidAuthTag -> CLIError "Error decrypting file: incorrect auth tag" + FTCEFileIOError e -> CLIError $ "File IO error: " <> show e + data CliCommand = SendFile SendOptions | ReceiveFile ReceiveOptions @@ -420,7 +428,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths when (FileSize encSize /= size) $ throwError $ CLIError "File size mismatch" liftIO $ printNoNewLine "Decrypting file..." - path <- decryptFile encSize chunkPaths key nonce + path <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce getFilePath forM_ chunks $ acknowledgeFileChunk a whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath liftIO $ do @@ -441,31 +449,12 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, when verbose $ putStrLn "" pure (chunkNo, chunkPath) downloadFileChunk _ _ _ _ _ = throwError $ CLIError "chunk has no replicas" - decryptFile :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath - decryptFile encSize chunkPaths key nonce = do - (authOk, f) <- liftEither . first (CLIError . show) . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (readChunks chunkPaths) - let (fileHdr, f') = LB.splitAt 1024 f - -- withFile encPath ReadMode $ \r -> do - -- fileHdr <- liftIO $ B.hGet r 1024 - case A.parse smpP $ LB.toStrict fileHdr of - A.Fail _ _ e -> throwError $ CLIError $ "Invalid file header: " <> e - A.Partial _ -> throwError $ CLIError "Invalid file header" - A.Done rest FileHeader {fileName} -> do - path <- getFilePath fileName - liftIO $ LB.writeFile path $ LB.fromStrict rest <> f' - unless authOk $ do - removeFile path - throwError $ CLIError "Error decrypting file: incorrect auth tag" - pure path - readChunks :: [FilePath] -> IO LB.ByteString - readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) "" - {-# NOINLINE readChunks #-} - getFilePath :: String -> ExceptT CLIError IO FilePath + getFilePath :: String -> ExceptT String IO FilePath getFilePath name = case filePath of Just path -> ifM (doesDirectoryExist path) (uniqueCombine path name) $ - ifM (doesFileExist path) (throwError $ CLIError "File already exists") (pure path) + ifM (doesFileExist path) (throwError "File already exists") (pure path) _ -> (`uniqueCombine` name) . ( "Downloads") =<< getHomeDirectory acknowledgeFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO () acknowledgeFileChunk a FileChunk {replicas = replica : _} = do diff --git a/src/Simplex/FileTransfer/Crypto.hs b/src/Simplex/FileTransfer/Crypto.hs new file mode 100644 index 000000000..53fdb5856 --- /dev/null +++ b/src/Simplex/FileTransfer/Crypto.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.FileTransfer.Crypto where + +import Control.Monad.Except +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bifunctor (first) +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Int (Int64) +import Simplex.FileTransfer.Types (FileHeader (..), authTagSize) +import qualified Simplex.Messaging.Crypto as C +import qualified Simplex.Messaging.Crypto.Lazy as LC +import Simplex.Messaging.Encoding +import UnliftIO.Directory (removeFile) + +decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO String) -> ExceptT FTCryptoError IO FilePath +decryptChunks encSize chunkPaths key nonce getFilePath = do + (authOk, f) <- liftEither . first FTCEDecryptionError . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (readChunks chunkPaths) + let (fileHdr, f') = LB.splitAt 1024 f + -- withFile encPath ReadMode $ \r -> do + -- fileHdr <- liftIO $ B.hGet r 1024 + case A.parse smpP $ LB.toStrict fileHdr of + A.Fail _ _ e -> throwError $ FTCEInvalidHeader e + A.Partial _ -> throwError $ FTCEInvalidHeader "incomplete" + A.Done rest FileHeader {fileName} -> do + path <- withExceptT FTCEFileIOError $ getFilePath fileName + liftIO $ LB.writeFile path $ LB.fromStrict rest <> f' + unless authOk $ do + removeFile path + throwError FTCEInvalidAuthTag + pure path + +readChunks :: [FilePath] -> IO LB.ByteString +readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) "" + +data FTCryptoError + = FTCEDecryptionError C.CryptoError + | FTCEInvalidHeader String + | FTCEInvalidAuthTag + | FTCEFileIOError String + deriving (Show, Eq) From 20fa63d0bbbae80ede89b29f9aca9744ab195439 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 14 Mar 2023 18:09:13 +0000 Subject: [PATCH 2/3] fix/enable xftp send test test --- tests/SMPAgentClient.hs | 6 ++---- tests/XFTPAgent.hs | 5 ++--- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 053f973e7..bcb9d080a 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -31,12 +31,13 @@ import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Server (runSMPAgentBlocking) import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig) import Simplex.Messaging.Parsers (parseAll) -import Simplex.Messaging.Protocol (ProtoServerWithAuth, XFTPServer) +import Simplex.Messaging.Protocol (ProtoServerWithAuth) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import Test.Hspec import UnliftIO.Concurrent import UnliftIO.Directory +import XFTPClient (testXFTPServer) agentTestHost :: NonEmpty TransportHost agentTestHost = "localhost" @@ -173,9 +174,6 @@ testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:50 testSMPServer2 :: SMPServer testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5002" -testXFTPServer :: XFTPServer -testXFTPServer = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001" - initAgentServers :: InitialAgentServers initAgentServers = InitialAgentServers diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 8e2d149bc..ed188a656 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -29,7 +29,7 @@ xftpAgentTests = around_ testBracket . describe "Functional API" $ do it "should receive file" testXFTPAgentReceive it "should resume receiving file after restart" testXFTPAgentReceiveRestore it "should cleanup tmp path after permanent error" testXFTPAgentReceiveCleanup - xit "should send file using experimental api" testXFTPAgentSendExperimental -- TODO uses default servers (remote) + it "should send file using experimental api" testXFTPAgentSendExperimental -- TODO uses default servers (remote) testXFTPAgentReceive :: IO () testXFTPAgentReceive = withXFTPServer $ do @@ -153,8 +153,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do doesDirectoryExist (recipientFiles "xftp.encrypted") `shouldReturn` False testXFTPAgentSendExperimental :: IO () --- testXFTPAgentSendExperimental = withXFTPServer $ do -testXFTPAgentSendExperimental = do +testXFTPAgentSendExperimental = withXFTPServer $ do -- create random file using cli let filePath = senderFiles "testfile" xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath] From 0130e26316d2dddf70f48e7c5762b025e93d5920 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 14 Mar 2023 19:35:44 +0000 Subject: [PATCH 3/3] allow any order --- tests/XFTPAgent.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index ed188a656..db04e1d20 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -170,7 +170,7 @@ testXFTPAgentSendExperimental = withXFTPServer $ do strDecode <$> B.readFile (senderFiles "testfile.descr/testfile.xftp/snd.xftp.private") `shouldReturn` Right sndDescr Right rfd1 <- strDecode <$> B.readFile (senderFiles "testfile.descr/testfile.xftp/rcv1.xftp") Right rfd2 <- strDecode <$> B.readFile (senderFiles "testfile.descr/testfile.xftp/rcv2.xftp") - rcvDescrs `shouldBe` [rfd1, rfd2] + rcvDescrs `shouldMatchList` [rfd1, rfd2] pure rfd1 -- receive file using agent