diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/SAML2.hs b/SAML2.hs new file mode 100644 --- /dev/null +++ b/SAML2.hs @@ -0,0 +1,23 @@ +-- | +-- OASIS Security Assertion Markup Language (SAML) V2.0 +-- +module SAML2 + ( Identified(..) + , namespaceURI + , samlToXML + , xmlToSAML + -- * Assertions and Protocols + , module SAML2.Core + -- * Bindings + , module SAML2.Bindings + -- * Metadata + , module SAML2.Metadata + -- * Profiles + , module SAML2.Profiles + ) where + +import SAML2.XML +import SAML2.Core +import SAML2.Bindings +import SAML2.Metadata +import SAML2.Profiles diff --git a/SAML2/Bindings.hs b/SAML2/Bindings.hs new file mode 100644 --- /dev/null +++ b/SAML2/Bindings.hs @@ -0,0 +1,9 @@ +-- | +-- Bindings for the OASIS Security Assertion Markup Language (SAML) V2.0 +-- +-- +module SAML2.Bindings + ( module SAML2.Bindings.Identifiers + ) where + +import SAML2.Bindings.Identifiers diff --git a/SAML2/Bindings/General.hs b/SAML2/Bindings/General.hs new file mode 100644 --- /dev/null +++ b/SAML2/Bindings/General.hs @@ -0,0 +1,18 @@ +-- | +-- General Considerations +-- +-- §3.1 +module SAML2.Bindings.General where + +import Data.ByteString (ByteString) +import Data.String (IsString(fromString)) + +type RelayState = ByteString + +-- |The name of the parameter used by many protocols for the message itself for requests (False) or responses (True). Often combined with 'SAML2.Core.Protocols.isSAMLResponse'. +protocolParameter :: IsString a => Bool -> a +protocolParameter False = fromString "SAMLRequest" +protocolParameter True = fromString "SAMLResponse" + +relayStateParameter :: IsString a => a +relayStateParameter = fromString "RelayState" diff --git a/SAML2/Bindings/HTTPPOST.hs b/SAML2/Bindings/HTTPPOST.hs new file mode 100644 --- /dev/null +++ b/SAML2/Bindings/HTTPPOST.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +-- | +-- HTTP POST Binding +-- +-- §3.5 +module SAML2.Bindings.HTTPPOST + ( encodeValue + , encodeForm + , decodeValue + , decodeForm + ) where + +import Control.Lens ((^.), (.~)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Lazy as BSL +import Data.Maybe (maybeToList) +import Data.Proxy (Proxy(..)) + +import SAML2.XML +import SAML2.Lens +import qualified SAML2.Core.Protocols as SAMLP +import SAML2.Core.Signature +import SAML2.Bindings.General +import SAML2.Bindings.Internal + +encodeValue :: SAMLP.SAMLProtocol a => a -> BS.ByteString +encodeValue = Base64.encode . BSL.toStrict . samlToXML + +encodeForm :: SAMLP.SAMLProtocol a => a -> [(BS.ByteString, BS.ByteString)] +encodeForm p = + (protocolParameter (SAMLP.isSAMLResponse p), encodeValue p) + : maybeToList ((relayStateParameter, ) <$> SAMLP.relayState (p ^. SAMLP.samlProtocol')) + +decodeValue :: SAMLP.SAMLProtocol a => Bool -> BS.ByteString -> IO a +decodeValue verf v = do + if verf + then verifySAMLProtocol b + else either fail return $ xmlToSAML b + where b = BSL.fromStrict $ Base64.decodeLenient v + +decodeForm :: forall a . (SAMLP.SAMLProtocol a) => Bool -> (BS.ByteString -> Maybe BS.ByteString) -> IO a +decodeForm verf f = do + p <- decodeValue verf =<< maybe (fail "SAML parameter missing") return (lookupProtocolParameter (Proxy :: Proxy a) f) + return $ SAMLP.samlProtocol' . $(fieldLens 'SAMLP.relayState) .~ (f relayStateParameter) $ p diff --git a/SAML2/Bindings/HTTPRedirect.hs b/SAML2/Bindings/HTTPRedirect.hs new file mode 100644 --- /dev/null +++ b/SAML2/Bindings/HTTPRedirect.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- HTTP Redirect Binding +-- +-- §3.4 +module SAML2.Bindings.HTTPRedirect + ( encodeQuery + , encodeHeaders + , decodeURI + ) where + +import qualified Codec.Compression.Zlib.Raw as DEFLATE +import Control.Lens ((^.), (.~)) +import Control.Monad (unless) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.Lazy as Base64 +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) +import Network.HTTP.Types.QueryLike (toQuery) +import Network.URI (URI(uriPath), nullURI, uriQuery, parseURIReference) + +import SAML2.Lens +import SAML2.XML +import qualified SAML2.XML.Signature as DS +import SAML2.Core.Namespaces +import SAML2.Core.Versioning +import qualified SAML2.Core.Protocols as SAMLP +import SAML2.Bindings.General +import SAML2.Bindings.Internal + +data Encoding + = EncodingDEFLATE + deriving (Eq, Bounded, Enum, Show) + +instance Identifiable URI Encoding where + identifier = samlURNIdentifier "bindings:URL-Encoding" . f where + f EncodingDEFLATE = (SAML20, "DEFLATE") + +paramSAML :: Bool -> BS.ByteString +paramSAML = protocolParameter + +paramRelayState, paramSignature, paramSignatureAlgorithm, paramEncoding :: BS.ByteString +paramRelayState = relayStateParameter +paramSignature = "Signature" +paramSignatureAlgorithm = "SigAlg" +paramEncoding = "SAMLEncoding" + +encodeQuery :: SAMLP.SAMLProtocol a => Maybe DS.SigningKey -> a -> IO Query +encodeQuery sk p = case sk of + Nothing -> return sq + Just k -> do + let sq' = sq ++ toQuery [(paramSignatureAlgorithm, show $ identifier $ DS.signingKeySignatureAlgorithm k)] + sig <- DS.signBase64 k $ renderQuery False sq' + return $ sq' ++ toQuery [(paramSignature, sig)] + where + p' = SAMLP.samlProtocol' . $(fieldLens 'SAMLP.protocolSignature) .~ Nothing $ p + pv = Base64.encode + $ DEFLATE.compressWith DEFLATE.defaultCompressParams{ DEFLATE.compressLevel = DEFLATE.bestCompression } + $ samlToXML p' + sq = toQuery $ + (paramSAML $ SAMLP.isSAMLResponse p, BSL.toStrict pv) + : maybeToList ((paramRelayState, ) <$> SAMLP.relayState (p' ^. SAMLP.samlProtocol')) + +httpHeaders :: ResponseHeaders +httpHeaders = + [ (hCacheControl, "no-cache,no-store") + , (hPragma, "no cache") + ] + +encodeHeaders :: SAMLP.SAMLProtocol a => Maybe DS.SigningKey -> a -> IO ResponseHeaders +encodeHeaders sk p = do + q <- encodeQuery sk p + return $ + (hLocation, BSC.pack $ show (fromMaybe nullURI d){ uriQuery = BSC.unpack $ renderQuery True q }) + : httpHeaders + where + d = SAMLP.protocolDestination $ p ^. SAMLP.samlProtocol' + +decodeURI :: forall a . SAMLP.SAMLProtocol a => DS.PublicKeys -> URI -> IO a +decodeURI pk ru = do + pq <- maybe (fail "SAML parameter missing") return $ lookupProtocolParameter (Proxy :: Proxy a) ql + pd <- case enc of + Identified EncodingDEFLATE -> + return $ DEFLATE.decompress $ Base64.decodeLenient $ BSL.fromStrict $ fst pq + _ -> fail $ "Unsupported HTTP redirect encoding: " ++ show enc + p <- either fail return $ xmlToSAML pd + case ql paramSignatureAlgorithm of + Just (sav, sas) -> do + sigres $ DS.verifyBase64 pk (reidentify $ puri sav) + (snd pq <> foldMap (BSC.cons '&' . snd) rsq <> BSC.cons '&' sas) + (foldMap fst $ ql paramSignature) + unless (SAMLP.protocolDestination (p ^. SAMLP.samlProtocol') == Just ru{ uriQuery = "" }) $ + fail "Destination incorrect" + Nothing -> return () + return $ SAMLP.samlProtocol' . $(fieldLens 'SAMLP.relayState) .~ (fst <$> rsq) $ p + where + qs = BSC.pack $ uriQuery ru + pqp s = (urlDecode True k, (maybe BSC.empty (urlDecode True . snd) $ BS.uncons v, s)) where + (k, v) = BSC.break ('=' ==) s + q = map pqp $ BSC.splitWith (`elem` ['&',';']) $ case BSC.uncons qs of + Just ('?', qs') -> qs' + _ -> qs + ql v = lookup v q + puri bs = fromMaybe nullURI{ uriPath = s } $ parseURIReference s where s = BSC.unpack bs + enc = maybe (Identified EncodingDEFLATE) reidentify $ fmap (puri . fst) $ ql paramEncoding + rsq = ql paramRelayState + sigres (Just True) = return () + sigres (Just False) = fail "Signature verification failed" + sigres Nothing = fail "Could not verify signature" + diff --git a/SAML2/Bindings/Identifiers.hs b/SAML2/Bindings/Identifiers.hs new file mode 100644 --- /dev/null +++ b/SAML2/Bindings/Identifiers.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | +-- Protocol Bindings identifiers +-- +-- §3.X.1 +module SAML2.Bindings.Identifiers where + +import SAML2.XML +import SAML2.Core.Namespaces +import SAML2.Core.Versioning + +data Binding + = BindingSOAP -- ^§3.2 + | BindingPAOS -- ^§3.3 + | BindingHTTPRedirect -- ^§3.4 + | BindingHTTPPOST -- ^§3.5 + | BindingHTTPArtifact -- ^§3.6 + | BindingURI -- ^§3.7 + deriving (Eq, Bounded, Enum, Show) + +instance Identifiable URI Binding where + identifier = samlURNIdentifier "bindings" . f where + f BindingSOAP = (SAML20, "SOAP") + f BindingPAOS = (SAML20, "PAOS") + f BindingHTTPRedirect = (SAML20, "HTTP-Redirect") + f BindingHTTPPOST = (SAML20, "HTTP-POST") + f BindingHTTPArtifact = (SAML20, "HTTP-Artifact") + f BindingURI = (SAML20, "URI") diff --git a/SAML2/Bindings/Internal.hs b/SAML2/Bindings/Internal.hs new file mode 100644 --- /dev/null +++ b/SAML2/Bindings/Internal.hs @@ -0,0 +1,15 @@ +module SAML2.Bindings.Internal where + +import Control.Applicative ((<|>)) +import Data.Proxy (Proxy) +import Data.String (IsString) + +import qualified SAML2.Core.Protocols as SAMLP +import SAML2.Bindings.General + +lookupProtocolParameter :: (SAMLP.SAMLProtocol m, IsString p) => Proxy m -> (p -> Maybe a) -> Maybe a +lookupProtocolParameter p f = + case SAMLP.isSAMLResponse_ p of + Just r -> f (protocolParameter r) + Nothing -> f (protocolParameter False) <|> f (protocolParameter True) + diff --git a/SAML2/Core.hs b/SAML2/Core.hs new file mode 100644 --- /dev/null +++ b/SAML2/Core.hs @@ -0,0 +1,107 @@ +-- | +-- Assertions and Protocols for the OASIS Security Assertion Markup Language (SAML) V2.0 +-- +-- +module SAML2.Core + ( -- * §1 + samlURN + , XString + , AnyURI + , DateTime + , ID + , NCName + -- * §2 + , SAML.ns + , BaseID(..) + , NameID(..) + , simpleNameID + , EncryptedNameID + , Identifier(..) + , EncryptedID + , EncryptedElement(..) + , PossiblyEncrypted(..) + , AssertionRef(..) + , Issuer(..) + , AssertionIDRef(..) + , Assertion(..) + , EncryptedAssertion + , Subject(..) + , noSubject + , SubjectConfirmation(..) + , SubjectConfirmationData(..) + , Conditions(..) + , Condition(..) + , Audience(..) + , Advice + , AdviceElement(..) + , Statement(..) + , AuthnStatement(..) + , SubjectLocality(..) + , AuthnContext(..) + , AuthnContextDecl(..) + , AttributeStatement(..) + , Attribute(..) + , EncryptedAttribute + , AuthzDecisionStatement(..) + , DecisionType(..) + , Action(..) + , Evidence(..) + -- * §3 + , nsP + , ProtocolType(..) + , RequestAbstractType(..) + , StatusResponseType(..) + , Status(..) + , StatusCode(..) + , StatusCode1(..) + , StatusCode2(..) + , successStatus + , AssertionIDRequest(..) + , SubjectQueryAbstractType(..) + , AuthnQuery(..) + , RequestedAuthnContext(..) + , AuthnContextRefs(..) + , AuthnContextComparisonType(..) + , AttributeQuery(..) + , AuthzDecisionQuery(..) + , Response(..) + , AuthnRequest(..) + , AssertionConsumerService(..) + , NameIDPolicy(..) + , Scoping(..) + , IDPList(..) + , IDPEntry(..) + , ArtifactResolve(..) + , ArtifactResponse(..) + , ManageNameIDRequest(..) + , NewID(..) + , NewEncryptedID + , ManageNameIDResponse(..) + , LogoutRequest(..) + , LogoutResponse(..) + , LogoutReason(..) + , NameIDMappingRequest(..) + , NameIDMappingResponse(..) + , AnyRequest(..) + , AnyResponse(..) + , AnyProtocol(..) + -- * §4 + , SAMLVersion(..) + , samlVersion + -- * §8 + , ActionNamespace(..) + , AttributeNameFormat(..) + , NameIDFormat(..) + , Consent(..) + ) where + +import SAML2.XML.Types +import SAML2.Core.Namespaces +import SAML2.Core.Datatypes +import SAML2.Core.Assertions as SAML +import SAML2.Core.Protocols as SAMLP +import SAML2.Core.Versioning +import SAML2.Core.Identifiers + +nsP :: Namespace +nsP = SAMLP.ns diff --git a/SAML2/Core/Assertions.hs b/SAML2/Core/Assertions.hs new file mode 100644 --- /dev/null +++ b/SAML2/Core/Assertions.hs @@ -0,0 +1,454 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- SAML Assertions +-- +-- §2 +module SAML2.Core.Assertions where + +import qualified Text.XML.HXT.Arrow.Pickle.Schema as XPS + +import SAML2.Lens +import SAML2.XML +import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP +import qualified SAML2.XML.Schema as XS +import qualified SAML2.XML.Signature.Types as DS +import qualified SAML2.XML.Encryption as XEnc +import SAML2.Core.Namespaces +import SAML2.Core.Versioning +import SAML2.Core.Identifiers +import SAML2.Profiles.ConfirmationMethod + +ns :: Namespace +ns = mkNamespace "" $ samlURN SAML20 ["assertion"] + +xpElem :: String -> XP.PU a -> XP.PU a +xpElem = xpTrimElemNS ns + +-- |§2.2.1 +data BaseID id = BaseID + { baseNameQualifier :: Maybe XString + , baseSPNameQualifier :: Maybe XString + , baseID :: !id + } deriving (Eq, Show) + +xpBaseID :: XP.PU id -> XP.PU (BaseID id) +xpBaseID idp = [XP.biCase|((n, s), i) <-> BaseID n s i|] + XP.>$< (XP.xpAttrImplied "NameQualifier" XS.xpString + XP.>*< XP.xpAttrImplied "SPNameQualifier" XS.xpString + XP.>*< idp) + +-- |§2.2.3 +data NameID = NameID + { nameBaseID :: BaseID XString + , nameIDFormat :: IdentifiedURI NameIDFormat + , nameSPProvidedID :: Maybe XString + } deriving (Eq, Show) + +simpleNameID :: NameIDFormat -> XString -> NameID +simpleNameID f s = NameID (BaseID Nothing Nothing s) (Identified f) Nothing + +xpNameIDDefaulting :: IdentifiedURI NameIDFormat -> XP.PU NameID +xpNameIDDefaulting fmt = [XP.biCase|((f, p), b) <-> NameID b f p|] + XP.>$< (XP.xpDefault fmt (XP.xpAttr "Format" XP.xpickle) + XP.>*< XP.xpAttrImplied "SPProvidedID" XS.xpString + XP.>*< xpBaseID XS.xpString) + +xpNameID :: XP.PU NameID +xpNameID = xpNameIDDefaulting $ Identified NameIDFormatUnspecified + +instance XP.XmlPickler NameID where + xpickle = xpElem "NameID" xpNameID + +type EncryptedNameID = EncryptedElement NameID + +instance XP.XmlPickler EncryptedNameID where + xpickle = xpElem "EncryptedID" xpEncryptedElement + +data Identifier + = IdentifierName NameID + | IdentifierBase (BaseID Nodes) + deriving (Eq, Show) + +instance XP.XmlPickler Identifier where + xpickle = [XP.biCase| + Left n <-> IdentifierName n + Right b <-> IdentifierBase b |] + XP.>$< (XP.xpickle XP.>|< xpElem "BaseID" (xpBaseID XP.xpTrees)) + +-- |§2.2.4 +type EncryptedID = EncryptedElement Identifier + +instance XP.XmlPickler EncryptedID where + xpickle = xpElem "EncryptedID" xpEncryptedElement + +data EncryptedElement a = EncryptedElement + { encryptedData :: XEnc.EncryptedData + , encryptedKey :: [XEnc.EncryptedKey] + } deriving (Eq, Show) + +xpEncryptedElement :: XP.PU (EncryptedElement a) +xpEncryptedElement = [XP.biCase|(d, k) <-> EncryptedElement d k|] + XP.>$< (XP.xpickle + XP.>*< XP.xpList XP.xpickle) + +data PossiblyEncrypted a + = NotEncrypted !a + | SoEncrypted (EncryptedElement a) + deriving (Eq, Show) + +xpPossiblyEncrypted :: (XP.XmlPickler a, XP.XmlPickler (EncryptedElement a)) => XP.PU (PossiblyEncrypted a) +xpPossiblyEncrypted = [XP.biCase| + Left a <-> NotEncrypted a + Right a <-> SoEncrypted a |] + XP.>$< (XP.xpickle XP.>|< XP.xpickle) + +data AssertionRef + = AssertionRefID AssertionIDRef + | AssertionURIRef AnyURI -- ^§2.3.2 + | AssertionRef (PossiblyEncrypted Assertion) + deriving (Eq, Show) + +instance XP.XmlPickler AssertionRef where + xpickle = [XP.biCase| + Left (Left i) <-> AssertionRefID i + Left (Right u) <-> AssertionURIRef u + Right a <-> AssertionRef a|] + XP.>$< (XP.xpickle + XP.>|< xpElem "AssertionURIRef" XS.xpAnyURI + XP.>|< xpPossiblyEncrypted) + +-- |§2.2.5 +newtype Issuer = Issuer{ issuer :: NameID } + deriving (Eq, Show) + +instance XP.XmlPickler Issuer where + xpickle = xpElem "Issuer" $ [XP.biCase| + n <-> Issuer n|] + XP.>$< xpNameIDDefaulting (Identified NameIDFormatEntity) + +-- |§2.3.1 +newtype AssertionIDRef = AssertionIDRef{ assertionIDRef :: ID } + deriving (Eq, Show) + +instance XP.XmlPickler AssertionIDRef where + xpickle = xpElem "AssertionIDRef" $ [XP.biCase| + i <-> AssertionIDRef i|] + XP.>$< XS.xpID + +-- |§2.3.3 +data Assertion = Assertion + { assertionVersion :: SAMLVersion + , assertionID :: ID + , assertionIssueInstant :: DateTime + , assertionIssuer :: Issuer + , assertionSignature :: Maybe DS.Signature + , assertionSubject :: Subject -- ^use 'noSubject' to omit + , assertionConditions :: Maybe Conditions + , assertionAdvice :: Maybe Advice + , assertionStatement :: [Statement] + } deriving (Eq, Show) + +instance XP.XmlPickler Assertion where + xpickle = xpElem "Assertion" $ + [XP.biCase| + ((((((((v, i), t), n), s), Nothing), c), a), l) <-> Assertion v i t n s (Subject Nothing []) c a l + ((((((((v, i), t), n), s), Just r), c), a), l) <-> Assertion v i t n s r c a l|] + XP.>$< (XP.xpAttr "Version" XP.xpickle + XP.>*< XP.xpAttr "ID" XS.xpID + XP.>*< XP.xpAttr "IssueInstant" XS.xpDateTime + XP.>*< XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpOption (xpElem "Advice" $ XP.xpList XP.xpickle) + XP.>*< XP.xpList XP.xpickle) + +instance DS.Signable Assertion where + signature' = $(fieldLens 'assertionSignature) + signedID = assertionID + +-- |§2.3.4 +type EncryptedAssertion = EncryptedElement Assertion + +instance XP.XmlPickler EncryptedAssertion where + xpickle = xpElem "EncryptedAssertion" xpEncryptedElement + +-- |§2.4.1 +data Subject = Subject + { subjectIdentifier :: Maybe (PossiblyEncrypted Identifier) + , subjectConfirmation :: [SubjectConfirmation] + } deriving (Eq, Show) + +instance XP.XmlPickler Subject where + xpickle = xpElem "Subject" $ [XP.biCase| + (i, c) <-> Subject i c|] + XP.>$< (XP.xpOption xpPossiblyEncrypted + XP.>*< XP.xpList XP.xpickle) + +noSubject :: Subject +noSubject = Subject Nothing [] + +-- |§2.4.1.1 +data SubjectConfirmation = SubjectConfirmation + { subjectConfirmationMethod :: IdentifiedURI ConfirmationMethod + , subjectConfirmationIdentifier :: Maybe (PossiblyEncrypted Identifier) + , subjectConfirmationData :: Maybe SubjectConfirmationData + } deriving (Eq, Show) + +instance XP.XmlPickler SubjectConfirmation where + xpickle = xpElem "SubjectConfirmation" $ [XP.biCase| + ((m, i), d) <-> SubjectConfirmation m i d|] + XP.>$< (XP.xpAttr "Method" XP.xpickle + XP.>*< XP.xpOption xpPossiblyEncrypted + XP.>*< XP.xpOption XP.xpickle) + +-- |§2.4.1.2 +data SubjectConfirmationData = SubjectConfirmationData + { subjectConfirmationNotBefore + , subjectConfirmationNotOnOrAfter :: Maybe DateTime + , subjectConfirmationRecipient :: Maybe AnyURI + , subjectConfirmationInResponseTo :: Maybe ID + , subjectConfirmationAddress :: Maybe IP + , subjectConfirmationKeyInfo :: [DS.KeyInfo] + , subjectConfirmationXML :: Nodes -- ^anything + } deriving (Eq, Show) + +instance XP.XmlPickler SubjectConfirmationData where + xpickle = xpElem "SubjectConfirmationData" $ [XP.biCase| + ((((((s, e), r), i), a), k), x) <-> SubjectConfirmationData s e r i a k x|] + XP.>$< (XP.xpAttrImplied "NotBefore" XS.xpDateTime + XP.>*< XP.xpAttrImplied "NotOnOrAfter" XS.xpDateTime + XP.>*< XP.xpAttrImplied "Recipient" XS.xpAnyURI + XP.>*< XP.xpAttrImplied "InResponseTo" XS.xpNCName + XP.>*< XP.xpAttrImplied "Address" xpIP + XP.>*< XP.xpList XP.xpickle + XP.>*< XP.xpAny) + +-- |§2.5.1 +data Conditions = Conditions + { conditionsNotBefore + , conditionsNotOnOrAfter :: Maybe DateTime + , conditions :: [Condition] + } deriving (Eq, Show) + +instance XP.XmlPickler Conditions where + xpickle = xpElem "Conditions" $ [XP.biCase| + ((s, e), c) <-> Conditions s e c|] + XP.>$< (XP.xpAttrImplied "NotBefore" XS.xpDateTime + XP.>*< XP.xpAttrImplied "NotOnOrAfter" XS.xpDateTime + XP.>*< XP.xpList XP.xpickle) + +data Condition + = Condition Node -- ^§2.5.1.3 + | AudienceRestriction (List1 Audience) -- ^§2.5.1.4 + | OneTimeUse -- ^§2.5.1.5 + | ProxyRestriction + { proxyRestrictionCount :: Maybe XS.NonNegativeInteger + , proxyRestrictionAudience :: [Audience] + } -- ^§2.5.1.6 + deriving (Eq, Show) + +instance XP.XmlPickler Condition where + xpickle = [XP.biCase| + Left (Left (Left a)) <-> AudienceRestriction a + Left (Left (Right ())) <-> OneTimeUse + Left (Right (c, a)) <-> ProxyRestriction c a + Right x <-> Condition x|] + XP.>$< (xpElem "AudienceRestriction" (xpList1 XP.xpickle) + XP.>|< xpElem "OneTimeUse" XP.xpUnit + XP.>|< xpElem "ProxyRestriction" + (XP.xpAttrImplied "Count" XS.xpNonNegativeInteger + XP.>*< XP.xpList XP.xpickle) + XP.>|< xpTrimAnyElem) + +-- |§2.5.1.4 +newtype Audience = Audience{ audience :: AnyURI } + deriving (Eq, Show) + +instance XP.XmlPickler Audience where + xpickle = xpElem "Audience" $ [XP.biCase| + u <-> Audience u|] + XP.>$< XS.xpAnyURI + +-- |§2.6.1 +type Advice = [AdviceElement] +data AdviceElement + = AdviceAssertion AssertionRef + | Advice Node + deriving (Eq, Show) + +instance XP.XmlPickler AdviceElement where + xpickle = [XP.biCase| + Left a <-> AdviceAssertion a + Right x <-> Advice x|] + XP.>$< (XP.xpickle + XP.>|< xpTrimAnyElem) + +-- |§2.7.1 +data Statement + = StatementAuthn AuthnStatement + | StatementAttribute AttributeStatement + | StatementAuthzDecision AuthzDecisionStatement + | Statement Node + deriving (Eq, Show) + +instance XP.XmlPickler Statement where + xpickle = [XP.biCase| + Left (Left (Left s)) <-> StatementAuthn s + Left (Left (Right s)) <-> StatementAttribute s + Left (Right s) <-> StatementAuthzDecision s + Right x <-> Statement x|] + XP.>$< (XP.xpickle + XP.>|< XP.xpickle + XP.>|< XP.xpickle + XP.>|< xpTrimAnyElem) + +-- |§2.7.2 +data AuthnStatement = AuthnStatement + { authnStatementInstant :: DateTime + , authnStatementSessionIndex :: Maybe XString + , authnStatementSessionNotOnOrAfter :: Maybe DateTime + , authnStatementSubjectLocality :: Maybe SubjectLocality + , authnStatementContext :: AuthnContext + } deriving (Eq, Show) + +instance XP.XmlPickler AuthnStatement where + xpickle = xpElem "AuthnStatement" $ [XP.biCase| + ((((t, i), e), l), c) <-> AuthnStatement t i e l c|] + XP.>$< (XP.xpAttr "AuthnInstant" XS.xpDateTime + XP.>*< XP.xpAttrImplied "SessionIndex" XS.xpString + XP.>*< XP.xpAttrImplied "SessionNotOnOrAfter" XS.xpDateTime + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpickle) + +-- |§2.7.2.1 +data SubjectLocality = SubjectLocality + { subjectLocalityAddress :: Maybe IP + , subjectLocalityDNSName :: Maybe XString + } deriving (Eq, Show) + +instance XP.XmlPickler SubjectLocality where + xpickle = xpElem "SubjectLocality" $ [XP.biCase| + (a, d) <-> SubjectLocality a d|] + XP.>$< (XP.xpAttrImplied "Address" xpIP + XP.>*< XP.xpAttrImplied "DNSName" XS.xpString) + +-- |§2.7.2.2 +data AuthnContext = AuthnContext + { authnContextClassRef :: Maybe AnyURI + , authnContextDecl :: Maybe AuthnContextDecl + , authnContextAuthenticatingAuthority :: [AnyURI] + } deriving (Eq, Show) + +instance XP.XmlPickler AuthnContext where + xpickle = xpElem "AuthnContext" $ [XP.biCase| + ((c, d), a) <-> AuthnContext c d a|] + XP.>$< (XP.xpOption (xpElem "AuthnContextClassRef" XS.xpAnyURI) + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpList (xpElem "AuthenticatingAuthority" XS.xpAnyURI)) + +data AuthnContextDecl + = AuthnContextDecl Nodes + | AuthnContextDeclRef AnyURI + deriving (Eq, Show) + +instance XP.XmlPickler AuthnContextDecl where + xpickle = [XP.biCase| + Left d <-> AuthnContextDecl d + Right r <-> AuthnContextDeclRef r|] + XP.>$< (xpElem "AuthnContextDecl" XP.xpAny + XP.>|< xpElem "AuthnContextDeclRef" XS.xpAnyURI) + +-- |§2.7.3 +newtype AttributeStatement = AttributeStatement{ attributeStatement :: List1 (PossiblyEncrypted Attribute) } + deriving (Eq, Show) + +instance XP.XmlPickler AttributeStatement where + xpickle = xpElem "AttributeStatement" $ [XP.biCase| + l <-> AttributeStatement l|] + XP.>$< xpList1 xpPossiblyEncrypted + +-- |§2.7.3.1 +data Attribute = Attribute + { attributeName :: XString + , attributeNameFormat :: IdentifiedURI AttributeNameFormat + , attributeFriendlyName :: Maybe XString + , attributeAttrs :: Nodes -- attributes + , attributeValues :: [Nodes] -- ^§2.7.3.1.1 + } deriving (Eq, Show) + +xpAttributeType :: XP.PU Attribute +xpAttributeType = [XP.biCase| + ((((n, f), u), x), v) <-> Attribute n f u x v|] + XP.>$< (XP.xpAttr "Name" XS.xpString + XP.>*< XP.xpDefault (Identified AttributeNameFormatUnspecified) (XP.xpAttr "NameFormat" XP.xpickle) + XP.>*< XP.xpAttrImplied "FriendlyName" XS.xpString + XP.>*< XP.xpAnyAttrs + XP.>*< XP.xpList (xpElem "AttributeValue" XP.xpAny)) + +instance XP.XmlPickler Attribute where + xpickle = xpElem "Attribute" xpAttributeType + +-- |§2.7.3.2 +type EncryptedAttribute = EncryptedElement Attribute + +instance XP.XmlPickler EncryptedAttribute where + xpickle = xpElem "EncryptedAttribute" xpEncryptedElement + +-- |§2.7.4 +data AuthzDecisionStatement = AuthzDecisionStatement + { authzDecisionStatementResource :: AnyURI + , authzDecisionStatementDecision :: DecisionType + , authzDecisionStatementAction :: List1 Action + , authzDecisionStatementEvidence :: Evidence + } deriving (Eq, Show) + +instance XP.XmlPickler AuthzDecisionStatement where + xpickle = xpElem "AuthzDecisionStatement" $ [XP.biCase| + (((r, d), a), e) <-> AuthzDecisionStatement r d a e|] + XP.>$< (XP.xpAttr "Resource" XS.xpAnyURI + XP.>*< XP.xpAttr "Decision" XP.xpickle + XP.>*< xpList1 XP.xpickle + XP.>*< XP.xpickle) + +-- |§2.7.4.1 +data DecisionType + = DecisionTypePermit + | DecisionTypeDeny + | DecisionTypeIndeterminate + deriving (Eq, Enum, Bounded, Show) + +instance Identifiable XString DecisionType where + identifier DecisionTypePermit = "Permit" + identifier DecisionTypeDeny = "Deny" + identifier DecisionTypeIndeterminate = "Indeterminate" +instance XP.XmlPickler DecisionType where + xpickle = xpIdentifier (XP.xpTextDT (XPS.scDT (namespaceURIString ns) "DecisionType" [])) "DecisionType" + +-- |§2.7.4.2 +data Action = Action + { actionNamespace :: IdentifiedURI ActionNamespace + , action :: XString + } deriving (Eq, Show) + +instance XP.XmlPickler Action where + xpickle = xpElem "Action" $ [XP.biCase| + (n, a) <-> Action n a|] + XP.>$< (XP.xpAttr "Namespace" XP.xpickle + XP.>*< XP.xpText0) + +-- |§2.7.4.3 +newtype Evidence = Evidence{ evidence :: [AssertionRef] } + deriving (Eq, Show, Monoid) + +instance XP.XmlPickler Evidence where + xpickle = [XP.biCase| + Nothing <-> Evidence [] + Just l <-> Evidence l|] + XP.>$< XP.xpOption (xpElem "Evidence" $ XP.xpList1 XP.xpickle) diff --git a/SAML2/Core/Datatypes.hs b/SAML2/Core/Datatypes.hs new file mode 100644 --- /dev/null +++ b/SAML2/Core/Datatypes.hs @@ -0,0 +1,20 @@ +-- | +-- Common Data Types +-- +-- §1.3 +module SAML2.Core.Datatypes where + +import Prelude hiding (String) + +import qualified SAML2.XML.Schema.Datatypes as XS + +-- |§1.3.1 +type XString = XS.String +-- |§1.3.2 +type AnyURI = XS.AnyURI +-- |§1.3.3 +type DateTime = XS.DateTime +-- |§1.3.4 +type ID = XS.ID +-- |§1.3.4 +type NCName = XS.NCName diff --git a/SAML2/Core/Identifiers.hs b/SAML2/Core/Identifiers.hs new file mode 100644 --- /dev/null +++ b/SAML2/Core/Identifiers.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | +-- SAML-Defined Identifiers +-- +-- §8 +module SAML2.Core.Identifiers where + +import Data.Default (Default(..)) + +import SAML2.XML +import SAML2.Core.Namespaces +import SAML2.Core.Versioning + +-- |§8.1 +data ActionNamespace + = ActionNamespaceRWEDC -- ^§8.1.1: Read Write Execute Delete Control + | ActionNamespaceRWEDCNegation -- ^§8.1.2: RWEDC ~RWEDC + | ActionNamespaceGHPP -- ^§8.1.3: GET HEAD PUT POST + | ActionNamespaceUNIX -- ^§8.1.4: octal + deriving (Eq, Enum, Bounded, Show) + +instance Identifiable URI ActionNamespace where + identifier = samlURNIdentifier "action" . f where + f ActionNamespaceRWEDC = (SAML10, "rwedc") + f ActionNamespaceRWEDCNegation = (SAML10, "rwedc-negation") + f ActionNamespaceGHPP = (SAML10, "ghpp") + f ActionNamespaceUNIX = (SAML10, "unix") + +-- |§8.2 +data AttributeNameFormat + = AttributeNameFormatUnspecified -- ^§8.2.1: Text + | AttributeNameFormatURI -- ^§8.2.2: URI + | AttributeNameFormatBasic -- ^§8.2.3: Name + deriving (Eq, Enum, Bounded, Show) + +instance Identifiable URI AttributeNameFormat where + identifier = samlURNIdentifier "attrname-format" . f where + f AttributeNameFormatUnspecified = (SAML20, "unspecified") + f AttributeNameFormatURI = (SAML20, "uri") + f AttributeNameFormatBasic = (SAML20, "basic") + +-- |§8.3 +data NameIDFormat + = NameIDFormatUnspecified -- ^§8.3.1: Text + | NameIDFormatEmail -- ^§8.3.2: rfc2822 + | NameIDFormatX509 -- ^§8.3.3: XML signature + | NameIDFormatWindows -- ^§8.3.4: Maybe Domain, User + | NameIDFormatKerberos -- ^§8.3.5: rfc1510 + | NameIDFormatEntity -- ^§8.3.6: SAML endpoint (BaseId and SPProvidedID must be Nothing) + | NameIDFormatPersistent -- ^§8.3.7: String <= 256 char (NameQualifier same as idp ident/Nothing, SPNameQualifier same as sp ident/Nothing, SPProvidedID alt ident from sp) + | NameIDFormatTransient -- ^§8.3.8: String <= 256 char + | NameIDFormatEncrypted -- ^§3.4.1.1: only for NameIDPolicy + deriving (Eq, Enum, Bounded, Show) + +instance Default NameIDFormat where + def = NameIDFormatUnspecified + +instance Identifiable URI NameIDFormat where + identifier = samlURNIdentifier "nameid-format" . f where + f NameIDFormatUnspecified = (SAML11, "unspecified") + f NameIDFormatEmail = (SAML11, "emailAddress") + f NameIDFormatX509 = (SAML11, "X509SubjectName") + f NameIDFormatWindows = (SAML11, "WindowsDomainQualifiedName") + f NameIDFormatKerberos = (SAML20, "kerberos") + f NameIDFormatEntity = (SAML20, "entity") + f NameIDFormatPersistent = (SAML20, "persistent") + f NameIDFormatTransient = (SAML20, "transient") + f NameIDFormatEncrypted = (SAML20, "encrypted") + +-- |§8.4 +data Consent + = ConsentUnspecified -- ^§8.4.1 + | ConsentObtained -- ^§8.4.2 + | ConsentPrior -- ^§8.4.3 + | ConsentImplicit -- ^§8.4.4 + | ConsentExplicit -- ^§8.4.5 + | ConsentUnavailable -- ^§8.4.6 + | ConsentInapplicable -- ^§8.4.7 + deriving (Eq, Enum, Bounded, Show) + +instance Default Consent where + def = ConsentUnspecified + +instance Identifiable URI Consent where + identifier = samlURNIdentifier "consent" . f where + f ConsentUnspecified = (SAML20, "unspecified") + f ConsentObtained = (SAML20, "obtained") + f ConsentPrior = (SAML20, "prior") + f ConsentImplicit = (SAML20, "current-implicit") + f ConsentExplicit = (SAML20, "current-explicit") + f ConsentUnavailable = (SAML20, "unavailable") + f ConsentInapplicable = (SAML20, "inapplicable") diff --git a/SAML2/Core/Namespaces.hs b/SAML2/Core/Namespaces.hs new file mode 100644 --- /dev/null +++ b/SAML2/Core/Namespaces.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | +-- Schema Organization and Namespaces +-- +-- §1.2 +module SAML2.Core.Namespaces + ( samlURN + , samlURNIdentifier + ) where + +import Data.Monoid ((<>)) +import Network.URI (URI(..)) + +import SAML2.Core.Versioning + +samlURN :: SAMLVersion -> [String] -> URI +samlURN v l = URI + { uriScheme = "urn:" + , uriAuthority = Nothing + , uriPath = "oasis:names:tc:SAML" <> concatMap (':':) (show v : l) + , uriQuery = "" + , uriFragment = "" + } + +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 diff --git a/SAML2/Core/Protocols.hs b/SAML2/Core/Protocols.hs new file mode 100644 --- /dev/null +++ b/SAML2/Core/Protocols.hs @@ -0,0 +1,765 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | +-- SAML Protocols +-- +-- §3 +module SAML2.Core.Protocols where + +import Control.Lens (Lens', lens, (.~), (^.), view) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy, asProxyTypeOf) +import qualified Text.XML.HXT.Arrow.Pickle.Schema as XPS + +import SAML2.Lens +import SAML2.XML +import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP +import qualified SAML2.XML.Schema as XS +import qualified SAML2.XML.Signature.Types as DS +import SAML2.Core.Namespaces +import SAML2.Core.Versioning +import qualified SAML2.Core.Assertions as SAML +import SAML2.Core.Identifiers +import SAML2.Bindings.General (RelayState) +import SAML2.Bindings.Identifiers + +ns :: Namespace +ns = mkNamespace "samlp" $ samlURN SAML20 ["protocol"] + +xpElem :: String -> XP.PU a -> XP.PU a +xpElem = xpTrimElemNS ns + +data ProtocolType = ProtocolType + { protocolID :: XS.ID + , protocolVersion :: SAMLVersion + , protocolIssueInstant :: DateTime + , protocolDestination :: Maybe AnyURI + , protocolConsent :: IdentifiedURI Consent + , protocolIssuer :: Maybe SAML.Issuer + , protocolSignature :: Maybe DS.Signature + , protocolExtensions :: [Node] + , relayState :: Maybe RelayState -- ^out-of-band data, not part of XML + } deriving (Eq, Show) + +instance XP.XmlPickler ProtocolType where + xpickle = XP.xpWrap (pt, tp) + $ (XP.xpAttr "ID" XS.xpID + XP.>*< XP.xpAttr "Version" XP.xpickle + XP.>*< XP.xpAttr "IssueInstant" XS.xpDateTime + XP.>*< XP.xpAttrImplied "Destination" XS.xpAnyURI + XP.>*< XP.xpDefault (Identified ConsentUnspecified) (XP.xpAttr "Consent" XP.xpickle) + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpOption (xpElem "Extensions" $ XP.xpList1 xpTrimAnyElem)) + where + pt (((((((i, v), t), d), c), u), g), x) = ProtocolType i v t d c u g (fromMaybe [] x) Nothing + tp (ProtocolType i v t d c u g [] _) = (((((((i, v), t), d), c), u), g), Nothing) + tp (ProtocolType i v t d c u g x _) = (((((((i, v), t), d), c), u), g), Just x) + +instance DS.Signable ProtocolType where + signature' = $(fieldLens 'protocolSignature) + signedID = protocolID +class (XP.XmlPickler a, DS.Signable a, Show a) => SAMLProtocol a where + samlProtocol' :: Lens' a ProtocolType + isSAMLResponse :: a -> Bool + isSAMLResponse_ :: Proxy a -> Maybe Bool + isSAMLResponse_ = Just . isSAMLResponse . asProxyTypeOf undefined + +-- |§3.2.1 +newtype RequestAbstractType = RequestAbstractType + { requestProtocol :: ProtocolType + } deriving (Eq, Show) + +instance XP.XmlPickler RequestAbstractType where + xpickle = [XP.biCase|p <-> RequestAbstractType p|] + XP.>$< XP.xpickle + +class SAMLProtocol a => SAMLRequest a where + samlRequest' :: Lens' a RequestAbstractType + +requestProtocol' :: Lens' RequestAbstractType ProtocolType +requestProtocol' = $(fieldLens 'requestProtocol) + +-- |§3.2.2 +data StatusResponseType = StatusResponseType + { statusProtocol :: !ProtocolType + , statusInResponseTo :: Maybe XS.NCName + , status :: Status + } deriving (Eq, Show) + +instance XP.XmlPickler StatusResponseType where + xpickle = [XP.biCase|((p, r), s) <-> StatusResponseType p r s|] + XP.>$< (XP.xpickle + XP.>*< XP.xpAttrImplied "InResponseTo" XS.xpNCName + XP.>*< XP.xpickle) + +class SAMLProtocol a => SAMLResponse a where + samlResponse' :: Lens' a StatusResponseType + +statusProtocol' :: Lens' StatusResponseType ProtocolType +statusProtocol' = $(fieldLens 'statusProtocol) + +-- |§3.2.2.1 +data Status = Status + { statusCode :: StatusCode + , statusMessage :: Maybe XString -- ^§3.2.2.3 + , statusDetail :: Maybe Nodes -- ^§3.2.2.4 + } deriving (Eq, Show) + +instance XP.XmlPickler Status where + xpickle = xpElem "Status" $ [XP.biCase| + ((c, m), d) <-> Status c m d|] + XP.>$< (XP.xpickle + XP.>*< XP.xpOption (xpElem "StatusMessage" XP.xpText0) + XP.>*< XP.xpOption (xpElem "StatusDetail" XP.xpAnyCont)) + +-- |§3.2.2.2 +data StatusCode = StatusCode + { statusCode1 :: StatusCode1 + , statusCodes :: [IdentifiedURI StatusCode2] + } deriving (Eq, Show) + +instance XP.XmlPickler StatusCode where + xpickle = xpElem "StatusCode" $ [XP.biCase| + (v, c) <-> StatusCode v c|] + XP.>$< (XP.xpAttr "Value" XP.xpickle + XP.>*< xpStatusCodes) where + xpStatusCodes = [XP.biCase| + Nothing <-> [] + Just (v, c) <-> v : c|] + XP.>$< XP.xpOption (xpElem "StatusCode" $ + XP.xpAttr "Value" XP.xpickle + XP.>*< xpStatusCodes) + +data StatusCode1 + = StatusSuccess + | StatusRequester + | StatusResponder + | StatusVersionMismatch + deriving (Eq, Bounded, Enum, Show) + +instance Identifiable URI StatusCode1 where + identifier = samlURNIdentifier "status" . f where + f StatusSuccess = (SAML20, "Success") + f StatusRequester = (SAML20, "Requester") + f StatusResponder = (SAML20, "Responder") + f StatusVersionMismatch = (SAML20, "VersionMismatch") +instance XP.XmlPickler StatusCode1 where + xpickle = xpIdentifier XS.xpAnyURI "status" + +data StatusCode2 + = StatusAuthnFailed + | StatusInvalidAttrNameOrValue + | StatusInvalidNameIDPolicy + | StatusNoAuthnContext + | StatusNoAvailableIDP + | StatusNoPassive + | StatusNoSupportedIDP + | StatusPartialLogout + | StatusProxyCountExceeded + | StatusRequestDenied + | StatusRequestUnsupported + | StatusRequestVersionDeprecated + | StatusRequestVersionTooHigh + | StatusRequestVersionTooLow + | StatusResourceNotRecognized + | StatusTooManyResponses + | StatusUnknownAttrProfile + | StatusUnknownPrincipal + | StatusUnsupportedBinding + deriving (Eq, Bounded, Enum, Show) + +instance Identifiable URI StatusCode2 where + identifier = samlURNIdentifier "status" . f where + f StatusAuthnFailed = (SAML20, "AuthnFailed") + f StatusInvalidAttrNameOrValue = (SAML20, "InvalidAttrNameOrValue") + f StatusInvalidNameIDPolicy = (SAML20, "InvalidNameIDPolicy") + f StatusNoAuthnContext = (SAML20, "NoAuthnContext") + f StatusNoAvailableIDP = (SAML20, "NoAvailableIDP") + f StatusNoPassive = (SAML20, "NoPassive") + f StatusNoSupportedIDP = (SAML20, "NoSupportedIDP") + f StatusPartialLogout = (SAML20, "PartialLogout") + f StatusProxyCountExceeded = (SAML20, "ProxyCountExceeded") + f StatusRequestDenied = (SAML20, "RequestDenied") + f StatusRequestUnsupported = (SAML20, "RequestUnsupported") + f StatusRequestVersionDeprecated = (SAML20, "RequestVersionDeprecated") + f StatusRequestVersionTooHigh = (SAML20, "RequestVersionTooHigh") + f StatusRequestVersionTooLow = (SAML20, "RequestVersionTooLow") + f StatusResourceNotRecognized = (SAML20, "ResourceNotRecognized") + f StatusTooManyResponses = (SAML20, "TooManyResponses") + f StatusUnknownAttrProfile = (SAML20, "UnknownAttrProfile") + f StatusUnknownPrincipal = (SAML20, "UnknownPrincipal") + f StatusUnsupportedBinding = (SAML20, "UnsupportedBinding") + +successStatus :: Status +successStatus = Status (StatusCode StatusSuccess []) Nothing Nothing + +-- |§3.3.1 +data AssertionIDRequest = AssertionIDRequest + { assertionIDRequest :: !RequestAbstractType + , assertionIDRequestRef :: List1 (SAML.AssertionIDRef) + } deriving (Eq, Show) + +instance XP.XmlPickler AssertionIDRequest where + xpickle = xpElem "AssertionIDRequest" $ [XP.biCase| + (q, r) <-> AssertionIDRequest q r|] + XP.>$< (XP.xpickle + XP.>*< xpList1 XP.xpickle) +instance DS.Signable AssertionIDRequest where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol AssertionIDRequest where + samlProtocol' = samlRequest' . requestProtocol' + isSAMLResponse _ = False +instance SAMLRequest AssertionIDRequest where + samlRequest' = $(fieldLens 'assertionIDRequest) + +-- |§3.3.2.1 +data SubjectQueryAbstractType = SubjectQueryAbstractType + { subjectQuery :: !RequestAbstractType + , subjectQuerySubject :: SAML.Subject + } deriving (Eq, Show) + +instance XP.XmlPickler SubjectQueryAbstractType where + xpickle = [XP.biCase| + (q, r) <-> SubjectQueryAbstractType q r|] + XP.>$< (XP.xpickle + XP.>*< XP.xpickle) + +subjectQuery' :: Lens' SubjectQueryAbstractType RequestAbstractType +subjectQuery' = $(fieldLens 'subjectQuery) + +-- |§3.3.2.2 +data AuthnQuery = AuthnQuery + { authnQuery :: !SubjectQueryAbstractType + , authnQuerySessionIndex :: Maybe XString + , authnQueryRequestedAuthnContext :: Maybe RequestedAuthnContext + } deriving (Eq, Show) + +instance XP.XmlPickler AuthnQuery where + xpickle = xpElem "AuthnQuery" $ [XP.biCase| + ((q, i), c) <-> AuthnQuery q i c|] + XP.>$< (XP.xpickle + XP.>*< XP.xpAttrImplied "SessionIndex" XS.xpString + XP.>*< XP.xpOption XP.xpickle) +instance DS.Signable AuthnQuery where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol AuthnQuery where + samlProtocol' = samlRequest' . requestProtocol' + isSAMLResponse _ = False +instance SAMLRequest AuthnQuery where + samlRequest' = authnQuery' . subjectQuery' where + authnQuery' = $(fieldLens 'authnQuery) + +-- |§3.3.2.2.1 +data RequestedAuthnContext = RequestedAuthnContext + { requestedAuthnContextComparison :: Maybe AuthnContextComparisonType + , requestedAuthnContextRefs :: AuthnContextRefs + } deriving (Eq, Show) + +instance XP.XmlPickler RequestedAuthnContext where + xpickle = xpElem "RequestedAuthnContext" $ [XP.biCase| + (c, r) <-> RequestedAuthnContext c r|] + XP.>$< (XP.xpAttrImplied "Comparison" XP.xpickle + XP.>*< XP.xpickle) + +data AuthnContextRefs + = AuthnContextClassRefs (List1 AnyURI) + | AuthnContextDeclRefs (List1 AnyURI) + deriving (Eq, Show) + +instance XP.XmlPickler AuthnContextRefs where + xpickle = [XP.biCase| + Left l <-> AuthnContextClassRefs l + Right l <-> AuthnContextDeclRefs l|] + XP.>$< (xpList1 (SAML.xpElem "AuthnContextClassRef" XS.xpAnyURI) + XP.>|< xpList1 (SAML.xpElem "AuthnContextDeclRef" XS.xpAnyURI)) + +data AuthnContextComparisonType + = ComparisonExact + | ComparisonMinimum + | ComparisonMaximum + | ComparisonBetter + deriving (Eq, Enum, Bounded, Show) + +instance Identifiable XString AuthnContextComparisonType where + identifier ComparisonExact = "exact" + identifier ComparisonMinimum = "minimum" + identifier ComparisonMaximum = "maximum" + identifier ComparisonBetter = "better" +instance XP.XmlPickler AuthnContextComparisonType where + xpickle = xpIdentifier (XP.xpTextDT (XPS.scDT (namespaceURIString ns) "AuthnContextComparisonType" [])) "AuthnContextComparisonType" + +-- |§3.3.2.3 +data AttributeQuery = AttributeQuery + { attributeQuery :: !SubjectQueryAbstractType + , attributeQueryAttributes :: [SAML.Attribute] + } deriving (Eq, Show) + +instance XP.XmlPickler AttributeQuery where + xpickle = xpElem "AttributeQuery" $ [XP.biCase| + (q, a) <-> AttributeQuery q a|] + XP.>$< (XP.xpickle + XP.>*< XP.xpList XP.xpickle) +instance DS.Signable AttributeQuery where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol AttributeQuery where + samlProtocol' = samlRequest' . requestProtocol' + isSAMLResponse _ = False +instance SAMLRequest AttributeQuery where + samlRequest' = attributeQuery' . subjectQuery' where + attributeQuery' = $(fieldLens 'attributeQuery) + +-- |§3.3.2.4 +data AuthzDecisionQuery = AuthzDecisionQuery + { authzDecisionQuery :: !SubjectQueryAbstractType + , authzDecisionQueryResource :: AnyURI + , authzDecisionQueryActions :: [SAML.Action] + , authzDecisionQueryEvidence :: SAML.Evidence + } deriving (Eq, Show) + +instance XP.XmlPickler AuthzDecisionQuery where + xpickle = xpElem "AuthzDecisionQuery" $ [XP.biCase| + (((q, r), a), e) <-> AuthzDecisionQuery q r a e|] + XP.>$< (XP.xpickle + XP.>*< XP.xpAttr "Resource" XS.xpAnyURI + XP.>*< XP.xpList XP.xpickle + XP.>*< XP.xpickle) +instance DS.Signable AuthzDecisionQuery where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol AuthzDecisionQuery where + samlProtocol' = samlRequest' . requestProtocol' + isSAMLResponse _ = False +instance SAMLRequest AuthzDecisionQuery where + samlRequest' = authzDecisionQuery' . subjectQuery' where + authzDecisionQuery' = $(fieldLens 'authzDecisionQuery) + +-- |§3.3.3 +data Response = Response + { response :: !StatusResponseType + , responseAssertions :: [SAML.PossiblyEncrypted SAML.Assertion] + } deriving (Eq, Show) + +instance XP.XmlPickler Response where + xpickle = xpElem "Response" $ [XP.biCase| + (r, a) <-> Response r a|] + XP.>$< (XP.xpickle + XP.>*< XP.xpList SAML.xpPossiblyEncrypted) +instance DS.Signable Response where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol Response where + samlProtocol' = samlResponse' . statusProtocol' + isSAMLResponse _ = True +instance SAMLResponse Response where + samlResponse' = $(fieldLens 'response) + +-- |§3.4.1 +data AuthnRequest = AuthnRequest + { authnRequest :: !RequestAbstractType + , authnRequestForceAuthn :: XS.Boolean + , authnRequestIsPassive :: XS.Boolean + , authnRequestAssertionConsumerService :: AssertionConsumerService + , authnRequestAssertionConsumingServiceIndex :: Maybe XS.UnsignedShort + , authnRequestProviderName :: Maybe XString + , authnRequestSubject :: Maybe SAML.Subject + , authnRequestNameIDPolicy :: Maybe NameIDPolicy + , authnRequestConditions :: Maybe SAML.Conditions + , authnRequestRequestedAuthnContext :: Maybe RequestedAuthnContext + , authnRequestScoping :: Maybe Scoping + } deriving (Eq, Show) + +data AssertionConsumerService + = AssertionConsumerServiceIndex XS.UnsignedShort + | AssertionConsumerServiceURL + { authnRequestAssertionConsumerServiceURL :: Maybe AnyURI + , authnRequestProtocolBinding :: Maybe (IdentifiedURI Binding) + } + deriving (Eq, Show) + +instance XP.XmlPickler AuthnRequest where + xpickle = xpElem "AuthnRequest" $ [XP.biCase| + ((((((((((q, f), p), Left i), g), n), s), np), c), r), sc) <-> AuthnRequest q f p (AssertionConsumerServiceIndex i) g n s np c r sc + ((((((((((q, f), p), Right (u, b)), g), n), s), np), c), r), sc) <-> AuthnRequest q f p (AssertionConsumerServiceURL u b) g n s np c r sc|] + XP.>$< (XP.xpickle + XP.>*< XP.xpDefault False (XP.xpAttr "ForceAuthn" XS.xpBoolean) + XP.>*< XP.xpDefault False (XP.xpAttr "IsPassive" XS.xpBoolean) + XP.>*< (XP.xpAttr "AssertionConsumerServiceIndex" XS.xpUnsignedShort + XP.>|< (XP.xpAttrImplied "AssertionConsumerServiceURL" XS.xpAnyURI + XP.>*< XP.xpAttrImplied "ProtocolBinding" XP.xpickle)) + XP.>*< XP.xpAttrImplied "AttributeConsumingServiceIndex" XS.xpUnsignedShort + XP.>*< XP.xpAttrImplied "ProviderName" XS.xpString + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpOption XP.xpickle) +instance DS.Signable AuthnRequest where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol AuthnRequest where + samlProtocol' = samlRequest' . requestProtocol' + isSAMLResponse _ = False +instance SAMLRequest AuthnRequest where + samlRequest' = $(fieldLens 'authnRequest) + +-- |§3.4.1.1 +data NameIDPolicy = NameIDPolicy + { nameIDPolicyFormat :: IdentifiedURI NameIDFormat + , nameIDPolicySPNameQualifier :: Maybe XString + , nameIDPolicyAllowCreate :: Bool + } deriving (Eq, Show) + +instance XP.XmlPickler NameIDPolicy where + xpickle = xpElem "NameIDPolicy" $ [XP.biCase| + ((f, q), c) <-> NameIDPolicy f q c|] + XP.>$< (XP.xpDefault (Identified NameIDFormatUnspecified) (XP.xpAttr "Format" XP.xpickle) + XP.>*< XP.xpAttrImplied "SPNameQualifier" XS.xpString + XP.>*< XP.xpDefault False (XP.xpAttr "AllowCreate" XS.xpBoolean)) + +-- |§3.4.1.2 +data Scoping = Scoping + { scopingProxyCount :: Maybe XS.NonNegativeInteger + , scopingIDPList :: Maybe IDPList + , scopingRequesterID :: [AnyURI] + } deriving (Eq, Show) + +instance XP.XmlPickler Scoping where + xpickle = xpElem "Scoping" $ [XP.biCase| + ((c, i), r) <-> Scoping c i r|] + XP.>$< (XP.xpAttrImplied "ProxyCount" XS.xpNonNegativeInteger + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpList (xpElem "RequesterID" XS.xpAnyURI)) + +-- |§3.4.1.3 +data IDPList = IDPList + { idpList :: List1 IDPEntry + , idpGetComplete :: Maybe AnyURI + } deriving (Eq, Show) + +instance XP.XmlPickler IDPList where + xpickle = xpElem "IDPList" $ [XP.biCase| + (l, c) <-> IDPList l c|] + XP.>$< (xpList1 XP.xpickle + XP.>*< XP.xpOption (xpElem "GetComplete" XS.xpAnyURI)) + +-- |§3.4.1.3.1 +data IDPEntry = IDPEntry + { idpEntryProviderID :: AnyURI + , idpEntryName :: Maybe XString + , idpEntryLoc :: Maybe AnyURI + } deriving (Eq, Show) + +instance XP.XmlPickler IDPEntry where + xpickle = xpElem "IDPEntry" $ [XP.biCase| + ((p, n), l) <-> IDPEntry p n l|] + XP.>$< (XP.xpAttr "ProviderID" XS.xpAnyURI + XP.>*< XP.xpAttrImplied "Name" XS.xpString + XP.>*< XP.xpAttrImplied "Loc" XS.xpAnyURI) + +-- |§3.5.1 +data ArtifactResolve = ArtifactResolve + { artifactResolve :: !RequestAbstractType + , artifactResolveArtifact :: XString + } deriving (Eq, Show) + +instance XP.XmlPickler ArtifactResolve where + xpickle = xpElem "ArtifactResolve" $ [XP.biCase| + (r, a) <-> ArtifactResolve r a|] + XP.>$< (XP.xpickle + XP.>*< xpElem "Artifact" XS.xpString) +instance DS.Signable ArtifactResolve where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol ArtifactResolve where + samlProtocol' = samlRequest' . requestProtocol' + isSAMLResponse _ = False +instance SAMLRequest ArtifactResolve where + samlRequest' = $(fieldLens 'artifactResolve) + +-- |§3.5.2 +data ArtifactResponse = ArtifactResponse + { artifactResponse :: !StatusResponseType + , artifactResponseMessage :: Maybe Node + } deriving (Eq, Show) + +instance XP.XmlPickler ArtifactResponse where + xpickle = xpElem "ArtifactResponse" $ [XP.biCase| + (r, a) <-> ArtifactResponse r a|] + XP.>$< (XP.xpickle + XP.>*< XP.xpOption xpTrimAnyElem) +instance DS.Signable ArtifactResponse where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol ArtifactResponse where + samlProtocol' = samlResponse' . statusProtocol' + isSAMLResponse _ = True +instance SAMLResponse ArtifactResponse where + samlResponse' = $(fieldLens 'artifactResponse) + +-- |§3.6.1 +data ManageNameIDRequest = ManageNameIDRequest + { manageNameIDRequest :: !RequestAbstractType + , manageNameIDRequestNameID :: SAML.PossiblyEncrypted SAML.NameID + , manageNameIDRequestNewID :: Maybe (SAML.PossiblyEncrypted NewID) + } deriving (Eq, Show) + +instance XP.XmlPickler ManageNameIDRequest where + xpickle = xpElem "ManageNameIDRequest" $ [XP.biCase| + ((r, o), Left n) <-> ManageNameIDRequest r o (Just n) + ((r, o), Right ()) <-> ManageNameIDRequest r o Nothing|] + XP.>$< (XP.xpickle + XP.>*< SAML.xpPossiblyEncrypted + XP.>*< (SAML.xpPossiblyEncrypted + XP.>|< xpElem "Terminate" XP.xpUnit)) +instance DS.Signable ManageNameIDRequest where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol ManageNameIDRequest where + samlProtocol' = samlRequest' . requestProtocol' + isSAMLResponse _ = False +instance SAMLRequest ManageNameIDRequest where + samlRequest' = $(fieldLens 'manageNameIDRequest) + +newtype NewID = NewID{ newID :: XString } + deriving (Eq, Show) + +instance XP.XmlPickler NewID where + xpickle = xpElem "NewID" $ [XP.biCase| + n <-> NewID n|] + XP.>$< XS.xpString + +type NewEncryptedID = SAML.EncryptedElement NewID + +instance XP.XmlPickler NewEncryptedID where + xpickle = xpElem "NewEncryptedID" SAML.xpEncryptedElement + +-- |§3.6.2 +newtype ManageNameIDResponse = ManageNameIDResponse + { manageNameIDResponse :: StatusResponseType } + deriving (Eq, Show) + +instance XP.XmlPickler ManageNameIDResponse where + xpickle = xpElem "ManageNameIDResponse" $ [XP.biCase| + r <-> ManageNameIDResponse r|] + XP.>$< XP.xpickle +instance DS.Signable ManageNameIDResponse where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol ManageNameIDResponse where + samlProtocol' = samlResponse' . statusProtocol' + isSAMLResponse _ = True +instance SAMLResponse ManageNameIDResponse where + samlResponse' = $(fieldLens 'manageNameIDResponse) + +-- |§3.7.1 +data LogoutRequest = LogoutRequest + { logoutRequest :: !RequestAbstractType + , logoutRequestReason :: Maybe (Identified XString LogoutReason) + , logoutRequestNotOnOrAfter :: Maybe XS.DateTime + , logoutRequestIdentifier :: SAML.PossiblyEncrypted SAML.Identifier + , logoutRequestSessionIndex :: Maybe XString + } deriving (Eq, Show) + +instance XP.XmlPickler LogoutRequest where + xpickle = xpElem "LogoutRequest" $ [XP.biCase| + ((((q, r), t), i), s) <-> LogoutRequest q r t i s|] + XP.>$< (XP.xpickle + XP.>*< XP.xpAttrImplied "Reason" XP.xpickle + XP.>*< XP.xpAttrImplied "NotOnOrAfter" XS.xpDateTime + XP.>*< SAML.xpPossiblyEncrypted + XP.>*< XP.xpOption (xpElem "SessionIndex" XS.xpString)) +instance DS.Signable LogoutRequest where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol LogoutRequest where + samlProtocol' = samlRequest' . requestProtocol' + isSAMLResponse _ = False +instance SAMLRequest LogoutRequest where + samlRequest' = $(fieldLens 'logoutRequest) + +-- |§3.7.2 +newtype LogoutResponse = LogoutResponse + { logoutResponse :: StatusResponseType } + deriving (Eq, Show) + +instance XP.XmlPickler LogoutResponse where + xpickle = xpElem "LogoutResponse" $ [XP.biCase| + r <-> LogoutResponse r|] + XP.>$< XP.xpickle +instance DS.Signable LogoutResponse where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol LogoutResponse where + samlProtocol' = samlResponse' . statusProtocol' + isSAMLResponse _ = True +instance SAMLResponse LogoutResponse where + samlResponse' = $(fieldLens 'logoutResponse) + +-- |§3.7.3 +data LogoutReason + = LogoutReasonUser + | LogoutReasonAdmin + deriving (Eq, Enum, Bounded, Show) + +instance Identifiable XString LogoutReason where + identifier = show . samlURNIdentifier "logout" . f where + f LogoutReasonUser = (SAML20, "user") + f LogoutReasonAdmin = (SAML20, "admin") +instance XP.XmlPickler (Identified XString LogoutReason) where + xpickle = xpIdentified XS.xpString + +-- |§3.8.1 +data NameIDMappingRequest = NameIDMappingRequest + { nameIDMappingRequest :: !RequestAbstractType + , nameIDMappingRequestIdentifier :: SAML.PossiblyEncrypted SAML.Identifier + , nameIDMappingRequestPolicy :: NameIDPolicy + } deriving (Eq, Show) + +instance XP.XmlPickler NameIDMappingRequest where + xpickle = xpElem "NameIDMappingRequest" $ [XP.biCase| + ((r, i), p) <-> NameIDMappingRequest r i p|] + XP.>$< (XP.xpickle + XP.>*< SAML.xpPossiblyEncrypted + XP.>*< XP.xpickle) +instance DS.Signable NameIDMappingRequest where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol NameIDMappingRequest where + samlProtocol' = samlRequest' . requestProtocol' + isSAMLResponse _ = False +instance SAMLRequest NameIDMappingRequest where + samlRequest' = $(fieldLens 'nameIDMappingRequest) + +-- |§3.8.2 +data NameIDMappingResponse = NameIDMappingResponse + { nameIDMappingResponse :: !StatusResponseType + , nameIDMappingResponseNameID :: SAML.PossiblyEncrypted SAML.NameID + } deriving (Eq, Show) + +instance XP.XmlPickler NameIDMappingResponse where + xpickle = xpElem "NameIDMappingResponse" $ [XP.biCase| + (r, a) <-> NameIDMappingResponse r a|] + XP.>$< (XP.xpickle + XP.>*< SAML.xpPossiblyEncrypted) +instance DS.Signable NameIDMappingResponse where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol NameIDMappingResponse where + samlProtocol' = samlResponse' . statusProtocol' + isSAMLResponse _ = True +instance SAMLResponse NameIDMappingResponse where + samlResponse' = $(fieldLens 'nameIDMappingResponse) + +data AnyRequest + = RequestAssertionIDRequest !AssertionIDRequest + | RequestAuthnQuery !AuthnQuery + | RequestAttributeQuery !AttributeQuery + | RequestAuthzDecisionQuery !AuthzDecisionQuery + | RequestAuthnRequest !AuthnRequest + | RequestArtifactResolve !ArtifactResolve + | RequestManageNameIDRequest !ManageNameIDRequest + | RequestLogoutRequest !LogoutRequest + | RequestNameIDMappingRequest !NameIDMappingRequest + deriving (Eq, Show) + +instance XP.XmlPickler AnyRequest where + xpickle = [XP.biCase| + Left (Left (Left (Left (Left (Left (Left (Left r))))))) <-> RequestAssertionIDRequest r + Left (Left (Left (Left (Left (Left (Left (Right r))))))) <-> RequestAuthnQuery r + Left (Left (Left (Left (Left (Left (Right r)))))) <-> RequestAttributeQuery r + Left (Left (Left (Left (Left (Right r))))) <-> RequestAuthzDecisionQuery r + Left (Left (Left (Left (Right r)))) <-> RequestAuthnRequest r + Left (Left (Left (Right r))) <-> RequestArtifactResolve r + Left (Left (Right r)) <-> RequestManageNameIDRequest r + Left (Right r) <-> RequestLogoutRequest r + Right r <-> RequestNameIDMappingRequest r|] + XP.>$< (XP.xpickle + XP.>|< XP.xpickle + XP.>|< XP.xpickle + XP.>|< XP.xpickle + XP.>|< XP.xpickle + XP.>|< XP.xpickle + XP.>|< XP.xpickle + XP.>|< XP.xpickle + XP.>|< XP.xpickle) +instance DS.Signable AnyRequest where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol AnyRequest where + samlProtocol' = samlRequest' . requestProtocol' + isSAMLResponse _ = False +instance SAMLRequest AnyRequest where + samlRequest' = lens g s where + g (RequestAssertionIDRequest r) = r ^. samlRequest' + g (RequestAuthnQuery r) = r ^. samlRequest' + g (RequestAttributeQuery r) = r ^. samlRequest' + g (RequestAuthzDecisionQuery r) = r ^. samlRequest' + g (RequestAuthnRequest r) = r ^. samlRequest' + g (RequestArtifactResolve r) = r ^. samlRequest' + g (RequestManageNameIDRequest r) = r ^. samlRequest' + g (RequestLogoutRequest r) = r ^. samlRequest' + g (RequestNameIDMappingRequest r) = r ^. samlRequest' + s (RequestAssertionIDRequest r) q = RequestAssertionIDRequest $ samlRequest' .~ q $ r + s (RequestAuthnQuery r) q = RequestAuthnQuery $ samlRequest' .~ q $ r + s (RequestAttributeQuery r) q = RequestAttributeQuery $ samlRequest' .~ q $ r + s (RequestAuthzDecisionQuery r) q = RequestAuthzDecisionQuery $ samlRequest' .~ q $ r + s (RequestAuthnRequest r) q = RequestAuthnRequest $ samlRequest' .~ q $ r + s (RequestArtifactResolve r) q = RequestArtifactResolve $ samlRequest' .~ q $ r + s (RequestManageNameIDRequest r) q = RequestManageNameIDRequest $ samlRequest' .~ q $ r + s (RequestLogoutRequest r) q = RequestLogoutRequest $ samlRequest' .~ q $ r + s (RequestNameIDMappingRequest r) q = RequestNameIDMappingRequest $ samlRequest' .~ q $ r + +data AnyResponse + = ResponseResponse !Response + | ResponseArtifactResponse !ArtifactResponse + deriving (Eq, Show) + +instance XP.XmlPickler AnyResponse where + xpickle = [XP.biCase| + Left r <-> ResponseResponse r + Right r <-> ResponseArtifactResponse r|] + XP.>$< (XP.xpickle + XP.>|< XP.xpickle) +instance DS.Signable AnyResponse where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol AnyResponse where + samlProtocol' = samlResponse' . statusProtocol' + isSAMLResponse _ = True +instance SAMLResponse AnyResponse where + samlResponse' = lens g s where + g (ResponseResponse r) = r ^. samlResponse' + 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 + deriving (Eq, Show) + +instance XP.XmlPickler AnyProtocol where + xpickle = [XP.biCase| + Left r <-> ProtocolRequest r + Right r <-> ProtocolResponse r|] + XP.>$< (XP.xpickle + XP.>|< XP.xpickle) +instance DS.Signable AnyProtocol where + signature' = samlProtocol' . DS.signature' + signedID = protocolID . view samlProtocol' +instance SAMLProtocol AnyProtocol where + samlProtocol' = lens g s where + g (ProtocolRequest r) = r ^. samlProtocol' + g (ProtocolResponse r) = r ^. samlProtocol' + s (ProtocolRequest r) q = ProtocolRequest $ samlProtocol' .~ q $ r + s (ProtocolResponse r) q = ProtocolResponse $ samlProtocol' .~ q $ r + isSAMLResponse (ProtocolRequest _) = False + isSAMLResponse (ProtocolResponse _) = True + isSAMLResponse_ _ = Nothing diff --git a/SAML2/Core/Signature.hs b/SAML2/Core/Signature.hs new file mode 100644 --- /dev/null +++ b/SAML2/Core/Signature.hs @@ -0,0 +1,55 @@ +-- | +-- SAML and XML Signature Syntax and Processing +-- +-- §5 +module SAML2.Core.Signature + ( signSAMLProtocol + , verifySAMLProtocol + ) where + +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 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 + +signSAMLProtocol :: SAMLP.SAMLProtocol a => DS.SigningKey -> a -> IO a +signSAMLProtocol sk m = do + r <- DS.generateReference DS.Reference + { DS.referenceId = Nothing + , DS.referenceURI = Just nullURI{ uriFragment = '#':SAMLP.protocolID p } + , DS.referenceType = Nothing + , DS.referenceTransforms = Just $ DS.Transforms + $ DS.simpleTransform DS.TransformEnvelopedSignature + :| DS.simpleTransform (DS.TransformCanonicalization $ C14N.CanonicalXMLExcl10 False) + : [] + , DS.referenceDigestMethod = DS.simpleDigest DS.DigestSHA1 + , DS.referenceDigestValue = error "signSAMLProtocol: referenceDigestValue" + } $ XP.pickleDoc XP.xpickle m + s' <- DS.generateSignature sk $ maybe DS.SignedInfo + { DS.signedInfoId = Nothing + , DS.signedInfoCanonicalizationMethod = DS.simpleCanonicalization $ C14N.CanonicalXMLExcl10 False + , DS.signedInfoSignatureMethod = DS.SignatureMethod + { DS.signatureMethodAlgorithm = Identified $ DS.signingKeySignatureAlgorithm sk + , DS.signatureMethodHMACOutputLength = Nothing + , DS.signatureMethod = [] + } + , DS.signedInfoReference = r :| [] + } DS.signatureSignedInfo $ SAMLP.protocolSignature p + return $ DS.signature' .~ Just s' $ m + where + p = m ^. SAMLP.samlProtocol' + +verifySAMLProtocol :: SAMLP.SAMLProtocol a => BSL.ByteString -> IO a +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 diff --git a/SAML2/Core/Versioning.hs b/SAML2/Core/Versioning.hs new file mode 100644 --- /dev/null +++ b/SAML2/Core/Versioning.hs @@ -0,0 +1,37 @@ +-- | +-- SAML Versioning +-- +-- §4 +module SAML2.Core.Versioning + ( SAMLVersion(..) + , samlVersion + ) where + +import Data.Version (Version, makeVersion) + +import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP + +data SAMLVersion + = SAML10 + | SAML11 + | SAML20 + deriving (Eq, Ord, Enum, Bounded) + +samlVersion :: SAMLVersion -> Version +samlVersion SAML10 = makeVersion [1,0] +samlVersion SAML11 = makeVersion [1,1] +samlVersion SAML20 = makeVersion [2,0] + +instance Show SAMLVersion where + show SAML10 = "1.0" + show SAML11 = "1.1" + show SAML20 = "2.0" + +instance Read SAMLVersion where + readsPrec _ ('1':'.':'0':s) = [(SAML10, s)] + readsPrec _ ('1':'.':'1':s) = [(SAML11, s)] + readsPrec _ ('2':'.':'0':s) = [(SAML20, s)] + readsPrec _ _ = [] + +instance XP.XmlPickler SAMLVersion where + xpickle = XP.xpPrim diff --git a/SAML2/Lens.hs b/SAML2/Lens.hs new file mode 100644 --- /dev/null +++ b/SAML2/Lens.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +module SAML2.Lens + ( fieldLens + ) where + +import Control.Lens.Lens (lens) +import qualified Language.Haskell.TH as TH + +fieldLens :: TH.Name -> TH.ExpQ +fieldLens f = do + a <- TH.newName "a" + b <- TH.newName "b" + return $ TH.VarE 'lens `TH.AppE` TH.VarE f + `TH.AppE` TH.LamE [TH.VarP a, TH.VarP b] (TH.RecUpdE (TH.VarE a) [(f, TH.VarE b)]) diff --git a/SAML2/Metadata.hs b/SAML2/Metadata.hs new file mode 100644 --- /dev/null +++ b/SAML2/Metadata.hs @@ -0,0 +1,34 @@ +-- | +-- Metadata for the OASIS Security Assertion Markup Language (SAML) V2.0 +-- +-- +module SAML2.Metadata + ( -- * §2 + nsMD + , EntityID + , Endpoint(..) + , IndexedEndpoint(..) + , Localized(..) + , LocalizedName + , LocalizedURI + , Metadata(..) + , Extensions(..) + , Descriptors(..) + , Descriptor(..) + , Organization(..) + , Contact(..) + , ContactType(..) + , AdditionalMetadataLocation(..) + , RoleDescriptor(..) + , KeyDescriptor(..) + , KeyTypes(..) + , SSODescriptor(..) + , AttributeConsumingService(..) + , RequestedAttribute(..) + ) where + +import SAML2.XML.Types +import SAML2.Metadata.Metadata + +nsMD :: Namespace +nsMD = ns diff --git a/SAML2/Metadata/Metadata.hs b/SAML2/Metadata/Metadata.hs new file mode 100644 --- /dev/null +++ b/SAML2/Metadata/Metadata.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- Metadata for SAML V2.0 +-- +-- §2 +module SAML2.Metadata.Metadata where + +import Data.Foldable (fold) +import qualified Network.URI as URI +import qualified Text.XML.HXT.Arrow.Pickle.Schema as XPS + +import SAML2.Lens +import SAML2.XML +import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP +import qualified SAML2.XML.Schema as XS +import qualified SAML2.XML.Signature.Types as DS +import qualified SAML2.XML.Encryption as XEnc +import SAML2.Core.Namespaces +import SAML2.Core.Versioning +import SAML2.Core.Identifiers +import qualified SAML2.Core.Assertions as SAML +import SAML2.Bindings.Identifiers + +ns :: Namespace +ns = mkNamespace "md" $ samlURN SAML20 ["metadata"] + +xpElem :: String -> XP.PU a -> XP.PU a +xpElem = xpTrimElemNS ns + +-- |§2.2.1 +type EntityID = AnyURI + +xpEntityID :: XP.PU EntityID +xpEntityID = XS.xpAnyURI -- XXX maxLength=1024 + +-- |§2.2.2 +data Endpoint = Endpoint + { endpointBinding :: IdentifiedURI Binding + , endpointLocation :: AnyURI + , endpointResponseLocation :: Maybe AnyURI + , endpointAttrs :: Nodes + , endpointXML :: Nodes + } deriving (Eq, Show) + +instance XP.XmlPickler Endpoint where + xpickle = [XP.biCase| + ((((b, l), r), a), x) <-> Endpoint b l r a x|] + XP.>$< (XP.xpAttr "Binding" XP.xpickle + XP.>*< XP.xpAttr "Location" XS.xpAnyURI + XP.>*< XP.xpAttrImplied "ResponseLocation" XS.xpAnyURI + XP.>*< XP.xpAnyAttrs + XP.>*< XP.xpList xpTrimAnyElem) + +-- |§2.2.3 +data IndexedEndpoint = IndexedEndpoint + { indexedEndpoint :: Endpoint + , indexedEndpointIndex :: XS.UnsignedShort + , indexedEndpointIsDefault :: XS.Boolean + } deriving (Eq, Show) + +instance XP.XmlPickler IndexedEndpoint where + xpickle = [XP.biCase| + ((i, d), e) <-> IndexedEndpoint e i d|] + XP.>$< (XP.xpAttr "index" XS.xpUnsignedShort + XP.>*< XP.xpDefault False (XP.xpAttr "isDefault" XS.xpBoolean) + XP.>*< XP.xpickle) + +data Localized a = Localized + { localizedLang :: XS.Language + , localized :: a + } deriving (Eq, Show) + +xpLocalized :: XP.PU a -> XP.PU (Localized a) +xpLocalized p = [XP.biCase| + (l, x) <-> Localized l x|] + XP.>$< (xpXmlLang + XP.>*< p) + +-- |§2.2.4 +type LocalizedName = Localized XS.String + +instance XP.XmlPickler LocalizedName where + xpickle = xpLocalized XS.xpString + +-- |§2.2.5 +type LocalizedURI = Localized XS.AnyURI + +instance XP.XmlPickler LocalizedURI where + xpickle = xpLocalized XS.xpAnyURI + +data Metadata + = EntityDescriptor + { entityID :: EntityID + , metadataID :: Maybe XS.ID + , metadataValidUntil :: Maybe XS.DateTime + , metadataCacheDuration :: Maybe XS.Duration + , entityAttrs :: Nodes + , metadataSignature :: Maybe DS.Signature + , metadataExtensions :: Extensions + , entityDescriptors :: Descriptors + , entityOrganization :: Maybe Organization + , entityContactPerson :: [Contact] + , entityAditionalMetadataLocation :: [AdditionalMetadataLocation] + } -- ^§2.3.2 + | EntitiesDescriptor + { metadataID :: Maybe XS.ID + , metadataValidUntil :: Maybe XS.DateTime + , metadataCacheDuration :: Maybe XS.Duration + , entitiesName :: Maybe XS.String + , metadataSignature :: Maybe DS.Signature + , metadataExtensions :: Extensions + , entities :: List1 Metadata + } -- ^§2.3.1 + deriving (Eq, Show) + +instance XP.XmlPickler Metadata where + xpickle = [XP.biCase| + Left ((((((((((e, i), vu), cd), xa), sig), ext), desc), org), cp), aml) <-> EntityDescriptor e i vu cd xa sig ext desc org cp aml + Right ((((((i, vu), cd), n), sig), ext), l) <-> EntitiesDescriptor i vu cd n sig ext l|] + XP.>$< (xpElem "EntityDescriptor" + (XP.xpAttr "entityID" xpEntityID + XP.>*< XP.xpAttrImplied "ID" XS.xpID + XP.>*< XP.xpAttrImplied "validUntil" XS.xpDateTime + XP.>*< XP.xpAttrImplied "cacheDuration" XS.xpDuration + XP.>*< XP.xpAnyAttrs + XP.>*< XP.xpickle + XP.>*< XP.xpickle + XP.>*< XP.xpickle + XP.>*< XP.xpickle + XP.>*< XP.xpList XP.xpickle + XP.>*< XP.xpList XP.xpickle) + XP.>|< xpElem "EntitiesDescriptor" + (XP.xpAttrImplied "ID" XS.xpID + XP.>*< XP.xpAttrImplied "validUntil" XS.xpDateTime + XP.>*< XP.xpAttrImplied "cacheDuration" XS.xpDuration + XP.>*< XP.xpAttrImplied "Name" XS.xpString + XP.>*< XP.xpickle + XP.>*< XP.xpickle + XP.>*< xpList1 XP.xpickle)) + +instance DS.Signable Metadata where + signature' = $(fieldLens 'metadataSignature) + signedID = fold . metadataID + +-- |§2.3.1 empty list means missing +newtype Extensions = Extensions{ extensions :: Nodes } + deriving (Eq, Show, Monoid) + +instance XP.XmlPickler Extensions where + xpickle = XP.xpDefault (Extensions []) $ + xpElem "Extensions" $ [XP.biCase| + x <-> Extensions x|] + XP.>$< (XP.xpList1 xpTrimAnyElem) + +data Descriptors + = Descriptors{ descriptors :: List1 Descriptor } + | AffiliationDescriptor + { affiliationDescriptorAffiliationOwnerID :: EntityID + , affiliationDescriptorID :: Maybe XS.ID + , affiliationDescriptorValidUntil :: Maybe XS.DateTime + , affiliationDescriptorCacheDuration :: Maybe XS.Duration + , affiliationDescriptorAttrs :: Nodes + , affiliationDescriptorSignature :: Maybe DS.Signature + , affiliationDescriptorExtensions :: Extensions + , affiliationDescriptorAffiliateMember :: List1 EntityID + , affiliationDescriptorKeyDescriptor :: [KeyDescriptor] + } -- ^§2.5 + deriving (Eq, Show) + +instance XP.XmlPickler Descriptors where + xpickle = [XP.biCase| + Left l <-> Descriptors l + Right ((((((((o, i), vu), cd), a), sig), ext), am), kd) <-> AffiliationDescriptor o i vu cd a sig ext am kd|] + XP.>$< (xpList1 XP.xpickle + XP.>|< xpElem "AffiliationDescriptor" + (XP.xpAttr "affiliationOwnerID" xpEntityID + XP.>*< XP.xpAttrImplied "ID" XS.xpID + XP.>*< XP.xpAttrImplied "validUntil" XS.xpDateTime + XP.>*< XP.xpAttrImplied "cacheDuration" XS.xpDuration + XP.>*< XP.xpAnyAttrs + XP.>*< XP.xpickle + XP.>*< XP.xpickle + XP.>*< xpList1 (xpElem "AffiliateMember" xpEntityID) + XP.>*< XP.xpList XP.xpickle)) + +data Descriptor + = Descriptor + { descriptorRole :: !RoleDescriptor + } -- ^§2.4.1 + | IDPSSODescriptor + { descriptorRole :: !RoleDescriptor + , descriptorSSO :: !SSODescriptor + , descriptorWantAuthnRequestsSigned :: XS.Boolean + , descriptorSingleSignOnService :: List1 Endpoint + , descriptorNameIDMappingService :: [Endpoint] + , descriptorAssertionIDRequestService :: [Endpoint] + , descriptorAttributeProfile :: [XS.AnyURI] + , descriptorAttribute :: [SAML.Attribute] + } -- ^§2.4.3 + | SPSSODescriptor + { descriptorRole :: !RoleDescriptor + , descriptorSSO :: !SSODescriptor + , descriptorAuthnRequestsSigned :: XS.Boolean + , descriptorWantAssertionsSigned :: XS.Boolean + , descriptorAssertionConsumerService :: List1 IndexedEndpoint + , descriptorAttributeConsumingService :: [AttributeConsumingService] + } -- ^§2.4.4 + | AuthnAuthorityDescriptor + { descriptorRole :: !RoleDescriptor + , descriptorAuthnQueryService :: List1 Endpoint + , descriptorAssertionIDRequestService :: [Endpoint] + , descriptorNameIDFormat :: [IdentifiedURI NameIDFormat] + } -- ^§2.4.5 + | AttributeAuthorityDescriptor + { descriptorRole :: !RoleDescriptor + , descriptorAttributeService :: List1 Endpoint + , descriptorAssertionIDRequestService :: [Endpoint] + , descriptorNameIDFormat :: [IdentifiedURI NameIDFormat] + , descriptorAttributeProfile :: [XS.AnyURI] + , descriptorAttribute :: [SAML.Attribute] + } -- ^§2.4.7 + | PDPDescriptor + { descriptorRole :: !RoleDescriptor + , descriptorAuthzService :: List1 Endpoint + , descriptorAssertionIDRequestService :: [Endpoint] + , descriptorNameIDFormat :: [IdentifiedURI NameIDFormat] + } -- ^§2.4.6 + deriving (Eq, Show) + +instance XP.XmlPickler Descriptor where + xpickle = [XP.biCase| + Left (Left (Left (Left (Left 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 "IDPSSODescriptor" + (XP.xpDefault False (XP.xpAttr "WantAuthnRequestsSigned" XS.xpBoolean) + XP.>*< XP.xpickle + XP.>*< XP.xpickle + XP.>*< xpList1 (xpElem "SingleSignOnService" XP.xpickle) + XP.>*< XP.xpList (xpElem "NameIDMappingService" XP.xpickle) + XP.>*< XP.xpList (xpElem "AssertionIDRequestService" XP.xpickle) + XP.>*< XP.xpList (xpElem "AttributeProfile" XS.xpAnyURI) + XP.>*< XP.xpList XP.xpickle) + XP.>|< xpElem "SPSSODescriptor" + (XP.xpDefault False (XP.xpAttr "AuthnRequestsSigned" XS.xpBoolean) + XP.>*< XP.xpDefault False (XP.xpAttr "WantAssertionsSigned" XS.xpBoolean) + XP.>*< XP.xpickle + XP.>*< XP.xpickle + XP.>*< xpList1 (xpElem "AssertionConsumerService" XP.xpickle) + XP.>*< XP.xpList XP.xpickle) + XP.>|< xpElem "AuthnAuthorityDescriptor" + (XP.xpickle + XP.>*< xpList1 (xpElem "AuthnQueryService" XP.xpickle) + XP.>*< XP.xpList (xpElem "AssertionIDRequestService" XP.xpickle) + XP.>*< XP.xpList (xpElem "NameIDFormat" XP.xpickle)) + XP.>|< xpElem "AttributeAuthorityDescriptor" + (XP.xpickle + XP.>*< xpList1 (xpElem "AttributeService" XP.xpickle) + XP.>*< XP.xpList (xpElem "AssertionIDRequestService" XP.xpickle) + XP.>*< XP.xpList (xpElem "NameIDFormat" XP.xpickle) + XP.>*< XP.xpList (xpElem "AttributeProfile" XS.xpAnyURI) + XP.>*< XP.xpList XP.xpickle) + XP.>|< xpElem "PDPDescriptor" + (XP.xpickle + XP.>*< xpList1 (xpElem "AuthzService" XP.xpickle) + XP.>*< XP.xpList (xpElem "AssertionIDRequestService" XP.xpickle) + XP.>*< XP.xpList (xpElem "NameIDFormat" XP.xpickle))) + +-- |§2.3.2.1 +data Organization = Organization + { organizationAttrs :: Nodes + , organizationExtensions :: Extensions + , organizationName :: List1 LocalizedName + , organizationDisplayName :: List1 LocalizedName + , organizationURL :: List1 LocalizedURI + } deriving (Eq, Show) + +instance XP.XmlPickler Organization where + xpickle = xpElem "Organization" $ + [XP.biCase| + ((((a, e), n), d), u) <-> Organization a e n d u|] + XP.>$< (XP.xpAnyAttrs + XP.>*< XP.xpickle + XP.>*< xpList1 (xpElem "OrganizationName" XP.xpickle) + XP.>*< xpList1 (xpElem "OrganizationDisplayName" XP.xpickle) + XP.>*< xpList1 (xpElem "OrganizationURL" XP.xpickle)) + +-- |§2.3.2.2 +data Contact = ContactPerson + { contactType :: ContactType + , contactAttrs :: Nodes + , contactExtensions :: Extensions + , contactCompany :: Maybe XS.String + , contactGivenName :: Maybe XS.String + , contactSurName :: Maybe XS.String + , contactEmailAddress :: [XS.AnyURI] + , contactTelephoneNumber :: [XS.String] + } deriving (Eq, Show) + +instance XP.XmlPickler Contact where + xpickle = xpElem "ContactPerson" $ + [XP.biCase| + (((((((t, a), ext), c), g), s), e), tn) <-> ContactPerson t a ext c g s e tn|] + XP.>$< (XP.xpAttr "contactType" XP.xpickle + XP.>*< XP.xpAnyAttrs + XP.>*< XP.xpickle + XP.>*< XP.xpOption (xpElem "Company" XS.xpString) + XP.>*< XP.xpOption (xpElem "GivenName" XS.xpString) + XP.>*< XP.xpOption (xpElem "SurName" XS.xpString) + XP.>*< XP.xpList (xpElem "EmailAddress" XS.xpAnyURI) + XP.>*< XP.xpList (xpElem "TelephoneNumber" XS.xpString)) + +data ContactType + = ContactTypeTechnical + | ContactTypeSupport + | ContactTypeAdministrative + | ContactTypeBilling + | ContactTypeOther + deriving (Eq, Enum, Bounded, Show) + +instance Identifiable XString ContactType where + identifier ContactTypeTechnical = "technical" + identifier ContactTypeSupport = "support" + identifier ContactTypeAdministrative = "administrative" + identifier ContactTypeBilling = "billing" + identifier ContactTypeOther = "other" +instance XP.XmlPickler ContactType where + xpickle = xpIdentifier (XP.xpTextDT (XPS.scDT (namespaceURIString ns) "ContactTypeType" [])) "ContactTypeType" + +-- |§2.3.2.3 +data AdditionalMetadataLocation = AdditionalMetadataLocation + { additionalMetadataLocationNamespace :: XS.AnyURI + , additionalMetadataLocation :: XS.AnyURI + } deriving (Eq, Show) + +instance XP.XmlPickler AdditionalMetadataLocation where + xpickle = xpElem "AdditionalMetadataLocation" $ + [XP.biCase| + (n, l) <-> AdditionalMetadataLocation n l|] + XP.>$< (XP.xpAttr "namespace" XS.xpAnyURI + XP.>*< XS.xpAnyURI) + +-- |§2.4.1 +data RoleDescriptor = RoleDescriptor + { roleDescriptorID :: Maybe XS.ID + , roleDescriptorValidUntil :: Maybe XS.DateTime + , roleDescriptorCacheDuration :: Maybe XS.Duration + , roleDescriptorProtocolSupportEnumeration :: [XS.AnyURI] + , roleDescriptorErrorURL :: Maybe XS.AnyURI + , roleDescriptorAttrs :: Nodes + , roleDescriptorSignature :: Maybe DS.Signature + , roleDescriptorExtensions :: Extensions + , roleDescriptorKeyDescriptor :: [KeyDescriptor] + , roleDescriptorOrganization :: Maybe Organization + , roleDescriptorContactPerson :: [Contact] + } deriving (Eq, Show) + +instance XP.XmlPickler RoleDescriptor where + xpickle = [XP.biCase| + ((((((((((i, vu), cd), ps), eu), a), sig), ext), key), org), cp) <-> RoleDescriptor i vu cd ps eu a sig ext key org cp|] + XP.>$< (XP.xpAttrImplied "ID" XS.xpID + XP.>*< XP.xpAttrImplied "validUntil" XS.xpDateTime + XP.>*< XP.xpAttrImplied "cacheDuration" XS.xpDuration + XP.>*< XP.xpAttr "protocolSupportEnumeration" xpAnyURIList + XP.>*< XP.xpAttrImplied "errorURL" XS.xpAnyURI + XP.>*< XP.xpAnyAttrs + XP.>*< XP.xpickle + XP.>*< XP.xpickle + XP.>*< XP.xpList XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpList XP.xpickle) + where + xpAnyURIList = XP.xpWrapEither + ( mapM (maybe (Left "invalid anyURI") Right . URI.parseURIReference) . words + , tail . foldr ((.) (' ':) . URI.uriToString id) "" + ) $ XP.xpTextDT $ XPS.scDT (namespaceURIString ns) "anyURIListType" [] + +instance DS.Signable RoleDescriptor where + signature' = $(fieldLens 'roleDescriptorSignature) + signedID = fold . roleDescriptorID + +-- |§2.4.1.1 +data KeyDescriptor = KeyDescriptor + { keyDescriptorUse :: KeyTypes + , keyDescriptorKeyInfo :: DS.KeyInfo + , keyDescriptorEncryptionMethod :: [XEnc.EncryptionMethod] + } deriving (Eq, Show) + +instance XP.XmlPickler KeyDescriptor where + xpickle = xpElem "KeyDescriptor" $ + [XP.biCase| + ((t, i), m) <-> KeyDescriptor t i m|] + XP.>$< (XP.xpDefault KeyTypeBoth (XP.xpAttr "use" XP.xpickle) + XP.>*< XP.xpickle + XP.>*< XP.xpList (xpElem "EncryptionMethod" XEnc.xpEncryptionMethodType)) + +data KeyTypes + = KeyTypeSigning + | KeyTypeEncryption + | KeyTypeBoth + deriving (Eq, Enum, Bounded, Show) + +-- |Does the second KeyTypes include the first type of use? +keyType :: KeyTypes -> KeyTypes -> Bool +keyType _ KeyTypeBoth = True +keyType k t = k == t + +instance Identifiable XString KeyTypes where + identifier KeyTypeSigning = "signing" + identifier KeyTypeEncryption = "encryption" + identifier KeyTypeBoth = "" + identifiedValues = [KeyTypeEncryption, KeyTypeSigning] +instance XP.XmlPickler KeyTypes where + xpickle = xpIdentifier (XP.xpTextDT (XPS.scDT (namespaceURIString ns) "KeyTypes" [])) "KeyTypes" + +-- |§2.4.2 +data SSODescriptor = SSODescriptor + { ssoDescriptorArtifactResolutionService :: [IndexedEndpoint] + , ssoDescriptorSingleLogoutService :: [Endpoint] + , ssoDescriptorManageNameIDService :: [Endpoint] + , ssoDescriptorNameIDFormat :: [IdentifiedURI NameIDFormat] + } deriving (Eq, Show) + +instance XP.XmlPickler SSODescriptor where + xpickle = [XP.biCase| + (((a, s), m), n) <-> SSODescriptor a s m n|] + XP.>$< (XP.xpList (xpElem "ArtifactResolutionService" XP.xpickle) + XP.>*< XP.xpList (xpElem "SingleLogoutService" XP.xpickle) + XP.>*< XP.xpList (xpElem "ManageNameIDService" XP.xpickle) + XP.>*< XP.xpList (xpElem "NameIDFormat" XP.xpickle)) + +-- |§2.4.4.1 +data AttributeConsumingService = AttributeConsumingService + { attributeConsumingServiceIndex :: XS.UnsignedShort + , attributeConsumingServiceIsDefault :: Bool + , attributeConsumingServiceServiceName :: List1 LocalizedName + , attributeConsumingServiceServiceDescription :: [LocalizedName] + , attributeConsumingServiceRequestedAttribute :: List1 RequestedAttribute + } deriving (Eq, Show) + +instance XP.XmlPickler AttributeConsumingService where + xpickle = xpElem "AttributeConsumingService" $ + [XP.biCase| + ((((i, d), sn), sd), ra) <-> AttributeConsumingService i d sn sd ra|] + XP.>$< (XP.xpAttr "index" XS.xpUnsignedShort + XP.>*< XP.xpDefault False (XP.xpAttr "isDefault" XS.xpBoolean) + XP.>*< xpList1 (xpElem "ServiceName" XP.xpickle) + XP.>*< XP.xpList (xpElem "ServiceDescription" XP.xpickle) + XP.>*< xpList1 XP.xpickle) + +-- |§2.4.4.1.1 +data RequestedAttribute = RequestedAttribute + { requestedAttribute :: !SAML.Attribute + , requestedAttributeIsRequired :: Bool + } deriving (Eq, Show) + +instance XP.XmlPickler RequestedAttribute where + xpickle = xpElem "RequestedAttribute" $ + [XP.biCase| + (r, a) <-> RequestedAttribute a r|] + XP.>$< (XP.xpDefault False (XP.xpAttr "isRequired" XS.xpBoolean) + XP.>*< SAML.xpAttributeType) diff --git a/SAML2/Profiles.hs b/SAML2/Profiles.hs new file mode 100644 --- /dev/null +++ b/SAML2/Profiles.hs @@ -0,0 +1,9 @@ +-- | +-- Profiles for the OASIS Security Assertion Markup Language (SAML) V2.0 +-- +-- +module SAML2.Profiles + ( module SAML2.Profiles.ConfirmationMethod + ) where + +import SAML2.Profiles.ConfirmationMethod diff --git a/SAML2/Profiles/ConfirmationMethod.hs b/SAML2/Profiles/ConfirmationMethod.hs new file mode 100644 --- /dev/null +++ b/SAML2/Profiles/ConfirmationMethod.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | +-- Confirmation Method Identifiers +-- +-- §3 +module SAML2.Profiles.ConfirmationMethod where + +import SAML2.XML +import SAML2.Core.Namespaces +import SAML2.Core.Versioning + +-- |§3 +data ConfirmationMethod + = ConfirmationMethodHolderOfKey + | ConfirmationMethodSenderVouches + | ConfirmationMethodBearer + deriving (Eq, Enum, Bounded, Show) + +instance Identifiable URI ConfirmationMethod where + identifier = samlURNIdentifier "cm" . f where + f ConfirmationMethodHolderOfKey = (SAML20, "holder-of-key") + f ConfirmationMethodSenderVouches = (SAML20, "sender-vouches") + f ConfirmationMethodBearer = (SAML20, "bearer") diff --git a/SAML2/XML.hs b/SAML2/XML.hs new file mode 100644 --- /dev/null +++ b/SAML2/XML.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeOperators #-} +module SAML2.XML + ( module SAML2.XML.Types + , module SAML2.Core.Datatypes + , URI + , xpTrimAnyElem + , xpTrimElemNS + , xpXmlLang + , IP, xpIP + , Identified(..) + , Identifiable(..) + , unidentify + , xpIdentified + , xpIdentifier + , IdentifiedURI + , samlToDoc + , samlToXML + , docToSAML + , docToXML + , xmlToSAML + , xmlToDoc + ) where + +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +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 SAML2.XML.Types +import SAML2.Core.Datatypes +import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP +import qualified SAML2.XML.Schema as XS + +xpTrimAnyElem :: XP.PU HXT.XmlTree +xpTrimAnyElem = XP.xpTrim XP.xpAnyElem + +xpTrimElemNS :: Namespace -> String -> XP.PU a -> XP.PU a +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 + +type IP = XS.String + +xpIP :: XP.PU IP +xpIP = XS.xpString + +data Identified b a + = Identified !a + | Unidentified !b + deriving (Eq, Show) + +instance Default a => Default (Identified b a) where + def = Identified def + +class Eq b => Identifiable b a | a -> b where + identifier :: a -> b + identifiedValues :: [a] + default identifiedValues :: (Bounded a, Enum a) => [a] + identifiedValues = [minBound..maxBound] + reidentify :: b -> Identified b a + reidentify u = maybe (Unidentified u) Identified $ lookup u l where + l = [ (identifier a, a) | a <- identifiedValues ] + +unidentify :: Identifiable b a => Identified b a -> b +unidentify (Identified a) = identifier a +unidentify (Unidentified b) = b + +identify :: Identifiable b a => b Inv.<-> Identified b a +identify = reidentify Inv.:<->: unidentify + +xpIdentified :: Identifiable b a => XP.PU b -> XP.PU (Identified b a) +xpIdentified = Inv.fmap identify + +xpIdentifier :: Identifiable b a => XP.PU b -> String -> XP.PU a +xpIdentifier b t = XP.xpWrapEither + ( \u -> case reidentify u of + Identified a -> Right a + Unidentified _ -> Left ("invalid " ++ t) + , identifier + ) b + +type IdentifiedURI = Identified URI + +instance Identifiable URI a => XP.XmlPickler (Identified URI a) where + xpickle = xpIdentified XS.xpAnyURI + +samlToDoc :: XP.XmlPickler a => a -> HXT.XmlTree +samlToDoc = head + . HXT.runLA (HXT.processChildren $ HXT.cleanupNamespaces HXT.collectPrefixUriPairs) + . XP.pickleDoc XP.xpickle + +docToXML :: HXT.XmlTree -> BSL.ByteString +docToXML = BSL.concat . HXT.runLA (HXT.xshowBlob HXT.getChildren) + +samlToXML :: XP.XmlPickler a => a -> BSL.ByteString +samlToXML = docToXML . samlToDoc + +xmlToDoc :: BSL.ByteString -> Maybe HXT.XmlTree +xmlToDoc = listToMaybe . HXT.runLA + (HXT.xreadDoc + HXT.>>> HXT.removeWhiteSpace + HXT.>>> HXT.neg HXT.isXmlPi + HXT.>>> HXT.propagateNamespaces) + . BSLC.unpack -- XXX encoding? + +docToSAML :: XP.XmlPickler a => HXT.XmlTree -> Either String a +docToSAML = XP.unpickleDoc' XP.xpickle + . head + . HXT.runLA (HXT.processBottomUp (HXT.processAttrl (HXT.neg HXT.isNamespaceDeclAttr))) + +xmlToSAML :: XP.XmlPickler a => BSL.ByteString -> Either String a +xmlToSAML = maybe (Left "invalid XML") docToSAML . xmlToDoc diff --git a/SAML2/XML/ASN1.hs b/SAML2/XML/ASN1.hs new file mode 100644 --- /dev/null +++ b/SAML2/XML/ASN1.hs @@ -0,0 +1,30 @@ +module SAML2.XML.ASN1 where + +import Control.Arrow (left) +import Data.ASN1.Types (ASN1, ASN1Object(..)) +import Data.ASN1.BinaryEncoding (BER(BER), DER(DER)) +import Data.ASN1.Encoding (decodeASN1', encodeASN1') +import qualified Data.X509 as X509 + +import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP +import qualified SAML2.XML.Schema as XS + +xpASN1 :: XP.PU [ASN1] +xpASN1 = XP.xpWrapEither + ( left show . decodeASN1' BER + , encodeASN1' DER + ) XS.xpBase64Binary + +xpASN1Object :: ASN1Object a => XP.PU a +xpASN1Object = XP.xpWrapEither + ( either Left check . fromASN1 + , (`toASN1` []) + ) xpASN1 where + check (x, []) = Right x + check _ = Left "trailing ASN1 data" + +xpX509Signed :: (Show a, Eq a, ASN1Object a) => XP.PU (X509.SignedExact a) +xpX509Signed = XP.xpWrapEither + ( X509.decodeSignedObject + , X509.encodeSignedObject + ) XS.xpBase64Binary diff --git a/SAML2/XML/Canonical.hs b/SAML2/XML/Canonical.hs new file mode 100644 --- /dev/null +++ b/SAML2/XML/Canonical.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +-- | +-- XML Canonicalization +-- +-- For §6.5 +module SAML2.XML.Canonical where + +import Control.Monad ((<=<)) +import qualified Data.ByteString as BS +import Data.Tree.Class (getChildren) +import qualified Text.XML.HXT.Core as HXT + +import SAML2.XML +import qualified SAML2.XML.LibXML2 as LibXML2 +import qualified SAML2.XML.Schema as XS +import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP + +-- |§6.5 +data CanonicalizationAlgorithm + = CanonicalXML10 + { canonicalWithComments :: Bool + } -- ^§6.5.1 + | CanonicalXML11 + { canonicalWithComments :: Bool + } -- ^§6.5.2 + | CanonicalXMLExcl10 + { canonicalWithComments :: Bool + } -- ^ + deriving (Eq, Show) + +instance Identifiable URI CanonicalizationAlgorithm where + identifier (CanonicalXML10 False) = httpURI "www.w3.org" "/TR/2001/REC-xml-c14n-20010315" "" "" + identifier (CanonicalXML10 True) = httpURI "www.w3.org" "/TR/2001/REC-xml-c14n-20010315" "" "#WithComments" + identifier (CanonicalXML11 False) = httpURI "www.w3.org" "/2006/12/xml-c14n11" "" "" + identifier (CanonicalXML11 True) = httpURI "www.w3.org" "/2006/12/xml-c14n11" "" "#WithComments" + identifier (CanonicalXMLExcl10 False) = httpURI "www.w3.org" "/2001/10/xml-exc-c14n" "" "#" + identifier (CanonicalXMLExcl10 True) = httpURI "www.w3.org" "/2001/10/xml-exc-c14n" "" "#WithComments" + identifiedValues = + [ CanonicalXML10 False + , CanonicalXML10 True + , CanonicalXML11 False + , CanonicalXML11 True + , CanonicalXMLExcl10 False + , CanonicalXMLExcl10 True + ] + +newtype InclusiveNamespaces = InclusiveNamespaces + { inclusiveNamespacesPrefixList :: XS.NMTOKENS + } deriving (Eq, Show) + +instance XP.XmlPickler InclusiveNamespaces where + xpickle = xpTrimElemNS (mkNamespace "ec" (httpURI "www.w3.org" "/2001/10/xml-exc-c14n" "" "#")) "InclusiveNamespaces" $ + [XP.biCase|n <-> InclusiveNamespaces n|] + XP.>$< XP.xpAttr "PrefixList" XS.xpNMTOKENS + +-- |Canonicalize and serialize an XML document +canonicalize :: CanonicalizationAlgorithm -> Maybe InclusiveNamespaces -> Maybe String -> HXT.XmlTree -> IO BS.ByteString +canonicalize a i s = + LibXML2.c14n (cm a) (inclusiveNamespacesPrefixList <$> i) (canonicalWithComments a) s + <=< LibXML2.fromXmlTrees . getChildren where + cm CanonicalXML10{} = LibXML2.C14N_1_0 + cm CanonicalXML11{} = LibXML2.C14N_1_1 + cm CanonicalXMLExcl10{} = LibXML2.C14N_EXCLUSIVE_1_0 diff --git a/SAML2/XML/Encryption.hs b/SAML2/XML/Encryption.hs new file mode 100644 --- /dev/null +++ b/SAML2/XML/Encryption.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | +-- XML Encryption Syntax and Processing +-- +-- (selected portions) +module SAML2.XML.Encryption where + +import SAML2.XML +import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP +import qualified SAML2.XML.Schema as XS +import qualified SAML2.XML.Signature.Types as DS + +nsFrag :: String -> URI +nsFrag = httpURI "www.w3.org" "/2001/04/xmlenc" "" . ('#':) + +ns :: Namespace +ns = mkNamespace "xenc" $ nsFrag "" + +xpElem :: String -> XP.PU a -> XP.PU a +xpElem = xpTrimElemNS ns + +-- |§3.1 +data EncryptedType = EncryptedType + { encryptedID :: Maybe ID + , encryptedType :: Maybe AnyURI + , encryptedMimeType :: Maybe XString + , encryptedEncoding :: Maybe (IdentifiedURI DS.EncodingAlgorithm) + , encryptedEncryptionMethod :: Maybe EncryptionMethod + , encryptedKeyInfo :: Maybe DS.KeyInfo + , encryptedCipherData :: CipherData + , encryptedEncryptionProperties :: Maybe EncryptionProperties + } deriving (Eq, Show) + +instance XP.XmlPickler EncryptedType where + xpickle = [XP.biCase|(((((((i, t), m), e), c), k), d), p) <-> EncryptedType i t m e c k d p|] + XP.>$< (XP.xpAttrImplied "Id" XS.xpID + XP.>*< XP.xpAttrImplied "Type" XS.xpAnyURI + XP.>*< XP.xpAttrImplied "MimeType" XS.xpString + XP.>*< XP.xpAttrImplied "Encoding" XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpickle + XP.>*< XP.xpOption XP.xpickle) + +-- |§3.2 +data EncryptionMethod = EncryptionMethod + { encryptionAlgorithm :: IdentifiedURI EncryptionAlgorithm + , encryptionKeySize :: Maybe Int + , encryptionOAEPparams :: Maybe XS.Base64Binary + , encryptionDigestMethod :: Maybe DS.DigestMethod + , encryption :: Nodes + } deriving (Eq, Show) + +xpEncryptionMethodType :: XP.PU EncryptionMethod +xpEncryptionMethodType = + [XP.biCase|((((a, s), p), d), x) <-> EncryptionMethod a s p d x|] + XP.>$< (XP.xpAttr "Algorithm" XP.xpickle + XP.>*< XP.xpOption (xpElem "KeySize" XP.xpickle) + XP.>*< XP.xpOption (xpElem "OAEPparams" XS.xpBase64Binary) + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpAnyCont) + +instance XP.XmlPickler EncryptionMethod where + xpickle = xpElem "EncryptionMethod" xpEncryptionMethodType + +-- |§3.3 +data CipherData + = CipherValue XS.Base64Binary + | CipherReference + { cipherURI :: AnyURI + , cipherTransforms :: List1 DS.Transform + } + deriving (Eq, Show) + +instance XP.XmlPickler CipherData where + xpickle = xpElem "CipherData" $ + [XP.biCase| + Left b <-> CipherValue b + Right (u, t) <-> CipherReference u t |] + XP.>$< (xpElem "CipherValue" XS.xpBase64Binary + XP.>|< xpElem "CipherReference" + (XP.xpAttr "URI" XS.xpAnyURI + XP.>*< xpElem "Transforms" (xpList1 XP.xpickle))) + +-- |§3.4 +newtype EncryptedData = EncryptedData{ encryptedData :: EncryptedType } + deriving (Eq, Show) + +instance XP.XmlPickler EncryptedData where + xpickle = xpElem "EncryptedData" $ + [XP.biCase|e <-> EncryptedData e|] + XP.>$< XP.xpickle + +-- |§3.5.1 +data EncryptedKey = EncryptedKey + { encryptedKey :: !EncryptedType + , encryptedKeyRecipient :: Maybe XString + , encryptedKeyReferenceList :: [Reference] -- ^empty for missing + , encryptedKeyCarriedKeyName :: Maybe XString + } deriving (Eq, Show) + +instance XP.XmlPickler EncryptedKey where + xpickle = xpElem "EncryptedKey" $ + [XP.biCase| + (e, ((r, Nothing), n)) <-> EncryptedKey e r [] n + (e, ((r, Just l), n)) <-> EncryptedKey e r l n + |] + XP.>$< (XP.xpickle + XP.>*< (XP.xpAttrImplied "Recipient" XS.xpString + XP.>*< XP.xpOption (xpElem "ReferenceList" $ XP.xpList1 XP.xpickle) + XP.>*< XP.xpOption (xpElem "CarriedKeyName" XS.xpString))) + +-- |§3.6 +data Reference + = DataReference + { referenceURI :: URI + , reference :: Nodes + } + | KeyReference + { referenceURI :: URI + , reference :: Nodes + } + deriving (Eq, Show) + +instance XP.XmlPickler Reference where + xpickle = [XP.biCase| + Left (u, r) <-> DataReference u r + Right (u, r) <-> KeyReference u r |] + XP.>$< (refs "DataReference" XP.>|< refs "KeyReference") + where + refs n = xpElem n + $ XP.xpAttr "URI" XS.xpAnyURI + XP.>*< XP.xpList xpTrimAnyElem + +-- |§3.7 +data EncryptionProperties = EncryptionProperties + { encryptionPropertiesId :: Maybe ID + , encryptionProperties :: List1 EncryptionProperty + } deriving (Eq, Show) + +instance XP.XmlPickler EncryptionProperties where + xpickle = xpElem "EncryptionProperties" $ + [XP.biCase|(i, l) <-> EncryptionProperties i l|] + XP.>$< (XP.xpAttrImplied "Id" XS.xpID + XP.>*< xpList1 XP.xpickle) + +data EncryptionProperty = EncryptionProperty + { encryptionPropertyId :: Maybe ID + , encryptionPropertyTarget :: Maybe AnyURI + , encryptionProperty :: Nodes + } deriving (Eq, Show) + +instance XP.XmlPickler EncryptionProperty where + xpickle = xpElem "EncryptionProperty" $ + [XP.biCase|((i, t), x) <-> EncryptionProperty i t x|] + XP.>$< (XP.xpAttrImplied "Id" XS.xpID + XP.>*< XP.xpAttrImplied "Target" XS.xpAnyURI + XP.>*< XP.xpAny) + +-- |§5.1 +data EncryptionAlgorithm + = BlockEncryptionTripleDES -- ^§5.2.2 + | BlockEncryptionAES128 -- ^§5.2.3 + | BlockEncryptionAES192 -- ^§5.2.3 + | BlockEncryptionAES256 -- ^§5.2.3 + | BlockEncryptionAES128GCM -- ^§5.2.4 + | BlockEncryptionAES192GCM -- ^§5.2.4 + | BlockEncryptionAES256GCM -- ^§5.2.4 + | KeyTransportRSA1_5 -- ^§5.5.1 + | KeyTransportRSAOAEPMGF1P -- ^§5.5.2 + | KeyTransportRSAOAEP -- ^§5.5.2 + deriving (Eq, Bounded, Enum, Show) + +instance Identifiable URI EncryptionAlgorithm where + identifier BlockEncryptionTripleDES = nsFrag "tripledes-cbc" + identifier BlockEncryptionAES128 = nsFrag "aes128-cbc" + identifier BlockEncryptionAES256 = nsFrag "aes256-cbc" + identifier BlockEncryptionAES192 = nsFrag "aes192-cbc" + identifier BlockEncryptionAES128GCM = httpURI "www.w3.org" "/2009/xmlenc11" "" "#aes128-gcm" + identifier BlockEncryptionAES192GCM = httpURI "www.w3.org" "/2009/xmlenc11" "" "#aes192-gcm" + identifier BlockEncryptionAES256GCM = httpURI "www.w3.org" "/2009/xmlenc11" "" "#aes256-gcm" + identifier KeyTransportRSA1_5 = nsFrag "rsa-1_5" + identifier KeyTransportRSAOAEPMGF1P = nsFrag "rsa-oaep-mgf1p" + identifier KeyTransportRSAOAEP = httpURI "www.w3.org" "/2009/xmlenc11" "" "#rsa-oaep" + +-- |§5.5 +data AgreementMethod = AgreementMethod + { agreementMethodAlgorithm :: IdentifiedURI EncryptionAlgorithm + , agreementMethodKA_Nonce :: Maybe XS.Base64Binary + , agreementMethodDigestMethod :: Maybe DS.DigestMethod + -- Nodes... + , agreementMethodOriginatorKeyInfo :: Maybe DS.KeyInfo + , agreementMethodRecipientKeyInfo :: Maybe DS.KeyInfo + } + +instance XP.XmlPickler AgreementMethod where + xpickle = xpElem "AgreementMethod" $ + [XP.biCase|((((a, n), d), o), r) <-> AgreementMethod a n d o r|] + XP.>$< (XP.xpAttr "Algorithm" XP.xpickle + XP.>*< XP.xpOption (xpElem "KA-Nonce" XS.xpBase64Binary) + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpOption (xpElem "OriginatorKeyInfo" DS.xpKeyInfoType) + XP.>*< XP.xpOption (xpElem "RecipientKeyInfo" DS.xpKeyInfoType)) diff --git a/SAML2/XML/LibXML2.hsc b/SAML2/XML/LibXML2.hsc new file mode 100644 --- /dev/null +++ b/SAML2/XML/LibXML2.hsc @@ -0,0 +1,115 @@ +module SAML2.XML.LibXML2 + ( Doc + , fromXmlTrees + , C14NMode(..) + , c14n + ) where + +import Control.Exception (bracket) +import Control.Monad ((<=<)) +import Data.Bits ((.|.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Unsafe as BSU +import Data.Maybe (fromMaybe) +import Data.String.Unicode (unicodeCharToUtf8') +import Data.Word (Word8) +import Foreign.C.Error (throwErrnoIf, throwErrnoIfNull) +import Foreign.C.String (CString, withCString) +import Foreign.C.Types (CInt(..)) +import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) +import Foreign.Marshal (alloca, withArray0, withMany, maybeWith) +import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr) +import Foreign.Storable (peek, peekByteOff) +import qualified Text.XML.HXT.Core as HXT +import qualified Text.XML.HXT.DOM.ShowXml as HXTS + +#include +#include +#include + +type XMLChar = #type xmlChar +data XMLDoc +data XMLXPathContext +data XMLXPathObject +data XMLNodeSet + +foreign import ccall unsafe "libxml/parser.h xmlReadMemory" + xmlReadMemory :: CString -> CInt -> CString -> CString -> CInt -> IO (Ptr XMLDoc) + +foreign import ccall unsafe "libxml/tree.h &xmlFreeDoc" + xmlFreeDoc :: FunPtr ((Ptr XMLDoc) -> IO ()) + +foreign import ccall unsafe "libxml/xpath.h xmlXPathNewContext" + xmlXPathNewContext :: Ptr XMLDoc -> IO (Ptr XMLXPathContext) + +foreign import ccall unsafe "libxml/xpath.h xmlXPathFreeContext" + xmlXPathFreeContext :: Ptr XMLXPathContext -> IO () + +foreign import ccall unsafe "libxml/xpath.h xmlXPathEval" + xmlXPathEval :: Ptr XMLChar -> Ptr XMLXPathContext -> IO (Ptr XMLXPathObject) + +foreign import ccall unsafe "libxml/xpath.h xmlXPathFreeObject" + xmlXPathFreeObject :: Ptr XMLXPathObject -> IO () + +foreign import ccall unsafe "libxml/c14n.h xmlC14NDocDumpMemory" + xmlC14NDocDumpMemory :: Ptr XMLDoc -> Ptr XMLNodeSet -> CInt -> Ptr (Ptr XMLChar) -> CInt -> Ptr (Ptr XMLChar) -> IO CInt + +foreign import ccall unsafe "xmlFree_stub" + xmlFree :: Ptr a -> IO () + +newtype Doc = Doc{ unDoc :: ForeignPtr XMLDoc } + +newDoc :: Ptr XMLDoc -> IO Doc +newDoc = fmap Doc . newForeignPtr xmlFreeDoc + +fromBytes :: BS.ByteString -> IO Doc +fromBytes s = do + d <- BSU.unsafeUseAsCStringLen s $ \(p, l) -> + throwErrnoIfNull "xmlReadMemory" $ + xmlReadMemory p (fromIntegral l) nullPtr nullPtr (#{const XML_PARSE_NOENT} .|. #{const XML_PARSE_DTDLOAD} .|. #{const XML_PARSE_DTDATTR} .|. #{const XML_PARSE_NONET} .|. #{const XML_PARSE_COMPACT}) + newDoc d + +fromXmlTrees :: HXT.XmlTrees -> IO Doc +fromXmlTrees = fromBytes . BSL.toStrict . HXTS.xshow' cq aq unicodeCharToUtf8' + where + cq '&' = ("&" ++) + cq '<' = ("<" ++) + cq '>' = (">" ++) + cq '\13' = (" " ++) + cq c = (c:) + aq '"' = (""" ++) + aq '\9' = (" " ++) + aq '\10' = (" " ++) + aq c = cq c + +withXMLXPathNodeList :: Ptr XMLDoc -> String -> (Ptr XMLNodeSet -> IO a) -> IO a +withXMLXPathNodeList d s f = + bracket (xmlXPathNewContext d) xmlXPathFreeContext $ \c -> + withCString s $ \p -> + bracket + (throwErrnoIfNull "xmlXPathEval" $ xmlXPathEval ((castPtr :: CString -> Ptr Word8) p) c) + xmlXPathFreeObject + $ f <=< #peek xmlXPathObject, nodesetval + +data C14NMode + = C14N_1_0 + | C14N_EXCLUSIVE_1_0 + | C14N_1_1 + +c14nmode :: C14NMode -> CInt +c14nmode C14N_1_0 = #{const XML_C14N_1_0} +c14nmode C14N_EXCLUSIVE_1_0 = #{const XML_C14N_EXCLUSIVE_1_0} +c14nmode C14N_1_1 = #{const XML_C14N_1_1} + +c14n :: C14NMode -> Maybe [String] -> Bool -> Maybe String -> Doc -> IO BS.ByteString +c14n m i c s d = + withForeignPtr (unDoc d) $ \dp -> + withMany withCString (fromMaybe [] i) $ \il -> + maybeWith (withArray0 nullPtr) (il <$ i) $ \ip -> + maybeWith (withXMLXPathNodeList dp) s $ \sn -> + alloca $ \p -> do + r <- throwErrnoIf (< 0) "xmlC14NDocDumpMemory" $ + xmlC14NDocDumpMemory dp sn (c14nmode m) ((castPtr :: Ptr CString -> Ptr (Ptr Word8)) ip) (fromIntegral $ fromEnum c) p + pp <- peek p + BSU.unsafePackCStringFinalizer pp (fromIntegral r) (xmlFree pp) diff --git a/SAML2/XML/Schema.hs b/SAML2/XML/Schema.hs new file mode 100644 --- /dev/null +++ b/SAML2/XML/Schema.hs @@ -0,0 +1,10 @@ +module SAML2.XML.Schema + ( ns + , module SAML2.XML.Schema.Datatypes + ) where + +import SAML2.XML.Types +import SAML2.XML.Schema.Datatypes + +ns :: Namespace +ns = mkNamespace "xs" $ httpURI "www.w3.org" "/2001/XMLSchema" "" "" diff --git a/SAML2/XML/Schema/Datatypes.hs b/SAML2/XML/Schema/Datatypes.hs new file mode 100644 --- /dev/null +++ b/SAML2/XML/Schema/Datatypes.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- XML Schema Datatypes +-- +-- (selected portions) +module SAML2.XML.Schema.Datatypes where + +import Prelude hiding (String) + +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Base64 as B64 +import Data.Char (isDigit) +import Data.Char.Properties.XMLCharProps (isXmlSpaceChar, isXmlNameChar) +import Data.Fixed (Pico, showFixed) +import qualified Data.Time.Clock as Time +import Data.Time.Format (formatTime, parseTimeM, defaultTimeLocale) +import Data.Word (Word16) +import qualified Network.URI as URI +import qualified Text.XML.HXT.Arrow.Pickle.Schema as XPS +import Text.XML.HXT.DOM.QualifiedName (isNCName) +import qualified Text.XML.HXT.DOM.XmlNode as XN +import qualified Text.XML.HXT.XMLSchema.DataTypeLibW3CNames as XSD + +import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP + +-- |§3.2.1 +type String = [Char] + +xpString :: XP.PU String +xpString = XP.xpTextDT (XPS.scDTxsd XSD.xsd_string []) + +-- |§3.2.1 +type Boolean = Bool + +xpBoolean :: XP.PU Boolean +xpBoolean = XP.xpWrapEither + ( \s -> case s of + "true" -> Right True + "false" -> Right False + "1" -> Right True + "0" -> Right False + _ -> Left "invalid boolean" + , \b -> if b then "true" else "false" + ) $ XP.xpTextDT $ XPS.scDTxsd XSD.xsd_boolean [] + +-- |§3.2.6 specifies a complete ISO8601 6-component duration; for SAML2 purposes we don't overly care +type Duration = Time.NominalDiffTime + +xpDuration :: XP.PU Duration +xpDuration = XP.xpWrapEither + ( maybe (Left "invalid duration") (Right . realToFrac) . prd + , \t -> (if signum t < 0 then ('-':) else id) + $ 'P':'T': showFixed True (abs $ realToFrac t :: Pico) ++ "S" + ) $ XP.xpTextDT $ XPS.scDTxsd XSD.xsd_duration [] where + prd ('-':s) = negate <$> prp s + prd ('+':s) = prp s + prd s = prp s + prp ('P':s) = pru (0 :: Pico) prt [('Y',31556952),('M',2629746),('D',86400)] s + prp _ = Nothing + prt x "" = Just x + prt x ('T':s) = pru x prs [('H',3600),('M',60)] s + prt _ _ = Nothing + prs x "" = Just x + prs x s = case span isDigit s of + (d@(_:_),'.':(span isDigit -> (p,"S"))) -> Just $ x + read (d ++ '.' : p) + (d@(_:_),"S") -> Just $ x + read d + _ -> Nothing + pru x c ul s = case span isDigit s of + (d@(_:_),uc:sr) | (_,uv):ur <- dropWhile ((uc /=) . fst) ul -> pru (x + uv * read d) c ur sr + _ -> c x s + +-- |§3.2.7 theoretically allows timezones, but SAML2 does not use them +type DateTime = Time.UTCTime + +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 + } + where + fmt = "%0Y-%m-%dT%H:%M:%S%Q" + fmtz = fmt ++ "%Z" + +-- |§3.2.16 +type Base64Binary = BS.ByteString + +xpBase64Binary :: XP.PU Base64Binary +xpBase64Binary = XP.xpWrapEither + ( B64.decode . BS.pack . filter (not . isXmlSpaceChar) + , BS.unpack . B64.encode + ) $ XP.xpText0DT $ XPS.scDTxsd XSD.xsd_base64Binary [] + +-- |§3.2.17 +type AnyURI = URI.URI + +xpAnyURI :: XP.PU AnyURI +xpAnyURI = XP.xpWrapEither + ( maybe (Left "invalid anyURI") Right . URI.parseURIReference + , \u -> URI.uriToString id u "") + $ XP.xpText0DT $ XPS.scDTxsd XSD.xsd_anyURI [] + +-- |§3.3.1 +type NormalizedString = String +-- |§3.3.2 +type Token = NormalizedString +-- |§3.3.3 +type Language = Token + +xpLanguage :: XP.PU Language +xpLanguage = XP.xpTextDT $ XPS.scDTxsd XSD.xsd_language [] + +-- |§3.3.4 +type NMTOKEN = Token + +isNMTOKEN :: Token -> Bool +isNMTOKEN [] = False +isNMTOKEN s = all isXmlNameChar s + +xpNMTOKEN :: XP.PU NMTOKEN +xpNMTOKEN = XP.xpWrapEither + ( \x -> if isNMTOKEN x then Right x else Left "NMTOKEN expected" + , id + ) $ XP.xpTextDT $ XPS.scDTxsd XSD.xsd_NMTOKEN [] + +-- |§3.3.5 +type NMTOKENS = [NMTOKEN] + +xpNMTOKENS :: XP.PU NMTOKENS +xpNMTOKENS = XP.xpWrapEither + ( \x -> case words x of + [] -> Left "NMTOKENS expected" + l | all isNMTOKEN l -> Right l + _ -> Left "NMTOKENS expected" + , unwords + ) $ XP.xpTextDT $ XPS.scDTxsd XSD.xsd_NMTOKENS [] + +-- |§3.3.8 +type ID = String +type NCName = String + +xpNCName :: XP.PU NCName +xpNCName = XP.xpWrapEither + ( \x -> if isNCName x then Right x else Left "NCName expected" + , id + ) $ XP.xpTextDT $ XPS.scDTxsd XSD.xsd_NCName [] + +xpID :: XP.PU ID +xpID = xpNCName{ XP.theSchema = XPS.scDTxsd XSD.xsd_ID [] } + +-- |§3.3.13 +xpInteger :: XP.PU Integer +xpInteger = XP.xpPrim{ XP.theSchema = XPS.scDTxsd XSD.xsd_integer [] } + +-- |§3.3.20 +type NonNegativeInteger = Word + +xpNonNegativeInteger :: XP.PU NonNegativeInteger +xpNonNegativeInteger = XP.xpPrim{ XP.theSchema = XPS.scDTxsd XSD.xsd_nonNegativeInteger [] } + +-- |§3.3.23 +type UnsignedShort = Word16 + +xpUnsignedShort :: XP.PU UnsignedShort +xpUnsignedShort = XP.xpPrim{ XP.theSchema = XPS.scDTxsd XSD.xsd_unsignedShort [] } + +-- |§3.3.20 +type PositiveInteger = NonNegativeInteger + +xpPositiveInteger :: XP.PU PositiveInteger +xpPositiveInteger = XP.xpWrapEither + ( \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 new file mode 100644 --- /dev/null +++ b/SAML2/XML/Signature.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE ViewPatterns #-} +-- | +-- XML Signature Syntax and Processing +-- +-- (selected portions) +module SAML2.XML.Signature + ( module SAML2.XML.Signature.Types + , generateReference + , SigningKey(..) + , PublicKeys(..) + , signingKeySignatureAlgorithm + , signBase64 + , verifyBase64 + , generateSignature + , verifySignature + ) where + +import Control.Applicative ((<|>)) +import Control.Monad (guard, (<=<)) +import Crypto.Number.Basic (numBytes) +import Crypto.Number.Serialize (i2ospOf_, os2ip) +import Crypto.Hash (hashlazy, SHA1(..), SHA256(..), SHA512(..), RIPEMD160(..)) +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.RSA.Types as RSA +import qualified Crypto.PubKey.RSA.PKCS15 as RSA +import qualified Data.ByteArray as BA +import qualified Data.ByteString as BS +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 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 SAML2.XML +import SAML2.XML.Canonical +import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP +import SAML2.XML.Signature.Types + +isDSElem :: HXT.ArrowXml a => String -> a HXT.XmlTree HXT.XmlTree +isDSElem n = HXT.isElem HXT.>>> HXT.hasQName (mkNName ns n) + +getID :: HXT.ArrowXml a => String -> a HXT.XmlTree HXT.XmlTree +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 + +applyTransformsBytes :: [Transform] -> BSL.ByteString -> IO BSL.ByteString +applyTransformsBytes [] = return +applyTransformsBytes (t : _) = fail ("applyTransforms: unsupported Signature " ++ show t) + +applyTransformsXML :: [Transform] -> HXT.XmlTree -> IO BSL.ByteString +applyTransformsXML (Transform (Identified (TransformCanonicalization a)) ins x : tl) = + applyTransformsBytes tl . BSL.fromStrict + <=< applyCanonicalization (CanonicalizationMethod (Identified a) ins (map (XP.pickleDoc XP.xpickle) x)) Nothing +applyTransformsXML (Transform (Identified TransformEnvelopedSignature) Nothing [] : tl) = + -- XXX assumes "this" signature in top-level + applyTransformsXML tl + . head . HXT.runLA (HXT.processChildren $ HXT.processChildren + $ HXT.neg (isDSElem "Signature")) +applyTransformsXML tl = applyTransformsBytes tl . DOM.xshowBlob . return + +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 d = error $ "unsupported " ++ show d + +generateReference :: Reference -> HXT.XmlTree -> IO Reference +generateReference r x = do + t <- applyTransforms (referenceTransforms r) x + let d = applyDigest (referenceDigestMethod r) t + return r + { referenceDigestValue = d } + +verifyReference :: Reference -> HXT.XmlTree -> IO (Maybe 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 + +data SigningKey + = SigningKeyDSA DSA.KeyPair + | SigningKeyRSA RSA.KeyPair + deriving (Eq, Show) + +data PublicKeys = PublicKeys + { publicKeyDSA :: Maybe DSA.PublicKey + , publicKeyRSA :: Maybe RSA.PublicKey + } deriving (Eq, Show) + +instance Monoid PublicKeys where + mempty = PublicKeys Nothing Nothing + PublicKeys dsa1 rsa1 `mappend` PublicKeys dsa2 rsa2 = + PublicKeys (dsa1 <|> dsa2) (rsa1 <|> rsa2) + +signingKeySignatureAlgorithm :: SigningKey -> SignatureAlgorithm +signingKeySignatureAlgorithm (SigningKeyDSA _) = SignatureDSA_SHA1 +signingKeySignatureAlgorithm (SigningKeyRSA _) = SignatureRSA_SHA1 + +signingKeyValue :: SigningKey -> KeyValue +signingKeyValue (SigningKeyDSA (DSA.toPublicKey -> DSA.PublicKey p y)) = DSAKeyValue + { dsaKeyValuePQ = Just (DSA.params_p p, DSA.params_q p) + , dsaKeyValueG = Just (DSA.params_g p) + , dsaKeyValueY = y + , dsaKeyValueJ = Nothing + , dsaKeyValueSeedPgenCounter = Nothing + } +signingKeyValue (SigningKeyRSA (RSA.toPublicKey -> RSA.PublicKey _ n e)) = RSAKeyValue + { rsaKeyValueModulus = n + , 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 + return $ i2ospOf_ 20 (DSA.sign_r s) <> i2ospOf_ 20 (DSA.sign_s s) +signBytes (SigningKeyRSA k) b = + either (fail . show) return =<< RSA.signSafer (Just SHA1) (RSA.toPrivateKey k) b + +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 && + DSA.verify SHA1 k DSA.Signature{ DSA.sign_r = os2ip r, DSA.sign_s = os2ip s } m + 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 _ _ _ _ = Nothing + +signBase64 :: SigningKey -> BS.ByteString -> IO BS.ByteString +signBase64 sk = fmap Base64.encode . signBytes sk + +verifyBase64 :: PublicKeys -> IdentifiedURI SignatureAlgorithm -> BS.ByteString -> BS.ByteString -> Maybe Bool +verifyBase64 pk alg m = either (const $ Just False) (verifyBytes pk alg m) . Base64.decode where + +generateSignature :: SigningKey -> SignedInfo -> IO Signature +generateSignature sk si = do + -- XXX: samlToDoc may not match later + six <- applyCanonicalization (signedInfoCanonicalizationMethod si) Nothing $ samlToDoc si + sv <- signBytes sk six + return Signature + { signatureId = Nothing + , signatureSignedInfo = si + , signatureSignatureValue = SignatureValue Nothing sv + , signatureKeyInfo = Just $ KeyInfo Nothing $ KeyInfoKeyValue (signingKeyValue sk) NonEmpty.:| [] + , signatureObject = [] + } + +verifySignature :: PublicKeys -> String -> HXT.XmlTree -> IO (Maybe Bool) +verifySignature pks xid doc = do + x <- case HXT.runLA (getID xid) doc of + [x] -> return x + _ -> fail "verifySignature: element not found" + sx <- case child "Signature" x of + [sx] -> return sx + _ -> fail "verifySignature: Signature not found" + s@Signature{ signatureSignedInfo = si } <- either fail return $ docToSAML sx + 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 + 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::*" diff --git a/SAML2/XML/Signature/Types.hs b/SAML2/XML/Signature/Types.hs new file mode 100644 --- /dev/null +++ b/SAML2/XML/Signature/Types.hs @@ -0,0 +1,613 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | +-- XML Signature Syntax and Processing +-- +-- (selected portions) +module SAML2.XML.Signature.Types where + +import Control.Lens (Lens') +import Crypto.Number.Serialize (i2osp, os2ip) +import qualified Data.X509 as X509 + +import SAML2.XML +import qualified SAML2.XML.Schema as XS +import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP +import qualified SAML2.XML.Canonical as C14N +import SAML2.XML.ASN1 + +nsFrag :: String -> URI +nsFrag = httpURI "www.w3.org" "/2000/09/xmldsig" "" . ('#':) + +nsFrag11 :: String -> URI +nsFrag11 = httpURI "www.w3.org" "/2009/xmldsig11" "" . ('#':) + +ns :: Namespace +ns = mkNamespace "ds" $ nsFrag "" + +ns11 :: Namespace +ns11 = mkNamespace "dsig11" $ nsFrag11 "" + +xpElem :: String -> XP.PU a -> XP.PU a +xpElem = xpTrimElemNS ns + +xpElem11 :: String -> XP.PU a -> XP.PU a +xpElem11 = xpTrimElemNS ns11 + +-- |§4.1 +type CryptoBinary = Integer -- as Base64Binary + +xpCryptoBinary :: XP.PU CryptoBinary +xpCryptoBinary = XP.xpWrap (os2ip, i2osp) XS.xpBase64Binary + +-- |§4.2 +data Signature = Signature + { signatureId :: Maybe ID + , signatureSignedInfo :: SignedInfo + , signatureSignatureValue :: SignatureValue + , signatureKeyInfo :: Maybe KeyInfo + , signatureObject :: [Object] + } deriving (Eq, Show) + +instance XP.XmlPickler Signature where + xpickle = xpElem "Signature" $ + [XP.biCase|((((i, s), v), k), o) <-> Signature i s v k o|] + XP.>$< (XP.xpAttrImplied "Id" XS.xpID + XP.>*< XP.xpickle + XP.>*< XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpList XP.xpickle) + +class Signable a where + signature' :: Lens' a (Maybe Signature) + signedID :: a -> XS.ID + +-- |§4.3 +data SignatureValue = SignatureValue + { signatureValueId :: Maybe ID + , signatureValue :: XS.Base64Binary + } deriving (Eq, Show) + +instance XP.XmlPickler SignatureValue where + xpickle = xpElem "SignatureValue" $ + [XP.biCase|(i, v) <-> SignatureValue i v|] + XP.>$< (XP.xpAttrImplied "Id" XS.xpID + XP.>*< XS.xpBase64Binary) + +-- |§4.4 +data SignedInfo = SignedInfo + { signedInfoId :: Maybe ID + , signedInfoCanonicalizationMethod :: CanonicalizationMethod + , signedInfoSignatureMethod :: SignatureMethod + , signedInfoReference :: List1 Reference + } deriving (Eq, Show) + +instance XP.XmlPickler SignedInfo where + xpickle = xpElem "SignedInfo" $ + [XP.biCase|(((i, c), s), r) <-> SignedInfo i c s r|] + XP.>$< (XP.xpAttrImplied "Id" XS.xpID + XP.>*< XP.xpickle + XP.>*< XP.xpickle + XP.>*< xpList1 XP.xpickle) + +-- |§4.4.1 +data CanonicalizationMethod = CanonicalizationMethod + { canonicalizationMethodAlgorithm :: IdentifiedURI C14N.CanonicalizationAlgorithm + , canonicalizationMethodInclusiveNamespaces :: Maybe C14N.InclusiveNamespaces + , canonicalizationMethod :: Nodes + } deriving (Eq, Show) + +instance XP.XmlPickler CanonicalizationMethod where + xpickle = xpElem "CanonicalizationMethod" $ + [XP.biCase|((a, n), x) <-> CanonicalizationMethod a n x|] + XP.>$< (XP.xpAttr "Algorithm" XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpAnyCont) + +simpleCanonicalization :: C14N.CanonicalizationAlgorithm -> CanonicalizationMethod +simpleCanonicalization a = CanonicalizationMethod (Identified a) Nothing [] + +-- |§4.4.2 +data SignatureMethod = SignatureMethod + { signatureMethodAlgorithm :: IdentifiedURI SignatureAlgorithm + , signatureMethodHMACOutputLength :: Maybe Int + , signatureMethod :: Nodes + } deriving (Eq, Show) + +instance XP.XmlPickler SignatureMethod where + xpickle = xpElem "SignatureMethod" $ + [XP.biCase|((a, l), x) <-> SignatureMethod a l x|] + XP.>$< (XP.xpAttr "Algorithm" XP.xpickle + XP.>*< XP.xpOption (xpElem "HMACOutputLength" XP.xpickle) + XP.>*< XP.xpAnyCont) + +-- |§4.4.3 +data Reference = Reference + { referenceId :: Maybe ID + , referenceURI :: Maybe AnyURI + , referenceType :: Maybe AnyURI -- xml object type + , referenceTransforms :: Maybe Transforms + , referenceDigestMethod :: DigestMethod + , referenceDigestValue :: XS.Base64Binary -- ^§4.3.3.6 + } deriving (Eq, Show) + +instance XP.XmlPickler Reference where + xpickle = xpElem "Reference" $ + [XP.biCase|(((((i, u), t), f), m), v) <-> Reference i u t f m v|] + XP.>$< (XP.xpAttrImplied "Id" XS.xpID + XP.>*< XP.xpAttrImplied "URI" XS.xpAnyURI + XP.>*< XP.xpAttrImplied "Type" XS.xpAnyURI + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpickle + XP.>*< xpElem "DigestValue" XS.xpBase64Binary) + +-- |§4.4.3.4 +newtype Transforms = Transforms{ transforms :: List1 Transform } + deriving (Eq, Show) + +instance XP.XmlPickler Transforms where + xpickle = xpElem "Transforms" $ + [XP.biCase|l <-> Transforms l|] + XP.>$< xpList1 XP.xpickle + +data Transform = Transform + { transformAlgorithm :: IdentifiedURI TransformAlgorithm + , transformInclusiveNamespaces :: Maybe C14N.InclusiveNamespaces + , transform :: [TransformElement] + } deriving (Eq, Show) + +instance XP.XmlPickler Transform where + xpickle = xpElem "Transform" $ + [XP.biCase|((a, n), l) <-> Transform a n l|] + XP.>$< (XP.xpAttr "Algorithm" XP.xpickle + XP.>*< XP.xpOption XP.xpickle + XP.>*< XP.xpList XP.xpickle) + +simpleTransform :: TransformAlgorithm -> Transform +simpleTransform a = Transform (Identified a) Nothing [] + +data TransformElement + = TransformElementXPath XString + | TransformElement Node + deriving (Eq, Show) + +instance XP.XmlPickler TransformElement where + xpickle = [XP.biCase| + Left s <-> TransformElementXPath s + Right x <-> TransformElement x |] + XP.>$< (xpElem "XPath" XS.xpString + XP.>|< xpTrimAnyElem) + +-- |§4.4.3.5 +data DigestMethod = DigestMethod + { digestAlgorithm :: IdentifiedURI DigestAlgorithm + , digest :: [Node] + } deriving (Eq, Show) + +instance XP.XmlPickler DigestMethod where + xpickle = xpElem "DigestMethod" $ + [XP.biCase|(a, d) <-> DigestMethod a d|] + XP.>$< (XP.xpAttr "Algorithm" XP.xpickle + XP.>*< XP.xpAnyCont) + +simpleDigest :: DigestAlgorithm -> DigestMethod +simpleDigest a = DigestMethod (Identified a) [] + +-- |§4.5 +data KeyInfo = KeyInfo + { keyInfoId :: Maybe ID + , keyInfoElements :: List1 KeyInfoElement + } deriving (Eq, Show) + +xpKeyInfoType :: XP.PU KeyInfo +xpKeyInfoType = [XP.biCase|(i, l) <-> KeyInfo i l|] + XP.>$< (XP.xpAttrImplied "Id" XS.xpID + XP.>*< xpList1 XP.xpickle) + +instance XP.XmlPickler KeyInfo where + xpickle = xpElem "KeyInfo" xpKeyInfoType + +data KeyInfoElement + = KeyName XString -- ^§4.5.1 + | KeyInfoKeyValue KeyValue -- ^§4.5.2 + | RetrievalMethod + { retrievalMethodURI :: URI + , retrievalMethodType :: Maybe URI + , retrievalMethodTransforms :: Maybe Transforms + } -- ^§4.5.3 + | X509Data + { x509Data :: List1 X509Element + } -- ^§4.5.4 + | PGPData + { pgpKeyID :: Maybe XS.Base64Binary + , pgpKeyPacket :: Maybe XS.Base64Binary + , pgpData :: Nodes + } -- ^§4.5.5 + | SPKIData + { spkiData :: List1 SPKIElement + } -- ^§4.5.6 + | MgmtData XString -- ^§4.5.7 + | KeyInfoElement Node + deriving (Eq, Show) + +instance XP.XmlPickler KeyInfoElement where + xpickle = [XP.biCase| + Left (Left (Left (Left (Left (Left (Left n)))))) <-> KeyName n + Left (Left (Left (Left (Left (Left (Right v)))))) <-> KeyInfoKeyValue v + Left (Left (Left (Left (Left (Right ((u, t), f)))))) <-> RetrievalMethod u t f + Left (Left (Left (Left (Right l)))) <-> X509Data l + Left (Left (Left (Right ((i, p), x)))) <-> PGPData i p x + Left (Left (Right l)) <-> SPKIData l + Left (Right m) <-> MgmtData m + Right x <-> KeyInfoElement x|] + XP.>$< (xpElem "KeyName" XS.xpString + XP.>|< XP.xpickle + XP.>|< xpElem "RetrievalMethod" + (XP.xpAttr "URI" XS.xpAnyURI + XP.>*< XP.xpAttrImplied "Type" XS.xpAnyURI + XP.>*< XP.xpOption XP.xpickle) + XP.>|< xpElem "X509Data" (xpList1 XP.xpickle) + XP.>|< xpElem "PGPData" + (XP.xpOption (xpElem "PGPKeyID" XS.xpBase64Binary) + XP.>*< XP.xpOption (xpElem "PGPKeyPacket" XS.xpBase64Binary) + XP.>*< XP.xpList xpTrimAnyElem) + XP.>|< xpElem "SPKIData" (xpList1 XP.xpickle) + XP.>|< xpElem "MgmtData" XS.xpString + XP.>|< XP.xpTree) + +-- |§4.5.2 +data KeyValue + = DSAKeyValue + { dsaKeyValuePQ :: Maybe (CryptoBinary, CryptoBinary) + , dsaKeyValueG :: Maybe CryptoBinary + , dsaKeyValueY :: CryptoBinary + , dsaKeyValueJ :: Maybe CryptoBinary + , dsaKeyValueSeedPgenCounter :: Maybe (CryptoBinary, CryptoBinary) + } -- ^§4.5.2.1 + | RSAKeyValue + { rsaKeyValueModulus + , rsaKeyValueExponent :: CryptoBinary + } -- ^§4.5.2.2 + | ECKeyValue + { ecKeyValueId :: Maybe XS.ID + , ecKeyValue :: ECKeyValue + , ecKeyValuePublicKey :: ECPoint + } -- ^§4.5.2.3 + | KeyValue Node + deriving (Eq, Show) + +instance XP.XmlPickler KeyValue where + xpickle = xpElem "KeyValue" $ + [XP.biCase| + Left (Left (Left ((((pq, g), y), j), sp))) <-> DSAKeyValue pq g y j sp + Left (Left (Right (m, e))) <-> RSAKeyValue m e + Left (Right ((i, v), p)) <-> ECKeyValue i v p + Right x <-> KeyValue x|] + XP.>$< (xpElem "DSAKeyValue" + (XP.xpOption + (xpElem "P" xpCryptoBinary + XP.>*< xpElem "Q" xpCryptoBinary) + XP.>*< XP.xpOption (xpElem "G" xpCryptoBinary) + XP.>*< xpElem "Y" xpCryptoBinary + XP.>*< XP.xpOption (xpElem "J" xpCryptoBinary) + XP.>*< (XP.xpOption + (xpElem "Seed" xpCryptoBinary + XP.>*< xpElem "PgenCounter" xpCryptoBinary))) + XP.>|< xpElem "RSAKeyValue" + (xpElem "Modulus" xpCryptoBinary + XP.>*< xpElem "Exponent" xpCryptoBinary) + XP.>|< xpElem11 "ECKeyValue" + (XP.xpAttrImplied "Id" XS.xpID + XP.>*< XP.xpickle + XP.>*< xpElem11 "PublicKey" xpCryptoBinary) + XP.>|< XP.xpTree) + +data ECKeyValue + = ECParameters + { ecParametersFieldID :: ECFieldID + , ecParametersCurve :: ECCurve + , ecParametersBase :: ECPoint + , ecParametersOrder :: CryptoBinary + , ecParametersCoFactor :: Maybe Integer + , ecParametersValidationData :: Maybe ECValidationData + } -- ^§4.5.2.3.1 + | ECNamedCurve + { ecNamedCurveURI :: XS.AnyURI + } + deriving (Eq, Show) + +type ECPoint = CryptoBinary + +instance XP.XmlPickler ECKeyValue where + xpickle = + [XP.biCase| + Left (((((f, c), b), o), cf), vd) <-> ECParameters f c b o cf vd + Right u <-> ECNamedCurve u|] + XP.>$< (xpElem11 "ECParameters" + (XP.xpickle + XP.>*< XP.xpickle + XP.>*< xpElem11 "Base" xpCryptoBinary + XP.>*< xpElem11 "Order" xpCryptoBinary + XP.>*< XP.xpOption (xpElem11 "CoFactor" XS.xpInteger) + XP.>*< XP.xpOption XP.xpickle) + XP.>|< xpElem11 "NamedCurve" + (XP.xpAttr "URI" XS.xpAnyURI)) + +data ECFieldID + = ECPrime + { ecP :: CryptoBinary + } + | ECTnB + { ecM :: XS.PositiveInteger + , ecK :: XS.PositiveInteger + } + | ECPnB + { ecM :: XS.PositiveInteger + , ecK1, ecK2, ecK3 :: XS.PositiveInteger + } + | ECGnB + { ecM :: XS.PositiveInteger + } + | ECFieldID Node + deriving (Eq, Show) + +instance XP.XmlPickler ECFieldID where + xpickle = xpElem11 "FieldID" $ + [XP.biCase| + Left (Left (Left (Left p))) <-> ECPrime p + Left (Left (Left (Right (m, k)))) <-> ECTnB m k + Left (Left (Right (((m, k1), k2), k3))) <-> ECPnB m k1 k2 k3 + Left (Right m) <-> ECGnB m + Right x <-> ECFieldID x|] + XP.>$< (xpElem11 "Prime" + (xpElem11 "P" xpCryptoBinary) + XP.>|< xpElem11 "TnB" + (xpElem11 "M" XS.xpPositiveInteger + XP.>*< xpElem11 "K" XS.xpPositiveInteger) + XP.>|< xpElem11 "PnB" + (xpElem11 "M" XS.xpPositiveInteger + XP.>*< xpElem11 "K1" XS.xpPositiveInteger + XP.>*< xpElem11 "K2" XS.xpPositiveInteger + XP.>*< xpElem11 "K3" XS.xpPositiveInteger) + XP.>|< xpElem11 "GnB" + (xpElem11 "M" XS.xpPositiveInteger) + XP.>|< xpTrimAnyElem) + +data ECCurve = ECCurve + { ecCurveA, ecCurveB :: CryptoBinary + } deriving (Eq, Show) + +instance XP.XmlPickler ECCurve where + xpickle = xpElem11 "Curve" $ + [XP.biCase| + (a, b) <-> ECCurve a b|] + XP.>$< (xpElem11 "A" xpCryptoBinary + XP.>*< xpElem11 "B" xpCryptoBinary) + +data ECValidationData = ECValidationData + { ecValidationDataHashAlgorithm :: AnyURI + , ecValidationDataSeed :: CryptoBinary + } deriving (Eq, Show) + +instance XP.XmlPickler ECValidationData where + xpickle = xpElem11 "ValidationData" $ + [XP.biCase| + (a, s) <-> ECValidationData a s|] + XP.>$< (XP.xpAttr "hashAlgorithm" XS.xpAnyURI + XP.>*< xpElem11 "seed" xpCryptoBinary) + +-- |§4.5.4.1 +type X509DistinguishedName = XString + +xpX509DistinguishedName :: XP.PU X509DistinguishedName +xpX509DistinguishedName = XS.xpString + +data X509Element + = X509IssuerSerial + { x509IssuerName :: X509DistinguishedName + , x509SerialNumber :: Int + } + | X509SKI XS.Base64Binary + | X509SubjectName X509DistinguishedName + | X509Certificate X509.SignedCertificate + | X509CRL X509.SignedCRL + | X509Digest + { x509DigestAlgorithm :: IdentifiedURI DigestAlgorithm + , x509Digest :: XS.Base64Binary + } + | X509Element Node + deriving (Eq, Show) + +instance XP.XmlPickler X509Element where + xpickle = [XP.biCase| + Left (Left (Left (Left (Left (Left (n, i)))))) <-> X509IssuerSerial n i + Left (Left (Left (Left (Left (Right n))))) <-> X509SubjectName n + Left (Left (Left (Left (Right b)))) <-> X509SKI b + Left (Left (Left (Right b))) <-> X509Certificate b + Left (Left (Right b)) <-> X509CRL b + Left (Right (a, d)) <-> X509Digest a d + Right x <-> X509Element x|] + XP.>$< (xpElem "X509IssuerSerial" + (xpElem "X509IssuerName" xpX509DistinguishedName + XP.>*< xpElem "X509SerialNumber" XP.xpickle) + XP.>|< xpElem "X509SubjectName" xpX509DistinguishedName + XP.>|< xpElem "X509SKI" XS.xpBase64Binary + XP.>|< xpElem "X509Certificate" xpX509Signed + XP.>|< xpElem "X509CRL" xpX509Signed + XP.>|< xpElem11 "X509Digest" + (XP.xpAttr "Algorithm" XP.xpickle + XP.>*< XS.xpBase64Binary) + XP.>|< xpTrimAnyElem) + +-- |§4.4.6 +data SPKIElement + = SPKISexp XS.Base64Binary + | SPKIElement Node + deriving (Eq, Show) + +instance XP.XmlPickler SPKIElement where + xpickle = [XP.biCase| + Left b <-> SPKISexp b + Right x <-> SPKIElement x|] + XP.>$< (xpElem "SPKISexp" XS.xpBase64Binary + XP.>|< xpTrimAnyElem) + +-- |§4.5 +data Object = Object + { objectId :: Maybe ID + , objectMimeType :: Maybe XString + , objectEncoding :: Maybe (IdentifiedURI EncodingAlgorithm) + , objectXML :: [ObjectElement] + } deriving (Eq, Show) + +instance XP.XmlPickler Object where + xpickle = xpElem "Object" $ + [XP.biCase|(((i, m), e), x) <-> Object i m e x|] + XP.>$< (XP.xpAttrImplied "Id" XS.xpID + XP.>*< XP.xpAttrImplied "MimeType" XS.xpString + XP.>*< XP.xpAttrImplied "Encoding" XP.xpickle + XP.>*< XP.xpList XP.xpickle) + +data ObjectElement + = ObjectSignature Signature + | ObjectSignatureProperties SignatureProperties + | ObjectManifest Manifest + | ObjectElement Node + deriving (Eq, Show) + +instance XP.XmlPickler ObjectElement where + xpickle = [XP.biCase| + Left (Left (Left s)) <-> ObjectSignature s + Left (Left (Right p)) <-> ObjectSignatureProperties p + Left (Right m) <-> ObjectManifest m + Right x <-> ObjectElement x|] + XP.>$< (XP.xpickle + XP.>|< XP.xpickle + XP.>|< XP.xpickle + XP.>|< XP.xpTree) + +-- |§5.1 +data Manifest = Manifest + { manifestId :: Maybe ID + , manifestReferences :: List1 Reference + } deriving (Eq, Show) + +instance XP.XmlPickler Manifest where + xpickle = xpElem "Manifest" $ + [XP.biCase|(i, r) <-> Manifest i r|] + XP.>$< (XP.xpAttrImplied "Id" XS.xpID + XP.>*< xpList1 XP.xpickle) + +-- |§5.2 +data SignatureProperties = SignatureProperties + { signaturePropertiesId :: Maybe ID + , signatureProperties :: List1 SignatureProperty + } deriving (Eq, Show) + +instance XP.XmlPickler SignatureProperties where + xpickle = xpElem "SignatureProperties" $ + [XP.biCase|(i, p) <-> SignatureProperties i p|] + XP.>$< (XP.xpAttrImplied "Id" XS.xpID + XP.>*< xpList1 XP.xpickle) + +data SignatureProperty = SignatureProperty + { signaturePropertyId :: Maybe ID + , signaturePropertyTarget :: AnyURI + , signatureProperty :: List1 Node + } deriving (Eq, Show) + +instance XP.XmlPickler SignatureProperty where + xpickle = xpElem "SignatureProperty" $ + [XP.biCase|((i, t), x) <-> SignatureProperty i t x|] + XP.>$< (XP.xpAttrImplied "Id" XS.xpID + XP.>*< XP.xpAttr "Target" XS.xpAnyURI + XP.>*< xpList1 XP.xpTree) + +-- |§6.1 +data EncodingAlgorithm + = EncodingBase64 + deriving (Eq, Bounded, Enum, Show) + +instance Identifiable URI EncodingAlgorithm where + identifier EncodingBase64 = nsFrag "base64" + +-- |§6.2 +data DigestAlgorithm + = DigestSHA1 -- ^§6.2.1 + | DigestSHA224 -- ^§6.2.2 + | DigestSHA256 -- ^§6.2.3 + | DigestSHA384 -- ^§6.2.4 + | DigestSHA512 -- ^§6.2.5 + | DigestRIPEMD160 -- ^xmlenc §5.7.4 + deriving (Eq, Bounded, Enum, Show) + +instance Identifiable URI DigestAlgorithm where + identifier DigestSHA1 = nsFrag "sha1" + identifier DigestSHA224 = httpURI "www.w3.org" "/2001/04/xmldsig-more" "" "#sha224" + identifier DigestSHA256 = httpURI "www.w3.org" "/2001/04/xmlenc" "" "#sha256" + identifier DigestSHA384 = httpURI "www.w3.org" "/2001/04/xmldsig-more" "" "#sha384" + identifier DigestSHA512 = httpURI "www.w3.org" "/2001/04/xmlenc" "" "#sha512" + identifier DigestRIPEMD160 = httpURI "www.w3.org" "/2001/04/xmlenc" "" "#ripemd160" + +-- |§6.3 +data MACAlgorithm + = MACHMAC_SHA1 -- ^§6.3.1 + deriving (Eq, Bounded, Enum, Show) + +instance Identifiable URI MACAlgorithm where + identifier MACHMAC_SHA1 = nsFrag "hmac-sha1" + +-- |§6.4 +data SignatureAlgorithm + = SignatureDSA_SHA1 + | SignatureDSA_SHA256 + | SignatureRSA_SHA1 + | SignatureRSA_SHA224 + | SignatureRSA_SHA256 + | SignatureRSA_SHA384 + | SignatureRSA_SHA512 + | SignatureECDSA_SHA1 + | SignatureECDSA_SHA224 + | SignatureECDSA_SHA256 + | SignatureECDSA_SHA384 + | SignatureECDSA_SHA512 + deriving (Eq, Bounded, Enum, Show) + +instance Identifiable URI SignatureAlgorithm where + identifier SignatureDSA_SHA1 = nsFrag "dsa-sha1" + identifier SignatureDSA_SHA256 = nsFrag11 "dsa-sha256" + identifier SignatureRSA_SHA1 = nsFrag "rsa-sha1" + identifier SignatureRSA_SHA224 = httpURI "www.w3.org" "/2001/04/xmldsig-more" "" "#rsa-sha224" + identifier SignatureRSA_SHA256 = httpURI "www.w3.org" "/2001/04/xmldsig-more" "" "#rsa-sha256" + identifier SignatureRSA_SHA384 = httpURI "www.w3.org" "/2001/04/xmldsig-more" "" "#rsa-sha384" + identifier SignatureRSA_SHA512 = httpURI "www.w3.org" "/2001/04/xmldsig-more" "" "#rsa-sha512" + identifier SignatureECDSA_SHA1 = httpURI "www.w3.org" "/2001/04/xmldsig-more" "" "#ecdsa-sha1" + identifier SignatureECDSA_SHA224 = httpURI "www.w3.org" "/2001/04/xmldsig-more" "" "#ecdsa-sha224" + identifier SignatureECDSA_SHA256 = httpURI "www.w3.org" "/2001/04/xmldsig-more" "" "#ecdsa-sha256" + identifier SignatureECDSA_SHA384 = httpURI "www.w3.org" "/2001/04/xmldsig-more" "" "#ecdsa-sha384" + identifier SignatureECDSA_SHA512 = httpURI "www.w3.org" "/2001/04/xmldsig-more" "" "#ecdsa-sha512" + +-- |§6.6 +data TransformAlgorithm + = TransformCanonicalization C14N.CanonicalizationAlgorithm -- ^§6.6.1 + | TransformBase64 -- ^§6.6.2 + | TransformXPath -- ^§6.6.3 + | TransformEnvelopedSignature -- ^§6.6.4 + | TransformXSLT -- ^§6.6.5 + deriving (Eq, Show) + +instance Identifiable URI TransformAlgorithm where + identifier (TransformCanonicalization c) = identifier c + identifier TransformBase64 = nsFrag "base64" + identifier TransformXPath = httpURI "www.w3.org" "/TR/1999/REC-xpath-19991116" "" "" + identifier TransformEnvelopedSignature = nsFrag "enveloped-signature" + identifier TransformXSLT = httpURI "www.w3.org" "/TR/1999/REC-xslt-19991116" "" "" + identifiedValues = + map TransformCanonicalization identifiedValues ++ + [ TransformBase64 + , TransformXSLT + , TransformXPath + , TransformEnvelopedSignature + ] diff --git a/SAML2/XML/Types.hs b/SAML2/XML/Types.hs new file mode 100644 --- /dev/null +++ b/SAML2/XML/Types.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE QuasiQuotes #-} +module SAML2.XML.Types where + +import Data.List.NonEmpty (NonEmpty(..)) +import Network.URI (URI(..), URIAuth(..), uriToString) +import qualified Text.XML.HXT.DOM.TypeDefs as HXT + +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 + +xpList1 :: XP.PU a -> XP.PU (List1 a) +xpList1 f = [XP.biCase|a:l <-> a:|l|] XP.>$< XP.xpList1 f + +type QName = HXT.QName + +data Namespace = Namespace + { namespacePrefix :: !String + , namespaceURI :: !URI + , namespaceURIString :: !String + } + +mkNamespace :: String -> URI -> Namespace +mkNamespace p u = Namespace p u $ uriToString id u "" + +mkNName :: Namespace -> String -> QName +mkNName ns n = HXT.mkQName (namespacePrefix ns) n (namespaceURIString ns) + +httpURI :: String -> String -> String -> String -> URI +httpURI host = URI "http:" $ Just $ URIAuth "" host "" + +xmlNS, xmlnsNS :: Namespace +xmlNS = mkNamespace "xml" $ httpURI "www.w3.org" "/XML/1998/namespace" "" "" +xmlnsNS = mkNamespace "xmlns" $ httpURI "www.w3.org" "/2000/xmlns/" "" "" diff --git a/SAML2/XML/libxml2_stub.c b/SAML2/XML/libxml2_stub.c new file mode 100644 --- /dev/null +++ b/SAML2/XML/libxml2_stub.c @@ -0,0 +1,5 @@ +#include + +void xmlFree_stub(void *p) { + return xmlFree(p); +} diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hsaml2.cabal b/hsaml2.cabal new file mode 100644 --- /dev/null +++ b/hsaml2.cabal @@ -0,0 +1,109 @@ +name: hsaml2 +version: 0.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 +license-file: LICENSE +author: Dylan Simon +maintainer: dylan@dylex.net +copyright: 2016 +category: Security, Network, Web +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC == 7.10.3 + +extra-source-files: + test/XML/signature-example.xml + test/XML/encryption-example.xml + +source-repository head + type: git + location: https://github.com/dylex/hsaml2 + +library + exposed-modules: + SAML2 + SAML2.XML + SAML2.XML.Schema + SAML2.XML.Schema.Datatypes + SAML2.XML.Canonical + SAML2.XML.ASN1 + SAML2.XML.Signature + SAML2.XML.Signature.Types + SAML2.XML.Encryption + SAML2.XML.Types + SAML2.Core + SAML2.Core.Namespaces + SAML2.Core.Datatypes + SAML2.Core.Assertions + SAML2.Core.Protocols + SAML2.Core.Versioning + SAML2.Core.Signature + SAML2.Core.Identifiers + SAML2.Profiles + SAML2.Profiles.ConfirmationMethod + SAML2.Bindings + SAML2.Bindings.General + SAML2.Bindings.Identifiers + SAML2.Bindings.HTTPRedirect + SAML2.Bindings.HTTPPOST + SAML2.Metadata + SAML2.Metadata.Metadata + other-modules: + SAML2.Lens + SAML2.XML.LibXML2 + SAML2.Bindings.Internal + c-sources: + SAML2/XML/libxml2_stub.c + build-depends: + asn1-encoding, + asn1-types >= 0.2, + base >=4.8 && <5, + base64-bytestring, + bytestring, + cryptonite, + data-default, + http-types, + hxt, + hxt-charproperties, + hxt-unicode, + invertible, + invertible-hxt, + lens, + memory, + mtl, + network-uri, + process, + semigroups, + template-haskell, + time, + x509, + zlib + pkgconfig-depends: libxml-2.0 + default-language: Haskell2010 + ghc-options: -Wall + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Bindings.HTTPRedirect + Metadata.Metadata + XML + XML.Canonical + XML.Encryption + XML.Signature + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base, + bytestring, + hsaml2, + hxt, + hxt-http, + network-uri, + semigroups, + time, + x509, + HUnit diff --git a/test/Bindings/HTTPRedirect.hs b/test/Bindings/HTTPRedirect.hs new file mode 100644 --- /dev/null +++ b/test/Bindings/HTTPRedirect.hs @@ -0,0 +1,50 @@ +module Bindings.HTTPRedirect (tests) where + +import qualified Data.ByteString.Char8 as BSC +import Data.Time (UTCTime(..), fromGregorian) +import qualified Test.HUnit as U + +import SAML2.XML +import SAML2.Core.Versioning +import SAML2.Core.Identifiers +import SAML2.Core.Assertions +import SAML2.Core.Protocols +import SAML2.Bindings.HTTPRedirect + +import XML + +tests :: U.Test +tests = U.test + [ U.TestCase $ U.assertEqual "request" + (RequestLogoutRequest $ LogoutRequest + (RequestAbstractType $ ProtocolType + "d2b7c388cec36fa7c39c28fd298644a8" + SAML20 + (UTCTime (fromGregorian 2004 1 21) (19*60*60+49)) + Nothing + (Identified ConsentUnspecified) + (Just $ Issuer $ simpleNameID NameIDFormatEntity "https://IdentityProvider.com/SAML") + Nothing + [] + (Just $ BSC.pack "0043bfc1bc45110dae17004005b13a2b")) + Nothing + Nothing + (NotEncrypted $ IdentifierName $ simpleNameID NameIDFormatPersistent "005a06e0-ad82-110d-a556-004005b13a2b") + (Just "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 + (ProtocolType + "b0730d21b628110d8b7e004005b13a2b" + SAML20 + (UTCTime (fromGregorian 2004 1 21) (19*60*60+49)) + Nothing + (Identified ConsentUnspecified) + (Just $ Issuer $ simpleNameID NameIDFormatEntity "https://ServiceProvider.com/SAML") + Nothing + [] + (Just $ BSC.pack "0043bfc1bc45110dae17004005b13a2b")) + (Just "d2b7c388cec36fa7c39c28fd298644a8") + successStatus) + =<< decodeURI mempty (uri "https://IdentityProvider.com/SAML/SLO/Response?SAMLResponse=fVFNa4QwEL0X%2Bh8k912TaDUGFUp7EbZQ6rKH3mKcbQVNJBOX%2FvxaXQ9tYec0vHlv3nzkqIZ%2BlAf7YSf%2FBjhagxB8Db1BuZQKMjkjrcIOpVEDoPRa1o8vB8n3VI7OeqttT1bJbbJCBOc7a8j9XTBH9VyQhqYRbTlrEi4Yo61oUqA0pvShYZHiDQkqs411tAVpeZPqSAgNOkrOas4zzcW55ZlI4liJrTXiBJVBr4wvCJ877ijbcXZkmaRUxtk7CU7gcB5mLu8pKVddvghd%2Ben9iDIMa3CXTsOrs5euBbfXdgh%2F9snDK%2FEqW69Ye%2BUnvGL%2F8CfbQnBS%2FQS3z4QLW9aT1oBIws0j%2FGOyAb9%2FV34Dw5k779IBAAA%3D&RelayState=0043bfc1bc45110dae17004005b13a2b") + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,26 @@ +module Main (main) where + +import System.Exit (exitSuccess, exitFailure) +import qualified Test.HUnit as U + +import qualified XML.Canonical +import qualified XML.Signature +import qualified XML.Encryption +import qualified Bindings.HTTPRedirect +import qualified Metadata.Metadata + +tests :: U.Test +tests = U.test + [ U.TestLabel "XML.Canonical" XML.Canonical.tests + , U.TestLabel "XML.Signature" XML.Signature.tests + , U.TestLabel "XML.Encryption" XML.Encryption.tests + , U.TestLabel "Bindings.HTTPRedirect" Bindings.HTTPRedirect.tests + , U.TestLabel "Metadata.Metadata" Metadata.Metadata.tests + ] + +main :: IO () +main = do + r <- U.runTestTT tests + if U.errors r == 0 && U.failures r == 0 + then exitSuccess + else exitFailure diff --git a/test/Metadata/Metadata.hs b/test/Metadata/Metadata.hs new file mode 100644 --- /dev/null +++ b/test/Metadata/Metadata.hs @@ -0,0 +1,493 @@ +{-# LANGUAGE OverloadedStrings #-} +module Metadata.Metadata (tests) where + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.X509 as X509 +import qualified Test.HUnit as U +import qualified Text.XML.HXT.Arrow.Pickle.Xml as XP +import qualified Text.XML.HXT.DOM.QualifiedName as HXT +import qualified Text.XML.HXT.DOM.XmlNode as HXT + +import SAML2.XML +import qualified SAML2.XML.Signature as DS +import qualified SAML2.XML.Encryption as XEnc +import SAML2.Core.Versioning +import SAML2.Core.Namespaces +import SAML2.Core.Identifiers +import qualified SAML2.Core.Assertions as SAML +import qualified SAML2.Core.Protocols as SAMLP +import SAML2.Bindings.Identifiers +import SAML2.Metadata.Metadata + +import XML + +tests :: U.Test +tests = U.test + [ testXML "test/Metadata/metadata-idp.xml" $ + EntityDescriptor + (uri "https://IdentityProvider.com/SAML") + Nothing + Nothing + (Just 31729999.8) + [] + Nothing + (Extensions []) + (Descriptors $ + IDPSSODescriptor + (RoleDescriptor + Nothing Nothing Nothing + [namespaceURI SAMLP.ns] + Nothing [] Nothing + (Extensions []) + [KeyDescriptor + KeyTypeSigning + (DS.KeyInfo + Nothing + (DS.KeyName "IdentityProvider.com SSO Key" + :| [])) + []] + Nothing + []) + (SSODescriptor + [IndexedEndpoint + (Endpoint + (Identified BindingSOAP) + (uri "https://IdentityProvider.com/SAML/Artifact") + Nothing [] []) + 0 + True] + [Endpoint + (Identified BindingSOAP) + (uri "https://IdentityProvider.com/SAML/SLO/SOAP") + Nothing [] [] + ,Endpoint + (Identified BindingHTTPRedirect) + (uri "https://IdentityProvider.com/SAML/SLO/Browser") + (Just $ uri "https://IdentityProvider.com/SAML/SLO/Response") + [] []] + [] + [Identified NameIDFormatX509 + ,Identified NameIDFormatPersistent + ,Identified NameIDFormatTransient]) + True + (Endpoint + (Identified BindingHTTPRedirect) + (uri "https://IdentityProvider.com/SAML/SSO/Browser") + Nothing [] [] + :| [Endpoint + (Identified BindingHTTPPOST) + (uri "https://IdentityProvider.com/SAML/SSO/Browser") + Nothing [] []]) + [] [] [] + [ SAML.Attribute + "urn:oid:1.3.6.1.4.1.5923.1.1.1.6" + (Identified AttributeNameFormatURI) + (Just "eduPersonPrincipalName") + [] [] + , SAML.Attribute + "urn:oid:1.3.6.1.4.1.5923.1.1.1.1" + (Identified AttributeNameFormatURI) + (Just "eduPersonAffiliation") + [] + [ [HXT.mkText "member"] + , [HXT.mkText "student"] + , [HXT.mkText "faculty"] + , [HXT.mkText "employee"] + , [HXT.mkText "staff"] + ]] + :| AttributeAuthorityDescriptor + (RoleDescriptor + Nothing Nothing Nothing + [namespaceURI SAMLP.ns] + Nothing [] Nothing + (Extensions []) + [KeyDescriptor + KeyTypeSigning + (DS.KeyInfo + Nothing + (DS.KeyName "IdentityProvider.com AA Key" + :| [])) + []] + Nothing []) + (Endpoint + (Identified BindingSOAP) + (uri "https://IdentityProvider.com/SAML/AA/SOAP") + Nothing [] [] + :| []) + [Endpoint + (Identified BindingURI) + (uri "https://IdentityProvider.com/SAML/AA/URI") + Nothing [] []] + [Identified NameIDFormatX509 + ,Identified NameIDFormatPersistent + ,Identified NameIDFormatTransient] + [] + [ SAML.Attribute + "urn:oid:1.3.6.1.4.1.5923.1.1.1.6" + (Identified AttributeNameFormatURI) + (Just "eduPersonPrincipalName") + [] [] + , SAML.Attribute + "urn:oid:1.3.6.1.4.1.5923.1.1.1.1" + (Identified AttributeNameFormatURI) + (Just "eduPersonAffiliation") + [] + [ [HXT.mkText "member"] + , [HXT.mkText "student"] + , [HXT.mkText "faculty"] + , [HXT.mkText "employee"] + , [HXT.mkText "staff"] + ]] + : []) + (Just $ Organization + [] + (Extensions []) + (Localized "en" "Identity Providers R US" :| []) + (Localized "en" "Identity Providers R US, a Division of Lerxst Corp." :| []) + (Localized "en" (uri "https://IdentityProvider.com") :| [])) + [] + [] + + , testXML "test/Metadata/metadata-sp.xml" $ + EntityDescriptor + (uri "https://ServiceProvider.com/SAML") + Nothing Nothing Nothing [] Nothing + (Extensions []) + (Descriptors $ + SPSSODescriptor + (RoleDescriptor + Nothing Nothing Nothing + [namespaceURI SAMLP.ns] + Nothing [] Nothing + (Extensions []) + [ KeyDescriptor + KeyTypeSigning + (DS.KeyInfo + Nothing + (DS.KeyName "ServiceProvider.com SSO Key" + :| [])) + [] + , KeyDescriptor + KeyTypeEncryption + (DS.KeyInfo + Nothing + (DS.KeyName "ServiceProvider.com Encrypt Key" + :| [])) + [XEnc.EncryptionMethod + (Identified XEnc.KeyTransportRSA1_5) + Nothing Nothing Nothing []] + ] + Nothing + []) + (SSODescriptor + [] + [Endpoint + (Identified BindingSOAP) + (uri "https://ServiceProvider.com/SAML/SLO/SOAP") + Nothing [] [] + ,Endpoint + (Identified BindingHTTPRedirect) + (uri "https://ServiceProvider.com/SAML/SLO/Browser") + (Just $ uri "https://ServiceProvider.com/SAML/SLO/Response") + [] []] + [] + [Identified NameIDFormatTransient]) + True + False + (IndexedEndpoint + (Endpoint + (Identified BindingHTTPArtifact) + (uri "https://ServiceProvider.com/SAML/SSO/Artifact") + Nothing [] []) + 0 + True + :| IndexedEndpoint + (Endpoint + (Identified BindingHTTPPOST) + (uri "https://ServiceProvider.com/SAML/SSO/POST") + Nothing [] []) + 1 + False + : []) + [ AttributeConsumingService + 0 + False + (Localized "en" "Academic Journals R US" :| []) + [] + (RequestedAttribute + (SAML.Attribute + "urn:oid:1.3.6.1.4.1.5923.1.1.1.7" + (Identified AttributeNameFormatURI) + (Just "eduPersonEntitlement") + [] + [ [HXT.mkText "https://ServiceProvider.com/entitlements/123456789"] + ]) + False + :| []) + ] + :| []) + (Just $ Organization + [] + (Extensions []) + (Localized "en" "Academic Journals R US" :| []) + (Localized "en" "Academic Journals R US, a Division of Dirk Corp." :| []) + (Localized "en" (uri "https://ServiceProvider.com") :| [])) + [] [] + + , testXML "test/Metadata/metadata-osf.xml" $ + EntityDescriptor + (uri "https://accounts.osf.io/shibboleth") + (Just "_d1a16315f5a36fc0a7d997a1a71a77edd110a396") + Nothing Nothing [] Nothing + (Extensions $ + let alg t a = + HXT.mkElement (HXT.mkQName "alg" (t ++ "Method") "urn:oasis:names:tc:SAML:metadata:algsupport") + [HXT.mkAttr (HXT.mkName "Algorithm") [HXT.mkText $ show $ identifier a]] + [] in + [ alg "Digest" DS.DigestSHA512 + , alg "Digest" DS.DigestSHA384 + , alg "Digest" DS.DigestSHA256 + , alg "Digest" DS.DigestSHA224 + , alg "Digest" DS.DigestSHA1 + , alg "Signing" DS.SignatureECDSA_SHA512 + , alg "Signing" DS.SignatureECDSA_SHA384 + , alg "Signing" DS.SignatureECDSA_SHA256 + , alg "Signing" DS.SignatureECDSA_SHA224 + , alg "Signing" DS.SignatureRSA_SHA512 + , alg "Signing" DS.SignatureRSA_SHA384 + , alg "Signing" DS.SignatureRSA_SHA256 + , alg "Signing" DS.SignatureDSA_SHA256 + , alg "Signing" DS.SignatureECDSA_SHA1 + , alg "Signing" DS.SignatureRSA_SHA1 + , alg "Signing" DS.SignatureDSA_SHA1 + ]) + (Descriptors + (SPSSODescriptor + (RoleDescriptor + Nothing Nothing Nothing + [ samlURN SAML20 ["protocol"] + , samlURN SAML11 ["protocol"] + , samlURN SAML10 ["protocol"] + ] + Nothing [] Nothing + (Extensions [ + pickleElem (xpTrimElemNS (mkNamespace "init" $ uri "urn:oasis:names:tc:SAML:profiles:SSO:request-init") "RequestInitiator" XP.xpickle) $ + Endpoint + (Unidentified $ uri "urn:oasis:names:tc:SAML:profiles:SSO:request-init") + (uri "https://accounts.osf.io/Shibboleth.sso/Login") + Nothing [] [] + ]) + [ KeyDescriptor + KeyTypeBoth + (DS.KeyInfo + Nothing + (DS.KeyName "f04f8d134cd2" + :| DS.X509Data + (DS.X509SubjectName "CN=f04f8d134cd2" + :| DS.X509Certificate (either error id $ X509.decodeSignedObject + "0\130\STX\235\&0\130\SOH\211\160\ETX\STX\SOH\STX\STX\t\NUL\154\132\171@\222\174iQ0\r\ACK\t*\134H\134\247\r\SOH\SOH\ENQ\ENQ\NUL0\ETB1\NAK0\DC3\ACK\ETXU\EOT\ETX\DC3\ff04f8d134cd20\RS\ETB\r151229001137Z\ETB\r251226001137Z0\ETB1\NAK0\DC3\ACK\ETXU\EOT\ETX\DC3\ff04f8d134cd20\130\SOH\"0\r\ACK\t*\134H\134\247\r\SOH\SOH\SOH\ENQ\NUL\ETX\130\SOH\SI\NUL0\130\SOH\n\STX\130\SOH\SOH\NUL\221{\CAN\250\180^\163X\171u\163+\214/\160\220W%8\164O\166\157\&7H\139\242\221\153\148\173\138\226\159n\159\176%~Z\179\144\137\150\218\159\225t\239\171\255&\183\&5\170\231\147\&7W\ETB[\171+\227\147\144\242\154)hvx\ACK\158\158\229\187\157H|{g>Y\166tJ\232+\165\\\251\250\218\177\129\129\244\CANx\r\b\223\245\182k\151\ENQE,xz\231\210)\ESC\150=\134\241~\171]\163\131R?5\210\ETX\245\157\253\131j\152q\193(\195\244\254\186\229\CAN\136\174\173\206B}w\227\&9\166_q\176J\193\r\219\227\191\255\SI\SI$2\153\191\231\160f\tbni\USn)\183\rVKF\221\184\SYNBH\216\178\&8\236\&9d3\RS{\STXQK\ETBa\244\234?bJ\178\207n:\203\165\234\203\213\243\159M\241\194\200D\\V@\140\147\186\190\130\218\bwbe\132^\224\217\247N\241Zw\197\134\234\130\ENQ\183\145G\STX\ETX\SOH\NUL\SOH\163:080\ETB\ACK\ETXU\GS\DC1\EOT\DLE0\SO\130\ff04f8d134cd20\GS\ACK\ETXU\GS\SO\EOT\SYN\EOT\DC4mz3\128Z\139\f\179>\185\134\&1\213\250J\165\233\251\203x0\r\ACK\t*\134H\134\247\r\SOH\SOH\ENQ\ENQ\NUL\ETX\130\SOH\SOH\NUL#\"\175\190\138\&9\237|Z\135L\157\160\&7\243\138\243\175\241\228Ui\228\223\&1 \SYN\188\170\192\155-\186\&7\221\250\167\RS\142=\193\218h\224x\246L6\155\&8f\176r\217\&8<\195&\DC38A\149\247\157y\156\132x\224_\DC3 &m\208\139\b6\224\SUBLH\254\218\207\US2\EOT\SI\SIg\236*\187\244^^FS\198\203C\179\157f\v\SI\129%\148)\DC2\211\171\200\237\237y\ESC\132c\255\DLE\153\ENQ\186\153~(\132\255\USm\200~j\153h1\207\138\173\249)\236\223\173f5\180:H\ETX\144\158\212\ETB\151\b\133f\208\ENQ\178[\DC4\131\232\229}\NUL\fAPf\ETX2|FX\196\GS\154_F\EOT\SO\201\&2\177\223\186\166\ENQd\141\171\233\NULUHd\201S\128\EOT|\246\EM\140O\202\215\b\190\DC3\153\230\NUL\165\203\128\254\209\187\189\DC4J\151c\178\163\221\213\t\238\198\199\ETX\128\ETB*vj:\177w0\DEL\200\US\204s?4\CANB\243\253A:\190@=\tm\245\230\SOH\208\251\&5\136\153F\207\197\218y\189\250\RS\215\ACK{Ze\195D\222~\225 \233\182R\129>\198Aj\208\t\132\CAN\201:E\139\255==w$]\131\230\CAN]\193\163\130\STX\172\&0\130\STX\168\&0\SO\ACK\ETXU\GS\SI\SOH\SOH\255\EOT\EOT\ETX\STX\ENQ\160\&0\f\ACK\ETXU\GS\DC3\SOH\SOH\255\EOT\STX0\NUL0\GS\ACK\ETXU\GS%\EOT\SYN0\DC4\ACK\b+\ACK\SOH\ENQ\ENQ\a\ETX\SOH\ACK\b+\ACK\SOH\ENQ\ENQ\a\ETX\STX0\GS\ACK\ETXU\GS\SO\EOT\SYN\EOT\DC4\137\209\220M\178,{S\132\DEL\241qy\252F3\192\SYNz80~\ACK\ETXU\GS#\EOTw0u\128\DC4\147-\200a\CAN\173c\227\155e\179\157\221\141\147\186\231\202cE\161Z\164X0V1\v0\t\ACK\ETXU\EOT\ACK\DC3\STXUS1\FS0\SUB\ACK\ETXU\EOT\n\DC3\DC3InCommon Federation1)0'\ACK\ETXU\EOT\ETX\DC3 InCommon Certification Authority\130\SOH\NUL0\129\186\ACK\b+\ACK\SOH\ENQ\ENQ\a\SOH\SOH\EOT\129\173\&0\129\170\&0\129\167\ACK\b+\ACK\SOH\ENQ\ENQ\a0\STX\134\129\154http://incommonca1.incommonfederation.org/bridge/certs/ca-certs.p7b\n\t\tCA Issuers - URI:http://incommonca2.incommonfederation.org/bridge/certs/ca-certs.p7b0\129\141\ACK\ETXU\GS\US\EOT\129\133\&0\129\130\&0?\160=\160;\134\&9http://incommoncrl1.incommonfederation.org/crl/eecrls.crl0?\160=\160;\134\&9http://incommoncrl2.incommonfederation.org/crl/eecrls.crl0^\ACK\ETXU\GS \EOTW0U0S\ACK\v+\ACK\SOH\EOT\SOH\174#\SOH\EOT\SOH\SOH0D0B\ACK\b+\ACK\SOH\ENQ\ENQ\a\STX\SOH\SYN6http://incommonca.incommonfederation.org/practices.pdf0\GS\ACK\ETXU\GS\DC1\EOT\SYN0\DC4\130\DC2shibboleth.nyu.edu0\r\ACK\t*\134H\134\247\r\SOH\SOH\ENQ\ENQ\NUL\ETX\130\SOH\SOH\NUL\173N\237\243\NAK\n\232\242\135\t?\216\223\156\151\187-\f/\v\239\SYN\210\DEL\192\196\153\228\161\167@Y{\203\234\197\148\252Z\DC3\131\143)\165\238\128\224\177fg\196\153\"\175\251\&5\234:I\251\212\146\DC4\254;\217\128\174x\217'\165\192\187\247\a\209\240\255(\DLE$R\EM\EOTBYmK-OO`)\162\191\237\139m\bW\172\156\\\147\220\224\ENQA\135\181\255\152\170Y\235\142\130Zq\239\162#\212\168\240\"\206\158\199\&6\SYN\193\223\231\DLE\142\196\SO\SO+c\NAK\213\NAKB\ENQ\252\DLE\ETX\247\196\198@\CAN\165\&63\253\EM\EM\249\198\162H\249\162%4\243H\162\235\&3\179\DLE5\STX\146\233Q\228%\186\167\233\160v\128\152^\205\219\246\184\176\155U\249\166\168\191\225\150\194(\255\138\233\&8\146\EOT\225\150\198\208\172\ACK\158\230XWI\149e\DC3\233\173\213E\218\CAN\153E\DLE\DLE\226_\173<\147\240%\180vM\ETX\EM:\SYN{h\247\181\172FO\207D\221P:\195\145\164\181\STX\185\179\EMe\DLE\ENQP\219w\226\&1\218.\f\vk\226\NUL\205\188\228\176\181\133.\SI\b\DEL>\153\DEL\148\ETX0\141O\157\191O)6\226Q\245\218\197\141\131\&4\140\170\">\193\189\SOH\209\&0\144T\134A\189\b\a\\-\243\236\NULy0\151 \163+\STX\ETX\SOH\NUL\SOH\163\130\SOH\DC10\130\SOH\r0\GS\ACK\ETXU\GS\SO\EOT\SYN\EOT\DC4\149\228.\172J\129\198\195\135\170\DC2\253\210\DLE\162X\194\136\191\GS0\129\221\ACK\ETXU\GS#\EOT\129\213\&0\129\210\128\DC4\149\228.\172J\129\198\195\135\170\DC2\253\210\DLE\162X\194\136\191\GS\161\129\174\164\129\171\&0\129\168\&1\v0\t\ACK\ETXU\EOT\ACK\DC3\STXUS1\DC10\SI\ACK\ETXU\EOT\b\DC3\bNew York1\DC10\SI\ACK\ETXU\EOT\a\DC3\bNew York1\FS0\SUB\ACK\ETXU\EOT\n\DC3\DC3New York University1\f0\n\ACK\ETXU\EOT\v\DC3\ETXITS1\"0 \ACK\ETXU\EOT\ETX\DC3\EMurn:mace:incommon:nyu.edu1#0!\ACK\t*\134H\134\247\r\SOH\t\SOH\SYN\DC4idm.services@nyu.edu\130\t\NUL\141\149\236\&9\165\128\180\&50\f\ACK\ETXU\GS\DC3\EOT\ENQ0\ETX\SOH\SOH\255\&0\r\ACK\t*\134H\134\247\r\SOH\SOH\ENQ\ENQ\NUL\ETX\130\SOH\SOH\NUL\194\239\SO\EM\206O\234\130\147a\153\231\180\221LF:,e\SYN\DEL\148i\142\144\DC1\216\193 \237\206\222m\180\132E\139\167\131\218\249\&0o\177)l\NAKd!\213i_\158\ACK_\128\175\204\141\156\164v\r>ll\DC1O\210Lq\150\224\247\ETB\174\206s\130\DC1\233\238L\194m\SO\184\170\187\&4\229\&7\169\172\217\233\158\150\NUL^~$\SO\164\&0\191\134\197\247\RS\189&\137\&8\NAK\171\172[\222dqR\147\DC2DP\DLE\170\t&W\141\&7}\SI\164w\193\\\177,\181\142\&4\185\\\188\ETB\136\GS\244\\\219\128\213Q4\RSU\172\226^\ETXWQ\191\219\130\\\212z\251\137L\162d\199\217\149\153\EOT\186;\187<\234\230\198\213\&4E\157\&4\SI(\172\183;\135\131i%\236yS\ENQ\251N\179\193C\196\205\236\170+re'.\181\t\175\&1\238\141\v/\247\157!r\FS$\ENQ=\251\186\233\188\156\178\198\ACKG\238\CAN\190\216\194e\NAK\SUB\179\153\DC2") + :| []) + :| [])) + [] + ] + Nothing []) + (SSODescriptor + [] [] [] []) + False + (Endpoint + (Unidentified $ uri "urn:mace:shibboleth:1.0:profiles:AuthnRequest") + (uri "https://shibboleth.nyu.edu/idp/profile/Shibboleth/SSO") + Nothing [] [] + :| Endpoint + (Identified BindingHTTPRedirect) + (uri "https://shibboleth.nyu.edu/idp/profile/SAML2/Redirect/SSO") + Nothing [] [] + : Endpoint + (Identified BindingHTTPPOST) + (uri "https://shibboleth.nyu.edu/idp/profile/SAML2/POST/SSO") + Nothing [] [] + : []) + [] + [] + [] + [] + :| [])) + (Just $ Organization + [] + (Extensions []) + (Localized "en" "New York University" :| []) + (Localized "en" "New York University" :| []) + (Localized "en" (uri "http://www.nyu.edu/") :| [])) + [ ContactPerson + ContactTypeTechnical + [] + (Extensions []) + Nothing + (Just "Yavor Yanakiev") + Nothing + [uri "yy27@nyu.edu"] + [] + , ContactPerson + ContactTypeTechnical + [] + (Extensions []) + Nothing + (Just "Tracy Edappara") + Nothing + [uri "tte3@nyu.edu"] + [] + , ContactPerson + ContactTypeAdministrative + [] + (Extensions []) + Nothing + (Just "Gary Chapman") + Nothing + [uri "gwc1@nyu.edu"] + [] + ] + [] + ] diff --git a/test/XML.hs b/test/XML.hs new file mode 100644 --- /dev/null +++ b/test/XML.hs @@ -0,0 +1,29 @@ +module XML + ( testXML + , uri + , pickleElem + ) where + +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.>>> HXT.processBottomUp (HXT.processAttrl (HXT.none `HXT.when` HXT.isNamespaceDeclAttr)) + +testXML :: (Eq a, HXT.XmlPickler a, Show a) => String -> a -> U.Test +testXML u a = U.TestCase $ + U.assertEqual u [Right a] =<< parseXML u + +uri :: String -> URI +uri = fromJust . parseURIReference + +pickleElem :: HXT.PU a -> a -> HXT.XmlTree +pickleElem p = head . DOM.getChildren . HXT.pickleDoc p diff --git a/test/XML/Canonical.hs b/test/XML/Canonical.hs new file mode 100644 --- /dev/null +++ b/test/XML/Canonical.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} +module XML.Canonical (tests) where + +import qualified Data.ByteString as BS +import qualified Test.HUnit as U +import qualified Text.XML.HXT.Core as HXT + +import SAML2.XML.Canonical + +canonicalizeXML :: CanonicalizationAlgorithm -> String -> Bool -> IO [BS.ByteString] +canonicalizeXML c 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)) + +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 + +tests :: U.Test +tests = U.test + [ testC14N (CanonicalXML10 False) "test/XML/noncanonical1.xml" False + "\nHello, world!\n" + , testC14N (CanonicalXML10 True) "test/XML/noncanonical1.xml" False + "\nHello, world!\n\n\n" + , testC14N (CanonicalXML10 False) "test/XML/noncanonical2.xml" False + "\n \n A B \n \n A\n \n B\n A B \n C\n \n" + , testC14N (CanonicalXML10 False) "test/XML/noncanonical3.xml" False + "\n \n \n \n \n \n \n \n \n \n \n \n \n" + , testC14N (CanonicalXML10 False) "test/XML/noncanonical4.xml" False + "\n First line \nSecond line\n 2\n value>\"0\" && value<\"10\" ?\"valid\":\"error\"\n "0" && value<"10" ?"valid":"error"\">valid\n \n \n \n" + , testC14N (CanonicalXML10 False) "test/XML/noncanonical5.xml" True + "\n Hello, world!\n" + , testC14N (CanonicalXML10 False) "test/XML/noncanonical6.xml" False + "\194\169" + -- , testC14N (CanonicalXML10 False) "test/XML/noncanonical7.xml" + ] diff --git a/test/XML/Encryption.hs b/test/XML/Encryption.hs new file mode 100644 --- /dev/null +++ b/test/XML/Encryption.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} +module XML.Encryption (tests) where + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Test.HUnit as U +import qualified Text.XML.HXT.Arrow.Pickle.Xml as XP +import qualified Text.XML.HXT.DOM.QualifiedName as HXT +import qualified Text.XML.HXT.DOM.XmlNode as HXT + +import SAML2.XML +import SAML2.XML.Signature +import SAML2.XML.Encryption + +import XML + +tests :: U.Test +tests = U.test + [ testXML "test/XML/encryption-example.xml" $ + EncryptedData $ EncryptedType (Just "eg1") + Nothing + Nothing + Nothing + (Just $ EncryptionMethod + (Identified KeyTransportRSAOAEPMGF1P) + (Just 256) + (Just "\246U\174\221") + (Just $ DigestMethod + (Identified DigestSHA1) + []) + []) + (Just $ KeyInfo Nothing + (KeyName "Joseph" + :| RetrievalMethod + (uri "http://exmample.org/Reagle/PublicKey") + (Just $ uri "http://www.w3.org/2001/04/xmlenc#EncryptedKey") + Nothing + : KeyInfoElement (pickleElem XP.xpickle $ EncryptedKey + (EncryptedType Nothing + Nothing + Nothing + Nothing + (Just $ EncryptionMethod + (Identified BlockEncryptionTripleDES) + Nothing + Nothing + Nothing + []) + Nothing + (CipherValue "\169\153>6G\ACK\129j\186>%qxP\194l\156\208\216\157") + Nothing) + Nothing + [ KeyReference + (uri "http://exmample.org/foo2") + [] + , DataReference + (uri "http://exmample.org/foo1") + [] + ] + Nothing) + : KeyInfoElement (pickleElem XP.xpickle $ AgreementMethod + (Unidentified (uri "example:Agreement/Algorithm")) + (Just "foo") + (Just $ DigestMethod + (Identified DigestSHA1) + []) + (Just $ KeyInfo Nothing $ + KeyInfoKeyValue (RSAKeyValue + 124965805205214 + 124965805205214) + :| []) + (Just $ KeyInfo Nothing $ + KeyInfoKeyValue (RSAKeyValue + 124965805205214 + 124965805205214) + :| [])) + : [])) + (CipherReference + (uri "http://example.org/pgpkeys/reagle.b64") + (Transform + (Identified TransformBase64) + Nothing + [] + :| [])) + (Just $ EncryptionProperties Nothing $ + EncryptionProperty (Just "ep2") + (Just $ uri "#eg1") + [HXT.mkElement (HXT.mkNsName "p" "http://www.w3.org/1999/xhtml") + [] + [HXT.mkText "This XML document tests the schema for ambigous content."]] + :| []) + + ] diff --git a/test/XML/Signature.hs b/test/XML/Signature.hs new file mode 100644 --- /dev/null +++ b/test/XML/Signature.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} +module XML.Signature (tests) where + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.X509 as X509 +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.XML +import SAML2.XML.Signature +import SAML2.XML.Canonical + +import XML + +tests :: U.Test +tests = U.test + [ testXML "test/XML/signature-example.xml" $ + Signature (Just "MyFirstSignature") + (SignedInfo Nothing + (CanonicalizationMethod + (Identified (CanonicalXML10 False)) + Nothing + []) + (SignatureMethod + (Identified SignatureDSA_SHA1) + Nothing + []) + (Reference Nothing + (Just $ uri "http://www.w3.org/TR/xml-stylesheet/") + Nothing + (Just $ Transforms $ + Transform + (Identified TransformBase64) + Nothing + [] + :| []) + (DigestMethod + (Identified DigestSHA1) + []) + "\143\169p\199z\239\DLE\243\180\188\171L\186\158\rm\229n\242y" + :| Reference Nothing + (Just $ uri "http://www.w3.org/TR/REC-xml-names/") + Nothing + (Just $ Transforms $ + Transform + (Identified TransformBase64) + Nothing + [] + :| []) + (DigestMethod + (Identified DigestSHA1) + []) + "R\181\203\f\176H\181\174\172\146\133y\252\SI\DLE\223\193\132\195\142" + : [])) + (SignatureValue Nothing + "0-\STX\DC4Z\213.\212e\144\199\&7\r\170'\224\SUB\170\158HB:Q\SUB\STX\NAK\NUL\147\202G\214$M+\234\181#\235\"\176\&4\243\217\&1D\NUL\177") + (Just $ KeyInfo Nothing $ + KeyInfoKeyValue (DSAKeyValue + (Just (4227,4467856506880)) + (Just 0) + 0 + Nothing + Nothing) + :| []) + [Object Nothing + Nothing + Nothing + [ObjectSignatureProperties $ SignatureProperties Nothing + (SignatureProperty Nothing + (uri "#MyFirstSignature") + (HXT.mkElement (HXT.mkQName "ts" "timestamp" "http://www.example.org/rfc/rfcxxxx.txt") + [] + [HXT.mkText "\n this is a test of the mixed content model"] + :| []) + :| [])]] + + , testXML "http://www.w3.org/TR/2002/REC-xmldsig-core-20020212/signature-example-rsa.xml" $ + Signature Nothing + (SignedInfo Nothing + (CanonicalizationMethod + (Identified (CanonicalXML10 False)) + Nothing + []) + (SignatureMethod + (Identified SignatureRSA_SHA1) + Nothing + []) + (Reference Nothing + (Just $ uri "http://www.w3.org/TR/xml-stylesheet") + Nothing + Nothing + (DigestMethod + (Identified DigestSHA1) + []) + "\235Cof\251]L\US\187RyK\167\241\246\226\158\225\225\187" + :| [])) + (SignatureValue Nothing + "\142\228\185F\DC2|\243\138\168\NAK\US\US\149U\221\254\182\235H5F\159\141\STXj\152\SOH\238\167\144\137?\171\175C^\144D:\EOTxT\ETX\199S\223\224BL\NAK\DLE#GA\142Y\165\246\\3\DLE\213\239K\205\243D@\163\205v\204E5-U\152\143dm\169\168\163\231/f\DC4\220\SIz\227\149\STX\141\&5\212\250\&8\ENQ\186k\251\147\191!\137\224\ACK\SI3\\\139\227\208\244\164f\155\255\226q>\201i\140\237\130\222") + (Just $ KeyInfo Nothing $ + KeyInfoKeyValue (RSAKeyValue + 129320787110389946406925163824095500161767249273623083115363317842079233133623467127773858023148958966585889333894288698085674111884585270272937137414571531865090153762072690670922714784242933462808045060688046441910524319219807614054721975863956765214954333806674482022007523948700289932875920496009317903247 + 65537) + :| X509Data + (X509SubjectName "\n CN=Merlin Hughes,O=Baltimore Technologies\\, Ltd.,ST=Dublin,C=IE\n " + :| X509IssuerSerial + "\n CN=Test RSA CA,O=Baltimore Technologies\\, Ltd.,ST=Dublin,C=IE\n " + 970849928 + : X509Certificate (either error id $ X509.decodeSignedObject + "0\130\STXx0\130\SOH\225\160\ETX\STX\SOH\STX\STX\EOT9\221\254\136\&0\r\ACK\t*\134H\134\247\r\SOH\SOH\EOT\ENQ\NUL0[1\v0\t\ACK\ETXU\EOT\ACK\DC3\STXIE1\SI0\r\ACK\ETXU\EOT\b\DC3\ACKDublin1%0#\ACK\ETXU\EOT\n\DC3\FSBaltimore Technologies, Ltd.1\DC40\DC2\ACK\ETXU\EOT\ETX\DC3\vTest RSA CA0\RS\ETB\r001006163207Z\ETB\r011006163204Z0]1\v0\t\ACK\ETXU\EOT\ACK\DC3\STXIE1\SI0\r\ACK\ETXU\EOT\b\DC3\ACKDublin1%0#\ACK\ETXU\EOT\n\DC3\FSBaltimore Technologies, Ltd.1\SYN0\DC4\ACK\ETXU\EOT\ETX\DC3\rMerlin Hughes0\129\159\&0\r\ACK\t*\134H\134\247\r\SOH\SOH\SOH\ENQ\NUL\ETX\129\141\NUL0\129\137\STX\129\129\NUL\184(\174\146\152\SOh\233\171\171W\207Q1\247\b\ENQ\241\184Y\143\142\201\146\226\&9\211+\SUB\239\211\rI)\197\237'c7jF\149\213\223\228j\187\201\150g\154\163m#7/k\251\251\202\194&\227\&3\190\197\251v\200\145\227\EOT\SUB`\bRq\\\136\153\DC1\250(N\237\190\FSN\230'\DC2/1\RS\219\184\136\201\250\CAN\224\193\160L\234\NAK\ACK\GSw\202x\190\182A\178\251\&8\226t\235K\202\178\202\SYN\218\235\143\STX\ETX\SOH\NUL\SOH\163G0E0\RS\ACK\ETXU\GS\DC1\EOT\ETB0\NAK\129\DC3merlin@baltimore.ie0\SO\ACK\ETXU\GS\SI\SOH\SOH\255\EOT\EOT\ETX\STX\a\128\&0\DC3\ACK\ETXU\GS#\EOT\f0\n\128\bI\224\173\146\NAK\130\237\&70\r\ACK\t*\134H\134\247\r\SOH\SOH\EOT\ENQ\NUL\ETX\129\129\NULrn\224\149j\253i\215+j*\169\242\214\169\235\&9\188s\173}\DEL\217\132(\197\200\&3!\206\201H\241\169\186\218\ACK^w\ACK} \134H\194SQ2\241\ETX@\GS\179v\207\222\DLE\EM\200\SOH\ETX\229\255$K\b\179\159fv\192\240\245\235lS\249\138\v7\169\ENQ\146p\NAK#eX\226\147\190<\GSM\172QVNk\221\FS\210be\218\242l\253\FS2-n\255\184 \US\v\242?\147\220F\175\183\231z\130\SYN") + : []) + : []) + [] + + , testXML "http://www.w3.org/TR/2002/REC-xmldsig-core-20020212/signature-example-dsa.xml" $ + Signature Nothing + (SignedInfo Nothing + (CanonicalizationMethod + (Identified (CanonicalXML10 False)) + Nothing + []) + (SignatureMethod + (Identified SignatureDSA_SHA1) + Nothing + []) + (Reference Nothing + (Just $ uri "http://www.w3.org/TR/xml-stylesheet") + Nothing + Nothing + (DigestMethod + (Identified DigestSHA1) + []) + "\235Cof\251]L\US\187RyK\167\241\246\226\158\225\225\187" + :| [])) + (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 + (Just (153189639877411708224318232157362603672344144516811966787300053511761023886224186320604641484819218412604307502181416378142369715493548254902826913797675909798516465379299499179683104783603344189053156355893057246996756239330536459114483648506158907550755189559705056134296533730500485771224694549017281352213, 1393672757286116725466646726891466679477132949611)) + (Just 35729760834794135337622213068423837828001418115741637960451705317746718553830652249599411519579460551833355506946575671195284376652749132624400687252979877843978133909425395446287975790304889073526084815938167334643701873370635770822329121239717107729346766305695485960113338821879352438123181471401687525574) + 80624726256040348115552042320696813500187275370942441977258669395023235020055564647117594451929708788598704081077890850726227289270230377442285367559774800853404089092381420228663316324808605521697655145608801533888071381819208887705771753016938104409283940243801509765453542091716518238707344493641683483917 + Nothing + Nothing) + :| X509Data + (X509SubjectName "\n CN=Merlin Hughes,O=Baltimore Technologies\\, Ltd.,ST=Dublin,C=IE\n " + :| X509IssuerSerial + "\n CN=Test DSA CA,O=Baltimore Technologies\\, Ltd.,ST=Dublin,C=IE\n " + 970849936 + : X509Certificate (either error id $ X509.decodeSignedObject + "0\130\ETX70\130\STX\245\160\ETX\STX\SOH\STX\STX\EOT9\221\254\144\&0\t\ACK\a*\134H\206\&8\EOT\ETX0[1\v0\t\ACK\ETXU\EOT\ACK\DC3\STXIE1\SI0\r\ACK\ETXU\EOT\b\DC3\ACKDublin1%0#\ACK\ETXU\EOT\n\DC3\FSBaltimore Technologies, Ltd.1\DC40\DC2\ACK\ETXU\EOT\ETX\DC3\vTest DSA CA0\RS\ETB\r001006163215Z\ETB\r011006163214Z0]1\v0\t\ACK\ETXU\EOT\ACK\DC3\STXIE1\SI0\r\ACK\ETXU\EOT\b\DC3\ACKDublin1%0#\ACK\ETXU\EOT\n\DC3\FSBaltimore Technologies, Ltd.1\SYN0\DC4\ACK\ETXU\EOT\ETX\DC3\rMerlin Hughes0\130\SOH\182\&0\130\SOH+\ACK\a*\134H\206\&8\EOT\SOH0\130\SOH\RS\STX\129\129\NUL\218&7\195N\182\176\&0w\252\&2%-c\158\ESC\223\184R\153\131gGr\169\EM=t\185MC\170\154\\\142\237:\184\221\"\EM\186\159\247\142\195\142@B\219\152J\158\172\164+}q\a\r\EOT\b\246\216\171\242\130\247\201 \133\215\246\196\144\174\232\US\SUB\168\159y+\216\221U\249I\221c\251=\fI\159\231\230\&3m\243\203\161\216-uH\n\151\234z\215M\143\245G\t(Y\DC3v\221&!:V\134\210\NAK\STX\NAK\NUL\244\RSr\164\182=\164\195\166\183\DLE\158L1\224\193\211Exk\STX\129\128\&2\225\128\150\167\129\213\172~\191#\182\248\235.n8e\238\145\241.\238;D\129\254\252\206v\SO1\DC2\ETX\210\140J\188\&3\177\140|\200\212vZ\138\SOH\202\177\&4\183\167\238\209Y\220+\181\n\242\137N\226\222\240\166\253\179\224\SOHP=\NAKB(\\(\210\168'\229\162\136\144\128\134\&2Z\209\203\205Z\189\189\187\192g\SYN\162\216q\222#\207\&2\209W\182\128\234+BH\181\162=G\204\220\214k\ENQ\132\205F(\198\ETX\129\132\NUL\STX\129\128r\208<`lk\182x \255\&2\149\190\161\SOy\249\240\153X\133\206\215'<\SYN\SI\148\155/\135\172\138#\136\131\155\175\US\158\158\f\139tk'\166\217\ETX(\ENQ\173B\DLE/\DC2\227W\227\137\182\STX@\DC2\218\&4\196\v>1\232n\171P\228HQ)?z\ETX\204$\206\178\179\162KP\240A\238(!\190\243VO\253\151\182\143\180\147\a[B\213\148\199pd\209M4\154*1\196\246e\240\143\173\251\216\189\r\163G0E0\RS\ACK\ETXU\GS\DC1\EOT\ETB0\NAK\129\DC3merlin@baltimore.ie0\SO\ACK\ETXU\GS\SI\SOH\SOH\255\EOT\EOT\ETX\STX\a\128\&0\DC3\ACK\ETXU\GS#\EOT\f0\n\128\bBY@m\n\193\SYN\207\&0\t\ACK\a*\134H\206\&8\EOT\ETX\ETX1\NUL0.\STX\NAK\NUL\174,\145a\ENQb\n\224\129\162@\242\246\NUL\193(\224\215o\138\STX\NAK\NUL\192t\232\239\ax\180Cp\244\176\n>IP\255\190\US\US_") + : []) + : []) + [] + ] diff --git a/test/XML/encryption-example.xml b/test/XML/encryption-example.xml new file mode 100644 --- /dev/null +++ b/test/XML/encryption-example.xml @@ -0,0 +1,53 @@ + + + + 256 + 9lWu3Q== + + + + Joseph + + + + + qZk+NkcGgWq6PiVxeFDCbJzQ2J0= + + + + + + + + Zm9v + + + + cafebabecafebabe + + + + + cafebabecafebabe + + + + + + + + + + + + + +

This XML document tests the schema for ambigous content.

+ + diff --git a/test/XML/signature-example.xml b/test/XML/signature-example.xml new file mode 100644 --- /dev/null +++ b/test/XML/signature-example.xml @@ -0,0 +1,41 @@ + + + + + + + + + + + + + + j6lwx3rvEPO0vKtMup4NbeVu8nk= + + + + + + + + UrXLDLBIta6skoV5/A8Q38GEw44= + + + MC0CFFrVLtRlkMc3Daon4BqqnkhCOlEaAhUAk8pH1iRNK+q1I+sisDTz2TFEALE= + + + +

ABCD

BBBBAAAA + + + + + + + + this is a test of the mixed content model + + + +