Merge branch 'master' into destination

.github/workflows/stackage-nightly.yml

@@ -3,6 +3,8 @@ name: stackage-nightly
 on:
   schedule:
     - cron: "5 6 * * *"
+  workflow_dispatch:
+  pull_request:
 
 jobs:
   build:

CHANGELOG.md

@@ -1,8 +1,10 @@
 # Changelog for `wai-saml2`
 
-## 0.4.1
+## Unreleased changes
 
-- Added `authnRequestDestination` field to `AuthnRequest`
+-   Support GHC 9.6 ([#53](https://github.com/mbg/wai-saml2/pull/53) by [@mbg](https://github.com/mbg))
+-   Fixed a bug in XML canonicalisation causing a digest mismatch on Okta when assertion attributes are present (special thanks to @hiroqn) ([#51](https://github.com/mbg/wai-saml2/pull/51) by [@fumieval](https://github.com/fumieval))
+-   Added `authnRequestDestination` field to `AuthnRequest` ([#47](https://github.com/mbg/wai-saml2/pull/47) by [@Philonous](https://github.com/Philonous))
 
 ## 0.4
 

src/Network/Wai/SAML2/C14N.hs

@@ -14,16 +14,19 @@ module Network.Wai.SAML2.C14N (
 --------------------------------------------------------------------------------
 
 import qualified Data.ByteString as BS
+import Data.Text (Text)
+import qualified Data.Text.Encoding as T
 
 import Foreign.C.Types
 
 import Text.XML.C14N
 
 --------------------------------------------------------------------------------
 
--- | 'canonicalise' @xml@ produces a canonical representation of @xml@.
-canonicalise :: BS.ByteString -> IO BS.ByteString
-canonicalise xml = c14n c14nOpts c14n_exclusive_1_0 [] False Nothing xml
+-- | 'canonicalise' @prefixList@ @xml@ produces a canonical representation of @xml@
+-- while retaining namespaces matching @prefixList@.
+canonicalise :: [Text] -> BS.ByteString -> IO BS.ByteString
+canonicalise prefixList xml = c14n c14nOpts c14n_exclusive_1_0 (map T.encodeUtf8 prefixList) False Nothing xml
 
 -- | The options we want to use for canonicalisation of XML documents.
 c14nOpts :: [CInt]

src/Network/Wai/SAML2/Response.hs

@@ -11,6 +11,7 @@ module Network.Wai.SAML2.Response (
     Response(..),
     removeSignature,
     extractSignedInfo,
+    extractPrefixList,
 
     -- * Re-exports
     module Network.Wai.SAML2.StatusCode,
@@ -133,6 +134,16 @@ extractSignedInfo cursor = do
                           ) >>= nodes
     pure signedInfo
 
+-- | Obtain a list of InclusiveNamespaces entries used for exclusive XML canonicalisation.
+extractPrefixList :: Cursor -> [T.Text]
+extractPrefixList cursor = concatMap T.words
+    $ concatMap (attribute "PrefixList")
+    $ cursor
+    $/ element (dsName "Reference")
+    &/ element (dsName "Transforms")
+    &/ element (dsName "Transform")
+    &/ element (ecName "InclusiveNamespaces")
+
 --------------------------------------------------------------------------------
 
 -- Reference [StatusResponseType]

src/Network/Wai/SAML2/Validation.hs

@@ -16,7 +16,9 @@ module Network.Wai.SAML2.Validation (
 --------------------------------------------------------------------------------
 
 import Control.Exception
+import Control.Monad (forM_, when, unless)
 import Control.Monad.Except
+import Control.Monad.IO.Class (liftIO)
 
 import Crypto.Error
 import Crypto.Hash
@@ -69,7 +71,7 @@ decodeResponse responseData = do
 
     -- try to parse the XML document; throw an exception if it is not
     -- a valid XML document
-    responseXmlDoc <- case XML.parseLBS def (LBS.fromStrict resXmlDocData) of
+    responseXmlDoc <- case XML.parseLBS parseSettings (LBS.fromStrict resXmlDocData) of
         Left err -> throwError $ InvalidResponseXml err
         Right responseXmlDoc -> pure responseXmlDoc
 
@@ -130,8 +132,9 @@ validateSAMLResponse cfg responseXmlDoc samlResponse now = do
     let signedInfoXml = XML.renderLBS def doc
 
     -- canonicalise the textual representation of the SignedInfo element
+    let prefixList = extractPrefixList (XML.fromDocument doc)
     signedInfoCanonResult <- liftIO $ try $
-        canonicalise (LBS.toStrict signedInfoXml)
+        canonicalise prefixList (LBS.toStrict signedInfoXml)
 
     normalisedSignedInfo <- case signedInfoCanonResult of
         Left err -> throwError $ CanonicalisationFailure err
@@ -161,7 +164,7 @@ validateSAMLResponse cfg responseXmlDoc samlResponse now = do
 
     -- then render the resulting document and canonicalise it
     let renderedXml = XML.renderLBS def docMinusSignature
-    refCanonResult <- liftIO $ try $ canonicalise (LBS.toStrict renderedXml)
+    refCanonResult <- liftIO $ try $ canonicalise prefixList (LBS.toStrict renderedXml)
 
     normalised <- case refCanonResult of
         Left err -> throwError $ CanonicalisationFailure err

src/Network/Wai/SAML2/XML.hs

@@ -13,6 +13,7 @@ module Network.Wai.SAML2.XML (
     xencName,
     dsName,
     mdName,
+    ecName,
 
     -- * Utility functions
     toMaybeText,
@@ -21,7 +22,8 @@ module Network.Wai.SAML2.XML (
 
     -- * XML parsing
     FromXML(..),
-    oneOrFail
+    oneOrFail,
+    parseSettings
 ) where
 
 --------------------------------------------------------------------------------
@@ -66,6 +68,12 @@ mdName name =
     Name name (Just "urn:oasis:names:tc:SAML:2.0:metadata") (Just "md")
 
 
+-- | 'ecName' @name@ constructs a 'Name' for @name@ in the
+-- http://www.w3.org/2001/10/xml-exc-c14n# namespace.
+ecName :: T.Text -> Name
+ecName name =
+    Name name (Just "http://www.w3.org/2001/10/xml-exc-c14n#") (Just "ec")
+
 -- | 'toMaybeText' @xs@ returns 'Nothing' if @xs@ is the empty list, or
 -- the result of concatenating @xs@ wrapped in 'Just' otherwise.
 toMaybeText :: [T.Text] -> Maybe T.Text
@@ -100,3 +108,8 @@ oneOrFail err [] = fail err
 oneOrFail _ (x:_) = pure x
 
 --------------------------------------------------------------------------------
+
+-- | It is important to retain namespaces in order to calculate the hash of the canonicalised XML correctly.
+-- see: https://stackoverflow.com/questions/69252831/saml-2-0-digest-value-calculation-in-saml-assertion
+parseSettings :: ParseSettings
+parseSettings = def { psRetainNamespaces = True }