{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Test.Cargohold.API where

import API.Cargohold
import qualified Codec.MIME.Type as MIME
import Control.Lens hiding (sets, (.=))
import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.Types (Pair)
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LBS hiding (replicate)
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.CaseInsensitive (mk)
import Data.String.Conversions
import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError, rfc822DateFormat)
import Data.Time.Format.ISO8601 (formatParseM, iso8601Format)
import Network.HTTP.Client (parseUrlThrow)
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTP
import SetupHelpers (createTeam, randomId, randomUser)
import Testlib.Prelude
import UnliftIO.Concurrent

--------------------------------------------------------------------------------
-- Simple (single-step) uploads

testSimpleRoundtrip :: (HasCallStack) => App ()
testSimpleRoundtrip :: HasCallStack => App ()
testSimpleRoundtrip = do
  let def' :: [Pair]
def' = [String
"public" String -> Bool -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Bool
False]
      rets :: [String]
rets = [String
"eternal", String
"persistent", String
"volatile", String
"eternal-infrequent_access", String
"expiring"]
      sets' :: [Value]
sets' = ([Pair] -> Value) -> [[Pair]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Pair] -> Value
object ([[Pair]] -> [Value]) -> [[Pair]] -> [Value]
forall a b. (a -> b) -> a -> b
$ [Pair]
def' [Pair] -> [[Pair]] -> [[Pair]]
forall a. a -> [a] -> [a]
: (String -> [Pair]) -> [String] -> [[Pair]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
r -> String
"retention" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
r Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [Pair]
def') [String]
rets
  (Value -> App ()) -> [Value] -> App ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ HasCallStack => Value -> App ()
Value -> App ()
simpleRoundtrip [Value]
sets'
  where
    simpleRoundtrip :: (HasCallStack) => Value -> App ()
    simpleRoundtrip :: HasCallStack => Value -> App ()
simpleRoundtrip Value
sets = do
      uid <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
      userId1 <- uid %. "id" & asString
      uid2 <- randomUser OwnDomain def
      -- Initial upload
      let bdy = (MIMEType
applicationText, String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Hello World")
      r1 <- uploadSimpleV3 uid sets bdy
      r1.status `shouldMatchInt` 201
      loc <- maybe (error "Could not find the Location header") (pure . cs @_ @String) $ lookup (mk $ cs "Location") r1.headers
      (tok, expires) <-
        (,)
          <$> asString (r1.json %. "token")
          <*> (lookupField r1.json "expires" >>= maybe (pure Nothing) (fmap pure . asString))
      -- Check mandatory Date header
      let Just date = C8.unpack <$> lookup (mk $ cs "Date") r1.headers
          utc = Bool -> TimeLocale -> String -> String -> UTCTime
forall t.
ParseTime t =>
Bool -> TimeLocale -> String -> String -> t
parseTimeOrError Bool
False TimeLocale
defaultTimeLocale String
rfc822DateFormat String
date :: UTCTime
          parseTimeIso String
t = UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe (String -> UTCTime
forall a. HasCallStack => String -> a
error (String -> UTCTime) -> String -> UTCTime
forall a b. (a -> b) -> a -> b
$ String
"Could not parse \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
t String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" as ISO8601") (Maybe UTCTime -> UTCTime) -> Maybe UTCTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Format UTCTime -> String -> Maybe UTCTime
forall (m :: * -> *) t. MonadFail m => Format t -> String -> m t
formatParseM (forall t. ISO8601 t => Format t
iso8601Format @UTCTime) String
t
          expires' = String -> UTCTime
parseTimeIso (String -> UTCTime) -> Maybe String -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
expires :: Maybe UTCTime
      -- Potentially check for the expires header
      case sets of
        Object Object
o -> case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (String -> Key
forall a. IsString a => String -> a
fromString String
"retention") Object
o of
          Maybe Value
Nothing -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just Value
r -> do
            r' <- Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString Value
r
            -- These retention policies never expire, so an expiration date isn't sent back
            unless (r' == "eternal" || r' == "persistent" || r' == "eternal-infrequent_access")
              $ assertBool "invalid expiration" (Just utc < expires')
        Value
_ -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      -- Lookup with token and download via redirect.
      r2 <- downloadAsset' uid loc tok
      r2.status `shouldMatchInt` 302
      cs @_ @String r2.body `shouldMatch` ""
      r3 <- flip get' id =<< parseUrlThrow (C8.unpack (getHeader' (mk $ cs "Location") r2))
      r3.status `shouldMatchInt` 200
      assertBool "content-type should always be application/octet-stream" $ Just applicationOctetStream == fmap MIME.mimeType (getContentType r3)
      assertBool "token mismatch" $ tok == decodeHeaderOrFail (mk $ cs "x-amz-meta-token") r3
      assertBool "user mismatch" $ userId1 == decodeHeaderOrFail (mk $ cs "x-amz-meta-user") r3
      assertBool "data mismatch" $ cs "Hello World" == r3.body
      -- Delete (forbidden for other users)
      deleteAsset uid2 r1.jsonBody >>= \Response
r -> Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
      -- Delete (allowed for creator)
      deleteAsset uid r1.jsonBody >>= \Response
r -> Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      r4 <- downloadAsset' uid loc tok
      r4.status `shouldMatchInt` 404
      let Just date' = C8.unpack <$> lookup (mk $ cs "Date") r4.headers
          utc' = Bool -> TimeLocale -> String -> String -> UTCTime
forall t.
ParseTime t =>
Bool -> TimeLocale -> String -> String -> t
parseTimeOrError Bool
False TimeLocale
defaultTimeLocale String
rfc822DateFormat String
date' :: UTCTime
      assertBool "bad date" (utc' >= utc)

testDownloadWithAcceptHeader :: (HasCallStack) => App ()
testDownloadWithAcceptHeader :: HasCallStack => App ()
testDownloadWithAcceptHeader = do
  assetId <- App String
HasCallStack => App String
randomId
  uid <- randomUser OwnDomain def
  domain <- make OwnDomain
  let key = String
"3-2-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
assetId
      qkey = [Pair] -> Value
object [String
"domain" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Value
domain, String
"id" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
key]
  res <- downloadAssetWithQualifiedAssetKey (header "Accept" "image/jpeg") uid qkey ()
  res.status `shouldMatchInt` 404

queryItem :: ByteString -> Maybe ByteString -> HTTP.Request -> HTTP.Request
queryItem :: ByteString -> Maybe ByteString -> Request -> Request
queryItem ByteString
k Maybe ByteString
v Request
r =
  [(ByteString, Maybe ByteString)] -> Request -> Request
HTTP.setQueryString ((ByteString
k, Maybe ByteString
v) (ByteString, Maybe ByteString)
-> [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
forall a. a -> [a] -> [a]
: [(ByteString, Maybe ByteString)]
queryItems) Request
r
  where
    queryItems :: [(ByteString, Maybe ByteString)]
queryItems = ByteString -> [(ByteString, Maybe ByteString)]
HTTP.parseQuery (ByteString -> [(ByteString, Maybe ByteString)])
-> ByteString -> [(ByteString, Maybe ByteString)]
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.queryString Request
r

get' :: HTTP.Request -> (HTTP.Request -> HTTP.Request) -> App Response
get' :: Request -> (Request -> Request) -> App Response
get' Request
r Request -> Request
f = String -> Request -> App Response
submit String
"GET" (Request -> App Response) -> Request -> App Response
forall a b. (a -> b) -> a -> b
$ Request -> Request
f Request
r

testSimpleTokens :: (HasCallStack) => App ()
testSimpleTokens :: HasCallStack => App ()
testSimpleTokens = do
  uid <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  uid2 <- randomUser OwnDomain def
  -- Initial upload
  let sets = [Pair] -> Value
object [String
"public" String -> Bool -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Bool
False, String
"retention" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"volatile"]
      bdy = (MIMEType
applicationText, String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Hello World")
  r1 <- uploadSimpleV3 uid sets bdy
  r1.status `shouldMatchInt` 201
  loc <-
    maybe
      (assertFailure "Could not get \"Location\" header from the request")
      (pure . cs @_ @String)
      $ getHeader (mk $ cs "Location") r1
  (key, tok) <-
    (,)
      <$> asString (r1.json %. "key")
      <*> r1.json
      %. "token"
  -- No access without token from other user (opaque 404)
  downloadAsset' uid2 loc () >>= \Response
r -> Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
404
  -- No access with empty token query parameter from other user (opaque 404)
  downloadAsset' uid2 loc (queryItem (cs "asset_token") Nothing) >>= \Response
r -> Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
404
  -- No access with wrong token (opaque 404)
  downloadAsset' uid2 loc (header "Asset-Token" "abc123") >>= \Response
r -> Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
404
  -- No access with wrong token as query parameter (opaque 404)
  downloadAsset' uid2 loc (queryItem (cs "asset_token") $ pure $ cs "acb123") >>= \Response
r -> Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
404
  -- Token renewal fails if not done by owner
  postToken uid2 key >>= \Response
r -> do
    Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
    label <- (Value -> App String) -> Maybe Value -> App (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label") (Value -> App Value)
-> (Value -> App String) -> Value -> App String
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString) Response
r.jsonBody
    label `shouldMatch` "unauthorised"
  -- Token renewal succeeds if done by owner
  r2 <- postToken uid key
  r2.status `shouldMatchInt` 200
  tok' <- r2.jsonBody %. "token" & asString
  assertBool "token unchanged" (tok /= String (cs tok'))
  -- Download by owner with new token.
  r3 <- downloadAsset' uid loc tok'
  r3.status `shouldMatchInt` 302
  cs @_ @String r3.body `shouldMatch` ""
  r4 <- flip get' id =<< parseUrlThrow (C8.unpack (getHeader' (mk $ cs "Location") r3))
  r4.status `shouldMatchInt` 200
  let r4ContentType :: Maybe String
      r4ContentType = forall a b. ConvertibleStrings a b => a -> b
cs @_ @String (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI ByteString -> Response -> Maybe ByteString
getHeader (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"content-type") Response
r4
  r4ContentType `shouldMatch` Just (cs @_ @String $ MIME.showMIMEType applicationOctetStream)
  let r4Tok :: Maybe String
      r4Tok = forall a b. ConvertibleStrings a b => a -> b
cs @_ @String (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI ByteString -> Response -> Maybe ByteString
getHeader (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"x-amz-meta-token") Response
r4
  r4Tok `shouldMatch` Just tok'
  let r4User :: Maybe String
      r4User = forall a b. ConvertibleStrings a b => a -> b
cs @_ @String (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI ByteString -> Response -> Maybe ByteString
getHeader (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"x-amz-meta-user") Response
r4
  r4User `shouldMatch` fmap Just (uid %. "id")
  cs @_ @String r4.body `shouldMatch` "Hello World"
  -- Verify access without token if the request comes from the creator.
  downloadAsset' uid loc () >>= \Response
r -> Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
302
  -- Verify access with new token from a different user.
  downloadAsset' uid2 loc tok' >>= \Response
r -> Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
302
  -- Verify access with new token as query parameter from a different user
  downloadAsset' uid2 loc (queryItem (cs "asset_token") (pure $ cs tok')) >>= \Response
r ->
    Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
302
  -- Delete Token fails if not done by owner
  deleteToken uid2 key >>= \Response
r -> do
    Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
    label' <- (Value -> App String) -> Maybe Value -> App (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label") (Value -> App Value)
-> (Value -> App String) -> Value -> App String
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString) Response
r.jsonBody
    label' `shouldMatch` "unauthorised"
  -- Delete Token succeeds by owner
  deleteToken uid key >>= \Response
r -> do
    Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    forall a b. ConvertibleStrings a b => a -> b
cs @_ @String Response
r.body String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
""
  -- Access without token from different user (asset is now "public")
  downloadAsset' uid2 loc () >>= \Response
r -> do
    Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
302
    forall a b. ConvertibleStrings a b => a -> b
cs @_ @String Response
r.body String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
""

defAssetSettings' :: [Pair]
defAssetSettings' :: [Pair]
defAssetSettings' = [String
"public" String -> Bool -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Bool
False]

defAssetSettings :: Value
defAssetSettings :: Value
defAssetSettings = [Pair] -> Value
object [Pair]
defAssetSettings'

-- S3 closes idle connections after ~5 seconds, before the http-client 'Manager'
-- does. If such a closed connection is reused for an upload, no problems should
-- occur (i.e. the closed connection should be detected before sending any data).
testSimpleS3ClosedConnectionReuse :: (HasCallStack) => App ()
testSimpleS3ClosedConnectionReuse :: HasCallStack => App ()
testSimpleS3ClosedConnectionReuse = App ()
go App () -> App () -> App ()
forall a b. App a -> App b -> App b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> App ()
wait App () -> App () -> App ()
forall a b. App a -> App b -> App b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> App ()
go
  where
    wait :: App ()
wait = IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> IO () -> App ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn String
"Waiting for S3 idle timeout ..." IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
7000000
    go :: App ()
go = do
      uid <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
      let sets = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Pair]
defAssetSettings' [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [String
"retention" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"volatile"]
      let part2 = (Text -> MIMEType
MIME.Text (Text -> MIMEType) -> Text -> MIMEType
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"plain", String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
100000 Char
'c')
      uploadSimpleV3 uid sets part2 >>= \Response
r -> Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201

testDownloadURLOverride :: (HasCallStack) => App ()
testDownloadURLOverride :: HasCallStack => App ()
testDownloadURLOverride = do
  -- This is a .example domain, it shouldn't resolve. But it is also not
  -- supposed to be used by cargohold to make connections.
  let downloadEndpoint :: String
downloadEndpoint = String
"external-s3-url.example"
      -- Stick the protocol on here, as the checks don't want to see it,
      -- they are just looking for the host name.
      f :: Value -> App Value
f = String -> String -> Value -> App Value
forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField String
"aws.s3DownloadEndpoint" (String
"https://" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
downloadEndpoint)
  [ServiceOverrides] -> ([String] -> App ()) -> App ()
forall a.
HasCallStack =>
[ServiceOverrides] -> ([String] -> App a) -> App a
startDynamicBackends [ServiceOverrides
forall a. Default a => a
def {cargoholdCfg = f}] (([String] -> App ()) -> App ()) -> ([String] -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \[String
d] -> do
    -- withSettingsOverrides (aws . s3DownloadEndpoint ?~ AWSEndpoint downloadEndpoint True 443) $ do
    uid <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
d CreateUser
forall a. Default a => a
def
    -- Upload, should work, shouldn't try to use the S3DownloadEndpoint
    let bdy = (MIMEType
applicationText, String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Hello World")
    uploadRes <- uploadSimpleV3 uid defAssetSettings bdy
    uploadRes.status `shouldMatchInt` 201
    let loc = CI ByteString -> Response -> String
forall a.
(HasCallStack, FromByteString a) =>
CI ByteString -> Response -> a
decodeHeaderOrFail (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Location") Response
uploadRes :: String
    (_key, tok, _expires) <-
      (,,)
        <$> uploadRes.json
        %. "key"
        <*> (uploadRes.json %. "token" & asString)
        <*> lookupField uploadRes.json "expires"
    -- Lookup with token and get download URL. Should return the
    -- S3DownloadEndpoint, but not try to use it.
    downloadURLRes <- downloadAsset' uid loc tok
    downloadURLRes.status `shouldMatchInt` 302
    cs @_ @String downloadURLRes.body `shouldMatch` ""
    downloadURL <- parseUrlThrow (C8.unpack (getHeader' (mk $ cs "Location") downloadURLRes))
    downloadEndpoint `shouldMatch` cs @_ @String (HTTP.host downloadURL)
    HTTP.port downloadURL `shouldMatchInt` 443
    True `shouldMatch` (HTTP.secure downloadURL)

--------------------------------------------------------------------------------
-- Client compatibility tests

-- Since the other tests use functions from the server code, it can happen that
-- an API change also changes the requests made here in the tests.
-- This test tries to prevent us from breaking the API without noticing.
--
-- The body is taken directly from a request made by the web app
-- (just replaced the content with a shorter one and updated the MD5 header).
testUploadCompatibility :: (HasCallStack) => App ()
testUploadCompatibility :: HasCallStack => App ()
testUploadCompatibility = do
  uid <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  -- Initial upload
  r1 <- uploadRawV3 uid exampleMultipart
  r1.status `shouldMatchInt` 201
  let locHeader = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Location"
      loc = forall a.
(HasCallStack, FromByteString a) =>
CI ByteString -> Response -> a
decodeHeaderOrFail @String CI ByteString
locHeader Response
r1
  -- Lookup and download via redirect.
  r2 <- downloadAsset' uid loc ()
  r2.status `shouldMatchInt` 302
  cs @_ @String r2.body `shouldMatch` ""
  r3 <- flip get' id =<< parseUrlThrow (C8.unpack (getHeader' locHeader r2))
  r3.status `shouldMatchInt` 200
  assertBool "Content types should match" $ getContentType r3 == Just applicationOctetStream'
  decodeHeaderOrFail @String (mk $ cs "x-amz-meta-user") r3 `shouldMatch` (uid %. "id")
  cs @_ @String r3.body `shouldMatch` Just "test"
  where
    exampleMultipart :: LBS.ByteString
    exampleMultipart :: ByteString
exampleMultipart =
      String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs
        String
"--FrontierIyj6RcVrqMcxNtMEWPsNpuPm325QsvWQ\r\n\
        \Content-Type: application/json;charset=utf-8\r\n\
        \Content-length: 37\r\n\
        \\r\n\
        \{\"public\":true,\"retention\":\"eternal\"}\r\n\
        \--FrontierIyj6RcVrqMcxNtMEWPsNpuPm325QsvWQ\r\n\
        \Content-Type: application/octet-stream\r\n\
        \Content-length: 4\r\n\
        \Content-MD5: CY9rzUYh03PK3k6DJie09g==\r\n\
        \\r\n\
        \test\r\n\
        \--FrontierIyj6RcVrqMcxNtMEWPsNpuPm325QsvWQ--\r\n\
        \\r\n"

--------------------------------------------------------------------------------
-- Federation behaviour

testRemoteDownloadWrongDomain :: (HasCallStack) => App ()
testRemoteDownloadWrongDomain :: HasCallStack => App ()
testRemoteDownloadWrongDomain = do
  assetId <- App String
HasCallStack => App String
randomId
  uid <- randomUser OwnDomain def
  let key = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"3-2-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
assetId
      qkey =
        [Pair] -> Value
object
          [ String
"key" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Value
key,
            String
"domain" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"invalid.example.com"
          ]
  res <- downloadAsset' uid qkey ()
  res.status `shouldMatchInt` 422

testRemoteDownloadNoAsset :: (HasCallStack) => App ()
testRemoteDownloadNoAsset :: HasCallStack => App ()
testRemoteDownloadNoAsset = do
  assetId <- App String
HasCallStack => App String
randomId
  uid <- randomUser OwnDomain def
  otherDomain <- make OtherDomain & asString
  let key = String
"3-2-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
assetId
      qkey =
        [Pair] -> Value
object
          [ String
"domain" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
otherDomain,
            String
"key" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
key
          ]
  res <- downloadAsset' uid qkey ()
  res.status `shouldMatchInt` 404

testRemoteDownloadShort :: (HasCallStack) => App ()
testRemoteDownloadShort :: HasCallStack => App ()
testRemoteDownloadShort = String -> App ()
forall a.
(HasCallStack, ConvertibleStrings a ByteString,
 ConvertibleStrings a String) =>
a -> App ()
remoteDownload String
"asset content"

testRemoteDownloadLong :: (HasCallStack) => App ()
testRemoteDownloadLong :: HasCallStack => App ()
testRemoteDownloadLong = String -> App ()
forall a.
(HasCallStack, ConvertibleStrings a ByteString,
 ConvertibleStrings a String) =>
a -> App ()
remoteDownload (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> [String]
forall a. Int -> a -> [a]
replicate Int
20000 (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
"hello world\n"

remoteDownload :: (HasCallStack, ConvertibleStrings a L8.ByteString, ConvertibleStrings a String) => a -> App ()
remoteDownload :: forall a.
(HasCallStack, ConvertibleStrings a ByteString,
 ConvertibleStrings a String) =>
a -> App ()
remoteDownload a
content = do
  uid1 <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  uid2 <- randomUser OtherDomain def
  r1 <- uploadSimpleV3 uid1 settings (applicationOctetStream, cs content)
  r1.status `shouldMatchInt` 201
  let locHeader = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Location"
      loc = forall a.
(HasCallStack, FromByteString a) =>
CI ByteString -> Response -> a
decodeHeaderOrFail @String CI ByteString
locHeader Response
r1
  -- Lookup and download via redirect.
  r2 <- downloadAsset' uid2 loc ()
  r2.status `shouldMatchInt` 200
  assertBool "Content types should match" $ getContentType r2 == Just applicationOctetStream'
  -- decodeHeaderOrFail @String (mk $ cs "x-amz-meta-user") r3 `shouldMatch` (uid %. "id")
  cs @_ @String r2.body `shouldMatch` Just (cs content :: String)
  where
    settings :: Value
settings = [Pair] -> Value
object [String
"public" String -> Bool -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Bool
True]

------------------------------------------------------------------------
-- Asset Audit Log

-- Upload and download audit logging scenarios across two backends (A and B).

-- Case 1:
--  - Uploader: on backend A (audit enabled)
--  - Downloader: on backend A (same backend)
-- Expected logs:
--   - Backend A: "file-upload", "download-url-creation""
testAssetAuditLogDownloadBackendALocal :: (HasCallStack) => App ()
testAssetAuditLogDownloadBackendALocal :: HasCallStack => App ()
testAssetAuditLogDownloadBackendALocal = do
  [ServiceOverrides] -> ([String] -> App ()) -> App ()
forall a.
HasCallStack =>
[ServiceOverrides] -> ([String] -> App a) -> App a
startDynamicBackends [ServiceOverrides
cargoholdAuditLogEnabled] (([String] -> App ()) -> App ()) -> ([String] -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \[String
domainA] -> do
    (owner, _tid, _members) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domainA Int
1
    -- Missing audit metadata should cause the upload to fail when the setting is enabled
    let missingMetaSettings = [Pair] -> Value
object [String
"public" String -> Bool -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Bool
False]
        body = (MIMEType
applicationText, String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"download-me")
    uploadSimple owner missingMetaSettings body `bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
      Response
resp.jsonBody Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"missing-audit-metadata"
    -- Now upload again with correct metadata and expect success 201
    settings <-
      validAssetMetadataSettings
        <$> randomId
        <*> (owner %. "qualified_id.domain" & asString)
    key <-
      uploadSimple owner settings body `bindResponse` \Response
r -> do
        Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
        Response
r.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key"
    -- Download by the owner (no token needed since same backend and owner).
    bindResponse (downloadAsset owner owner key "nginz-https.example.com" id) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      ByteString -> String
BC.unpack Response
resp.body String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"download-me"

-- Case 2:
--  - Uploader: on backend A (audit enabled)
--  - Downloader: on backend B (audit disabled)
-- Expected logs:
--   - Backend A: "file-upload", "file-download"
--   - Backend B: No logging.
testAssetAuditLogDownloadBackendALoggingBackendBNotLogging :: (HasCallStack) => App ()
testAssetAuditLogDownloadBackendALoggingBackendBNotLogging :: HasCallStack => App ()
testAssetAuditLogDownloadBackendALoggingBackendBNotLogging = do
  [ServiceOverrides] -> ([String] -> App ()) -> App ()
forall a.
HasCallStack =>
[ServiceOverrides] -> ([String] -> App a) -> App a
startDynamicBackends [ServiceOverrides
cargoholdAuditLogEnabled] (([String] -> App ()) -> App ()) -> ([String] -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \[String
domainA] -> do
    let domainB :: Domain
domainB = Domain
OwnDomain
    (owner, _tid, _members) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domainA Int
1
    downloader <- randomUser domainB def
    -- Upload on A with metadata
    settings <-
      validAssetMetadataSettings
        <$> randomId
        <*> (owner %. "qualified_id.domain" & asString)
    let body = (MIMEType
applicationText, String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"hello-onprem")
    (loc, tok) <-
      uploadSimple owner settings body `bindResponse` \Response
r -> do
        Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
        (,) (Value -> String -> (Value, String))
-> App Value -> App (String -> (Value, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response
r.json App (String -> (Value, String))
-> App String -> App (Value, String)
forall a b. App (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Response
r.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"token" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString)
    -- Federated download by user on backend B.
    bindResponse (downloadAsset' downloader loc tok) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      ByteString -> String
BC.unpack Response
resp.body String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"hello-onprem"

-- Case 3:
--  - Uploader: on backend A (audit enabled)
--  - Downloader: on backend B (audit enabled)
--  Expected logs:
--    - Backend A: "file-upload", "file-download"
--    - Backend B: "file-download"
testAssetAuditLogDownloadBackendALoggingBackendBLogging :: (HasCallStack) => App ()
testAssetAuditLogDownloadBackendALoggingBackendBLogging :: HasCallStack => App ()
testAssetAuditLogDownloadBackendALoggingBackendBLogging = do
  -- Start two dynamic backends with audit logging enabled on both.
  [ServiceOverrides] -> ([String] -> App ()) -> App ()
forall a.
HasCallStack =>
[ServiceOverrides] -> ([String] -> App a) -> App a
startDynamicBackends [ServiceOverrides
cargoholdAuditLogEnabled, ServiceOverrides
cargoholdAuditLogEnabled] (([String] -> App ()) -> App ()) -> ([String] -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \[String
domainA, String
domainB] -> do
    (owner, _tid, _members) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domainA Int
1
    downloader <- randomUser domainB def
    -- Upload on A with required metadata
    settings <-
      validAssetMetadataSettings
        <$> randomId
        <*> (owner %. "qualified_id.domain" & asString)
    let body = (MIMEType
applicationText, String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"hello-onprem")
    (loc, tok) <-
      uploadSimple owner settings body `bindResponse` \Response
r -> do
        Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
        (,) (Value -> String -> (Value, String))
-> App Value -> App (String -> (Value, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response
r.json App (String -> (Value, String))
-> App String -> App (Value, String)
forall a b. App (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Response
r.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"token" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString)
    -- Federated download by user on backend B.
    bindResponse (downloadAsset' downloader loc tok) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      ByteString -> String
BC.unpack Response
resp.body String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"hello-onprem"

-- Case 4:
--  - Uploader on backend A (audit disabled)
--  - Downloader on backend B (audit enabled)
--  Expected logs:
--    - Backend A: Not logging
--    - Backend B: "file-download"
testAssetAuditLogDownloadBackendANotLoggingBackendBLogging :: (HasCallStack) => App ()
testAssetAuditLogDownloadBackendANotLoggingBackendBLogging :: HasCallStack => App ()
testAssetAuditLogDownloadBackendANotLoggingBackendBLogging = do
  -- Start two backends: A without audit, B with audit.
  [ServiceOverrides] -> ([String] -> App ()) -> App ()
forall a.
HasCallStack =>
[ServiceOverrides] -> ([String] -> App a) -> App a
startDynamicBackends [ServiceOverrides
forall a. Default a => a
def, ServiceOverrides
cargoholdAuditLogEnabled] (([String] -> App ()) -> App ()) -> ([String] -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \[String
domainA, String
domainB] -> do
    (owner, _tid, _members) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domainA Int
1
    downloader <- randomUser domainB def
    -- Upload on A with required metadata (no audit logging on A)
    settings <-
      validAssetMetadataSettings
        <$> randomId
        <*> (owner %. "qualified_id.domain" & asString)
    let body = (MIMEType
applicationText, String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"hello-onprem")
    (loc, tok) <-
      uploadSimple owner settings body `bindResponse` \Response
r -> do
        Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
        (,) (Value -> String -> (Value, String))
-> App Value -> App (String -> (Value, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response
r.json App (String -> (Value, String))
-> App String -> App (Value, String)
forall a b. App (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Response
r.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"token" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString)
    -- Federated download by user on backend B (audit enabled on B).
    bindResponse (downloadAsset' downloader loc tok) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      ByteString -> String
BC.unpack Response
resp.body String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"hello-onprem"

cargoholdAuditLogEnabled :: ServiceOverrides
cargoholdAuditLogEnabled :: ServiceOverrides
cargoholdAuditLogEnabled =
  ServiceOverrides
forall a. Default a => a
def
    { cargoholdCfg =
        setField "settings.assetAuditLogEnabled" True
          . setField "logLevel" "Info"
          . setField "logFormat" "StructuredJSON"
    }

validAssetMetadataSettings :: (ToJSON a1, ToJSON a2) => a1 -> a2 -> Value
validAssetMetadataSettings :: forall a1 a2. (ToJSON a1, ToJSON a2) => a1 -> a2 -> Value
validAssetMetadataSettings a1
convId a2
dom =
  [Pair] -> Value
object
    [ String
"public" String -> Bool -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Bool
False,
      String
"convId" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [Pair] -> Value
object [String
"id" String -> a1 -> Pair
forall a. ToJSON a => String -> a -> Pair
.= a1
convId, String
"domain" String -> a2 -> Pair
forall a. ToJSON a => String -> a -> Pair
.= a2
dom],
      String
"filename" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"virus.js",
      String
"filetype" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"application/javascript"
    ]