Fix Unicode character corruption and lack of XML character escaping

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

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)

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

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

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)
+  ]

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'
+  ]