{-# 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 = do
  let defSettings = ["public" .= False]
      rets = ["eternal", "persistent", "volatile", "eternal-infrequent_access", "expiring"]
      allSets = fmap object $ (defSettings :) $ (\r -> ["retention" .= r]) <$> rets
  mapM_ simpleRoundtrip allSets
  where
    simpleRoundtrip :: (HasCallStack) => Value -> App ()
    simpleRoundtrip sets = do
      uid <- randomUser OwnDomain def
      uid2 <- randomUser OwnDomain def
      -- Initial upload
      let bdy = (applicationText, cs "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 = parseTimeOrError False defaultTimeLocale rfc822DateFormat
          parseTimeIso t = fromMaybe (error $ "Could not parse \"" <> t <> "\" as ISO8601") $ formatParseM (iso8601Format @UTCTime) t
          utc = parseTime date :: UTCTime
          expires' = parseTimeIso <$> 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 o -> case KM.lookup (fromString "retention") o of
          Nothing -> pure ()
          Just r -> do
            r' <- asString 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')
        _ -> pure ()
      -- Lookup with token and download via redirect.
      r2 <- downloadAsset' uid r1.json tok
      r2.status `shouldMatchInt` 302
      assertBool "Response body should be empty" $ r2.body == mempty

      let locReq = C8.unpack (getHeader' (mk $ cs "Location") 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.json >>= \r -> r.status `shouldMatchInt` 403
      -- Delete (allowed for creator)
      deleteAssetV3 uid r1.json >>= \r -> r.status `shouldMatchInt` 200
      r4 <- downloadAsset' uid key tok
      r4.status `shouldMatchInt` 404
      let Just date' = C8.unpack <$> lookup (mk $ cs "Date") r4.headers
      let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime
      assertBool "bad date" (utc' >= utc)

-- | Simulates an interrupted upload, where the user sends less data than expected.
testUploadWrongContentLength :: (HasCallStack) => App ()
testUploadWrongContentLength = do
  uid <- randomUser OwnDomain def
  let payloadBytes = 2 * 1024
  payload <- BS.fromStrict <$> (liftIO . getRandomBytes) payloadBytes
  let -- A too small offset (<= 16) to the correct payloadBytes may lead to
      -- having the delimiter `--frontier--` being interpreted as content. So,
      -- we add a big offset here.
      tooBigContentLength = payloadBytes + 1024
  uploadRawV3 uid (body tooBigContentLength payload) >>= \resp -> do
    resp.status `shouldMatchInt` 400
    resp.json %. "label" `shouldMatch` "incomplete-body"

  -- Sanity check
  key <-
    uploadRawV3 uid (body payloadBytes payload) >>= \resp -> do
      resp.status `shouldMatchInt` 201
      resp.json %. "key"

  bindResponse (downloadAsset uid uid key "nginz-https.example.com" id) $ \resp -> do
    resp.status `shouldMatchInt` 200
    let contentLength = (readMaybe . unpack . decodeUtf8) . snd =<< contentLengthHeader resp
    assertBool "Content-Length matches" $ contentLength == (Just payloadBytes)
    assertBool "Body" $ resp.body == (LBS.toStrict payload)
  where
    body :: Int -> LBS.ByteString -> LBS.ByteString
    body contentLength payload =
      let settings = object ["public" .= False, "retention" .= "volatile"]
       in toLazyByteString
            $ beginMultipartBody settings applicationOctetStream' (fromIntegral contentLength)
            <> lazyByteString payload
            <> endMultipartBody'
