{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module SetupHelpers where

import API.Brig
import API.BrigInternal
import API.Cargohold
import API.Common
import API.Galley
import API.GalleyInternal (legalholdWhitelistTeam)
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 Testlib.JSON
import Testlib.MockIntegrationService (mkLegalHoldSettings)
import Testlib.Prelude
import Testlib.Printing (indent)
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

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 = do
  Value
owner <- domain -> CreateUser -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Response
createUser domain
domain CreateUser
forall a. Default a => a
def {team = True} 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
  String
tid <- Value
owner Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"team" 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
  [Value]
members <- Int -> [Int] -> (Int -> App Value) -> App [Value]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
Int -> t a -> (a -> m b) -> m (t b)
pooledForConcurrentlyN Int
64 [Int
2 .. Int
memberCount] ((Int -> App Value) -> App [Value])
-> (Int -> App Value) -> App [Value]
forall a b. (a -> b) -> a -> b
$ \Int
_ -> Value -> CreateTeamMember -> App Value
forall inviter.
(HasCallStack, MakesValue inviter) =>
inviter -> CreateTeamMember -> App Value
createTeamMember Value
owner CreateTeamMember
forall a. Default a => a
def
  (Value, String, [Value]) -> App (Value, String, [Value])
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value
owner, String
tid, [Value]
members)

data CreateTeamMember = CreateTeamMember
  { CreateTeamMember -> String
role :: String
  }

instance Default CreateTeamMember where
  def :: CreateTeamMember
def = CreateTeamMember {$sel:role:CreateTeamMember :: String
role = String
"member"}

createTeamMember ::
  (HasCallStack, MakesValue inviter) =>
  inviter ->
  CreateTeamMember ->
  App Value
createTeamMember :: forall inviter.
(HasCallStack, MakesValue inviter) =>
inviter -> CreateTeamMember -> App Value
createTeamMember inviter
inviter CreateTeamMember
args = do
  String
newUserEmail <- App String
randomEmail
  Value
invitation <-
    inviter -> PostInvitation -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> PostInvitation -> App Response
postInvitation
      inviter
inviter
      PostInvitation
forall a. Default a => a
def
        { email = Just newUserEmail,
          role = Just args.role
        }
      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
  String
invitationCode <-
    (inviter -> Value -> App Response
forall user inv.
(HasCallStack, MakesValue user, MakesValue inv) =>
user -> inv -> App Response
getInvitationCode inviter
inviter Value
invitation 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 -> 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
  let body :: AddUser
body =
        AddUser
          { $sel:name:AddUser :: Maybe String
name = String -> Maybe String
forall a. a -> Maybe a
Just String
newUserEmail,
            $sel:email:AddUser :: Maybe String
email = String -> Maybe String
forall a. a -> Maybe a
Just String
newUserEmail,
            $sel:password:AddUser :: Maybe String
password = String -> Maybe String
forall a. a -> Maybe a
Just String
defPassword,
            $sel:teamCode:AddUser :: Maybe String
teamCode = String -> Maybe String
forall a. a -> Maybe a
Just String
invitationCode
          }
  inviter -> AddUser -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> AddUser -> App Response
addUser inviter
inviter AddUser
body 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

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
  [usr]
t <- [usr] -> [[usr]]
forall a. [a] -> [[a]]
tails [usr]
users
  (usr
a, [usr]
others) <- Maybe (usr, [usr]) -> [(usr, [usr])]
forall a. Maybe a -> [a]
maybeToList ([usr] -> Maybe (usr, [usr])
forall a. [a] -> Maybe (a, [a])
uncons [usr]
t)
  usr
b <- [usr]
others
  (usr, usr) -> [(usr, usr)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (usr
a, usr
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
  [Value]
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)
  [Value] -> App ()
forall usr. (HasCallStack, MakesValue usr) => [usr] -> App ()
connectUsers [Value]
users
  [Value] -> App [Value]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
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
  Value
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
  [Value]
ids <- Value
page Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_conversations" 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
  Value
result <- App Response -> (Response -> App Value) -> App Value
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (u -> [Value] -> App Response
forall user. MakesValue user => user -> [Value] -> App Response
listConversations u
u [Value]
ids) ((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
  Value
result Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"found" 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

-- | 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
  (Value
alice, String
tid, [Value]
_) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  Value
bob <- domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser domain
secondDomain CreateUser
forall a. Default a => a
def
  [Value] -> App ()
forall usr. (HasCallStack, MakesValue usr) => [usr] -> App ()
connectUsers [Value
alice, Value
bob]

  ConvId
conv <-
    Value -> CreateConv -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> CreateConv -> App Response
postConversation Value
alice CreateConv
defProteus {qualifiedUsers = [bob], team = Just 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
201
      App Value -> (Value -> App ConvId) -> App ConvId
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 ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId

  App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (Value -> ConvId -> String -> App Response
forall user protocol.
(HasCallStack, MakesValue user, MakesValue protocol) =>
user -> ConvId -> protocol -> App Response
putConversationProtocol Value
bob ConvId
conv String
"mixed") ((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

  ConvId
convId <-
    Value -> Value -> App Response
forall user inv.
(HasCallStack, MakesValue user, MakesValue inv) =>
user -> inv -> App Response
getConversation Value
alice (ConvId -> Value
convIdToQidObject ConvId
conv)
      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 ConvId) -> App ConvId
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 ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId

  (Value, Value, ConvId) -> App (Value, Value, ConvId)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value
alice, Value
bob, ConvId
convId)

supportMLS :: (HasCallStack, MakesValue u) => u -> App ()
supportMLS :: forall user. (HasCallStack, MakesValue user) => user -> App ()
supportMLS u
u = do
  [String]
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
    [Value]
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
    (Value -> App String) -> [Value] -> App [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString [Value]
prots
  let prots' :: [String]
prots' = String
"mls" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
prots
  App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (u -> [String] -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> [String] -> App Response
putUserSupportedProtocols u
u [String]
prots') ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \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 u. (HasCallStack, MakesValue u) => u -> App Value
addUserToTeam u
u = do
  Value
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
  String
email <- Value
inv Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"email" 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
  Value
resp <- u -> Value -> App Response
forall user inv.
(HasCallStack, MakesValue user, MakesValue inv) =>
user -> inv -> App Response
getInvitationCode u
u Value
inv 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
  String
code <- Value
resp 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
  u -> AddUser -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> AddUser -> App Response
addUser u
u AddUser
forall a. Default a => a
def {email = Just email, teamCode = Just code} 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

-- | 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
      Value
u <- domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser domain
domain CreateUser
forall a. Default a => a
def
      Value -> user -> App ()
forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> App ()
connectTwoUsers Value
u user
other
      Int
apiVersion <- domain -> App Int
forall domain. MakesValue domain => domain -> App Int
getAPIVersionFor domain
domain
      Value
conv <-
        if Int
apiVersion Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
6
          then user -> Value -> App Response
forall user inv.
(HasCallStack, MakesValue user, MakesValue inv) =>
user -> inv -> App Response
getMLSOne2OneConversation user
other Value
u 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
          else user -> Value -> App Response
forall user inv.
(HasCallStack, MakesValue user, MakesValue inv) =>
user -> inv -> App Response
getMLSOne2OneConversation user
other Value
u 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
"conversation")

      String
desiredConvDomain <- convDomain -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make convDomain
convDomain 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
      String
actualConvDomain <- Value
conv Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id.domain" 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

      if String
desiredConvDomain String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
actualConvDomain
        then Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
u
        else App Value
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 (Text -> String
Text.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
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 u. (HasCallStack, MakesValue u) => u -> App Value
randomUserId domain
domain = do
  Value
d <- domain -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make domain
domain
  String
uid <- App String
HasCallStack => App String
randomId
  Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> App Value) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [String
"id" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
uid, String
"domain" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Value
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. [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
  Value
owningUser <- domain1 -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser domain1
owningDomain CreateUser
forall a. Default a => a
def
  Value
domainName <- Value
owningUser Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id.domain"
  let go :: App (Value, Value, Value)
go = do
        Value
otherUser <- domain2 -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser domain2
otherDomain CreateUser
forall a. Default a => a
def
        Value
otherUserId <- Value
otherUser Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id"
        Value
conn <-
          Value -> Value -> App Response
forall user inv.
(HasCallStack, MakesValue user, MakesValue inv) =>
user -> inv -> App Response
postConnection Value
owningUser Value
otherUser App Response -> (Response -> App Value) -> App Value
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
201
            Value
payload <- Response
resp.json
            Value
payload 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
"sent"
            Value
payload Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_to" App Value -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value
otherUserId
            Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
payload
        Value
one2one <- Value
conn Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_conversation"
        Value
one2oneDomain <- Value
one2one Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"domain"
        if Value
domainName Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
one2oneDomain
          then (Value, Value, Value) -> App (Value, Value, Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value
owningUser, Value
otherUser, Value
one2one)
          else Value -> App ()
forall user. (HasCallStack, MakesValue user) => user -> App ()
SetupHelpers.deleteUser Value
otherUser App () -> App (Value, Value, Value) -> App (Value, Value, Value)
forall a b. App a -> App b -> App b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> App (Value, Value, Value)
go
  App (Value, Value, Value)
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
  [Value]
l <- Value -> App [Value]
forall u. (HasCallStack, MakesValue u) => u -> App [Value]
getAllConvs Value
user1
  let isWith :: [Value] -> Value -> App Bool
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.
        Bool
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)
        [Value]
others <- Value
c Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"members.others" 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
        [Value]
qIds <- [Value] -> (Value -> App Value) -> App [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Value]
others (Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id")
        Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> App Bool) -> Bool -> App Bool
forall a b. (a -> b) -> a -> b
$ [Value]
qIds [Value] -> [Value] -> Bool
forall a. Eq a => a -> a -> Bool
== [Value]
users Bool -> Bool -> Bool
&& Bool
t
  [Value] -> Value
forall a. HasCallStack => [a] -> a
head ([Value] -> Value) -> App [Value] -> App Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> App Bool) -> [Value] -> App [Value]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ([Value] -> Value -> App Bool
isWith [Value
user2]) [Value]
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 np :: NewProvider
np@(NewProvider {String
Maybe String
newProviderName :: String
newProviderDesc :: String
newProviderEmail :: String
newProviderPassword :: Maybe String
newProviderUrl :: String
$sel:newProviderName:NewProvider :: NewProvider -> String
$sel:newProviderDesc:NewProvider :: NewProvider -> String
$sel:newProviderEmail:NewProvider :: NewProvider -> String
$sel:newProviderPassword:NewProvider :: NewProvider -> Maybe String
$sel:newProviderUrl:NewProvider :: NewProvider -> String
..}) = do
  String
dom <- user -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objDomain user
u
  Value
provider <- user -> NewProvider -> App Value
forall provider user.
(HasCallStack, MakesValue provider, MakesValue user) =>
user -> provider -> App Value
newProvider user
u NewProvider
np
  String
pass <- case Maybe String
newProviderPassword of
    Maybe String
Nothing -> Value
provider 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
  (String
key, String
code) <- do
    Value
pair <-
      String -> String -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> String -> App Response
getProviderActivationCodeInternal String
dom String
newProviderEmail App Response -> (Response -> App Value) -> App Value
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
    String
k <- Value
pair 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
    String
c <- Value
pair 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
    (String, String) -> App (String, String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
k, String
c)
  String -> String -> String -> App ()
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> String -> String -> App ()
activateProvider String
dom String
key String
code
  String -> String -> String -> App ByteString
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> String -> String -> App ByteString
loginProvider String
dom String
newProviderEmail String
pass App ByteString -> Value -> App Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Value
provider

-- | setup a legalhold device for @uid@, authorised by @owner@
--   at the specified port
setUpLHDevice ::
  (HasCallStack, MakesValue tid, MakesValue owner, MakesValue uid) =>
  tid ->
  owner ->
  uid ->
  -- | the host and port the LH service is running on
  (String, Int) ->
  App ()
setUpLHDevice :: forall tid owner uid.
(HasCallStack, MakesValue tid, MakesValue owner, MakesValue uid) =>
tid -> owner -> uid -> (String, Int) -> App ()
setUpLHDevice tid
tid owner
alice uid
bob (String, Int)
lhPort = do
  tid -> owner -> App Response
forall uid tid.
(HasCallStack, MakesValue uid, MakesValue tid) =>
tid -> uid -> App Response
legalholdWhitelistTeam tid
tid owner
alice
    App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

  -- the status messages for these have already been tested
  tid -> owner -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings tid
tid owner
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhPort)
    App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

  tid -> owner -> uid -> App Response
forall userFrom userTo status.
(HasCallStack, MakesValue userFrom, MakesValue userTo,
 MakesValue status) =>
userFrom -> userTo -> status -> App Response
requestLegalHoldDevice tid
tid owner
alice uid
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 => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

  tid -> uid -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice tid
tid uid
bob String
defPassword
    App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

lhDeviceIdOf :: (MakesValue user) => user -> App String
lhDeviceIdOf :: forall user. MakesValue user => user -> App String
lhDeviceIdOf user
bob = do
  String
bobId <- user -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId user
bob
  user -> [String] -> App Response
forall uid tid.
(HasCallStack, MakesValue uid, MakesValue tid) =>
tid -> uid -> App Response
getClientsFull user
bob [String
bobId] App Response -> (Response -> App String) -> App String
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`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

randomScimUser :: App Value
randomScimUser :: App Value
randomScimUser = do
  String
email <- App String
randomEmail
  HasCallStack => String -> String -> App Value
String -> String -> App Value
randomScimUserWith String
email String
email

randomScimUserWith :: (HasCallStack) => String -> String -> App Value
randomScimUserWith :: HasCallStack => String -> String -> App Value
randomScimUserWith String
extId String
email = do
  String
handle <- Int -> Int -> App String
randomHandleWithRange Int
12 Int
128
  Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> App Value) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$
    [Pair] -> Value
object
      [ String
"schemas" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String
"urn:ietf:params:scim:schemas:core:2.0:User"],
        String
"externalId" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
extId,
        String
"emails" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Array -> Value
Array ([Value] -> Array
forall a. [a] -> Vector a
fromList [[Pair] -> Value
object [String
"value" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
email]]),
        String
"userName" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
handle,
        String
"displayName" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
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
  String
payload <- (String
"asset_contents=" <>) (String -> String) -> App String -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App String
HasCallStack => App String
randomId
  Value
asset <- App Response -> (Response -> App Value) -> App Value
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (usr -> String -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> String -> App Response
uploadFreshAsset usr
usr String
payload) (HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201)
  String
dom <- Value
asset Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"domain" 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
  String
key <- Value
asset 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
  Success ([Value]
oldAssets :: [Value]) <- App Response
-> (Response -> App (Result [Value])) -> App (Result [Value])
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (usr -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> App Response
getSelf usr
usr) ((Response -> App (Result [Value])) -> App (Result [Value]))
-> (Response -> App (Result [Value])) -> App (Result [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 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
  App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse
    (usr -> PutSelf -> App Response
forall caller.
(HasCallStack, MakesValue caller) =>
caller -> PutSelf -> App Response
putSelf usr
usr PutSelf
forall a. Default a => a
def {assets = Just (object ["key" .= key, "size" .= "preview", "type" .= "image"] : oldAssets)})
    HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
  (String, String, String) -> App (String, String, String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
dom, String
key, String
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
  String
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)

  String
payload <- 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
forall a. a -> a
id) ((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
    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

  (String, String) -> App (String, String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
locurl, String
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
  (String
dom, String
key, String
_payload) <- usr -> App (String, String, String)
forall usr.
(HasCallStack, MakesValue usr) =>
usr -> App (String, String, String)
uploadProfilePicture usr
usr
  usr -> String -> String -> App (String, String)
forall caller.
(HasCallStack, MakesValue caller) =>
caller -> String -> String -> App (String, String)
downloadProfilePicture usr
usr String
dom String
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
        (String
domain, String
id_) <- a -> App (String, String)
forall usr.
(HasCallStack, MakesValue usr) =>
usr -> App (String, String)
objQid a
user
        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
$ String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
id_ String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
domain
  String
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)
  String -> App a -> App a
forall a. String -> App a -> App a
addFailureContext String
allLines App a
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
  String
jsonStr <- a -> App String
forall user. MakesValue user => user -> App String
prettyJSON a
ctx
  let ctxStr :: String
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]
  String -> App b -> App b
forall a. String -> App a -> App a
addFailureContext String
ctxStr App b
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

registerTestIdPWithMetaWithPrivateCreds :: (HasCallStack, MakesValue owner) => owner -> App (Response, (SAML.IdPMetadata, SAML.SignPrivCreds))
registerTestIdPWithMetaWithPrivateCreds :: forall owner.
(HasCallStack, MakesValue owner) =>
owner -> App (Response, (IdPMetadata, SignPrivCreds))
registerTestIdPWithMetaWithPrivateCreds owner
owner = do
  SampleIdP IdPMetadata
idpmeta SignPrivCreds
pCreds SignCreds
_ SignedCertificate
_ <- App SampleIdP
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadRandom m) =>
m SampleIdP
makeSampleIdPMetadata
  (,(IdPMetadata
idpmeta, SignPrivCreds
pCreds)) (Response -> (Response, (IdPMetadata, SignPrivCreds)))
-> App Response -> App (Response, (IdPMetadata, SignPrivCreds))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> owner -> IdPMetadata -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> IdPMetadata -> App Response
createIdp owner
owner IdPMetadata
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 -> Value -> (String, (SAML.IdPMetadata, SAML.SignPrivCreds)) -> App ()
loginWithSaml :: HasCallStack =>
Bool
-> String
-> Value
-> (String, (IdPMetadata, SignPrivCreds))
-> App ()
loginWithSaml Bool
expectSuccess String
tid Value
scimUser (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 ()
  Response
spmeta <- Domain -> String -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> String -> App Response
getSPMetadata Domain
OwnDomain String
tid
  Response
authnreq <- Domain -> String -> App Response
forall dom.
(HasCallStack, MakesValue dom) =>
dom -> String -> App Response
initiateSamlLogin Domain
OwnDomain String
iid
  String
email <- Value
scimUser Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"externalId" 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
  let nameId :: NameID
nameId = 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
$ Text -> Either String NameID
forall (m :: * -> *). MonadError String m => Text -> m NameID
SAML.emailNameID (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
email)
  SignedAuthnResponse
authnResp <- 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 ()
-> SPMetadata
-> AuthnRequest
-> Bool
-> SimpleSP SignedAuthnResponse
forall extra (m :: * -> *).
(HasCallStack, HasMonadSign m, HasCreateUUID m, HasNow m) =>
NameID
-> SignPrivCreds
-> IdPConfig extra
-> SPMetadata
-> AuthnRequest
-> Bool
-> m SignedAuthnResponse
SAML.mkAuthnResponseWithSubj NameID
nameId SignPrivCreds
privcreds IdPConfig ()
idpConfig (ByteString -> SPMetadata
toSPMetaData Response
spmeta.body) (ByteString -> AuthnRequest
parseAuthnReqResp Response
authnreq.body) Bool
True
  Response
loginResp <- Domain -> String -> SignedAuthnResponse -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> String -> SignedAuthnResponse -> App Response
finalizeSamlLogin Domain
OwnDomain String
tid SignedAuthnResponse
authnResp
  HasCallStack => Response -> App ()
Response -> App ()
validateLoginResp Response
loginResp
  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 ()
    validateLoginResp :: HasCallStack => Response -> App ()
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 ()
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 ()
hasPersistentCookieHeader Response
resp

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

    runSimpleSP :: SAML.SimpleSP a -> App a
    runSimpleSP :: forall a. SimpleSP a -> App a
runSimpleSP 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
      SimpleSPCtx
ctx <- Config -> [IdPConfig ()] -> IO SimpleSPCtx
SAML.mkSimpleSPCtx Config
forall a. HasCallStack => a
undefined []
      Either SimpleError a
result <- SimpleSPCtx -> SimpleSP a -> IO (Either SimpleError a)
forall a. SimpleSPCtx -> SimpleSP a -> IO (Either SimpleError a)
SAML.runSimpleSP SimpleSPCtx
ctx SimpleSP a
action
      a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ a -> Either SimpleError a -> a
forall b a. b -> Either a b -> b
fromRight (String -> a
forall a. HasCallStack => String -> a
error String
"simple sp action failed") Either SimpleError a
result

    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 (Text -> Maybe Text -> Maybe Text -> Name
XML.Name (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"input") (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"http://www.w3.org/1999/xhtml")) Maybe Text
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 -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& Name -> Cursor -> [Text]
XML.attribute (String -> Name
forall a. IsString a => String -> a
fromString String
"value")
            [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& [Text] -> Text
forall a. HasCallStack => [a] -> a
head
            Text -> (Text -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Text -> 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
"")