{-# 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 Crypto.Random
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString as BS
import Data.ByteString.Builder
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LBS
import Data.CaseInsensitive
import Data.String.Conversions
import Data.Text
import Data.Text.Encoding
import Data.Time.Clock (UTCTime)
import Data.Time.Format
import Data.Time.Format.ISO8601
import Network.HTTP.Client
import SetupHelpers
import Testlib.Prelude
import Text.Read (readMaybe)

--------------------------------------------------------------------------------
-- 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]]
forall a. a -> [a] -> [a]
:) ([[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
      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 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
      -- use v3 path instead of the one returned in the header
      (key, tok, expires) <-
        (,,)
          <$> r1.json
          %. "key"
          <*> (r1.json %. "token" >>= asString)
          <*> (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
          parseTime = Bool -> TimeLocale -> String -> String -> UTCTime
forall t.
ParseTime t =>
Bool -> TimeLocale -> String -> String -> t
parseTimeOrError Bool
False TimeLocale
defaultTimeLocale String
rfc822DateFormat
          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 = String -> UTCTime
parseTime String
date :: 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 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
            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 r1.jsonBody tok
      r2.status `shouldMatchInt` 302
      assertBool "Response body should be empty" $ r2.body == mempty

      let 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)
      req <- liftIO $ parseRequest locReq
      r3 <- submit "GET" req
      r3.status `shouldMatchInt` 200
      assertBool "content-type should always be application/octet-stream"
        $ getHeader (mk $ cs "content-type") r3
        == Just (encodeUtf8 $ showMIMEType applicationOctetStream)
      assertBool "Token mismatch" $ getHeader (mk $ cs "x-amz-meta-token") r3 == pure (cs tok)
      uid' <- uid %. "id" >>= asString
      assertBool "User mismatch" $ getHeader (mk $ cs "x-amz-meta-user") r3 == pure (cs uid')
      assertBool "Data mismatch" $ r3.body == cs "Hello World"
      -- Delete (forbidden for other users)
      deleteAssetV3 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)
      deleteAssetV3 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 key tok
      r4.status `shouldMatchInt` 404
      let Just date' = C8.unpack <$> lookup (mk $ cs "Date") r4.headers
      let 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)

-- | Simulates an interrupted upload, where the user sends less data than expected.
testUploadWrongContentLength :: (HasCallStack) => App ()
testUploadWrongContentLength :: HasCallStack => App ()
testUploadWrongContentLength = 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 payloadBytes = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024
  payload <- BS.fromStrict <$> (liftIO . getRandomBytes) payloadBytes
  let -- A too small offset (<= 16) to the correct payloadBytes may lead to
      -- having the delimiter `--frontier--` being interpreted as content. So,
      -- we add a big offset here.
      tooBigContentLength = Int
payloadBytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1024
  uploadRawV3 uid (body tooBigContentLength payload) >>= \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
"incomplete-body"

  -- Sanity check
  key <-
    uploadRawV3 uid (body payloadBytes payload) >>= \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key"

  bindResponse (downloadAsset uid uid 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
    let contentLength :: Maybe Int
contentLength = (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int)
-> (ByteString -> String) -> ByteString -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8) (ByteString -> Maybe Int)
-> ((CI ByteString, ByteString) -> ByteString)
-> (CI ByteString, ByteString)
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CI ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((CI ByteString, ByteString) -> Maybe Int)
-> Maybe (CI ByteString, ByteString) -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Response -> Maybe (CI ByteString, ByteString)
contentLengthHeader Response
resp
    HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"Content-Length matches" (Bool -> App ()) -> Bool -> App ()
forall a b. (a -> b) -> a -> b
$ Maybe Int
contentLength Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
payloadBytes)
    HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"Body" (Bool -> App ()) -> Bool -> App ()
forall a b. (a -> b) -> a -> b
$ Response
resp.body ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== (ByteString -> ByteString
LBS.toStrict ByteString
payload)
  where
    body :: Int -> LBS.ByteString -> LBS.ByteString
    body :: Int -> ByteString -> ByteString
body Int
contentLength ByteString
payload =
      let settings :: Value
settings = [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"]
       in Builder -> ByteString
toLazyByteString
            (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> Type -> Word -> Builder
beginMultipartBody Value
settings Type
applicationOctetStream' (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
contentLength)
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lazyByteString ByteString
payload
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
endMultipartBody'