packages feed

hsaml2 0.1.2 → 0.2.0

raw patch · 15 files changed

+273/−128 lines, 15 filesdep +cryptondep +crypton-x509dep +silentlydep −hxt-httpdep −string-conversions

Dependencies added: crypton, crypton-x509, silently

Dependencies removed: hxt-http, string-conversions

Files

SAML2/Bindings/HTTPRedirect.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TupleSections #-}@@ -23,7 +22,6 @@ import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL import Data.Maybe (fromMaybe, maybeToList)-import Data.Monoid ((<>)) import Data.Proxy (Proxy(..)) import Network.HTTP.Types.Header (ResponseHeaders, hLocation, hCacheControl, hPragma) import Network.HTTP.Types.URI (Query, renderQuery, urlDecode)
SAML2/Core/Namespaces.hs view
@@ -8,7 +8,6 @@   , samlURNIdentifier   ) where -import Data.Monoid ((<>)) import Network.URI (URI(..))  import SAML2.Core.Versioning@@ -24,9 +23,3 @@  samlURNIdentifier :: String -> (SAMLVersion, String) -> URI samlURNIdentifier t (v, n) = samlURN v [t, n]---- samlURNIdentifier :: String -> (a -> (SAMLVersion, String)) -> (a -> samlURN)--- samlURNIdentifier = (.) . uncurry . samlURNIdentifier---- xpSAMLURNIdentifier :: Identifiable URI a => String -> XP.PU a--- xpSAMLURNIdentifier = xpIdentifier XS.xpAnyURI
SAML2/Core/Signature.hs view
@@ -6,12 +6,10 @@ module SAML2.Core.Signature   ( signSAMLProtocol   , verifySAMLProtocol-  , verifySAMLProtocol'+  , verifySAMLProtocolWithKeys   ) where -import Control.Exception-import Control.Lens ((^.), (.~))-import Control.Monad (unless)+import Control.Lens ((^.), (?~)) import qualified Data.ByteString.Lazy as BSL import Data.List.NonEmpty (NonEmpty((:|))) import Network.URI (URI(uriFragment), nullURI)@@ -45,7 +43,7 @@       }     , DS.signedInfoReference = r :| []     } DS.signatureSignedInfo $ SAMLP.protocolSignature p-  return $ DS.signature' .~ Just s' $ m+  return $ DS.signature' ?~ s' $ m   where   p = m ^. SAMLP.samlProtocol' @@ -53,20 +51,15 @@ verifySAMLProtocol b = do   x <- maybe (fail "invalid XML") return $ xmlToDoc b   m <- either fail return $ docToSAML x-  v <- DS.verifySignature mempty (DS.signedID m) x-  unless (or v) $ fail "verifySAMLProtocol: invalid or missing signature"-  return m+  v <- DS.verifySignatureUnenvelopedSigs mempty (DS.signedID m) x+  case v of+    Left msg -> fail $ "verifySAMLProtocol: invalid or missing signature: " ++ show msg+    Right () -> return m  -- | A variant of 'verifySAMLProtocol' that is more symmetric to 'signSAMLProtocol'.  The reason it -- takes an 'XmlTree' and not an @a@ is that signature verification needs both.------ TODO: Should this replace 'verifySAMLProtocol'?-verifySAMLProtocol' :: SAMLP.SAMLProtocol a => DS.PublicKeys -> XmlTree -> IO a-verifySAMLProtocol' pubkeys x = do+verifySAMLProtocolWithKeys :: SAMLP.SAMLProtocol a => DS.PublicKeys -> XmlTree -> IO a+verifySAMLProtocolWithKeys pubkeys x = do   m <- either fail return $ docToSAML x-  v :: Either SomeException (Maybe Bool) <- try $ DS.verifySignature pubkeys (DS.signedID m) x-  case v of-    Left e             -> fail $ "signature verification failed: " ++ show e-    Right Nothing      -> fail "signature verification failed: no matching key/alg pair."-    Right (Just False) -> fail "signature verification failed: verification failed."-    Right (Just True)  -> pure m+  v <- DS.verifySignatureUnenvelopedSigs pubkeys (DS.signedID m) x+  either (fail . show) (const $ pure m) v
SAML2/Metadata/Metadata.hs view
@@ -15,6 +15,7 @@ import qualified Network.URI as URI import qualified Text.XML.HXT.Arrow.Pickle.Schema as XPS +import qualified Text.XML.HXT.DOM.QualifiedName as HXT import SAML2.Lens import SAML2.XML import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP@@ -197,6 +198,11 @@   = Descriptor     { descriptorRole :: !RoleDescriptor     } -- ^§2.4.1+  | ExtendedRoleDescriptor+    { descriptorRoleExtensionType :: !(XS.String)+    , descriptorRole :: !RoleDescriptor+    , descriptorAdditionalNodes :: !Nodes+    } -- ^§2.4.1 (variant extended with use of xsi:type attribute)   | IDPSSODescriptor     { descriptorRole :: !RoleDescriptor     , descriptorSSO :: !SSODescriptor@@ -237,15 +243,23 @@     } -- ^§2.4.6   deriving (Eq, Show) +xsiTypeQName :: HXT.QName+xsiTypeQName = HXT.mkQName "xsi" "type" "http://www.w3.org/2001/XMLSchema-instance"+ instance XP.XmlPickler Descriptor where   xpickle = [XP.biCase|-      Left (Left (Left (Left (Left r)))) <-> Descriptor r+      Left (Left (Left (Left (Left (Left ((t, rde), an)))))) <-> ExtendedRoleDescriptor t rde an+      Left (Left (Left (Left (Left (Right r))))) <-> Descriptor r       Left (Left (Left (Left (Right (((((((ws, r), s), sso), nim), air), ap), a))))) <-> IDPSSODescriptor r s ws sso nim air ap a       Left (Left (Left (Right (((((a, w), r), s), e), t)))) <-> SPSSODescriptor r s a w e t       Left (Left (Right (((r, a), s), n))) <-> AuthnAuthorityDescriptor r a s n       Left (Right (((((r, a), s), n), tp), t)) <-> AttributeAuthorityDescriptor r a s n tp t       Right (((r, a), s), n) <-> PDPDescriptor r a s n|]-    XP.>$< (xpElem "RoleDescriptor" XP.xpickle+    XP.>$< (xpElem "RoleDescriptor" +        (XP.xpAttrQN xsiTypeQName XS.xpString+          XP.>*< XP.xpickle +          XP.>*< XP.xpTrees)+    XP.>|<  xpElem "RoleDescriptor" XP.xpickle     XP.>|<  xpElem "IDPSSODescriptor"             (XP.xpDefault False (XP.xpAttr "WantAuthnRequestsSigned" XS.xpBoolean)       XP.>*< XP.xpickle
SAML2/XML.hs view
@@ -18,11 +18,14 @@   , xpIdentifier   , IdentifiedURI   , samlToDoc+  , samlToDocFirstChild   , samlToXML   , docToSAML-  , docToXML+  , docToXMLWithoutRoot+  , docToXMLWithRoot   , xmlToSAML   , xmlToDoc+  , xmlToDocE   ) where  import qualified Data.ByteString.Lazy as BSL@@ -32,9 +35,9 @@ import Data.Maybe (listToMaybe) import Network.URI (URI) import qualified Text.XML.HXT.Core as HXT-import Text.XML.HXT.Arrow.Edit (escapeXmlRefs)-import Text.XML.HXT.DOM.ShowXml (xshow')+import qualified Text.XML.HXT.DOM.ShowXml import Text.XML.HXT.DOM.XmlNode (getChildren)+import qualified Data.Tree.NTree.TypeDefs as HXT  import SAML2.XML.Types import SAML2.Core.Datatypes@@ -48,7 +51,7 @@ xpTrimElemNS ns n c = XP.xpTrim $ XP.xpElemQN (mkNName ns n) (c XP.>* XP.xpWhitespace)  xpXmlLang :: XP.PU XS.Language-xpXmlLang = XP.xpAttrQN (mkNName xmlNS "lang") $ XS.xpLanguage+xpXmlLang = XP.xpAttrQN (mkNName xmlNS "lang") XS.xpLanguage  type IP = XS.String @@ -100,14 +103,43 @@   . HXT.runLA (HXT.processChildren $ HXT.cleanupNamespaces HXT.collectPrefixUriPairs)   . XP.pickleDoc XP.xpickle -docToXML :: HXT.XmlTree -> BSL.ByteString-docToXML = xshow' cquot aquot (:) . getChildren where (cquot, aquot) = escapeXmlRefs+-- | From the input xml forest, take the first child of the first tree.+samlToDocFirstChild :: XP.XmlPickler a => a -> HXT.XmlTree+samlToDocFirstChild = head . getChildren . head+  . HXT.runLA (HXT.processChildren $ HXT.cleanupNamespaces HXT.collectPrefixUriPairs)+  . XP.pickleDoc XP.xpickle +-- | see also 'docToXMLWithRoot'+docToXMLWithoutRoot :: HXT.XmlTree -> BSL.ByteString+docToXMLWithoutRoot =  BSL.concat . HXT.runLA (HXT.xshowBlob 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+-- code enough to be confident not to break anything, i'll just leave this extra function for+-- reference.+docToXMLWithRoot :: HXT.XmlTree -> BSL.ByteString+docToXMLWithRoot = Text.XML.HXT.DOM.ShowXml.xshowBlob . (:[])+ samlToXML :: XP.XmlPickler a => a -> BSL.ByteString-samlToXML = docToXML . samlToDoc+samlToXML = docToXMLWithoutRoot . samlToDoc  xmlToDoc :: BSL.ByteString -> Maybe HXT.XmlTree-xmlToDoc = listToMaybe . HXT.runLA+xmlToDoc = either (const Nothing) Just . xmlToDocE++xmlToDocE :: BSL.ByteString -> Either String HXT.XmlTree+xmlToDocE = fix . xmlToDocUnsafe+  where+    fix Nothing =+      Left "Nothing"+    fix (Just (HXT.NTree (HXT.XError num msg) shouldBeEmpty)) =+      Left $ show num ++ ": " ++ msg ++ (if null shouldBeEmpty then "" else show shouldBeEmpty)+    fix (Just good) =+      Right good++-- | Take a UTF-8 encoded bytestring and return an xml tree.  This is unsafe and returns xml+-- trees containing parse errors on occasion; call 'xmlToDocE' instead.+xmlToDocUnsafe :: BSL.ByteString -> Maybe HXT.XmlTree+xmlToDocUnsafe = listToMaybe . HXT.runLA   (HXT.xreadDoc   HXT.>>> HXT.removeWhiteSpace   HXT.>>> HXT.neg HXT.isXmlPi
SAML2/XML/Canonical.hs view
@@ -58,9 +58,12 @@  -- |Canonicalize and serialize an XML document canonicalize :: CanonicalizationAlgorithm -> Maybe InclusiveNamespaces -> Maybe String -> HXT.XmlTree -> IO BS.ByteString-canonicalize a i s =+canonicalize a i s = canonicalizeWithRoot a i s . getChildren++canonicalizeWithRoot :: CanonicalizationAlgorithm -> Maybe InclusiveNamespaces -> Maybe String -> HXT.XmlTrees -> IO BS.ByteString+canonicalizeWithRoot a i s =   LibXML2.c14n (cm a) (inclusiveNamespacesPrefixList <$> i) (canonicalWithComments a) s-    <=< LibXML2.fromXmlTrees . getChildren where+    <=< LibXML2.fromXmlTrees where   cm CanonicalXML10{} = LibXML2.C14N_1_0   cm CanonicalXML11{} = LibXML2.C14N_1_1   cm CanonicalXMLExcl10{} = LibXML2.C14N_EXCLUSIVE_1_0
SAML2/XML/Schema/Datatypes.hs view
@@ -14,7 +14,6 @@ import Data.Char.Properties.XMLCharProps (isXmlSpaceChar, isXmlNameChar) import Data.Fixed (Pico, showFixed) import Data.List (elemIndex)-import Data.Semigroup ((<>)) import qualified Data.Time.Clock as Time import Data.Time.Format (formatTime, parseTimeM, defaultTimeLocale) import Data.Word (Word16)
SAML2/XML/Signature.hs view
@@ -1,5 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -- | -- XML Signature Syntax and Processing --@@ -9,16 +14,21 @@   , generateReference   , SigningKey(..)   , PublicKeys(..)+  , SignatureError (..)   , signingKeySignatureAlgorithm   , signBase64   , verifyBase64   , generateSignature-  , verifySignature+  , verifySignatureUnenvelopedSigs+  , applyCanonicalization+  , applyTransforms   ) where +import GHC.Stack import Control.Applicative ((<|>))-import Control.Monad (guard, (<=<))-import Crypto.Number.Basic (numBytes)+import Control.Exception (SomeException, handle)+import Control.Monad ((<=<))+import Control.Monad.Except import Crypto.Number.Serialize (i2ospOf_, os2ip) import Crypto.Hash (hashlazy, SHA1(..), SHA256(..), SHA512(..), RIPEMD160(..)) import qualified Crypto.PubKey.DSA as DSA@@ -29,9 +39,7 @@ import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Lazy as BSL import qualified Data.List.NonEmpty as NonEmpty-import Data.Maybe (isJust)-import Data.Monoid ((<>))-import qualified Data.X509 as X509+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@@ -71,14 +79,11 @@ applyTransforms :: Maybe Transforms -> HXT.XmlTree -> IO BSL.ByteString applyTransforms = applyTransformsXML . maybe [] (NonEmpty.toList . transforms) -asType :: a -> proxy a -> proxy a-asType _ = id- applyDigest :: DigestMethod -> BSL.ByteString -> BS.ByteString-applyDigest (DigestMethod (Identified DigestSHA1) []) = BA.convert . asType SHA1 . hashlazy-applyDigest (DigestMethod (Identified DigestSHA256) []) = BA.convert . asType SHA256 . hashlazy-applyDigest (DigestMethod (Identified DigestSHA512) []) = BA.convert . asType SHA512 . hashlazy-applyDigest (DigestMethod (Identified DigestRIPEMD160) []) = BA.convert . asType RIPEMD160 . hashlazy+applyDigest (DigestMethod (Identified DigestSHA1) []) = BA.convert . hashlazy @SHA1+applyDigest (DigestMethod (Identified DigestSHA256) []) = BA.convert . hashlazy @SHA256+applyDigest (DigestMethod (Identified DigestSHA512) []) = BA.convert . hashlazy @SHA512+applyDigest (DigestMethod (Identified DigestRIPEMD160) []) = BA.convert . hashlazy @RIPEMD160 applyDigest d = error $ "unsupported " ++ show d  generateReference :: Reference -> HXT.XmlTree -> IO Reference@@ -88,13 +93,22 @@   return r     { referenceDigestValue = d } -verifyReference :: Reference -> HXT.XmlTree -> IO (Maybe String)+-- | Re-compute the digest (after transforms) of a 'Reference'd subtree of an xml document and+-- compare it against the one given in the 'Reference'.  If it matches, return the xml ID;+-- otherwise, return an error string.+verifyReference :: HasCallStack => Reference -> HXT.XmlTree -> IO (Either String String) verifyReference r doc = case referenceURI r of-  Just URI{ uriScheme = "", uriAuthority = Nothing, uriPath = "", uriQuery = "", uriFragment = '#':xid }-    | x@[_] <- HXT.runLA (getID xid) doc -> do-    t <- applyTransforms (referenceTransforms r) $ DOM.mkRoot [] x-    return $ xid <$ guard (applyDigest (referenceDigestMethod r) t == referenceDigestValue r)-  _ -> return Nothing+  Just URI{ uriScheme = "", uriAuthority = Nothing, uriPath = "", uriQuery = "", uriFragment = '#':xid } ->+    case HXT.runLA (getID xid) doc of+      x@[_] -> do+        t :: BSL.ByteString <- applyTransforms (referenceTransforms r) $ DOM.mkRoot [] x+        let have = applyDigest (referenceDigestMethod r) t+            want = referenceDigestValue r+        return $ if have == want+          then Right xid+          else Left $ "#" <> xid <> ": digest mismatch"+      bad -> return . Left $ "#" <> xid <> ": has " <> show (length bad) <> " matches, should have 1."+  bad -> return . Left $ "unexpected referenceURI: " <> show bad  data SigningKey   = SigningKeyDSA DSA.KeyPair@@ -113,8 +127,7 @@ #endif instance Monoid PublicKeys where   mempty = PublicKeys Nothing Nothing-  PublicKeys dsa1 rsa1 `mappend` PublicKeys dsa2 rsa2 =-    PublicKeys (dsa1 <|> dsa2) (rsa1 <|> rsa2)+  mappend = (<>)  signingKeySignatureAlgorithm :: SigningKey -> SignatureAlgorithm signingKeySignatureAlgorithm (SigningKeyDSA _) = SignatureDSA_SHA1@@ -133,22 +146,6 @@   , rsaKeyValueExponent = e   } -publicKeyValues :: KeyValue -> PublicKeys-publicKeyValues DSAKeyValue{ dsaKeyValuePQ = Just (p, q), dsaKeyValueG = Just g, dsaKeyValueY = y } = mempty-  { publicKeyDSA = Just $ DSA.PublicKey-    { DSA.public_params = DSA.Params-      { DSA.params_p = p-      , DSA.params_q = q-      , DSA.params_g = g-      }-    , DSA.public_y = y-    }-  }-publicKeyValues RSAKeyValue{ rsaKeyValueModulus = n, rsaKeyValueExponent = e } = mempty-  { publicKeyRSA = Just $ RSA.PublicKey (numBytes n) n e-  }-publicKeyValues _ = mempty- signBytes :: SigningKey -> BS.ByteString -> IO BS.ByteString signBytes (SigningKeyDSA k) b = do   s <- DSA.sign (DSA.toPrivateKey k) SHA1 b@@ -187,6 +184,7 @@     , signatureObject = []     } +-- deprecated!  use 'verifySignature' instead.  this is left here so it can be used for testing only. -- Exception in IO:  something is syntactically wrong with the input -- Nothing:          no matching key/alg pairs found -- Just False:       signature verification failed || dangling refs || explicit ref is not among the signed ones@@ -206,18 +204,36 @@   let verified :: Maybe Bool       verified = verifyBytes pks (signatureMethodAlgorithm $ signedInfoSignatureMethod si) (signatureValue $ signatureSignatureValue s) six       valid :: Bool-      valid = elem (Just xid) rl && all isJust rl+      valid = elem (Right xid) rl && all isRight rl   return $ (valid &&) <$> verified   where   child n = HXT.runLA $ HXT.getChildren HXT.>>> isDSElem n HXT.>>> HXT.cleanupNamespaces HXT.collectPrefixUriPairs-  keyinfo (KeyInfoKeyValue kv) = publicKeyValues kv-  keyinfo (X509Data l) = foldMap keyx509d l-  keyinfo _ = mempty-  keyx509d (X509Certificate sc) = keyx509p $ X509.certPubKey $ X509.getCertificate sc-  keyx509d _ = mempty-  keyx509p (X509.PubKeyRSA r) = mempty{ publicKeyRSA = Just r }-  keyx509p (X509.PubKeyDSA d) = mempty{ publicKeyDSA = Just d }-  keyx509p _ = mempty   xpathsel t = "/*[local-name()='" ++ t ++ "' and namespace-uri()='" ++ namespaceURIString ns ++ "']"   xpathbase = "/*" ++ xpathsel "Signature" ++ xpathsel "SignedInfo" ++ "//"   xpath = xpathbase ++ ". | " ++ xpathbase ++ "@* | " ++ xpathbase ++ "namespace::*"+++-- | It turns out sometimes we don't get envelopped signatures, but signatures that are+-- located outside the signed sub-tree.  Since 'verifySiganture' doesn't support this case, if+-- you encounter it you should fall back to 'verifySignatureUnenvelopedSigs'.+verifySignatureUnenvelopedSigs :: PublicKeys -> String -> HXT.XmlTree -> IO (Either SignatureError ())+verifySignatureUnenvelopedSigs pks xid doc = catchAll $ warpResult <$> verifySignature pks xid doc+  where+    catchAll :: IO (Either SignatureError ()) -> IO (Either SignatureError ())+    catchAll = handle $ pure . Left . SignatureVerificationLegacyFailure . Left . (show @SomeException)++    warpResult (Just True) = Right ()+    warpResult bad = Left (SignatureVerificationLegacyFailure (Right bad))++data SignatureError =+    SignedElementNotFound+  | SignatureNotFoundOrEmpty+  | SignatureParseError String+  | SignatureCanonicalizationError String+  | SignatureVerifyReferenceError String+  | SignatureVerifyBadReferences String+  | SignatureVerifyInputNotReferenced String+  | SignatureVerificationCryptoUnsupported String+  | SignatureVerificationCryptoFailed String+  | SignatureVerificationLegacyFailure (Either String (Maybe Bool))+  deriving (Eq, Show)
SAML2/XML/Signature/Types.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- |
SAML2/XML/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-}+ module SAML2.XML.Types where  import Data.List.NonEmpty (NonEmpty(..))@@ -8,8 +9,10 @@ import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP  type Node = HXT.XmlTree+ -- instance XP.XmlPickler XML.Node where xpickle = XP.xpTree type Nodes = HXT.XmlTrees+ -- instance XP.XmlPickler XML.Nodes where xpickle = XP.xpTrees type List1 a = NonEmpty a
hsaml2.cabal view
@@ -1,5 +1,5 @@ name:                hsaml2-version:             0.1.2+version:             0.2.0 synopsis:            OASIS Security Assertion Markup Language (SAML) V2.0 description:         Direct implementation of the SAML XML standard (https://www.oasis-open.org/standards#samlv2.0), along with some related dependencies.  This is currently partial, as the standard is quite extensive, but is sufficient to build a functioning SP and fully validate responses.  The module layout basically follows the standard definition documentation.  Its use still requires a fairly extensive understanding of SAML. license:             Apache-2.0@@ -10,7 +10,6 @@ category:            Security, Network, Web build-type:          Simple cabal-version:       >=1.10-tested-with:         GHC == 8.0.2 || == 8.2.2 || == 8.4.4 || == 8.6.5 || == 8.8.3  extra-source-files:   test/Metadata/metadata-idp.xml@@ -27,6 +26,10 @@   test/XML/signature-example.xml   test/XML/world.txt +flag crypton+  description: Use cryton instead of cryptonite+  default: True+ source-repository head   type: git   location: https://github.com/dylex/hsaml2@@ -66,13 +69,20 @@     SAML2.Bindings.Internal   c-sources:     SAML2/XML/libxml2_stub.c+  if flag(crypton)+    build-depends:+      crypton,+      crypton-x509+  else+    build-depends:+      cryptonite,+      x509   build-depends:     asn1-encoding,     asn1-types >= 0.2,     base >=4.8 && <5,     base64-bytestring,     bytestring,-    cryptonite,     data-default,     http-types,     hxt,@@ -85,11 +95,11 @@     mtl,     network-uri,     process,+    silently,     semigroups,     template-haskell,     time,     utf8-string,-    x509,     zlib   pkgconfig-depends: libxml-2.0   default-language:    Haskell2010@@ -109,18 +119,23 @@     XML.Signature   default-language: Haskell2010   ghc-options: -Wall+  if flag(crypton)+    build-depends:+      crypton,+      crypton-x509+  else+    build-depends:+      cryptonite,+      x509   build-depends:     base,     base64-bytestring,     bytestring,-    cryptonite,+    utf8-string,     hsaml2,     hxt,-    hxt-http,     http-types,     network-uri,     semigroups,-    string-conversions,     time,-    x509,     HUnit
test/Metadata/Metadata.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Metadata.Metadata (tests) where +import Control.Monad.IO.Class  import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.X509 as X509 import qualified Test.HUnit as U@@ -490,4 +492,12 @@         []       ]       []+  , canLoadMetadata "test/Metadata/metadata-idp-azure.xml"   ]+    where+      canLoadMetadata :: String -> U.Test+      canLoadMetadata metadataPath = U.TestCase $ do+        [res] <- liftIO $ parseXML metadataPath +        case (res :: Either String Metadata) of +          Left s -> U.assertFailure s+          _ -> pure ()
test/XML.hs view
@@ -1,5 +1,6 @@ module XML   ( testXML+  , parseXML   , uri   , pickleElem   ) where@@ -7,15 +8,13 @@ import Data.Maybe (fromJust) import Network.URI (URI, parseURIReference) import qualified Test.HUnit as U- import qualified Text.XML.HXT.Core as HXT-import qualified Text.XML.HXT.HTTP as HXT (withHTTP) import qualified Text.XML.HXT.DOM.XmlNode as DOM  parseXML :: HXT.XmlPickler a => String -> IO [Either String a] parseXML u = fmap (map (HXT.unpickleDoc' HXT.xpickle)) $   HXT.runX $-    HXT.readDocument [HXT.withCheckNamespaces HXT.yes, HXT.withHTTP [], HXT.withRemoveWS HXT.yes] u+    HXT.readDocument [HXT.withCheckNamespaces HXT.yes, HXT.withRemoveWS HXT.yes] u     HXT.>>> HXT.processBottomUp (HXT.processAttrl (HXT.none `HXT.when` HXT.isNamespaceDeclAttr))  testXML :: (Eq a, HXT.XmlPickler a, Show a) => String -> a -> U.Test
test/XML/Canonical.hs view
@@ -2,20 +2,34 @@ module XML.Canonical (tests) where  import qualified Data.ByteString as BS+import qualified Data.ByteString.UTF8 as BSU+import qualified Data.ByteString.Lazy.UTF8 as BSLU import qualified Test.HUnit as U import qualified Text.XML.HXT.Core as HXT+import System.IO.Unsafe (unsafePerformIO) +import Control.Monad+import Data.Either (isRight)+import SAML2.XML import SAML2.XML.Canonical  canonicalizeXML :: CanonicalizationAlgorithm -> String -> Bool -> IO [BS.ByteString]-canonicalizeXML c f ent = HXT.runX $+canonicalizeXML algo f ent = HXT.runX   (HXT.readDocument [HXT.withCheckNamespaces HXT.yes, HXT.withValidate HXT.no, HXT.withCanonicalize HXT.no, HXT.withSubstDTDEntities ent] f-  HXT.>>> HXT.arrIO (canonicalize c Nothing Nothing))+  HXT.>>> HXT.arrIO (canonicalize algo Nothing Nothing))  testC14N :: CanonicalizationAlgorithm -> String -> Bool -> BS.ByteString -> U.Test-testC14N c f ent s = U.TestCase $-  U.assertEqual (show c ++ ' ' : f) [s] =<< canonicalizeXML c f ent+testC14N algo f ent s = U.TestCase $+  U.assertEqual (show algo ++ ' ' : f) [s] =<< canonicalizeXML algo f ent +testIdempotency :: CanonicalizationAlgorithm -> String -> U.Test+testIdempotency algo input = U.TestCase $ do+  U.assertBool (show algo ++ "[1] " ++ input) (isRight (go input))+  U.assertBool (show algo ++ "[2] " ++ input) (go input == (go >=> go) input)+ where+  go :: String -> Either String String+  go = fmap (BSU.toString . unsafePerformIO . canonicalizeWithRoot algo Nothing Nothing . (: [])) . xmlToDocE . BSLU.fromString+ tests :: U.Test tests = U.test   [ testC14N (CanonicalXML10 False) "test/XML/noncanonical1.xml" False@@ -33,4 +47,5 @@   , testC14N (CanonicalXML10 False) "test/XML/noncanonical6.xml" False     "<doc>\194\169</doc>"   -- , testC14N (CanonicalXML10 False) "test/XML/noncanonical7.xml"+  , testIdempotency (CanonicalXMLExcl10 False) "<a>\n  <b>\n\n\nwef  </b></a>"   ]
test/XML/Signature.hs view
@@ -1,18 +1,26 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+ module XML.Signature (tests) where  import Control.Exception (SomeException, try)+import Control.Monad import Data.ByteString.Base64 import Data.Either (isLeft) import Data.List (isInfixOf) import Data.List.NonEmpty (NonEmpty(..))-import Data.String.Conversions+import Data.Maybe (fromMaybe) import Data.Time import qualified Data.X509 as X509 import GHC.Stack  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.XML as HS import qualified Test.HUnit as U@@ -33,7 +41,7 @@ import XML.Keys  tests :: U.Test-tests = U.test [serializationTests, signVerifyTests, counterExamples]+tests = U.test [serializationTests, signVerifyTests, verifyTests, counterExamples]   ----------------------------------------------------------------------@@ -101,7 +109,7 @@             :| [])           :| [])]] -  , testXML "http://www.w3.org/TR/2002/REC-xmldsig-core-20020212/signature-example-rsa.xml" $+  , testXML "test/XML/signature-example-rsa.xml" $     Signature Nothing       (SignedInfo Nothing         (CanonicalizationMethod@@ -138,7 +146,7 @@         : [])       [] -  , testXML "http://www.w3.org/TR/2002/REC-xmldsig-core-20020212/signature-example-dsa.xml" $+  , testXML "test/XML/signature-example-dsa.xml" $     Signature Nothing       (SignedInfo Nothing         (CanonicalizationMethod@@ -188,36 +196,39 @@   [ U.TestCase $ do       let req = somereq       req' <- signSAMLProtocol privkey1 req-      let reqdoc = samlToDoc req'-      req'' :: AuthnRequest <- verifySAMLProtocol' pubkey1 reqdoc-      U.assertEqual "AuthnRequest with verifySAMLProtocol' (matching pubkeys)" req' req''+      let reqdoc = samlToDocFirstChild req'+      req'' :: AuthnRequest <- verifySAMLProtocolWithKeys pubkey1 reqdoc+      U.assertEqual "AuthnRequest with verifySAMLProtocolWithKeys (matching pubkeys)" req' req''    , U.TestCase $ do       let req = somereq       req' <- signSAMLProtocol privkeyRsa req       let reqdoc = samlToDoc req'-      req'' :: Either SomeException AuthnRequest <- try $ verifySAMLProtocol' pubkey1 reqdoc-      U.assertBool "AuthnRequest with verifySAMLProtocol' (bad pubkeys): isLeft"+      req'' :: Either SomeException AuthnRequest <- try $ verifySAMLProtocolWithKeys pubkey1 reqdoc+      U.assertBool "AuthnRequest with verifySAMLProtocolWithKeys (bad pubkeys): isLeft"         $ isLeft req''-      U.assertBool "AuthnRequest with verifySAMLProtocol' (bad pubkeys): error message matches"-        $ "Left user error (signature verification failed: no matching key/alg pair.)" `isInfixOf` show req''+      U.assertBool "AuthnRequest with verifySAMLProtocolWithKeys (bad pubkeys): error message matches"+        $ "(SignatureVerificationLegacyFailure (Right Nothing))" `isInfixOf` show req''    , U.TestCase $ do       let req = somereq       req' <- signSAMLProtocol privkeyRsa req       let reqdoc = samlToDoc req'-      req'' :: Either SomeException AuthnRequest <- try $ verifySAMLProtocol' (pubkey1 <> dummyPubkeyRSA) reqdoc-      U.assertBool "AuthnRequest with verifySAMLProtocol' (bad pubkeys): isLeft"+      req'' :: Either SomeException AuthnRequest <- try $ verifySAMLProtocolWithKeys (pubkey1 <> dummyPubkeyRSA) reqdoc+      U.assertBool "AuthnRequest with verifySAMLProtocolWithKeys (bad pubkeys): isLeft"         $ isLeft req''-      U.assertBool "AuthnRequest with verifySAMLProtocol' (bad pubkeys): error message matches"-        $ "Left user error (signature verification failed: verification failed.)" `isInfixOf` show req''+      U.assertBool "AuthnRequest with verifySAMLProtocolWithKeys (bad pubkeys): error message matches"+        $ "(SignatureVerificationLegacyFailure (Right (Just False)))" `isInfixOf` show req''    , U.TestCase $ do       let req = somereq       req' <- signSAMLProtocol privkey1 req-      let reqdoc = samlToDoc req'-      req'' :: Either SomeException AuthnRequest <- try $ verifySAMLProtocol' pubkey2 reqdoc-      U.assertBool "AuthnRequest with verifySAMLProtocol' (bad pubkeys)" $ isLeft req''+      let reqdoc = samlToDocFirstChild req'+      req'' :: Either SomeException AuthnRequest <- try $ verifySAMLProtocolWithKeys pubkey2 reqdoc+      U.assertBool "AuthnRequest with verifySAMLProtocolWithKeys (bad pubkeys)"+        $ isLeft req''+      U.assertBool "AuthnRequest with verifySAMLProtocolWithKeys (bad pubkeys): error message matches"+        $ "(SignatureVerificationLegacyFailure (Right (Just False)))" `isInfixOf` show req''   ]  somereq :: AuthnRequest@@ -252,6 +263,55 @@ Just someTime = parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" "2013-03-18T03:28:54.1Z"  ----------------------------------------------------------------------+-- some real-world responses and signature verification runs++data VerifyExample+    = VerifyExample+        BSL.ByteString -- keyinfo from metadata of idp+        BSL.ByteString -- signed response (in the base64 encoded form from the multipart body)+        String -- identifier of the sub-tree of which the signature is to be verified+        (Either SignatureError ()) -- expected result+        Int -- serial number+    deriving (Eq, Show)++verifyTests :: U.Test+verifyTests = U.test $ runVerifyExample <$> examples++runVerifyExample :: VerifyExample -> U.Test+runVerifyExample (VerifyExample keys xmltree refid want examplenumber) = U.TestCase $ do+    let keys' = either (error . show) id $ parseKeyInfo keys+    let xmltree' = either (error . show) id $ (EL.decode >=> xmlToDocE) xmltree+    have <- verifySignatureUnenvelopedSigs keys' refid xmltree'+    U.assertEqual ("verify example #" ++ show examplenumber) want have++parseKeyInfo :: BSL.ByteString -> Either String PublicKeys+parseKeyInfo = getCert >=> getKeys+  where+    getCert :: BSL.ByteString -> Either String X509.SignedCertificate+    getCert raw = case xmlToSAML @KeyInfo raw of+        (Right (keyInfoElements -> X509Data (X509Certificate cert :| []) :| [])) -> Right cert+        bad -> Left $ "unsupported: " ++ show bad++    getKeys :: X509.SignedCertificate -> Either String PublicKeys+    getKeys cert = do+        case X509.certPubKey . X509.signedObject $ X509.getSigned cert of+            X509.PubKeyDSA pk -> Right $ PublicKeys (Just pk) Nothing+            X509.PubKeyRSA pk -> Right $ PublicKeys Nothing (Just pk)+            bad -> Left $ "unsupported: " ++ show bad++examples :: [VerifyExample]+examples = zipWith ($) xs [1 ..]+  where+    xs :: [Int -> VerifyExample]+    xs =+        [ VerifyExample+            "<KeyInfo xmlns=\"http://www.w3.org/2000/09/xmldsig#\"><X509Data><X509Certificate>MIIDBTCCAe2gAwIBAgIQev76BWqjWZxChmKkGqoAfDANBgkqhkiG9w0BAQsFADAtMSswKQYDVQQDEyJhY2NvdW50cy5hY2Nlc3Njb250cm9sLndpbmRvd3MubmV0MB4XDTE4MDIxODAwMDAwMFoXDTIwMDIxOTAwMDAwMFowLTErMCkGA1UEAxMiYWNjb3VudHMuYWNjZXNzY29udHJvbC53aW5kb3dzLm5ldDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAMgmGiRfLh6Fdi99XI2VA3XKHStWNRLEy5Aw/gxFxchnh2kPdk/bejFOs2swcx7yUWqxujjCNRsLBcWfaKUlTnrkY7i9x9noZlMrijgJy/Lk+HH5HX24PQCDf+twjnHHxZ9G6/8VLM2e5ZBeZm+t7M3vhuumEHG3UwloLF6cUeuPdW+exnOB1U1fHBIFOG8ns4SSIoq6zw5rdt0CSI6+l7b1DEjVvPLtJF+zyjlJ1Qp7NgBvAwdiPiRMU4l8IRVbuSVKoKYJoyJ4L3eXsjczoBSTJ6VjV2mygz96DC70MY3avccFrk7tCEC6ZlMRBfY1XPLyldT7tsR3EuzjecSa1M8CAwEAAaMhMB8wHQYDVR0OBBYEFIks1srixjpSLXeiR8zES5cTY6fBMA0GCSqGSIb3DQEBCwUAA4IBAQCKthfK4C31DMuDyQZVS3F7+4Evld3hjiwqu2uGDK+qFZas/D/eDunxsFpiwqC01RIMFFN8yvmMjHphLHiBHWxcBTS+tm7AhmAvWMdxO5lzJLS+UWAyPF5ICROe8Mu9iNJiO5JlCo0Wpui9RbB1C81Xhax1gWHK245ESL6k7YWvyMYWrGqr1NuQcNS0B/AIT1Nsj1WY7efMJQOmnMHkPUTWryVZlthijYyd7P2Gz6rY5a81DAFqhDNJl2pGIAE6HWtSzeUEh3jCsHEkoglKfm4VrGJEuXcALmfCMbdfTvtu4rlsaP2hQad+MG/KJFlenoTK34EMHeBPDCpqNDz8UVNk</X509Certificate></X509Data></KeyInfo>"+            "PHNhbWxwOlJlc3BvbnNlIElEPSJfM2FlYjMwNTQtZTg1Zi00MWZhLWEyMGYtMGYyNzhiMzI3ZjRlIiBWZXJzaW9uPSIyLjAiIElzc3VlSW5zdGFudD0iMjAxOC0wNC0xNFQwOTo1ODo1OC40NTdaIiBEZXN0aW5hdGlvbj0iaHR0cHM6Ly96YjIuemVyb2J1enoubmV0OjYwNDQzL2F1dGhyZXNwIiBJblJlc3BvbnNlVG89ImlkY2YyMjk5YWM1NTFiNDJmMWFhOWI4ODgwNGVkMzA4YzIiIHhtbG5zOnNhbWxwPSJ1cm46b2FzaXM6bmFtZXM6dGM6U0FNTDoyLjA6cHJvdG9jb2wiPjxJc3N1ZXIgeG1sbnM9InVybjpvYXNpczpuYW1lczp0YzpTQU1MOjIuMDphc3NlcnRpb24iPmh0dHBzOi8vc3RzLndpbmRvd3MubmV0LzY4MmZlYmU4LTAyMWItNGZkZS1hYzA5LWU2MDA4NWYwNTE4MS88L0lzc3Vlcj48c2FtbHA6U3RhdHVzPjxzYW1scDpTdGF0dXNDb2RlIFZhbHVlPSJ1cm46b2FzaXM6bmFtZXM6dGM6U0FNTDoyLjA6c3RhdHVzOlN1Y2Nlc3MiLz48L3NhbWxwOlN0YXR1cz48QXNzZXJ0aW9uIElEPSJfYzc5YzNlYzgtMWMyNi00NzUyLTk0NDMtMWY3NmViN2Q1ZGQ2IiBJc3N1ZUluc3RhbnQ9IjIwMTgtMDQtMTRUMDk6NTg6NTguNDQyWiIgVmVyc2lvbj0iMi4wIiB4bWxucz0idXJuOm9hc2lzOm5hbWVzOnRjOlNBTUw6Mi4wOmFzc2VydGlvbiI+PElzc3Vlcj5odHRwczovL3N0cy53aW5kb3dzLm5ldC82ODJmZWJlOC0wMjFiLTRmZGUtYWMwOS1lNjAwODVmMDUxODEvPC9Jc3N1ZXI+PFNpZ25hdHVyZSB4bWxucz0iaHR0cDovL3d3dy53My5vcmcvMjAwMC8wOS94bWxkc2lnIyI+PFNpZ25lZEluZm8+PENhbm9uaWNhbGl6YXRpb25NZXRob2QgQWxnb3JpdGhtPSJodHRwOi8vd3d3LnczLm9yZy8yMDAxLzEwL3htbC1leGMtYzE0biMiLz48U2lnbmF0dXJlTWV0aG9kIEFsZ29yaXRobT0iaHR0cDovL3d3dy53My5vcmcvMjAwMS8wNC94bWxkc2lnLW1vcmUjcnNhLXNoYTI1NiIvPjxSZWZlcmVuY2UgVVJJPSIjX2M3OWMzZWM4LTFjMjYtNDc1Mi05NDQzLTFmNzZlYjdkNWRkNiI+PFRyYW5zZm9ybXM+PFRyYW5zZm9ybSBBbGdvcml0aG09Imh0dHA6Ly93d3cudzMub3JnLzIwMDAvMDkveG1sZHNpZyNlbnZlbG9wZWQtc2lnbmF0dXJlIi8+PFRyYW5zZm9ybSBBbGdvcml0aG09Imh0dHA6Ly93d3cudzMub3JnLzIwMDEvMTAveG1sLWV4Yy1jMTRuIyIvPjwvVHJhbnNmb3Jtcz48RGlnZXN0TWV0aG9kIEFsZ29yaXRobT0iaHR0cDovL3d3dy53My5vcmcvMjAwMS8wNC94bWxlbmMjc2hhMjU2Ii8+PERpZ2VzdFZhbHVlPmxrV25SSUlBRm1IVmVXSVpWWGJhZGoxTzRhN05nNDRwL2NIQkZNOHFhYk09PC9EaWdlc3RWYWx1ZT48L1JlZmVyZW5jZT48L1NpZ25lZEluZm8+PFNpZ25hdHVyZVZhbHVlPmRhZ2VaWTV3aWdWVUpSeVg0bUZDZ0dMOVBhajRuVXpsTmFoQ2d4SkcybVU2M0RhTHpldm1qeWRITHVMWnhGR3MrNmxDRDhpb0xjNUpMckp3OFBlKzB3d1hZV0huTFAvWU53eVFSNWI2bVpUZWpOOUQvcFpORGNSdVRiQmZNeEdsTjhWVU5oaWg3OHRVL24xQmxiZE5oSGpBTmVTbGdPVUNlWWlIZWVzekRHaERYMi9RZ1p6OEJDL3FHa2ZBNUlIbHlSVHJBZkRoTmhGNFRpQ1F5N1haaVRqMXZ4WlE2ZDBBcTVGaWhFc0JtVW9qYnI1WW5KSjA2WjZ2KzRCS1lVWXNkUkY5RklWdlVtRCszckZORlJBQjdBMnp6c0RxYk82UUdham5YNURKaWtaNmtvTmFreFBsM3Jqd29lRWxwTzBDSG5oWXcyMEN1U09kMnVhK2ppeHRvdz09PC9TaWduYXR1cmVWYWx1ZT48S2V5SW5mbz48WDUwOURhdGE+PFg1MDlDZXJ0aWZpY2F0ZT5NSUlEQlRDQ0FlMmdBd0lCQWdJUWV2NzZCV3FqV1p4Q2htS2tHcW9BZkRBTkJna3Foa2lHOXcwQkFRc0ZBREF0TVNzd0tRWURWUVFERXlKaFkyTnZkVzUwY3k1aFkyTmxjM05qYjI1MGNtOXNMbmRwYm1SdmQzTXVibVYwTUI0WERURTRNREl4T0RBd01EQXdNRm9YRFRJd01ESXhPVEF3TURBd01Gb3dMVEVyTUNrR0ExVUVBeE1pWVdOamIzVnVkSE11WVdOalpYTnpZMjl1ZEhKdmJDNTNhVzVrYjNkekxtNWxkRENDQVNJd0RRWUpLb1pJaHZjTkFRRUJCUUFEZ2dFUEFEQ0NBUW9DZ2dFQkFNZ21HaVJmTGg2RmRpOTlYSTJWQTNYS0hTdFdOUkxFeTVBdy9neEZ4Y2huaDJrUGRrL2JlakZPczJzd2N4N3lVV3F4dWpqQ05Sc0xCY1dmYUtVbFRucmtZN2k5eDlub1psTXJpamdKeS9MaytISDVIWDI0UFFDRGYrdHdqbkhIeFo5RzYvOFZMTTJlNVpCZVptK3Q3TTN2aHV1bUVIRzNVd2xvTEY2Y1VldVBkVytleG5PQjFVMWZIQklGT0c4bnM0U1NJb3E2enc1cmR0MENTSTYrbDdiMURFalZ2UEx0SkYrenlqbEoxUXA3TmdCdkF3ZGlQaVJNVTRsOElSVmJ1U1ZLb0tZSm95SjRMM2VYc2pjem9CU1RKNlZqVjJteWd6OTZEQzcwTVkzYXZjY0Zyazd0Q0VDNlpsTVJCZlkxWFBMeWxkVDd0c1IzRXV6amVjU2ExTThDQXdFQUFhTWhNQjh3SFFZRFZSME9CQllFRklrczFzcml4anBTTFhlaVI4ekVTNWNUWTZmQk1BMEdDU3FHU0liM0RRRUJDd1VBQTRJQkFRQ0t0aGZLNEMzMURNdUR5UVpWUzNGNys0RXZsZDNoaml3cXUydUdESytxRlphcy9EL2VEdW54c0ZwaXdxQzAxUklNRkZOOHl2bU1qSHBoTEhpQkhXeGNCVFMrdG03QWhtQXZXTWR4TzVsekpMUytVV0F5UEY1SUNST2U4TXU5aU5KaU81SmxDbzBXcHVpOVJiQjFDODFYaGF4MWdXSEsyNDVFU0w2azdZV3Z5TVlXckdxcjFOdVFjTlMwQi9BSVQxTnNqMVdZN2VmTUpRT21uTUhrUFVUV3J5VlpsdGhpall5ZDdQMkd6NnJZNWE4MURBRnFoRE5KbDJwR0lBRTZIV3RTemVVRWgzakNzSEVrb2dsS2ZtNFZyR0pFdVhjQUxtZkNNYmRmVHZ0dTRybHNhUDJoUWFkK01HL0tKRmxlbm9USzM0RU1IZUJQRENwcU5EejhVVk5rPC9YNTA5Q2VydGlmaWNhdGU+PC9YNTA5RGF0YT48L0tleUluZm8+PC9TaWduYXR1cmU+PFN1YmplY3Q+PE5hbWVJRCBGb3JtYXQ9InVybjpvYXNpczpuYW1lczp0YzpTQU1MOjIuMDpuYW1laWQtZm9ybWF0OnBlcnNpc3RlbnQiPnhKeGRxUzhXMlVYYXdiWlpxcEdGWEtHNHVFbU81R2ppaktEMlJrTWlwQm88L05hbWVJRD48U3ViamVjdENvbmZpcm1hdGlvbiBNZXRob2Q9InVybjpvYXNpczpuYW1lczp0YzpTQU1MOjIuMDpjbTpiZWFyZXIiPjxTdWJqZWN0Q29uZmlybWF0aW9uRGF0YSBJblJlc3BvbnNlVG89ImlkY2YyMjk5YWM1NTFiNDJmMWFhOWI4ODgwNGVkMzA4YzIiIE5vdE9uT3JBZnRlcj0iMjAxOC0wNC0xNFQxMDowMzo1OC40NDJaIiBSZWNpcGllbnQ9Imh0dHBzOi8vemIyLnplcm9idXp6Lm5ldDo2MDQ0My9hdXRocmVzcCIvPjwvU3ViamVjdENvbmZpcm1hdGlvbj48L1N1YmplY3Q+PENvbmRpdGlvbnMgTm90QmVmb3JlPSIyMDE4LTA0LTE0VDA5OjUzOjU4LjQ0MloiIE5vdE9uT3JBZnRlcj0iMjAxOC0wNC0xNFQxMDo1Mzo1OC40NDJaIj48QXVkaWVuY2VSZXN0cmljdGlvbj48QXVkaWVuY2U+aHR0cHM6Ly96YjIuemVyb2J1enoubmV0OjYwNDQzL2F1dGhyZXNwPC9BdWRpZW5jZT48L0F1ZGllbmNlUmVzdHJpY3Rpb24+PC9Db25kaXRpb25zPjxBdHRyaWJ1dGVTdGF0ZW1lbnQ+PEF0dHJpYnV0ZSBOYW1lPSJodHRwOi8vc2NoZW1hcy5taWNyb3NvZnQuY29tL2lkZW50aXR5L2NsYWltcy90ZW5hbnRpZCI+PEF0dHJpYnV0ZVZhbHVlPjY4MmZlYmU4LTAyMWItNGZkZS1hYzA5LWU2MDA4NWYwNTE4MTwvQXR0cmlidXRlVmFsdWU+PC9BdHRyaWJ1dGU+PEF0dHJpYnV0ZSBOYW1lPSJodHRwOi8vc2NoZW1hcy5taWNyb3NvZnQuY29tL2lkZW50aXR5L2NsYWltcy9vYmplY3RpZGVudGlmaWVyIj48QXR0cmlidXRlVmFsdWU+Y2NmYjM3ODgtODI0MS00YWZlLTg4OTctZjMxM2YzNWY5ZTM3PC9BdHRyaWJ1dGVWYWx1ZT48L0F0dHJpYnV0ZT48QXR0cmlidXRlIE5hbWU9Imh0dHA6Ly9zY2hlbWFzLnhtbHNvYXAub3JnL3dzLzIwMDUvMDUvaWRlbnRpdHkvY2xhaW1zL25hbWUiPjxBdHRyaWJ1dGVWYWx1ZT5maXN4dDFAYXp1cmV3aXJlLm9ubWljcm9zb2Z0LmNvbTwvQXR0cmlidXRlVmFsdWU+PC9BdHRyaWJ1dGU+PEF0dHJpYnV0ZSBOYW1lPSJodHRwOi8vc2NoZW1hcy5taWNyb3NvZnQuY29tL2lkZW50aXR5L2NsYWltcy9kaXNwbGF5bmFtZSI+PEF0dHJpYnV0ZVZhbHVlPmZpc3h0MTwvQXR0cmlidXRlVmFsdWU+PC9BdHRyaWJ1dGU+PEF0dHJpYnV0ZSBOYW1lPSJodHRwOi8vc2NoZW1hcy5taWNyb3NvZnQuY29tL2lkZW50aXR5L2NsYWltcy9pZGVudGl0eXByb3ZpZGVyIj48QXR0cmlidXRlVmFsdWU+aHR0cHM6Ly9zdHMud2luZG93cy5uZXQvNjgyZmViZTgtMDIxYi00ZmRlLWFjMDktZTYwMDg1ZjA1MTgxLzwvQXR0cmlidXRlVmFsdWU+PC9BdHRyaWJ1dGU+PEF0dHJpYnV0ZSBOYW1lPSJodHRwOi8vc2NoZW1hcy5taWNyb3NvZnQuY29tL2NsYWltcy9hdXRobm1ldGhvZHNyZWZlcmVuY2VzIj48QXR0cmlidXRlVmFsdWU+aHR0cDovL3NjaGVtYXMubWljcm9zb2Z0LmNvbS93cy8yMDA4LzA2L2lkZW50aXR5L2F1dGhlbnRpY2F0aW9ubWV0aG9kL3Bhc3N3b3JkPC9BdHRyaWJ1dGVWYWx1ZT48L0F0dHJpYnV0ZT48L0F0dHJpYnV0ZVN0YXRlbWVudD48QXV0aG5TdGF0ZW1lbnQgQXV0aG5JbnN0YW50PSIyMDE4LTA0LTE0VDA5OjU4OjU1LjYxM1oiIFNlc3Npb25JbmRleD0iX2M3OWMzZWM4LTFjMjYtNDc1Mi05NDQzLTFmNzZlYjdkNWRkNiI+PEF1dGhuQ29udGV4dD48QXV0aG5Db250ZXh0Q2xhc3NSZWY+dXJuOm9hc2lzOm5hbWVzOnRjOlNBTUw6Mi4wOmFjOmNsYXNzZXM6UGFzc3dvcmQ8L0F1dGhuQ29udGV4dENsYXNzUmVmPjwvQXV0aG5Db250ZXh0PjwvQXV0aG5TdGF0ZW1lbnQ+PC9Bc3NlcnRpb24+PC9zYW1scDpSZXNwb25zZT4K"+            "_c79c3ec8-1c26-4752-9443-1f76eb7d5dd6"+            (Right ())+        ]++---------------------------------------------------------------------- -- more counter-examples  counterExamples :: U.Test@@ -261,21 +321,17 @@       U.assertEqual "canoncalization broke the input" i o   ] -canonicalizeCounterExample :: HasCallStack => BS.ByteString -> IO (LBS, LBS)+canonicalizeCounterExample :: HasCallStack => BS.ByteString -> IO (LBS.ByteString, LBS.ByteString) canonicalizeCounterExample base64input = do   let inbs :: LBS.ByteString-      inbs = either (error "badcase") cs $ Data.ByteString.Base64.decode base64input+      inbs = either (error "badcase") BS.fromStrict $ Data.ByteString.Base64.decode base64input        tree :: XmlTree-      tree = maybe (error "badcase") id $ HS.xmlToDoc inbs+      tree = fromMaybe (error "badcase") $ HS.xmlToDoc inbs        algo :: CanonicalizationAlgorithm       algo = CanonicalXMLExcl10 {canonicalWithComments = True} -  outbs :: LBS.ByteString <- cs <$> canonicalize algo Nothing Nothing (NTree (XTag (mkQName "" "" "root") []) [tree])--  -- LBS.putStr ("[" <> inbs <> "]\n")-  -- LBS.putStr ("[" <> outbs <> "]\n")-  -- print $ inbs == outbs+  outbs :: LBS.ByteString <- BS.fromStrict <$> canonicalize algo Nothing Nothing (NTree (XTag (mkQName "" "" "root") []) [tree])    pure (inbs, outbs)