content: {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
  
  -- This file is part of the Wire Server implementation.
  --
  -- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
  --
  -- This program is free software: you can redistribute it and/or modify it under
  -- the terms of the GNU Affero General Public License as published by the Free
  -- Software Foundation, either version 3 of the License, or (at your option) any
  -- later version.
  --
  -- This program is distributed in the hope that it will be useful, but WITHOUT
  -- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  -- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
  -- details.
  --
  -- You should have received a copy of the GNU Affero General Public License along
  -- with this program. If not, see <https://www.gnu.org/licenses/>.
  
  module Test.Cargohold.API where
  
  import API.Cargohold
  import qualified Codec.MIME.Type as MIME
  import Control.Lens hiding (sets, (.=))
  import qualified Data.Aeson.KeyMap as KM
  import Data.Aeson.Types (Pair)
  import qualified Data.ByteString.Char8 as BC
  import qualified Data.ByteString.Char8 as C8
  import qualified Data.ByteString.Lazy as LBS hiding (replicate)
  import qualified Data.ByteString.Lazy.Char8 as L8
  import Data.CaseInsensitive (mk)
  import Data.String.Conversions
  import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError, rfc822DateFormat)
  import Data.Time.Format.ISO8601 (formatParseM, iso8601Format)
  import Network.HTTP.Client (parseUrlThrow)
  import qualified Network.HTTP.Client as HTTP
  import qualified Network.HTTP.Types as HTTP
  import SetupHelpers (createTeam, randomId, randomUser)
  import Testlib.Prelude
  import UnliftIO.Concurrent
  
  --------------------------------------------------------------------------------
  -- Simple (single-step) uploads
  
  testSimpleRoundtrip :: (HasCallStack) => App ()
  testSimpleRoundtrip = do
    let def' = ["public" .= False]
        rets = ["eternal", "persistent", "volatile", "eternal-infrequent_access", "expiring"]
        sets' = fmap object $ def' : fmap (\r -> "retention" .= r : def') rets
    mapM_ simpleRoundtrip sets'
    where
      simpleRoundtrip :: (HasCallStack) => Value -> App ()
      simpleRoundtrip sets = do
        uid <- randomUser OwnDomain def
        userId1 <- uid %. "id" & asString
        uid2 <- randomUser OwnDomain def
        -- Initial upload
        let bdy = (applicationText, cs "Hello World")
        r1 <- uploadSimpleV3 uid sets bdy
        r1.status `shouldMatchInt` 201
        loc <- maybe (error "Could not find the Location header") (pure . cs @_ @String) $ lookup (mk $ cs "Location") r1.headers
        (tok, expires) <-
          (,)
            <$> asString (r1.json %. "token")
            <*> (lookupField r1.json "expires" >>= maybe (pure Nothing) (fmap pure . asString))
        -- Check mandatory Date header
        let Just date = C8.unpack <$> lookup (mk $ cs "Date") r1.headers
            utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime
            parseTimeIso t = fromMaybe (error $ "Could not parse \"" <> t <> "\" as ISO8601") $ formatParseM (iso8601Format @UTCTime) t
            expires' = parseTimeIso <$> expires :: Maybe UTCTime
        -- Potentially check for the expires header
        case sets of
          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 loc tok
        r2.status `shouldMatchInt` 302
        cs @_ @String r2.body `shouldMatch` ""
        r3 <- flip get' id =<< parseUrlThrow (C8.unpack (getHeader' (mk $ cs "Location") r2))
        r3.status `shouldMatchInt` 200
        assertBool "content-type should always be application/octet-stream" $ Just applicationOctetStream == fmap MIME.mimeType (getContentType r3)
        assertBool "token mismatch" $ tok == decodeHeaderOrFail (mk $ cs "x-amz-meta-token") r3
        assertBool "user mismatch" $ userId1 == decodeHeaderOrFail (mk $ cs "x-amz-meta-user") r3
        assertBool "data mismatch" $ cs "Hello World" == r3.body
        -- Delete (forbidden for other users)
        deleteAsset uid2 r1.jsonBody >>= \r -> r.status `shouldMatchInt` 403
        -- Delete (allowed for creator)
        deleteAsset uid r1.jsonBody >>= \r -> r.status `shouldMatchInt` 200
        r4 <- downloadAsset' uid loc tok
        r4.status `shouldMatchInt` 404
        let Just date' = C8.unpack <$> lookup (mk $ cs "Date") r4.headers
            utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime
        assertBool "bad date" (utc' >= utc)
  
  testDownloadWithAcceptHeader :: (HasCallStack) => App ()
  testDownloadWithAcceptHeader = do
    assetId <- randomId
    uid <- randomUser OwnDomain def
    domain <- make OwnDomain
    let key = "3-2-" <> assetId
        qkey = object ["domain" .= domain, "id" .= key]
    res <- downloadAssetWithQualifiedAssetKey (header "Accept" "image/jpeg") uid qkey ()
    res.status `shouldMatchInt` 404
  
  queryItem :: ByteString -> Maybe ByteString -> HTTP.Request -> HTTP.Request
  queryItem k v r =
    HTTP.setQueryString ((k, v) : queryItems) r
    where
      queryItems = HTTP.parseQuery $ HTTP.queryString r
  
  get' :: HTTP.Request -> (HTTP.Request -> HTTP.Request) -> App Response
  get' r f = submit "GET" $ f r
  
  testSimpleTokens :: (HasCallStack) => App ()
  testSimpleTokens = do
    uid <- randomUser OwnDomain def
    uid2 <- randomUser OwnDomain def
    -- Initial upload
    let sets = object ["public" .= False, "retention" .= "volatile"]
        bdy = (applicationText, cs "Hello World")
    r1 <- uploadSimpleV3 uid sets bdy
    r1.status `shouldMatchInt` 201
    loc <-
      maybe
        (assertFailure "Could not get \"Location\" header from the request")
        (pure . cs @_ @String)
        $ getHeader (mk $ cs "Location") r1
    (key, tok) <-
      (,)
        <$> asString (r1.json %. "key")
        <*> r1.json
        %. "token"
    -- No access without token from other user (opaque 404)
    downloadAsset' uid2 loc () >>= \r -> r.status `shouldMatchInt` 404
    -- No access with empty token query parameter from other user (opaque 404)
    downloadAsset' uid2 loc (queryItem (cs "asset_token") Nothing) >>= \r -> r.status `shouldMatchInt` 404
    -- No access with wrong token (opaque 404)
    downloadAsset' uid2 loc (header "Asset-Token" "abc123") >>= \r -> r.status `shouldMatchInt` 404
    -- No access with wrong token as query parameter (opaque 404)
    downloadAsset' uid2 loc (queryItem (cs "asset_token") $ pure $ cs "acb123") >>= \r -> r.status `shouldMatchInt` 404
    -- Token renewal fails if not done by owner
    postToken uid2 key >>= \r -> do
      r.status `shouldMatchInt` 403
      label <- traverse ((%. "label") >=> asString) r.jsonBody
      label `shouldMatch` "unauthorised"
    -- Token renewal succeeds if done by owner
    r2 <- postToken uid key
    r2.status `shouldMatchInt` 200
    tok' <- r2.jsonBody %. "token" & asString
    assertBool "token unchanged" (tok /= String (cs tok'))
    -- Download by owner with new token.
    r3 <- downloadAsset' uid loc tok'
    r3.status `shouldMatchInt` 302
    cs @_ @String r3.body `shouldMatch` ""
    r4 <- flip get' id =<< parseUrlThrow (C8.unpack (getHeader' (mk $ cs "Location") r3))
    r4.status `shouldMatchInt` 200
    let r4ContentType :: Maybe String
        r4ContentType = cs @_ @String <$> getHeader (mk $ cs "content-type") r4
    r4ContentType `shouldMatch` Just (cs @_ @String $ MIME.showMIMEType applicationOctetStream)
    let r4Tok :: Maybe String
        r4Tok = cs @_ @String <$> getHeader (mk $ cs "x-amz-meta-token") r4
    r4Tok `shouldMatch` Just tok'
    let r4User :: Maybe String
        r4User = cs @_ @String <$> getHeader (mk $ cs "x-amz-meta-user") r4
    r4User `shouldMatch` fmap Just (uid %. "id")
    cs @_ @String r4.body `shouldMatch` "Hello World"
    -- Verify access without token if the request comes from the creator.
    downloadAsset' uid loc () >>= \r -> r.status `shouldMatchInt` 302
    -- Verify access with new token from a different user.
    downloadAsset' uid2 loc tok' >>= \r -> r.status `shouldMatchInt` 302
    -- Verify access with new token as query parameter from a different user
    downloadAsset' uid2 loc (queryItem (cs "asset_token") (pure $ cs tok')) >>= \r ->
      r.status `shouldMatchInt` 302
    -- Delete Token fails if not done by owner
    deleteToken uid2 key >>= \r -> do
      r.status `shouldMatchInt` 403
      label' <- traverse ((%. "label") >=> asString) r.jsonBody
      label' `shouldMatch` "unauthorised"
    -- Delete Token succeeds by owner
    deleteToken uid key >>= \r -> do
      r.status `shouldMatchInt` 200
      cs @_ @String r.body `shouldMatch` ""
    -- Access without token from different user (asset is now "public")
    downloadAsset' uid2 loc () >>= \r -> do
      r.status `shouldMatchInt` 302
      cs @_ @String r.body `shouldMatch` ""
  
  defAssetSettings' :: [Pair]
  defAssetSettings' = ["public" .= False]
  
  defAssetSettings :: Value
  defAssetSettings = object 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 = go >> wait >> go
    where
      wait = liftIO $ putStrLn "Waiting for S3 idle timeout ..." >> threadDelay 7000000
      go = do
        uid <- randomUser OwnDomain def
        let sets = object $ defAssetSettings' <> ["retention" .= "volatile"]
        let part2 = (MIME.Text $ cs "plain", cs $ replicate 100000 'c')
        uploadSimpleV3 uid sets part2 >>= \r -> r.status `shouldMatchInt` 201
  
  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 = "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 = setField "aws.s3DownloadEndpoint" ("https://" <> downloadEndpoint)
    startDynamicBackends [def {cargoholdCfg = f}] $ \[d] -> do
      -- withSettingsOverrides (aws . s3DownloadEndpoint ?~ AWSEndpoint downloadEndpoint True 443) $ do
      uid <- randomUser d def
      -- Upload, should work, shouldn't try to use the S3DownloadEndpoint
      let bdy = (applicationText, cs "Hello World")
      uploadRes <- uploadSimpleV3 uid defAssetSettings bdy
      uploadRes.status `shouldMatchInt` 201
      let loc = decodeHeaderOrFail (mk $ cs "Location") uploadRes :: String
      (_key, tok, _expires) <-
        (,,)
          <$> uploadRes.json
          %. "key"
          <*> (uploadRes.json %. "token" & asString)
          <*> lookupField uploadRes.json "expires"
      -- Lookup with token and get download URL. Should return the
      -- S3DownloadEndpoint, but not try to use it.
      downloadURLRes <- downloadAsset' uid loc tok
      downloadURLRes.status `shouldMatchInt` 302
      cs @_ @String downloadURLRes.body `shouldMatch` ""
      downloadURL <- parseUrlThrow (C8.unpack (getHeader' (mk $ cs "Location") downloadURLRes))
      downloadEndpoint `shouldMatch` cs @_ @String (HTTP.host downloadURL)
      HTTP.port downloadURL `shouldMatchInt` 443
      True `shouldMatch` (HTTP.secure downloadURL)
  
  --------------------------------------------------------------------------------
  -- Client compatibility tests
  
  -- Since the other tests use functions from the server code, it can happen that
  -- an API change also changes the requests made here in the tests.
  -- This test tries to prevent us from breaking the API without noticing.
  --
  -- The body is taken directly from a request made by the web app
  -- (just replaced the content with a shorter one and updated the MD5 header).
  testUploadCompatibility :: (HasCallStack) => App ()
  testUploadCompatibility = do
    uid <- randomUser OwnDomain def
    -- Initial upload
    r1 <- uploadRawV3 uid exampleMultipart
    r1.status `shouldMatchInt` 201
    let locHeader = mk $ cs "Location"
        loc = decodeHeaderOrFail @String locHeader r1
    -- Lookup and download via redirect.
    r2 <- downloadAsset' uid loc ()
    r2.status `shouldMatchInt` 302
    cs @_ @String r2.body `shouldMatch` ""
    r3 <- flip get' id =<< parseUrlThrow (C8.unpack (getHeader' locHeader r2))
    r3.status `shouldMatchInt` 200
    assertBool "Content types should match" $ getContentType r3 == Just applicationOctetStream'
    decodeHeaderOrFail @String (mk $ cs "x-amz-meta-user") r3 `shouldMatch` (uid %. "id")
    cs @_ @String r3.body `shouldMatch` Just "test"
    where
      exampleMultipart :: LBS.ByteString
      exampleMultipart =
        cs
          "--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 = do
    assetId <- randomId
    uid <- randomUser OwnDomain def
    let key = toJSON $ "3-2-" <> assetId
        qkey =
          object
            [ "key" .= key,
              "domain" .= "invalid.example.com"
            ]
    res <- downloadAsset' uid qkey ()
    res.status `shouldMatchInt` 422
  
  testRemoteDownloadNoAsset :: (HasCallStack) => App ()
  testRemoteDownloadNoAsset = do
    assetId <- randomId
    uid <- randomUser OwnDomain def
    otherDomain <- make OtherDomain & asString
    let key = "3-2-" <> assetId
        qkey =
          object
            [ "domain" .= otherDomain,
              "key" .= key
            ]
    res <- downloadAsset' uid qkey ()
    res.status `shouldMatchInt` 404
  
  testRemoteDownloadShort :: (HasCallStack) => App ()
  testRemoteDownloadShort = remoteDownload "asset content"
  
  testRemoteDownloadLong :: (HasCallStack) => App ()
  testRemoteDownloadLong = remoteDownload $ concat $ replicate 20000 $ "hello world\n"
  
  remoteDownload :: (HasCallStack, ConvertibleStrings a L8.ByteString, ConvertibleStrings a String) => a -> App ()
  remoteDownload content = do
    uid1 <- randomUser OwnDomain def
    uid2 <- randomUser OtherDomain def
    r1 <- uploadSimpleV3 uid1 settings (applicationOctetStream, cs content)
    r1.status `shouldMatchInt` 201
    let locHeader = mk $ cs "Location"
        loc = decodeHeaderOrFail @String locHeader r1
    -- Lookup and download via redirect.
    r2 <- downloadAsset' uid2 loc ()
    r2.status `shouldMatchInt` 200
    assertBool "Content types should match" $ getContentType r2 == Just applicationOctetStream'
    -- decodeHeaderOrFail @String (mk $ cs "x-amz-meta-user") r3 `shouldMatch` (uid %. "id")
    cs @_ @String r2.body `shouldMatch` Just (cs content :: String)
    where
      settings = object ["public" .= True]
  
  ------------------------------------------------------------------------
  -- Asset Audit Log
  
  -- Upload and download audit logging scenarios across two backends (A and B).
  
  -- Case 1:
  --  - Uploader: on backend A (audit enabled)
  --  - Downloader: on backend A (same backend)
  -- Expected logs:
  --   - Backend A: "file-upload", "download-url-creation""
  testAssetAuditLogDownloadBackendALocal :: (HasCallStack) => App ()
  testAssetAuditLogDownloadBackendALocal = do
    startDynamicBackends [cargoholdAuditLogEnabled] $ \[domainA] -> do
      (owner, _tid, _members) <- createTeam domainA 1
      -- Missing audit metadata should cause the upload to fail when the setting is enabled
      let missingMetaSettings = object ["public" .= False]
          body = (applicationText, cs "download-me")
      uploadSimple owner missingMetaSettings body `bindResponse` \resp -> do
        resp.status `shouldMatchInt` 400
        resp.jsonBody %. "label" `shouldMatch` "missing-audit-metadata"
      -- Now upload again with correct metadata and expect success 201
      settings <-
        validAssetMetadataSettings
          <$> randomId
          <*> (owner %. "qualified_id.domain" & asString)
      key <-
        uploadSimple owner settings body `bindResponse` \r -> do
          r.status `shouldMatchInt` 201
          r.json %. "key"
      -- Download by the owner (no token needed since same backend and owner).
      bindResponse (downloadAsset owner owner key "nginz-https.example.com" id) $ \resp -> do
        resp.status `shouldMatchInt` 200
        BC.unpack resp.body `shouldMatch` "download-me"
  
  -- Case 2:
  --  - Uploader: on backend A (audit enabled)
  --  - Downloader: on backend B (audit disabled)
  -- Expected logs:
  --   - Backend A: "file-upload", "file-download"
  --   - Backend B: No logging.
  testAssetAuditLogDownloadBackendALoggingBackendBNotLogging :: (HasCallStack) => App ()
  testAssetAuditLogDownloadBackendALoggingBackendBNotLogging = do
    startDynamicBackends [cargoholdAuditLogEnabled] $ \[domainA] -> do
      let domainB = OwnDomain
      (owner, _tid, _members) <- createTeam domainA 1
      downloader <- randomUser domainB def
      -- Upload on A with metadata
      settings <-
        validAssetMetadataSettings
          <$> randomId
          <*> (owner %. "qualified_id.domain" & asString)
      let body = (applicationText, cs "hello-onprem")
      (loc, tok) <-
        uploadSimple owner settings body `bindResponse` \r -> do
          r.status `shouldMatchInt` 201
          (,) <$> r.json <*> (r.json %. "token" & asString)
      -- Federated download by user on backend B.
      bindResponse (downloadAsset' downloader loc tok) $ \resp -> do
        resp.status `shouldMatchInt` 200
        BC.unpack resp.body `shouldMatch` "hello-onprem"
  
  -- Case 3:
  --  - Uploader: on backend A (audit enabled)
  --  - Downloader: on backend B (audit enabled)
  --  Expected logs:
  --    - Backend A: "file-upload", "file-download"
  --    - Backend B: "file-download"
  testAssetAuditLogDownloadBackendALoggingBackendBLogging :: (HasCallStack) => App ()
  testAssetAuditLogDownloadBackendALoggingBackendBLogging = do
    -- Start two dynamic backends with audit logging enabled on both.
    startDynamicBackends [cargoholdAuditLogEnabled, cargoholdAuditLogEnabled] $ \[domainA, domainB] -> do
      (owner, _tid, _members) <- createTeam domainA 1
      downloader <- randomUser domainB def
      -- Upload on A with required metadata
      settings <-
        validAssetMetadataSettings
          <$> randomId
          <*> (owner %. "qualified_id.domain" & asString)
      let body = (applicationText, cs "hello-onprem")
      (loc, tok) <-
        uploadSimple owner settings body `bindResponse` \r -> do
          r.status `shouldMatchInt` 201
          (,) <$> r.json <*> (r.json %. "token" & asString)
      -- Federated download by user on backend B.
      bindResponse (downloadAsset' downloader loc tok) $ \resp -> do
        resp.status `shouldMatchInt` 200
        BC.unpack resp.body `shouldMatch` "hello-onprem"
  
  -- Case 4:
  --  - Uploader on backend A (audit disabled)
  --  - Downloader on backend B (audit enabled)
  --  Expected logs:
  --    - Backend A: Not logging
  --    - Backend B: "file-download"
  testAssetAuditLogDownloadBackendANotLoggingBackendBLogging :: (HasCallStack) => App ()
  testAssetAuditLogDownloadBackendANotLoggingBackendBLogging = do
    -- Start two backends: A without audit, B with audit.
    startDynamicBackends [def, cargoholdAuditLogEnabled] $ \[domainA, domainB] -> do
      (owner, _tid, _members) <- createTeam domainA 1
      downloader <- randomUser domainB def
      -- Upload on A with required metadata (no audit logging on A)
      settings <-
        validAssetMetadataSettings
          <$> randomId
          <*> (owner %. "qualified_id.domain" & asString)
      let body = (applicationText, cs "hello-onprem")
      (loc, tok) <-
        uploadSimple owner settings body `bindResponse` \r -> do
          r.status `shouldMatchInt` 201
          (,) <$> r.json <*> (r.json %. "token" & asString)
      -- Federated download by user on backend B (audit enabled on B).
      bindResponse (downloadAsset' downloader loc tok) $ \resp -> do
        resp.status `shouldMatchInt` 200
        BC.unpack resp.body `shouldMatch` "hello-onprem"
  
  cargoholdAuditLogEnabled :: ServiceOverrides
  cargoholdAuditLogEnabled =
    def
      { cargoholdCfg =
          setField "settings.assetAuditLogEnabled" True
            . setField "logLevel" "Info"
            . setField "logFormat" "StructuredJSON"
      }
  
  validAssetMetadataSettings :: (ToJSON a1, ToJSON a2) => a1 -> a2 -> Value
  validAssetMetadataSettings convId dom =
    object
      [ "public" .= False,
        "convId" .= object ["id" .= convId, "domain" .= dom],
        "filename" .= "virus.js",
        "filetype" .= "application/javascript"
      ]
  