Stream object transfers with shared byte throttling
This commit is contained in:
parent
a4e615096c
commit
4b044b1456
1 changed files with 1228 additions and 105 deletions
|
|
@ -9,15 +9,11 @@ module Nuthatch.App
|
|||
) where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Exception (SomeException, try)
|
||||
import Control.Monad (forever, unless, void, when)
|
||||
import Control.Exception (SomeException, throwIO, try)
|
||||
import Control.Monad (forever, void, when)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Except (runExceptT)
|
||||
import Crypto.Hash (Digest, SHA256, hashlazy)
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.ByteArray as BA
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Either (isRight)
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
|
|
@ -43,19 +39,33 @@ import qualified Nuthatch.Db as Db
|
|||
import Nuthatch.Oidc
|
||||
import Nuthatch.Paths
|
||||
import Nuthatch.Protocol
|
||||
import Nuthatch.Redis (Redis, cacheGet, cacheInvalidatePrefixes, cacheSet, throttleTake)
|
||||
import Nuthatch.Redis
|
||||
( Redis
|
||||
, cacheGet
|
||||
, cacheInvalidatePrefixes
|
||||
, cacheSet
|
||||
, throttleCheck
|
||||
, throttleTake
|
||||
)
|
||||
import Nuthatch.S3
|
||||
( ListPage (..)
|
||||
, ObjectInfo (..)
|
||||
, PutObjectError (..)
|
||||
, S3
|
||||
, S3Error (..)
|
||||
, deleteObject
|
||||
, getObjectBytes
|
||||
, getObjectSource
|
||||
, headObject
|
||||
, listObjects
|
||||
, putObject
|
||||
, observeObjectFully
|
||||
, putObjectStream
|
||||
, renderS3Error
|
||||
)
|
||||
import Nuthatch.Session
|
||||
import Nuthatch.Streaming
|
||||
( BandwidthError (..)
|
||||
, UploadStreamError (..)
|
||||
)
|
||||
import Nuthatch.Types
|
||||
import Nuthatch.Ui (browsePage, browserScript)
|
||||
import Servant
|
||||
|
|
@ -63,7 +73,7 @@ import Servant.Server.Experimental.Auth
|
|||
( AuthHandler
|
||||
, mkAuthHandler
|
||||
)
|
||||
import Servant.Types.SourceT (runSourceT, source)
|
||||
import Servant.Types.SourceT (SourceT)
|
||||
import Web.Cookie
|
||||
( defaultSetCookie
|
||||
, parseCookies
|
||||
|
|
@ -306,17 +316,9 @@ handleDownloadRequest env session root path = do
|
|||
(DownloadObjectStoreFailed (renderS3Error message))
|
||||
Right Nothing -> throwOperationError err404 DownloadNotFound
|
||||
Right (Just value) -> pure value
|
||||
throttle <- liftIO $
|
||||
throttleTake (envRedis env) (envConfig env) (suUserId user) (oiSize info)
|
||||
case throttle of
|
||||
Left _ -> throwOperationError err503 DownloadThrottleUnavailable
|
||||
Right False -> throwOperationError err429 DownloadBandwidthExceeded
|
||||
Right True -> pure ()
|
||||
result <- liftIO (getObjectBytes (envS3 env) key)
|
||||
body <- either
|
||||
(throwOperationError status502Error . DownloadObjectStoreFailed . renderS3Error)
|
||||
pure
|
||||
result
|
||||
requireDownloadBandwidth env user (oiSize info)
|
||||
let inspect = inspectBandwidth env user
|
||||
body = getObjectSource (envS3 env) key (transferPieceSize env) inspect
|
||||
liftIO $ audit "download" "ok" (Just (unUserId (suUserId user)))
|
||||
[ ("root", A.toJSON (rootLabel root))
|
||||
, ("bytes", A.toJSON (oiSize info))
|
||||
|
|
@ -324,7 +326,8 @@ handleDownloadRequest env session root path = do
|
|||
let filename = sanitizeFilename (basename path)
|
||||
pure $
|
||||
addHeader ("attachment; filename=\"" <> filename <> "\"") $
|
||||
addHeader "nosniff" (source (BL.toChunks body))
|
||||
addHeader "nosniff" $
|
||||
addHeader (oiSize info) body
|
||||
|
||||
handleUploadRequest
|
||||
:: Env
|
||||
|
|
@ -339,31 +342,16 @@ handleUploadRequest
|
|||
-> Handler UploadResponse
|
||||
handleUploadRequest env session root path operation declaredSize contentIdentity providedCsrf bodySource = do
|
||||
requireCsrf UploadCsrfRejected session providedCsrf
|
||||
chunksResult <- liftIO (runExceptT (runSourceT bodySource))
|
||||
chunks <- either
|
||||
(throwOperationError err400 . UploadInvalidBodyStream . T.pack)
|
||||
pure
|
||||
chunksResult
|
||||
let user = sessionUser session
|
||||
body = BL.fromChunks chunks
|
||||
size = unDeclaredSize declaredSize
|
||||
actualSize = toInteger (BL.length body)
|
||||
configuredMaximum = cfgMaxObjectBytes (envConfig env)
|
||||
unless (actualSize == size) $
|
||||
throwOperationError err400 UploadSizeMismatch
|
||||
when (size > configuredMaximum) $
|
||||
throwOperationError err413 UploadTooLarge
|
||||
unless (contentSha256 body == contentIdentity) $
|
||||
throwOperationError err400 UploadContentIdentityMismatch
|
||||
throttle <- liftIO $
|
||||
throttleTake (envRedis env) (envConfig env) (suUserId user) size
|
||||
case throttle of
|
||||
Left _ -> throwOperationError err503 UploadThrottleUnavailable
|
||||
Right False -> throwOperationError err429 UploadBandwidthExceeded
|
||||
Right True -> pure ()
|
||||
outcome <- liftIO (runPut env user root path operation size contentIdentity body)
|
||||
requireUploadBandwidth env user size
|
||||
outcome <- liftIO $
|
||||
runPut env user root path operation size contentIdentity bodySource
|
||||
result <- either
|
||||
(throwOperationError err409 . UploadMutationRejected)
|
||||
throwPutFailure
|
||||
pure
|
||||
outcome
|
||||
liftIO $ audit "put" (mutationAuditResult result) (Just (unUserId (suUserId user)))
|
||||
|
|
@ -376,6 +364,48 @@ handleUploadRequest env session root path operation declaredSize contentIdentity
|
|||
, uploadResponseResult = result
|
||||
}
|
||||
|
||||
requireDownloadBandwidth :: Env -> SessionUser -> Integer -> Handler ()
|
||||
requireDownloadBandwidth env user size = do
|
||||
available <- liftIO $
|
||||
throttleCheck
|
||||
(envRedis env)
|
||||
(envConfig env)
|
||||
(suUserId user)
|
||||
(min size (toInteger (transferPieceSize env)))
|
||||
case available of
|
||||
Left _ -> throwOperationError err503 DownloadThrottleUnavailable
|
||||
Right False -> throwOperationError err429 DownloadBandwidthExceeded
|
||||
Right True -> pure ()
|
||||
|
||||
requireUploadBandwidth :: Env -> SessionUser -> Integer -> Handler ()
|
||||
requireUploadBandwidth env user size = do
|
||||
available <- liftIO $
|
||||
throttleCheck
|
||||
(envRedis env)
|
||||
(envConfig env)
|
||||
(suUserId user)
|
||||
(min size (toInteger (transferPieceSize env)))
|
||||
case available of
|
||||
Left _ -> throwOperationError err503 UploadThrottleUnavailable
|
||||
Right False -> throwOperationError err429 UploadBandwidthExceeded
|
||||
Right True -> pure ()
|
||||
|
||||
inspectBandwidth :: Env -> SessionUser -> BS.ByteString -> IO ()
|
||||
inspectBandwidth env user chunk = do
|
||||
result <- throttleTake
|
||||
(envRedis env)
|
||||
(envConfig env)
|
||||
(suUserId user)
|
||||
(toInteger (BS.length chunk))
|
||||
case result of
|
||||
Left _ -> throwIO BandwidthUnavailable
|
||||
Right False -> throwIO BandwidthExceeded
|
||||
Right True -> pure ()
|
||||
|
||||
transferPieceSize :: Env -> Int
|
||||
transferPieceSize env =
|
||||
fromInteger (max 1 (min 65536 (cfgThrottleBurstBytes (envConfig env))))
|
||||
|
||||
handleDeleteRequest
|
||||
:: Env
|
||||
-> SessionContext
|
||||
|
|
@ -495,8 +525,8 @@ runPut
|
|||
-> OperationId
|
||||
-> Integer
|
||||
-> ContentSha256
|
||||
-> BL.ByteString
|
||||
-> IO (Either Text MutationResult)
|
||||
-> SourceT IO BS.ByteString
|
||||
-> IO (Either PutFailure MutationResult)
|
||||
runPut env user root rel op size sha body = do
|
||||
ensurePersonalPool (envDb env) (envConfig env) (suUserId user)
|
||||
let uid = suUserId user
|
||||
|
|
@ -509,12 +539,57 @@ runPut env user root rel op size sha body = do
|
|||
(cfgMaxObjectBytes (envConfig env))
|
||||
case outcome of
|
||||
AdmitConflict -> pure (Right MutationConflict)
|
||||
AdmitRejected reason _ -> pure (Left reason)
|
||||
AdmitRejected reason _ -> pure (Left (PutRejected reason))
|
||||
AdmitReplay MutationPending _ -> pure (Right MutationPending)
|
||||
AdmitReplay result _ -> pure (Right result)
|
||||
AdmitPrepared rec -> dispatchAndFinalize env user root rec $ do
|
||||
_ <- putObject (envS3 env) key size (Just sha) body
|
||||
pure ()
|
||||
AdmitPrepared rec ->
|
||||
dispatchAndFinalize
|
||||
env
|
||||
user
|
||||
root
|
||||
rec
|
||||
PutSettlementFailed
|
||||
(putObjectStream
|
||||
(envS3 env)
|
||||
key
|
||||
size
|
||||
(Just sha)
|
||||
(transferPieceSize env)
|
||||
(inspectBandwidth env user)
|
||||
body
|
||||
>>= pure . either (Left . PutDispatchFailed) Right)
|
||||
|
||||
data PutFailure
|
||||
= PutRejected Text
|
||||
| PutDispatchFailed PutObjectError
|
||||
| PutSettlementFailed
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
throwPutFailure :: PutFailure -> Handler a
|
||||
throwPutFailure failure =
|
||||
case failure of
|
||||
PutRejected reason ->
|
||||
throwOperationError err409 (UploadMutationRejected reason)
|
||||
PutDispatchFailed (PutObjectStreamError streamError) ->
|
||||
case streamError of
|
||||
UploadStreamInvalid message ->
|
||||
throwOperationError err400 (UploadInvalidBodyStream (T.pack message))
|
||||
UploadStreamSizeMismatch ->
|
||||
throwOperationError err400 UploadSizeMismatch
|
||||
UploadStreamIdentityMismatch ->
|
||||
throwOperationError err400 UploadContentIdentityMismatch
|
||||
PutDispatchFailed (PutObjectBandwidthError bandwidthError) ->
|
||||
case bandwidthError of
|
||||
BandwidthUnavailable ->
|
||||
throwOperationError err503 UploadThrottleUnavailable
|
||||
BandwidthExceeded ->
|
||||
throwOperationError err429 UploadBandwidthExceeded
|
||||
PutDispatchFailed (PutObjectStoreError err) ->
|
||||
throwOperationError err409
|
||||
(UploadMutationRejected (renderS3Error err))
|
||||
PutSettlementFailed ->
|
||||
throwOperationError err409
|
||||
(UploadMutationRejected "mutation failed after store settlement")
|
||||
|
||||
runDelete
|
||||
:: Env
|
||||
|
|
@ -538,9 +613,15 @@ runDelete env user root rel op = do
|
|||
AdmitRejected reason _ -> pure (Left reason)
|
||||
AdmitReplay MutationPending _ -> pure (Right MutationPending)
|
||||
AdmitReplay result _ -> pure (Right result)
|
||||
AdmitPrepared rec -> dispatchAndFinalize env user root rec $ do
|
||||
_ <- deleteObject (envS3 env) key
|
||||
pure ()
|
||||
AdmitPrepared rec ->
|
||||
dispatchAndFinalize
|
||||
env
|
||||
user
|
||||
root
|
||||
rec
|
||||
"mutation failed after store settlement"
|
||||
(deleteObject (envS3 env) key
|
||||
>>= pure . either (Left . renderS3Error) Right)
|
||||
|
||||
deletePrefix :: Env -> SessionUser -> Root -> Text -> IO (Either Text Int)
|
||||
deletePrefix env user root prefix = do
|
||||
|
|
@ -596,9 +677,10 @@ dispatchAndFinalize
|
|||
-> SessionUser
|
||||
-> Root
|
||||
-> MutationRecord
|
||||
-> IO ()
|
||||
-> IO (Either Text MutationResult)
|
||||
dispatchAndFinalize env user root rec dispatch = do
|
||||
-> failure
|
||||
-> IO (Either failure ())
|
||||
-> IO (Either failure MutationResult)
|
||||
dispatchAndFinalize env user root rec settlementFailure dispatch = do
|
||||
prepared <- withTransaction (envDb env) $ \conn -> do
|
||||
moved <- markApplying conn rec
|
||||
if not moved
|
||||
|
|
@ -607,7 +689,7 @@ dispatchAndFinalize env user root rec dispatch = do
|
|||
if not prepared
|
||||
then pure (Right MutationPending)
|
||||
else do
|
||||
_ <- try dispatch :: IO (Either SomeException ())
|
||||
dispatchResult <- dispatch
|
||||
observed <- observeObject (envS3 env) (mrObjectKey rec)
|
||||
finalized <- withTransaction (envDb env) $ \conn -> do
|
||||
settled <- markExternalSettled conn rec
|
||||
|
|
@ -620,23 +702,17 @@ dispatchAndFinalize env user root rec dispatch = do
|
|||
(listCacheAncestorPrefixes (mrRelativePath rec))
|
||||
pure (Right MutationSucceeded)
|
||||
Just MutationFailed ->
|
||||
pure (Left "mutation failed after store settlement")
|
||||
pure (Left (either id (const settlementFailure) dispatchResult))
|
||||
Just other -> pure (Right other)
|
||||
Nothing -> pure (Right MutationPending)
|
||||
|
||||
observeObject :: S3 -> ObjectKey -> IO ObjectObservation
|
||||
observeObject s3 key = do
|
||||
result <- headObject s3 key
|
||||
result <- observeObjectFully s3 key
|
||||
case result of
|
||||
Right (Just info@ObjectInfo { oiSha256 = Just _ }) ->
|
||||
Right info ->
|
||||
pure (ObjectPresent (oiSize info) (oiSha256 info))
|
||||
Right (Just _) -> do
|
||||
body <- getObjectBytes s3 key
|
||||
pure $ case body of
|
||||
Right bytes ->
|
||||
ObjectPresent (toInteger (BL.length bytes)) (Just (contentSha256 bytes))
|
||||
Left err -> ObjectUnavailable (renderS3Error err)
|
||||
Right Nothing -> pure ObjectAbsent
|
||||
Left S3NotFound -> pure ObjectAbsent
|
||||
Left err -> pure (ObjectUnavailable (renderS3Error err))
|
||||
|
||||
listEntries :: Env -> SessionUser -> Root -> Text -> IO (Either Text [ListEntry])
|
||||
|
|
@ -781,10 +857,6 @@ recoverOne env rec =
|
|||
pure ()
|
||||
_ -> pure ()
|
||||
|
||||
contentSha256 :: BL.ByteString -> ContentSha256
|
||||
contentSha256 body =
|
||||
ContentSha256 . TE.decodeUtf8 . B16.encode . BA.convert $
|
||||
(hashlazy body :: Digest SHA256)
|
||||
|
||||
lastSeg :: Text -> Text
|
||||
lastSeg t =
|
||||
|
|
|
|||
Loading…
Reference in a new issue