{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

-- 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.User where

import API.Brig
import API.BrigInternal as I
import API.Common
import API.GalleyInternal
import qualified API.Spar as Spar
import Control.Monad.Codensity
import Control.Monad.Reader
import qualified Data.Aeson as Aeson
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import SetupHelpers
import Testlib.Prelude
import Testlib.ResourcePool
import Testlib.VersionedFed

testSupportedProtocols :: (HasCallStack) => OneOf Domain (FedDomain 1) -> App ()
testSupportedProtocols :: HasCallStack => OneOf Domain (FedDomain 1) -> App ()
testSupportedProtocols OneOf Domain (FedDomain 1)
bobDomain = do
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  alice %. "supported_protocols" `shouldMatchSet` ["proteus"]

  bob <- randomUser bobDomain def

  do
    -- bob sees default supported protocols for alice
    u <- getUser bob alice >>= getJSON 200
    u %. "supported_protocols" `shouldMatch` ["proteus"]

    p <- getUserSupportedProtocols bob alice >>= getJSON 200
    p `shouldMatch` ["proteus"]

  -- alice updates her supported protocols
  bindResponse (putUserSupportedProtocols alice ["proteus", "mls"]) $ \Response
resp ->
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

  do
    -- bob sees the updated list
    u <- getUser bob alice >>= getJSON 200
    u %. "supported_protocols" `shouldMatchSet` ["proteus", "mls"]

    p <- getUserSupportedProtocols bob alice >>= getJSON 200
    p `shouldMatch` ["proteus", "mls"]

  -- invalid protocol name in update
  bindResponse (putUserSupportedProtocols alice ["proteus", "mls", "mixed"]) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"bad-request"

testCreateUserSupportedProtocols :: (HasCallStack) => App ()
testCreateUserSupportedProtocols :: HasCallStack => App ()
testCreateUserSupportedProtocols = do
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def {supportedProtocols = Just ["proteus", "mls"]}
  bindResponse (getUserSupportedProtocols alice alice) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> [String] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatchSet` [String
"proteus", String
"mls"]

  bindResponse (createUser OwnDomain def {supportedProtocols = Just ["proteus", "mixed"]}) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"bad-request"

testRemoveMlsSupportShouldFail :: (HasCallStack) => App ()
testRemoveMlsSupportShouldFail :: HasCallStack => App ()
testRemoveMlsSupportShouldFail = do
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def {supportedProtocols = Just ["proteus", "mls"]}
  bindResponse (getUserSupportedProtocols alice alice) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> [String] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatchSet` [String
"proteus", String
"mls"]

  putUserSupportedProtocols alice ["proteus"] `bindResponse` \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
409
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-protocol-error"

  bindResponse (getUserSupportedProtocols alice alice) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> [String] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatchSet` [String
"proteus", String
"mls"]

-- | For now this only tests attempts to update /self/handle in E2EId-enabled teams.  More
-- tests can be found under `/services/brig/test/integration` (and should be moved here).
testUpdateHandle :: (HasCallStack) => App ()
testUpdateHandle :: HasCallStack => App ()
testUpdateHandle = do
  -- create team with one member, without scim, but with `mlsE2EId` enabled.
  (owner, team, [mem1]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  mem1id <- asString $ mem1 %. "id"

  let featureName = String
"mlsE2EId"
  bindResponse (getTeamFeature owner team featureName) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"disabled"
  assertSuccess =<< setTeamFeatureStatus owner team featureName "enabled"
  bindResponse (getTeamFeature owner team featureName) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"enabled"

  -- all as expected here.  (see the second time we check this at the end of the test for an
  -- explanation why we care.)
  bindResponse (getSelf mem1) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"managed_by" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"wire"
  bindResponse (getUsersId owner [mem1id]) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    mb <- ([Value] -> App Value
forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne ([Value] -> App Value) -> App [Value] -> App Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList Response
resp.json) App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"managed_by"
    mb `shouldMatch` "wire"

  -- mem1 attempts to update handle for the first time => success
  --
  -- this is desired, because without SCIM users need to pick their own handles initially.
  -- moreover it is fine, because if `handle == NULL`, no mls E2Eid client certs can be
  -- created.
  handle <- UUID.toString <$> liftIO UUID.nextRandom
  bindResponse (putHandle mem1 handle) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
  bindResponse (putHandle mem1 handle) $ \Response
resp -> do
    -- idempotency
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

  -- mem1 attempts to update handle again => failure
  handle2 <- UUID.toString <$> liftIO UUID.nextRandom
  bindResponse (putHandle mem1 handle2) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"managed-by-scim"

  -- now self thinks it is managed by "scim", so clients can block change attempts to handle,
  -- display name without adding E2EId-specific logic.  this is just a hack, though: `GET
  -- /self` is the only place where this is happening, other end-points still report the truth
  -- that is still stored correctly in the DB.
  --
  -- details: https://wearezeta.atlassian.net/browse/WPB-6189.
  -- FUTUREWORK: figure out a better way for clients to detect E2EId (V6?)
  bindResponse (getSelf mem1) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"managed_by" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"scim"
  bindResponse (getUsersId owner [mem1id]) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    mb <- ([Value] -> App Value
forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne ([Value] -> App Value) -> App [Value] -> App Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList Response
resp.json) App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"managed_by"
    mb `shouldMatch` "wire"
  bindResponse (Spar.getScimTokens owner) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"tokens" App Value -> [String] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` ([] @String)

-- | For now this only tests attempts to update one's own display name, email address, or
-- language in E2EId-enabled teams (ie., everything except handle).  More tests can be found
-- under `/services/brig/test/integration` (and should be moved here).
testUpdateSelf :: (HasCallStack) => Tagged "mode" TestUpdateSelfMode -> App ()
testUpdateSelf :: HasCallStack => Tagged "mode" TestUpdateSelfMode -> App ()
testUpdateSelf (MkTagged TestUpdateSelfMode
mode) = do
  -- create team with one member, without scim, but with `mlsE2EId` enabled.
  (owner, team, [mem1]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2

  let featureName = String
"mlsE2EId"
  bindResponse (getTeamFeature owner team featureName) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"disabled"
  assertSuccess =<< setTeamFeatureStatus owner team featureName "enabled"
  bindResponse (getTeamFeature owner team featureName) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"enabled"

  case mode of
    TestUpdateSelfMode
TestUpdateDisplayName -> do
      -- blocked unconditionally
      someDisplayName <- UUID -> String
UUID.toString (UUID -> String) -> App UUID -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID -> App UUID
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
UUID.nextRandom
      before <- getSelf mem1
      bindResponse (putSelf mem1 def {name = Just someDisplayName}) $ \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
        Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"managed-by-scim"
      after <- getSelf mem1
      void $ (before.json %. "name") `shouldMatch` (after.json %. "name")
    TestUpdateSelfMode
TestUpdateEmailAddress -> do
      -- allowed unconditionally *for owner* (this is a bit off-topic: team members can't
      -- change their email addresses themselves under any conditions)
      someEmail <- (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"@example.com") (String -> String) -> (UUID -> String) -> UUID -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> String
UUID.toString (UUID -> String) -> App UUID -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID -> App UUID
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
UUID.nextRandom
      bindResponse (putUserEmail owner owner someEmail) $ \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    TestUpdateSelfMode
TestUpdateLocale -> do
      -- scim maps "User.preferredLanguage" to brig's locale field.  allowed unconditionally.
      -- we try two languages to make sure it doesn't work because it's already the active
      -- locale.
      [String] -> (String -> App ()) -> App ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String
"uk", String
"he"] ((String -> App ()) -> App ()) -> (String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
someLocale ->
        App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (Value -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> App Response
putSelfLocale Value
mem1 String
someLocale) ((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

data TestUpdateSelfMode
  = TestUpdateDisplayName
  | TestUpdateEmailAddress
  | TestUpdateLocale
  deriving (TestUpdateSelfMode -> TestUpdateSelfMode -> Bool
(TestUpdateSelfMode -> TestUpdateSelfMode -> Bool)
-> (TestUpdateSelfMode -> TestUpdateSelfMode -> Bool)
-> Eq TestUpdateSelfMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestUpdateSelfMode -> TestUpdateSelfMode -> Bool
== :: TestUpdateSelfMode -> TestUpdateSelfMode -> Bool
$c/= :: TestUpdateSelfMode -> TestUpdateSelfMode -> Bool
/= :: TestUpdateSelfMode -> TestUpdateSelfMode -> Bool
Eq, Int -> TestUpdateSelfMode -> String -> String
[TestUpdateSelfMode] -> String -> String
TestUpdateSelfMode -> String
(Int -> TestUpdateSelfMode -> String -> String)
-> (TestUpdateSelfMode -> String)
-> ([TestUpdateSelfMode] -> String -> String)
-> Show TestUpdateSelfMode
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestUpdateSelfMode -> String -> String
showsPrec :: Int -> TestUpdateSelfMode -> String -> String
$cshow :: TestUpdateSelfMode -> String
show :: TestUpdateSelfMode -> String
$cshowList :: [TestUpdateSelfMode] -> String -> String
showList :: [TestUpdateSelfMode] -> String -> String
Show, (forall x. TestUpdateSelfMode -> Rep TestUpdateSelfMode x)
-> (forall x. Rep TestUpdateSelfMode x -> TestUpdateSelfMode)
-> Generic TestUpdateSelfMode
forall x. Rep TestUpdateSelfMode x -> TestUpdateSelfMode
forall x. TestUpdateSelfMode -> Rep TestUpdateSelfMode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestUpdateSelfMode -> Rep TestUpdateSelfMode x
from :: forall x. TestUpdateSelfMode -> Rep TestUpdateSelfMode x
$cto :: forall x. Rep TestUpdateSelfMode x -> TestUpdateSelfMode
to :: forall x. Rep TestUpdateSelfMode x -> TestUpdateSelfMode
Generic)

testActivateAccountWithPhoneV5 :: (HasCallStack) => App ()
testActivateAccountWithPhoneV5 :: HasCallStack => App ()
testActivateAccountWithPhoneV5 = do
  let dom :: Domain
dom = Domain
OwnDomain
  let phone :: String
phone = String
"+4912345678"
  let reqBody :: Value
reqBody = [Pair] -> Value
Aeson.object [String
"phone" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
phone]
  Domain -> Value -> App Response
forall user target.
(HasCallStack, MakesValue user, MakesValue target) =>
user -> target -> App Response
activateUserV5 Domain
dom Value
reqBody App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"bad-request"

testMigratingPasswordHashingAlgorithm :: (HasCallStack) => App ()
testMigratingPasswordHashingAlgorithm :: HasCallStack => App ()
testMigratingPasswordHashingAlgorithm = do
  let argon2idOpts :: Value
argon2idOpts =
        [Pair] -> Value
object
          [ String
"algorithm" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"argon2id",
            String
"iterations" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
1 :: Int),
            String
"memory" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
128 :: Int),
            String
"parallelism" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
1 :: Int)
          ]
      cfgArgon2id :: ServiceOverrides
cfgArgon2id =
        ServiceOverrides
forall a. Default a => a
def
          { brigCfg =
              setField "settings.setPasswordHashingOptions" argon2idOpts
                >=> removeField "optSettings.setSuspendInactiveUsers",
            galleyCfg = setField "settings.passwordHashingOptions" argon2idOpts
          }
      cfgScrypt :: ServiceOverrides
cfgScrypt =
        ServiceOverrides
forall a. Default a => a
def
          { brigCfg =
              setField "settings.setPasswordHashingOptions.algorithm" "scrypt"
                >=> removeField "optSettings.setSuspendInactiveUsers",
            galleyCfg = setField "settings.passwordHashingOptions.algorithm" "scrypt"
          }
  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
testBackend] -> do
    let domain :: String
domain = BackendResource
testBackend.berDomain
    email1 <- App String
randomEmail
    password1 <- randomString 20

    email2 <- randomEmail
    password2 <- randomString 20

    runCodensity (startDynamicBackend testBackend cfgScrypt) $ \String
_ -> do
      App Value -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Value -> App ()) -> App Value -> App ()
forall a b. (a -> b) -> a -> b
$ String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain (CreateUser
forall a. Default a => a
def {email = Just email1, password = Just password1})
      String -> String -> String -> App Response
forall domain_.
(HasCallStack, MakesValue domain_) =>
domain_ -> String -> String -> App Response
login String
domain String
email1 String
password1 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 => Response -> App ()
Response -> App ()
assertSuccess

    runCodensity (startDynamicBackend testBackend cfgArgon2id) $ \String
_ -> do
      String -> String -> String -> App Response
forall domain_.
(HasCallStack, MakesValue domain_) =>
domain_ -> String -> String -> App Response
login String
domain String
email1 String
password1 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 => Response -> App ()
Response -> App ()
assertSuccess

      -- Create second user to ensure that we're testing migrating back. This is
      -- not really needed because the login above rehashes the password, but it
      -- makes the test clearer.
      App Value -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Value -> App ()) -> App Value -> App ()
forall a b. (a -> b) -> a -> b
$ String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain (CreateUser
forall a. Default a => a
def {email = Just email2, password = Just password2})
      String -> String -> String -> App Response
forall domain_.
(HasCallStack, MakesValue domain_) =>
domain_ -> String -> String -> App Response
login String
domain String
email2 String
password2 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 => Response -> App ()
Response -> App ()
assertSuccess

    -- Check that both users can still login with Scrypt in case the operator
    -- wants to rollback the config.
    runCodensity (startDynamicBackend testBackend cfgScrypt) $ \String
_ -> do
      String -> String -> String -> App Response
forall domain_.
(HasCallStack, MakesValue domain_) =>
domain_ -> String -> String -> App Response
login String
domain String
email1 String
password1 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 => Response -> App ()
Response -> App ()
assertSuccess
      String -> String -> String -> App Response
forall domain_.
(HasCallStack, MakesValue domain_) =>
domain_ -> String -> String -> App Response
login String
domain String
email2 String
password2 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 => Response -> App ()
Response -> App ()
assertSuccess

testUpdateEmailForEmailDomainForAnotherBackend :: (HasCallStack) => App ()
testUpdateEmailForEmailDomainForAnotherBackend :: HasCallStack => App ()
testUpdateEmailForEmailDomainForAnotherBackend = [Versioned] -> (Versioned -> App ()) -> App ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int -> Versioned
ExplicitVersion Int
8, Versioned
Versioned] \Versioned
version -> do
  emailDomain <- App String
randomDomain
  user <- randomUser OwnDomain def
  email <- user %. "email" & asString
  (cookie, token) <- bindResponse (login user email defPassword) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    token <- Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"access_token" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
    let cookie = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Response -> Maybe String
getCookie String
"zuid" Response
resp
    pure ("zuid=" <> cookie, token)

  I.domainRegistrationPreAuthorize OwnDomain emailDomain >>= assertStatus 204
  setup <- setupOwnershipTokenForBackend OwnDomain emailDomain
  updateDomainRedirect
    OwnDomain
    version
    emailDomain
    (Just setup.ownershipToken)
    (mkDomainRedirectBackend version "https://example.com" "https://webapp.example.com")
    >>= assertStatus 200

  let newEmail = String
"galadriel@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
emailDomain
  updateEmail user newEmail cookie token `bindResponse` \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"condition-failed"

  bindResponse (getActivationCode user newEmail) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
404
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"not-found"

  bindResponse (getSelf user) $ \Response
resp -> do
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"email" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
email

testActivateEmailForEmailDomainForAnotherBackend :: (HasCallStack) => App ()
testActivateEmailForEmailDomainForAnotherBackend :: HasCallStack => App ()
testActivateEmailForEmailDomainForAnotherBackend = do
  tid <- App String
HasCallStack => App String
randomId
  sso <- randomId
  object
    [ "domain_redirect" .= "backend",
      "backend"
        .= object
          [ "config_url" .= "https://example.com",
            "webapp_url" .= "https://webapp.example.com"
          ],
      "team_invite"
        .= "not-allowed"
    ]
    & testActivateEmailShouldBeAllowed False
  object
    [ "domain_redirect" .= "none",
      "team_invite" .= "allowed"
    ]
    & testActivateEmailShouldBeAllowed True
  object
    [ "domain_redirect" .= "no-registration",
      "team_invite" .= "team",
      "team" .= tid
    ]
    & testActivateEmailShouldBeAllowed False
  object
    [ "domain_redirect" .= "no-registration",
      "team_invite" .= "not-allowed"
    ]
    & testActivateEmailShouldBeAllowed False
  object
    [ "domain_redirect" .= "sso",
      "sso_code" .= sso,
      "team_invite" .= "not-allowed"
    ]
    & testActivateEmailShouldBeAllowed False
  object
    [ "domain_redirect" .= "sso",
      "sso_code" .= sso,
      "team_invite" .= "team",
      "team" .= tid
    ]
    & testActivateEmailShouldBeAllowed False
  where
    testActivateEmailShouldBeAllowed :: (HasCallStack) => Bool -> Value -> App ()
    testActivateEmailShouldBeAllowed :: HasCallStack => Bool -> Value -> App ()
testActivateEmailShouldBeAllowed Bool
activateAllowed Value
update = do
      emailDomain <- App String
randomDomain
      user <- randomUser OwnDomain def
      email <- user %. "email" & asString
      (cookie, token) <- bindResponse (login user email defPassword) $ \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
        token <- Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"access_token" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
        let cookie = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Response -> Maybe String
getCookie String
"zuid" Response
resp
        pure ("zuid=" <> cookie, token)

      let newEmail = String
"galadriel@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
emailDomain
      updateEmail user newEmail cookie token >>= assertSuccess

      (key, code) <- bindResponse (getActivationCode user newEmail) $ \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
        (,)
          (String -> String -> (String, String))
-> App String -> App (String -> (String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString)
          App (String -> (String, String))
-> App String -> App (String, String)
forall a b. App (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"code" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString)

      I.updateDomainRegistration OwnDomain emailDomain update >>= assertSuccess

      if activateAllowed
        then do
          API.Brig.activate user key code >>= assertSuccess
          getSelf user `bindResponse` \Response
resp -> do
            Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"email" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
newEmail
        else do
          API.Brig.activate user key code `bindResponse` \Response
resp -> do
            Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
            Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"condition-failed"

          getSelf user `bindResponse` \Response
resp -> do
            Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"email" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
email

testPasswordChange :: (HasCallStack) => App ()
testPasswordChange :: HasCallStack => App ()
testPasswordChange =
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend
    ServiceOverrides
forall a. Default a => a
def
      { brigCfg =
          -- Disable password hashing rate limiting, so we can create enable services quickly
          setField @_ @Int "optSettings.setPasswordHashingRateLimit.userLimit.inverseRate" 0
      }
    ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
      user <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain CreateUser
forall a. Default a => a
def
      email <- asString $ user %. "email"
      newPassword <- randomString 20

      putPassword user defPassword defPassword `bindResponse` \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
409
        Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"password-must-differ"

      putPassword user defPassword newPassword >>= assertSuccess

      login domain email defPassword `bindResponse` \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
        Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"invalid-credentials"
      login domain email newPassword >>= assertSuccess

testEphemeralUserCreation :: (HasCallStack) => TaggedBool "ephemeral-user-creation-enabled" -> App ()
testEphemeralUserCreation :: HasCallStack =>
TaggedBool "ephemeral-user-creation-enabled" -> App ()
testEphemeralUserCreation (TaggedBool Bool
enabled) = do
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend
    ServiceOverrides
forall a. Default a => a
def
      { brigCfg = setField "optSettings.setEphemeralUserCreationEnabled" enabled
      }
    ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
      String -> App Response
forall {dom}. MakesValue dom => dom -> App Response
registerEphemeralUser String
domain App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
        if Bool
enabled
          then do
            Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
          else do
            Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
            Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"ephemeral-user-creation-disabled"

        String -> App Response
registerUserWithEmail String
domain 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 => Response -> App ()
Response -> App ()
assertSuccess
  where
    registerEphemeralUser :: dom -> App Response
registerEphemeralUser dom
domain = dom -> AddUser -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> AddUser -> App Response
addUser dom
domain AddUser
forall a. Default a => a
def
    registerUserWithEmail :: String -> App Response
registerUserWithEmail String
domain = String -> AddUser -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> AddUser -> App Response
addUser String
domain AddUser
forall a. Default a => a
def {email = Just ("user@" <> domain)}