Merge branch 'wireapp:develop' into develop

changelog.d/3-bug-fixes/asset-uploads-500

@@ -0,0 +1,3 @@
+Return HTTP status 400 in case of interrupted file uploads. Previously, the AWS
+S3 error due to the wrong "content length" was interpreted as application error
+(HTTP status 500.) This led to false alerts in monitoring systems.

integration/test/Test/Cargohold/API/V3.hs

@@ -21,18 +21,24 @@ module Test.Cargohold.API.V3 where
 
 import API.Cargohold
 import Codec.MIME.Type (showMIMEType)
+import Crypto.Random
 import qualified Data.Aeson.KeyMap as KM
+import qualified Data.ByteString as BS
+import Data.ByteString.Builder
 import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy as LBS
 import Data.CaseInsensitive
 import Data.String.Conversions
-import Data.Text.Encoding (encodeUtf8)
+import Data.Text
+import Data.Text.Encoding
 import Data.Time.Clock (UTCTime)
 import Data.Time.Format
 import Data.Time.Format.ISO8601
 import Network.HTTP.Client
 import SetupHelpers
 import Test.Cargohold.API.Util
 import Testlib.Prelude
+import Text.Read (readMaybe)
 
 --------------------------------------------------------------------------------
 -- Simple (single-step) uploads
@@ -103,3 +109,37 @@ testSimpleRoundtrip = do
       let Just date' = C8.unpack <$> lookup (mk $ cs "Date") r4.headers
       let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime
       assertBool "bad date" (utc' >= utc)
+
+-- | Simulates an interrupted upload, where the user sends less data than expected.
+testUploadWrongContentLength :: (HasCallStack) => App ()
+testUploadWrongContentLength = do
+  uid <- randomUser OwnDomain def
+  let payloadBytes = 2 * 1024
+  payload <- BS.fromStrict <$> (liftIO . getRandomBytes) payloadBytes
+  let -- A too small offset (<= 16) to the correct payloadBytes may lead to
+      -- having the delimiter `--frontier--` being interpreted as content. So,
+      -- we add a big offset here.
+      tooBigContentLength = payloadBytes + 1024
+  uploadRaw uid (body tooBigContentLength payload) >>= \resp -> do
+    resp.status `shouldMatchInt` 400
+    resp.jsonBody %. "label" `shouldMatch` "incomplete-body"
+
+  -- Sanity check
+  key <-
+    uploadRaw uid (body payloadBytes payload) >>= \resp -> do
+      resp.status `shouldMatchInt` 201
+      resp.json %. "key"
+
+  bindResponse (downloadAsset uid uid key "nginz-https.example.com" id) $ \resp -> do
+    resp.status `shouldMatchInt` 200
+    let contentLength = (readMaybe . unpack . decodeUtf8) . snd =<< contentLengthHeader resp
+    assertBool "Content-Length matches" $ contentLength == (Just payloadBytes)
+    assertBool "Body" $ resp.body == (LBS.toStrict payload)
+  where
+    body :: Int -> LBS.ByteString -> LBS.ByteString
+    body contentLength payload =
+      let settings = object ["public" .= False, "retention" .= "volatile"]
+       in toLazyByteString
+            $ beginMultipartBody settings applicationOctetStream' (fromIntegral contentLength)
+            <> lazyByteString payload
+            <> endMultipartBody'

integration/test/Testlib/HTTP.hs

@@ -22,7 +22,7 @@ import Data.Tuple.Extra
 import GHC.Generics
 import GHC.Stack
 import qualified Network.HTTP.Client as HTTP
-import Network.HTTP.Types (hLocation)
+import Network.HTTP.Types (hContentLength, hLocation)
 import qualified Network.HTTP.Types as HTTP
 import Network.HTTP.Types.URI (parseQuery)
 import Network.URI (URI (..), URIAuth (..), parseURI)
@@ -234,6 +234,9 @@ locationHeaderHost resp =
 locationHeader :: Response -> Maybe (HTTP.HeaderName, ByteString)
 locationHeader = findHeader hLocation
 
+contentLengthHeader :: Response -> Maybe (HTTP.HeaderName, ByteString)
+contentLengthHeader = findHeader hContentLength
+
 findHeader :: HTTP.HeaderName -> Response -> Maybe (HTTP.HeaderName, ByteString)
 findHeader name resp = find (\(name', _) -> name == name') resp.headers
 

libs/wire-api/src/Wire/API/Error/Cargohold.hs

@@ -28,6 +28,7 @@ data CargoholdError
   | NoMatchingAssetEndpoint
   | UnverifiedUser
   | UserNotFound
+  | IncompleteBody
 
 instance (Typeable (MapError e), KnownError (MapError e)) => IsSwaggerError (e :: CargoholdError) where
   addToOpenApi = addStaticErrorToSwagger @(MapError e)
@@ -46,3 +47,5 @@ type instance MapError 'UserNotFound = 'StaticError 403 "not-found" "User not fo
 
 -- | Return `AssetNotFound` to hide there's a multi-ingress setup.
 type instance MapError 'NoMatchingAssetEndpoint = MapError 'AssetNotFound
+
+type instance MapError 'IncompleteBody = 'StaticError 400 "incomplete-body" "HTTP content-length header does not match body size"

libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs

@@ -141,6 +141,7 @@ type BaseAPIv3 (tag :: PrincipalTag) =
     ( Summary "Upload an asset"
         :> CanThrow 'AssetTooLarge
         :> CanThrow 'InvalidLength
+        :> CanThrow 'IncompleteBody
         :> tag
         :> AssetBody
         :> MultiVerb
@@ -292,6 +293,7 @@ type MainAPI =
                :> From 'V2
                :> CanThrow 'AssetTooLarge
                :> CanThrow 'InvalidLength
+               :> CanThrow 'IncompleteBody
                :> ZLocalUser
                :> "assets"
                :> AssetBody

services/cargohold/src/CargoHold/API/Error.hs

@@ -44,6 +44,9 @@ userNotFound = errorToWai @'UserNotFound
 noMatchingAssetEndpoint :: Error
 noMatchingAssetEndpoint = errorToWai @'NoMatchingAssetEndpoint
 
+incompleteBody :: Error
+incompleteBody = errorToWai @'IncompleteBody
+
 clientError :: LText -> Error
 clientError = mkError status400 "client-error"
 

services/cargohold/src/CargoHold/AWS.hs

@@ -37,6 +37,7 @@ where
 import Amazonka (AWSRequest, AWSResponse)
 import qualified Amazonka as AWS
 import qualified Amazonka.S3 as S3
+import CargoHold.API.Error
 import CargoHold.CloudFront
 import CargoHold.Options hiding (cloudFront, s3Bucket)
 import Conduit
@@ -177,11 +178,16 @@ exec env request = do
         Log.field "remote" (Log.val "S3")
           ~~ Log.msg (show err)
           ~~ Log.msg (show req)
-      -- We just re-throw the error, but logging it here also gives us the request
-      -- that caused it.
-      throwM (GeneralError err)
+      -- We re-throw the error, but distinguish between user errors and server
+      -- errors. Logging it here also gives us the request that caused it.
+      rethrowError err
     Right r -> pure r
 
+rethrowError :: (MonadThrow m) => AWS.Error -> m a
+rethrowError e = case e of
+  AWS.ServiceError se | se ^. AWS.serviceError_code == AWS.ErrorCode "IncompleteBody" -> throwM incompleteBody
+  _ -> throwM (GeneralError e)
+
 execStream ::
   ( AWSRequest r,
     Typeable r,

tools/db/migrate-features/src/Main.hs

@@ -35,8 +35,8 @@ main :: IO ()
 main = do
   s <- execParser (info (helper <*> settingsParser) desc)
   lgr <- initLogger
-  gc <- initCas (s ^. setCasGalley) lgr -- Galley's Cassandra
-  runCommand gc
+  cs <- initCas (s ^. setCasGalley) lgr
+  runCommand MigrationOpts {granularity = s ^. setGranularity, logger = lgr, clientState = cs}
   where
     desc =
       header "migrate-features"

tools/db/migrate-features/src/Options.hs

@@ -19,6 +19,7 @@
 
 module Options
   ( setCasGalley,
+    setGranularity,
     cHosts,
     cPort,
     cKeyspace,
@@ -33,7 +34,8 @@ import Imports
 import Options.Applicative
 
 data MigratorSettings = MigratorSettings
-  { _setCasGalley :: !CassandraSettings
+  { _setCasGalley :: !CassandraSettings,
+    _setGranularity :: Int
   }
   deriving (Show)
 
@@ -52,6 +54,14 @@ settingsParser :: Parser MigratorSettings
 settingsParser =
   MigratorSettings
     <$> cassandraSettingsParser "galley"
+    <*> option
+      auto
+      ( long "granularity"
+          <> metavar "INT"
+          <> help "Number of migrated teams for status report"
+          <> value 10000
+          <> showDefault
+      )
 
 cassandraSettingsParser :: String -> Parser CassandraSettings
 cassandraSettingsParser ks =