-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Test.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

-- | Test multi-ingress SSO with an IdP that is not bound to a domain.
--
-- In this case NO SSO login can happen as a redirect to a common IdP would
-- leak information about relationships to a common backend. Also, in reality
-- it is very hard (to impossible for some IdPs) to find a valid and sound
-- configuration for multiple domains at IdP SaaS.
testMultiIngressSSOGeneralIdp :: (HasCallStack) => App ()
testMultiIngressSSOGeneralIdp :: HasCallStack => App ()
testMultiIngressSSOGeneralIdp = 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
      (owner, tid, _) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
      void $ setTeamFeatureStatus owner tid "sso" "enabled"

      (idp, _idpMeta) <- registerTestIdPWithMetaWithPrivateCreds owner
      idpId <- asString $ idp.json %. "id"

      _ernieEmail <- ("ernie@" <>) <$> randomDomain
      checkSPMetadata domain ernieZHost tid

      -- Z-Host set, but IdP has no domain -> failure
      initiateSamlLoginWithZHost domain (Just ernieZHost) idpId >>= assertLabel 404 "not-found"

      precheckSamlLoginWithZHost domain (Just ernieZHost) idpId >>= assertStatus 404

      -- When multi-ingress is configured, domain match is mandatory (empty Z-Host is a no-match)
      initiateSamlLoginWithZHost domain Nothing idpId >>= assertLabel 404 "not-found"

      precheckSamlLoginWithZHost domain Nothing idpId >>= assertStatus 404

      -- Kermit's domain is not configured at all
      _kermitEmail <- ("kermit@" <>) <$> randomDomain
      getSPMetadataWithZHost domain (Just kermitZHost) tid >>= assertLabel 404 "not-found"

      initiateSamlLoginWithZHost domain (Just kermitZHost) idpId >>= assertLabel 404 "not-found"

      precheckSamlLoginWithZHost domain (Just kermitZHost) idpId >>= assertStatus 404

-- | Test multi-ingress SSO with an IdP that is bound to a domain.
--
-- The IdP is created on a multi-ingress domain. The details of managing
-- multi-ingress IdPs are covered in `Test.Spar.MultiIngressIdp`. Here we want
-- to test that logins are possible with such an IdP, but only if the request's
-- and IdP's domains match.
testMultiIngressSSODomainBoundIdp :: (HasCallStack) => App ()
testMultiIngressSSODomainBoundIdp :: HasCallStack => App ()
testMultiIngressSSODomainBoundIdp = 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
      (owner, tid, _) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
      void $ setTeamFeatureStatus owner tid "sso" "enabled"

      (idp, idpMeta) <- registerTestIdPWithMetaWithPrivateCredsForZHost owner (Just ernieZHost)
      idpId <- asString $ idp.json %. "id"

      ernieEmail <- ("ernie@" <>) <$> randomDomain
      checkSPMetadata domain ernieZHost tid
      checkAuthnRequest domain ernieZHost idpId tid

      -- Ernie's precheck succeeds for the correct domain
      precheckSamlLoginWithZHost domain (Just ernieZHost) idpId >>= assertStatus 200

      makeSuccessfulSamlLogin domain ernieZHost tid ernieEmail idpId idpMeta

      -- SAML flow cannot be intercepted and redirected to another domain
      finalizeLoginWithWrongZHost ernieZHost bertZHost domain tid ernieEmail (idpId, idpMeta)
        `bindResponse` \Response
resp -> do
          HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200 Response
resp
          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"

      _bertEmail <- ("bert@" <>) <$> randomDomain
      checkSPMetadata domain bertZHost tid

      -- Bert cannot initiate a login with an Ernie IdP
      initiateSamlLoginWithZHost domain (Just bertZHost) idpId >>= assertLabel 404 "not-found"

      precheckSamlLoginWithZHost domain (Just bertZHost) idpId >>= assertStatus 404

      -- Kermit's domain is not configured at all
      _kermitEmail <- ("kermit@" <>) <$> randomDomain
      getSPMetadataWithZHost domain (Just kermitZHost) tid >>= assertLabel 404 "not-found"

      initiateSamlLoginWithZHost domain (Just kermitZHost) idpId >>= assertLabel 404 "not-found"

      precheckSamlLoginWithZHost domain (Just kermitZHost) idpId >>= assertStatus 404

-- | Test that without multi-ingress configuration, endpoints are domain-agnostic.
--
-- In the standard (non-multi-ingress) case, SAML endpoints work regardless of
-- which domain (Z-Host) is used or if no Z-Host is specified.
testSsoWithoutMultiIngress :: (HasCallStack) => App ()
testSsoWithoutMultiIngress :: HasCallStack => App ()
testSsoWithoutMultiIngress = do
  let host1 :: String
host1 = String
"nginz-https.host1.example.com"
      host2 :: String
host2 = String
"nginz-https.host2.example.com"
      spHost :: String
spHost = String
"nginz-https.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 =
          setField "saml.spSsoUri" ("https://" <> spHost <> "/sso")
            >=> setField "saml.spAppUri" ("https://" <> spHost <> "/")
            >=> setField "saml.contacts" [object ["type" .= "ContactTechnical"]]
      }
    ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
      (owner, tid, _) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
      void $ setTeamFeatureStatus owner tid "sso" "enabled"

      -- Create both types of IdPs
      idpGeneral <- registerTestIdPWithMetaWithPrivateCreds owner
      idpZHost1 <- registerTestIdPWithMetaWithPrivateCredsForZHost owner (Just host1)
      idpZHost2 <- registerTestIdPWithMetaWithPrivateCredsForZHost owner (Just host2)

      forM_
        [idpGeneral, idpZHost1, idpZHost2]
        $ \(Response
idp, (IdPMetadata, SignPrivCreds)
idpMeta) -> do
          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 Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id"

          -- Precheck succeeds from any domain
          precheckSamlLoginWithZHost domain (Just host1) idpId >>= assertStatus 200
          precheckSamlLoginWithZHost domain (Just host2) idpId >>= assertStatus 200
          precheckSamlLoginWithZHost domain Nothing idpId >>= assertStatus 200

          -- SP metadata is accessible from any domain
          getSPMetadataWithZHost domain (Just host1) tid >>= assertStatus 200
          getSPMetadataWithZHost domain (Just host2) tid >>= assertStatus 200
          getSPMetadataWithZHost domain Nothing tid >>= assertStatus 200

          -- AuthnRequest Issuer is same regardless of Z-Host (domain-agnostic)
          checkAuthnRequestBase domain (Just host1) spHost idpId tid
          checkAuthnRequestBase domain (Just host2) spHost idpId tid
          checkAuthnRequestBase domain Nothing spHost idpId tid

          -- Authentication request can be initiated from any domain
          initiateSamlLoginWithZHost domain (Just host1) idpId >>= assertStatus 200
          initiateSamlLoginWithZHost domain (Just host2) idpId >>= assertStatus 200
          initiateSamlLoginWithZHost domain Nothing idpId >>= assertStatus 200

          -- SAML login
          email1 <- ("user1@" <>) <$> randomDomain
          makeSuccessfulSamlLogin domain host1 tid email1 idpId idpMeta

          email2 <- ("user2@" <>) <$> randomDomain
          makeSuccessfulSamlLogin domain host2 tid email2 idpId idpMeta

          email3 <- ("user3@" <>) <$> randomDomain
          let nameId3 = 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
email3)
          void $ loginWithSamlWithZHost Nothing domain True tid nameId3 (idpId, idpMeta)

-- | Check the AuthnRequest by the SP (Wire backend) to be sent to the IdP
--
-- Most important: The @Issuer@ must fit to the multi-ingress domain (@host@).
checkAuthnRequest :: (HasCallStack, MakesValue domain) => domain -> String -> String -> String -> App ()
checkAuthnRequest :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> String -> String -> String -> App ()
checkAuthnRequest domain
domain String
host String
idpId String
tid = domain -> Maybe String -> String -> String -> String -> App ()
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Maybe String -> String -> String -> String -> App ()
checkAuthnRequestBase domain
domain (String -> Maybe String
forall a. a -> Maybe a
Just String
host) String
host String
idpId String
tid

-- | Check the AuthnRequest by the SP (Wire backend) to be sent to the IdP
--
-- Compares the Issuer in the request against an expected target host URL. This
-- allows testing that requests to different hosts produce different (or same)
-- Issuer URLs.
checkAuthnRequestBase :: (HasCallStack, MakesValue domain) => domain -> Maybe String -> String -> String -> String -> App ()
checkAuthnRequestBase :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Maybe String -> String -> String -> String -> App ()
checkAuthnRequestBase domain
domain Maybe String
mbRequestHost String
targetHost String
idpId String
tid =
  domain -> Maybe String -> String -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Maybe String -> String -> App Response
initiateSamlLoginWithZHost domain
domain Maybe String
mbRequestHost String
idpId App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
authnreq -> do
    HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200 Response
authnreq

    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
targetHost 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

-- | Check the metadata of the ServiceProvider (i.e. of the Wire backend on multi-ingress domain @host@)
checkSPMetadata :: (HasCallStack, MakesValue domain) => domain -> String -> String -> App ()
checkSPMetadata :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> String -> String -> App ()
checkSPMetadata domain
domain String
host String
tid =
  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
host) String
tid App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
    HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200 Response
resp

    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
    HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200 Response
res
    user <- Response
res.json Maybe Value -> (Maybe Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& Maybe 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
    user %. "status" `shouldMatch` "active"
    user %. "email" `shouldMatch` 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 ()
  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
  authnreq <- initiateSamlLoginWithZHost domain (Just zHost1) iid
  let 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 = ByteString -> SPMetadata
toSPMetaData Response
spmeta.body
      parsedAuthnReq = ByteString -> AuthnRequest
parseAuthnReqResp Response
authnreq.body
  authnReqResp <- makeAuthnResponse nameId privcreds idpConfig spMetaData parsedAuthnReq
  finalizeSamlLoginWithZHost domain (Just zHost2) tid 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