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

module SAML2.WebSSO.Test.Util.VendorCompatibility
  ( vendorCompatibility,
    vendorParseAuthResponse,
  )
where

import Control.Concurrent.MVar
import Control.Lens
import Control.Monad
import qualified Data.ByteString.Base64.Lazy as EL (encode)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Data.String.Conversions
import qualified Data.UUID 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.
(SP m, SPStoreIdP (Error err) m, SPStoreID Assertion m,
 SPStoreID AuthnRequest 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

vendorParseAuthResponse :: HasCallStack => FilePath -> URI.URI -> Spec
vendorParseAuthResponse :: HasCallStack => FilePath -> URI -> Spec
vendorParseAuthResponse 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
  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
    LT
authnrespRaw :: LT <- FilePath -> WaiSession () LT
forall (m :: * -> *). MonadIO m => FilePath -> m LT
readSampleIO (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")
    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
    () -> WaiSession () ()
forall a. a -> WaiSession () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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 :: ()
_idpId :: IdPId
_idpMetadata :: IdPMetadata
_idpExtraInfo :: ()
..}
              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) Time
            reqstore :: Map (ID AuthnRequest) Time
reqstore = ID AuthnRequest -> Time -> Map (ID AuthnRequest) 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) Time
timeInALongTime
            -- 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
. (URI -> Identity URI) -> Config -> Identity Config
Lens' Config 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) Time
 -> Identity (Map (ID AuthnRequest) Time))
-> Ctx -> Identity Ctx
Lens' Ctx (Map (ID AuthnRequest) Time)
ctxRequestStore ((Map (ID AuthnRequest) Time
  -> Identity (Map (ID AuthnRequest) Time))
 -> Ctx -> Identity Ctx)
-> Map (ID AuthnRequest) Time -> Ctx -> Ctx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (ID AuthnRequest) 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

eraseSampleIdPs :: Ctx -> Ctx
eraseSampleIdPs :: Ctx -> Ctx
eraseSampleIdPs = ([(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_, SampleIdP)]
forall a. Monoid a => a
mempty -- SampleIdPs as we create them here have undefineds that will break showing.