{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 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.Brig where

import API.Brig as BrigP
import qualified API.BrigInternal as BrigI
import API.Common
import API.GalleyInternal (setTeamFeatureStatus)
import API.Spar
import Control.Retry
import Data.Aeson.Types hiding ((.=))
import Data.List.Split
import Data.String.Conversions
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import GHC.Stack
import SetupHelpers
import System.IO.Extra
import Testlib.Assertions
import Testlib.Prelude
import UnliftIO.Temporary

testCrudFederationRemotes :: (HasCallStack) => App ()
testCrudFederationRemotes = do
  otherDomain <- asString OtherDomain
  withModifiedBackend def $ \ownDomain -> do
    let parseFedConns :: (HasCallStack) => Response -> App [Value]
        parseFedConns resp =
          -- Pick out the list of federation domain configs
          getJSON 200 resp %. "remotes"
            & asList
              -- Enforce that the values are objects and not something else
              >>= traverse (fmap Object . asObject)

        addTest :: (MakesValue fedConn, Ord fedConn2, ToJSON fedConn2, MakesValue fedConn2, HasCallStack) => fedConn -> [fedConn2] -> App ()
        addTest fedConn want = do
          bindResponse (BrigI.createFedConn ownDomain fedConn) $ \res -> do
            addFailureContext ("res = " <> show res) $ res.status `shouldMatchInt` 200
            res2 <- parseFedConns =<< BrigI.readFedConns ownDomain
            sort res2 `shouldMatch` sort want

        updateTest :: (MakesValue fedConn, Ord fedConn2, ToJSON fedConn2, MakesValue fedConn2, HasCallStack) => String -> fedConn -> [fedConn2] -> App ()
        updateTest domain fedConn want = do
          bindResponse (BrigI.updateFedConn ownDomain domain fedConn) $ \res -> do
            addFailureContext ("res = " <> show res) $ res.status `shouldMatchInt` 200
            res2 <- parseFedConns =<< BrigI.readFedConns ownDomain
            sort res2 `shouldMatch` sort want

    dom1 :: String <- (<> ".example.com") . UUID.toString <$> liftIO UUID.nextRandom

    let remote1, remote1' :: BrigI.FedConn
        remote1 = BrigI.FedConn dom1 "no_search" Nothing
        remote1' = remote1 {BrigI.searchStrategy = "full_search", BrigI.restriction = Just []}

        cfgRemotesExpect :: BrigI.FedConn
        cfgRemotesExpect = BrigI.FedConn (cs otherDomain) "full_search" Nothing

    cfgRemotes <- parseFedConns =<< BrigI.readFedConns ownDomain
    cfgRemotes `shouldMatch` ([] @Value)
    -- entries present in the config file can be idempotently added if identical, but cannot be
    -- updated.
    addTest cfgRemotesExpect [cfgRemotesExpect]
    -- create
    addTest remote1 [cfgRemotesExpect, remote1]
    addTest remote1 [cfgRemotesExpect, remote1] -- idempotency
    -- update
    updateTest (BrigI.domain remote1) remote1' [cfgRemotesExpect, remote1']

testCrudOAuthClient :: (HasCallStack) => App ()
testCrudOAuthClient = do
  user <- randomUser OwnDomain def
  let appName = "foobar"
  let url = "https://example.com/callback.html"
  clientId <- bindResponse (BrigI.registerOAuthClient user appName url) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json %. "client_id"
  bindResponse (BrigI.getOAuthClient user clientId) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json %. "application_name" `shouldMatch` appName
    resp.json %. "redirect_url" `shouldMatch` url
  let newName = "barfoo"
  let newUrl = "https://example.com/callback2.html"
  bindResponse (BrigI.updateOAuthClient user clientId newName newUrl) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json %. "application_name" `shouldMatch` newName
    resp.json %. "redirect_url" `shouldMatch` newUrl
  bindResponse (BrigI.deleteOAuthClient user clientId) $ \resp -> do
    resp.status `shouldMatchInt` 200
  bindResponse (BrigI.getOAuthClient user clientId) $ \resp -> do
    resp.status `shouldMatchInt` 404

testCrudFederationRemoteTeams :: (HasCallStack) => App ()
testCrudFederationRemoteTeams = do
  (_, tid, _) <- createTeam OwnDomain 1
  (_, tid2, _) <- createTeam OwnDomain 1
  rd <- (\n -> n <> ".wire.com") <$> randomName
  bindResponse (BrigI.addFederationRemoteTeam' OwnDomain rd tid) $ \resp -> do
    resp.status `shouldMatchInt` 533
  void $ BrigI.createFedConn OwnDomain $ BrigI.FedConn rd "full_search" Nothing
  bindResponse (BrigI.addFederationRemoteTeam' OwnDomain rd tid) $ \resp -> do
    resp.status `shouldMatchInt` 533
  void $ BrigI.updateFedConn OwnDomain rd $ BrigI.FedConn rd "full_search" (Just [])
  bindResponse (BrigI.getFederationRemoteTeams OwnDomain rd) $ \resp -> do
    resp.status `shouldMatchInt` 200
    checkAbsence resp [tid, tid2]
  BrigI.addFederationRemoteTeam OwnDomain rd tid
  bindResponse (BrigI.getFederationRemoteTeams OwnDomain rd) $ \resp -> do
    resp.status `shouldMatchInt` 200
    checkPresence resp [tid]
    checkAbsence resp [tid2]
  BrigI.addFederationRemoteTeam OwnDomain rd tid2
  bindResponse (BrigI.getFederationRemoteTeams OwnDomain rd) $ \resp -> do
    resp.status `shouldMatchInt` 200
    checkPresence resp [tid, tid2]
  BrigI.deleteFederationRemoteTeam OwnDomain rd tid
  bindResponse (BrigI.getFederationRemoteTeams OwnDomain rd) $ \resp -> do
    resp.status `shouldMatchInt` 200
    checkPresence resp [tid2]
    checkAbsence resp [tid]
  BrigI.deleteFederationRemoteTeam OwnDomain rd tid2
  bindResponse (BrigI.getFederationRemoteTeams OwnDomain rd) $ \resp -> do
    resp.status `shouldMatchInt` 200
    checkAbsence resp [tid, tid2]
  where
    checkAbsence :: Response -> [String] -> App ()
    checkAbsence resp tids = do
      l <- resp.json & asList
      remoteTeams <- forM l (\e -> e %. "team_id" & asString)
      when (any (\t -> t `elem` remoteTeams) tids) $ assertFailure "Expected response to not contain any of the teams"

    checkPresence :: Response -> [String] -> App ()
    checkPresence resp tids = do
      l <- resp.json & asList
      remoteTeams <- forM l (\e -> e %. "team_id" & asString)
      when (any (\t -> t `notElem` remoteTeams) tids) $ assertFailure "Expected response to contain all of the teams"

testSFTCredentials :: (HasCallStack) => App ()
testSFTCredentials = do
  let ttl = (60 :: Int)
  withSystemTempFile "sft-secret" $ \secretFile secretHandle -> do
    liftIO $ do
      hPutStr secretHandle "xMtZyTpu=Leb?YKCoq#BXQR:gG^UrE83dNWzFJ2VcD"
      hClose secretHandle
    withModifiedBackend
      ( def
          { brigCfg =
              ( setField "sft.sftBaseDomain" "integration-tests.zinfra.io"
                  . setField "sft.sftToken.ttl" ttl
                  . setField "sft.sftToken.secret" secretFile
                  . setField "sft.sftDiscoveryIntervalSeconds" (1 :: Int)
                  . setField "optSettings.setSftListAllServers" "enabled"
              )
          }
      )
      $ \domain -> do
        user <- randomUser domain def

        sftServersAll <-
          retrying
            (limitRetriesByCumulativeDelay 2_000_000 $ fullJitterBackoff 50_000)
            (\_ xs -> let shouldRetry = null xs in pure shouldRetry)
            $ \_ -> do
              resp <- getCallsConfigV2 user
              resp.json %. "sft_servers_all" & asList

        when (null sftServersAll) $ assertFailure "sft_servers_all empty"
        for_ sftServersAll $ \s -> do
          cred <- s %. "credential" & asString
          when (null cred) $ assertFailure "credential missing"
          usr <- s %. "username" & asString
          let parts = splitOn "." usr
          when (length parts /= 5) $ assertFailure "username should have 5 parts"
          when (take 2 (head parts) /= "d=") $ assertFailure "missing expiry time identifier"
          when (take 2 (parts !! 1) /= "v=") $ assertFailure "missing version identifier"
          when (take 2 (parts !! 2) /= "k=") $ assertFailure "missing key ID identifier"
          when (take 2 (parts !! 3) /= "s=") $ assertFailure "missing federation identifier"
          when (take 2 (parts !! 4) /= "r=") $ assertFailure "missing random data identifier"
          for_ parts $ \part -> when (length part < 3) $ assertFailure ("value missing for " <> part)

testSFTNoCredentials :: (HasCallStack) => App ()
testSFTNoCredentials = withModifiedBackend
  ( def
      { brigCfg =
          ( setField "sft.sftBaseDomain" "integration-tests.zinfra.io"
              . setField "optSettings.setSftListAllServers" "enabled"
          )
      }
  )
  $ \domain -> do
    user <- randomUser domain def
    bindResponse (getCallsConfigV2 user) \resp -> do
      sftServersAll <- resp.json %. "sft_servers_all" & asList
      when (null sftServersAll) $ assertFailure "sft_servers_all missing"
      for_ sftServersAll $ \s -> do
        credM <- lookupField s "credential"
        when (isJust credM) $ assertFailure "should not generate credential"
        usrM <- lookupField s "username"
        when (isJust usrM) $ assertFailure "should not generate username"

testSFTFederation :: (HasCallStack) => App ()
testSFTFederation = do
  withModifiedBackend
    ( def
        { brigCfg =
            ( setField "sft.sftBaseDomain" "integration-tests.zinfra.io"
                . removeField "multiSFT"
            )
        }
    )
    $ \domain -> do
      user <- randomUser domain def
      bindResponse (getCallsConfigV2 user) \resp -> do
        isFederatingM <- lookupField resp.json "is_federating"
        when (isJust isFederatingM) $ assertFailure "is_federating should not be present"
  withModifiedBackend
    ( def
        { brigCfg =
            ( setField "sft.sftBaseDomain" "integration-tests.zinfra.io"
                . setField "multiSFT" True
            )
        }
    )
    $ \domain -> do
      user <- randomUser domain def
      bindResponse (getCallsConfigV2 user) \resp -> do
        isFederating <-
          maybe (assertFailure "is_federating missing") asBool
            =<< lookupField resp.json "is_federating"
        unless isFederating $ assertFailure "is_federating should be true"
  withModifiedBackend
    ( def
        { brigCfg =
            ( setField "sft.sftBaseDomain" "integration-tests.zinfra.io"
                . setField "multiSFT" False
            )
        }
    )
    $ \domain -> do
      user <- randomUser domain def
      bindResponse (getCallsConfigV2 user) \resp -> do
        isFederating <-
          maybe (assertFailure "is_federating missing") asBool
            =<< lookupField resp.json "is_federating"
        when isFederating $ assertFailure "is_federating should be false"

testDeleteEmail :: (HasCallStack) => App ()
testDeleteEmail = do
  (owner, tid, [usr]) <- createTeam OwnDomain 2
  putSelf usr (PutSelf Nothing Nothing (Just "Alice") Nothing) >>= assertSuccess
  email <- getSelf usr >>= getJSON 200 >>= (%. "email") >>= asString

  let associateUsrWithSSO :: (HasCallStack) => App ()
      associateUsrWithSSO = do
        void $ setTeamFeatureStatus owner tid "sso" "enabled"
        registerTestIdPWithMeta owner >>= assertSuccess
        tok <- createScimTokenV6 owner def >>= getJSON 200 >>= (%. "token") >>= asString
        void $ findUsersByExternalId owner tok email

      searchShouldBe :: (HasCallStack) => String -> App ()
      searchShouldBe expected = do
        BrigI.refreshIndex OwnDomain
        bindResponse (BrigP.searchTeamWithSearchTerm owner email) $ \resp -> do
          resp.status `shouldMatchInt` 200
          numDocs <- length <$> (resp.json %. "documents" >>= asList)
          case expected of
            "empty" -> numDocs `shouldMatchInt` 0
            "non-empty" -> numDocs `shouldMatchInt` 1

  deleteSelfEmail usr >>= assertStatus 403
  searchShouldBe "non-empty"
  associateUsrWithSSO
  deleteSelfEmail usr >>= assertSuccess
  searchShouldBe "empty"
