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

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
    IdPMetadata
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
    IO () -> WaiSession () ()
forall a. IO a -> WaiSession () a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WaiSession () ()) -> IO () -> WaiSession () ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (IdPMetadata -> FilePath
forall a. Show a => a -> FilePath
show IdPMetadata
idpmeta) Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldNotBe` Int
0

    Bool
checkAuthResp <- IO Bool -> WaiSession () Bool
forall a. IO a -> WaiSession () a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> WaiSession () Bool) -> IO Bool -> WaiSession () Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesSampleExistIO FilePath
filePathResp
    if Bool -> Bool
not Bool
checkAuthResp
      then IO () -> WaiSession () ()
forall a. IO a -> WaiSession () a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WaiSession () ()) -> IO () -> WaiSession () ()
forall a b. (a -> b) -> a -> b
$ do
        FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"*** no response for filePath (" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
filePathResp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
") [skipping]"
      else do
        LT
authnrespRaw :: LT <- FilePath -> WaiSession () LT
forall (m :: * -> *). MonadIO m => FilePath -> m LT
readSampleIO FilePath
filePathResp
        AuthnResponse
authnresp :: AuthnResponse <- (FilePath -> WaiSession () AuthnResponse)
-> (AuthnResponse -> WaiSession () AuthnResponse)
-> Either FilePath AuthnResponse
-> WaiSession () AuthnResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> WaiSession () AuthnResponse
forall a. HasCallStack => FilePath -> a
error (FilePath -> WaiSession () AuthnResponse)
-> (FilePath -> FilePath)
-> FilePath
-> WaiSession () AuthnResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. Show a => a -> FilePath
show) AuthnResponse -> WaiSession () AuthnResponse
forall a. a -> WaiSession () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath AuthnResponse -> WaiSession () AuthnResponse)
-> Either FilePath AuthnResponse -> WaiSession () AuthnResponse
forall a b. (a -> b) -> a -> b
$ LT -> Either FilePath AuthnResponse
forall (m :: * -> *) a.
(HasXMLRoot a, MonadError FilePath m) =>
LT -> m a
decode LT
authnrespRaw
        let idpcfg :: IdPConfig ()
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 :: 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 :: 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 :: Issuer
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 :: 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

        IO () -> WaiSession () ()
forall a. IO a -> WaiSession () a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WaiSession () ())
-> ((Ctx -> IO Ctx) -> IO ())
-> (Ctx -> IO Ctx)
-> WaiSession () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CtxV -> (Ctx -> IO Ctx) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ CtxV
ctx ((Ctx -> IO Ctx) -> WaiSession () ())
-> (Ctx -> IO Ctx) -> WaiSession () ()
forall a b. (a -> b) -> a -> b
$ \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
        SResponse
verdict :: SResponse <-
          -- it is essential to not use @encode authnresp@ here, as that has no signature!
          ByteString -> [(FilePath, FilePath)] -> WaiSession () SResponse
forall st.
ByteString -> [(FilePath, FilePath)] -> WaiSession st SResponse
postHtmlForm
            ByteString
"/sso/authresp"
            [(FilePath
"SAMLResponse", ByteString -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> FilePath) -> (LT -> ByteString) -> LT -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
EL.encode (ByteString -> ByteString)
-> (LT -> ByteString) -> LT -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LT -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (LT -> FilePath) -> LT -> FilePath
forall a b. (a -> b) -> a -> b
$ LT
authnrespRaw)]
        Bool -> WaiSession () () -> WaiSession () ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status -> Int
statusCode (SResponse -> Status
simpleStatus SResponse
verdict) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
303) (WaiSession () () -> WaiSession () ())
-> (IO () -> WaiSession () ()) -> IO () -> WaiSession () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> WaiSession () ()
forall a. IO a -> WaiSession () a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WaiSession () ()) -> IO () -> WaiSession () ()
forall a b. (a -> b) -> a -> b
$ do
          FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ SResponse -> FilePath
forall a. Show a => a -> FilePath
ppShow SResponse
verdict
        IO () -> WaiSession () ()
forall a. IO a -> WaiSession () a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WaiSession () ()) -> IO () -> WaiSession () ()
forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode (SResponse -> Status
simpleStatus SResponse
verdict) Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
303