{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -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 SetupHelpers where

import API.Brig
import API.BrigInternal
import API.Cargohold
import API.Common
import API.Galley
import API.Spar
import Control.Monad.Reader
import Crypto.Random (getRandomBytes)
import Data.Aeson hiding ((.=))
import qualified Data.Aeson.Types as Aeson
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Base64.Lazy as EL
import qualified Data.ByteString.Base64.URL as B64Url
import Data.ByteString.Char8 (unpack)
import qualified Data.CaseInsensitive as CI
import Data.Default
import Data.Function
import Data.String.Conversions (cs)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8)
import qualified Data.UUID as UUID
import Data.UUID.V1 (nextUUID)
import Data.UUID.V4 (nextRandom)
import Data.Vector (fromList)
import GHC.Stack
import qualified SAML2.WebSSO as SAML
import qualified SAML2.WebSSO.API.Example as SAML
import qualified SAML2.WebSSO.Test.MockResponse as SAML
import SAML2.WebSSO.Test.Util (SampleIdP (..), makeSampleIdPMetadata)
import System.Random (randomRIO)
import Test.DNSMock
import Testlib.JSON
import Testlib.Prelude
import Testlib.Printing (indent)
import Text.Regex.TDFA ((=~))
import qualified Text.XML as XML
import qualified Text.XML.Cursor as XML
import qualified Text.XML.DSig as SAML
import UnliftIO (pooledForConcurrentlyN)

randomUser :: (HasCallStack, MakesValue domain) => domain -> CreateUser -> App Value
randomUser :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser domain
domain CreateUser
cu = App Response -> (Response -> App Value) -> App Value
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (domain -> CreateUser -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Response
createUser domain
domain CreateUser
cu) ((Response -> App Value) -> App Value)
-> (Response -> App Value) -> App Value
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
201
  Response
resp.json

ephemeralUser :: (HasCallStack, MakesValue domain) => domain -> App Value
ephemeralUser :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> App Value
ephemeralUser domain
domain = do
  name <- App String
randomName
  req <- baseRequest domain Brig Versioned "/register"
  bindResponse (submit "POST" $ req & addJSONObject ["name" .= name] & addHeader "X-Forwarded-For" "127.0.0.42") $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
    Response
resp.json

deleteUser :: (HasCallStack, MakesValue user) => user -> App ()
deleteUser :: forall user. (HasCallStack, MakesValue user) => user -> App ()
deleteUser user
user = App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (user -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> App Response
API.Brig.deleteUser user
user) ((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

-- | returns (owner, team id, members)
createTeam :: (HasCallStack, MakesValue domain) => domain -> Int -> App (Value, String, [Value])
createTeam :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam domain
domain Int
memberCount = domain -> String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> String -> Int -> App (Value, String, [Value])
createTeamWithEmailDomain domain
domain String
"example.com" Int
memberCount

createTeamWithEmailDomain :: (HasCallStack, MakesValue domain) => domain -> String -> Int -> App (Value, String, [Value])
createTeamWithEmailDomain :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> String -> Int -> App (Value, String, [Value])
createTeamWithEmailDomain domain
domain String
emailDomain Int
memberCount = do
  ownerEmail <- App String
randomName App String -> (String -> String) -> App String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
emailDomain)
  owner <- createUser domain def {team = True, email = Just ownerEmail} >>= getJSON 201
  tid <- owner %. "team" & asString
  members <- pooledForConcurrentlyN 64 [2 .. memberCount] $ \Int
_ -> do
    email <- App String
randomName App String -> (String -> String) -> App String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
emailDomain)
    createTeamMember owner def {email = Just email}
  pure (owner, tid, members)

data CreateTeamMember = CreateTeamMember
  { CreateTeamMember -> String
role :: String,
    CreateTeamMember -> Maybe String
email :: Maybe String
  }

instance Default CreateTeamMember where
  def :: CreateTeamMember
def = CreateTeamMember {role :: String
role = String
"member", email :: Maybe String
email = Maybe String
forall a. Maybe a
Nothing}

createTeamMember ::
  (HasCallStack, MakesValue inviter) =>
  inviter ->
  CreateTeamMember ->
  App Value
createTeamMember :: forall inviter.
(HasCallStack, MakesValue inviter) =>
inviter -> CreateTeamMember -> App Value
createTeamMember inviter
inviter CreateTeamMember
args = do
  newUserEmail <- App String -> (String -> App String) -> Maybe String -> App String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe App String
randomEmail String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CreateTeamMember
args.email
  invitation <-
    postInvitation
      inviter
      def
        { email = Just newUserEmail,
          role = Just args.role
        }
      >>= getJSON 201
  invitationCode <-
    (getInvitationCode inviter invitation >>= getJSON 200)
      %. "code"
      & asString
  let body =
        AddUser
forall a. Default a => a
def
          { name = Just newUserEmail,
            email = Just newUserEmail,
            password = Just defPassword,
            teamCode = Just invitationCode
          }
  addUser inviter body >>= getJSON 201

connectTwoUsers ::
  ( HasCallStack,
    MakesValue alice,
    MakesValue bob
  ) =>
  alice ->
  bob ->
  App ()
connectTwoUsers :: forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> App ()
connectTwoUsers alice
alice bob
bob = do
  alice -> bob -> App Response
forall user inv.
(HasCallStack, MakesValue user, MakesValue inv) =>
user -> inv -> App Response
postConnection alice
alice bob
bob 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
  bob -> alice -> String -> App Response
forall userFrom userTo status.
(HasCallStack, MakesValue userFrom, MakesValue userTo,
 MakesValue status) =>
userFrom -> userTo -> status -> App Response
putConnection bob
bob alice
alice String
"accepted" 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

connectUsers :: (HasCallStack, MakesValue usr) => [usr] -> App ()
connectUsers :: forall usr. (HasCallStack, MakesValue usr) => [usr] -> App ()
connectUsers [usr]
users = ((usr, usr) -> App ()) -> [(usr, usr)] -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((usr -> usr -> App ()) -> (usr, usr) -> App ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry usr -> usr -> App ()
forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> App ()
connectTwoUsers) ([(usr, usr)] -> App ()) -> [(usr, usr)] -> App ()
forall a b. (a -> b) -> a -> b
$ do
  t <- [usr] -> [[usr]]
forall a. [a] -> [[a]]
tails [usr]
users
  (a, others) <- maybeToList (uncons t)
  b <- others
  pure (a, b)

assertConnection :: (HasCallStack, MakesValue alice, MakesValue bob) => alice -> bob -> String -> App ()
assertConnection :: forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> String -> App ()
assertConnection alice
alice bob
bob String
status =
  alice -> bob -> App Response
forall user inv.
(HasCallStack, MakesValue user, MakesValue inv) =>
user -> inv -> App Response
getConnection alice
alice bob
bob 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
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
status

createAndConnectUsers :: (HasCallStack, MakesValue domain) => [domain] -> App [Value]
createAndConnectUsers :: forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [domain]
domains = do
  users <- [domain] -> (domain -> App Value) -> App [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [domain]
domains ((domain -> CreateUser -> App Value)
-> CreateUser -> domain -> App Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser CreateUser
forall a. Default a => a
def)
  connectUsers users
  pure users

createUsers :: (HasCallStack, MakesValue domain) => [domain] -> App [Value]
createUsers :: forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createUsers [domain]
domains = [domain] -> (domain -> App Value) -> App [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [domain]
domains ((domain -> CreateUser -> App Value)
-> CreateUser -> domain -> App Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser CreateUser
forall a. Default a => a
def)

getAllConvs :: (HasCallStack, MakesValue u) => u -> App [Value]
getAllConvs :: forall u. (HasCallStack, MakesValue u) => u -> App [Value]
getAllConvs u
u = do
  page <- App Response -> (Response -> App Value) -> App Value
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (u -> ListConversationIds -> App Response
forall user.
MakesValue user =>
user -> ListConversationIds -> App Response
listConversationIds u
u ListConversationIds
forall a. Default a => a
def) ((Response -> App Value) -> App Value)
-> (Response -> App Value) -> App Value
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
  ids <- page %. "qualified_conversations" & asList
  result <- bindResponse (listConversations u ids) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json
  result %. "found" & asList

getAllConvIds :: (HasCallStack, MakesValue u) => u -> Int -> App [Value]
getAllConvIds :: forall u. (HasCallStack, MakesValue u) => u -> Int -> App [Value]
getAllConvIds u
u Int
pageSize = [Value] -> Maybe String -> App [Value]
go [] Maybe String
forall a. Maybe a
Nothing
  where
    go :: [Value] -> Maybe String -> App [Value]
go [Value]
acc Maybe String
state0 = do
      page <- App Response -> (Response -> App Value) -> App Value
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (u -> ListConversationIds -> App Response
forall user.
MakesValue user =>
user -> ListConversationIds -> App Response
listConversationIds u
u ListConversationIds
forall a. Default a => a
def {size = Just pageSize, pagingState = state0}) ((Response -> App Value) -> App Value)
-> (Response -> App Value) -> App Value
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
      ids <- page %. "qualified_conversations" & asList
      state <- page %. "paging_state" >>= asOptional >>= traverse asString
      hasMore <- page %. "has_more" & asBool
      if hasMore
        then go (acc <> ids) state
        else pure (acc <> ids)

-- | Setup a team user, another user, connect the two, create a proteus
-- conversation, upgrade to mixed. Return the two users and the conversation.
simpleMixedConversationSetup ::
  (HasCallStack, MakesValue domain) =>
  domain ->
  App (Value, Value, ConvId)
simpleMixedConversationSetup :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> App (Value, Value, ConvId)
simpleMixedConversationSetup domain
secondDomain = do
  (alice, tid, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  bob <- randomUser secondDomain def
  connectUsers [alice, bob]

  conv <-
    postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid}
      >>= getJSON 201
      >>= objConvId

  bindResponse (putConversationProtocol bob conv "mixed") $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

  convId <-
    getConversation alice (convIdToQidObject conv)
      >>= getJSON 200
      >>= objConvId

  pure (alice, bob, convId)

supportMLS :: (HasCallStack, MakesValue u) => u -> App ()
supportMLS :: forall user. (HasCallStack, MakesValue user) => user -> App ()
supportMLS u
u = do
  prots <- App Response -> (Response -> App [String]) -> App [String]
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (u -> u -> App Response
forall user inv.
(HasCallStack, MakesValue user, MakesValue inv) =>
user -> inv -> App Response
getUserSupportedProtocols u
u u
u) ((Response -> App [String]) -> App [String])
-> (Response -> App [String]) -> App [String]
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
    prots <- Response
resp.json App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall u. (HasCallStack, MakesValue u) => u -> App [Value]
asList
    traverse asString prots
  let prots' = String
"mls" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
prots
  bindResponse (putUserSupportedProtocols u prots') $ \Response
resp ->
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

addUserToTeam :: (HasCallStack, MakesValue u) => u -> App Value
addUserToTeam :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> App Value
addUserToTeam u
u = do
  inv <- u -> PostInvitation -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> PostInvitation -> App Response
postInvitation u
u PostInvitation
forall a. Default a => a
def App Response -> (Response -> App Value) -> App Value
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 Value
Int -> Response -> App Value
getJSON Int
201
  email <- inv %. "email" & asString
  resp <- getInvitationCode u inv >>= getJSON 200
  code <- resp %. "code" & asString
  addUser u def {email = Just email, teamCode = Just code} >>= getJSON 201

-- | Create a user on the given domain, such that the 1-1 conversation with
-- 'other' resides on 'convDomain'. This connects the two users as a side-effect.
createMLSOne2OnePartner ::
  (MakesValue user, MakesValue domain, MakesValue convDomain, HasCallStack) =>
  domain ->
  user ->
  convDomain ->
  App Value
createMLSOne2OnePartner :: forall user domain convDomain.
(MakesValue user, MakesValue domain, MakesValue convDomain,
 HasCallStack) =>
domain -> user -> convDomain -> App Value
createMLSOne2OnePartner domain
domain user
other convDomain
convDomain = App Value
loop
  where
    loop :: App Value
loop = do
      u <- domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser domain
domain CreateUser
forall a. Default a => a
def
      connectTwoUsers u other
      apiVersion <- getAPIVersionFor domain
      conv <-
        if apiVersion < 6
          then getMLSOne2OneConversation other u >>= getJSON 200
          else getMLSOne2OneConversation other u >>= getJSON 200 >>= (%. "conversation")

      desiredConvDomain <- make convDomain & asString
      actualConvDomain <- conv %. "qualified_id.domain" & asString

      if desiredConvDomain == actualConvDomain
        then pure u
        else loop

-- Copied from `src/CargoHold/API/V3.hs` and inlined to avoid pulling in `types-common`
randomToken :: (HasCallStack) => App String
randomToken :: HasCallStack => App String
randomToken = ByteString -> String
unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64Url.encode (ByteString -> String) -> App ByteString -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ByteString
forall byteArray. ByteArray byteArray => Int -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
16)

data TokenLength = GCM | APNS

randomSnsToken :: (HasCallStack) => TokenLength -> App String
randomSnsToken :: HasCallStack => TokenLength -> App String
randomSnsToken = \case
  TokenLength
GCM -> Int -> App String
mkTok Int
16
  TokenLength
APNS -> Int -> App String
mkTok Int
32
  where
    mkTok :: Int -> App String
mkTok = (ByteString -> String) -> App ByteString -> App String
forall a b. (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ST -> String
Text.unpack (ST -> String) -> (ByteString -> ST) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ST
decodeUtf8 (ByteString -> ST)
-> (ByteString -> ByteString) -> ByteString -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode) (App ByteString -> App String)
-> (Int -> App ByteString) -> Int -> App String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> App ByteString
randomBytes

randomId :: (HasCallStack) => App String
randomId :: HasCallStack => App String
randomId = IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (UUID -> String
forall a. Show a => a -> String
show (UUID -> String) -> IO UUID -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
nextRandom)

randomUUIDv1 :: (HasCallStack) => App String
randomUUIDv1 :: HasCallStack => App String
randomUUIDv1 = IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (UUID -> String
forall a. Show a => a -> String
show (UUID -> String) -> (Maybe UUID -> UUID) -> Maybe UUID -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe UUID -> UUID
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe UUID -> String) -> IO (Maybe UUID) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe UUID)
nextUUID)

randomUserId :: (HasCallStack, MakesValue domain) => domain -> App Value
randomUserId :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> App Value
randomUserId domain
domain = do
  d <- domain -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make domain
domain
  uid <- randomId
  pure $ object ["id" .= uid, "domain" .= d]

withFederatingBackendsAllowDynamic :: (HasCallStack) => ((String, String, String) -> App a) -> App a
withFederatingBackendsAllowDynamic :: forall a.
HasCallStack =>
((String, String, String) -> App a) -> App a
withFederatingBackendsAllowDynamic (String, String, String) -> App a
k = do
  let setFederationConfig :: Value -> App Value
setFederationConfig =
        String -> String -> Value -> App Value
forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField String
"optSettings.setFederationStrategy" String
"allowDynamic"
          (Value -> App Value) -> (Value -> App Value) -> Value -> App Value
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> Value -> Value -> App Value
forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField String
"optSettings.setFederationDomainConfigsUpdateFreq" (Scientific -> Value
Aeson.Number Scientific
1)
  [ServiceOverrides] -> ([String] -> App a) -> App a
forall a.
HasCallStack =>
[ServiceOverrides] -> ([String] -> App a) -> App a
startDynamicBackends
    [ ServiceOverrides
forall a. Default a => a
def {brigCfg = setFederationConfig},
      ServiceOverrides
forall a. Default a => a
def {brigCfg = setFederationConfig},
      ServiceOverrides
forall a. Default a => a
def {brigCfg = setFederationConfig}
    ]
    (([String] -> App a) -> App a) -> ([String] -> App a) -> App a
forall a b. (a -> b) -> a -> b
$ \[String
domainA, String
domainB, String
domainC] -> (String, String, String) -> App a
k (String
domainA, String
domainB, String
domainC)

-- | Create two users on different domains such that the one-to-one
-- conversation, once finalised, will be hosted on the backend given by the
-- first domain.
createOne2OneConversation ::
  (HasCallStack, MakesValue domain1, MakesValue domain2) =>
  domain1 ->
  domain2 ->
  App (Value, Value, Value)
createOne2OneConversation :: forall domain1 domain2.
(HasCallStack, MakesValue domain1, MakesValue domain2) =>
domain1 -> domain2 -> App (Value, Value, Value)
createOne2OneConversation domain1
owningDomain domain2
otherDomain = do
  owningUser <- domain1 -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser domain1
owningDomain CreateUser
forall a. Default a => a
def
  domainName <- owningUser %. "qualified_id.domain"
  let go = do
        otherUser <- domain2 -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser domain2
otherDomain CreateUser
forall a. Default a => a
def
        otherUserId <- otherUser %. "qualified_id"
        conn <-
          postConnection owningUser otherUser `bindResponse` \Response
resp -> do
            Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
            payload <- Response
resp.json
            payload %. "status" `shouldMatch` "sent"
            payload %. "qualified_to" `shouldMatch` otherUserId
            pure payload
        one2one <- conn %. "qualified_conversation"
        one2oneDomain <- one2one %. "domain"
        if domainName == one2oneDomain
          then pure (owningUser, otherUser, one2one)
          else SetupHelpers.deleteUser otherUser >> go
  go

data One2OneConvState = Established | Connect

-- | Converts to an integer corresponding to the numeric representation of the
-- 'Wire.API.Conversation.ConvType' type.
toConvType :: One2OneConvState -> Int
toConvType :: One2OneConvState -> Int
toConvType = \case
  One2OneConvState
Established -> Int
2
  One2OneConvState
Connect -> Int
3

-- | Fetch the one-to-one conversation between the two users that is in one of
-- two possible states.
getOne2OneConversation :: (HasCallStack) => Value -> Value -> One2OneConvState -> App Value
getOne2OneConversation :: HasCallStack => Value -> Value -> One2OneConvState -> App Value
getOne2OneConversation Value
user1 Value
user2 One2OneConvState
cnvState = do
  l <- Value -> App [Value]
forall u. (HasCallStack, MakesValue u) => u -> App [Value]
getAllConvs Value
user1
  let isWith [Value]
users Value
c = do
        -- The conversation type 2 is for 1-to-1 conversations. Type 3 is for
        -- the connection conversation, which is the state of the conversation
        -- before the connection is fully established.
        t <- (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== One2OneConvState -> Int
toConvType One2OneConvState
cnvState) (Int -> Bool) -> App Int -> App Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value
c Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> (App Value -> App Int) -> App Int
forall a b. a -> (a -> b) -> b
& App Value -> App Int
forall a. (HasCallStack, MakesValue a) => a -> App Int
asInt)
        others <- c %. "members.others" & asList
        qIds <- for others (%. "qualified_id")
        pure $ qIds == users && t
  head <$> filterM (isWith [user2]) l

-- | Create a provider, get an activation code, activate the provider and log it
-- in. The return value is the created provider.
setupProvider ::
  ( HasCallStack,
    MakesValue user
  ) =>
  user ->
  NewProvider ->
  App Value
setupProvider :: forall user.
(HasCallStack, MakesValue user) =>
user -> NewProvider -> App Value
setupProvider user
u (NewProvider {String
Maybe String
newProviderName :: String
newProviderDesc :: String
newProviderPassword :: Maybe String
newProviderUrl :: String
newProviderUrl :: NewProvider -> String
newProviderPassword :: NewProvider -> Maybe String
newProviderDesc :: NewProvider -> String
newProviderName :: NewProvider -> String
..}) = do
  dom <- user -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objDomain user
u
  providerEmail <- randomEmail
  newProviderResponse <-
    newProvider u $
      object
        [ "name" .= newProviderName,
          "description" .= newProviderDesc,
          "email" .= providerEmail,
          "password" .= newProviderPassword,
          "url" .= newProviderUrl
        ]
  pass <- case newProviderPassword of
    Maybe String
Nothing -> Value
newProviderResponse Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"password" 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
    Just String
pass -> String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
pass
  (key, code) <- do
    pair <-
      getProviderActivationCodeInternal dom providerEmail `bindResponse` \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
        Response
resp.json
    k <- pair %. "key" & asString
    c <- pair %. "code" & asString
    pure (k, c)
  activateProvider dom key code
  loginProvider dom providerEmail pass >>= assertSuccess
  pid <- asString $ newProviderResponse %. "id"
  getProvider dom pid >>= getJSON 200

lhDeviceIdOf :: (MakesValue user) => user -> App String
lhDeviceIdOf :: forall user. MakesValue user => user -> App String
lhDeviceIdOf user
bob = do
  bobId <- user -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId user
bob
  getClientsFull bob [bobId] `bindResponse` \Response
resp ->
    do
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
bobId
        App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall u. (HasCallStack, MakesValue u) => u -> App [Value]
asList
          App [Value] -> ([Value] -> App [Value]) -> App [Value]
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> App Bool) -> [Value] -> App [Value]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM \Value
val -> (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"legalhold") (String -> Bool) -> App String -> App Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value
val Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" 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 [Value] -> ([Value] -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Value] -> App Value
forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne
      App Value -> (Value -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id")
      App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString

randomUUIDString :: App String
randomUUIDString :: App String
randomUUIDString = 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
nextRandom

randomScimUser :: App Value
randomScimUser :: App Value
randomScimUser = HasCallStack => RandomScimUserParams -> App Value
RandomScimUserParams -> App Value
randomScimUserWith RandomScimUserParams
forall a. Default a => a
def

randomScimUserWithEmail :: String -> String -> App Value
randomScimUserWithEmail :: String -> String -> App Value
randomScimUserWithEmail String
extId String
email =
  HasCallStack => RandomScimUserParams -> App Value
RandomScimUserParams -> App Value
randomScimUserWith
    RandomScimUserParams
forall a. Default a => a
def
      { mkExternalId = pure extId,
        prependExternalIdToEmails = False,
        mkOtherEmails = pure [email]
      }

data RandomScimUserParams = RandomScimUserParams
  { RandomScimUserParams -> App String
mkExternalId :: App String,
    RandomScimUserParams -> Bool
prependExternalIdToEmails :: Bool, -- NB: this flag is also honored if externalId is not an email!
    RandomScimUserParams -> App [String]
mkOtherEmails :: App [String]
  }

instance Default RandomScimUserParams where
  def :: RandomScimUserParams
def =
    RandomScimUserParams
      { mkExternalId :: App String
mkExternalId = App String
randomEmail,
        prependExternalIdToEmails :: Bool
prependExternalIdToEmails = Bool
True,
        mkOtherEmails :: App [String]
mkOtherEmails = [String] -> App [String]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      }

randomScimUserWith :: (HasCallStack) => RandomScimUserParams -> App Value
randomScimUserWith :: HasCallStack => RandomScimUserParams -> App Value
randomScimUserWith RandomScimUserParams
params = do
  extId <- RandomScimUserParams
params.mkExternalId
  emails <- do
    let mk a
email = [Pair] -> Value
object [String
"value" String -> a -> Pair
forall a. ToJSON a => String -> a -> Pair
.= a
email]
        hd = [String
extId | RandomScimUserParams
params.prependExternalIdToEmails]
    tl <- params.mkOtherEmails
    pure $ Array (fromList (mk <$> (hd <> tl)))
  handle <- randomHandleWithRange 12 128
  pure $
    object
      [ "schemas" .= ["urn:ietf:params:scim:schemas:core:2.0:User"],
        "externalId" .= extId,
        "emails" .= emails,
        "userName" .= handle,
        "displayName" .= handle
      ]

-- | This adds one random asset to the `assets` field in the user record and returns an asset
-- key.  The asset carries a fresh UUIDv4 in text form (even though it is typed 'preview` and
-- `image').
uploadProfilePicture :: (HasCallStack, MakesValue usr) => usr -> App (String, String, String)
uploadProfilePicture :: forall usr.
(HasCallStack, MakesValue usr) =>
usr -> App (String, String, String)
uploadProfilePicture usr
usr = do
  payload <- (String
"asset_contents=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> App String -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App String
HasCallStack => App String
randomId
  asset <- bindResponse (uploadAsset usr payload) (getJSON 201)
  dom <- asset %. "domain" & asString
  key <- asset %. "key" & asString
  Success (oldAssets :: [Value]) <- bindResponse (getSelf usr) $ \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
"assets" App Value -> (Value -> Result [Value]) -> App (Result [Value])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Value -> Result [Value]
forall a. FromJSON a => Value -> Result a
fromJSON
  bindResponse
    (putSelf usr def {assets = Just (object ["key" .= key, "size" .= "preview", "type" .= "image"] : oldAssets)})
    assertSuccess
  pure (dom, key, payload)

-- | Take a calling user (any user will do) and an asset domain and key, and return a
-- (temporarily valid) s3 url plus asset payload (if created with `uploadProfilePicture`,
-- that's a UUIDv4).
downloadProfilePicture :: (HasCallStack, MakesValue caller) => caller -> String -> String -> App (String, String)
downloadProfilePicture :: forall caller.
(HasCallStack, MakesValue caller) =>
caller -> String -> String -> App (String, String)
downloadProfilePicture caller
caller String
assetDomain String
assetKey = do
  locurl <- App Response -> (Response -> App String) -> App String
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (caller
-> caller
-> String
-> String
-> (Request -> Request)
-> App Response
forall user key assetDomain.
(HasCallStack, MakesValue user, MakesValue key,
 MakesValue assetDomain) =>
user
-> assetDomain
-> key
-> String
-> (Request -> Request)
-> App Response
downloadAsset caller
caller caller
caller String
assetKey String
assetDomain Request -> Request
noRedirect) ((Response -> App String) -> App String)
-> (Response -> App String) -> App String
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
302
    App String
-> (ByteString -> App String) -> Maybe ByteString -> App String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (String -> App String
forall a. HasCallStack => String -> a
error String
"no location header in 302 response!?")
      (String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> App String)
-> (ByteString -> String) -> ByteString -> App String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs)
      (CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Location")) Response
resp.headers)

  payload <- bindResponse (downloadAsset caller caller assetKey assetDomain id) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> App String) -> String -> App String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs Response
resp.body

  pure (locurl, payload)

-- | Call 'uploadProfilePicture' and 'downloadPicture', returning the return value of the
-- latter.
uploadDownloadProfilePicture :: (HasCallStack, MakesValue usr) => usr -> App (String, String)
uploadDownloadProfilePicture :: forall usr.
(HasCallStack, MakesValue usr) =>
usr -> App (String, String)
uploadDownloadProfilePicture usr
usr = do
  (dom, key, _payload) <- usr -> App (String, String, String)
forall usr.
(HasCallStack, MakesValue usr) =>
usr -> App (String, String, String)
uploadProfilePicture usr
usr
  downloadProfilePicture usr dom key

addUsersToFailureContext :: (MakesValue user) => [(String, user)] -> App a -> App a
addUsersToFailureContext :: forall user a.
MakesValue user =>
[(String, user)] -> App a -> App a
addUsersToFailureContext [(String, user)]
namesAndUsers App a
action = do
  let mkLine :: (String, a) -> App String
mkLine (String
name, a
user) = do
        (domain, id_) <- a -> App (String, String)
forall usr.
(HasCallStack, MakesValue usr) =>
usr -> App (String, String)
objQid a
user
        pure $ name <> ": " <> id_ <> "@" <> domain
  allLines <- [String] -> String
unlines ([String] -> String) -> App [String] -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((String, user) -> App String) -> [(String, user)] -> App [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String, user) -> App String
forall {a}. MakesValue a => (String, a) -> App String
mkLine [(String, user)]
namesAndUsers)
  addFailureContext allLines action

addJSONToFailureContext :: (MakesValue a) => String -> a -> App b -> App b
addJSONToFailureContext :: forall a b. MakesValue a => String -> a -> App b -> App b
addJSONToFailureContext String
name a
ctx App b
action = do
  jsonStr <- a -> App String
forall user. MakesValue user => user -> App String
prettyJSON a
ctx
  let ctxStr = [String] -> String
unlines [String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":", Int -> String -> String
indent Int
2 String
jsonStr]
  addFailureContext ctxStr action

registerTestIdPWithMeta :: (HasCallStack, MakesValue owner) => owner -> App Response
registerTestIdPWithMeta :: forall user.
(HasCallStack, MakesValue user) =>
user -> App Response
registerTestIdPWithMeta owner
owner = (Response, (IdPMetadata, SignPrivCreds)) -> Response
forall a b. (a, b) -> a
fst ((Response, (IdPMetadata, SignPrivCreds)) -> Response)
-> App (Response, (IdPMetadata, SignPrivCreds)) -> App Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> owner -> App (Response, (IdPMetadata, SignPrivCreds))
forall owner.
(HasCallStack, MakesValue owner) =>
owner -> App (Response, (IdPMetadata, SignPrivCreds))
registerTestIdPWithMetaWithPrivateCreds owner
owner

registerTestIdPWithMetaWithPrivateCredsForZHost ::
  (HasCallStack, MakesValue owner) =>
  owner ->
  Maybe String ->
  App (Response, (SAML.IdPMetadata, SAML.SignPrivCreds))
registerTestIdPWithMetaWithPrivateCredsForZHost :: forall owner.
(HasCallStack, MakesValue owner) =>
owner
-> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds))
registerTestIdPWithMetaWithPrivateCredsForZHost owner
owner Maybe String
mbZhost = do
  SampleIdP idpmeta pCreds _ _ <- App SampleIdP
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadRandom m) =>
m SampleIdP
makeSampleIdPMetadata
  (,(idpmeta, pCreds)) <$> createIdpWithZHost owner mbZhost idpmeta

registerTestIdPWithMetaWithPrivateCreds :: (HasCallStack, MakesValue owner) => owner -> App (Response, (SAML.IdPMetadata, SAML.SignPrivCreds))
registerTestIdPWithMetaWithPrivateCreds :: forall owner.
(HasCallStack, MakesValue owner) =>
owner -> App (Response, (IdPMetadata, SignPrivCreds))
registerTestIdPWithMetaWithPrivateCreds = (owner
 -> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds)))
-> Maybe String
-> owner
-> App (Response, (IdPMetadata, SignPrivCreds))
forall a b c. (a -> b -> c) -> b -> a -> c
flip owner
-> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds))
forall owner.
(HasCallStack, MakesValue owner) =>
owner
-> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds))
registerTestIdPWithMetaWithPrivateCredsForZHost Maybe String
forall a. Maybe a
Nothing

updateTestIdpWithMetaWithPrivateCreds :: (HasCallStack, MakesValue owner) => owner -> String -> App (Response, (SAML.IdPMetadata, SAML.SignPrivCreds))
updateTestIdpWithMetaWithPrivateCreds :: forall owner.
(HasCallStack, MakesValue owner) =>
owner -> String -> App (Response, (IdPMetadata, SignPrivCreds))
updateTestIdpWithMetaWithPrivateCreds owner
owner String
idpId = do
  SampleIdP idpmeta pCreds _ _ <- App SampleIdP
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadRandom m) =>
m SampleIdP
makeSampleIdPMetadata
  (,(idpmeta, pCreds)) <$> updateIdp owner idpId idpmeta

-- | Given a team configured with saml sso, attempt a login with valid credentials.  This
-- function simulates client *and* IdP (instead of talking to an IdP).  It can be used to test
-- scim-provisioned users as well as saml auto-provisioning without scim.
loginWithSaml :: (HasCallStack) => Bool -> String -> SAML.NameID -> (String, (SAML.IdPMetadata, SAML.SignPrivCreds)) -> App (Maybe String, SAML.SignedAuthnResponse)
loginWithSaml :: HasCallStack =>
Bool
-> String
-> NameID
-> (String, (IdPMetadata, SignPrivCreds))
-> App (Maybe String, SignedAuthnResponse)
loginWithSaml = Maybe String
-> Domain
-> Bool
-> String
-> NameID
-> (String, (IdPMetadata, SignPrivCreds))
-> App (Maybe String, SignedAuthnResponse)
forall domain.
(MakesValue domain, HasCallStack) =>
Maybe String
-> domain
-> Bool
-> String
-> NameID
-> (String, (IdPMetadata, SignPrivCreds))
-> App (Maybe String, SignedAuthnResponse)
loginWithSamlWithZHost Maybe String
forall a. Maybe a
Nothing Domain
OwnDomain

loginWithSamlEmail :: (HasCallStack) => Bool -> String -> String -> (String, (SAML.IdPMetadata, SAML.SignPrivCreds)) -> App (Maybe String, SAML.SignedAuthnResponse)
loginWithSamlEmail :: HasCallStack =>
Bool
-> String
-> String
-> (String, (IdPMetadata, SignPrivCreds))
-> App (Maybe String, SignedAuthnResponse)
loginWithSamlEmail Bool
expectSuccess String
tid String
email =
  Maybe String
-> Domain
-> Bool
-> String
-> NameID
-> (String, (IdPMetadata, SignPrivCreds))
-> App (Maybe String, SignedAuthnResponse)
forall domain.
(MakesValue domain, HasCallStack) =>
Maybe String
-> domain
-> Bool
-> String
-> NameID
-> (String, (IdPMetadata, SignPrivCreds))
-> App (Maybe String, SignedAuthnResponse)
loginWithSamlWithZHost Maybe String
forall a. Maybe a
Nothing Domain
OwnDomain Bool
expectSuccess String
tid (NameID -> Either String NameID -> NameID
forall b a. b -> Either a b -> b
fromRight (String -> NameID
forall a. HasCallStack => String -> a
error String
"could not create name id") (Either String NameID -> NameID) -> Either String NameID -> NameID
forall a b. (a -> b) -> a -> b
$ ST -> Either String NameID
forall (m :: * -> *). MonadError String m => ST -> m NameID
SAML.emailNameID (String -> ST
forall a b. ConvertibleStrings a b => a -> b
cs String
email))

-- | Given a team configured with saml sso, attempt a login with valid credentials.  This
-- function simulates client *and* IdP (instead of talking to an IdP).  It can be used to test
-- scim-provisioned users as well as saml auto-provisioning without scim.
loginWithSamlWithZHost ::
  (MakesValue domain, HasCallStack) =>
  Maybe String ->
  domain ->
  Bool ->
  String ->
  SAML.NameID ->
  (String, (SAML.IdPMetadata, SAML.SignPrivCreds)) ->
  App (Maybe String, SAML.SignedAuthnResponse)
loginWithSamlWithZHost :: forall domain.
(MakesValue domain, HasCallStack) =>
Maybe String
-> domain
-> Bool
-> String
-> NameID
-> (String, (IdPMetadata, SignPrivCreds))
-> App (Maybe String, SignedAuthnResponse)
loginWithSamlWithZHost Maybe String
mbZHost domain
domain Bool
expectSuccess String
tid NameID
nameId (String
iid, (IdPMetadata
meta, SignPrivCreds
privcreds)) = do
  let idpConfig :: IdPConfig ()
idpConfig = IdPId -> IdPMetadata -> () -> IdPConfig ()
forall extra. IdPId -> IdPMetadata -> extra -> IdPConfig extra
SAML.IdPConfig (UUID -> IdPId
SAML.IdPId (UUID -> Maybe UUID -> UUID
forall a. a -> Maybe a -> a
fromMaybe (String -> UUID
forall a. HasCallStack => String -> a
error String
"invalid idp id") (String -> Maybe UUID
UUID.fromString String
iid))) IdPMetadata
meta ()
  spmeta <- domain -> Maybe String -> String -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Maybe String -> String -> App Response
getSPMetadataWithZHost domain
domain Maybe String
mbZHost String
tid
  authnreq <- initiateSamlLoginWithZHost domain mbZHost iid
  let spMetaData = ByteString -> SPMetadata
toSPMetaData Response
spmeta.body
      parsedAuthnReq = ByteString -> AuthnRequest
parseAuthnReqResp Response
authnreq.body
  authnReqResp <- makeAuthnResponse nameId privcreds idpConfig spMetaData parsedAuthnReq
  mUid <- finalizeSamlLoginWithZHost domain mbZHost tid authnReqResp `bindResponse` validateLoginResp
  pure (mUid, authnReqResp)
  where
    toSPMetaData :: ByteString -> SAML.SPMetadata
    toSPMetaData :: ByteString -> SPMetadata
toSPMetaData ByteString
bs = SPMetadata -> Either String SPMetadata -> SPMetadata
forall b a. b -> Either a b -> b
fromRight (String -> SPMetadata
forall a. HasCallStack => String -> a
error String
"could not decode spmetatdata") (Either String SPMetadata -> SPMetadata)
-> Either String SPMetadata -> SPMetadata
forall a b. (a -> b) -> a -> b
$ Text -> Either String SPMetadata
forall (m :: * -> *) a.
(HasXMLRoot a, MonadError String m) =>
Text -> m a
SAML.decode (Text -> Either String SPMetadata)
-> Text -> Either String SPMetadata
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
bs

    validateLoginResp :: (HasCallStack) => Response -> App (Maybe String)
    validateLoginResp :: HasCallStack => Response -> App (Maybe String)
validateLoginResp Response
resp =
      if Bool
expectSuccess
        then do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
          let bdy :: String
bdy = ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs Response
resp.body
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">"
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"<title>wire:sso:success</title>"
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"window.opener.postMessage({type: 'AUTH_SUCCESS'}, receiverOrigin)"
          Response -> App (Maybe String)
hasPersistentCookieHeader Response
resp
        else do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
          let bdy :: String
bdy = ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs Response
resp.body
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">"
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"<title>wire:sso:error:"
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"window.opener.postMessage({"
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"\"type\":\"AUTH_ERROR\""
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"\"payload\":{"
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"\"label\":\"forbidden\""
          String
bdy String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` String
"}, receiverOrigin)"
          Response -> App (Maybe String)
hasPersistentCookieHeader Response
resp

    hasPersistentCookieHeader :: Response -> App (Maybe String)
    hasPersistentCookieHeader :: Response -> App (Maybe String)
hasPersistentCookieHeader Response
rsp = do
      let mCookie :: Maybe String
mCookie = String -> Response -> Maybe String
getCookie String
"zuid" Response
rsp
      case Maybe String
mCookie of
        Maybe String
Nothing -> do
          Bool
expectSuccess Bool -> Bool -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Bool
False
          Maybe String -> App (Maybe String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
        Just String
cookie -> do
          Bool
expectSuccess Bool -> Bool -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Bool
True
          Maybe String -> App (Maybe String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> App (Maybe String))
-> Maybe String -> App (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
getUserIdFromCookie String
cookie

    getUserIdFromCookie :: String -> Maybe String
    getUserIdFromCookie :: String -> Maybe String
getUserIdFromCookie String
cookie = do
      let regex :: String
regex = String
"u=([0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12})"
      case String
cookie String -> String -> [[String]]
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
regex :: [[String]] of
        [[String
_, String
uuid]] -> String -> Maybe String
forall a. a -> Maybe a
Just String
uuid
        [[String]]
_ -> Maybe String
forall a. Maybe a
Nothing

makeAuthnResponse ::
  SAML.NameID ->
  SAML.SignPrivCreds ->
  SAML.IdPConfig extra ->
  SAML.SPMetadata ->
  SAML.AuthnRequest ->
  App SAML.SignedAuthnResponse
makeAuthnResponse :: forall extra.
NameID
-> SignPrivCreds
-> IdPConfig extra
-> SPMetadata
-> AuthnRequest
-> App SignedAuthnResponse
makeAuthnResponse NameID
nameId SignPrivCreds
privcreds IdPConfig extra
idpConfig SPMetadata
spMetaData AuthnRequest
parsedAuthnReq =
  SimpleSP SignedAuthnResponse -> App SignedAuthnResponse
forall a. SimpleSP a -> App a
runSimpleSP (SimpleSP SignedAuthnResponse -> App SignedAuthnResponse)
-> SimpleSP SignedAuthnResponse -> App SignedAuthnResponse
forall a b. (a -> b) -> a -> b
$
    NameID
-> SignPrivCreds
-> IdPConfig extra
-> SPMetadata
-> Maybe AuthnRequest
-> Bool
-> SimpleSP SignedAuthnResponse
forall extra (m :: * -> *).
(HasCallStack, HasMonadSign m, HasCreateUUID m, HasNow m) =>
NameID
-> SignPrivCreds
-> IdPConfig extra
-> SPMetadata
-> Maybe AuthnRequest
-> Bool
-> m SignedAuthnResponse
SAML.mkAuthnResponseWithSubj NameID
nameId SignPrivCreds
privcreds IdPConfig extra
idpConfig SPMetadata
spMetaData (AuthnRequest -> Maybe AuthnRequest
forall a. a -> Maybe a
Just AuthnRequest
parsedAuthnReq) Bool
True

-- | extract an `AuthnRequest` from the html form in the http response from /sso/initiate-login
parseAuthnReqResp ::
  ByteString ->
  SAML.AuthnRequest
parseAuthnReqResp :: ByteString -> AuthnRequest
parseAuthnReqResp ByteString
bs = AuthnRequest
reqBody
  where
    xml :: XML.Document
    xml :: Document
xml =
      Document -> Either SomeException Document -> Document
forall b a. b -> Either a b -> b
fromRight (String -> Document
forall a. HasCallStack => String -> a
error String
"malformed html in response body") (Either SomeException Document -> Document)
-> Either SomeException Document -> Document
forall a b. (a -> b) -> a -> b
$
        ParseSettings -> Text -> Either SomeException Document
XML.parseText ParseSettings
forall a. Default a => a
XML.def (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
bs)

    reqBody :: SAML.AuthnRequest
    reqBody :: AuthnRequest
reqBody =
      (Document -> Cursor
XML.fromDocument Document
xml Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
XML.$// Name -> Cursor -> [Cursor]
XML.element (ST -> Maybe ST -> Maybe ST -> Name
XML.Name (String -> ST
forall a b. ConvertibleStrings a b => a -> b
cs String
"input") (ST -> Maybe ST
forall a. a -> Maybe a
Just (String -> ST
forall a b. ConvertibleStrings a b => a -> b
cs String
"http://www.w3.org/1999/xhtml")) Maybe ST
forall a. Maybe a
Nothing))
        [Cursor] -> ([Cursor] -> Cursor) -> Cursor
forall a b. a -> (a -> b) -> b
& [Cursor] -> Cursor
forall a. HasCallStack => [a] -> a
head
        Cursor -> (Cursor -> [ST]) -> [ST]
forall a b. a -> (a -> b) -> b
& Name -> Cursor -> [ST]
XML.attribute (String -> Name
forall a. IsString a => String -> a
fromString String
"value")
        [ST] -> ([ST] -> ST) -> ST
forall a b. a -> (a -> b) -> b
& [ST] -> ST
forall a. HasCallStack => [a] -> a
head
        ST -> (ST -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& ST -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs
        ByteString
-> (ByteString -> Either String ByteString)
-> Either String ByteString
forall a b. a -> (a -> b) -> b
& ByteString -> Either String ByteString
EL.decode
        Either String ByteString
-> (Either String ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& ByteString -> Either String ByteString -> ByteString
forall b a. b -> Either a b -> b
fromRight (String -> ByteString
forall a. HasCallStack => String -> a
error String
"")
        ByteString -> (ByteString -> Text) -> Text
forall a b. a -> (a -> b) -> b
& ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs
        Text
-> (Text -> Either String AuthnRequest)
-> Either String AuthnRequest
forall a b. a -> (a -> b) -> b
& Text -> Either String AuthnRequest
forall a (m :: * -> *).
(HasXML a, MonadError String m) =>
Text -> m a
SAML.decodeElem
        Either String AuthnRequest
-> (Either String AuthnRequest -> AuthnRequest) -> AuthnRequest
forall a b. a -> (a -> b) -> b
& AuthnRequest -> Either String AuthnRequest -> AuthnRequest
forall b a. b -> Either a b -> b
fromRight (String -> AuthnRequest
forall a. HasCallStack => String -> a
error String
"")

getAuthnResponse :: String -> SAML.IdPConfig extra -> SAML.SignPrivCreds -> App SAML.SignedAuthnResponse
getAuthnResponse :: forall extra.
String
-> IdPConfig extra -> SignPrivCreds -> App SignedAuthnResponse
getAuthnResponse String
tid IdPConfig extra
idp SignPrivCreds
privCreds = do
  subject <- App NameID
nextSubject
  getAuthnResponseCustomNameID subject tid idp privCreds

getAuthnResponseCustomNameID :: SAML.NameID -> String -> SAML.IdPConfig extra -> SAML.SignPrivCreds -> App SAML.SignedAuthnResponse
getAuthnResponseCustomNameID :: forall extra.
NameID
-> String
-> IdPConfig extra
-> SignPrivCreds
-> App SignedAuthnResponse
getAuthnResponseCustomNameID NameID
subject String
tid IdPConfig extra
idp SignPrivCreds
privCreds = do
  spmeta :: SAML.SPMetadata <-
    Domain -> String -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> String -> App Response
getSPMetadata Domain
OwnDomain String
tid App Response -> (Response -> App SPMetadata) -> App SPMetadata
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
200
      (String -> App SPMetadata)
-> (SPMetadata -> App SPMetadata)
-> Either String SPMetadata
-> App SPMetadata
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> App SPMetadata
forall a. HasCallStack => String -> a
error (String -> App SPMetadata)
-> (String -> String) -> String -> App SPMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) SPMetadata -> App SPMetadata
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String SPMetadata -> App SPMetadata)
-> Either String SPMetadata -> App SPMetadata
forall a b. (a -> b) -> a -> b
$ Text -> Either String SPMetadata
forall (m :: * -> *) a.
(HasXMLRoot a, MonadError String m) =>
Text -> m a
SAML.decode (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Response
resp.body)
  runSimpleSP $ SAML.mkAuthnResponseWithSubj subject privCreds idp spmeta Nothing True

-- | useful for, say, getting an authentication request that spar won't remember.
runSimpleSP :: SAML.SimpleSP a -> App a
runSimpleSP :: forall a. SimpleSP a -> App a
runSimpleSP SimpleSP a
action = do
  ctx <- IO SimpleSPCtx -> App SimpleSPCtx
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SimpleSPCtx -> App SimpleSPCtx)
-> IO SimpleSPCtx -> App SimpleSPCtx
forall a b. (a -> b) -> a -> b
$ Config -> [IdPConfig ()] -> IO SimpleSPCtx
SAML.mkSimpleSPCtx Config
forall a. HasCallStack => a
undefined []
  runSimpleSPWithCtx ctx action

runSimpleSPWithCtx :: SAML.SimpleSPCtx -> SAML.SimpleSP a -> App a
runSimpleSPWithCtx :: forall a. SimpleSPCtx -> SimpleSP a -> App a
runSimpleSPWithCtx SimpleSPCtx
ctx SimpleSP a
action = IO a -> App a
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> App a) -> IO a -> App a
forall a b. (a -> b) -> a -> b
$ do
  result <- SimpleSPCtx -> SimpleSP a -> IO (Either SimpleError a)
forall a. SimpleSPCtx -> SimpleSP a -> IO (Either SimpleError a)
SAML.runSimpleSP SimpleSPCtx
ctx SimpleSP a
action
  pure $ fromRight (error "simple sp action failed") result

nextSubject :: App SAML.NameID
nextSubject :: App NameID
nextSubject = do
  unameId <-
    (Int, Int) -> App Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0, Int
1 :: Int) App Int -> (Int -> App UnqualifiedNameID) -> App UnqualifiedNameID
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Int
0 -> (String -> UnqualifiedNameID)
-> (UnqualifiedNameID -> UnqualifiedNameID)
-> Either String UnqualifiedNameID
-> UnqualifiedNameID
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> UnqualifiedNameID
forall a. HasCallStack => String -> a
error (String -> UnqualifiedNameID)
-> (String -> String) -> String -> UnqualifiedNameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) UnqualifiedNameID -> UnqualifiedNameID
forall a. a -> a
id (Either String UnqualifiedNameID -> UnqualifiedNameID)
-> (String -> Either String UnqualifiedNameID)
-> String
-> UnqualifiedNameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> Either String UnqualifiedNameID
forall (m :: * -> *).
MonadError String m =>
ST -> m UnqualifiedNameID
SAML.mkUNameIDEmail (ST -> Either String UnqualifiedNameID)
-> (String -> ST) -> String -> Either String UnqualifiedNameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ST
forall a b. ConvertibleStrings a b => a -> b
cs (String -> UnqualifiedNameID)
-> App String -> App UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App String
randomEmail
      Int
1 -> IO UnqualifiedNameID -> App UnqualifiedNameID
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UnqualifiedNameID -> App UnqualifiedNameID)
-> IO UnqualifiedNameID -> App UnqualifiedNameID
forall a b. (a -> b) -> a -> b
$ ST -> UnqualifiedNameID
SAML.mkUNameIDUnspecified (ST -> UnqualifiedNameID)
-> (UUID -> ST) -> UUID -> UnqualifiedNameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> ST
UUID.toText (UUID -> UnqualifiedNameID) -> IO UUID -> IO UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
nextRandom
  either (error . show) pure $ SAML.mkNameID unameId Nothing Nothing Nothing

-- helpers

data ChallengeSetup = ChallengeSetup
  { ChallengeSetup -> String
dnsToken :: String,
    ChallengeSetup -> String
challengeId :: String,
    ChallengeSetup -> String
challengeToken :: String,
    ChallengeSetup -> String
technitiumToken :: String
  }

setupChallenge :: (MakesValue domain, HasCallStack) => domain -> String -> App ChallengeSetup
setupChallenge :: forall domain.
(MakesValue domain, HasCallStack) =>
domain -> String -> App ChallengeSetup
setupChallenge domain
domain String
emailDomain = do
  challenge <- domain -> String -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> String -> App Response
getDomainVerificationChallenge domain
domain String
emailDomain App Response -> (Response -> App Value) -> App Value
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 Value
Int -> Response -> App Value
getJSON Int
200
  dnsToken <- challenge %. "dns_verification_token" & asString
  challengeId <- challenge %. "id" & asString
  challengeToken <- challenge %. "token" & asString

  technitiumToken <- getTechnitiumApiKey
  registerTechnitiumZone technitiumToken emailDomain

  pure $
    ChallengeSetup
      { dnsToken,
        challengeId,
        challengeToken,
        technitiumToken
      }

data DomainRegistrationSetup = DomainRegistrationSetup
  { DomainRegistrationSetup -> String
dnsToken :: String,
    DomainRegistrationSetup -> String
technitiumToken :: String,
    DomainRegistrationSetup -> String
ownershipToken :: String
  }

setupChallengeAndDnsRecord :: (MakesValue domain, HasCallStack) => domain -> String -> App ChallengeSetup
setupChallengeAndDnsRecord :: forall domain.
(MakesValue domain, HasCallStack) =>
domain -> String -> App ChallengeSetup
setupChallengeAndDnsRecord domain
domain String
emailDomain = do
  challenge <- domain -> String -> App ChallengeSetup
forall domain.
(MakesValue domain, HasCallStack) =>
domain -> String -> App ChallengeSetup
setupChallenge domain
domain String
emailDomain
  -- register TXT DNS record
  registerTechnitiumRecord challenge.technitiumToken emailDomain ("wire-domain." <> emailDomain) "TXT" challenge.dnsToken
  pure challenge

setupOwnershipTokenForBackend :: (MakesValue domain, HasCallStack) => domain -> String -> App DomainRegistrationSetup
setupOwnershipTokenForBackend :: forall domain.
(MakesValue domain, HasCallStack) =>
domain -> String -> App DomainRegistrationSetup
setupOwnershipTokenForBackend domain
domain String
emailDomain = do
  challenge <- domain -> String -> App ChallengeSetup
forall domain.
(MakesValue domain, HasCallStack) =>
domain -> String -> App ChallengeSetup
setupChallengeAndDnsRecord domain
domain String
emailDomain
  -- verify domain
  ownershipToken <- bindResponse (verifyDomain domain emailDomain challenge.challengeId challenge.challengeToken) $ \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
"domain_ownership_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

  pure $ DomainRegistrationSetup challenge.dnsToken challenge.technitiumToken ownershipToken

setupOwnershipTokenForTeam :: (MakesValue user, HasCallStack) => user -> String -> App DomainRegistrationSetup
setupOwnershipTokenForTeam :: forall domain.
(MakesValue domain, HasCallStack) =>
domain -> String -> App DomainRegistrationSetup
setupOwnershipTokenForTeam user
user String
emailDomain = do
  challenge <- user -> String -> App ChallengeSetup
forall domain.
(MakesValue domain, HasCallStack) =>
domain -> String -> App ChallengeSetup
setupChallengeAndDnsRecord user
user String
emailDomain

  -- verify domain
  ownershipToken <- bindResponse (verifyDomainForTeam user emailDomain challenge.challengeId challenge.challengeToken) $ \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
"domain_ownership_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

  pure $ DomainRegistrationSetup challenge.dnsToken challenge.technitiumToken ownershipToken

activateEmail :: (HasCallStack, MakesValue domain) => domain -> String -> App ()
activateEmail :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> String -> App ()
activateEmail domain
domain String
email = do
  (actkey, code) <- App Response
-> (Response -> App (String, String)) -> App (String, String)
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (domain -> String -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> String -> App Response
getActivationCode domain
domain String
email) ((Response -> App (String, String)) -> App (String, String))
-> (Response -> App (String, String)) -> App (String, String)
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
    (,)
      (String -> String -> (String, String))
-> App String -> App (String -> (String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Response
res.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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
res.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"code" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString)
  API.Brig.activate domain actkey code >>= assertSuccess

registerInvitedUser :: (HasCallStack, MakesValue domain) => domain -> String -> String -> App ()
registerInvitedUser :: forall dom.
(HasCallStack, MakesValue dom) =>
dom -> String -> String -> App ()
registerInvitedUser domain
domain String
tid String
email = do
  domain -> String -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> String -> App Response
getInvitationByEmail domain
domain String
email
    App Response -> (Response -> App Value) -> App Value
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 Value
Int -> Response -> App Value
getJSON Int
200
    App Value -> (Value -> App Response) -> App Response
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= domain -> String -> Value -> App Response
forall domain inv.
(HasCallStack, MakesValue domain, MakesValue inv) =>
domain -> String -> inv -> App Response
getInvitationCodeForTeam domain
domain String
tid
    App Response -> (Response -> App Value) -> App Value
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 Value
Int -> Response -> App Value
getJSON Int
200
    App Value -> (Value -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"code")
    App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
    App String -> (String -> App Response) -> App Response
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= domain -> String -> String -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> String -> String -> App Response
registerUser domain
domain String
email
    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

getMetrics :: (HasCallStack, MakesValue domain) => domain -> Service -> App Response
getMetrics :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Service -> App Response
getMetrics domain
domain Service
service = do
  req <- domain -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
rawBaseRequest domain
domain Service
service Versioned
Unversioned String
"/i/metrics"
  submit "GET" req