packages feed

hsaml2 (empty) → 0.1

raw patch · 43 files changed

+5253/−0 lines, 43 filesdep +HUnitdep +asn1-encodingdep +asn1-typessetup-changed

Dependencies added: HUnit, asn1-encoding, asn1-types, base, base64-bytestring, bytestring, cryptonite, data-default, hsaml2, http-types, hxt, hxt-charproperties, hxt-http, hxt-unicode, invertible, invertible-hxt, lens, memory, mtl, network-uri, process, semigroups, template-haskell, time, x509, zlib

Files

+ LICENSE view
@@ -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.
+ SAML2.hs view
@@ -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
+ SAML2/Bindings.hs view
@@ -0,0 +1,9 @@+-- |+-- Bindings for the OASIS Security Assertion Markup Language (SAML) V2.0+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-bindings-2.0-os.pdf saml-bindings-2.0-os>+module SAML2.Bindings+  ( module SAML2.Bindings.Identifiers+  ) where++import SAML2.Bindings.Identifiers
+ SAML2/Bindings/General.hs view
@@ -0,0 +1,18 @@+-- |+-- General Considerations+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-bindings-2.0-os.pdf saml-bindings-2.0-os> §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"
+ SAML2/Bindings/HTTPPOST.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+-- |+-- HTTP POST Binding+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-bindings-2.0-os.pdf saml-bindings-2.0-os> §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
+ SAML2/Bindings/HTTPRedirect.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- HTTP Redirect Binding+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-bindings-2.0-os.pdf saml-bindings-2.0-os> §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"+
+ SAML2/Bindings/Identifiers.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- |+-- Protocol Bindings identifiers+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-bindings-2.0-os.pdf saml-bindings-2.0-os> §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")
+ SAML2/Bindings/Internal.hs view
@@ -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)+
+ SAML2/Core.hs view
@@ -0,0 +1,107 @@+-- |+-- Assertions and Protocols for the OASIS Security Assertion Markup Language (SAML) V2.0+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf saml-core-2.0-os>+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
+ SAML2/Core/Assertions.hs view
@@ -0,0 +1,454 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- SAML Assertions+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf saml-core-2.0-os> §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)
+ SAML2/Core/Datatypes.hs view
@@ -0,0 +1,20 @@+-- |+-- Common Data Types+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf saml-core-2.0-os> §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
+ SAML2/Core/Identifiers.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- |+-- SAML-Defined Identifiers+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf saml-core-2.0-os> §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")
+ SAML2/Core/Namespaces.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleContexts #-}+-- |+-- Schema Organization and Namespaces+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf saml-core-2.0-os> §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
+ SAML2/Core/Protocols.hs view
@@ -0,0 +1,765 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- |+-- SAML Protocols+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf saml-core-2.0-os> §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
+ SAML2/Core/Signature.hs view
@@ -0,0 +1,55 @@+-- |+-- SAML and XML Signature Syntax and Processing+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf saml-core-2.0-os> §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
+ SAML2/Core/Versioning.hs view
@@ -0,0 +1,37 @@+-- |+-- SAML Versioning+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf saml-core-2.0-os> §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
+ SAML2/Lens.hs view
@@ -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)])
+ SAML2/Metadata.hs view
@@ -0,0 +1,34 @@+-- |+-- Metadata for the OASIS Security Assertion Markup Language (SAML) V2.0+--+-- <http://docs.oasis-open.org/security/saml/v2.0/saml-metadata-2.0-os.pdf saml-metadata-2.0-os>+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
+ SAML2/Metadata/Metadata.hs view
@@ -0,0 +1,471 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Metadata for SAML V2.0+-- +-- <http://docs.oasis-open.org/security/saml/v2.0/saml-metadata-2.0-os.pdf saml-metadata-2.0-os> §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)
+ SAML2/Profiles.hs view
@@ -0,0 +1,9 @@+-- |+-- Profiles for the OASIS Security Assertion Markup Language (SAML) V2.0+--+-- <https://docs.oasis-open.org/security/saml/v2.0/saml-profiles-2.0-os.pdf saml-profiles-2.0-os>+module SAML2.Profiles+  ( module SAML2.Profiles.ConfirmationMethod+  ) where++import SAML2.Profiles.ConfirmationMethod
+ SAML2/Profiles/ConfirmationMethod.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- |+-- Confirmation Method Identifiers+-- +-- <https://docs.oasis-open.org/security/saml/v2.0/saml-profiles-2.0-os.pdf saml-profiles-2.0-os> §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")
+ SAML2/XML.hs view
@@ -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
+ SAML2/XML/ASN1.hs view
@@ -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
+ SAML2/XML/Canonical.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+-- |+-- XML Canonicalization+--+-- For <http://www.w3.org/TR/2008/REC-xmldsig-core-20080610/> §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 <http://www.w3.org/TR/xml-c14n/ xml-c14n>+  | CanonicalXML11+    { canonicalWithComments :: Bool+    } -- ^§6.5.2 <http://www.w3.org/TR/xml-c14n11/ xml-c14n11>+  | CanonicalXMLExcl10+    { canonicalWithComments :: Bool+    } -- ^<http://www.w3.org/TR/xml-exc-c14n/ xml-exc-c14n>+  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
+ SAML2/XML/Encryption.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- |+-- XML Encryption Syntax and Processing+--+-- <http://www.w3.org/TR/xmlenc-core1/> (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))
+ SAML2/XML/LibXML2.hsc view
@@ -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 <libxml/parser.h>+#include <libxml/parser.h>+#include <libxml/c14n.h>++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 '&'   = ("&amp;"  ++)+  cq '<'   = ("&lt;"   ++)+  cq '>'   = ("&gt;"   ++)+  cq '\13' = ("&#xD;"  ++)+  cq c = (c:)+  aq '"'   = ("&quot;" ++)+  aq '\9'  = ("&#x9;"  ++)+  aq '\10' = ("&#xA;"  ++)+  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)
+ SAML2/XML/Schema.hs view
@@ -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" "" ""
+ SAML2/XML/Schema/Datatypes.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-}+-- |+-- XML Schema Datatypes+--+-- <http://www.w3.org/TR/2004/REC-xmlschema-2-20041028/> (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 [] }+
+ SAML2/XML/Signature.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE ViewPatterns #-}+-- |+-- XML Signature Syntax and Processing+--+-- <http://www.w3.org/TR/2008/REC-xmldsig-core-20080610/> (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::*"
+ SAML2/XML/Signature/Types.hs view
@@ -0,0 +1,613 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- |+-- XML Signature Syntax and Processing+--+-- <http://www.w3.org/TR/xmldsig-core1/> (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+    ]
+ SAML2/XML/Types.hs view
@@ -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/" "" ""
+ SAML2/XML/libxml2_stub.c view
@@ -0,0 +1,5 @@+#include <libxml/globals.h>++void xmlFree_stub(void *p) {+	return xmlFree(p);+}
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hsaml2.cabal view
@@ -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
+ test/Bindings/HTTPRedirect.hs view
@@ -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")+  ]
+ test/Main.hs view
@@ -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
+ test/Metadata/Metadata.hs view
@@ -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<fL\\x\183h\246o\230\166\STXrj]\196Z^\132)\206\&8e|+,T\204\219\251;\158T8\DC3\ACK\197\DC1\190\162{Y\250")+                  : [])+                : []))+              [ XEnc.EncryptionMethod +                (Identified XEnc.BlockEncryptionAES128GCM)+                Nothing Nothing Nothing []+              , XEnc.EncryptionMethod +                (Identified XEnc.BlockEncryptionAES192GCM)+                Nothing Nothing Nothing []+              , XEnc.EncryptionMethod +                (Identified XEnc.BlockEncryptionAES256GCM)+                Nothing Nothing Nothing []+              , XEnc.EncryptionMethod +                (Identified XEnc.BlockEncryptionAES128)+                Nothing Nothing Nothing []+              , XEnc.EncryptionMethod +                (Identified XEnc.BlockEncryptionAES192)+                Nothing Nothing Nothing []+              , XEnc.EncryptionMethod +                (Identified XEnc.BlockEncryptionAES256)+                Nothing Nothing Nothing []+              , XEnc.EncryptionMethod +                (Identified XEnc.BlockEncryptionTripleDES)+                Nothing Nothing Nothing []+              , XEnc.EncryptionMethod +                (Identified XEnc.KeyTransportRSAOAEP)+                Nothing Nothing Nothing []+              , XEnc.EncryptionMethod +                (Identified XEnc.KeyTransportRSAOAEPMGF1P)+                Nothing Nothing Nothing []+              ] +            ]+            Nothing [])+          (SSODescriptor +            [IndexedEndpoint +              (Endpoint +                (Identified BindingSOAP)+                (uri "https://accounts.osf.io/Shibboleth.sso/Artifact/SOAP")+                Nothing [] [])+              1+              False]+            [ Endpoint +              (Identified BindingSOAP)+              (uri "https://accounts.osf.io/Shibboleth.sso/SLO/SOAP")+              Nothing [] []+            , Endpoint +              (Identified BindingHTTPRedirect)+              (uri "https://accounts.osf.io/Shibboleth.sso/SLO/Redirect")+              Nothing [] []+            , Endpoint +              (Identified BindingHTTPPOST)+              (uri "https://accounts.osf.io/Shibboleth.sso/SLO/POST")+              Nothing [] []+            , Endpoint +              (Identified BindingHTTPArtifact)+              (uri "https://accounts.osf.io/Shibboleth.sso/SLO/Artifact")+              Nothing [] []+            ]+            [] [])+          False False+          (IndexedEndpoint +            (Endpoint +              (Identified BindingHTTPPOST)+              (uri "https://accounts.osf.io/Shibboleth.sso/SAML2/POST")+              Nothing [] [])+            1+            False+          :| IndexedEndpoint +            (Endpoint +              (Unidentified $ samlURN SAML20 ["bindings", "HTTP-POST-SimpleSign"])+              (uri "https://accounts.osf.io/Shibboleth.sso/SAML2/POST-SimpleSign")+              Nothing [] [])+            2+            False+          : IndexedEndpoint +            (Endpoint +              (Identified BindingHTTPArtifact)+              (uri "https://accounts.osf.io/Shibboleth.sso/SAML2/Artifact")+              Nothing [] [])+            3+            False+          : IndexedEndpoint +            (Endpoint +              (Identified BindingPAOS)+              (uri "https://accounts.osf.io/Shibboleth.sso/SAML2/ECP")+              Nothing [] [])+            4+            False+          : IndexedEndpoint +            (Endpoint +              (Unidentified $ samlURN SAML10 ["profiles", "browser-post"])+              (uri "https://accounts.osf.io/Shibboleth.sso/SAML/POST")+              Nothing [] [])+            5+            False+          : IndexedEndpoint +            (Endpoint +              (Unidentified $ samlURN SAML10 ["profiles", "artifact-01"])+              (uri "https://accounts.osf.io/Shibboleth.sso/SAML/Artifact")+              Nothing [] [])+            6+            False+          : [])+          []+        :| []))+      Nothing [] []++  , testXML "test/Metadata/metadata-nyu.xml" $+    EntityDescriptor+      (uri "urn:mace:incommon:nyu.edu")+      Nothing+      Nothing Nothing [] Nothing+      (Extensions [])+      (Descriptors+        (IDPSSODescriptor+          (RoleDescriptor +            Nothing Nothing Nothing+            [ uri "urn:mace:shibboleth:1.0"+            , samlURN SAML11 ["protocol"]+            , samlURN SAML20 ["protocol"]+            ]+            Nothing [] Nothing+            (Extensions [+              HXT.mkElement (HXT.mkQName "shibmd" "Scope" "urn:mace:shibboleth:metadata:1.0")+                [HXT.mkAttr (HXT.mkName "regexp") [HXT.mkText "false"]]+                [HXT.mkText "nyu.edu"]+            ])+            [ KeyDescriptor +              KeyTypeSigning+              (DS.KeyInfo +                Nothing+                (DS.X509Data +                  (DS.X509Certificate (either error id $ X509.decodeSignedObject+                    "0\130\ACKM0\130\ENQ5\160\ETX\STX\SOH\STX\STX\SOH|0\r\ACK\t*\134H\134\247\r\SOH\SOH\ENQ\ENQ\NUL0V1\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 Authority0\RS\ETB\r070116232303Z\ETB\r080116232303Z081\v0\t\ACK\ETXU\EOT\ACK\DC3\STXUS1\f0\n\ACK\ETXU\EOT\n\DC3\ETXNYU1\ESC0\EM\ACK\ETXU\EOT\ETX\DC3\DC2shibboleth.nyu.edu0\130\SOH\184\&0\130\SOH,\ACK\a*\134H\206\&8\EOT\SOH0\130\SOH\US\STX\129\129\NUL\253\DELS\129\GSu\DC2)R\223J\156.\236\228\231\246\DC1\183R<\239D\NUL\195\RS?\128\182Q&iE]@\"Q\251Y=\141X\250\191\197\245\186\&0\246\203\155Ul\215\129;\128\GS4o\242f`\183k\153P\165\164\159\159\232\EOT{\DLE\"\194O\187\169\215\254\183\198\ESC\248;W\231\198\168\166\NAK\SI\EOT\251\131\246\211\197\RS\195\STX5T\DC3Z\SYN\145\&2\246u\243\174+a\215*\239\242\"\ETX\EM\157\209H\SOH\199\STX\NAK\NUL\151`P\143\NAK#\v\204\178\146\185\130\162\235\132\v\240X\FS\245\STX\129\129\NUL\247\225\160\133\214\155=\222\203\188\171\\6\184W\185y\148\175\187\250:\234\130\249WL\v=\a\130gQYW\142\186\212YO\230q\a\DLE\129\128\180I\SYNq#\232L(\SYN\DC3\183\207\t2\140\200\166\225<\SYNz\139T|\141(\224\163\174\RS+\179\166u\145n\163\DEL\v\250!5b\241\251bz\SOH$;\204\164\241\190\168Q\144\137\168\131\223\225Z\229\159\ACK\146\139f^\128{U%d\SOHL;\254\207I*\ETX\129\133\NUL\STX\129\129\NUL\228b\190y]\216\187'\219M\226W\158\165x\141?\142s>\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<d\199D\230\162\198\139\251b\NAK\ETX\207\213waW\167\231\t,\152(\\\196\131y;6\157\248\253\211\232M\DC3\145\132\246\200Q\DEL\169I\150\151U\226u\\\239\139\186\DC3Dp\160'\191\239\165+\186OU\205\200\139J\"p\DC2?\228\184S\223\131\221\236\212\174p\215\FS\172\150k]\197\135z\GS\177\&14j\149H\238Z\169\152\206\166\129y;\242\169\223\211W\214+\244\243(\203Pk\172\215E%+\144q")+                  :| [])+                :| []))+              [] +            , KeyDescriptor +              KeyTypeSigning+              (DS.KeyInfo +                Nothing+                (DS.X509Data +                  (DS.X509Certificate (either error id $ X509.decodeSignedObject+                  "0\130\EOT\232\&0\130\ETX\208\160\ETX\STX\SOH\STX\STX\t\NUL\141\149\236\&9\165\128\180\&50\r\ACK\t*\134H\134\247\r\SOH\SOH\ENQ\ENQ\NUL0\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.edu0\RS\ETB\r120810213516Z\ETB\r220808213516Z0\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.edu0\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\223o\134\232\180\242Sp\195\194,7\167\204z\150\NUL\226Ezu\ACK\DLE\STX\247\221\DC3\179\ETX\175;o\189\197\131\189\133\158Xv>\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"]+        []+      ]+      []+  ]
+ test/XML.hs view
@@ -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
+ test/XML/Canonical.hs view
@@ -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+    "<?xml-stylesheet href=\"doc.xsl\"\n   type=\"text/xsl\"   ?>\n<doc>Hello, world!</doc>\n<?pi-without-data?>"+  , testC14N (CanonicalXML10 True) "test/XML/noncanonical1.xml" False+    "<?xml-stylesheet href=\"doc.xsl\"\n   type=\"text/xsl\"   ?>\n<doc>Hello, world!<!-- Comment 1 --></doc>\n<?pi-without-data?>\n<!-- Comment 2 -->\n<!-- Comment 3 -->"+  , testC14N (CanonicalXML10 False) "test/XML/noncanonical2.xml" False+    "<doc>\n   <clean>   </clean>\n   <dirty>   A   B   </dirty>\n   <mixed>\n      A\n      <clean>   </clean>\n      B\n      <dirty>   A   B   </dirty>\n      C\n   </mixed>\n</doc>"+  , testC14N (CanonicalXML10 False) "test/XML/noncanonical3.xml" False+    "<doc>\n   <e1></e1>\n   <e2></e2>\n   <e3 id=\"elem3\" name=\"elem3\"></e3>\n   <e4 id=\"elem4\" name=\"elem4\"></e4>\n   <e5 xmlns=\"http://example.org\" xmlns:a=\"http://www.w3.org\" xmlns:b=\"http://www.ietf.org\" attr=\"I'm\" attr2=\"all\" b:attr=\"sorted\" a:attr=\"out\"></e5>\n   <e6 xmlns:a=\"http://www.w3.org\">\n      <e7 xmlns=\"http://www.ietf.org\">\n         <e8 xmlns=\"\">\n            <e9 xmlns:a=\"http://www.ietf.org\" attr=\"default\"></e9>\n         </e8>\n      </e7>\n   </e6>\n</doc>"+  , testC14N (CanonicalXML10 False) "test/XML/noncanonical4.xml" False+    "<doc>\n   <text>First line&#xD;\nSecond line</text>\n   <value>2</value>\n   <compute>value&gt;\"0\" &amp;&amp; value&lt;\"10\" ?\"valid\":\"error\"</compute>\n   <compute expr=\"value>&quot;0&quot; &amp;&amp; value&lt;&quot;10&quot; ?&quot;valid&quot;:&quot;error&quot;\">valid</compute>\n   <norm attr=\" '    &#xD;&#xA;&#x9;   ' \"></norm>\n   <normNames attr=\"A &#xD;&#xA;&#x9; B\"></normNames>\n   <normId id=\"' &#xD;&#xA;&#x9; '\"></normId>\n</doc>"+  , testC14N (CanonicalXML10 False) "test/XML/noncanonical5.xml" True+    "<doc attrExtEnt=\"entExt\">\n   Hello, world!\n</doc>"+  , testC14N (CanonicalXML10 False) "test/XML/noncanonical6.xml" False+    "<doc>\194\169</doc>"+  -- , testC14N (CanonicalXML10 False) "test/XML/noncanonical7.xml"+  ]
+ test/XML/Encryption.hs view
@@ -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."]]+        :| [])++  ]
+ test/XML/Signature.hs view
@@ -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_")+          : [])+        : [])+      []+  ]
+ test/XML/encryption-example.xml view
@@ -0,0 +1,53 @@+<?xml version="1.0" encoding="UTF-8"?>+<EncryptedData Id="eg1" xmlns="http://www.w3.org/2001/04/xmlenc#"+               xmlns:ds="http://www.w3.org/2000/09/xmldsig#"+	       xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">+  <EncryptionMethod+   Algorithm="http://www.w3.org/2001/04/xmlenc#rsa-oaep-mgf1p">+      <KeySize>256</KeySize>+      <OAEPparams>9lWu3Q==</OAEPparams>+      <ds:DigestMethod+       Algorithm="http://www.w3.org/2000/09/xmldsig#sha1"/>+  </EncryptionMethod>+  <ds:KeyInfo>+    <ds:KeyName>Joseph</ds:KeyName>+    <ds:RetrievalMethod URI="http://exmample.org/Reagle/PublicKey"+      Type="http://www.w3.org/2001/04/xmlenc#EncryptedKey"/>+    <EncryptedKey>+      <EncryptionMethod Algorithm="http://www.w3.org/2001/04/xmlenc#tripledes-cbc"/>+      <CipherData>+        <CipherValue>qZk+NkcGgWq6PiVxeFDCbJzQ2J0=</CipherValue>+      </CipherData>+      <ReferenceList>+        <KeyReference URI="http://exmample.org/foo2"/>+        <DataReference URI="http://exmample.org/foo1"/>+      </ReferenceList>+    </EncryptedKey>+     <AgreementMethod Algorithm="example:Agreement/Algorithm">+       <KA-Nonce>Zm9v</KA-Nonce>+       <ds:DigestMethod+       Algorithm="http://www.w3.org/2000/09/xmldsig#sha1"/>+      <OriginatorKeyInfo>+         <ds:KeyValue><ds:RSAKeyValue> +               <ds:Modulus>cafebabe</ds:Modulus><ds:Exponent>cafebabe</ds:Exponent>+         </ds:RSAKeyValue></ds:KeyValue>+       </OriginatorKeyInfo>+       <RecipientKeyInfo>+         <ds:KeyValue><ds:RSAKeyValue> +               <ds:Modulus>cafebabe</ds:Modulus><ds:Exponent>cafebabe</ds:Exponent>+         </ds:RSAKeyValue></ds:KeyValue>+       </RecipientKeyInfo> +     </AgreementMethod>+  </ds:KeyInfo>+  <CipherData>+    <CipherReference URI="http://example.org/pgpkeys/reagle.b64">+      <Transforms>+        <ds:Transform Algorithm="http://www.w3.org/2000/09/xmldsig#base64"/>+      </Transforms>+    </CipherReference>+  </CipherData>+  <EncryptionProperties>+    <EncryptionProperty Target="#eg1" Id="ep2">+      <p xmlns="http://www.w3.org/1999/xhtml">This XML document tests the schema for ambigous content.</p>+    </EncryptionProperty></EncryptionProperties>+</EncryptedData>
+ test/XML/signature-example.xml view
@@ -0,0 +1,41 @@+<?xml version='1.0'?>+<Signature Id="MyFirstSignature" xmlns="http://www.w3.org/2000/09/xmldsig#">+  <SignedInfo> +	 <CanonicalizationMethod Algorithm="http://www.w3.org/TR/2001/REC-xml-c14n-20010315">+	 </CanonicalizationMethod>+	 <SignatureMethod Algorithm="http://www.w3.org/2000/09/xmldsig#dsa-sha1">+	 </SignatureMethod>+	 <Reference URI="http://www.w3.org/TR/xml-stylesheet/"> +		<Transforms> +		  <Transform Algorithm="http://www.w3.org/2000/09/xmldsig#base64"/>+		</Transforms> +		<DigestMethod Algorithm="http://www.w3.org/2000/09/xmldsig#sha1"> +		</DigestMethod>+		<DigestValue>j6lwx3rvEPO0vKtMup4NbeVu8nk=</DigestValue> +	 </Reference> +	 <Reference URI="http://www.w3.org/TR/REC-xml-names/"> +		<Transforms> +		  <Transform Algorithm="http://www.w3.org/2000/09/xmldsig#base64"/> +		</Transforms> +		<DigestMethod Algorithm="http://www.w3.org/2000/09/xmldsig#sha1"> +		</DigestMethod>+		<DigestValue>UrXLDLBIta6skoV5/A8Q38GEw44=</DigestValue> +	 </Reference> 	 +  </SignedInfo> +  <SignatureValue>MC0CFFrVLtRlkMc3Daon4BqqnkhCOlEaAhUAk8pH1iRNK+q1I+sisDTz2TFEALE=</SignatureValue> +  <KeyInfo>+    <KeyValue>+      <DSAKeyValue>+        <P>ABCD</P><Q>BBBBAAAA</Q><G></G><Y></Y>+      </DSAKeyValue> +    </KeyValue> +  </KeyInfo>+  <Object>+     <SignatureProperties>+        <SignatureProperty Target="#MyFirstSignature">+          <ts:timestamp xmlns:ts="http://www.example.org/rfc/rfcxxxx.txt">+           this is a test of the mixed content model</ts:timestamp>+        </SignatureProperty>+      </SignatureProperties>+  </Object>+</Signature>