Merge branch 'master' into master-ghc9

apps/smp-server/Main.hs

@@ -3,7 +3,6 @@
 module Main where
 
 import Control.Logger.Simple
-import Data.Maybe
 import Simplex.Messaging.Server.Main
 import System.Environment
 

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.4.0.1
+version: 5.4.0.2
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.4.0.1
+version:        5.4.0.2
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -35,6 +35,7 @@ flag swift
 library
   exposed-modules:
       Simplex.FileTransfer.Agent
+      Simplex.FileTransfer.Chunks
       Simplex.FileTransfer.Client
       Simplex.FileTransfer.Client.Agent
       Simplex.FileTransfer.Client.Main
@@ -89,11 +90,13 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
       Simplex.Messaging.Agent.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
       Simplex.Messaging.Crypto
+      Simplex.Messaging.Crypto.File
       Simplex.Messaging.Crypto.Lazy
       Simplex.Messaging.Crypto.Ratchet
       Simplex.Messaging.Encoding
@@ -536,6 +539,7 @@ test-suite simplexmq-test
       AgentTests.SQLiteTests
       CLITests
       CoreTests.BatchingTests
+      CoreTests.CryptoFileTests
       CoreTests.CryptoTests
       CoreTests.EncodingTests
       CoreTests.ProtocolErrorTests

src/Simplex/FileTransfer/Agent.hs

@@ -55,6 +55,8 @@ import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
+import qualified Simplex.Messaging.Crypto.File as CF
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol (EntityId, XFTPServer)
@@ -101,8 +103,8 @@ closeXFTPAgent XFTPAgent {xftpRcvWorkers, xftpSndWorkers} = do
       ws <- atomically $ stateTVar wsSel (,M.empty)
       mapM_ (uninterruptibleCancel . snd) ws
 
-xftpReceiveFile' :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> m RcvFileId
-xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks}) = do
+xftpReceiveFile' :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> m RcvFileId
+xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks}) cfArgs = do
   g <- asks idsDrg
   prefixPath <- getPrefixPath "rcv.xftp"
   createDirectory prefixPath
@@ -111,7 +113,8 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks}) = d
       relSavePath = relPrefixPath </> "xftp.decrypted"
   createDirectory =<< toFSFilePath relTmpPath
   createEmptyFile =<< toFSFilePath relSavePath
-  fId <- withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath relSavePath
+  let saveFile = CryptoFile relSavePath cfArgs
+  fId <- withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile
   forM_ chunks downloadChunk
   pure fId
   where
@@ -245,14 +248,16 @@ runXFTPRcvLocalWorker c doWork = do
           decryptFile f `catchAgentError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
     decryptFile :: RcvFile -> m ()
-    decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, savePath, status, chunks} = do
+    decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, saveFile, status, chunks} = do
+      let CryptoFile savePath cfArgs = saveFile
       fsSavePath <- toFSFilePath savePath
       when (status == RFSDecrypting) $
         whenM (doesFileExist fsSavePath) (removeFile fsSavePath >> createEmptyFile fsSavePath)
       withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting
       chunkPaths <- getChunkPaths chunks
       encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
-      void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure fsSavePath
+      let destFile = CryptoFile fsSavePath cfArgs
+      void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure destFile
       notify c rcvFileEntityId $ RFDONE fsSavePath
       forM_ tmpPath (removePath <=< toFSFilePath)
       atomically $ waitUntilForeground c
@@ -279,16 +284,16 @@ xftpDeleteRcvFile' c rcvFileEntityId = do
 notify :: forall m e. (MonadUnliftIO m, AEntityI e) => AgentClient -> EntityId -> ACommand 'Agent e -> m ()
 notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, APC (sAEntity @e) cmd)
 
-xftpSendFile' :: AgentMonad m => AgentClient -> UserId -> FilePath -> Int -> m SndFileId
-xftpSendFile' c userId filePath numRecipients = do
+xftpSendFile' :: AgentMonad m => AgentClient -> UserId -> CryptoFile -> Int -> m SndFileId
+xftpSendFile' c userId file numRecipients = do
   g <- asks idsDrg
   prefixPath <- getPrefixPath "snd.xftp"
   createDirectory prefixPath
   let relPrefixPath = takeFileName prefixPath
   key <- liftIO C.randomSbKey
   nonce <- liftIO C.randomCbNonce
   -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window
-  fId <- withStore c $ \db -> createSndFile db g userId numRecipients filePath relPrefixPath key nonce
+  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce
   addXFTPSndWorker c Nothing
   pure fId
 
@@ -334,16 +339,17 @@ runXFTPSndPrepareWorker c doWork = do
       withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading
       where
         encryptFileForUpload :: SndFile -> FilePath -> m (FileDigest, [(XFTPChunkSpec, FileDigest)])
-        encryptFileForUpload SndFile {key, nonce, filePath} fsEncPath = do
-          let fileName = takeFileName filePath
-          fileSize <- fromInteger <$> getFileSize filePath
+        encryptFileForUpload SndFile {key, nonce, srcFile} fsEncPath = do
+          let CryptoFile {filePath} = srcFile
+              fileName = takeFileName filePath
+          fileSize <- liftIO $ fromInteger <$> CF.getFileContentsSize srcFile
           when (fileSize > maxFileSize) $ throwError $ INTERNAL "max file size exceeded"
           let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
               fileSize' = fromIntegral (B.length fileHdr) + fileSize
               chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize
               chunkSizes' = map fromIntegral chunkSizes
               encSize = sum chunkSizes'
-          void $ liftError (INTERNAL . show) $ encryptFile filePath fileHdr key nonce fileSize' encSize fsEncPath
+          void $ liftError (INTERNAL . show) $ encryptFile srcFile fileHdr key nonce fileSize' encSize fsEncPath
           digest <- liftIO $ LC.sha512Hash <$> LB.readFile fsEncPath
           let chunkSpecs = prepareChunkSpecs fsEncPath chunkSizes
           chunkDigests <- map FileDigest <$> mapM (liftIO . getChunkDigest) chunkSpecs

src/Simplex/FileTransfer/Chunks.hs

@@ -0,0 +1,35 @@
+module Simplex.FileTransfer.Chunks where
+
+import Data.Word (Word32)
+
+serverChunkSizes :: [Word32]
+serverChunkSizes = [chunkSize0, chunkSize1, chunkSize2, chunkSize3]
+{-# INLINE serverChunkSizes #-}
+
+chunkSize0 :: Word32
+chunkSize0 = kb 64
+{-# INLINE chunkSize0 #-}
+
+chunkSize1 :: Word32
+chunkSize1 = kb 256
+{-# INLINE chunkSize1 #-}
+
+chunkSize2 :: Word32
+chunkSize2 = mb 1
+{-# INLINE chunkSize2 #-}
+
+chunkSize3 :: Word32
+chunkSize3 = mb 4
+{-# INLINE chunkSize3 #-}
+
+kb :: Integral a => a -> a
+kb n = 1024 * n
+{-# INLINE kb #-}
+
+mb :: Integral a => a -> a
+mb n = 1024 * kb n
+{-# INLINE mb #-}
+
+gb :: Integral a => a -> a
+gb n = 1024 * mb n
+{-# INLINE gb #-}

src/Simplex/FileTransfer/Client/Main.hs

@@ -20,9 +20,6 @@ module Simplex.FileTransfer.Client.Main
     cliSendFileOpts,
     prepareChunkSizes,
     prepareChunkSpecs,
-    chunkSize1,
-    chunkSize2,
-    chunkSize3,
     maxFileSize,
     fileSizeLen,
     getChunkDigest,
@@ -51,6 +48,7 @@ import qualified Data.Text as T
 import Data.Word (Word32)
 import GHC.Records (HasField (getField))
 import Options.Applicative
+import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Client.Agent
 import Simplex.FileTransfer.Client.Presets
@@ -61,6 +59,8 @@ import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
 import Simplex.FileTransfer.Types
 import Simplex.FileTransfer.Util (uniqueCombine)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.File (CryptoFile (..), FTCryptoError (..))
+import qualified Simplex.Messaging.Crypto.File as CF
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
@@ -78,15 +78,6 @@ import UnliftIO.Directory
 xftpClientVersion :: String
 xftpClientVersion = "1.0.1"
 
-chunkSize1 :: Word32
-chunkSize1 = kb 256
-
-chunkSize2 :: Word32
-chunkSize2 = mb 1
-
-chunkSize3 :: Word32
-chunkSize3 = mb 4
-
 maxFileSize :: Int64
 maxFileSize = gb 1
 
@@ -104,6 +95,7 @@ cliCryptoError = \case
   FTCECryptoError e -> CLIError $ "Error decrypting file: " <> show e
   FTCEInvalidHeader e -> CLIError $ "Invalid file header: " <> e
   FTCEInvalidAuthTag -> CLIError "Error decrypting file: incorrect auth tag"
+  FTCEInvalidFileSize -> CLIError "Error decrypting file: incorrect file size"
   FTCEFileIOError e -> CLIError $ "File IO error: " <> show e
 
 data CliCommand
@@ -303,7 +295,8 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
           defChunkSize = head chunkSizes
           chunkSizes' = map fromIntegral chunkSizes
           encSize = sum chunkSizes'
-      withExceptT (CLIError . show) $ encryptFile filePath fileHdr key nonce fileSize' encSize encPath
+          srcFile = CF.plain filePath
+      withExceptT (CLIError . show) $ encryptFile srcFile fileHdr key nonce fileSize' encSize encPath
       digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
       let chunkSpecs = prepareChunkSpecs encPath chunkSizes
           fdRcv = FileDescription {party = SFRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
@@ -436,7 +429,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 <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce getFilePath
+      CryptoFile path _ <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce $ fmap CF.plain . getFilePath
       forM_ chunks $ acknowledgeFileChunk a
       whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
       liftIO $ do
@@ -531,7 +524,11 @@ getFileDescription' path =
 prepareChunkSizes :: Int64 -> [Word32]
 prepareChunkSizes size' = prepareSizes size'
   where
-    (smallSize, bigSize) = if size' > size34 chunkSize3 then (chunkSize2, chunkSize3) else (chunkSize1, chunkSize2)
+    (smallSize, bigSize)
+      | size' > size34 chunkSize3 = (chunkSize2, chunkSize3)
+      | otherwise = (chunkSize1, chunkSize2)
+      --  | size' > size34 chunkSize2 = (chunkSize1, chunkSize2)
+      --  | otherwise = (chunkSize0, chunkSize1)
     size34 sz = (fromIntegral sz * 3) `div` 4
     prepareSizes 0 = []
     prepareSizes size

src/Simplex/FileTransfer/Crypto.hs

@@ -17,27 +17,30 @@ 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 Simplex.Messaging.Crypto.File (CryptoFile (..), FTCryptoError (..))
+import qualified Simplex.Messaging.Crypto.File as CF
 import Simplex.Messaging.Crypto.Lazy (LazyByteString)
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Util (liftEitherWith)
 import UnliftIO
 import UnliftIO.Directory (removeFile)
 
-encryptFile :: FilePath -> ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT FTCryptoError IO ()
-encryptFile filePath fileHdr key nonce fileSize' encSize encFile = do
+encryptFile :: CryptoFile -> ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT FTCryptoError IO ()
+encryptFile srcFile fileHdr key nonce fileSize' encSize encFile = do
   sb <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce
-  withFile filePath ReadMode $ \r -> withFile encFile WriteMode $ \w -> do
+  CF.withFile srcFile ReadMode $ \r -> withFile encFile WriteMode $ \w -> do
     let lenStr = smpEncode fileSize'
         (hdr, !sb') = LC.sbEncryptChunk sb $ lenStr <> fileHdr
         padLen = encSize - authTagSize - fileSize' - 8
     liftIO $ B.hPut w hdr
     sb2 <- encryptChunks r w (sb', fileSize' - fromIntegral (B.length fileHdr))
+    CF.hGetTag r
     sb3 <- encryptPad w (sb2, padLen)
     let tag = BA.convert $ LC.sbAuth sb3
     liftIO $ B.hPut w tag
   where
-    encryptChunks r = encryptChunks_ $ liftIO . B.hGet r . fromIntegral
+    encryptChunks r = encryptChunks_ $ liftIO . CF.hGet r . fromIntegral
     encryptPad = encryptChunks_ $ \sz -> pure $ B.replicate (fromIntegral sz) '#'
     encryptChunks_ :: (Int64 -> IO ByteString) -> Handle -> (LC.SbState, Int64) -> ExceptT FTCryptoError IO LC.SbState
     encryptChunks_ get w (!sb, !len)
@@ -50,28 +53,28 @@ encryptFile filePath fileHdr key nonce fileSize' encSize encFile = do
         liftIO $ B.hPut w ch'
         encryptChunks_ get w (sb', len - chSize)
 
-decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO String) -> ExceptT FTCryptoError IO FilePath
+decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO CryptoFile) -> ExceptT FTCryptoError IO CryptoFile
 decryptChunks _ [] _ _ _ = throwError $ FTCEInvalidHeader "empty"
-decryptChunks encSize (chPath : chPaths) key nonce getFilePath = case reverse chPaths of
+decryptChunks encSize (chPath : chPaths) key nonce getDestFile = case reverse chPaths of
   [] -> do
     (!authOk, !f) <- liftEither . first FTCECryptoError . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (LB.readFile chPath)
     unless authOk $ throwError FTCEInvalidAuthTag
     (FileHeader {fileName}, !f') <- parseFileHeader f
-    path <- withExceptT FTCEFileIOError $ getFilePath fileName
-    liftIO $ LB.writeFile path f'
-    pure path
+    destFile <- withExceptT FTCEFileIOError $ getDestFile fileName
+    CF.writeFile destFile f'
+    pure destFile
   lastPath : chPaths' -> do
     (state, expectedLen, ch) <- decryptFirstChunk
     (FileHeader {fileName}, ch') <- parseFileHeader ch
-    path <- withExceptT FTCEFileIOError $ getFilePath fileName
-    authOk <- liftIO . withFile path WriteMode $ \h -> do
-      liftIO $ LB.hPut h ch'
+    destFile@(CryptoFile path _) <- withExceptT FTCEFileIOError $ getDestFile fileName
+    authOk <- CF.withFile destFile WriteMode $ \h -> liftIO $ do
+      CF.hPut h ch'
       state' <- foldM (decryptChunk h) state $ reverse chPaths'
       decryptLastChunk h state' expectedLen
     unless authOk $ do
       removeFile path
       throwError FTCEInvalidAuthTag
-    pure path
+    pure destFile
     where
       decryptFirstChunk = do
         sb <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce
@@ -84,7 +87,7 @@ decryptChunks encSize (chPath : chPaths) key nonce getFilePath = case reverse ch
         ch <- LB.readFile chPth
         let len' = len + LB.length ch
             (ch', sb') = LC.sbDecryptChunkLazy sb ch
-        LB.hPut h ch'
+        CF.hPut h ch'
         pure (sb', len')
       decryptLastChunk h (!sb, !len) expectedLen = do
         ch <- LB.readFile lastPath
@@ -94,7 +97,8 @@ decryptChunks encSize (chPath : chPaths) key nonce getFilePath = case reverse ch
             len' = len + LB.length ch2
             ch3 = LB.take (LB.length ch2 - len' + expectedLen) ch2
             tag :: ByteString = BA.convert (LC.sbAuth sb')
-        LB.hPut h ch3
+        CF.hPut h ch3
+        CF.hPutTag h
         pure $ B.length tag'' == 16 && BA.constEq tag'' tag
   where
     parseFileHeader :: LazyByteString -> ExceptT FTCryptoError IO (FileHeader, LazyByteString)
@@ -107,10 +111,3 @@ decryptChunks encSize (chPath : chPaths) key nonce getFilePath = case reverse ch
 
 readChunks :: [FilePath] -> IO LB.ByteString
 readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) ""
-
-data FTCryptoError
-  = FTCECryptoError C.CryptoError
-  | FTCEInvalidHeader String
-  | FTCEInvalidAuthTag
-  | FTCEFileIOError String
-  deriving (Show, Eq, Exception)

src/Simplex/FileTransfer/Description.hs

@@ -55,6 +55,7 @@ import qualified Data.Yaml as Y
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.Generics (Generic)
+import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Protocol
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -238,18 +239,6 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where
           A.decimal
         ]
 
-kb :: Integral a => a -> a
-kb n = 1024 * n
-{-# INLINE kb #-}
-
-mb :: Integral a => a -> a
-mb n = 1024 * kb n
-{-# INLINE mb #-}
-
-gb :: Integral a => a -> a
-gb n = 1024 * mb n
-{-# INLINE gb #-}
-
 instance (Integral a, Show a) => IsString (FileSize a) where
   fromString = either error id . strDecode . B.pack