xftp: write secret_box auth tag to the end of the file, for efficienc…

…y of ecryption/decryption (#650)

* xftp: write secret_box auth tag to the end of the file, for efficiency of ecryption/decryption

* comments

src/Simplex/FileTransfer/Client.hs

@@ -120,7 +120,7 @@ sendXFTPCommand XFTPClient {http2Client = http2@HTTP2Client {sessionId}} pKey fI
       forM_ chunkSpec_ $ \XFTPChunkSpec {filePath, chunkOffset, chunkSize} ->
         withFile filePath ReadMode $ \h -> do
           hSeek h AbsoluteSeek $ fromIntegral chunkOffset
-          sendFile h send chunkSize
+          sendFile h send $ fromIntegral chunkSize
       done
 
 createXFTPChunk ::

src/Simplex/FileTransfer/Client/Main.hs

@@ -59,8 +59,8 @@ smallChunkSize = 1 * mb
 fileSizeLen :: Int64
 fileSizeLen = 8
 
-cbAuthTagLen :: Int64
-cbAuthTagLen = fromIntegral C.cbAuthTagSize
+authTagSize :: Int64
+authTagSize = fromIntegral C.authTagSize
 
 mb :: Num a => a
 mb = 1024 * 1024
@@ -153,7 +153,7 @@ cliCommandP =
     randomP =
       RandomFileOptions
         <$> argument str (metavar "FILE" <> help "Path to save file")
-        <*> argument strDec (metavar "SIZE" <> help "File size (bytes/kb/mb)")
+        <*> argument strDec (metavar "SIZE" <> help "File size (bytes/kb/mb/gb)")
     strDec = eitherReader $ strDecode . B.pack
     fileDescrArg = argument str (metavar "FILE" <> help "File description file")
     retryCountP = option auto (long "retry" <> short 'r' <> metavar "RETRY" <> help "Number of network retries" <> value defaultRetryCount <> showDefault)
@@ -250,8 +250,8 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       fileSize <- fromInteger <$> getFileSize filePath
       let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
           fileSize' = fromIntegral (B.length fileHdr) + fileSize
-          chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + cbAuthTagLen
-          encSize = fromIntegral $ sum chunkSizes
+          chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize
+          encSize = sum $ map fromIntegral chunkSizes
       encrypt fileHdr key nonce fileSize' encSize encPath
       digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
       let chunkSpecs = prepareChunkSpecs encPath chunkSizes
@@ -263,10 +263,8 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
         encrypt fileHdr key nonce fileSize' encSize encFile = do
           f <- liftIO $ LB.readFile filePath
           let f' = LB.fromStrict fileHdr <> f
-          c <- liftEither $ first (CLIError . show) $ LC.sbEncrypt key nonce f' fileSize' $ encSize - cbAuthTagLen
+          c <- liftEither $ first (CLIError . show) $ LC.sbEncryptTailTag key nonce f' fileSize' $ encSize - authTagSize
           liftIO $ LB.writeFile encFile c
-    -- let padSize = paddedSize - fileSize - fromIntegral (B.length fileHdr)
-    -- when (padSize > 0) . LB.hPut h $ LB.replicate padSize '#'
     uploadFile :: [XFTPChunkSpec] -> ExceptT CLIError IO [SentFileChunk]
     uploadFile chunks = do
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
@@ -368,14 +366,16 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
   getFileDescription' fileDescription >>= receiveFile
   where
     receiveFile :: ValidFileDescription 'FPRecipient -> ExceptT CLIError IO ()
-    receiveFile (ValidFileDescription FileDescription {digest, key, nonce, chunks}) = do
+    receiveFile (ValidFileDescription FileDescription {size, digest, key, nonce, chunks}) = do
       encPath <- getEncPath tempPath "xftp"
       createDirectory encPath
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
       chunkPaths <- forM chunks $ downloadFileChunk a encPath
       encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
       when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
-      path <- decryptFile chunkPaths key nonce
+      encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
+      when (FileSize encSize /= size) $ throwError $ CLIError "File size mismatch"
+      path <- decryptFile encSize chunkPaths key nonce
       forM_ chunks $ acknowledgeFileChunk a
       whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
       liftIO $ putStrLn $ "File received: " <> path
@@ -389,9 +389,9 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
       withRetry retryCount $ downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
       pure chunkPath
     downloadFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"
-    decryptFile :: [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
-    decryptFile chunkPaths key nonce = do
-      f <- liftEither . first (CLIError . show) . LC.sbDecrypt key nonce =<< liftIO (readChunks chunkPaths)
+    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
@@ -401,6 +401,9 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
         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) LB.empty

src/Simplex/FileTransfer/Description.hs

@@ -196,20 +196,24 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where
   strEncode (FileSize b)
     | b' /= 0 = bshow b
     | kb' /= 0 = bshow kb <> "kb"
-    | otherwise = bshow mb <> "mb"
+    | mb' /= 0 = bshow mb <> "mb"
+    | otherwise = bshow gb <> "gb"
     where
       (kb, b') = b `divMod` 1024
       (mb, kb') = kb `divMod` 1024
+      (gb, mb') = mb `divMod` 1024
   strP =
     FileSize
       <$> A.choice
-        [ (mb *) <$> A.decimal <* "mb",
+        [ (gb *) <$> A.decimal <* "gb",
+          (mb *) <$> A.decimal <* "mb",
           (kb *) <$> A.decimal <* "kb",
           A.decimal
         ]
     where
       kb = 1024
       mb = 1024 * kb
+      gb = 1024 * mb
 
 groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]]
 groupReplicasByServer defChunkSize =

src/Simplex/FileTransfer/Protocol.hs

@@ -337,6 +337,8 @@ data XFTPErrorType
     SIZE
   | -- | incorrent file digest
     DIGEST
+  | -- | file encryption/decryption failed
+    CRYPTO
   | -- | no expected file body in request/response or no file on the server
     NO_FILE
   | -- | unexpected file body
@@ -357,6 +359,7 @@ instance Encoding XFTPErrorType where
     AUTH -> "AUTH"
     SIZE -> "SIZE"
     DIGEST -> "DIGEST"
+    CRYPTO -> "CRYPTO"
     NO_FILE -> "NO_FILE"
     HAS_FILE -> "HAS_FILE"
     FILE_IO -> "FILE_IO"
@@ -371,6 +374,7 @@ instance Encoding XFTPErrorType where
       "AUTH" -> pure AUTH
       "SIZE" -> pure SIZE
       "DIGEST" -> pure DIGEST
+      "CRYPTO" -> pure CRYPTO
       "NO_FILE" -> pure NO_FILE
       "HAS_FILE" -> pure HAS_FILE
       "FILE_IO" -> pure FILE_IO

src/Simplex/FileTransfer/Transport.hs

@@ -103,7 +103,7 @@ receiveEncFile getBody = receiveFile_ . receive
                     tagSz = B.length tag'
                     tag = LC.sbAuth sbState'
                 tag'' <- if tagSz == C.authTagSize then pure tag' else (tag' <>) <$> getBody (C.authTagSize - tagSz)
-                pure $ if BA.constEq tag'' tag then Right () else Left DIGEST
+                pure $ if BA.constEq tag'' tag then Right () else Left CRYPTO
           | otherwise -> pure $ Left SIZE
     authSz = fromIntegral C.authTagSize
 

src/Simplex/Messaging/Crypto.hs

@@ -121,7 +121,6 @@ module Simplex.Messaging.Crypto
     sbKey,
     unsafeSbKey,
     randomSbKey,
-    cbAuthTagSize,
 
     -- * pseudo-random bytes
     pseudoRandomBytes,
@@ -993,9 +992,6 @@ sbDecrypt_ secret (CbNonce nonce) packet
     (rs, msg) = xSalsa20 secret nonce c
     tag = Poly1305.auth rs c
 
-cbAuthTagSize :: Int
-cbAuthTagSize = 16
-
 newtype CbNonce = CryptoBoxNonce {unCbNonce :: ByteString}
   deriving (Eq, Show)
 

src/Simplex/Messaging/Crypto/Lazy.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -11,9 +13,12 @@ module Simplex.Messaging.Crypto.Lazy
     unPad,
     sbEncrypt,
     sbDecrypt,
+    sbEncryptTailTag,
+    sbDecryptTailTag,
     fastReplicate,
     SbState,
     cbInit,
+    sbInit,
     sbEncryptChunk,
     sbDecryptChunk,
     sbAuth,
@@ -79,13 +84,15 @@ unPad padded
     (lenStr, rest) = LB.splitAt 8 padded
 
 -- | NaCl @secret_box@ lazy encrypt with a symmetric 256-bit key and 192-bit nonce.
+-- The resulting string will be bigger than paddedLen by the size of the auth tag (16 bytes).
 sbEncrypt :: SbKey -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString
 sbEncrypt (SbKey key) (CbNonce nonce) msg len paddedLen =
   prependTag <$> (secretBox sbEncryptChunk key nonce =<< pad msg len paddedLen)
   where
     prependTag (tag :| cs) = LB.Chunk tag $ LB.fromChunks cs
 
 -- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce.
+-- The resulting string will be smaller than packet size by the size of the auth tag (16 bytes).
 sbDecrypt :: SbKey -> CbNonce -> LazyByteString -> Either CryptoError LazyByteString
 sbDecrypt (SbKey key) (CbNonce nonce) packet
   | LB.length tag' < 16 = Left CBDecryptError
@@ -104,12 +111,40 @@ secretBox sbProcess secret nonce msg = run <$> sbInit_ secret nonce
     update (cs, st) chunk = let (c, st') = sbProcess st chunk in (c : cs, st')
     run state = let (cs, state') = process state in BA.convert (sbAuth state') :| reverse cs
 
+-- | NaCl @secret_box@ lazy encrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files).
+sbEncryptTailTag :: SbKey -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString
+sbEncryptTailTag (SbKey key) (CbNonce nonce) msg len paddedLen =
+  LB.fromChunks <$> (secretBoxTailTag sbEncryptChunk key nonce =<< pad msg len paddedLen)
+
+-- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files).
+-- paddedLen should NOT include the tag length, it should be the same number that is passed to sbEncrypt / sbEncryptTailTag.
+sbDecryptTailTag :: SbKey -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString)
+sbDecryptTailTag (SbKey key) (CbNonce nonce) paddedLen packet =
+  case secretBox sbDecryptChunk key nonce c of
+    Right (tag :| cs) ->
+      let valid = LB.length tag' == 16 && BA.constEq (LB.toStrict tag') tag
+       in (valid,) <$> unPad (LB.fromChunks cs)
+    Left e -> Left e
+  where
+    (c, tag') = LB.splitAt paddedLen packet
+
+secretBoxTailTag :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError [ByteString]
+secretBoxTailTag sbProcess secret nonce msg = run <$> sbInit_ secret nonce
+  where
+    process state = foldlChunks update ([], state) msg
+    update (cs, st) chunk = let (c, st') = sbProcess st chunk in (c : cs, st')
+    run state = let (cs, state') = process state in reverse $ BA.convert (sbAuth state') : cs
+
 type SbState = (XSalsa.State, Poly1305.State)
 
 cbInit :: DhSecretX25519 -> CbNonce -> Either CryptoError SbState
 cbInit (DhSecretX25519 secret) (CbNonce nonce) = sbInit_ secret nonce
 {-# INLINE cbInit #-}
 
+sbInit :: SbKey -> CbNonce -> Either CryptoError SbState
+sbInit (SbKey secret) (CbNonce nonce) = sbInit_ secret nonce
+{-# INLINE sbInit #-}
+
 sbInit_ :: ByteArrayAccess key => key -> ByteString -> Either CryptoError SbState
 sbInit_ secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs)
   where

tests/CoreTests/CryptoTests.hs

@@ -76,6 +76,8 @@ cryptoTests = do
   describe "lazy secretbox" $ do
     testLazySecretBox
     testLazySecretBoxFile
+    testLazySecretBoxTailTag
+    testLazySecretBoxFileTailTag
   describe "X509 key encoding" $ do
     describe "Ed25519" $ testEncoding C.SEd25519
     describe "Ed448" $ testEncoding C.SEd448
@@ -148,6 +150,33 @@ testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random s
   Right s'' <- LC.sbDecrypt k nonce <$> LB.readFile (f <> ".encrypted")
   s'' `shouldBe` s
 
+testLazySecretBoxTailTag :: Spec
+testLazySecretBoxTailTag = it "should lazily encrypt / decrypt string with a random symmetric key (tail tag)" . ioProperty $ do
+  k <- C.randomSbKey
+  nonce <- C.randomCbNonce
+  pure $ \(s, pad) ->
+    let b = LE.encodeUtf8 $ LT.pack s
+        len = LB.length b
+        pad' = min (abs pad) 100000
+        paddedLen = len + pad' + 8
+        cipher = LC.sbEncryptTailTag k nonce b len paddedLen
+        plain = LC.sbDecryptTailTag k nonce paddedLen =<< cipher
+     in isRight cipher && cipher /= (snd <$> plain) && Right (True, b) == plain
+
+testLazySecretBoxFileTailTag :: Spec
+testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a random symmetric key (tail tag)" $ do
+  k <- C.randomSbKey
+  nonce <- C.randomCbNonce
+  let f = "tests/tmp/testsecretbox"
+      paddedLen = 4 * 1024 * 1024
+      len = 4 * 1000 * 1000 :: Int64
+      s = LC.fastReplicate len 'a'
+  Right s' <- pure $ LC.sbEncryptTailTag k nonce s len paddedLen
+  LB.writeFile (f <> ".encrypted") s'
+  Right (auth, s'') <- LC.sbDecryptTailTag k nonce paddedLen <$> LB.readFile (f <> ".encrypted")
+  s'' `shouldBe` s
+  auth `shouldBe` True
+
 testEncoding :: (C.AlgorithmI a) => C.SAlgorithm a -> Spec
 testEncoding alg = it "should encode / decode key" . ioProperty $ do
   (k, pk) <- C.generateKeyPair alg

tests/XFTPServerTests.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module XFTPServerTests where
 
@@ -30,14 +31,14 @@ xftpServerTests :: Spec
 xftpServerTests =
   before_ (createDirectoryIfMissing False xftpServerFiles)
     . after_ (removeDirectoryRecursive xftpServerFiles)
+    . describe "XFTP file chunk delivery"
     $ do
-      describe "XFTP file chunk delivery" $ do
-        it "should create, upload and receive file chunk (1 client)" testFileChunkDelivery
-        it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2
-        it "should delete file chunk (1 client)" testFileChunkDelete
-        it "should delete file chunk (2 clients)" testFileChunkDelete2
-        it "should acknowledge file chunk reception (1 client)" testFileChunkAck
-        it "should acknowledge file chunk reception (2 clients)" testFileChunkAck2
+      it "should create, upload and receive file chunk (1 client)" testFileChunkDelivery
+      it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2
+      it "should delete file chunk (1 client)" testFileChunkDelete
+      it "should delete file chunk (2 clients)" testFileChunkDelete2
+      it "should acknowledge file chunk reception (1 client)" testFileChunkAck
+      it "should acknowledge file chunk reception (2 clients)" testFileChunkAck2
 
 chSize :: Num n => n
 chSize = 128 * 1024
@@ -99,8 +100,9 @@ runTestFileChunkDelete s r = do
   downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
   liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
   deleteXFTPChunk s spKey sId
-  liftIO $ readChunk sId
-    `shouldThrow` \(e :: SomeException) -> "openBinaryFile: does not exist" `isInfixOf` show e
+  liftIO $
+    readChunk sId
+      `shouldThrow` \(e :: SomeException) -> "openBinaryFile: does not exist" `isInfixOf` show e
   downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
     `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
   deleteXFTPChunk s spKey sId
@@ -113,7 +115,7 @@ testFileChunkAck2 :: Expectation
 testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r
 
 runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
-runTestFileChunkAck s r =  do
+runTestFileChunkAck s r = do
   (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   bytes <- liftIO $ createTestChunk testChunkPath