-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2026 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.Migration.CustomBackend (testCustomBackendMigration) where

import API.Galley
import API.GalleyInternal
import Control.Monad.Codensity
import Control.Monad.Reader
import SetupHelpers
import Test.Migration.Util (waitForMigration)
import Testlib.Prelude
import Testlib.ResourcePool

-- | Drives the custom-backend store through the full cutover lifecycle
-- (cassandra -> migration-to-postgresql -> postgresql). Every phase writes and
-- reads, so all three interpreters (Cassandra, dual-write, Postgres) are
-- exercised on both paths.
--
-- Rows created before the cutover (d1: pure Cassandra writes, d2: dual-write)
-- must be served by the pure-Postgres interpreter afterwards — d1 proves the
-- background worker backfilled a row that only ever existed in Cassandra. The
-- re-put of d1 during the backfill proves the Postgres interpreter upserts
-- (UPDATE-as-insert, like the Cassandra store).
testCustomBackendMigration :: (HasCallStack) => App ()
testCustomBackendMigration :: HasCallStack => App ()
testCustomBackendMigration = do
  resourcePool <- (Env -> ResourcePool BackendResource)
-> App (ResourcePool BackendResource)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.resourcePool)
  runCodensity (acquireResources 1 resourcePool) $ \[BackendResource
backend] -> do
    let domain :: String
domain = BackendResource
backend.berDomain

    -- P1 cassandra: write via the pure Cassandra interpreter
    owner <-
      Codensity App String -> forall b. (String -> App b) -> App b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity (HasCallStack =>
BackendResource -> ServiceOverrides -> Codensity App String
BackendResource -> ServiceOverrides -> Codensity App String
startDynamicBackend BackendResource
backend (String -> Bool -> ServiceOverrides
forall {b} {b}. (ToJSON b, ToJSON b) => b -> b -> ServiceOverrides
conf String
"cassandra" Bool
False)) ((String -> App Value) -> App Value)
-> (String -> App Value) -> App Value
forall a b. (a -> b) -> a -> b
$ \String
_ -> do
        (owner, _, _) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
        putCustomBackend owner d1Domain d1Payload >>= assertStatus 201
        checkCustomBackend owner d1Domain d1ConfigUrl d1WelcomeUrl
        pure owner

    -- P2 migration-to-postgresql (worker off): reads still come from
    -- Cassandra, writes go to both stores
    runCodensity (startDynamicBackend backend (conf "migration-to-postgresql" False)) $ \String
_ -> do
      Value -> String -> String -> String -> App ()
forall {b} {domain} {user} {b}.
(MakesValue b, MakesValue domain, MakesValue user, MakesValue b) =>
user -> domain -> b -> b -> App ()
checkCustomBackend Value
owner String
d1Domain String
d1ConfigUrl String
d1WelcomeUrl
      Value -> String -> Value -> App Response
forall user domain payload.
(HasCallStack, MakesValue user, MakesValue domain,
 MakesValue payload) =>
user -> domain -> payload -> App Response
putCustomBackend Value
owner String
d2Domain Value
d2Payload App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
      Value -> String -> String -> String -> App ()
forall {b} {domain} {user} {b}.
(MakesValue b, MakesValue domain, MakesValue user, MakesValue b) =>
user -> domain -> b -> b -> App ()
checkCustomBackend Value
owner String
d2Domain String
d2ConfigUrl String
d2WelcomeUrl

    -- P3 migration-to-postgresql (worker on): dual-write while backfilling
    runCodensity (startDynamicBackend backend (conf "migration-to-postgresql" True)) $ \String
_ -> do
      Value -> String -> String -> String -> App ()
forall {b} {domain} {user} {b}.
(MakesValue b, MakesValue domain, MakesValue user, MakesValue b) =>
user -> domain -> b -> b -> App ()
checkCustomBackend Value
owner String
d1Domain String
d1ConfigUrl String
d1WelcomeUrl
      Value -> String -> String -> String -> App ()
forall {b} {domain} {user} {b}.
(MakesValue b, MakesValue domain, MakesValue user, MakesValue b) =>
user -> domain -> b -> b -> App ()
checkCustomBackend Value
owner String
d2Domain String
d2ConfigUrl String
d2WelcomeUrl
      Value -> String -> Value -> App Response
forall user domain payload.
(HasCallStack, MakesValue user, MakesValue domain,
 MakesValue payload) =>
user -> domain -> payload -> App Response
putCustomBackend Value
owner String
d3Domain Value
d3Payload App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
      -- Backfill done: dual-write is now the only writer, so the re-put below
      -- proves UPDATE-as-insert without racing the worker's stale copy.
      HasCallStack => String -> String -> App ()
String -> String -> App ()
waitForMigration String
domain String
counterName
      -- UPDATE-as-insert: overwriting d1 must replace its config URL in both
      -- stores.
      Value -> String -> Value -> App Response
forall user domain payload.
(HasCallStack, MakesValue user, MakesValue domain,
 MakesValue payload) =>
user -> domain -> payload -> App Response
putCustomBackend Value
owner String
d1Domain Value
d1Payload' App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
      Value -> String -> String -> String -> App ()
forall {b} {domain} {user} {b}.
(MakesValue b, MakesValue domain, MakesValue user, MakesValue b) =>
user -> domain -> b -> b -> App ()
checkCustomBackend Value
owner String
d1Domain String
d1ConfigUrl' String
d1WelcomeUrl

    -- P4 postgresql: reads are served exclusively from Postgres
    runCodensity (startDynamicBackend backend (conf "postgresql" False)) $ \String
_ -> do
      Value -> String -> String -> String -> App ()
forall {b} {domain} {user} {b}.
(MakesValue b, MakesValue domain, MakesValue user, MakesValue b) =>
user -> domain -> b -> b -> App ()
checkCustomBackend Value
owner String
d1Domain String
d1ConfigUrl' String
d1WelcomeUrl
      Value -> String -> String -> String -> App ()
forall {b} {domain} {user} {b}.
(MakesValue b, MakesValue domain, MakesValue user, MakesValue b) =>
user -> domain -> b -> b -> App ()
checkCustomBackend Value
owner String
d2Domain String
d2ConfigUrl String
d2WelcomeUrl
      Value -> String -> String -> String -> App ()
forall {b} {domain} {user} {b}.
(MakesValue b, MakesValue domain, MakesValue user, MakesValue b) =>
user -> domain -> b -> b -> App ()
checkCustomBackend Value
owner String
d3Domain String
d3ConfigUrl String
d3WelcomeUrl

      -- Write and delete via the pure Postgres interpreter.
      Value -> String -> App Response
forall user domain.
(HasCallStack, MakesValue user, MakesValue domain) =>
user -> domain -> App Response
deleteCustomBackend Value
owner String
d3Domain App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
      Value -> String -> App Response
forall user domain.
(HasCallStack, MakesValue user, MakesValue domain) =>
user -> domain -> App Response
getCustomBackend Value
owner String
d3Domain App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
404
  where
    conf :: b -> b -> ServiceOverrides
conf b
db b
runMigration =
      ServiceOverrides
forall a. Default a => a
def
        { galleyCfg = setField "postgresMigration.customBackend" db,
          backgroundWorkerCfg = setField "migrateCustomBackend" runMigration
        }
    counterName :: String
counterName = String
"^wire_custom_backend_migration_finished"

    d1Domain :: String
d1Domain = String
"example.com"
    d1ConfigUrl :: String
d1ConfigUrl = String
"https://example.com/config.json"
    d1ConfigUrl' :: String
d1ConfigUrl' = String
"https://example.com/config-v2.json"
    d1WelcomeUrl :: String
d1WelcomeUrl = String
"https://example.com/welcome"
    d1Payload :: Value
d1Payload =
      [Pair] -> Value
object
        [ String
"config_json_url" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
d1ConfigUrl,
          String
"webapp_welcome_url" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
d1WelcomeUrl
        ]
    d1Payload' :: Value
d1Payload' =
      [Pair] -> Value
object
        [ String
"config_json_url" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
d1ConfigUrl',
          String
"webapp_welcome_url" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
d1WelcomeUrl
        ]

    d2Domain :: String
d2Domain = String
"example.org"
    d2ConfigUrl :: String
d2ConfigUrl = String
"https://example.org/config.json"
    d2WelcomeUrl :: String
d2WelcomeUrl = String
"https://example.org/welcome"
    d2Payload :: Value
d2Payload =
      [Pair] -> Value
object
        [ String
"config_json_url" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
d2ConfigUrl,
          String
"webapp_welcome_url" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
d2WelcomeUrl
        ]

    d3Domain :: String
d3Domain = String
"example.net"
    d3ConfigUrl :: String
d3ConfigUrl = String
"https://example.net/config.json"
    d3WelcomeUrl :: String
d3WelcomeUrl = String
"https://example.net/welcome"
    d3Payload :: Value
d3Payload =
      [Pair] -> Value
object
        [ String
"config_json_url" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
d3ConfigUrl,
          String
"webapp_welcome_url" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
d3WelcomeUrl
        ]

    checkCustomBackend :: user -> domain -> b -> b -> App ()
checkCustomBackend user
user domain
dom b
configUrl b
welcomeUrl =
      App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (user -> domain -> App Response
forall user domain.
(HasCallStack, MakesValue user, MakesValue domain) =>
user -> domain -> App Response
getCustomBackend user
user domain
dom) ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
        Response
resp.json Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"config_json_url" App Value -> b -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` b
configUrl
        Response
resp.json Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"webapp_welcome_url" App Value -> b -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` b
welcomeUrl