{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unused-binds -Wno-incomplete-patterns -Wno-incomplete-uni-patterns -Wno-orphans #-}

-- 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 SAML2.WebSSO.Test.Util.VendorCompatibility
  ( vendorCompatibility,
  )
where

import Control.Concurrent.MVar
import Control.Lens
import Control.Monad
import Data.ByteString.Base64.Lazy qualified as EL (encode)
import Data.Map qualified as Map
import Data.Maybe (fromJust)
import Data.String.Conversions
import Data.UUID qualified as UUID
import Network.HTTP.Types.Status (statusCode)
import Network.Wai.Test
import SAML2.WebSSO
import SAML2.WebSSO.Test.Util.Misc
import SAML2.WebSSO.Test.Util.TestSP
import SAML2.WebSSO.Test.Util.Types
import Servant
import Test.Hspec hiding (pending)
import Test.Hspec.Wai
import Text.Show.Pretty (ppShow)
import URI.ByteString as URI

testAuthRespApp :: (HasCallStack) => URI.URI -> SpecWith (CtxV, Application) -> Spec
testAuthRespApp :: HasCallStack => URI -> SpecWith (CtxV, Application) -> Spec
testAuthRespApp URI
ssoURI =
  Proxy ("sso" :> APIAuthResp')
-> ServerT ("sso" :> APIAuthResp') TestSP
-> IO CtxV
-> SpecWith (CtxV, Application)
-> Spec
forall api.
HasServer api '[] =>
Proxy api
-> ServerT api TestSP
-> IO CtxV
-> SpecWith (CtxV, Application)
-> Spec
withapp
    (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @("sso" :> APIAuthResp'))
    (Maybe (IdPConfigSPId TestSP)
-> TestSP Issuer
-> TestSP URI
-> HandleVerdict TestSP
-> AuthnResponseBody
-> TestSP (WithCookieAndLocation ST)
forall (m :: * -> *) err extra.
(SPStoreIdP (Error err) m, SP m, MonadError (Error err) m,
 SPStore m, extra ~ IdPConfigExtra m) =>
Maybe (IdPConfigSPId m)
-> m Issuer
-> m URI
-> HandleVerdict m
-> AuthnResponseBody
-> m (WithCookieAndLocation ST)
authresp' Maybe Void
Maybe (IdPConfigSPId TestSP)
forall a. Maybe a
Nothing TestSP Issuer
spissuer TestSP URI
respuri (OnSuccessRedirect TestSP -> HandleVerdict TestSP
forall (m :: * -> *). OnSuccessRedirect m -> HandleVerdict m
HandleVerdictRedirect (SubjectFoldCase -> OnSuccessRedirect TestSP
forall (m :: * -> *).
(Monad m, SP m) =>
SubjectFoldCase -> OnSuccessRedirect m
simpleOnSuccess SubjectFoldCase
SubjectFoldCase)))
    IO CtxV
forall (m :: * -> *). MonadIO m => m CtxV
mkTestCtxSimple
  where
    spissuer :: TestSP Issuer
spissuer = URI -> Issuer
Issuer (URI -> Issuer) -> TestSP URI -> TestSP Issuer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestSP URI
respuri
    respuri :: TestSP URI
respuri = URI -> TestSP URI
forall a. a -> TestSP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
ssoURI

vendorCompatibility :: (HasCallStack) => FilePath -> URI.URI -> Spec
vendorCompatibility :: HasCallStack => FilePath -> URI -> Spec
vendorCompatibility FilePath
filePath URI
ssoURI = HasCallStack => URI -> SpecWith (CtxV, Application) -> Spec
URI -> SpecWith (CtxV, Application) -> Spec
testAuthRespApp URI
ssoURI (SpecWith (CtxV, Application) -> Spec)
-> SpecWith (CtxV, Application) -> Spec
forall a b. (a -> b) -> a -> b
$ do
  let filePathMeta :: FilePath
filePathMeta = FilePath
"vendors/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
filePath FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-metadata.xml"
      filePathResp :: FilePath
filePathResp = FilePath
"vendors/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
filePath FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-authnresp.xml"

  FilePath
-> ((CtxV, Application) -> IO ())
-> SpecWith (Arg ((CtxV, Application) -> IO ()))
forall a.
(HasCallStack, Example a) =>
FilePath -> a -> SpecWith (Arg a)
it FilePath
filePath (((CtxV, Application) -> IO ()) -> SpecWith (CtxV, Application))
-> ((CtxV -> WaiSession () ()) -> (CtxV, Application) -> IO ())
-> (CtxV -> WaiSession () ())
-> SpecWith (CtxV, Application)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CtxV -> WaiSession () ()) -> (CtxV, Application) -> IO ()
forall a. (CtxV -> WaiSession () a) -> (CtxV, Application) -> IO a
runtest ((CtxV -> WaiSession () ()) -> SpecWith (CtxV, Application))
-> (CtxV -> WaiSession () ()) -> SpecWith (CtxV, Application)
forall a b. (a -> b) -> a -> b
$ \CtxV
ctx -> do
    idpmeta :: IdPMetadata <- FilePath -> WaiSession () LT
forall (m :: * -> *). MonadIO m => FilePath -> m LT
readSampleIO FilePath
filePathMeta WaiSession () LT
-> (LT -> WaiSession () IdPMetadata) -> WaiSession () IdPMetadata
forall a b.
WaiSession () a -> (a -> WaiSession () b) -> WaiSession () b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> WaiSession () IdPMetadata)
-> (IdPMetadata -> WaiSession () IdPMetadata)
-> Either FilePath IdPMetadata
-> WaiSession () IdPMetadata
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> WaiSession () IdPMetadata
forall a. HasCallStack => FilePath -> a
error (FilePath -> WaiSession () IdPMetadata)
-> (FilePath -> FilePath) -> FilePath -> WaiSession () IdPMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. Show a => a -> FilePath
show) IdPMetadata -> WaiSession () IdPMetadata
forall a. a -> WaiSession () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath IdPMetadata -> WaiSession () IdPMetadata)
-> (LT -> Either FilePath IdPMetadata)
-> LT
-> WaiSession () IdPMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LT -> Either FilePath IdPMetadata
forall (m :: * -> *) a.
(HasXMLRoot a, MonadError FilePath m) =>
LT -> m a
decode
    liftIO $ length (show idpmeta) `shouldNotBe` 0

    checkAuthResp <- liftIO $ doesSampleExistIO filePathResp
    if not checkAuthResp
      then liftIO $ do
        putStrLn $ "*** no response for filePath (" <> filePathResp <> ") [skipping]"
      else do
        authnrespRaw :: LT <- readSampleIO filePathResp
        authnresp :: AuthnResponse <- either (error . show) pure $ decode authnrespRaw
        let idpcfg = IdPConfig {()
IdPId
IdPMetadata
_idpId :: IdPId
_idpMetadata :: IdPMetadata
_idpExtraInfo :: ()
_idpExtraInfo :: ()
_idpMetadata :: IdPMetadata
_idpId :: IdPId
..}
              where
                _idpId :: IdPId
_idpId = UUID -> IdPId
IdPId UUID
UUID.nil
                _idpMetadata :: IdPMetadata
_idpMetadata = IdPMetadata
idpmeta
                _idpExtraInfo :: ()
_idpExtraInfo = ()
            sampleidp :: SampleIdP
            sampleidp = IdPMetadata
-> SignPrivCreds -> SignCreds -> SignedCertificate -> SampleIdP
SampleIdP IdPMetadata
idpmeta (FilePath -> SignPrivCreds
forall a. HasCallStack => FilePath -> a
error FilePath
"no private credentials available") SignCreds
forall a. HasCallStack => a
undefined SignedCertificate
forall a. HasCallStack => a
undefined

        let -- NB: reqstore, new are taken from the unsigned AuthnResponse header.  the test still
            -- makes perfect sense given the information is available in the header.  if it is
            -- not, just dig into the assertions and take the information from there.
            -- authnresp inResponseTo, with comfortable end of life.
            reqstore :: Map.Map (ID AuthnRequest) (Issuer, Time)
            reqstore = ID AuthnRequest
-> (Issuer, Time) -> Map (ID AuthnRequest) (Issuer, Time)
forall k a. k -> a -> Map k a
Map.singleton (Maybe (ID AuthnRequest) -> ID AuthnRequest
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (ID AuthnRequest) -> ID AuthnRequest)
-> Maybe (ID AuthnRequest) -> ID AuthnRequest
forall a b. (a -> b) -> a -> b
$ AuthnResponse
authnresp AuthnResponse
-> Getting
     (Maybe (ID AuthnRequest)) AuthnResponse (Maybe (ID AuthnRequest))
-> Maybe (ID AuthnRequest)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (ID AuthnRequest)) AuthnResponse (Maybe (ID AuthnRequest))
forall payload (f :: * -> *).
Functor f =>
(Maybe (ID AuthnRequest) -> f (Maybe (ID AuthnRequest)))
-> Response payload -> f (Response payload)
rspInRespTo) (Issuer
idpIssuer, Time
timeInALongTime)

            -- The issuer we expect in the SAML response (IdP -> SP)
            idpIssuer = IdPConfig ()
idpcfg IdPConfig () -> Getting Issuer (IdPConfig ()) Issuer -> Issuer
forall s a. s -> Getting a s a -> a
^. (IdPMetadata -> Const Issuer IdPMetadata)
-> IdPConfig () -> Const Issuer (IdPConfig ())
forall extra (f :: * -> *).
Functor f =>
(IdPMetadata -> f IdPMetadata)
-> IdPConfig extra -> f (IdPConfig extra)
idpMetadata ((IdPMetadata -> Const Issuer IdPMetadata)
 -> IdPConfig () -> Const Issuer (IdPConfig ()))
-> ((Issuer -> Const Issuer Issuer)
    -> IdPMetadata -> Const Issuer IdPMetadata)
-> Getting Issuer (IdPConfig ()) Issuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Issuer -> Const Issuer Issuer)
-> IdPMetadata -> Const Issuer IdPMetadata
Lens' IdPMetadata Issuer
edIssuer
            -- 1 second after authnresp IssueInstant
            now :: Time
            now = NominalDiffTime -> Time -> Time
addTime NominalDiffTime
1 (Time -> Time) -> Time -> Time
forall a b. (a -> b) -> a -> b
$ AuthnResponse
authnresp AuthnResponse -> Getting Time AuthnResponse Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time AuthnResponse Time
forall payload (f :: * -> *).
Functor f =>
(Time -> f Time) -> Response payload -> f (Response payload)
rspIssueInstant

        liftIO . modifyMVar_ ctx $ \Ctx
ctx' ->
          Ctx -> IO Ctx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx -> IO Ctx) -> Ctx -> IO Ctx
forall a b. (a -> b) -> a -> b
$
            Ctx
ctx'
              Ctx -> (Ctx -> Ctx) -> Ctx
forall a b. a -> (a -> b) -> b
& ([(IdPConfig (), SampleIdP)]
 -> Identity [(IdPConfig (), SampleIdP)])
-> Ctx -> Identity Ctx
Lens' Ctx [(IdPConfig (), SampleIdP)]
ctxIdPs (([(IdPConfig (), SampleIdP)]
  -> Identity [(IdPConfig (), SampleIdP)])
 -> Ctx -> Identity Ctx)
-> [(IdPConfig (), SampleIdP)] -> Ctx -> Ctx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(IdPConfig ()
idpcfg, SampleIdP
sampleidp)]
              -- & ctxConfig . cfgSPAppURI .~ _
              -- (the SPAppURI default is a incorrect, but that should not invalidate the test)
              Ctx -> (Ctx -> Ctx) -> Ctx
forall a b. a -> (a -> b) -> b
& (Config -> Identity Config) -> Ctx -> Identity Ctx
Lens' Ctx Config
ctxConfig ((Config -> Identity Config) -> Ctx -> Identity Ctx)
-> ((URI -> Identity URI) -> Config -> Identity Config)
-> (URI -> Identity URI)
-> Ctx
-> Identity Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either
   MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
 -> Identity
      (Either
         MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)))
-> Config -> Identity Config
Lens'
  Config
  (Either
     MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig))
cfgDomainConfigs ((Either
    MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
  -> Identity
       (Either
          MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)))
 -> Config -> Identity Config)
-> ((URI -> Identity URI)
    -> Either
         MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
    -> Identity
         (Either
            MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)))
-> (URI -> Identity URI)
-> Config
-> Identity Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiIngressDomainConfig -> Identity MultiIngressDomainConfig)
-> Either
     MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
-> Identity
     (Either
        MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig))
forall a c b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Either a c) (f (Either b c))
_Left ((MultiIngressDomainConfig -> Identity MultiIngressDomainConfig)
 -> Either
      MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
 -> Identity
      (Either
         MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)))
-> ((URI -> Identity URI)
    -> MultiIngressDomainConfig -> Identity MultiIngressDomainConfig)
-> (URI -> Identity URI)
-> Either
     MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
-> Identity
     (Either
        MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (URI -> Identity URI)
-> MultiIngressDomainConfig -> Identity MultiIngressDomainConfig
Lens' MultiIngressDomainConfig URI
cfgSPSsoURI ((URI -> Identity URI) -> Ctx -> Identity Ctx) -> URI -> Ctx -> Ctx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ URI
ssoURI
              Ctx -> (Ctx -> Ctx) -> Ctx
forall a b. a -> (a -> b) -> b
& (Map (ID AuthnRequest) (Issuer, Time)
 -> Identity (Map (ID AuthnRequest) (Issuer, Time)))
-> Ctx -> Identity Ctx
Lens' Ctx (Map (ID AuthnRequest) (Issuer, Time))
ctxRequestStore ((Map (ID AuthnRequest) (Issuer, Time)
  -> Identity (Map (ID AuthnRequest) (Issuer, Time)))
 -> Ctx -> Identity Ctx)
-> Map (ID AuthnRequest) (Issuer, Time) -> Ctx -> Ctx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (ID AuthnRequest) (Issuer, Time)
reqstore
              Ctx -> (Ctx -> Ctx) -> Ctx
forall a b. a -> (a -> b) -> b
& (Time -> Identity Time) -> Ctx -> Identity Ctx
Lens' Ctx Time
ctxNow ((Time -> Identity Time) -> Ctx -> Identity Ctx)
-> Time -> Ctx -> Ctx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Time
now
        verdict :: SResponse <-
          -- it is essential to not use @encode authnresp@ here, as that has no signature!
          postHtmlForm
            "/sso/authresp"
            [("SAMLResponse", cs . EL.encode . cs $ authnrespRaw)]
        when (statusCode (simpleStatus verdict) /= 303) . liftIO $ do
          putStrLn $ ppShow verdict
        liftIO $ statusCode (simpleStatus verdict) `shouldBe` 303