-- 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.
--
-- The IdP is created via a non-multi-ingress way/domain. It is valid for all
-- domains - no matter if they are configured as multi-ingress domains or not.
-- However, the SP must be consistent in the communication: If the SAML login
-- flow was started on one domain, it must return to exactly this domain.
testMultiIngressSSOGeneralIdp :: (HasCallStack) => App ()
testMultiIngressSSOGeneralIdp :: HasCallStack => App ()
testMultiIngressSSOGeneralIdp = HasCallStack =>
(forall owner.
 (HasCallStack, MakesValue owner) =>
 owner
 -> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds)))
-> App ()
(forall owner.
 (HasCallStack, MakesValue owner) =>
 owner
 -> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds)))
-> App ()
multiIngressSSOCommonTest (App (Response, (IdPMetadata, SignPrivCreds))
-> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds))
forall a b. a -> b -> a
const (App (Response, (IdPMetadata, SignPrivCreds))
 -> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds)))
-> (owner -> App (Response, (IdPMetadata, SignPrivCreds)))
-> owner
-> Maybe String
-> App (Response, (IdPMetadata, SignPrivCreds))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. owner -> App (Response, (IdPMetadata, SignPrivCreds))
forall owner.
(HasCallStack, MakesValue owner) =>
owner -> App (Response, (IdPMetadata, SignPrivCreds))
registerTestIdPWithMetaWithPrivateCreds)

-- | 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, ensuring we haven't
-- broken basic functionality.
testMultiIngressSSODomainBoundIdp :: (HasCallStack) => App ()
testMultiIngressSSODomainBoundIdp :: HasCallStack => App ()
testMultiIngressSSODomainBoundIdp = HasCallStack =>
(forall owner.
 (HasCallStack, MakesValue owner) =>
 owner
 -> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds)))
-> App ()
(forall owner.
 (HasCallStack, MakesValue owner) =>
 owner
 -> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds)))
-> App ()
multiIngressSSOCommonTest owner
-> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds))
forall owner.
(HasCallStack, MakesValue owner) =>
owner
-> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds))
registerTestIdPWithMetaWithPrivateCredsForZHost

multiIngressSSOCommonTest ::
  (HasCallStack) =>
  ( forall owner.
    (HasCallStack, MakesValue owner) =>
    owner ->
    Maybe String ->
    App (Response, (SAML.IdPMetadata, SAML.SignPrivCreds))
  ) ->
  App ()
multiIngressSSOCommonTest :: HasCallStack =>
(forall owner.
 (HasCallStack, MakesValue owner) =>
 owner
 -> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds)))
-> App ()
multiIngressSSOCommonTest forall owner.
(HasCallStack, MakesValue owner) =>
owner
-> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds))
registerTestIdPWithMetaWithPrivateCredsFn = 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
-> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds))
forall owner.
(HasCallStack, MakesValue owner) =>
owner
-> Maybe String -> App (Response, (IdPMetadata, SignPrivCreds))
registerTestIdPWithMetaWithPrivateCredsFn Value
owner (String -> Maybe String
forall a. a -> Maybe a
Just String
ernieZHost)
      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 ()
checkSPMetadata String
domain String
ernieZHost String
tid
      HasCallStack => String -> String -> String -> String -> App ()
String -> String -> String -> String -> App ()
checkAuthnRequest 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 ()
checkSPMetadata String
domain String
bertZHost String
tid
      HasCallStack => String -> String -> String -> String -> App ()
String -> String -> String -> String -> App ()
checkAuthnRequest 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

-- | 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) => String -> String -> String -> String -> App ()
checkAuthnRequest :: HasCallStack => String -> String -> String -> String -> App ()
checkAuthnRequest 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

-- | Check the metadata of the ServiceProvider (i.e. of the Wire backend on multi-ingress domain @host@)
checkSPMetadata :: (HasCallStack) => String -> String -> String -> App ()
checkSPMetadata :: HasCallStack => String -> String -> String -> App ()
checkSPMetadata 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