-- 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 Testlib.VersionedFed where

import Control.Monad.Reader
import Data.Proxy
import qualified Data.Text as T
import GHC.TypeLits
import System.Environment
import Testlib.PTest
import Testlib.Prelude

data FedDomain n = FedDomain

instance MakesValue (FedDomain 0) where
  make :: HasCallStack => FedDomain 0 -> App Value
make FedDomain 0
FedDomain = (Env -> Value) -> App Value
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Value
String (Text -> Value) -> (Env -> Text) -> Env -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Env -> String) -> Env -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.federationV0Domain))

instance MakesValue (FedDomain 1) where
  make :: HasCallStack => FedDomain 1 -> App Value
make FedDomain 1
FedDomain = (Env -> Value) -> App Value
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Value
String (Text -> Value) -> (Env -> Text) -> Env -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Env -> String) -> Env -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.federationV1Domain))

instance MakesValue (FedDomain 2) where
  make :: HasCallStack => FedDomain 2 -> App Value
make FedDomain 2
FedDomain = (Env -> Value) -> App Value
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Value
String (Text -> Value) -> (Env -> Text) -> Env -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Env -> String) -> Env -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.federationV2Domain))

instance MakesValue (FedDomain 3) where
  make :: HasCallStack => FedDomain 3 -> App Value
make FedDomain 3
FedDomain = (Env -> Value) -> App Value
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Value
String (Text -> Value) -> (Env -> Text) -> Env -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Env -> String) -> Env -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.federationV3Domain))

instance (KnownNat n) => TestCases (FedDomain n) where
  mkTestCases :: IO [TestCase (FedDomain n)]
mkTestCases =
    let v :: Integer
v = Proxy n -> Integer
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n)
     in (TestCase Integer -> TestCase (FedDomain n))
-> [TestCase Integer] -> [TestCase (FedDomain n)]
forall a b. (a -> b) -> [a] -> [b]
map ((Integer -> FedDomain n)
-> TestCase Integer -> TestCase (FedDomain n)
forall a b. (a -> b) -> TestCase a -> TestCase b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FedDomain n -> Integer -> FedDomain n
forall a b. a -> b -> a
const FedDomain n
forall {k} (n :: k). FedDomain n
FedDomain))
          ([TestCase Integer] -> [TestCase (FedDomain n)])
-> IO [TestCase Integer] -> IO [TestCase (FedDomain n)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Integer -> IO [TestCase Integer]
mkFedTestCase (String
"[domain=fed-v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
v String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]") Integer
v

mkFedTestCase :: String -> Integer -> IO [TestCase Integer]
mkFedTestCase :: String -> Integer -> IO [TestCase Integer]
mkFedTestCase String
name Integer
n = do
  v <- String -> IO (Maybe String)
lookupEnv (String -> IO (Maybe String)) -> String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String
"ENABLE_FEDERATION_V" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
n
  if v == Just "1"
    then pure [MkTestCase name n]
    else pure []

data AnyFedDomain = AnyFedDomain {AnyFedDomain -> Integer
unFedDomain :: Integer}

data FedVersion
  = FedVersionLegacy Integer
  | FedVersionCurrentStable
  | FedVersionCurrentDevelopment
  deriving (FedVersion -> FedVersion -> Bool
(FedVersion -> FedVersion -> Bool)
-> (FedVersion -> FedVersion -> Bool) -> Eq FedVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FedVersion -> FedVersion -> Bool
== :: FedVersion -> FedVersion -> Bool
$c/= :: FedVersion -> FedVersion -> Bool
/= :: FedVersion -> FedVersion -> Bool
Eq, Int -> FedVersion -> String -> String
[FedVersion] -> String -> String
FedVersion -> String
(Int -> FedVersion -> String -> String)
-> (FedVersion -> String)
-> ([FedVersion] -> String -> String)
-> Show FedVersion
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FedVersion -> String -> String
showsPrec :: Int -> FedVersion -> String -> String
$cshow :: FedVersion -> String
show :: FedVersion -> String
$cshowList :: [FedVersion] -> String -> String
showList :: [FedVersion] -> String -> String
Show)

fedVersionName :: FedVersion -> String
fedVersionName :: FedVersion -> String
fedVersionName (FedVersionLegacy Integer
version) = String
"fed-v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
version
fedVersionName FedVersion
FedVersionCurrentStable = String
"current-stable"
fedVersionName FedVersion
FedVersionCurrentDevelopment = String
"current-dev"

-- | Pairs of distinct enabled legacy/current backends
data FedVersionPair = FedVersionPair
  { FedVersionPair -> FedVersion
localFedVersion :: FedVersion,
    FedVersionPair -> FedVersion
remoteFedVersion :: FedVersion
  }

instance TestCases FedVersionPair where
  mkTestCases :: IO [TestCase FedVersionPair]
mkTestCases = do
    legacyCases <- forall a. TestCases a => IO [TestCase a]
mkTestCases @AnyFedDomain
    -- The pinned v0 worker requires explicit remote-domain registration, which
    -- does not cover the dynamic backends used by these cross-version tests.
    let legacyVersions = [Integer -> FedVersion
FedVersionLegacy Integer
version | MkTestCase String
_ (AnyFedDomain Integer
version) <- [TestCase AnyFedDomain]
legacyCases, Integer
version Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0]
        versions = [FedVersion]
legacyVersions [FedVersion] -> [FedVersion] -> [FedVersion]
forall a. Semigroup a => a -> a -> a
<> [FedVersion
FedVersionCurrentStable, FedVersion
FedVersionCurrentDevelopment]
    pure
      [ MkTestCase
          ( "[local="
              <> fedVersionName localVersion
              <> "][remote="
              <> fedVersionName remoteVersion
              <> "]"
          )
          (FedVersionPair localVersion remoteVersion)
      | localVersion <- versions,
        remoteVersion <- versions,
        localVersion /= remoteVersion
      ]

instance MakesValue AnyFedDomain where
  make :: HasCallStack => AnyFedDomain -> App Value
make (AnyFedDomain Integer
0) = (Env -> Value) -> App Value
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Value
String (Text -> Value) -> (Env -> Text) -> Env -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Env -> String) -> Env -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.federationV0Domain))
  make (AnyFedDomain Integer
1) = (Env -> Value) -> App Value
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Value
String (Text -> Value) -> (Env -> Text) -> Env -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Env -> String) -> Env -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.federationV1Domain))
  make (AnyFedDomain Integer
2) = (Env -> Value) -> App Value
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Value
String (Text -> Value) -> (Env -> Text) -> Env -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Env -> String) -> Env -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.federationV2Domain))
  make (AnyFedDomain Integer
3) = (Env -> Value) -> App Value
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Value
String (Text -> Value) -> (Env -> Text) -> Env -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Env -> String) -> Env -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.federationV3Domain))
  make (AnyFedDomain Integer
_) = String -> App Value
forall a. HasCallStack => String -> a
error String
"invalid federation version"

instance TestCases AnyFedDomain where
  mkTestCases :: IO [TestCase AnyFedDomain]
mkTestCases =
    (TestCase Integer -> TestCase AnyFedDomain)
-> [TestCase Integer] -> [TestCase AnyFedDomain]
forall a b. (a -> b) -> [a] -> [b]
map ((Integer -> AnyFedDomain)
-> TestCase Integer -> TestCase AnyFedDomain
forall a b. (a -> b) -> TestCase a -> TestCase b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> AnyFedDomain
AnyFedDomain)
      ([TestCase Integer] -> [TestCase AnyFedDomain])
-> ([[TestCase Integer]] -> [TestCase Integer])
-> [[TestCase Integer]]
-> [TestCase AnyFedDomain]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TestCase Integer]] -> [TestCase Integer]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      ([[TestCase Integer]] -> [TestCase AnyFedDomain])
-> IO [[TestCase Integer]] -> IO [TestCase AnyFedDomain]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, Integer) -> IO [TestCase Integer])
-> [(String, Integer)] -> IO [[TestCase Integer]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
        ((String -> Integer -> IO [TestCase Integer])
-> (String, Integer) -> IO [TestCase Integer]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Integer -> IO [TestCase Integer]
mkFedTestCase)
        [(String
"[domain=fed-v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
v String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]", Integer
v) | Integer
v <- [Integer
0, Integer
1, Integer
2, Integer
3]]

-- | This can be used as an argument for parametrised tests. It will be bound
-- to at least 'OtherDomain', and optionally to legacy federated domains,
-- according to the values of the corresponding environment variables
-- (@ENABLE_FEDERATION_V0@ and similar).
data StaticDomain = StaticDomain | StaticFedDomain Integer
  deriving (StaticDomain -> StaticDomain -> Bool
(StaticDomain -> StaticDomain -> Bool)
-> (StaticDomain -> StaticDomain -> Bool) -> Eq StaticDomain
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StaticDomain -> StaticDomain -> Bool
== :: StaticDomain -> StaticDomain -> Bool
$c/= :: StaticDomain -> StaticDomain -> Bool
/= :: StaticDomain -> StaticDomain -> Bool
Eq)

instance MakesValue StaticDomain where
  make :: HasCallStack => StaticDomain -> App Value
make StaticDomain
StaticDomain = Domain -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make Domain
OtherDomain
  make (StaticFedDomain Integer
n) = AnyFedDomain -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make (Integer -> AnyFedDomain
AnyFedDomain Integer
n)

instance TestCases StaticDomain where
  mkTestCases :: IO [TestCase StaticDomain]
mkTestCases = do
    feds <-
      (TestCase Integer -> TestCase StaticDomain)
-> [TestCase Integer] -> [TestCase StaticDomain]
forall a b. (a -> b) -> [a] -> [b]
map ((Integer -> StaticDomain)
-> TestCase Integer -> TestCase StaticDomain
forall a b. (a -> b) -> TestCase a -> TestCase b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> StaticDomain
StaticFedDomain)
        ([TestCase Integer] -> [TestCase StaticDomain])
-> ([[TestCase Integer]] -> [TestCase Integer])
-> [[TestCase Integer]]
-> [TestCase StaticDomain]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TestCase Integer]] -> [TestCase Integer]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        ([[TestCase Integer]] -> [TestCase StaticDomain])
-> IO [[TestCase Integer]] -> IO [TestCase StaticDomain]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, Integer) -> IO [TestCase Integer])
-> [(String, Integer)] -> IO [[TestCase Integer]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
          ((String -> Integer -> IO [TestCase Integer])
-> (String, Integer) -> IO [TestCase Integer]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Integer -> IO [TestCase Integer]
mkFedTestCase)
          [(String
"[domain=fed-v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
v String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]", Integer
v) | Integer
v <- [Integer
0, Integer
1, Integer
2, Integer
3]]
    pure $ [MkTestCase "[domain=other]" StaticDomain] <> feds