diff --git a/SAML2/XML.hs b/SAML2/XML.hs index 1e3c185..8415eef 100644 --- a/SAML2/XML.hs +++ b/SAML2/XML.hs @@ -20,6 +20,7 @@ module SAML2.XML , samlToDoc , samlToDocFirstChild , samlToXML + , xshowEscapeXMLByteString , docToSAML , docToXMLWithoutRoot , docToXMLWithRoot @@ -35,7 +36,6 @@ import qualified Data.Invertible as Inv import Data.Maybe (listToMaybe) import Network.URI (URI) import qualified Text.XML.HXT.Core as HXT -import qualified Text.XML.HXT.DOM.ShowXml import Text.XML.HXT.DOM.XmlNode (getChildren) import qualified Data.Tree.NTree.TypeDefs as HXT @@ -109,16 +109,24 @@ samlToDocFirstChild = head . getChildren . head . HXT.runLA (HXT.processChildren $ HXT.cleanupNamespaces HXT.collectPrefixUriPairs) . XP.pickleDoc XP.xpickle +-- | Serialize the trees selected by the given arrow to an escaped-XML, UTF-8 encoded `ByteString`. +xshowEscapeXMLByteString :: HXT.LA HXT.XmlTree HXT.XmlTree -> HXT.XmlTree -> BSL.ByteString +xshowEscapeXMLByteString sel = BSLU.fromString . concat . HXT.runLA (HXT.xshowEscapeXml sel) + -- | see also 'docToXMLWithRoot' +-- +-- Produces UTF-8 encoded `ByteString`. docToXMLWithoutRoot :: HXT.XmlTree -> BSL.ByteString -docToXMLWithoutRoot = BSL.concat . HXT.runLA (HXT.xshowBlob HXT.getChildren) +docToXMLWithoutRoot = xshowEscapeXMLByteString HXT.getChildren --- | 'docToXML' chops off the root element from the tree. 'docToXMLWithRoot' does not do --- this. it may make sense to remove 'docToXMLWithoutRoot', but since i don't understand this +-- | 'docToXMLWithoutRoot' chops off the root element from the tree. 'docToXMLWithRoot' does not do +-- this. It may make sense to remove 'docToXMLWithoutRoot', but since i don't understand this -- code enough to be confident not to break anything, i'll just leave this extra function for -- reference. +-- +-- Produces UTF-8 encoded `ByteString`. docToXMLWithRoot :: HXT.XmlTree -> BSL.ByteString -docToXMLWithRoot = Text.XML.HXT.DOM.ShowXml.xshowBlob . (:[]) +docToXMLWithRoot = xshowEscapeXMLByteString HXT.this samlToXML :: XP.XmlPickler a => a -> BSL.ByteString samlToXML = docToXMLWithoutRoot . samlToDoc diff --git a/SAML2/XML/Signature.hs b/SAML2/XML/Signature.hs index f170c8c..529929a 100644 --- a/SAML2/XML/Signature.hs +++ b/SAML2/XML/Signature.hs @@ -42,7 +42,6 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Either (isRight) import Network.URI (URI(..)) import qualified Text.XML.HXT.Core as HXT -import qualified Text.XML.HXT.DOM.ShowXml as DOM import qualified Text.XML.HXT.DOM.XmlNode as DOM import qualified Text.XML.HXT.DOM.QualifiedName as DOM @@ -74,7 +73,7 @@ applyTransformsXML (Transform (Identified TransformEnvelopedSignature) Nothing [ applyTransformsXML tl . head . HXT.runLA (HXT.processChildren $ HXT.processChildren $ HXT.neg (isDSElem "Signature")) -applyTransformsXML tl = applyTransformsBytes tl . DOM.xshowBlob . return +applyTransformsXML tl = applyTransformsBytes tl . xshowEscapeXMLByteString HXT.this applyTransforms :: Maybe Transforms -> HXT.XmlTree -> IO BSL.ByteString applyTransforms = applyTransformsXML . maybe [] (NonEmpty.toList . transforms) diff --git a/hsaml2.cabal b/hsaml2.cabal index 4ee2989..ec36e8b 100644 --- a/hsaml2.cabal +++ b/hsaml2.cabal @@ -116,6 +116,7 @@ test-suite tests XML.Canonical XML.Keys XML.Encryption + XML.Serialization XML.Signature default-language: Haskell2010 ghc-options: -Wall diff --git a/test/Main.hs b/test/Main.hs index cdb5503..3ea07e1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -4,6 +4,7 @@ import System.Exit (exitSuccess, exitFailure) import qualified Test.HUnit as U import qualified XML.Canonical +import qualified XML.Serialization import qualified XML.Signature import qualified XML.Encryption import qualified Bindings.HTTPRedirect @@ -12,6 +13,7 @@ import qualified Metadata.Metadata tests :: U.Test tests = U.test [ U.TestLabel "XML.Canonical" XML.Canonical.tests + , U.TestLabel "XML.Serialization" XML.Serialization.tests , U.TestLabel "XML.Signature" XML.Signature.tests , U.TestLabel "XML.Encryption" XML.Encryption.tests , U.TestLabel "Bindings.HTTPRedirect" Bindings.HTTPRedirect.tests diff --git a/test/XML/Serialization.hs b/test/XML/Serialization.hs new file mode 100644 index 0000000..7e823b3 --- /dev/null +++ b/test/XML/Serialization.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module XML.Serialization (tests) where + +import qualified Test.HUnit as U +import Text.XML.HXT.DOM.XmlNode (mkText) + +import qualified SAML2.Core.Assertions as A +import SAML2.Core.Identifiers (AttributeNameFormat(AttributeNameFormatUnspecified)) +import SAML2.XML + +-- | XML meta-characters plus codepoints outside Latin-1. +riskyString :: String +riskyString = "><& проверка テスト 🪲" + +mkAttribute :: String -> A.Attribute +mkAttribute v = A.Attribute + { A.attributeName = "x" + , A.attributeNameFormat = Identified AttributeNameFormatUnspecified + , A.attributeFriendlyName = Nothing + , A.attributeAttrs = [] + , A.attributeValues = [[mkText v]] + } + +assertRoundTrips :: String -> A.Attribute -> Either String A.Attribute -> U.Assertion +assertRoundTrips label orig parsed = case parsed of + Left err -> U.assertFailure $ label ++ ": failed to parse serialized output: " ++ err + Right orig' -> U.assertEqual label orig orig' + +tests :: U.Test +tests = U.test [encodingAndXMLEscapingRegressionTests] + +-- | The serialization functions used to be implemented via HXT's 'Text.XML.HXT.DOM.ShowXml.xshowBlob', which +-- +-- 1. never XML-escapes '<'\/'&' in text content, so a value containing them produced +-- invalid or structurally wrong XML, and +-- 2. packs the shown 'String' into a 'Data.ByteString.Lazy.ByteString' by truncating +-- every 'Char' to @fromEnum c \`mod\` 256@ (i.e. it only supports Latin-1), silently +-- corrupting anything else. +encodingAndXMLEscapingRegressionTests :: U.Test +encodingAndXMLEscapingRegressionTests = U.test + [ U.TestCase $ do + let attr = mkAttribute riskyString + assertRoundTrips "(xmlToSAML . samlToXML) round-trip" attr + (xmlToSAML $ samlToXML attr) + , U.TestCase $ do + let attr = mkAttribute riskyString + assertRoundTrips "(xmlToSAML . docToXMLWithRoot . samlToDocFirstChild) round-trip" attr + (xmlToSAML . docToXMLWithRoot $ samlToDocFirstChild attr) + , U.TestCase $ do + let attr = mkAttribute riskyString + assertRoundTrips "(xmlToSAML . docToXMLWithoutRoot . samlToDoc) round-trip" attr + (xmlToSAML . docToXMLWithoutRoot $ samlToDoc attr) + ] diff --git a/test/XML/Signature.hs b/test/XML/Signature.hs index 370fb08..128ee62 100644 --- a/test/XML/Signature.hs +++ b/test/XML/Signature.hs @@ -22,6 +22,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base64.Lazy as EL import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy as LBS +import qualified SAML2.Core.Assertions as A import qualified SAML2.XML as HS import qualified Test.HUnit as U import qualified Text.XML.HXT.DOM.QualifiedName as HXT @@ -41,7 +42,8 @@ import XML import XML.Keys tests :: U.Test -tests = U.test [serializationTests, signVerifyTests, verifyTests, counterExamples] +tests = U.test + [serializationTests, signVerifyTests, verifyTests, counterExamples, transformFallbackTests] ---------------------------------------------------------------------- @@ -335,3 +337,27 @@ canonicalizeCounterExample base64input = do outbs :: LBS.ByteString <- BS.fromStrict <$> canonicalize algo Nothing Nothing (NTree (XTag (mkQName "" "" "root") []) [tree]) pure (inbs, outbs) + + +---------------------------------------------------------------------- +-- regression: applyTransforms's fallback case used to serialize via `HXT.xshowBlob`, which +-- neither XML-escapes '<'/'&' nor supports anything beyond Latin-1. + +transformFallbackTests :: U.Test +transformFallbackTests = U.test + [ U.TestCase $ do + let riskyString = "><& проверка テスト 🪲" + attr = A.Attribute + { A.attributeName = "x" + , A.attributeNameFormat = Identified AttributeNameFormatUnspecified + , A.attributeFriendlyName = Nothing + , A.attributeAttrs = [] + , A.attributeValues = [[HXT.mkText riskyString]] + } + out <- applyTransforms Nothing (samlToDocFirstChild attr) + case xmlToSAML out :: Either String A.Attribute of + Left err -> U.assertFailure $ "xmlToSAML: " ++ err + Right attr' -> U.assertEqual + "applyTransforms with no canonicalization transform preserves escapable/non-Latin-1 text" + attr attr' + ]