diff --git a/SAML2/Core/Assertions.hs b/SAML2/Core/Assertions.hs --- a/SAML2/Core/Assertions.hs +++ b/SAML2/Core/Assertions.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE FlexibleContexts #-} @@ -445,7 +446,11 @@ -- |§2.7.4.3 newtype Evidence = Evidence{ evidence :: [AssertionRef] } - deriving (Eq, Show, Monoid) + deriving (Eq, Show +#if MIN_VERSION_base(4,11,0) + , Semigroup +#endif + , Monoid) instance XP.XmlPickler Evidence where xpickle = [XP.biCase| diff --git a/SAML2/Core/Protocols.hs b/SAML2/Core/Protocols.hs --- a/SAML2/Core/Protocols.hs +++ b/SAML2/Core/Protocols.hs @@ -66,7 +66,7 @@ samlProtocol' :: Lens' a ProtocolType isSAMLResponse :: a -> Bool isSAMLResponse_ :: Proxy a -> Maybe Bool - isSAMLResponse_ = Just . isSAMLResponse . asProxyTypeOf undefined + isSAMLResponse_ = Just . isSAMLResponse . asProxyTypeOf undefined -- |§3.2.1 newtype RequestAbstractType = RequestAbstractType @@ -152,24 +152,24 @@ data StatusCode2 = StatusAuthnFailed - | StatusInvalidAttrNameOrValue - | StatusInvalidNameIDPolicy - | StatusNoAuthnContext - | StatusNoAvailableIDP - | StatusNoPassive - | StatusNoSupportedIDP - | StatusPartialLogout - | StatusProxyCountExceeded - | StatusRequestDenied - | StatusRequestUnsupported + | StatusInvalidAttrNameOrValue + | StatusInvalidNameIDPolicy + | StatusNoAuthnContext + | StatusNoAvailableIDP + | StatusNoPassive + | StatusNoSupportedIDP + | StatusPartialLogout + | StatusProxyCountExceeded + | StatusRequestDenied + | StatusRequestUnsupported | StatusRequestVersionDeprecated - | StatusRequestVersionTooHigh - | StatusRequestVersionTooLow - | StatusResourceNotRecognized - | StatusTooManyResponses - | StatusUnknownAttrProfile - | StatusUnknownPrincipal - | StatusUnsupportedBinding + | StatusRequestVersionTooHigh + | StatusRequestVersionTooLow + | StatusResourceNotRecognized + | StatusTooManyResponses + | StatusUnknownAttrProfile + | StatusUnknownPrincipal + | StatusUnsupportedBinding deriving (Eq, Bounded, Enum, Show) instance Identifiable URI StatusCode2 where @@ -564,7 +564,7 @@ , logoutRequestReason :: Maybe (Identified XString LogoutReason) , logoutRequestNotOnOrAfter :: Maybe XS.DateTime , logoutRequestIdentifier :: SAML.PossiblyEncrypted SAML.Identifier - , logoutRequestSessionIndex :: Maybe XString + , logoutRequestSessionIndex :: [XString] } deriving (Eq, Show) instance XP.XmlPickler LogoutRequest where @@ -574,7 +574,7 @@ XP.>*< XP.xpAttrImplied "Reason" XP.xpickle XP.>*< XP.xpAttrImplied "NotOnOrAfter" XS.xpDateTime XP.>*< SAML.xpPossiblyEncrypted - XP.>*< XP.xpOption (xpElem "SessionIndex" XS.xpString)) + XP.>*< XP.xpList (xpElem "SessionIndex" XS.xpString)) instance DS.Signable LogoutRequest where signature' = samlProtocol' . DS.signature' signedID = protocolID . view samlProtocol' @@ -659,14 +659,14 @@ data AnyRequest = RequestAssertionIDRequest !AssertionIDRequest - | RequestAuthnQuery !AuthnQuery - | RequestAttributeQuery !AttributeQuery - | RequestAuthzDecisionQuery !AuthzDecisionQuery + | RequestAuthnQuery !AuthnQuery + | RequestAttributeQuery !AttributeQuery + | RequestAuthzDecisionQuery !AuthzDecisionQuery | RequestAuthnRequest !AuthnRequest - | RequestArtifactResolve !ArtifactResolve - | RequestManageNameIDRequest !ManageNameIDRequest - | RequestLogoutRequest !LogoutRequest - | RequestNameIDMappingRequest !NameIDMappingRequest + | RequestArtifactResolve !ArtifactResolve + | RequestManageNameIDRequest !ManageNameIDRequest + | RequestLogoutRequest !LogoutRequest + | RequestNameIDMappingRequest !NameIDMappingRequest deriving (Eq, Show) instance XP.XmlPickler AnyRequest where @@ -717,8 +717,8 @@ s (RequestNameIDMappingRequest r) q = RequestNameIDMappingRequest $ samlRequest' .~ q $ r data AnyResponse - = ResponseResponse !Response - | ResponseArtifactResponse !ArtifactResponse + = ResponseResponse !Response + | ResponseArtifactResponse !ArtifactResponse deriving (Eq, Show) instance XP.XmlPickler AnyResponse where @@ -739,7 +739,7 @@ g (ResponseArtifactResponse r) = r ^. samlResponse' s (ResponseResponse r) q = ResponseResponse $ samlResponse' .~ q $ r s (ResponseArtifactResponse r) q = ResponseArtifactResponse $ samlResponse' .~ q $ r - + data AnyProtocol = ProtocolRequest !AnyRequest | ProtocolResponse !AnyResponse diff --git a/SAML2/Core/Signature.hs b/SAML2/Core/Signature.hs --- a/SAML2/Core/Signature.hs +++ b/SAML2/Core/Signature.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} -- | -- SAML and XML Signature Syntax and Processing -- @@ -5,16 +6,18 @@ module SAML2.Core.Signature ( signSAMLProtocol , verifySAMLProtocol + , verifySAMLProtocol' ) where +import Control.Exception import Control.Lens ((^.), (.~)) import Control.Monad (unless) import qualified Data.ByteString.Lazy as BSL import Data.List.NonEmpty (NonEmpty((:|))) import Network.URI (URI(uriFragment), nullURI) +import Text.XML.HXT.DOM.TypeDefs import SAML2.XML -import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP import qualified SAML2.XML.Canonical as C14N import qualified SAML2.XML.Signature as DS import qualified SAML2.Core.Protocols as SAMLP @@ -31,7 +34,7 @@ : [] , DS.referenceDigestMethod = DS.simpleDigest DS.DigestSHA1 , DS.referenceDigestValue = error "signSAMLProtocol: referenceDigestValue" - } $ XP.pickleDoc XP.xpickle m + } $ samlToDoc m s' <- DS.generateSignature sk $ maybe DS.SignedInfo { DS.signedInfoId = Nothing , DS.signedInfoCanonicalizationMethod = DS.simpleCanonicalization $ C14N.CanonicalXMLExcl10 False @@ -53,3 +56,17 @@ v <- DS.verifySignature mempty (DS.signedID m) x unless (or v) $ fail "verifySAMLProtocol: invalid or missing signature" 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 + 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 diff --git a/SAML2/Metadata/Metadata.hs b/SAML2/Metadata/Metadata.hs --- a/SAML2/Metadata/Metadata.hs +++ b/SAML2/Metadata/Metadata.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -149,7 +150,11 @@ -- |§2.3.1 empty list means missing newtype Extensions = Extensions{ extensions :: Nodes } - deriving (Eq, Show, Monoid) + deriving (Eq, Show +#if MIN_VERSION_base(4,11,0) + , Semigroup +#endif + , Monoid) instance XP.XmlPickler Extensions where xpickle = XP.xpDefault (Extensions []) $ diff --git a/SAML2/XML.hs b/SAML2/XML.hs --- a/SAML2/XML.hs +++ b/SAML2/XML.hs @@ -26,12 +26,15 @@ ) where import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as BSLC +import qualified Data.ByteString.Lazy.UTF8 as BSLU import Data.Default (Default(..)) import qualified Data.Invertible as Inv 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 Text.XML.HXT.DOM.XmlNode (getChildren) import SAML2.XML.Types import SAML2.Core.Datatypes @@ -98,7 +101,7 @@ . XP.pickleDoc XP.xpickle docToXML :: HXT.XmlTree -> BSL.ByteString -docToXML = BSL.concat . HXT.runLA (HXT.xshowBlob HXT.getChildren) +docToXML = xshow' cquot aquot (:) . getChildren where (cquot, aquot) = escapeXmlRefs samlToXML :: XP.XmlPickler a => a -> BSL.ByteString samlToXML = docToXML . samlToDoc @@ -109,7 +112,7 @@ HXT.>>> HXT.removeWhiteSpace HXT.>>> HXT.neg HXT.isXmlPi HXT.>>> HXT.propagateNamespaces) - . BSLC.unpack -- XXX encoding? + . BSLU.toString docToSAML :: XP.XmlPickler a => HXT.XmlTree -> Either String a docToSAML = XP.unpickleDoc' XP.xpickle diff --git a/SAML2/XML/Schema/Datatypes.hs b/SAML2/XML/Schema/Datatypes.hs --- a/SAML2/XML/Schema/Datatypes.hs +++ b/SAML2/XML/Schema/Datatypes.hs @@ -13,6 +13,8 @@ import Data.Char (isDigit) 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) @@ -57,7 +59,7 @@ prd ('+':s) = prp s prd s = prp s prp ('P':s) = pru (0 :: Pico) prt [('Y',31556952),('M',2629746),('D',86400)] s - prp _ = Nothing + prp _ = Nothing prt x "" = Just x prt x ('T':s) = pru x prs [('H',3600),('M',60)] s prt _ _ = Nothing @@ -76,13 +78,26 @@ xpDateTime :: XP.PU DateTime xpDateTime = XP.PU { XP.theSchema = XPS.scDTxsd XSD.xsd_dateTime [] - , XP.appPickle = XP.putCont . XN.mkText . formatTime defaultTimeLocale fmt - , XP.appUnPickle = XP.getCont >>= XP.liftMaybe "dateTime expects text" . XN.getText >>= parseTimeM True defaultTimeLocale fmtz + , XP.appPickle = XP.putCont . XN.mkText . tweakTimeString . formatTime defaultTimeLocale fmtz + , XP.appUnPickle = XP.getCont >>= XP.liftMaybe "dateTime expects text" . XN.getText >>= parseTime } where - fmt = "%0Y-%m-%dT%H:%M:%S%Q" - fmtz = fmt ++ "%Z" + -- timezone must be 'Z', and MicrosoftS(tm) Azure(tm) will choke when it is ommitted. (error + -- messages are utterly unhelpful.) + fmtz = "%Y-%m-%dT%H:%M:%S%QZ" + parseTime dateString = maybe (XP.throwMsg $ "can't parse date " <> dateString) pure + $ parseTimeM True defaultTimeLocale fmtz dateString + + -- adding '%Q' may be longer than 7 digits, which makes MicrosoftS(tm) Azure(tm) choke. + tweakTimeString :: String -> String + tweakTimeString s = case elemIndex '.' s of + Nothing -> s + Just i -> case splitAt i s of + (t, u) -> case splitAt 8 u of + (_, "") -> t ++ u + (v, _) -> t ++ v ++ "Z" + -- |§3.2.16 type Base64Binary = BS.ByteString @@ -96,7 +111,7 @@ type AnyURI = URI.URI xpAnyURI :: XP.PU AnyURI -xpAnyURI = XP.xpWrapEither +xpAnyURI = XP.xpWrapEither ( maybe (Left "invalid anyURI") Right . URI.parseURIReference , \u -> URI.uriToString id u "") $ XP.xpText0DT $ XPS.scDTxsd XSD.xsd_anyURI [] @@ -173,4 +188,3 @@ ( \x -> if x > 0 then Right x else Left "0 is not positive" , id ) $ XP.xpPrim{ XP.theSchema = XPS.scDTxsd XSD.xsd_positiveInteger [] } - diff --git a/SAML2/XML/Signature.hs b/SAML2/XML/Signature.hs --- a/SAML2/XML/Signature.hs +++ b/SAML2/XML/Signature.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} -- | -- XML Signature Syntax and Processing @@ -35,6 +36,7 @@ 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 import SAML2.XML import SAML2.XML.Canonical @@ -48,12 +50,12 @@ getID = HXT.deep . HXT.hasAttrValue "ID" . (==) applyCanonicalization :: CanonicalizationMethod -> Maybe String -> HXT.XmlTree -> IO BS.ByteString -applyCanonicalization (CanonicalizationMethod (Identified a) ins []) = canonicalize a ins -applyCanonicalization m = fail $ "applyCanonicalization: unsupported " ++ show m +applyCanonicalization (CanonicalizationMethod (Identified a) ins []) x y = canonicalize a ins x y +applyCanonicalization m _ _ = fail $ "applyCanonicalization: unsupported " ++ show m applyTransformsBytes :: [Transform] -> BSL.ByteString -> IO BSL.ByteString -applyTransformsBytes [] = return -applyTransformsBytes (t : _) = fail ("applyTransforms: unsupported Signature " ++ show t) +applyTransformsBytes [] v = return v +applyTransformsBytes (t : _) _ = fail ("applyTransforms: unsupported Signature " ++ show t) applyTransformsXML :: [Transform] -> HXT.XmlTree -> IO BSL.ByteString applyTransformsXML (Transform (Identified (TransformCanonicalization a)) ins x : tl) = @@ -104,6 +106,11 @@ , publicKeyRSA :: Maybe RSA.PublicKey } deriving (Eq, Show) +#if MIN_VERSION_base(4,11,0) +instance Semigroup PublicKeys where + PublicKeys dsa1 rsa1 <> PublicKeys dsa2 rsa2 = + PublicKeys (dsa1 <|> dsa2) (rsa1 <|> rsa2) +#endif instance Monoid PublicKeys where mempty = PublicKeys Nothing Nothing PublicKeys dsa1 rsa1 `mappend` PublicKeys dsa2 rsa2 = @@ -149,6 +156,7 @@ signBytes (SigningKeyRSA k) b = either (fail . show) return =<< RSA.signSafer (Just SHA1) (RSA.toPrivateKey k) b +-- | indicate verification result; return 'Nothing' if no matching key/alg pair is found verifyBytes :: PublicKeys -> IdentifiedURI SignatureAlgorithm -> BS.ByteString -> BS.ByteString -> Maybe Bool verifyBytes PublicKeys{ publicKeyDSA = Just k } (Identified SignatureDSA_SHA1) sig m = Just $ BS.length sig == 40 && @@ -156,6 +164,8 @@ where (r, s) = BS.splitAt 20 sig verifyBytes PublicKeys{ publicKeyRSA = Just k } (Identified SignatureRSA_SHA1) sig m = Just $ RSA.verify (Just SHA1) k m sig +verifyBytes PublicKeys{ publicKeyRSA = Just k } (Identified SignatureRSA_SHA256) sig m = Just $ + RSA.verify (Just SHA256) k m sig verifyBytes _ _ _ _ = Nothing signBase64 :: SigningKey -> BS.ByteString -> IO BS.ByteString @@ -177,9 +187,14 @@ , signatureObject = [] } +-- 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 +-- Just True: everything is ok! verifySignature :: PublicKeys -> String -> HXT.XmlTree -> IO (Maybe Bool) verifySignature pks xid doc = do - x <- case HXT.runLA (getID xid) doc of + let namespaces = DOM.toNsEnv $ HXT.runLA HXT.collectNamespaceDecl doc + x <- case HXT.runLA (getID xid HXT.>>> HXT.attachNsEnv namespaces) doc of [x] -> return x _ -> fail "verifySignature: element not found" sx <- case child "Signature" x of @@ -189,8 +204,11 @@ six <- applyCanonicalization (signedInfoCanonicalizationMethod si) (Just xpath) $ DOM.mkRoot [] [x] rl <- mapM (`verifyReference` x) (signedInfoReference si) let keys = pks <> foldMap (foldMap keyinfo . keyInfoElements) (signatureKeyInfo s) - return $ ((any (Just xid ==) rl && all isJust rl) &&) - <$> verifyBytes keys (signatureMethodAlgorithm $ signedInfoSignatureMethod si) (signatureValue $ signatureSignatureValue s) six + verified :: Maybe Bool + verified = verifyBytes keys (signatureMethodAlgorithm $ signedInfoSignatureMethod si) (signatureValue $ signatureSignatureValue s) six + valid :: Bool + valid = elem (Just xid) rl && all isJust rl + return $ (valid &&) <$> verified where child n = HXT.runLA $ HXT.getChildren HXT.>>> isDSElem n HXT.>>> HXT.cleanupNamespaces HXT.collectPrefixUriPairs keyinfo (KeyInfoKeyValue kv) = publicKeyValues kv diff --git a/hsaml2.cabal b/hsaml2.cabal --- a/hsaml2.cabal +++ b/hsaml2.cabal @@ -1,5 +1,5 @@ name: hsaml2 -version: 0.1 +version: 0.1.1 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,11 +10,22 @@ category: Security, Network, Web build-type: Simple cabal-version: >=1.10 -tested-with: GHC == 7.10.3 +tested-with: GHC == 8.0.2 || == 8.2.2 || == 8.4.4 || == 8.6.5 || == 8.8.3 extra-source-files: - test/XML/signature-example.xml + test/Metadata/metadata-idp.xml + test/Metadata/metadata-nyu.xml + test/Metadata/metadata-osf.xml + test/Metadata/metadata-sp.xml test/XML/encryption-example.xml + test/XML/noncanonical1.xml + test/XML/noncanonical2.xml + test/XML/noncanonical3.xml + test/XML/noncanonical4.xml + test/XML/noncanonical5.xml + test/XML/noncanonical6.xml + test/XML/signature-example.xml + test/XML/world.txt source-repository head type: git @@ -55,7 +66,7 @@ SAML2.Bindings.Internal c-sources: SAML2/XML/libxml2_stub.c - build-depends: + build-depends: asn1-encoding, asn1-types >= 0.2, base >=4.8 && <5, @@ -77,6 +88,7 @@ semigroups, template-haskell, time, + utf8-string, x509, zlib pkgconfig-depends: libxml-2.0 @@ -98,12 +110,15 @@ ghc-options: -Wall build-depends: base, + base64-bytestring, bytestring, + cryptonite, hsaml2, hxt, hxt-http, network-uri, semigroups, + string-conversions, time, x509, HUnit diff --git a/test/Bindings/HTTPRedirect.hs b/test/Bindings/HTTPRedirect.hs --- a/test/Bindings/HTTPRedirect.hs +++ b/test/Bindings/HTTPRedirect.hs @@ -30,7 +30,7 @@ Nothing Nothing (NotEncrypted $ IdentifierName $ simpleNameID NameIDFormatPersistent "005a06e0-ad82-110d-a556-004005b13a2b") - (Just "1")) + ["1"]) =<< decodeURI mempty (uri "https://ServiceProvider.com/SAML/SLO/Browser?SAMLRequest=fVFdS8MwFH0f7D%2BUvGdNsq62oSsIQyhMESc%2B%2BJYlmRbWpObeyvz3puv2IMjyFM7HPedyK1DdsZdb%2F%2BEHfLFfgwVMTt3RgTwzazIEJ72CFqRTnQWJWu7uH7dSLJjsg0ev%2FZFMlttiBWADtt6R%2BSyJr9msiRH7O70sCm31Mj%2Bo%2BC%2B1KA5GlEWeZaogSQMw2MYBKodrIhjLKONU8FdeSsZkVr6T5M0GiHMjvWCknqZXZ2OoPxF7kGnaGOuwxZ%2Fn4L9bY8NC%2By4du1XpRXnxPcXizSZ58KFTeHujEWkNPZylsh9bAMYYUjO2Uiy3jCpTCMo5M1StVjmN9SO150sl9lU6RV2Dp0vsLIy7NM7YU82r9B90PrvCf85W%2FwL8zSVQzAEAAA%3D%3D&RelayState=0043bfc1bc45110dae17004005b13a2b") , U.TestCase $ U.assertEqual "response" (LogoutResponse $ StatusResponseType diff --git a/test/Metadata/metadata-idp.xml b/test/Metadata/metadata-idp.xml new file mode 100644 --- /dev/null +++ b/test/Metadata/metadata-idp.xml @@ -0,0 +1,86 @@ + + + + + IdentityProvider.com SSO Key + + + + + + urn:oasis:names:tc:SAML:1.1:nameid-format:X509SubjectName + urn:oasis:names:tc:SAML:2.0:nameid-format:persistent + urn:oasis:names:tc:SAML:2.0:nameid-format:transient + + + + + + member + student + faculty + employee + staff + + + + + + IdentityProvider.com AA Key + + + + + urn:oasis:names:tc:SAML:1.1:nameid-format:X509SubjectName + urn:oasis:names:tc:SAML:2.0:nameid-format:persistent + urn:oasis:names:tc:SAML:2.0:nameid-format:transient + + + + member + student + faculty + employee + staff + + + + Identity Providers R US + Identity Providers R US, a Division of Lerxst Corp. + https://IdentityProvider.com + + diff --git a/test/Metadata/metadata-nyu.xml b/test/Metadata/metadata-nyu.xml new file mode 100644 --- /dev/null +++ b/test/Metadata/metadata-nyu.xml @@ -0,0 +1,114 @@ + + + + nyu.edu + + + + + + + MIIGTTCCBTWgAwIBAgIBfDANBgkqhkiG9w0BAQUFADBWMQswCQYDVQQGEwJVUzEc + MBoGA1UEChMTSW5Db21tb24gRmVkZXJhdGlvbjEpMCcGA1UEAxMgSW5Db21tb24g + Q2VydGlmaWNhdGlvbiBBdXRob3JpdHkwHhcNMDcwMTE2MjMyMzAzWhcNMDgwMTE2 + MjMyMzAzWjA4MQswCQYDVQQGEwJVUzEMMAoGA1UEChMDTllVMRswGQYDVQQDExJz + aGliYm9sZXRoLm55dS5lZHUwggG4MIIBLAYHKoZIzjgEATCCAR8CgYEA/X9TgR11 + EilS30qcLuzk5/YRt1I870QAwx4/gLZRJmlFXUAiUftZPY1Y+r/F9bow9subVWzX + gTuAHTRv8mZgt2uZUKWkn5/oBHsQIsJPu6nX/rfGG/g7V+fGqKYVDwT7g/bTxR7D + AjVUE1oWkTL2dfOuK2HXKu/yIgMZndFIAccCFQCXYFCPFSMLzLKSuYKi64QL8Fgc + 9QKBgQD34aCF1ps93su8q1w2uFe5eZSvu/o66oL5V0wLPQeCZ1FZV4661FlP5nEH + EIGAtEkWcSPoTCgWE7fPCTKMyKbhPBZ6i1R8jSjgo64eK7OmdZFuo38L+iE1YvH7 + YnoBJDvMpPG+qFGQiaiD3+Fa5Z8GkotmXoB7VSVkAUw7/s9JKgOBhQACgYEA5GK+ + eV3YuyfbTeJXnqV4jT+Ocz7XCL4TmeYApcuA/tG7vRRKl2Oyo93VCe7GxwOAFyp2 + ajqxdzB/yB/Mcz80GELz/UE6vkA9CW315gHQ+zWImUbPxdp5vfoe1wZ7WmXDRN5+ + 4SDptlKBPsZBatAJhBjJOkWL/z09dyRdg+YYXcGjggKsMIICqDAOBgNVHQ8BAf8E + BAMCBaAwDAYDVR0TAQH/BAIwADAdBgNVHSUEFjAUBggrBgEFBQcDAQYIKwYBBQUH + AwIwHQYDVR0OBBYEFInR3E2yLHtThH/xcXn8RjPAFno4MH4GA1UdIwR3MHWAFJMt + yGEYrWPjm2Wznd2Nk7rnymNFoVqkWDBWMQswCQYDVQQGEwJVUzEcMBoGA1UEChMT + SW5Db21tb24gRmVkZXJhdGlvbjEpMCcGA1UEAxMgSW5Db21tb24gQ2VydGlmaWNh + dGlvbiBBdXRob3JpdHmCAQAwgboGCCsGAQUFBwEBBIGtMIGqMIGnBggrBgEFBQcw + AoaBmmh0dHA6Ly9pbmNvbW1vbmNhMS5pbmNvbW1vbmZlZGVyYXRpb24ub3JnL2Jy + aWRnZS9jZXJ0cy9jYS1jZXJ0cy5wN2IKCQlDQSBJc3N1ZXJzIC0gVVJJOmh0dHA6 + Ly9pbmNvbW1vbmNhMi5pbmNvbW1vbmZlZGVyYXRpb24ub3JnL2JyaWRnZS9jZXJ0 + cy9jYS1jZXJ0cy5wN2IwgY0GA1UdHwSBhTCBgjA/oD2gO4Y5aHR0cDovL2luY29t + bW9uY3JsMS5pbmNvbW1vbmZlZGVyYXRpb24ub3JnL2NybC9lZWNybHMuY3JsMD+g + PaA7hjlodHRwOi8vaW5jb21tb25jcmwyLmluY29tbW9uZmVkZXJhdGlvbi5vcmcv + Y3JsL2VlY3Jscy5jcmwwXgYDVR0gBFcwVTBTBgsrBgEEAa4jAQQBATBEMEIGCCsG + AQUFBwIBFjZodHRwOi8vaW5jb21tb25jYS5pbmNvbW1vbmZlZGVyYXRpb24ub3Jn + L3ByYWN0aWNlcy5wZGYwHQYDVR0RBBYwFIISc2hpYmJvbGV0aC5ueXUuZWR1MA0G + CSqGSIb3DQEBBQUAA4IBAQCtTu3zFQro8ocJP9jfnJe7LQwvC+8W0n/AxJnkoadA + WXvL6sWU/FoTg48ppe6A4LFmZ8SZIq/7Neo6SfvUkhT+O9mArnjZJ6XAu/cH0fD/ + KBAkUhkEQlltSy1PT2Apor/ti20IV6ycXJPc4AVBh7X/mKpZ646CWnHvoiPUqPAi + zjxkx0TmosaL+2IVA8/Vd2FXp+cJLJgoXMSDeTs2nfj90+hNE5GE9shRf6lJlpdV + 4nVc74u6E0RwoCe/76Uruk9VzciLSiJwEj/kuFPfg93s1K5w1xyslmtdxYd6HbEx + NGqVSO5aqZjOpoF5O/Kp39NX1iv08yjLUGus10UlK5Bx + + + + + + + + + + MIIE6DCCA9CgAwIBAgIJAI2V7DmlgLQ1MA0GCSqGSIb3DQEBBQUAMIGoMQswCQYD + VQQGEwJVUzERMA8GA1UECBMITmV3IFlvcmsxETAPBgNVBAcTCE5ldyBZb3JrMRww + GgYDVQQKExNOZXcgWW9yayBVbml2ZXJzaXR5MQwwCgYDVQQLEwNJVFMxIjAgBgNV + BAMTGXVybjptYWNlOmluY29tbW9uOm55dS5lZHUxIzAhBgkqhkiG9w0BCQEWFGlk + bS5zZXJ2aWNlc0BueXUuZWR1MB4XDTEyMDgxMDIxMzUxNloXDTIyMDgwODIxMzUx + NlowgagxCzAJBgNVBAYTAlVTMREwDwYDVQQIEwhOZXcgWW9yazERMA8GA1UEBxMI + TmV3IFlvcmsxHDAaBgNVBAoTE05ldyBZb3JrIFVuaXZlcnNpdHkxDDAKBgNVBAsT + A0lUUzEiMCAGA1UEAxMZdXJuOm1hY2U6aW5jb21tb246bnl1LmVkdTEjMCEGCSqG + SIb3DQEJARYUaWRtLnNlcnZpY2VzQG55dS5lZHUwggEiMA0GCSqGSIb3DQEBAQUA + A4IBDwAwggEKAoIBAQDfb4botPJTcMPCLDenzHqWAOJFenUGEAL33ROzA687b73F + g72Fnlh2Pp7HNhbB3+cQjsQODitjFdUVQgX8EAP3xMZAGKU2M/0ZGfnGokj5oiU0 + 80ii6zOzEDUCkulR5CW6p+mgdoCYXs3b9riwm1X5pqi/4ZbCKP+K6TiSBOGWxtCs + Bp7mWFdJlWUT6a3VRdoYmUUQEOJfrTyT8CW0dk0DGToWe2j3taxGT89E3VA6w5Gk + tQK5sxllEAVQ23fiMdouDAtr4gDNvOSwtYUuDwh/Ppl/lAMwjU+dv08pNuJR9drF + jYM0jKoiPsG9AdEwkFSGQb0IB1wt8+wAeTCXIKMrAgMBAAGjggERMIIBDTAdBgNV + HQ4EFgQUleQurEqBxsOHqhL90hCiWMKIvx0wgd0GA1UdIwSB1TCB0oAUleQurEqB + xsOHqhL90hCiWMKIvx2hga6kgaswgagxCzAJBgNVBAYTAlVTMREwDwYDVQQIEwhO + ZXcgWW9yazERMA8GA1UEBxMITmV3IFlvcmsxHDAaBgNVBAoTE05ldyBZb3JrIFVu + aXZlcnNpdHkxDDAKBgNVBAsTA0lUUzEiMCAGA1UEAxMZdXJuOm1hY2U6aW5jb21t + b246bnl1LmVkdTEjMCEGCSqGSIb3DQEJARYUaWRtLnNlcnZpY2VzQG55dS5lZHWC + CQCNlew5pYC0NTAMBgNVHRMEBTADAQH/MA0GCSqGSIb3DQEBBQUAA4IBAQDC7w4Z + zk/qgpNhmee03UxGOixlFn+UaY6QEdjBIO3O3m20hEWLp4Pa+TBvsSlsFWQh1Wlf + ngZfgK/MjZykdg0+bGwRT9JMcZbg9xeuznOCEenuTMJtDriquzTlN6ms2emelgBe + fiQOpDC/hsX3Hr0miTgVq6xb3mRxUpMSRFAQqgkmV403fQ+kd8FcsSy1jjS5XLwX + iB30XNuA1VE0HlWs4l4DV1G/24Jc1Hr7iUyiZMfZlZkEuju7POrmxtU0RZ00Dyis + tzuHg2kl7HlTBftOs8FDxM3sqityZScutQmvMe6NCy/3nSFyHCQFPfu66bycssYG + R+4YvtjCZRUas5kS + + + + + + + + + + New York University + New York University + http://www.nyu.edu/ + + + Yavor Yanakiev + yy27@nyu.edu + + + Tracy Edappara + tte3@nyu.edu + + + Gary Chapman + gwc1@nyu.edu + + diff --git a/test/Metadata/metadata-osf.xml b/test/Metadata/metadata-osf.xml new file mode 100644 --- /dev/null +++ b/test/Metadata/metadata-osf.xml @@ -0,0 +1,73 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + f04f8d134cd2 + + CN=f04f8d134cd2 + MIIC6zCCAdOgAwIBAgIJAJqEq0DermlRMA0GCSqGSIb3DQEBBQUAMBcxFTATBgNV +BAMTDGYwNGY4ZDEzNGNkMjAeFw0xNTEyMjkwMDExMzdaFw0yNTEyMjYwMDExMzda +MBcxFTATBgNVBAMTDGYwNGY4ZDEzNGNkMjCCASIwDQYJKoZIhvcNAQEBBQADggEP +ADCCAQoCggEBAN17GPq0XqNYq3WjK9YvoNxXJTikT6adN0iL8t2ZlK2K4p9un7Al +flqzkImW2p/hdO+r/ya3NarnkzdXF1urK+OTkPKaKWh2eAaenuW7nUh8e2c+WaZ0 +SugrpVz7+tqxgYH0GHgNCN/1tmuXBUUseHrn0ikblj2G8X6rXaODUj810gP1nf2D +aphxwSjD9P665RiIrq3OQn134zmmX3GwSsEN2+O//w8PJDKZv+egZglibmkfbim3 +DVZLRt24FkJI2LI47DlkMx57AlFLF2H06j9iSrLPbjrLperL1fOfTfHCyERcVkCM +k7q+gtoId2JlhF7g2fdO8Vp3xYbqggW3kUcCAwEAAaM6MDgwFwYDVR0RBBAwDoIM +ZjA0ZjhkMTM0Y2QyMB0GA1UdDgQWBBRtejOAWosMsz65hjHV+kql6fvLeDANBgkq +hkiG9w0BAQUFAAOCAQEAIyKvvoo57Xxah0ydoDfzivOv8eRVaeTfMSAWvKrAmy26 +N936px6OPcHaaOB49kw2mzhmsHLZODzDJhM4QZX3nXmchHjgXxMgICZt0IsINuAa +TEj+2s8fMgQPD2fsKrv0Xl5GU8bLQ7OdZgsPgSWUKRLTq8jt7XkbhGP/EJkFupl+ +KIT/H23IfmqZaDHPiq35KezfrWY1tDpIA5Ce1BeXCIVm0AWyWxSD6OV9AAxBUGYD +MnxGWMQdml9GBA7JMrHfuqYFZI2r6QBVSGTJU4AEfPYZjE/KPGZMXHi3aPZv5qYC +cmpdxFpehCnOOGV8KyxUzNv7O55UOBMGxRG+ontZ+g== + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/test/Metadata/metadata-sp.xml b/test/Metadata/metadata-sp.xml new file mode 100644 --- /dev/null +++ b/test/Metadata/metadata-sp.xml @@ -0,0 +1,48 @@ + + + + + ServiceProvider.com SSO Key + + + + + ServiceProvider.com Encrypt Key + + + + + + urn:oasis:names:tc:SAML:2.0:nameid-format:transient + + + + Academic Journals R US + + https://ServiceProvider.com/entitlements/123456789 + + + + + Academic Journals R US + Academic Journals R US, a Division of Dirk Corp. + https://ServiceProvider.com + + diff --git a/test/XML/Signature.hs b/test/XML/Signature.hs --- a/test/XML/Signature.hs +++ b/test/XML/Signature.hs @@ -1,20 +1,46 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module XML.Signature (tests) where +import Control.Exception (SomeException, try) +import Data.ByteString.Base64 +import Data.Either (isLeft) +import qualified Crypto.PubKey.DSA as DSA import Data.List.NonEmpty (NonEmpty(..)) +import Data.String.Conversions +import Data.Time import qualified Data.X509 as X509 +import GHC.Stack +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified SAML2.XML as HS import qualified Test.HUnit as U import qualified Text.XML.HXT.DOM.QualifiedName as HXT import qualified Text.XML.HXT.DOM.XmlNode as HXT +import SAML2.Core.Protocols +import SAML2.Core.Versioning +import SAML2.Core.Signature +import SAML2.Core.Identifiers import SAML2.XML -import SAML2.XML.Signature import SAML2.XML.Canonical +import SAML2.XML.Signature +import Data.Tree.NTree.TypeDefs +import Text.XML.HXT.DOM.TypeDefs import XML tests :: U.Test -tests = U.test +tests = U.test [serializationTests, signVerifyTests, counterExamples] + + +---------------------------------------------------------------------- +-- serialization roundtrips + +serializationTests :: U.Test +serializationTests = U.test [ testXML "test/XML/signature-example.xml" $ Signature (Just "MyFirstSignature") (SignedInfo Nothing @@ -78,11 +104,11 @@ , testXML "http://www.w3.org/TR/2002/REC-xmldsig-core-20020212/signature-example-rsa.xml" $ Signature Nothing (SignedInfo Nothing - (CanonicalizationMethod + (CanonicalizationMethod (Identified (CanonicalXML10 False)) Nothing []) - (SignatureMethod + (SignatureMethod (Identified SignatureRSA_SHA1) Nothing []) @@ -90,7 +116,7 @@ (Just $ uri "http://www.w3.org/TR/xml-stylesheet") Nothing Nothing - (DigestMethod + (DigestMethod (Identified DigestSHA1) []) "\235Cof\251]L\US\187RyK\167\241\246\226\158\225\225\187" @@ -101,9 +127,9 @@ KeyInfoKeyValue (RSAKeyValue 129320787110389946406925163824095500161767249273623083115363317842079233133623467127773858023148958966585889333894288698085674111884585270272937137414571531865090153762072690670922714784242933462808045060688046441910524319219807614054721975863956765214954333806674482022007523948700289932875920496009317903247 65537) - :| X509Data + :| X509Data (X509SubjectName "\n CN=Merlin Hughes,O=Baltimore Technologies\\, Ltd.,ST=Dublin,C=IE\n " - :| X509IssuerSerial + :| X509IssuerSerial "\n CN=Test RSA CA,O=Baltimore Technologies\\, Ltd.,ST=Dublin,C=IE\n " 970849928 : X509Certificate (either error id $ X509.decodeSignedObject @@ -115,7 +141,7 @@ , testXML "http://www.w3.org/TR/2002/REC-xmldsig-core-20020212/signature-example-dsa.xml" $ Signature Nothing (SignedInfo Nothing - (CanonicalizationMethod + (CanonicalizationMethod (Identified (CanonicalXML10 False)) Nothing []) @@ -135,7 +161,7 @@ (SignatureValue Nothing "\169@\ETX\f\193\217\147'\155\189\ETBK\179\238\131\191\180o\128\194\209\149F\131\a\132=\202\DELW\160\144;\245\173\188\243g\223N") (Just $ KeyInfo Nothing $ - KeyInfoKeyValue (DSAKeyValue + KeyInfoKeyValue (DSAKeyValue (Just (153189639877411708224318232157362603672344144516811966787300053511761023886224186320604641484819218412604307502181416378142369715493548254902826913797675909798516465379299499179683104783603344189053156355893057246996756239330536459114483648506158907550755189559705056134296533730500485771224694549017281352213, 1393672757286116725466646726891466679477132949611)) (Just 35729760834794135337622213068423837828001418115741637960451705317746718553830652249599411519579460551833355506946575671195284376652749132624400687252979877843978133909425395446287975790304889073526084815938167334643701873370635770822329121239717107729346766305695485960113338821879352438123181471401687525574) 80624726256040348115552042320696813500187275370942441977258669395023235020055564647117594451929708788598704081077890850726227289270230377442285367559774800853404089092381420228663316324808605521697655145608801533888071381819208887705771753016938104409283940243801509765453542091716518238707344493641683483917 @@ -143,7 +169,7 @@ Nothing) :| X509Data (X509SubjectName "\n CN=Merlin Hughes,O=Baltimore Technologies\\, Ltd.,ST=Dublin,C=IE\n " - :| X509IssuerSerial + :| X509IssuerSerial "\n CN=Test DSA CA,O=Baltimore Technologies\\, Ltd.,ST=Dublin,C=IE\n " 970849936 : X509Certificate (either error id $ X509.decodeSignedObject @@ -152,3 +178,116 @@ : []) [] ] + + +---------------------------------------------------------------------- +-- signing / verification + +signVerifyTests :: U.Test +signVerifyTests = U.test + [ U.TestCase $ do + let req = somereq + req' <- signSAMLProtocol privkey1 req + let reqlbs = samlToXML req' + req'' :: AuthnRequest <- verifySAMLProtocol reqlbs + U.assertEqual "AuthnRequest with verifySAMLProtocol (no pubkeys)" req' req'' + + , 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'' + + , 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'' + ] + +{-# NOINLINE keypair1 #-} +keypair1 :: (SigningKey, PublicKeys) +keypair1 = unsafePerformIO mkkeypair + +{-# NOINLINE keypair2 #-} +keypair2 :: (SigningKey, PublicKeys) +keypair2 = unsafePerformIO mkkeypair + +privkey1, _privkey2 :: SigningKey +pubkey1, pubkey2 :: PublicKeys +((privkey1, pubkey1), (_privkey2, pubkey2)) = (keypair1, keypair2) + +mkkeypair :: IO (SigningKey, PublicKeys) +mkkeypair = do + privnum <- DSA.generatePrivate params + let pubnum = DSA.calculatePublic params privnum + kp = DSA.KeyPair params pubnum privnum + pure (SigningKeyDSA kp, PublicKeys (Just $ DSA.toPublicKey kp) Nothing) + where + params = DSA.Params + { DSA.params_p = 13232376895198612407547930718267435757728527029623408872245156039757713029036368719146452186041204237350521785240337048752071462798273003935646236777459223 + , DSA.params_q = 857393771208094202104259627990318636601332086981 + , DSA.params_g = 5421644057436475141609648488325705128047428394380474376834667300766108262613900542681289080713724597310673074119355136085795982097390670890367185141189796 + } + +somereq :: AuthnRequest +somereq = AuthnRequest + { authnRequest = RequestAbstractType someprottype + , authnRequestForceAuthn = False + , authnRequestIsPassive = False + , authnRequestAssertionConsumerService = AssertionConsumerServiceURL Nothing Nothing + , authnRequestAssertionConsumingServiceIndex = Nothing + , authnRequestProviderName = Nothing + , authnRequestSubject = Nothing + , authnRequestNameIDPolicy = Nothing + , authnRequestConditions = Nothing + , authnRequestRequestedAuthnContext = Nothing + , authnRequestScoping = Nothing + } + +someprottype :: ProtocolType +someprottype = ProtocolType + { protocolID = "wef" + , protocolVersion = SAML20 + , protocolIssueInstant = someTime + , protocolDestination = Nothing + , protocolConsent = Identified ConsentUnspecified + , protocolIssuer = Nothing + , protocolSignature = Nothing + , protocolExtensions = [] + , relayState = Nothing + } + +someTime :: UTCTime +Just someTime = parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" "2013-03-18T03:28:54.1Z" + +---------------------------------------------------------------------- +-- more counter-examples + +counterExamples :: U.Test +counterExamples = U.test + [ U.TestCase $ do + (i, o) <- canonicalizeCounterExample "PGE+w6Q8L2E+" + U.assertEqual "canoncalization broke the input" i o + ] + +canonicalizeCounterExample :: HasCallStack => BS.ByteString -> IO (LBS, LBS) +canonicalizeCounterExample base64input = do + let inbs :: LBS.ByteString + inbs = either (error "badcase") cs $ Data.ByteString.Base64.decode base64input + + tree :: XmlTree + tree = maybe (error "badcase") id $ 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 + + pure (inbs, outbs) diff --git a/test/XML/noncanonical1.xml b/test/XML/noncanonical1.xml new file mode 100644 --- /dev/null +++ b/test/XML/noncanonical1.xml @@ -0,0 +1,13 @@ + + + + + +Hello, world! + + + + + + diff --git a/test/XML/noncanonical2.xml b/test/XML/noncanonical2.xml new file mode 100644 --- /dev/null +++ b/test/XML/noncanonical2.xml @@ -0,0 +1,11 @@ + + + A B + + A + + B + A B + C + + diff --git a/test/XML/noncanonical3.xml b/test/XML/noncanonical3.xml new file mode 100644 --- /dev/null +++ b/test/XML/noncanonical3.xml @@ -0,0 +1,18 @@ +]> + + + + + + + + + + + + + + diff --git a/test/XML/noncanonical4.xml b/test/XML/noncanonical4.xml new file mode 100644 --- /dev/null +++ b/test/XML/noncanonical4.xml @@ -0,0 +1,13 @@ + + +]> + + First line Second line + 2 + "0" && value<"10" ?"valid":"error"]]> + valid + + + + diff --git a/test/XML/noncanonical5.xml b/test/XML/noncanonical5.xml new file mode 100644 --- /dev/null +++ b/test/XML/noncanonical5.xml @@ -0,0 +1,12 @@ + + + + + +]> + + &ent1;, &ent2;! + + + diff --git a/test/XML/noncanonical6.xml b/test/XML/noncanonical6.xml new file mode 100644 --- /dev/null +++ b/test/XML/noncanonical6.xml @@ -0,0 +1,2 @@ + +© diff --git a/test/XML/world.txt b/test/XML/world.txt new file mode 100644 --- /dev/null +++ b/test/XML/world.txt @@ -0,0 +1,1 @@ +world