module Test.Spar.MultiIngressSSO where

import API.BrigInternal
import API.Common
import API.GalleyInternal
import API.Spar
import Control.Arrow ((>>>))
import Data.ByteString.Base64
import Data.String.Conversions (cs)
import qualified Data.Text as T
import qualified Data.UUID as UUID
import GHC.Stack
import qualified SAML2.WebSSO as SAML
import SetupHelpers
import qualified Testlib.KleisliXML as KXML
import Testlib.Prelude
import qualified Text.XML as XML
import qualified Text.XML.Cursor as XML
import qualified Text.XML.DSig as SAML

testMultiIngressSSO :: (HasCallStack) => App ()
testMultiIngressSSO :: HasCallStack => App ()
testMultiIngressSSO = do
  let ernieZHost :: String
ernieZHost = String
"nginz-https.ernie.example.com"
      bertZHost :: String
bertZHost = String
"nginz-https.bert.example.com"
      kermitZHost :: String
kermitZHost = String
"nginz-https.kermit.example.com"

  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend
    ServiceOverrides
forall a. Default a => a
def
      { sparCfg =
          removeField "saml.spSsoUri"
            >=> removeField "saml.spAppUri"
            >=> removeField "saml.contacts"
            >=> setField
              "saml.spDomainConfigs"
              ( object
                  [ ernieZHost
                      .= object
                        [ "spAppUri" .= "https://webapp.ernie.example.com",
                          "spSsoUri" .= "https://nginz-https.ernie.example.com/sso",
                          "contacts" .= [object ["type" .= "ContactTechnical"]]
                        ],
                    bertZHost
                      .= object
                        [ "spAppUri" .= "https://webapp.bert.example.com",
                          "spSsoUri" .= "https://nginz-https.bert.example.com/sso",
                          "contacts" .= [object ["type" .= "ContactTechnical"]]
                        ]
                  ]
              )
      }
    ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
      (Value
owner, String
tid, [Value]
_) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
      App Response -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Response -> App ()) -> App Response -> App ()
forall a b. (a -> b) -> a -> b
$ Value -> String -> String -> String -> App Response
forall domain team.
(HasCallStack, MakesValue domain, MakesValue team) =>
domain -> team -> String -> String -> App Response
setTeamFeatureStatus Value
owner String
tid String
"sso" String
"enabled"

      (Response
idp, (IdPMetadata, SignPrivCreds)
idpMeta) <- Value -> App (Response, (IdPMetadata, SignPrivCreds))
forall owner.
(HasCallStack, MakesValue owner) =>
owner -> App (Response, (IdPMetadata, SignPrivCreds))
registerTestIdPWithMetaWithPrivateCreds Value
owner
      String
idpId <- App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString (App Value -> App String) -> App Value -> App String
forall a b. (a -> b) -> a -> b
$ Response
idp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id"

      String
ernieEmail <- (String
"ernie@" <>) (String -> String) -> App String -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App String
randomDomain
      HasCallStack => String -> String -> String -> App ()
String -> String -> String -> App ()
checkMetadataSPIssuer String
domain String
ernieZHost String
tid
      HasCallStack => String -> String -> String -> String -> App ()
String -> String -> String -> String -> App ()
checkAuthnSPIssuer String
domain String
ernieZHost String
idpId String
tid

      String
-> String
-> String
-> String
-> String
-> (String, (IdPMetadata, SignPrivCreds))
-> App Response
forall domain.
(MakesValue domain, HasCallStack) =>
String
-> String
-> domain
-> String
-> String
-> (String, (IdPMetadata, SignPrivCreds))
-> App Response
finalizeLoginWithWrongZHost String
bertZHost String
ernieZHost String
domain String
tid String
ernieEmail (String
idpId, (IdPMetadata, SignPrivCreds)
idpMeta) 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

        let titleName :: Name
titleName = Text -> Maybe Text -> Maybe Text -> Name
XML.Name (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"title") (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
            getRoot :: ByteString -> Maybe XML.Cursor
            getRoot :: ByteString -> Maybe Cursor
getRoot = Cursor -> Maybe Cursor
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cursor -> Maybe Cursor)
-> (ByteString -> Cursor) -> ByteString -> Maybe Cursor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Cursor
KXML.parseXml (Text -> Cursor) -> (ByteString -> Text) -> ByteString -> Cursor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs

        ((ByteString -> Maybe Cursor
getRoot (ByteString -> Maybe Cursor)
-> (Cursor -> Maybe Text) -> ByteString -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> Maybe Cursor
KXML.findElement Name
titleName (Cursor -> Maybe Cursor)
-> (Cursor -> Maybe Text) -> Cursor -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> Maybe Text
KXML.getContent) Response
resp.body)
          Maybe Text -> Maybe String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (String -> Maybe String
forall a. a -> Maybe a
Just String
"wire:sso:error:forbidden")

      String
-> String
-> String
-> String
-> String
-> (IdPMetadata, SignPrivCreds)
-> App ()
forall domain.
MakesValue domain =>
domain
-> String
-> String
-> String
-> String
-> (IdPMetadata, SignPrivCreds)
-> App ()
makeSuccessfulSamlLogin String
domain String
ernieZHost String
tid String
ernieEmail String
idpId (IdPMetadata, SignPrivCreds)
idpMeta

      String
bertEmail <- (String
"bert@" <>) (String -> String) -> App String -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App String
randomDomain
      HasCallStack => String -> String -> String -> App ()
String -> String -> String -> App ()
checkMetadataSPIssuer String
domain String
bertZHost String
tid
      HasCallStack => String -> String -> String -> String -> App ()
String -> String -> String -> String -> App ()
checkAuthnSPIssuer String
domain String
bertZHost String
idpId String
tid

      String
-> String
-> String
-> String
-> String
-> (IdPMetadata, SignPrivCreds)
-> App ()
forall domain.
MakesValue domain =>
domain
-> String
-> String
-> String
-> String
-> (IdPMetadata, SignPrivCreds)
-> App ()
makeSuccessfulSamlLogin String
domain String
bertZHost String
tid String
bertEmail String
idpId (IdPMetadata, SignPrivCreds)
idpMeta

      -- Kermit's domain is not configured
      String
kermitEmail <- (String
"kermit@" <>) (String -> String) -> App String -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App String
randomDomain
      String -> Maybe String -> String -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Maybe String -> String -> App Response
getSPMetadataWithZHost String
domain (String -> Maybe String
forall a. a -> Maybe a
Just String
kermitZHost) String
tid 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
404
        Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"not-found"

      String -> Maybe String -> String -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Maybe String -> String -> App Response
initiateSamlLoginWithZHost String
domain (String -> Maybe String
forall a. a -> Maybe a
Just String
kermitZHost) String
idpId App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
authnreq -> do
        Response
authnreq.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
404
        Response
authnreq.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"not-found"

      String
-> String
-> String
-> String
-> String
-> (String, (IdPMetadata, SignPrivCreds))
-> App Response
forall domain.
(MakesValue domain, HasCallStack) =>
String
-> String
-> domain
-> String
-> String
-> (String, (IdPMetadata, SignPrivCreds))
-> App Response
finalizeLoginWithWrongZHost String
bertZHost String
kermitZHost String
domain String
tid String
kermitEmail (String
idpId, (IdPMetadata, SignPrivCreds)
idpMeta) 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
404

checkAuthnSPIssuer :: (HasCallStack) => String -> String -> String -> String -> App ()
checkAuthnSPIssuer :: HasCallStack => String -> String -> String -> String -> App ()
checkAuthnSPIssuer String
domain String
host String
idpId String
tid =
  String -> Maybe String -> String -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Maybe String -> String -> App Response
initiateSamlLoginWithZHost String
domain (String -> Maybe String
forall a. a -> Maybe a
Just String
host) String
idpId App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
authnreq -> do
    Response
authnreq.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

    let inputName :: Name
inputName = 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
        valueName :: Name
valueName = Text -> Maybe Text -> Maybe Text -> Name
XML.Name (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"value") Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
        issuerName :: Name
issuerName = Text -> Maybe Text -> Maybe Text -> Name
XML.Name (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"Issuer") (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"urn:oasis:names:tc:SAML:2.0:assertion")) Maybe Text
forall a. Maybe a
Nothing

        decodeBase64 :: T.Text -> Maybe ByteString
        decodeBase64 :: Text -> Maybe ByteString
decodeBase64 = (String -> Maybe ByteString)
-> (ByteString -> Maybe ByteString)
-> Either String ByteString
-> Maybe ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ByteString -> String -> Maybe ByteString
forall a b. a -> b -> a
const Maybe ByteString
forall a. Maybe a
Nothing) ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Either String ByteString -> Maybe ByteString)
-> (Text -> Either String ByteString) -> Text -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
Data.ByteString.Base64.decode (ByteString -> Either String ByteString)
-> (Text -> ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs

        targetSPUrl :: Text
targetSPUrl = String -> Text
T.pack (String
"https://" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
host String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/sso/finalize-login/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tid)

        getIssuerUrl :: ByteString -> Maybe T.Text
        getIssuerUrl :: ByteString -> Maybe Text
getIssuerUrl =
          (Cursor -> Maybe Cursor
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cursor -> Maybe Cursor)
-> (ByteString -> Cursor) -> ByteString -> Maybe Cursor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Cursor
KXML.parseXml (Text -> Cursor) -> (ByteString -> Text) -> ByteString -> Cursor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs)
            (ByteString -> Maybe Cursor)
-> (Cursor -> Maybe Text) -> ByteString -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> Maybe Cursor
KXML.findElement Name
inputName
            (Cursor -> Maybe Cursor)
-> (Cursor -> Maybe Text) -> Cursor -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> Maybe Text
KXML.getAttribute Name
valueName
            (Cursor -> Maybe Text)
-> (Text -> Maybe Text) -> Cursor -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Text)
-> (Text -> Maybe ByteString) -> Text -> Maybe ByteString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Text -> Maybe ByteString
decodeBase64)
            (Text -> Maybe ByteString)
-> (ByteString -> Maybe Text) -> Text -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text)
-> (Text -> Maybe Cursor) -> ByteString -> Maybe Cursor
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Cursor -> Maybe Cursor
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cursor -> Maybe Cursor)
-> (Text -> Cursor) -> Text -> Maybe Cursor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Cursor
KXML.parseXml))
            (ByteString -> Maybe Cursor)
-> (Cursor -> Maybe Text) -> ByteString -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> Maybe Cursor
KXML.findElement Name
issuerName
            (Cursor -> Maybe Cursor)
-> (Cursor -> Maybe Text) -> Cursor -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> Maybe Text
KXML.getContent

    ByteString -> Maybe Text
getIssuerUrl Response
authnreq.body Maybe Text -> Text -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Text
targetSPUrl

checkMetadataSPIssuer :: (HasCallStack) => String -> String -> String -> App ()
checkMetadataSPIssuer :: HasCallStack => String -> String -> String -> App ()
checkMetadataSPIssuer String
domain String
host String
tid =
  String -> Maybe String -> String -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Maybe String -> String -> App Response
getSPMetadataWithZHost String
domain (String -> Maybe String
forall a. a -> Maybe a
Just String
host) String
tid 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

    let spSsoDescName :: Name
spSsoDescName = Text -> Maybe Text -> Maybe Text -> Name
XML.Name (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"SPSSODescriptor") (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"urn:oasis:names:tc:SAML:2.0:metadata")) (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"md"))
        acsName :: Name
acsName = Text -> Maybe Text -> Maybe Text -> Name
XML.Name (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"AssertionConsumerService") (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"urn:oasis:names:tc:SAML:2.0:metadata")) (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"md"))
        orgName :: Name
orgName = Text -> Maybe Text -> Maybe Text -> Name
XML.Name (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"Organization") (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"urn:oasis:names:tc:SAML:2.0:metadata")) (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"md"))
        orgUrlName :: Name
orgUrlName = Text -> Maybe Text -> Maybe Text -> Name
XML.Name (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"OrganizationURL") (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"urn:oasis:names:tc:SAML:2.0:metadata")) (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"md"))
        entityIdName :: Name
entityIdName = Text -> Maybe Text -> Maybe Text -> Name
XML.Name (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"entityID") Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
        locationName :: Name
locationName = Text -> Maybe Text -> Maybe Text -> Name
XML.Name (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
"Location") Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing

        targetSPUrl :: Text
targetSPUrl = String -> Text
T.pack (String
"https://" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
host String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/sso/finalize-login/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tid)

        root :: Cursor
root = (Text -> Cursor
KXML.parseXml (Text -> Cursor) -> (ByteString -> Text) -> ByteString -> Cursor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs) Response
resp.body

        getLocation :: XML.Cursor -> Maybe T.Text
        getLocation :: Cursor -> Maybe Text
getLocation =
          Name -> Cursor -> Maybe Cursor
KXML.findElement Name
spSsoDescName
            (Cursor -> Maybe Cursor)
-> (Cursor -> Maybe Text) -> Cursor -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> Maybe Cursor
KXML.findElement Name
acsName
            (Cursor -> Maybe Cursor)
-> (Cursor -> Maybe Text) -> Cursor -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> Maybe Text
KXML.getAttribute Name
locationName

        getOrgUrlContent :: XML.Cursor -> Maybe T.Text
        getOrgUrlContent :: Cursor -> Maybe Text
getOrgUrlContent =
          Name -> Cursor -> Maybe Cursor
KXML.findElement Name
spSsoDescName
            (Cursor -> Maybe Cursor)
-> (Cursor -> Maybe Text) -> Cursor -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> Maybe Cursor
KXML.findElement Name
orgName
            (Cursor -> Maybe Cursor)
-> (Cursor -> Maybe Text) -> Cursor -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> Maybe Cursor
KXML.findElement Name
orgUrlName
            (Cursor -> Maybe Cursor)
-> (Cursor -> Maybe Text) -> Cursor -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> Maybe Text
KXML.getContent

    Name -> Cursor -> Maybe Text
KXML.getAttribute Name
entityIdName Cursor
root Maybe Text -> Maybe Text -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Text -> Maybe Text
forall a. a -> Maybe a
Just Text
targetSPUrl
    Cursor -> Maybe Text
getLocation Cursor
root Maybe Text -> Maybe Text -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Text -> Maybe Text
forall a. a -> Maybe a
Just Text
targetSPUrl
    Cursor -> Maybe Text
getOrgUrlContent Cursor
root Maybe Text -> Maybe Text -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Text -> Maybe Text
forall a. a -> Maybe a
Just Text
targetSPUrl

makeSuccessfulSamlLogin ::
  (MakesValue domain) =>
  domain ->
  String ->
  String ->
  String ->
  String ->
  (SAML.IdPMetadata, SAML.SignPrivCreds) ->
  App ()
makeSuccessfulSamlLogin :: forall domain.
MakesValue domain =>
domain
-> String
-> String
-> String
-> String
-> (IdPMetadata, SignPrivCreds)
-> App ()
makeSuccessfulSamlLogin domain
domain String
host String
tid String
email String
idpId (IdPMetadata, SignPrivCreds)
idpMeta = do
  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)
  App (Maybe String, SignedAuthnResponse) -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App (Maybe String, SignedAuthnResponse) -> App ())
-> App (Maybe String, SignedAuthnResponse) -> App ()
forall a b. (a -> b) -> a -> b
$ 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 (String -> Maybe String
forall a. a -> Maybe a
Just String
host) domain
domain Bool
True String
tid NameID
nameId (String
idpId, (IdPMetadata, SignPrivCreds)
idpMeta)
  domain -> String -> App ()
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> String -> App ()
activateEmail domain
domain String
email
  domain -> [String] -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> [String] -> App Response
getUsersByEmail domain
domain [String
email] App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
res -> do
    Response
res.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Value
user <- Response
res.json 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 a. (HasCallStack, MakesValue a) => a -> 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 Value
forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne
    Value
user 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
"active"
    Value
user Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"email" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
email

finalizeLoginWithWrongZHost ::
  (MakesValue domain, HasCallStack) =>
  String ->
  String ->
  domain ->
  String ->
  String ->
  (String, (SAML.IdPMetadata, SAML.SignPrivCreds)) ->
  App Response
finalizeLoginWithWrongZHost :: forall domain.
(MakesValue domain, HasCallStack) =>
String
-> String
-> domain
-> String
-> String
-> (String, (IdPMetadata, SignPrivCreds))
-> App Response
finalizeLoginWithWrongZHost String
zHost1 String
zHost2 domain
domain String
tid String
email (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 -> Maybe String -> String -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Maybe String -> String -> App Response
getSPMetadataWithZHost domain
domain (String -> Maybe String
forall a. a -> Maybe a
Just String
zHost1) String
tid
  Response
authnreq <- domain -> Maybe String -> String -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Maybe String -> String -> App Response
initiateSamlLoginWithZHost domain
domain (String -> Maybe String
forall a. a -> Maybe a
Just String
zHost1) String
iid
  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)
      spMetaData :: SPMetadata
spMetaData = ByteString -> SPMetadata
toSPMetaData Response
spmeta.body
      parsedAuthnReq :: AuthnRequest
parsedAuthnReq = ByteString -> AuthnRequest
parseAuthnReqResp Response
authnreq.body
  SignedAuthnResponse
authnReqResp <- NameID
-> SignPrivCreds
-> IdPConfig ()
-> SPMetadata
-> AuthnRequest
-> App SignedAuthnResponse
forall extra.
NameID
-> SignPrivCreds
-> IdPConfig extra
-> SPMetadata
-> AuthnRequest
-> App SignedAuthnResponse
makeAuthnResponse NameID
nameId SignPrivCreds
privcreds IdPConfig ()
idpConfig SPMetadata
spMetaData AuthnRequest
parsedAuthnReq
  domain
-> Maybe String -> String -> SignedAuthnResponse -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain
-> Maybe String -> String -> SignedAuthnResponse -> App Response
finalizeSamlLoginWithZHost domain
domain (String -> Maybe String
forall a. a -> Maybe a
Just String
zHost2) String
tid SignedAuthnResponse
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