xftp: use agent servers in experimental send, refactor decryption (#686)

* xftp: use agent servers in experimental send, refactor decryption

* fix/enable xftp send test test

* allow any order

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

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

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

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)

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

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]
@@ -171,7 +170,7 @@ testXFTPAgentSendExperimental = 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