xftp: prevent overwriting completed upload (#1063)

* xftp: prevent overwriting completed upload

* add size check for skipCommitted

* fix import

* fail on incorrect size

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
This commit is contained in:
Alexander Bondarenko
2024-03-28 20:12:48 +02:00
committed by GitHub
parent ee90ea6a69
commit bbc9eccf4d
2 changed files with 42 additions and 10 deletions
+22 -10
View File
@@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
@@ -25,7 +26,7 @@ import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
@@ -47,13 +48,14 @@ import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Lazy as LC
import qualified Simplex.Messaging.Encoding.Base64.URL as U
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicAuthKey, RecipientId, TransmissionAuth)
import Simplex.Messaging.Protocol (CorrId, RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth)
import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.Transport (THandleParams (..))
import Simplex.Messaging.Transport.Buffer (trimCR)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
import Simplex.Messaging.Transport.HTTP2.Server
import Simplex.Messaging.Transport.Server (runTCPServer)
import Simplex.Messaging.Util
@@ -67,13 +69,12 @@ import qualified UnliftIO.Exception as E
type M a = ReaderT XFTPEnv IO a
data XFTPTransportRequest =
XFTPTransportRequest
{ thParams :: THandleParams XFTPVersion,
reqBody :: HTTP2Body,
request :: H.Request,
sendResponse :: H.Response -> IO ()
}
data XFTPTransportRequest = XFTPTransportRequest
{ thParams :: THandleParams XFTPVersion,
reqBody :: HTTP2Body,
request :: H.Request,
sendResponse :: H.Response -> IO ()
}
runXFTPServer :: XFTPServerConfig -> IO ()
runXFTPServer cfg = do
@@ -373,8 +374,19 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
receiveServerFile FileRec {senderId, fileInfo = FileInfo {size, digest}, filePath} = case bodyPart of
Nothing -> pure $ FRErr SIZE
-- TODO validate body size from request before downloading, once it's populated
Just getBody -> ifM reserve receive (pure $ FRErr QUOTA) -- TODO: handle duplicate uploads
Just getBody -> skipCommitted $ ifM reserve receive (pure $ FRErr QUOTA)
where
-- having a filePath means the file is already uploaded and committed, must not change anything
skipCommitted = ifM (isJust <$> readTVarIO filePath) (liftIO $ drain $ fromIntegral size)
where
-- can't send FROk without reading the request body or a client will block on sending it
-- can't send any old error as the client would fail or restart indefinitely
drain s = do
bs <- B.length <$> getBody fileBlockSize
if
| bs == s -> pure FROk
| bs == 0 || bs > s -> pure $ FRErr SIZE
| otherwise -> drain (s - bs)
reserve = do
us <- asks $ usedStorage . store
quota <- asks $ fromMaybe maxBound . fileSizeQuota . config