core: optionally encrypt SMP files (#3082)

* core: optionally encrypt SMP files

* encrypt to temp file and rename or remove encryption args if it fails

* fix file encryption error handling

src/Simplex/Chat/Mobile/File.hs

@@ -34,6 +34,7 @@ import Foreign.Ptr
 import Foreign.Storable (poke)
 import GHC.Generics (Generic)
 import Simplex.Chat.Mobile.Shared
+import Simplex.Chat.Util (chunkSize, encryptFile)
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..), CryptoFileHandle, FTCryptoError (..))
 import qualified Simplex.Messaging.Crypto.File as CF
 import Simplex.Messaging.Encoding.String
@@ -105,16 +106,8 @@ chatEncryptFile fromPath toPath =
   where
     encrypt = do
       cfArgs <- liftIO $ CF.randomArgs
-      let toFile = CryptoFile toPath $ Just cfArgs
-      withExceptT show $
-        withFile fromPath ReadMode $ \r -> CF.withFile toFile WriteMode $ \w -> do
-          encryptChunks r w
-          liftIO $ CF.hPutTag w
+      encryptFile fromPath toPath cfArgs
       pure cfArgs
-    encryptChunks r w = do
-      ch <- liftIO $ LB.hGet r chunkSize
-      unless (LB.null ch) $ liftIO $ CF.hPut w ch
-      unless (LB.length ch < chunkSize) $ encryptChunks r w
 
 cChatDecryptFile :: CString -> CString -> CString -> CString -> IO CString
 cChatDecryptFile cFromPath cKey cNonce cToPath = do
@@ -149,7 +142,3 @@ chatDecryptFile fromPath keyStr nonceStr toPath = fromLeft "" <$> runCatchExcept
 
 runCatchExceptT :: ExceptT String IO a -> IO (Either String a)
 runCatchExceptT action = runExceptT action `catchAll` (pure . Left . show)
-
-chunkSize :: Num a => a
-chunkSize = 65536
-{-# INLINE chunkSize #-}

src/Simplex/Chat/Store/Files.hs

@@ -57,6 +57,7 @@ module Simplex.Chat.Store.Files
     xftpAcceptRcvFT,
     setRcvFileToReceive,
     setFileCryptoArgs,
+    removeFileCryptoArgs,
     getRcvFilesToReceive,
     setRcvFTAgentDeleted,
     updateRcvFileStatus,
@@ -487,7 +488,7 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File
   rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
   let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_
       -- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it
-      xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False, cryptoArgs = Nothing}) <$> rfd_
+      xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_
       fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
   fileId <- liftIO $ do
     DB.execute
@@ -500,7 +501,7 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File
       db
       "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
       (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs)
-  pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing}
+  pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing}
 
 createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
 createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
@@ -508,7 +509,7 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD
   rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
   let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_
       -- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it
-      xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False, cryptoArgs = Nothing}) <$> rfd_
+      xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_
       fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
   fileId <- liftIO $ do
     DB.execute
@@ -521,7 +522,7 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD
       db
       "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
       (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, rfdId, currentTs, currentTs)
-  pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId}
+  pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId, cryptoArgs = Nothing}
 
 createRcvFD_ :: DB.Connection -> UserId -> UTCTime -> FileDescr -> ExceptT StoreError IO RcvFileDescr
 createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do
@@ -639,8 +640,8 @@ getRcvFileTransfer db User {userId} fileId = do
         ft senderDisplayName fileStatus =
           let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
               cryptoArgs = CFArgs <$> fileKey <*> fileNonce
-              xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted, cryptoArgs}) <$> rfd_
-           in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId}
+              xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted}) <$> rfd_
+           in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId, cryptoArgs}
         rfi = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_
         rfi_ = case (filePath_, connId_, agentConnId_) of
           (Just filePath, connId, agentConnId) -> pure $ Just RcvFileInfo {filePath, connId, agentConnId}
@@ -709,6 +710,11 @@ setFileCryptoArgs_ db fileId (CFArgs key nonce) currentTs =
     "UPDATE files SET file_crypto_key = ?, file_crypto_nonce = ?, updated_at = ? WHERE file_id = ?"
     (key, nonce, currentTs, fileId)
 
+removeFileCryptoArgs :: DB.Connection -> FileTransferId -> IO ()
+removeFileCryptoArgs db fileId = do
+  currentTs <- getCurrentTime
+  DB.execute db "UPDATE files SET file_crypto_key = NULL, file_crypto_nonce = NULL, updated_at = ? WHERE file_id = ?" (currentTs, fileId)
+
 getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer]
 getRcvFilesToReceive db user@User {userId} = do
   cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime

src/Simplex/Chat/Types.hs

@@ -986,7 +986,10 @@ data RcvFileTransfer = RcvFileTransfer
     senderDisplayName :: ContactName,
     chunkSize :: Integer,
     cancelled :: Bool,
-    grpMemberId :: Maybe Int64
+    grpMemberId :: Maybe Int64,
+    -- XFTP files are encrypted as they are received, they are never stored unecrypted
+    -- SMP files are encrypted after all chunks are received
+    cryptoArgs :: Maybe CryptoFileArgs
   }
   deriving (Eq, Show, Generic)
 
@@ -995,8 +998,7 @@ instance ToJSON RcvFileTransfer where toEncoding = J.genericToEncoding J.default
 data XFTPRcvFile = XFTPRcvFile
   { rcvFileDescription :: RcvFileDescr,
     agentRcvFileId :: Maybe AgentRcvFileId,
-    agentRcvFileDeleted :: Bool,
-    cryptoArgs :: Maybe CryptoFileArgs
+    agentRcvFileDeleted :: Bool
   }
   deriving (Eq, Show, Generic)
 

src/Simplex/Chat/Util.hs

@@ -1,6 +1,32 @@
-module Simplex.Chat.Util (week) where
+module Simplex.Chat.Util (week, encryptFile, chunkSize) where
 
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class
+import qualified Data.ByteString.Lazy as LB
 import Data.Time (NominalDiffTime)
+import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
+import qualified Simplex.Messaging.Crypto.File as CF
+import UnliftIO.IO (IOMode (..), withFile)
 
 week :: NominalDiffTime
 week = 7 * 86400
+
+encryptFile :: FilePath -> FilePath -> CryptoFileArgs -> ExceptT String IO ()
+encryptFile fromPath toPath cfArgs = do
+  let toFile = CryptoFile toPath $ Just cfArgs
+  -- uncomment to test encryption error in runTestFileTransferEncrypted
+  -- throwError "test error"
+  withExceptT show $
+    withFile fromPath ReadMode $ \r -> CF.withFile toFile WriteMode $ \w -> do
+      encryptChunks r w
+      liftIO $ CF.hPutTag w
+  where
+    encryptChunks r w = do
+      ch <- liftIO $ LB.hGet r chunkSize
+      unless (LB.null ch) $ liftIO $ CF.hPut w ch
+      unless (LB.length ch < chunkSize) $ encryptChunks r w
+
+chunkSize :: Num a => a
+chunkSize = 65536
+{-# INLINE chunkSize #-}

src/Simplex/Chat/View.hs

@@ -1592,8 +1592,8 @@ viewChatError logLevel = \case
     CEFileCancelled f -> ["file cancelled: " <> plain f]
     CEFileCancel fileId e -> ["error cancelling file " <> sShow fileId <> ": " <> sShow e]
     CEFileAlreadyExists f -> ["file already exists: " <> plain f]
-    CEFileRead f e -> ["cannot read file " <> plain f, sShow e]
-    CEFileWrite f e -> ["cannot write file " <> plain f, sShow e]
+    CEFileRead f e -> ["cannot read file " <> plain f <> ": " <> plain e]
+    CEFileWrite f e -> ["cannot write file " <> plain f <> ": " <> plain e]
     CEFileSend fileId e -> ["error sending file " <> sShow fileId <> ": " <> sShow e]
     CEFileRcvChunk e -> ["error receiving file: " <> plain e]
     CEFileInternal e -> ["file error: " <> plain e]