Stream object transfers with shared byte throttling

2026-07-18 20:48:26 +09:00 · 2026-07-18 20:48:26 +09:00 · 4b044b1456
commit 4b044b1456
parent a4e615096c
6 changed files with 1228 additions and 105 deletions
--- a/src/Nuthatch/Api.hs
+++ b/src/Nuthatch/Api.hs
@ -431,6 +431,7 @@ type DownloadSuccess =
  Headers
    '[ Header "Content-Disposition" Text
     , Header "X-Content-Type-Options" Text
+     , Header "Content-Length" Integer
     ]
    (SourceIO BS.ByteString)

--- a/src/Nuthatch/App.hs
+++ b/src/Nuthatch/App.hs
@ -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 =
--- a/src/Nuthatch/Config.hs
+++ b/src/Nuthatch/Config.hs
@ -10,6 +10,7 @@ import           Data.Maybe (fromMaybe)
 import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
+import           Nuthatch.Streaming (maximumMultipartBytes)
 import           System.Environment (lookupEnv)
 import           Text.Read (readMaybe)

@ -102,6 +103,12 @@ loadConfig = do
  maxObject <- envInteger "NUTHATCH_MAX_OBJECT_BYTES" (100 * 1024 * 1024)
  throttleRate <- envInteger "NUTHATCH_THROTTLE_BYTES_PER_SEC" (10 * 1024 * 1024)
  throttleBurst <- envInteger "NUTHATCH_THROTTLE_BURST_BYTES" (20 * 1024 * 1024)
+  when (maxObject <= 0 || maxObject > maximumMultipartBytes) $
+    fail "NUTHATCH_MAX_OBJECT_BYTES exceeds the supported streaming range"
+  when (throttleRate <= 0 || throttleRate > luaExactIntegerMax) $
+    fail "NUTHATCH_THROTTLE_BYTES_PER_SEC exceeds the exact throttle range"
+  when (throttleBurst <= 0 || throttleBurst > luaExactIntegerMax) $
+    fail "NUTHATCH_THROTTLE_BURST_BYTES exceeds the exact throttle range"
  listTtl <- envInteger "NUTHATCH_LIST_CACHE_TTL_SEC" 30
  searchMax <- fromInteger <$> envInteger "NUTHATCH_SEARCH_MAX_KEYS" 500
  recoveryGrace <- envInteger "NUTHATCH_RECOVERY_GRACE_SEC" 90
@ -143,6 +150,9 @@ loadConfig = do
    , cfgRecoveryGraceSec = recoveryGrace
    }

+luaExactIntegerMax :: Integer
+luaExactIntegerMax = 9007199254740991
+
 splitHostPort :: String -> (String, String)
 splitHostPort s =
  case break (== ':') s of
--- a/src/Nuthatch/Redis.hs
+++ b/src/Nuthatch/Redis.hs
@ -4,6 +4,7 @@ module Nuthatch.Redis
  , cacheGet
  , cacheSet
  , cacheInvalidatePrefixes
+  , throttleCheck
  , throttleTake
  ) where

@ -13,7 +14,6 @@ import qualified Data.ByteString.Char8 as BS8
 import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
-import           Data.Time.Clock.POSIX (getPOSIXTime)
 import           Database.Redis
  ( ConnectInfo (..)
  , Connection
@ -69,9 +69,21 @@ cacheInvalidatePrefixes conn uid root prefixes = do
            :: IO (Either SomeException (Either Reply Integer))
      pure ()

+throttleCheck :: Redis -> Config -> UserId -> Integer -> IO (Either Text Bool)
+throttleCheck conn cfg uid bytes =
+  throttleRequest conn cfg uid bytes False
+
 throttleTake :: Redis -> Config -> UserId -> Integer -> IO (Either Text Bool)
-throttleTake conn cfg uid bytes = do
-  now <- floor <$> getPOSIXTime
+throttleTake conn cfg uid bytes = throttleRequest conn cfg uid bytes True
+
+throttleRequest
+  :: Redis
+  -> Config
+  -> UserId
+  -> Integer
+  -> Bool
+  -> IO (Either Text Bool)
+throttleRequest conn cfg uid bytes consume = do
  let key = TE.encodeUtf8 ("nuthatch:throttle:" <> unUserId uid)
      rate = cfgThrottleBytesPerSec cfg
      burst = cfgThrottleBurstBytes cfg
@ -80,8 +92,11 @@ throttleTake conn cfg uid bytes = do
          [ "local key = KEYS[1]"
          , "local rate = tonumber(ARGV[1])"
          , "local burst = tonumber(ARGV[2])"
-          , "local now = tonumber(ARGV[3])"
-          , "local need = tonumber(ARGV[4])"
+          , "local need = tonumber(ARGV[3])"
+          , "local consume = tonumber(ARGV[4])"
+          , "local clock = redis.call('TIME')"
+          , "local now = tonumber(clock[1]) + tonumber(clock[2]) / 1000000"
+          , "local ttl = math.max(1, math.ceil(burst / rate))"
          , "local data = redis.call('HMGET', key, 'tokens', 'ts')"
          , "local tokens = tonumber(data[1])"
          , "local ts = tonumber(data[2])"
@ -91,20 +106,20 @@ throttleTake conn cfg uid bytes = do
          , "tokens = math.min(burst, tokens + delta * rate)"
          , "if tokens < need then"
          , "  redis.call('HMSET', key, 'tokens', tokens, 'ts', now)"
-          , "  redis.call('EXPIRE', key, 3600)"
+          , "  redis.call('EXPIRE', key, ttl)"
          , "  return 0"
          , "end"
-          , "tokens = tokens - need"
+          , "if consume == 1 then tokens = tokens - need end"
          , "redis.call('HMSET', key, 'tokens', tokens, 'ts', now)"
-          , "redis.call('EXPIRE', key, 3600)"
+          , "redis.call('EXPIRE', key, ttl)"
          , "return 1"
          ]
  result <- try (runRedis conn $
    R.eval script [key]
      [ BS8.pack (show rate)
      , BS8.pack (show burst)
-      , BS8.pack (show (now :: Integer))
      , BS8.pack (show bytes)
+      , if consume then "1" else "0"
      ]) :: IO (Either SomeException (Either Reply Integer))
  pure $ case result of
    Left _ -> Left "redis unavailable"
--- a/src/Nuthatch/S3.hs
+++ b/src/Nuthatch/S3.hs
@ -1,12 +1,16 @@
 module Nuthatch.S3
  ( S3
  , S3Error (..)
+  , PutObjectError (..)
  , ObjectInfo (..)
  , ListPage (..)
  , newS3
  , putObject
+  , putObjectStream
  , getObjectBytes
+  , getObjectSource
  , headObject
+  , observeObjectFully
  , deleteObject
  , listObjects
  , renderS3Error
@ -16,8 +20,24 @@ import qualified Aws
 import qualified Aws.Aws as AwsRun
 import qualified Aws.Core as AwsCore
 import qualified Aws.S3 as S3
+import           Control.Concurrent.Async (withAsync)
+import           Control.Concurrent.STM
+  ( atomically
+  , newTBQueueIO
+  , readTBQueue
+  , writeTBQueue
+  )
 import           Control.Applicative ((<|>))
-import           Control.Exception (SomeException, fromException, try)
+import           Control.Exception
+  ( SomeAsyncException
+  , SomeException
+  , fromException
+  , onException
+  , throwIO
+  , try
+  )
+import           Control.Monad (void)
+import           Control.Monad.IO.Class (liftIO)
 import           Control.Monad.Trans.Resource (runResourceT)
 import           Crypto.Hash
  ( Context
@ -32,6 +52,7 @@ import qualified Data.ByteString.Char8 as BS8
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.Conduit as C
 import qualified Data.Conduit.List as CL
+import           Data.IORef
 import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
@ -40,7 +61,18 @@ import           Network.HTTP.Client.TLS (tlsManagerSettings)
 import           Network.HTTP.Types.Status (statusCode)
 import           Network.URI (URI (..), URIAuth (..), parseURI)
 import           Nuthatch.Config (Config (..))
+import           Nuthatch.Streaming
+  ( BandwidthError (..)
+  , UploadStreamError (..)
+  , consumeUploadParts
+  , maximumMultipartBytes
+  , multipartPartBytes
+  )
 import           Nuthatch.Types
+import           Servant.Types.SourceT
+  ( SourceT (..)
+  , StepT (..)
+  )
 import           Text.Read (readMaybe)

 data S3 = S3
@ -57,6 +89,12 @@ data S3Error
  | S3ResponseError
  deriving stock (Eq, Show)

+data PutObjectError
+  = PutObjectStoreError S3Error
+  | PutObjectStreamError UploadStreamError
+  | PutObjectBandwidthError BandwidthError
+  deriving stock (Eq, Show)
+
 data ObjectInfo = ObjectInfo
  { oiSize   :: Integer
  , oiSha256 :: Maybe ContentSha256
@ -127,6 +165,110 @@ newS3 cfg = do
    , s3Bucket = cfgS3Bucket cfg
    }

+putObjectStream
+  :: S3
+  -> ObjectKey
+  -> Integer
+  -> Maybe ContentSha256
+  -> Int
+  -> (BS8.ByteString -> IO ())
+  -> SourceT IO BS8.ByteString
+  -> IO (Either PutObjectError ())
+putObjectStream store (ObjectKey key) size sha pieceSize inspect body =
+  if size > maximumMultipartBytes
+    then pure (Left (PutObjectStoreError S3ResponseError))
+    else case sha of
+      Nothing -> pure (Left (PutObjectStoreError S3ResponseError))
+      Just identity
+        | size == 0 -> do
+          streamed <- trySynchronous
+            (consumeUploadParts
+              size identity pieceSize multipartPartBytes inspect body
+              (const (throwIO UploadStreamSizeMismatch)))
+          case streamed of
+            Left exception -> pure (Left (classifyPutException exception))
+            Right () -> putEmptyObject store key sha
+        | otherwise -> do
+          initiated <- trySynchronous $ runMemory store $
+            (S3.postInitiateMultipartUpload (s3Bucket store) key)
+              { S3.imuContentType = Just "application/octet-stream"
+              , S3.imuMetadata =
+                  [("nuthatch-sha256", unContentSha256 identity)]
+              }
+          case initiated of
+            Left exception ->
+              pure (Left (PutObjectStoreError (classifyException exception)))
+            Right response -> uploadMultipart
+              store key size identity pieceSize inspect body
+              (S3.imurUploadId response)
+
+putEmptyObject
+  :: S3
+  -> Text
+  -> Maybe ContentSha256
+  -> IO (Either PutObjectError ())
+putEmptyObject store key sha = do
+  result <- trySynchronous $ runMemory store $
+    (S3.putObject (s3Bucket store) key (HTTP.RequestBodyBS BS8.empty))
+      { S3.poContentType = Just "application/octet-stream"
+      , S3.poMetadata = maybe []
+          (\identity ->
+            [("nuthatch-sha256", unContentSha256 identity)])
+          sha
+      }
+  pure $ either
+    (Left . PutObjectStoreError . classifyException)
+    (const (Right ()))
+    result
+
+uploadMultipart
+  :: S3
+  -> Text
+  -> Integer
+  -> ContentSha256
+  -> Int
+  -> (BS8.ByteString -> IO ())
+  -> SourceT IO BS8.ByteString
+  -> Text
+  -> IO (Either PutObjectError ())
+uploadMultipart store key size identity pieceSize inspect body uploadId = do
+  nextPartRef <- newIORef (1 :: Integer)
+  etagsRef <- newIORef []
+  let abort = void (try (runMemory store $
+        S3.postAbortMultipartUpload (s3Bucket store) key uploadId)
+        :: IO (Either SomeException S3.AbortMultipartUploadResponse))
+      upload = do
+        consumeUploadParts
+          size identity pieceSize multipartPartBytes inspect body $ \part -> do
+            partNumber <- readIORef nextPartRef
+            response <- runMemory store $
+              S3.uploadPart
+                (s3Bucket store)
+                key
+                partNumber
+                uploadId
+                (HTTP.RequestBodyBS part)
+            modifyIORef' etagsRef ((partNumber, S3.uprETag response) :)
+            writeIORef nextPartRef (partNumber + 1)
+        etags <- reverse <$> readIORef etagsRef
+        void $ runMemory store $
+          S3.postCompleteMultipartUpload
+            (s3Bucket store)
+            key
+            uploadId
+            etags
+  result <- trySynchronous (upload `onException` abort)
+  case result of
+    Right () -> pure (Right ())
+    Left exception -> pure (Left (classifyPutException exception))
+
+classifyPutException :: SomeException -> PutObjectError
+classifyPutException exception =
+  case (fromException exception, fromException exception) of
+    (Just streamError, _) -> PutObjectStreamError streamError
+    (_, Just bandwidthError) -> PutObjectBandwidthError bandwidthError
+    _ -> PutObjectStoreError (classifyException exception)
+
 putObject
  :: S3
  -> ObjectKey
@ -154,6 +296,61 @@ getObjectBytes store (ObjectKey key) = do
  result <- getObjectMemory store key
  pure $ result >>= \(_, body) -> Right body

+data DownloadEvent
+  = DownloadChunk BS8.ByteString
+  | DownloadFailed S3Error
+  | DownloadFinished
+
+getObjectSource
+  :: S3
+  -> ObjectKey
+  -> Int
+  -> (BS8.ByteString -> IO ())
+  -> SourceT IO BS8.ByteString
+getObjectSource store (ObjectKey key) pieceSize inspect =
+  SourceT $ \consume -> do
+    queue <- newTBQueueIO 2
+    withAsync (produce queue) $ \_ ->
+      consume (consumeQueue queue)
+  where
+    produce queue = do
+      result <- trySynchronous (runResourceT $ do
+        response <- AwsRun.pureAws
+          (s3Configuration store)
+          (s3Service store)
+          (s3Manager store)
+          (S3.getObject (s3Bucket store) key)
+        C.runConduit $
+          HTTP.responseBody (S3.gorResponse response)
+            C..| C.awaitForever
+              (\chunk -> mapM_
+                (liftIO . atomically . writeTBQueue queue . DownloadChunk)
+                (splitPieces chunk)))
+        :: IO (Either SomeException ())
+      atomically $ writeTBQueue queue $ case result of
+        Left exception -> DownloadFailed (classifyException exception)
+        Right () -> DownloadFinished
+
+    consumeQueue queue = Effect $ atomically (readTBQueue queue) >>= \case
+      DownloadChunk chunk -> trySynchronous (inspect chunk) >>= \case
+        Left exception ->
+          pure (Error (T.unpack (renderDownloadException exception)))
+        Right () -> pure (Yield chunk (consumeQueue queue))
+      DownloadFailed err -> pure (Error (T.unpack (renderS3Error err)))
+      DownloadFinished -> pure Stop
+
+    splitPieces chunk
+      | BS8.null chunk = []
+      | otherwise =
+          let (piece, rest) = BS8.splitAt pieceSize chunk
+          in piece : splitPieces rest
+
+    renderDownloadException exception =
+      case fromException exception of
+        Just BandwidthUnavailable -> "bandwidth throttle unavailable"
+        Just BandwidthExceeded -> "bandwidth limit exceeded"
+        Nothing -> renderS3Error (classifyException exception)
+
 headObject :: S3 -> ObjectKey -> IO (Either S3Error (Maybe ObjectInfo))
 headObject store (ObjectKey key) = do
  result <- try (runMemory store (S3.headObject (s3Bucket store) key))
@ -162,9 +359,37 @@ headObject store (ObjectKey key) = do
    Left err -> pure (Left (classifyException err))
    Right (S3.HeadObjectMemoryResponse Nothing) -> pure (Right Nothing)
    Right (S3.HeadObjectMemoryResponse (Just _)) -> do
-      object <- observeObjectStream store key
+      object <- getObjectHeaders store key
      pure (Just <$> object)

+getObjectHeaders :: S3 -> Text -> IO (Either S3Error ObjectInfo)
+getObjectHeaders store key = do
+  result <- try (runResourceT $ do
+    response <- AwsRun.pureAws
+      (s3Configuration store)
+      (s3Service store)
+      (s3Manager store)
+      (S3.getObject (s3Bucket store) key)
+    let metadata = S3.gorMetadata response
+        httpResponse = S3.gorResponse response
+        knownSize =
+          lookup "Content-Length" (HTTP.responseHeaders httpResponse)
+            >>= readMaybe . BS8.unpack
+        knownIdentity =
+          lookup "nuthatch-sha256" (S3.omUserMetadata metadata)
+            >>= either (const Nothing) Just . validateContentSha256
+    maybe (fail "missing object content length")
+      (\size -> pure ObjectInfo
+        { oiSize = size
+        , oiSha256 = knownIdentity
+        })
+      knownSize)
+    :: IO (Either SomeException ObjectInfo)
+  pure (either (Left . classifyException) Right result)
+
+observeObjectFully :: S3 -> ObjectKey -> IO (Either S3Error ObjectInfo)
+observeObjectFully store (ObjectKey key) = observeObjectStream store key
+
 deleteObject :: S3 -> ObjectKey -> IO (Either S3Error ())
 deleteObject store (ObjectKey key) = do
  result <- try (runMemory store (S3.DeleteObject key (s3Bucket store)))
@ -259,30 +484,18 @@ observeObjectStream store key = do
        (s3Service store)
        (s3Manager store)
        (S3.getObject (s3Bucket store) key)
-      let metadata = S3.gorMetadata response
-          httpResponse = S3.gorResponse response
-          knownSize =
-            lookup "Content-Length" (HTTP.responseHeaders httpResponse)
-              >>= readMaybe . BS8.unpack
-          knownIdentity =
-            lookup "nuthatch-sha256" (S3.omUserMetadata metadata)
-              >>= either (const Nothing) Just . validateContentSha256
-      case (knownSize, knownIdentity) of
-        (Just size, Just identity) ->
-          pure ObjectInfo
-            { oiSize = size
-            , oiSha256 = Just identity
-            }
-        _ -> do
-          (size, context) <- C.runConduit $
-            HTTP.responseBody httpResponse
-              C..| CL.fold updateDigest (0, hashInit)
-          pure ObjectInfo
-            { oiSize = size
-            , oiSha256 = Just (contextIdentity context)
-            }
+      let httpResponse = S3.gorResponse response
+      (size, context) <- C.runConduit $
+        HTTP.responseBody httpResponse
+          C..| CL.fold updateDigest (0, hashInit)
+      pure ObjectInfo
+        { oiSize = size
+        , oiSha256 = Just (contextIdentity context)
+        }
    updateDigest (size, context) chunk =
-      (size + toInteger (BS8.length chunk), hashUpdate context chunk)
+      let nextSize = size + toInteger (BS8.length chunk)
+          nextContext = hashUpdate context chunk
+      in nextSize `seq` nextContext `seq` (nextSize, nextContext)

 contextIdentity :: Context SHA256 -> ContentSha256
 contextIdentity =
@ -311,6 +524,15 @@ classifyException exception =
        Just (HTTP.InvalidUrlException _ _) -> S3ResponseError
        Nothing -> S3ResponseError

+trySynchronous :: IO a -> IO (Either SomeException a)
+trySynchronous action = do
+  result <- try action
+  case result of
+    Left exception
+      | Just (_ :: SomeAsyncException) <- fromException exception ->
+          throwIO exception
+    _ -> pure result
+
 lastMaybe :: [a] -> Maybe a
 lastMaybe [] = Nothing
 lastMaybe values = Just (last values)
--- a/src/Nuthatch/Streaming.hs
+++ b/src/Nuthatch/Streaming.hs
@ -0,0 +1,124 @@
+module Nuthatch.Streaming
+  ( UploadStreamError (..)
+  , BandwidthError (..)
+  , multipartPartBytes
+  , maximumMultipartBytes
+  , consumeUploadParts
+  ) where
+
+import           Control.Exception (Exception, throwIO)
+import           Crypto.Hash (Context, SHA256, hashFinalize, hashInit, hashUpdate)
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as B16
+import           Data.IORef
+import qualified Data.Text.Encoding as TE
+import           Nuthatch.Types
+import           Servant.Types.SourceT
+  ( SourceT
+  , foreach
+  )
+
+data UploadStreamError
+  = UploadStreamInvalid String
+  | UploadStreamSizeMismatch
+  | UploadStreamIdentityMismatch
+  deriving stock (Eq, Show)
+
+instance Exception UploadStreamError
+
+data BandwidthError
+  = BandwidthUnavailable
+  | BandwidthExceeded
+  deriving stock (Eq, Show)
+
+instance Exception BandwidthError
+
+multipartPartBytes :: Int
+multipartPartBytes = 5 * 1024 * 1024
+
+maximumMultipartBytes :: Integer
+maximumMultipartBytes = toInteger multipartPartBytes * 10000
+
+data UploadState = UploadState
+  { usPending     :: [BS.ByteString]
+  , usPendingSize :: Int
+  , usSize        :: Integer
+  , usHash        :: Context SHA256
+  }
+
+consumeUploadParts
+  :: Integer
+  -> ContentSha256
+  -> Int
+  -> Int
+  -> (BS.ByteString -> IO ())
+  -> SourceT IO BS.ByteString
+  -> (BS.ByteString -> IO ())
+  -> IO ()
+consumeUploadParts
+    expectedSize
+    expectedIdentity
+    pieceSize
+    partSize
+    inspect
+    body
+    emitPart = do
+  stateRef <- newIORef UploadState
+    { usPending = []
+    , usPendingSize = 0
+    , usSize = 0
+    , usHash = hashInit
+    }
+  foreach
+    (throwIO . UploadStreamInvalid)
+    (mapM_ (acceptPiece stateRef) . splitPieces)
+    body
+  state <- readIORef stateRef
+  if usSize state /= expectedSize
+    then throwIO UploadStreamSizeMismatch
+    else if digestIdentity (usHash state) /= expectedIdentity
+      then throwIO UploadStreamIdentityMismatch
+      else if usPendingSize state == 0
+        then pure ()
+        else emitPart (BS.concat (reverse (usPending state)))
+  where
+    splitPieces bytes
+      | BS.null bytes = []
+      | otherwise =
+          let (piece, rest) = BS.splitAt pieceSize bytes
+          in piece : splitPieces rest
+
+    acceptPiece stateRef piece = do
+      inspect piece
+      state <- readIORef stateRef
+      let nextSize = usSize state + toInteger (BS.length piece)
+          nextHash = hashUpdate (usHash state) piece
+      nextHash `seq` pure ()
+      if nextSize > expectedSize
+        then throwIO UploadStreamSizeMismatch
+        else fillPart stateRef state
+          { usPending = piece : usPending state
+          , usPendingSize = usPendingSize state + BS.length piece
+          , usSize = nextSize
+          , usHash = nextHash
+          }
+
+    fillPart stateRef state
+      | usPendingSize state < partSize = writeIORef stateRef state
+      | otherwise = do
+          let bytes = BS.concat (reverse (usPending state))
+              (part, remainder) = BS.splitAt partSize bytes
+          emitPart part
+          writeIORef stateRef state
+            { usPending = [remainder | not (BS.null remainder)]
+            , usPendingSize = BS.length remainder
+            }
+
+digestIdentity :: Context SHA256 -> ContentSha256
+digestIdentity =
+  ContentSha256
+    . TE.decodeUtf8
+    . B16.encode
+    . BA.convert
+    . hashFinalize