From 4ce4fa3423572bc1bee54b98748cfb5f4b302035 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 23 Feb 2023 18:28:20 +0000 Subject: [PATCH] xftp: write secret_box auth tag to the end of the file, for efficiency 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 | 2 +- src/Simplex/FileTransfer/Client/Main.hs | 29 +++++++++++--------- src/Simplex/FileTransfer/Description.hs | 8 ++++-- src/Simplex/FileTransfer/Protocol.hs | 4 +++ src/Simplex/FileTransfer/Transport.hs | 2 +- src/Simplex/Messaging/Crypto.hs | 4 --- src/Simplex/Messaging/Crypto/Lazy.hs | 35 +++++++++++++++++++++++++ tests/CoreTests/CryptoTests.hs | 29 ++++++++++++++++++++ tests/XFTPServerTests.hs | 24 +++++++++-------- 9 files changed, 105 insertions(+), 32 deletions(-) diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 5c9a475cf..27e0cdd70 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/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 :: diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 622767fd2..63939c296 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/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 diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs index 289d716c3..7b3eee7e9 100644 --- a/src/Simplex/FileTransfer/Description.hs +++ b/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 = diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index bc1cdb17b..41d7b7aff 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/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 diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index a57848d62..ad94b551d 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/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 diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 235b6919c..a6574c4af 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/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) diff --git a/src/Simplex/Messaging/Crypto/Lazy.hs b/src/Simplex/Messaging/Crypto/Lazy.hs index cb1d40aac..1e055bdfd 100644 --- a/src/Simplex/Messaging/Crypto/Lazy.hs +++ b/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,6 +84,7 @@ 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) @@ -86,6 +92,7 @@ sbEncrypt (SbKey key) (CbNonce nonce) msg len paddedLen = 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 diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index 5033b4e4e..2f7b61f6b 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/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 diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 0c5d1ecb0..695101a96 100644 --- a/tests/XFTPServerTests.hs +++ b/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