xftp: add server to client encryption layer with cryptobox (#646)

* xftp: add server to client encryption layer with cryptobox

* workarounds for http2

* update http2 commit

* remove TODOs

src/Simplex/FileTransfer/Client.hs

@@ -31,10 +31,10 @@ import Simplex.Messaging.Client
     transportClientConfig,
   )
 import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Protocol
   ( Protocol (..),
     ProtocolServer (..),
-    RcvPublicDhKey,
     RecipientId,
     SenderId,
   )
@@ -142,16 +142,17 @@ uploadXFTPChunk c spKey fId chunkSpec =
     (FROk, _body) -> pure ()
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
-downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> RcvPublicDhKey -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
-downloadXFTPChunk c rpKey fId rKey chunkSpec@XFTPRcvChunkSpec {filePath} =
-  sendXFTPCommand c rpKey fId (FGET rKey) Nothing >>= \case
-    (FRFile sKey, HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of
+downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
+downloadXFTPChunk c rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath} = do
+  (rDhKey, rpDhKey) <- liftIO C.generateKeyPair'
+  sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case
+    (FRFile sDhKey cbNonce, HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of
       -- TODO atm bodySize is set to 0, so chunkSize will be incorrect - validate once set
       Just chunkPart -> do
-        -- let chunk = XFTPChunkBody {chunkSize = bodySize - B.length bodyHead, chunkPart, http2Body}
-        withExceptT PCEResponseError $ do
-          -- TODO chunk decryption
-          receiveFile chunkPart chunkSpec `catchError` \e ->
+        let dhSecret = C.dh' sDhKey rpDhKey
+        cbState <- liftEither . first PCECryptoError $ LC.cbInit dhSecret cbNonce
+        withExceptT PCEResponseError $
+          receiveEncFile chunkPart cbState chunkSpec `catchError` \e ->
             whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
       _ -> throwError $ PCEResponseError NO_FILE
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r

src/Simplex/FileTransfer/Client/Main.hs

@@ -332,7 +332,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
   encPath <- getEncPath tempPath "xftp"
   createDirectory encPath
   a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
-  chunkPaths <- pooledForConcurrentlyN 32 chunks $ downloadFileChunk a encPath
+  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
@@ -346,9 +346,8 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
       let FileChunkReplica {server, rcvId, rcvKey} = replica
       chunkPath <- uniqueCombine encPath $ show chunkNo
       c <- retries $ getXFTPServerClient a server
-      (rKey, rpKey) <- liftIO C.generateKeyPair'
       let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
-      retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) rKey chunkSpec
+      retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) chunkSpec
       pure chunkPath
     downloadFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"
     decryptFile :: [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath

src/Simplex/FileTransfer/Protocol.hs

@@ -251,7 +251,7 @@ instance ProtocolMsgTag FileResponseTag where
 data FileResponse
   = FRSndIds SenderId (NonEmpty RecipientId)
   | FRRcvIds (NonEmpty RecipientId)
-  | FRFile RcvPublicDhKey
+  | FRFile RcvPublicDhKey C.CbNonce
   | FROk
   | FRErr XFTPErrorType
   | FRPong
@@ -262,7 +262,7 @@ instance ProtocolEncoding XFTPErrorType FileResponse where
   encodeProtocol _v = \case
     FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds)
     FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds)
-    FRFile rKey -> e (FRFile_, ' ', rKey)
+    FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce)
     FROk -> e FROk_
     FRErr err -> e (FRErr_, ' ', err)
     FRPong -> e FRPong_
@@ -273,7 +273,7 @@ instance ProtocolEncoding XFTPErrorType FileResponse where
   protocolP _v = \case
     FRSndIds_ -> FRSndIds <$> _smpP <*> smpP
     FRRcvIds_ -> FRRcvIds <$> _smpP
-    FRFile_ -> FRFile <$> _smpP
+    FRFile_ -> FRFile <$> _smpP <*> smpP
     FROk_ -> pure FROk
     FRErr_ -> FRErr <$> _smpP
     FRPong_ -> pure FRPong
@@ -313,7 +313,7 @@ data XFTPErrorType
     SIZE
   | -- | incorrent file digest
     DIGEST
-  | -- | no file body
+  | -- | no expected file body in request/response or no file on the server
     NO_FILE
   | -- | unexpected file body
     HAS_FILE

src/Simplex/FileTransfer/Server.hs

@@ -36,6 +36,7 @@ import Simplex.FileTransfer.Server.Stats
 import Simplex.FileTransfer.Server.Store
 import Simplex.FileTransfer.Transport
 import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
@@ -122,11 +123,10 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
               ]
         threadDelay interval
 
--- TODO add client DH secret
 data ServerFile = ServerFile
   { filePath :: FilePath,
     fileSize :: Word32,
-    fileDhSecret :: C.DhSecretX25519
+    sbState :: LC.SbState
   }
 
 processRequest :: HTTP2Request -> M ()
@@ -152,12 +152,13 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen
       where
         streamBody t_ send done = do
           case t_ of
-            Left _ -> send "padding error" -- TODO respond with BLOCK error?
+            Left _ -> do
+              send "padding error" -- TODO respond with BLOCK error?
+              done
             Right t -> do
               send $ byteString t
-              -- TODO chunk encryption
-              forM_ serverFile_ $ \ServerFile {filePath, fileSize, fileDhSecret} ->
-                withFile filePath ReadMode $ \h -> sendFile h send $ fromIntegral fileSize
+              forM_ serverFile_ $ \ServerFile {filePath, fileSize, sbState} -> do
+                withFile filePath ReadMode $ \h -> sendEncFile h send sbState (fromIntegral fileSize)
           done
 
 data VerificationResult = VRVerified XFTPRequest | VRFailed
@@ -196,7 +197,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     FADD _rcps -> noFile FROk
     FPUT -> (,Nothing) <$> receiveServerFile fr
     FDEL -> noFile FROk
-    FGET dhKey -> sendServerFile fr dhKey
+    FGET rDhKey -> sendServerFile fr rDhKey
     FACK -> noFile FROk
     -- it should never get to the options below, they are passed in other constructors of XFTPRequest
     FNEW _ _ -> noFile $ FRErr INTERNAL
@@ -219,13 +220,16 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
             Left e -> whenM (doesFileExist fPath) (removeFile fPath) $> FRErr e
 
     sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
-    sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rKey = do
+    sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rDhKey = do
       readTVarIO filePath >>= \case
         Just path -> do
-          (sKey, spKey) <- liftIO C.generateKeyPair'
-          let fileDhSecret = C.dh' rKey spKey
-          pure (FRFile sKey, Just ServerFile {filePath = path, fileSize = size, fileDhSecret})
-        _ -> pure (FRErr AUTH, Nothing) -- TODO file-specific errors?
+          (sDhKey, spDhKey) <- liftIO C.generateKeyPair'
+          let dhSecret = C.dh' rDhKey spDhKey
+          cbNonce <- liftIO C.randomCbNonce
+          pure $ case LC.cbInit dhSecret cbNonce of
+            Right sbState -> (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
+            _ -> (FRErr INTERNAL, Nothing)
+        _ -> pure (FRErr NO_FILE, Nothing)
 
 randomId :: (MonadUnliftIO m, MonadReader XFTPEnv m) => Int -> m ByteString
 randomId n = do

src/Simplex/FileTransfer/Transport.hs

@@ -10,10 +10,15 @@ module Simplex.FileTransfer.Transport
     XFTPRcvChunkSpec (..),
     sendFile,
     receiveFile,
+    sendEncFile,
+    receiveEncFile,
   )
 where
 
+import Control.Concurrent (threadDelay)
+import qualified Control.Exception as E
 import Control.Monad.Except
+import qualified Data.ByteArray as BA
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -21,6 +26,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Word (Word32)
 import GHC.IO.Handle.Internals (ioe_EOF)
 import Simplex.FileTransfer.Protocol (XFTPErrorType (..), xftpBlockSize)
+import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Version
 import System.IO (Handle, IOMode (..), withFile)
@@ -40,18 +46,33 @@ sendFile h send = go
   where
     go 0 = pure ()
     go sz =
-      B.hGet h xftpBlockSize >>= \case
-        "" -> ioe_EOF
-        ch -> do
-          let ch' = B.take (fromIntegral sz) ch -- sz >= xftpBlockSize
-          send $ byteString ch'
-          go $ sz - fromIntegral (B.length ch')
+      getFileChunk h sz >>= \ch -> do
+        send $ byteString ch
+        go $ sz - fromIntegral (B.length ch)
+
+sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
+sendEncFile h send = go
+  where
+    go sbState 0 = do
+      -- TODO remove padding when HTTP2 issue is fixed
+      let authTag = BA.convert (LC.sbAuth sbState) <> B.replicate (xftpBlockSize - C.authTagSize) '#'
+      send $ byteString authTag
+    go sbState sz =
+      getFileChunk h sz >>= \ch -> do
+        let (encCh, sbState') = LC.sbEncryptChunk sbState ch
+        send (byteString encCh) `E.catch` \(e :: E.SomeException) -> print e >> E.throwIO e
+        -- TODO remove delay when HTTP2 issue is fixed
+        threadDelay 500
+        go sbState' $ sz - fromIntegral (B.length ch)
+
+getFileChunk :: Handle -> Word32 -> IO ByteString
+getFileChunk h sz =
+  B.hGet h xftpBlockSize >>= \case
+    "" -> ioe_EOF
+    ch -> pure $ B.take (fromIntegral sz) ch -- sz >= xftpBlockSize
 
 receiveFile :: (Int -> IO ByteString) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
-receiveFile getBody XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do
-  ExceptT $ withFile filePath WriteMode (`receive` chunkSize)
-  digest' <- liftIO $ LC.sha512Hash <$> LB.readFile filePath
-  when (digest' /= chunkDigest) $ throwError DIGEST
+receiveFile getBody = receiveFile_ receive
   where
     receive h sz = do
       ch <- getBody xftpBlockSize
@@ -61,3 +82,33 @@ receiveFile getBody XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do
           | chSize > 0 -> B.hPut h ch >> receive h (sz - chSize)
           | sz == 0 -> pure $ Right ()
           | otherwise -> pure $ Left SIZE
+
+receiveEncFile :: (Int -> IO ByteString) -> LC.SbState -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
+receiveEncFile getBody = receiveFile_ . receive
+  where
+    receive sbState h sz = do
+      ch <- getBody xftpBlockSize
+      let chSize = fromIntegral $ B.length ch
+      if
+          | chSize > sz + authSz -> pure $ Left SIZE
+          | chSize > 0 -> do
+            let (ch', rest) = B.splitAt (fromIntegral sz) ch
+                (decCh, sbState') = LC.sbDecryptChunk sbState ch'
+                sz' = sz - fromIntegral (B.length ch')
+            B.hPut h decCh
+            if sz' > 0
+              then receive sbState' h sz'
+              else do
+                let tag' = B.take C.authTagSize rest
+                    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
+          | otherwise -> pure $ Left SIZE
+    authSz = fromIntegral C.authTagSize
+
+receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ())) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
+receiveFile_ receive XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do
+  ExceptT $ withFile filePath WriteMode (`receive` chunkSize)
+  digest' <- liftIO $ LC.sha512Hash <$> LB.readFile filePath
+  when (digest' /= chunkDigest) $ throwError DIGEST

src/Simplex/Messaging/Agent/Client.hs

@@ -592,7 +592,7 @@ protocolClientError protocolError_ host = \case
   PCENetworkError -> BROKER host NETWORK
   PCEIncompatibleHost -> BROKER host HOST
   PCETransportError e -> BROKER host $ TRANSPORT e
-  e@PCESignatureError {} -> INTERNAL $ show e
+  e@PCECryptoError {} -> INTERNAL $ show e
   PCEIOError {} -> BROKER host NETWORK
 
 data SMPTestStep = TSConnect | TSCreateQueue | TSSecureQueue | TSDeleteQueue | TSDisconnect

src/Simplex/Messaging/Client.hs

@@ -414,8 +414,8 @@ data ProtocolClientError err
   | -- | TCP transport handshake or some other transport error.
     -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
     PCETransportError TransportError
-  | -- | Error when cryptographically "signing" the command.
-    PCESignatureError C.CryptoError
+  | -- | Error when cryptographically "signing" the command or when initializing crypto_box.
+    PCECryptoError C.CryptoError
   | -- | IO Error
     PCEIOError IOException
   deriving (Eq, Show, Exception)

src/Simplex/Messaging/Crypto/Lazy.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -11,6 +12,11 @@ module Simplex.Messaging.Crypto.Lazy
     sbEncrypt,
     sbDecrypt,
     fastReplicate,
+    SbState,
+    cbInit,
+    sbEncryptChunk,
+    sbDecryptChunk,
+    sbAuth,
   )
 where
 
@@ -29,7 +35,7 @@ import qualified Data.ByteString.Lazy.Internal as LB
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
 import Foreign (sizeOf)
-import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), SbKey, pattern CbNonce, pattern SbKey)
+import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), DhSecret (..), DhSecretX25519, SbKey, pattern CbNonce, pattern SbKey)
 import Simplex.Messaging.Encoding
 
 type LazyByteString = LB.ByteString
@@ -92,7 +98,7 @@ sbDecrypt (SbKey key) (CbNonce nonce) packet
     (tag', c) = LB.splitAt 16 packet
 
 secretBox :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError (NonEmpty ByteString)
-secretBox sbProcess secret nonce msg = run <$> sbInit secret nonce
+secretBox 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')
@@ -100,8 +106,12 @@ secretBox sbProcess secret nonce msg = run <$> sbInit secret nonce
 
 type SbState = (XSalsa.State, Poly1305.State)
 
-sbInit :: ByteArrayAccess key => key -> ByteString -> Either CryptoError SbState
-sbInit secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs)
+cbInit :: DhSecretX25519 -> CbNonce -> Either CryptoError SbState
+cbInit (DhSecretX25519 secret) (CbNonce nonce) = sbInit_ secret nonce
+{-# INLINE cbInit #-}
+
+sbInit_ :: ByteArrayAccess key => key -> ByteString -> Either CryptoError SbState
+sbInit_ secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs)
   where
     zero = B.replicate 16 $ toEnum 0
     (iv0, iv1) = B.splitAt 8 nonce

src/Simplex/Messaging/Notifications/Server.hs

@@ -235,7 +235,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
       PCEResponseError e -> updateErr "ResponseError " e
       PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
       PCETransportError e -> updateErr "TransportError " e
-      PCESignatureError e -> updateErr "SignatureError " e
+      PCECryptoError e -> updateErr "CryptoError " e
       PCEIncompatibleHost -> updateSubStatus smpQueue $ NSErr "IncompatibleHost"
       PCEResponseTimeout -> pure ()
       PCENetworkError -> pure ()

src/Simplex/Messaging/Notifications/Server/Push/APNS.hs

@@ -343,7 +343,7 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
   nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg
   apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
   req <- liftIO $ apnsRequest c tknStr apnsNtf
-  -- TODO if HTTP2 client is thread-safe, we can use sendRequestDirect (the tests pass)
+  -- TODO when HTTP2 client is thread-safe, we can use sendRequestDirect
   HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req
   let status = H.responseStatus response
       reason' = maybe "" reason $ J.decodeStrict' bodyHead