{-# 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 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 (randomId, randomUser)
import Test.Cargohold.API.Util
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
      Value
uid <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
      String
userId1 <- Value
uid Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" 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
      Value
uid2 <- 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
      let bdy :: (MIMEType, ByteString)
bdy = (MIMEType
applicationText, String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Hello World")
      Response
r1 <- Value -> Value -> (MIMEType, ByteString) -> App Response
forall user settings.
(HasCallStack, MakesValue user, MakesValue settings) =>
user -> settings -> (MIMEType, ByteString) -> App Response
uploadSimple Value
uid Value
sets (MIMEType, ByteString)
bdy
      Response
r1.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
      String
loc <- App String
-> (ByteString -> App String) -> Maybe ByteString -> App String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> App String
forall a. HasCallStack => String -> a
error String
"Could not find the Location header") (String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> App String)
-> (ByteString -> String) -> ByteString -> App String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertibleStrings a b => a -> b
cs @_ @String) (Maybe ByteString -> App String) -> Maybe ByteString -> App String
forall a b. (a -> b) -> a -> b
$ CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (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
r1.headers
      (String
tok, Maybe String
expires) <-
        (,)
          (String -> Maybe String -> (String, Maybe String))
-> App String -> App (Maybe String -> (String, Maybe String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString (Response
r1.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"token")
          App (Maybe String -> (String, Maybe String))
-> App (Maybe String) -> App (String, Maybe String)
forall a b. App (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (App Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Response
r1.json String
"expires" App (Maybe Value)
-> (Maybe Value -> App (Maybe String)) -> App (Maybe String)
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= App (Maybe String)
-> (Value -> App (Maybe String))
-> Maybe Value
-> App (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe String -> App (Maybe String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing) ((String -> Maybe String) -> App String -> App (Maybe String)
forall a b. (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (App String -> App (Maybe String))
-> (Value -> App String) -> Value -> App (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString))
      -- Check mandatory Date header
      let Just String
date = ByteString -> String
C8.unpack (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (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
"Date") Response
r1.headers
          utc :: UTCTime
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 -> 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' :: Maybe UTCTime
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 Value
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
            String
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
            Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
r' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"eternal" Bool -> Bool -> Bool
|| String
r' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"persistent" Bool -> Bool -> Bool
|| String
r' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"eternal-infrequent_access")
              (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"invalid expiration" (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
utc Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< Maybe UTCTime
expires')
        Value
_ -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      -- Lookup with token and download via redirect.
      Response
r2 <- Value -> String -> String -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid String
loc String
tok
      Response
r2.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
r2.body String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
""
      Response
r3 <- (Request -> (Request -> Request) -> App Response)
-> (Request -> Request) -> Request -> App Response
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> (Request -> Request) -> App Response
get' Request -> Request
forall a. a -> a
id (Request -> App Response) -> App Request -> App Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> App Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (ByteString -> String
C8.unpack (CI ByteString -> Response -> 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
"Location") Response
r2))
      Response
r3.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"content-type should always be application/octet-stream" (Bool -> App ()) -> Bool -> App ()
forall a b. (a -> b) -> a -> b
$ MIMEType -> Maybe MIMEType
forall a. a -> Maybe a
Just MIMEType
applicationOctetStream Maybe MIMEType -> Maybe MIMEType -> Bool
forall a. Eq a => a -> a -> Bool
== (Type -> MIMEType) -> Maybe Type -> Maybe MIMEType
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> MIMEType
MIME.mimeType (Response -> Maybe Type
getContentType Response
r3)
      HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"token mismatch" (Bool -> App ()) -> Bool -> App ()
forall a b. (a -> b) -> a -> b
$ String
tok String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== 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
"x-amz-meta-token") Response
r3
      HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"user mismatch" (Bool -> App ()) -> Bool -> App ()
forall a b. (a -> b) -> a -> b
$ String
userId1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== 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
"x-amz-meta-user") Response
r3
      HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"data mismatch" (Bool -> App ()) -> Bool -> App ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Hello World" ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Response
r3.body
      -- Delete (forbidden for other users)
      Value -> Maybe Value -> App Response
forall user key.
(HasCallStack, MakesValue user, MakesValue key) =>
user -> key -> App Response
deleteAsset Value
uid2 Response
r1.jsonBody App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Response
r -> Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
      -- Delete (allowed for creator)
      Value -> Maybe Value -> App Response
forall user key.
(HasCallStack, MakesValue user, MakesValue key) =>
user -> key -> App Response
deleteAsset Value
uid Response
r1.jsonBody App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Response
r -> Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
r4 <- Value -> String -> String -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid String
loc String
tok
      Response
r4.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
404
      let Just String
date' = ByteString -> String
C8.unpack (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (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
"Date") Response
r4.headers
          utc' :: UTCTime
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
      HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"bad date" (UTCTime
utc' UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
utc)

testDownloadWithAcceptHeader :: (HasCallStack) => App ()
testDownloadWithAcceptHeader :: HasCallStack => App ()
testDownloadWithAcceptHeader = do
  String
assetId <- App String
HasCallStack => App String
randomId
  Value
uid <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  Value
domain <- Domain -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make Domain
OwnDomain
  let key :: String
key = String
"3-2-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
assetId
      qkey :: Value
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]
  Response
res <- (Request -> Request) -> Value -> Value -> () -> App Response
forall tok key user.
(HasCallStack, IsAssetToken tok, MakesValue key,
 MakesValue user) =>
(Request -> Request) -> user -> key -> tok -> App Response
downloadAssetWithQualifiedAssetKey (String -> String -> Request -> Request
header String
"Accept" String
"image/jpeg") Value
uid Value
qkey ()
  Response
res.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
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
  Value
uid <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  Value
uid2 <- 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
  let sets :: Value
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, ByteString)
bdy = (MIMEType
applicationText, String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Hello World")
  Response
r1 <- Value -> Value -> (MIMEType, ByteString) -> App Response
forall user settings.
(HasCallStack, MakesValue user, MakesValue settings) =>
user -> settings -> (MIMEType, ByteString) -> App Response
uploadSimple Value
uid Value
sets (MIMEType, ByteString)
bdy
  Response
r1.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
  String
loc <-
    App String
-> (ByteString -> App String) -> Maybe ByteString -> App String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (String -> App String
forall a. HasCallStack => String -> App a
assertFailure String
"Could not get \"Location\" header from the request")
      (String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> App String)
-> (ByteString -> String) -> ByteString -> App String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertibleStrings a b => a -> b
cs @_ @String)
      (Maybe ByteString -> App String) -> Maybe ByteString -> App String
forall a b. (a -> b) -> a -> 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
"Location") Response
r1
  (String
key, Value
tok) <-
    (,)
      (String -> Value -> (String, Value))
-> App String -> App (Value -> (String, Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString (Response
r1.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key")
      App (Value -> (String, Value)) -> App Value -> App (String, Value)
forall a b. App (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Response
r1.json
      App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"token"
  -- No access without token from other user (opaque 404)
  Value -> String -> () -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid2 String
loc () App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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)
  Value -> String -> (Request -> Request) -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid2 String
loc (ByteString -> Maybe ByteString -> Request -> Request
queryItem (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"asset_token") Maybe ByteString
forall a. Maybe a
Nothing) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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)
  Value -> String -> (Request -> Request) -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid2 String
loc (String -> String -> Request -> Request
header String
"Asset-Token" String
"abc123") App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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)
  Value -> String -> (Request -> Request) -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid2 String
loc (ByteString -> Maybe ByteString -> Request -> Request
queryItem (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"asset_token") (Maybe ByteString -> Request -> Request)
-> Maybe ByteString -> Request -> Request
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"acb123") App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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
  Value -> String -> App Response
forall user.
(MakesValue user, HasCallStack) =>
user -> String -> App Response
postToken Value
uid2 String
key App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Response
r -> do
    Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
    Maybe String
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
    Maybe String
label Maybe String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"unauthorised"
  -- Token renewal succeeds if done by owner
  Response
r2 <- Value -> String -> App Response
forall user.
(MakesValue user, HasCallStack) =>
user -> String -> App Response
postToken Value
uid String
key
  Response
r2.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
  String
tok' <- Response
r2.jsonBody Maybe 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
  HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"token unchanged" (Value
tok Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Value
String (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
tok'))
  -- Download by owner with new token.
  Response
r3 <- Value -> String -> String -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid String
loc String
tok'
  Response
r3.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
r3.body String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
""
  Response
r4 <- (Request -> (Request -> Request) -> App Response)
-> (Request -> Request) -> Request -> App Response
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> (Request -> Request) -> App Response
get' Request -> Request
forall a. a -> a
id (Request -> App Response) -> App Request -> App Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> App Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (ByteString -> String
C8.unpack (CI ByteString -> Response -> 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
"Location") Response
r3))
  Response
r4.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
  let r4ContentType :: Maybe String
      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
  Maybe String
r4ContentType Maybe String -> Maybe String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String -> Maybe String
forall a. a -> Maybe a
Just (forall a b. ConvertibleStrings a b => a -> b
cs @_ @String (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ MIMEType -> Text
MIME.showMIMEType MIMEType
applicationOctetStream)
  let r4Tok :: Maybe String
      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
  Maybe String
r4Tok Maybe String -> Maybe String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String -> Maybe String
forall a. a -> Maybe a
Just String
tok'
  let r4User :: Maybe String
      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
  Maybe String
r4User Maybe String -> App (Maybe Value) -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (Value -> Maybe Value) -> App Value -> App (Maybe Value)
forall a b. (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Maybe Value
forall a. a -> Maybe a
Just (Value
uid Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id")
  forall a b. ConvertibleStrings a b => a -> b
cs @_ @String Response
r4.body String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"Hello World"
  -- Verify access without token if the request comes from the creator.
  Value -> String -> () -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid String
loc () App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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.
  Value -> String -> String -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid2 String
loc String
tok' App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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
  Value -> String -> (Request -> Request) -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid2 String
loc (ByteString -> Maybe ByteString -> Request -> Request
queryItem (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"asset_token") (ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
tok')) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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
  Value -> String -> App Response
forall user.
(MakesValue user, HasCallStack) =>
user -> String -> App Response
deleteToken Value
uid2 String
key App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Response
r -> do
    Response
r.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
    Maybe String
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
    Maybe String
label' Maybe String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"unauthorised"
  -- Delete Token succeeds by owner
  Value -> String -> App Response
forall user.
(MakesValue user, HasCallStack) =>
user -> String -> App Response
deleteToken Value
uid String
key App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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")
  Value -> String -> () -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid2 String
loc () App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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
      Value
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 :: Value
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 :: (MIMEType, ByteString)
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')
      Value -> Value -> (MIMEType, ByteString) -> App Response
forall user settings.
(HasCallStack, MakesValue user, MakesValue settings) =>
user -> settings -> (MIMEType, ByteString) -> App Response
uploadSimple Value
uid Value
sets (MIMEType, ByteString)
part2 App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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. [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
    Value
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, ByteString)
bdy = (MIMEType
applicationText, String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Hello World")
    Response
uploadRes <- Value -> Value -> (MIMEType, ByteString) -> App Response
forall user settings.
(HasCallStack, MakesValue user, MakesValue settings) =>
user -> settings -> (MIMEType, ByteString) -> App Response
uploadSimple Value
uid Value
defAssetSettings (MIMEType, ByteString)
bdy
    Response
uploadRes.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
    let loc :: String
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
    (Value
_key, String
tok, Maybe Value
_expires) <-
      (,,)
        (Value -> String -> Maybe Value -> (Value, String, Maybe Value))
-> App Value
-> App (String -> Maybe Value -> (Value, String, Maybe Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response
uploadRes.json
        App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key"
        App (String -> Maybe Value -> (Value, String, Maybe Value))
-> App String -> App (Maybe Value -> (Value, String, Maybe Value))
forall a b. App (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Response
uploadRes.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)
        App (Maybe Value -> (Value, String, Maybe Value))
-> App (Maybe Value) -> App (Value, String, Maybe Value)
forall a b. App (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> App Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Response
uploadRes.json String
"expires"
    -- Lookup with token and get download URL. Should return the
    -- S3DownloadEndpoint, but not try to use it.
    Response
downloadURLRes <- Value -> String -> String -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid String
loc String
tok
    Response
downloadURLRes.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
downloadURLRes.body String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
""
    Request
downloadURL <- String -> App Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (ByteString -> String
C8.unpack (CI ByteString -> Response -> 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
"Location") Response
downloadURLRes))
    String
downloadEndpoint String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` forall a b. ConvertibleStrings a b => a -> b
cs @_ @String (Request -> ByteString
HTTP.host Request
downloadURL)
    Request -> Int
HTTP.port Request
downloadURL Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
443
    Bool
True Bool -> Bool -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (Request -> Bool
HTTP.secure Request
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
  Value
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
  Response
r1 <- Value -> ByteString -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ByteString -> App Response
uploadRaw Value
uid ByteString
exampleMultipart
  Response
r1.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
  let locHeader :: CI ByteString
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 :: String
loc = forall a.
(HasCallStack, FromByteString a) =>
CI ByteString -> Response -> a
decodeHeaderOrFail @String CI ByteString
locHeader Response
r1
  -- Lookup and download via redirect.
  Response
r2 <- Value -> String -> () -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid String
loc ()
  Response
r2.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
r2.body String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
""
  Response
r3 <- (Request -> (Request -> Request) -> App Response)
-> (Request -> Request) -> Request -> App Response
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> (Request -> Request) -> App Response
get' Request -> Request
forall a. a -> a
id (Request -> App Response) -> App Request -> App Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> App Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (ByteString -> String
C8.unpack (CI ByteString -> Response -> ByteString
getHeader' CI ByteString
locHeader Response
r2))
  Response
r3.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
  HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"Content types should match" (Bool -> App ()) -> Bool -> App ()
forall a b. (a -> b) -> a -> b
$ Response -> Maybe Type
getContentType Response
r3 Maybe Type -> Maybe Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type -> Maybe Type
forall a. a -> Maybe a
Just Type
applicationOctetStream'
  forall a.
(HasCallStack, FromByteString a) =>
CI ByteString -> Response -> a
decodeHeaderOrFail @String (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
r3 String -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (Value
uid Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id")
  forall a b. ConvertibleStrings a b => a -> b
cs @_ @String Response
r3.body String -> Maybe String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String -> Maybe String
forall a. a -> Maybe a
Just String
"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
  String
assetId <- App String
HasCallStack => App String
randomId
  Value
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 key :: Value
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 :: Value
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"
          ]
  Response
res <- Value -> Value -> () -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid Value
qkey ()
  Response
res.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
422

testRemoteDownloadNoAsset :: (HasCallStack) => App ()
testRemoteDownloadNoAsset :: HasCallStack => App ()
testRemoteDownloadNoAsset = do
  String
assetId <- App String
HasCallStack => App String
randomId
  Value
uid <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  String
otherDomain <- Domain -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make Domain
OtherDomain 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
  let key :: String
key = String
"3-2-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
assetId
      qkey :: Value
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
          ]
  Response
res <- Value -> Value -> () -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid Value
qkey ()
  Response
res.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
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
  Value
uid1 <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  Value
uid2 <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OtherDomain CreateUser
forall a. Default a => a
def
  Response
r1 <- Value -> Value -> (MIMEType, ByteString) -> App Response
forall user settings.
(HasCallStack, MakesValue user, MakesValue settings) =>
user -> settings -> (MIMEType, ByteString) -> App Response
uploadSimple Value
uid1 Value
settings (MIMEType
applicationOctetStream, a -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs a
content)
  Response
r1.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
  let locHeader :: CI ByteString
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 :: String
loc = forall a.
(HasCallStack, FromByteString a) =>
CI ByteString -> Response -> a
decodeHeaderOrFail @String CI ByteString
locHeader Response
r1
  -- Lookup and download via redirect.
  Response
r2 <- Value -> String -> () -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid2 String
loc ()
  Response
r2.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
  HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"Content types should match" (Bool -> App ()) -> Bool -> App ()
forall a b. (a -> b) -> a -> b
$ Response -> Maybe Type
getContentType Response
r2 Maybe Type -> Maybe Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type -> Maybe Type
forall a. a -> Maybe a
Just Type
applicationOctetStream'
  -- decodeHeaderOrFail @String (mk $ cs "x-amz-meta-user") r3 `shouldMatch` (uid %. "id")
  forall a b. ConvertibleStrings a b => a -> b
cs @_ @String Response
r2.body String -> Maybe String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String -> Maybe String
forall a. a -> Maybe a
Just (a -> String
forall a b. ConvertibleStrings a b => a -> b
cs a
content :: String)
  where
    settings :: Value
settings = [Pair] -> Value
object [String
"public" String -> Bool -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Bool
True]