{-# 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.V3 where

import API.Cargohold
import Codec.MIME.Type (showMIMEType)
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Char8 as C8
import Data.CaseInsensitive
import Data.String.Conversions
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Time.Format
import Data.Time.Format.ISO8601
import Network.HTTP.Client
import SetupHelpers
import Test.Cargohold.API.Util
import Testlib.Prelude

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

testSimpleRoundtrip :: (HasCallStack) => App ()
testSimpleRoundtrip :: HasCallStack => App ()
testSimpleRoundtrip = do
  let defSettings :: [Pair]
defSettings = [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"]
      allSets :: [Value]
allSets = ([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]
defSettings :) ([[Pair]] -> [[Pair]]) -> [[Pair]] -> [[Pair]]
forall a b. (a -> b) -> a -> b
$ (\String
r -> [String
"retention" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
r]) (String -> [Pair]) -> [String] -> [[Pair]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [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]
allSets
  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
      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
      -- use v3 path instead of the one returned in the header
      (Value
key, String
tok, Maybe String
expires) <-
        (,,)
          (Value -> String -> Maybe String -> (Value, String, Maybe String))
-> App Value
-> App (String -> Maybe String -> (Value, String, Maybe String))
forall (f :: * -> *) a b. Functor 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
"key"
          App (String -> Maybe String -> (Value, String, Maybe String))
-> App String
-> App (Maybe String -> (Value, 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
<*> (Response
r1.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"token" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString)
          App (Maybe String -> (Value, String, Maybe String))
-> App (Maybe String) -> App (Value, 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
          parseTime :: String -> UTCTime
parseTime = Bool -> TimeLocale -> String -> String -> UTCTime
forall t.
ParseTime t =>
Bool -> TimeLocale -> String -> String -> t
parseTimeOrError Bool
False TimeLocale
defaultTimeLocale String
rfc822DateFormat
          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
          utc :: UTCTime
utc = String -> UTCTime
parseTime String
date :: UTCTime
          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
        -- We don't care what the rentention value is here,
        -- we're just checking to see if other checks need
        -- to be done.
        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 -> Maybe Value -> String -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid Response
r1.jsonBody String
tok
      Response
r2.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
302
      HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"Response body should be empty" (Bool -> App ()) -> Bool -> App ()
forall a b. (a -> b) -> a -> b
$ Response
r2.body ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
forall a. Monoid a => a
mempty

      let locReq :: String
locReq = 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)
      Request
req <- IO Request -> App Request
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> App Request) -> IO Request -> App Request
forall a b. (a -> b) -> a -> b
$ String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
locReq
      Response
r3 <- String -> Request -> App Response
submit String
"GET" Request
req
      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
$ 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
r3
        Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ MIMEType -> Text
showMIMEType MIMEType
applicationOctetStream)
      HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"Token mismatch" (Bool -> App ()) -> Bool -> App ()
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
"x-amz-meta-token") Response
r3 Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
tok)
      String
uid' <- Value
uid Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
      HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"User mismatch" (Bool -> App ()) -> Bool -> App ()
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
"x-amz-meta-user") Response
r3 Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
uid')
      HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"Data mismatch" (Bool -> App ()) -> Bool -> App ()
forall a b. (a -> b) -> a -> b
$ Response
r3.body ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Hello World"
      -- Delete (forbidden for other users)
      Value -> Maybe Value -> App Response
forall user key.
(HasCallStack, MakesValue user, MakesValue key) =>
user -> key -> App Response
deleteAssetV3 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
deleteAssetV3 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 -> Value -> String -> App Response
forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' Value
uid Value
key 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
      let 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)