diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2020 Michael B. Gale + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/src/Network/Wai/SAML2.hs b/src/Network/Wai/SAML2.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/SAML2.hs @@ -0,0 +1,190 @@ +-------------------------------------------------------------------------------- +-- SAML2 Middleware for WAI -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the MIT license found in the LICENSE -- +-- file in the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +-- | Implements WAI 'Middleware' for SAML2 service providers. Two different +-- interfaces are supported (with equivalent functionality): one which simply +-- stores the outcome of the validation process in the request vault and one +-- which passes the outcome to a callback. +module Network.Wai.SAML2 ( + -- * Callback-based middleware + -- + -- $callbackBasedMiddleware + saml2Callback, + + -- * Vault-based middleware + -- + -- $vaultBasedMiddleware + assertionKey, + errorKey, + saml2Vault, + + -- * Re-exports + module Network.Wai.SAML2.Config, + module Network.Wai.SAML2.Error, + module Network.Wai.SAML2.Assertion +) where + +-------------------------------------------------------------------------------- + +import qualified Data.Vault.Lazy as V + +import Network.Wai +import Network.Wai.Parse +import Network.Wai.SAML2.Config +import Network.Wai.SAML2.Validation +import Network.Wai.SAML2.Assertion +import Network.Wai.SAML2.Error + +import System.IO.Unsafe (unsafePerformIO) + +-------------------------------------------------------------------------------- + +-- | Checks whether the request method of @request@ is @"POST"@. +isPOST :: Request -> Bool +isPOST = (=="POST") . requestMethod + +-------------------------------------------------------------------------------- + +-- $callbackBasedMiddleware +-- +-- This 'Middleware' provides a SAML2 service provider (SP) implementation +-- that can be wrapped around an existing WAI 'Application'. The middleware is +-- parameterised over the SAML2 configuration and a callback. If the middleware +-- intercepts a request made to the endpoint given by the SAML2 configuration, +-- the result of validating the SAML2 response contained in the request body +-- will be passed to the callback. +-- +-- > saml2Callback cfg callback mainApp +-- > where callback (Left err) app req sendResponse = do +-- > -- a POST request was made to the assertion endpoint, but +-- > -- something went wrong, details of which are provided by +-- > -- the error: this should probably be logged as it may +-- > -- indicate that an attack was attempted against the +-- > -- endpoint, but you *must* not show the error +-- > -- to the client as it would severely compromise +-- > -- system security +-- > -- +-- > -- you may also want to return e.g. a HTTP 400 or 401 status +-- > +-- > callback (Right assertion) app req sendResponse = do +-- > -- a POST request was made to the assertion endpoint and the +-- > -- SAML2 response was successfully validated: +-- > -- you *must* check that you have not encountered the +-- > -- assertion ID before; we assume that there is a +-- > -- computation tryRetrieveAssertion which looks up +-- > -- assertions by ID in e.g. a database +-- > result <- tryRetrieveAssertion (assertionId assertion) +-- > +-- > case result of +-- > Just something -> -- a replay attack has occurred +-- > Nothing -> do +-- > -- store the assertion id somewhere +-- > storeAssertion (assertionId assertion) +-- > +-- > -- the assertion is valid and you can now e.g. +-- > -- retrieve user data from your database +-- > -- before proceeding with the request by e.g. +-- > -- redirecting them to the main view + +-- | 'saml2Callback' @config callback@ produces SAML2 'Middleware' for +-- the given @config@. If the middleware intercepts a request to the +-- endpoint given by @config@, the result will be passed to @callback@. +saml2Callback :: SAML2Config + -> (Either SAML2Error Assertion -> Middleware) + -> Middleware +saml2Callback cfg callback app req sendResponse = do + let path = rawPathInfo req + + -- check if we need to handle this request + if | path == saml2AssertionPath cfg && isPOST req -> do + -- default request parse options, but do not allow files; + -- we are not expecting any + let bodyOpts = setMaxRequestNumFiles 0 + $ setMaxRequestFileSize 0 + $ defaultParseRequestBodyOptions + + -- parse the request + (body, _) <- parseRequestBodyEx bodyOpts lbsBackEnd req + + case body of + -- extract the SAML response from the request body + [("SAMLResponse",val)] -> do + result <- validateResponse cfg val + + -- call the callback + callback result app req sendResponse + + -- the request does not contain the expected payload + _ -> callback (Left InvalidRequest) app req sendResponse + -- not one of the paths we need to handle, pass the request on to the + -- inner application + | otherwise -> app req sendResponse + +-------------------------------------------------------------------------------- + +-- $vaultBasedMiddleware +-- +-- This is a simpler-to-use 'Middleware' which stores the outcome of a request +-- made to the assertation endpoint in the request vault. The inner WAI +-- application can then check of the presence of an assertion or an error with +-- 'V.lookup' and 'assertionKey' or 'errorKey' respectively. At most one of +-- the two locations will be populated for a given request, i.e. it is not +-- possible for an assertion to be validated and an error to occur. +-- +-- > saml2Vault cfg $ \app req sendResponse -> do +-- > case V.lookup errorKey (vault req) of +-- > Just err -> +-- > -- log the error, but you *must* not show the error +-- > -- to the client as it would severely compromise +-- > -- system security +-- > Nothing -> pure () -- carry on +-- > +-- > case V.lookup assertionKey (vault req) of +-- > Nothing -> pure () -- carry on +-- > Just assertion -> do +-- > -- a valid assertion was processed by the middleware, +-- > -- you *must* check that you have not encountered the +-- > -- assertion ID before; we assume that there is a +-- > -- computation tryRetrieveAssertion which looks up +-- > -- assertions by ID in e.g. a database +-- > result <- tryRetrieveAssertion (assertionId assertion) +-- > +-- > case result of +-- > Just something -> -- a replay attack has occurred +-- > Nothing -> do +-- > -- store the assertion id somewhere +-- > storeAssertion (assertionId assertion) +-- > +-- > -- the assertion is valid + +-- | 'assertionKey' is a vault key for retrieving assertions from +-- request vaults if the 'saml2Vault' 'Middleware' is used. +assertionKey :: V.Key Assertion +assertionKey = unsafePerformIO V.newKey + +-- | 'errorKey' is a vault key for retrieving SAML2 errors from request vaults +-- if the 'saml2Vault' 'Middleware' is used. +errorKey :: V.Key SAML2Error +errorKey = unsafePerformIO V.newKey + +-- | 'saml2Vault' @config@ produces SAML2 'Middleware' for the given @config@. +saml2Vault :: SAML2Config -> Middleware +saml2Vault cfg = saml2Callback cfg callback + -- if the middleware intercepts a request containing a SAML2 response at + -- the configured endpoint, the outcome of processing response will be + -- passed to this callback: we store the result in the corresponding + -- entry in the request vault + where callback (Left err) app req sendResponse = do + app req{ + vault = V.insert errorKey err (vault req) + } sendResponse + callback (Right assertion) app req sendResponse = do + app req{ + vault = V.insert assertionKey assertion (vault req) + } sendResponse + +-------------------------------------------------------------------------------- diff --git a/src/Network/Wai/SAML2/Assertion.hs b/src/Network/Wai/SAML2/Assertion.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/SAML2/Assertion.hs @@ -0,0 +1,232 @@ +-------------------------------------------------------------------------------- +-- SAML2 Middleware for WAI -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the MIT license found in the LICENSE -- +-- file in the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +-- | Types to represent SAML2 assertions and functions to parse them from XML. +module Network.Wai.SAML2.Assertion ( + SubjectConfirmationMethod(..), + SubjectConfirmation(..), + Subject(..), + Conditions(..), + AuthnStatement(..), + AssertionAttribute(..), + AttributeStatement, + parseAttributeStatement, + Assertion(..) +) where + +-------------------------------------------------------------------------------- + +import Control.Monad + +import qualified Data.Text as T +import Data.Time + +import Text.XML.Cursor + +import Network.Wai.SAML2.XML + +-------------------------------------------------------------------------------- + +-- | Enumerates different subject confirmation methods. +-- See http://docs.oasis-open.org/security/saml/Post2.0/sstc-saml-tech-overview-2.0-cd-02.html#4.2.1.Subject%20Confirmation%20|outline +data SubjectConfirmationMethod + = HolderOfKey -- ^ urn:oasis:names:tc:SAML:2.0:cm:holder-of-key + | SenderVouches -- ^ urn:oasis:names:tc:SAML:2.0:cm:sender-vouches + | Bearer -- ^ urn:oasis:names:tc:SAML:2.0:cm:bearer + deriving (Eq, Show) + +instance FromXML SubjectConfirmationMethod where + parseXML cursor = case T.concat $ attribute "Method" cursor of + "urn:oasis:names:tc:SAML:2.0:cm:holder-of-key" -> pure HolderOfKey + "urn:oasis:names:tc:SAML:2.0:cm:sender-vouches" -> pure SenderVouches + "urn:oasis:names:tc:SAML:2.0:cm:bearer" -> pure Bearer + _ -> fail "Not a valid SubjectConfirmationMethod." + +-------------------------------------------------------------------------------- + +-- | Represents a subject confirmation record. +data SubjectConfirmation = SubjectConfirmation { + -- | The subject confirmation method used. + subjectConfirmationMethod :: !SubjectConfirmationMethod, + -- | The address of the subject. + subjectConfirmationAddress :: !T.Text, + -- | A timestamp. + subjectConfirmationNotOnOrAfter :: !UTCTime, + -- | The recipient. + subjectConfirmationRecipient :: !T.Text +} deriving (Eq, Show) + +instance FromXML SubjectConfirmation where + parseXML cursor = do + method <- parseXML cursor + + notOnOrAfter <- parseUTCTime $ T.concat $ + cursor $/ element (saml2Name "SubjectConfirmationData") + >=> attribute "NotOnOrAfter" + + pure SubjectConfirmation{ + subjectConfirmationMethod = method, + subjectConfirmationAddress = T.concat $ + cursor $/ element (saml2Name "SubjectConfirmationData") + >=> attribute "Address", + subjectConfirmationNotOnOrAfter = notOnOrAfter, + subjectConfirmationRecipient = T.concat $ + cursor $/ element (saml2Name "SubjectConfirmationData") + >=> attribute "Recipient" + } + +-- | The subject of the assertion. +data Subject = Subject { + -- | The list of subject confirmation elements, if any. + subjectConfirmations :: ![SubjectConfirmation] +} deriving (Eq, Show) + +instance FromXML Subject where + parseXML cursor = do + confirmations <- sequence $ + cursor $/ element (saml2Name "SubjectConfirmation") &| parseXML + + pure Subject{ + subjectConfirmations = confirmations + } + +-------------------------------------------------------------------------------- + +-- | Conditions under which a SAML assertion is issued. +data Conditions = Conditions { + -- | The time when the assertion is valid from (inclusive). + conditionsNotBefore :: !UTCTime, + -- | The time the assertion is valid to (not inclusive). + conditionsNotOnOrAfter :: !UTCTime, + -- | The intended audience of the assertion. + conditionsAudience :: !T.Text +} deriving (Eq, Show) + +instance FromXML Conditions where + parseXML cursor = do + notBefore <- parseUTCTime $ + T.concat $ attribute "NotBefore" cursor + notOnOrAfter <- parseUTCTime $ + T.concat $ attribute "NotOnOrAfter" cursor + + pure Conditions{ + conditionsNotBefore = notBefore, + conditionsNotOnOrAfter = notOnOrAfter, + conditionsAudience = T.concat $ + cursor $/ element (saml2Name "AudienceRestriction") + &/ element (saml2Name "Audience") + &/ content + } + +-------------------------------------------------------------------------------- + +-- | SAML2 authentication statements. +data AuthnStatement = AuthnStatement { + -- | The timestamp when the assertion was issued. + authnStatementInstant :: !UTCTime, + -- | The session index. + authnStatementSessionIndex :: !T.Text, + -- | The statement locality. + authnStatementLocality :: !T.Text +} deriving (Eq, Show) + +instance FromXML AuthnStatement where + parseXML cursor = do + issueInstant <- parseUTCTime $ + T.concat $ attribute "AuthnInstant" cursor + + pure AuthnStatement{ + authnStatementInstant = issueInstant, + authnStatementSessionIndex = T.concat $ + attribute "SessionIndex" cursor, + authnStatementLocality = T.concat $ + cursor $/ element (saml2Name "SubjectLocality") + >=> attribute "Address" + } + +-------------------------------------------------------------------------------- + +-- | SAML2 assertion attributes. +data AssertionAttribute = AssertionAttribute { + -- | The name of the attribute. + attributeName :: !T.Text, + -- | A friendly attribute name, if it exists. + attributeFriendlyName :: !(Maybe T.Text), + -- | The name format. + attributeNameFormat :: !T.Text, + -- | The value of the attribute. + attributeValue :: !T.Text +} deriving (Eq, Show) + +instance FromXML AssertionAttribute where + parseXML cursor = do + pure AssertionAttribute{ + attributeName = T.concat $ attribute "Name" cursor, + attributeFriendlyName = + toMaybeText $ attribute "FriendlyName" cursor, + attributeNameFormat = T.concat $ attribute "NameFormat" cursor, + attributeValue = T.concat $ + cursor $/ element (saml2Name "AttributeValue") &/ content + } + +-- | SAML2 assertion statements (collections of assertion attributes). +type AttributeStatement = [AssertionAttribute] + +-- | 'parseAttributeStatement' @cursor@ parses an 'AttributeStatement'. +parseAttributeStatement :: Cursor -> AttributeStatement +parseAttributeStatement cursor = + cursor $/ element (saml2Name "Attribute") >=> parseXML + +-------------------------------------------------------------------------------- + +-- | Represents a SAML2 assertion. +data Assertion = Assertion { + -- | The unique ID of this assertion. It is important to keep track of + -- these in order to avoid replay attacks. + assertionId :: !T.Text, + -- | The date and time when the assertion was issued. + assertionIssued :: !UTCTime, + -- | The name of the entity that issued this assertion. + assertionIssuer :: !T.Text, + -- | The subject of the assertion. + assertionSubject :: !Subject, + -- | The conditions under which the assertion is issued. + assertionConditions :: !Conditions, + -- | The authentication statement included in the assertion. + assertionAuthnStatement :: !AuthnStatement, + -- | The assertion's attribute statement. + assertionAttributeStatement :: !AttributeStatement +} deriving (Eq, Show) + +instance FromXML Assertion where + parseXML cursor = do + issueInstant <- parseUTCTime $ + T.concat $ attribute "IssueInstant" cursor + + subject <- oneOrFail "Subject is required" $ + cursor $/ element (saml2Name "Subject") >=> parseXML + + conditions <- oneOrFail "Conditions are required" $ + cursor $/ element (saml2Name "Conditions") >=> parseXML + + authnStatement <- oneOrFail "AuthnStatement is required" $ + cursor $/ element (saml2Name "AuthnStatement") >=> parseXML + + pure Assertion{ + assertionId = T.concat $ attribute "ID" cursor, + assertionIssued = issueInstant, + assertionIssuer = T.concat $ + cursor $/ element (saml2Name "Issuer") &/ content, + assertionSubject = subject, + assertionConditions = conditions, + assertionAuthnStatement = authnStatement, + assertionAttributeStatement = + cursor $/ element (saml2Name "AttributeStatement") + >=> parseAttributeStatement + } + +-------------------------------------------------------------------------------- diff --git a/src/Network/Wai/SAML2/C14N.hs b/src/Network/Wai/SAML2/C14N.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/SAML2/C14N.hs @@ -0,0 +1,44 @@ +-------------------------------------------------------------------------------- +-- SAML2 Middleware for WAI -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the MIT license found in the LICENSE -- +-- file in the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +-- | A high-level interface to XML canonicalisation for the purpose of +-- SAML2 signature validation. +module Network.Wai.SAML2.C14N ( + canonicalise +) where + +-------------------------------------------------------------------------------- + +import qualified Data.ByteString as BS + +import Foreign.C.Types + +import Text.XML.C14N + +-------------------------------------------------------------------------------- + +-- | 'canonicalise' @xml@ produces a canonical representation of @xml@. +canonicalise :: BS.ByteString -> IO BS.ByteString +canonicalise xml = c14n c14nOpts c14n_exclusive_1_0 [] False Nothing xml + +-- | The options we want to use for canonicalisation of XML documents. +c14nOpts :: [CInt] +c14nOpts = + [ xml_opt_noent + , xml_opt_dtdload + , xml_opt_dtdattr + -- disable network access + , xml_opt_nonet + -- compact small text nodes, this has no effect on the rendered output + , xml_opt_compact + -- suppress standard output; the function will still fail if + -- something goes wrong, but the reason won't be reported + , xml_opt_noerror + , xml_opt_nowarning + ] + +-------------------------------------------------------------------------------- diff --git a/src/Network/Wai/SAML2/Config.hs b/src/Network/Wai/SAML2/Config.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/SAML2/Config.hs @@ -0,0 +1,58 @@ +-------------------------------------------------------------------------------- +-- SAML2 Middleware for WAI -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the MIT license found in the LICENSE -- +-- file in the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +-- | Configuration types and smart constructors for the SAML2 middleware. +module Network.Wai.SAML2.Config ( + SAML2Config(..), + saml2Config +) where + +-------------------------------------------------------------------------------- + +import qualified Data.ByteString as BS +import qualified Data.Text as T +import Crypto.PubKey.RSA + +-------------------------------------------------------------------------------- + +-- | Represents configurations for the SAML2 middleware. +data SAML2Config = SAML2Config { + -- | The path relative to the root of the web application at which the + -- middleware should listen for SAML2 assertions (e.g. /sso/assert). + saml2AssertionPath :: !BS.ByteString, + -- | The service provider's private key, used to decrypt data from + -- the identity provider. + saml2PrivateKey :: !PrivateKey, + -- | The identity provider's public key, used to validate + -- signatures. + saml2PublicKey :: !PublicKey, + -- | The name of the entity we expect assertions from. If this is set + -- to 'Nothing', the issuer name is not validated. + saml2ExpectedIssuer :: !(Maybe T.Text), + -- | The URL we expect the SAML2 response to contain as destination. + saml2ExpectedDestination :: !(Maybe T.Text), + -- | A value indicating whether to disable time validity checks. This + -- should not be set to 'True' in a production environment, but may + -- be useful for testing purposes. + saml2DisableTimeValidation :: !Bool +} + +-- | 'saml2Config' @privateKey publicKey@ constructs a 'SAML2Config' value +-- with the most basic set of options possible using @privateKey@ as the +-- SP's private key and @publicKey@ as the IdP's public key. You should +-- almost certainly change the resulting settings. +saml2Config :: PrivateKey -> PublicKey -> SAML2Config +saml2Config privKey pubKey = SAML2Config{ + saml2AssertionPath = "/sso/assert", + saml2PrivateKey = privKey, + saml2PublicKey = pubKey, + saml2ExpectedIssuer = Nothing, + saml2ExpectedDestination = Nothing, + saml2DisableTimeValidation = False +} + +-------------------------------------------------------------------------------- diff --git a/src/Network/Wai/SAML2/Error.hs b/src/Network/Wai/SAML2/Error.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/SAML2/Error.hs @@ -0,0 +1,64 @@ +-------------------------------------------------------------------------------- +-- SAML2 Middleware for WAI -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the MIT license found in the LICENSE -- +-- file in the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +-- | SAML2-related errors. +module Network.Wai.SAML2.Error ( + SAML2Error(..) +) where + +-------------------------------------------------------------------------------- + +import Control.Exception + +import Crypto.Error +import Crypto.PubKey.RSA.Types as RSA + +import qualified Data.Text as T + +import Network.Wai.SAML2.StatusCode + +-------------------------------------------------------------------------------- + +-- | Enumerates errors that may arise in the SAML2 middleware. +data SAML2Error + -- | The response received from the client is not valid XML. + = InvalidResponseXml SomeException + -- | The assertion is not valid XML. + | InvalidAssertionXml SomeException + -- | The response is not a valid SAML2 response. + | InvalidResponse IOException + -- | The assertion is not a valid SAML2 assertion. + | InvalidAssertion IOException + -- | The issuer is not who we expected. + | InvalidIssuer T.Text + -- | The destination is not what we expected. + | UnexpectedDestination T.Text + -- | The reference ID is not what we expected. + | UnexpectedReference T.Text + -- | The response indicates a stuatus other than 'Success'. + | Unsuccessful StatusCode + -- | Failed to canonicalise some XML. + | CanonicalisationFailure IOException + -- | Unable to decrypt the AES key. + | DecryptionFailure RSA.Error + -- | The initialisation vector for a symmetric cipher is invalid. + | InvalidIV + -- | The padding for a blockcipher is invalid. + | InvalidPadding + -- | The signature is incorrect. + | InvalidSignature + -- | The digest is incorrect. + | InvalidDigest + -- | The assertion is not valid. + | NotValid + -- | A general crypto error occurred. + | CryptoError CryptoError + -- | The request made to the configured endpoint is not valid. + | InvalidRequest + deriving Show + +-------------------------------------------------------------------------------- diff --git a/src/Network/Wai/SAML2/KeyInfo.hs b/src/Network/Wai/SAML2/KeyInfo.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/SAML2/KeyInfo.hs @@ -0,0 +1,40 @@ +-------------------------------------------------------------------------------- +-- SAML2 Middleware for WAI -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the MIT license found in the LICENSE -- +-- file in the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +-- | Types to represent keys that are contained in SAML2 responses. +module Network.Wai.SAML2.KeyInfo ( + KeyInfo(..) +) where + +-------------------------------------------------------------------------------- + +import qualified Data.ByteString as BS +import qualified Data.Text as T +import Data.Text.Encoding + +import Text.XML.Cursor + +import Network.Wai.SAML2.XML + +-------------------------------------------------------------------------------- + +-- | Represents a key. +data KeyInfo = KeyInfo { + -- | The key data. + keyInfoCertificate :: BS.ByteString +} deriving (Eq, Show) + +instance FromXML KeyInfo where + parseXML cursor = pure KeyInfo{ + keyInfoCertificate = + encodeUtf8 $ T.concat $ cursor + $/ element (dsName "X509Data") + &/ element (dsName "X509Certificate") + &/ content + } + +-------------------------------------------------------------------------------- diff --git a/src/Network/Wai/SAML2/Response.hs b/src/Network/Wai/SAML2/Response.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/SAML2/Response.hs @@ -0,0 +1,115 @@ +-------------------------------------------------------------------------------- +-- SAML2 Middleware for WAI -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the MIT license found in the LICENSE -- +-- file in the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +-- | Types to reprsent SAML2 responses. +module Network.Wai.SAML2.Response ( + -- * SAML2 responses + Response(..), + removeSignature, + extractSignedInfo, + + -- * Re-exports + module Network.Wai.SAML2.StatusCode, + module Network.Wai.SAML2.Signature +) where + +-------------------------------------------------------------------------------- + +import qualified Data.Text as T +import Data.Time + +import Text.XML +import Text.XML.Cursor + +import Network.Wai.SAML2.XML +import Network.Wai.SAML2.XML.Encrypted +import Network.Wai.SAML2.StatusCode +import Network.Wai.SAML2.Signature + +-------------------------------------------------------------------------------- + +-- | Represents SAML2 responses. +data Response = Response { + -- | The intended destination of this response. + responseDestination :: !T.Text, + -- | The unique ID of the response. + responseId :: !T.Text, + -- | The timestamp when the response was issued. + responseIssueInstant :: !UTCTime, + -- | The SAML version. + responseVersion :: !T.Text, + -- | The name of the issuer. + responseIssuer :: !T.Text, + -- | The status of the response. + responseStatusCode :: !StatusCode, + -- | The response signature. + responseSignature :: !Signature, + -- | The (encrypted) assertion. + responseEncryptedAssertion :: !EncryptedAssertion +} deriving (Eq, Show) + +instance FromXML Response where + parseXML cursor = do + issueInstant <- parseUTCTime + $ T.concat + $ attribute "IssueInstant" cursor + + statusCode <- case parseXML cursor of + Nothing -> fail "Invalid status code" + Just sc -> pure sc + + encAssertion <- oneOrFail "EncryptedAssertion is required" + $ cursor + $/ element (saml2Name "EncryptedAssertion") + &/ element (xencName "EncryptedData") + >=> parseXML + + signature <- oneOrFail "Signature is required" $ + cursor $/ element (dsName "Signature") >=> parseXML + + pure Response{ + responseDestination = T.concat $ attribute "Destination" cursor, + responseId = T.concat $ attribute "ID" cursor, + responseIssueInstant = issueInstant, + responseVersion = T.concat $ attribute "Version" cursor, + responseIssuer = T.concat $ + cursor $/ element (saml2Name "Issuer") &/ content, + responseStatusCode = statusCode, + responseSignature = signature, + responseEncryptedAssertion = encAssertion + } + +-------------------------------------------------------------------------------- + +-- | Returns 'True' if the argument is not a @@ element. +isNotSignature :: Node -> Bool +isNotSignature (NodeElement e) = elementName e /= dsName "Signature" +isNotSignature _ = True + +-- | 'removeSignature' @document@ removes all @@ elements from +-- @document@ and returns the resulting document. +removeSignature :: Document -> Document +removeSignature (Document prologue root misc) = + let Element n attr ns = root + in Document prologue (Element n attr (filter isNotSignature ns)) misc + +-- | Returns all nodes at @cursor@. +nodes :: Cursor -> [Node] +nodes = pure . node + +-- | 'extractSignedInfo' @cursor@ extracts the SignedInfo element from the +-- document reprsented by @cursor@. +extractSignedInfo :: MonadFail m => Cursor -> m Element +extractSignedInfo cursor = do + NodeElement signedInfo <- oneOrFail "SignedInfo is required" + $ cursor + $/ element (dsName "Signature") + &/ element (dsName "SignedInfo") + >=> nodes + pure signedInfo + +-------------------------------------------------------------------------------- diff --git a/src/Network/Wai/SAML2/Signature.hs b/src/Network/Wai/SAML2/Signature.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/SAML2/Signature.hs @@ -0,0 +1,159 @@ +-------------------------------------------------------------------------------- +-- SAML2 Middleware for WAI -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the MIT license found in the LICENSE -- +-- file in the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +-- | SAML2 signatures. +module Network.Wai.SAML2.Signature ( + CanonicalisationMethod(..), + SignatureMethod(..), + DigestMethod(..), + SignedInfo(..), + Reference(..), + Signature(..) +) where + +-------------------------------------------------------------------------------- + +import qualified Data.ByteString as BS +import qualified Data.Text as T +import Data.Text.Encoding + +import Text.XML.Cursor + +import Network.Wai.SAML2.XML + +-------------------------------------------------------------------------------- + +-- | Enumerates XML canonicalisation methods. +data CanonicalisationMethod + -- | Original C14N 1.0 specification. + = C14N_1_0 + -- | Exclusive C14N 1.0 specification. + | C14N_EXC_1_0 + -- | C14N 1.1 specification. + | C14N_1_1 + deriving (Eq, Show) + +instance FromXML CanonicalisationMethod where + parseXML cursor = + case T.concat $ attribute "Algorithm" cursor of + "http://www.w3.org/2001/10/xml-exc-c14n#" -> pure C14N_EXC_1_0 + _ -> fail "Not a valid CanonicalisationMethod" + +-- | Enumerates signature methods. +data SignatureMethod + -- | RSA with SHA256 digest + = RSA_SHA256 + deriving (Eq, Show) + +instance FromXML SignatureMethod where + parseXML cursor = case T.concat $ attribute "Algorithm" cursor of + "http://www.w3.org/2001/04/xmldsig-more#rsa-sha256" -> pure RSA_SHA256 + _ -> fail "Not a valid SignatureMethod" + +-------------------------------------------------------------------------------- + +-- | Enumerates digest methods. +data DigestMethod + -- | SHA256 + = DigestSHA256 + deriving (Eq, Show) + +instance FromXML DigestMethod where + parseXML cursor = case T.concat $ attribute "Algorithm" cursor of + "http://www.w3.org/2001/04/xmlenc#sha256" -> pure DigestSHA256 + _ -> fail "Not a valid DigestMethod" + +-- | Represents a reference to some entity along with a digest of it. +data Reference = Reference { + -- | The URI of the entity that is referenced. + referenceURI :: !T.Text, + -- | The method that was used to calculate the digest for the + -- entity that is referenced. + referenceDigestMethod :: !DigestMethod, + -- | The digest of the entity that was calculated by the IdP. + referenceDigestValue :: !BS.ByteString +} deriving (Eq, Show) + +instance FromXML Reference where + parseXML cursor = do + -- the reference starts with a #, drop it + let uri = T.drop 1 $ T.concat $ attribute "URI" cursor + + digestMethod <- oneOrFail "DigestMethod is required" $ + cursor $/ element (dsName "DigestMethod") + >=> parseXML + + let digestValue = encodeUtf8 $ T.concat $ + cursor $/ element (dsName "DigestValue") &/ content + + pure Reference{ + referenceURI = uri, + referenceDigestMethod = digestMethod, + referenceDigestValue = digestValue + } + +-------------------------------------------------------------------------------- + +-- | Represents references to some entities for which the IdP has calculated +-- digests. The 'SignedInfo' component is then signed by the IdP. +data SignedInfo = SignedInfo { + -- | The XML canonicalisation method used. + signedInfoCanonicalisationMethod :: !CanonicalisationMethod, + -- | The method used to compute the signature for the referenced entity. + signedInfoSignatureMethod :: !SignatureMethod, + -- | The reference to some entity, along with a digest. + signedInfoReference :: !Reference +} deriving (Eq, Show) + +instance FromXML SignedInfo where + parseXML cursor = do + canonicalisationMethod <- + oneOrFail "CanonicalizationMethod is required" + $ cursor + $/ element (dsName "CanonicalizationMethod") + >=> parseXML + + signatureMethod <- + oneOrFail "SignatureMethod is required" + $ cursor + $/ element (dsName "SignatureMethod") + >=> parseXML + + reference <- + oneOrFail "Reference is required" + $ cursor + $/ element (dsName "Reference") + >=> parseXML + + pure SignedInfo{ + signedInfoCanonicalisationMethod = canonicalisationMethod, + signedInfoSignatureMethod = signatureMethod, + signedInfoReference = reference + } + +-- | Represents response signatures. +data Signature = Signature { + -- | Information about the data for which the IdP has computed digests. + signatureInfo :: !SignedInfo, + -- | The signature of the 'SignedInfo' value. + signatureValue :: !BS.ByteString +} deriving (Eq, Show) + +instance FromXML Signature where + parseXML cursor = do + info <- oneOrFail "SignedInfo is required" $ + cursor $/ element (dsName "SignedInfo") >=> parseXML + + let value = encodeUtf8 $ T.concat $ + cursor $/ element (dsName "SignatureValue") &/ content + + pure Signature{ + signatureInfo = info, + signatureValue = value + } + +-------------------------------------------------------------------------------- diff --git a/src/Network/Wai/SAML2/StatusCode.hs b/src/Network/Wai/SAML2/StatusCode.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/SAML2/StatusCode.hs @@ -0,0 +1,43 @@ +-------------------------------------------------------------------------------- +-- SAML2 Middleware for WAI -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the MIT license found in the LICENSE -- +-- file in the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +-- | SAML2 status codes. +module Network.Wai.SAML2.StatusCode ( + StatusCode(..) +) where + +-------------------------------------------------------------------------------- + +import Control.Monad + +import qualified Data.Text as T + +import Text.XML.Cursor + +import Network.Wai.SAML2.XML + +-------------------------------------------------------------------------------- + +-- | Enumerates SAML2 status codes. +data StatusCode + -- | The response indicates success! + = Success + deriving (Eq, Show) + +instance FromXML StatusCode where + parseXML cursor = + let value = T.concat + $ cursor + $/ element (saml2pName "Status") + &/ element (saml2pName "StatusCode") + >=> attribute "Value" + in case value of + "urn:oasis:names:tc:SAML:2.0:status:Success" -> pure Success + _ -> fail "Not a valid status code." + + +-------------------------------------------------------------------------------- diff --git a/src/Network/Wai/SAML2/Validation.hs b/src/Network/Wai/SAML2/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/SAML2/Validation.hs @@ -0,0 +1,259 @@ +-------------------------------------------------------------------------------- +-- SAML2 Middleware for WAI -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the MIT license found in the LICENSE -- +-- file in the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +-- | Functions to process and validate SAML2 respones. +module Network.Wai.SAML2.Validation ( + validateResponse, + ansiX923 +) where + +-------------------------------------------------------------------------------- + +import Control.Exception +import Control.Monad.Except + +import Crypto.Error +import Crypto.Hash +import qualified Crypto.PubKey.RSA.OAEP as OAEP +import Crypto.PubKey.RSA.PKCS15 as PKCS15 +import Crypto.Cipher.AES +import Crypto.Cipher.Types + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Default.Class +import Data.Time + +import Network.Wai.SAML2.XML.Encrypted +import Network.Wai.SAML2.Config +import Network.Wai.SAML2.Error +import Network.Wai.SAML2.XML +import Network.Wai.SAML2.C14N +import Network.Wai.SAML2.Response +import Network.Wai.SAML2.Assertion + +import qualified Text.XML as XML +import qualified Text.XML.Cursor as XML + +-------------------------------------------------------------------------------- + +-- | 'validateResponse' @cfg responseData@ validates a SAML2 response contained +-- in Base64-encoded @responseData@. +validateResponse :: SAML2Config + -> BS.ByteString + -> IO (Either SAML2Error Assertion) +validateResponse cfg responseData = runExceptT $ do + -- get the current time + now <- liftIO $ getCurrentTime + + -- the response data is Base64-encoded; decode it + let resXmlDocData = BS.decodeLenient responseData + + -- try to parse the XML document; throw an exception if it is not + -- a valid XML document + responseXmlDoc <- case XML.parseLBS def (LBS.fromStrict resXmlDocData) of + Left err -> throwError $ InvalidResponseXml err + Right responseXmlDoc -> pure responseXmlDoc + + -- try to parse the XML document into a structured SAML2 response + resParseResult <- liftIO $ try $ + parseXML (XML.fromDocument responseXmlDoc) + + samlResponse <- case resParseResult of + Left err -> throwError $ InvalidResponse err + Right samlResponse -> pure samlResponse + + -- check that the response indicates success + case responseStatusCode samlResponse of + Success -> pure () + status -> throwError $ Unsuccessful status + + -- check that the destination is as expected, if the configuration + -- expects us to validate this + let destination = responseDestination samlResponse + + case saml2ExpectedDestination cfg of + Just expectedDestination + | destination /= expectedDestination -> + throwError $ UnexpectedDestination destination + _ -> pure () + + -- check that the issuer is as expected, if the configuration + -- expects us to validate this + let issuer = responseIssuer samlResponse + + case saml2ExpectedIssuer cfg of + Just expectedIssuer + | issuer /= expectedIssuer -> throwError $ InvalidIssuer issuer + _ -> pure () + + -- ***CORE VALIDATION*** + -- See https://www.w3.org/TR/xmldsig-core1/#sec-CoreValidation + -- + -- *REFERENCE VALIDATION* + -- 1. We extract the SignedInfo element from the SAML2 response's + -- Signature element. This element contains + signedInfo <- extractSignedInfo (XML.fromDocument responseXmlDoc) + + -- construct a new XML document from the SignedInfo element and render + -- it into a textual representation + let doc = XML.Document (XML.Prologue [] Nothing []) signedInfo [] + let signedInfoXml = XML.renderLBS def doc + + -- canonicalise the textual representation of the SignedInfo element + signedInfoCanonResult <- liftIO $ try $ + canonicalise (LBS.toStrict signedInfoXml) + + normalisedSignedInfo <- case signedInfoCanonResult of + Left err -> throwError $ CanonicalisationFailure err + Right result -> pure result + + -- 2. At this point we should dereference all elements identified by + -- Reference elements inside the SignedInfo element. However, we do + -- not currently do that and instead just assume that there is only + -- one Reference element which targets the overall Response. + -- We sanity check this, just in case we are wrong since we do not + -- want an attacker to be able to exploit this. + let documentId = responseId samlResponse + let referenceId = referenceURI + $ signedInfoReference + $ signatureInfo + $ responseSignature samlResponse + + if documentId /= referenceId + then throwError $ UnexpectedReference referenceId + else pure () + + -- Now that we have sanity checked that we should indeed validate + -- the entire Response, we need to remove the Signature element + -- from it (since the Response cannot possibly have been hashed with + -- the Signature element present). First remove the Signature element: + let docMinusSignature = removeSignature responseXmlDoc + + -- then render the resulting document and canonicalise it + let renderedXml = XML.renderLBS def docMinusSignature + refCanonResult <- liftIO $ try $ canonicalise (LBS.toStrict renderedXml) + + normalised <- case refCanonResult of + Left err -> throwError $ CanonicalisationFailure err + Right result -> pure result + + -- next, compute the hash for the normalised document and extract the + -- existing hash from the response; both hash values must be the same + -- or the response has been tampered with; if both hashes are the same, + -- then the response has not been tampered with, assuming that the + -- Signature has not been tampered with, which we validate next + let documentHash = hashWith SHA256 normalised + let referenceHash = digestFromByteString + $ BS.decodeLenient + $ referenceDigestValue + $ signedInfoReference + $ signatureInfo + $ responseSignature samlResponse + + if Just documentHash /= referenceHash + then throwError InvalidDigest + else pure () + + -- *SIGNATURE VALIDATION* + -- We need to check that the SignedInfo element has not been tampered + -- with, which we do by checking the signature contained in the response; + -- first: extract the signature data from the response + let sig = BS.decodeLenient $ signatureValue $ responseSignature samlResponse + + -- using the IdP's public key and the canonicalised SignedInfo element, + -- check that the signature is correct + let pubKey = saml2PublicKey cfg + + if PKCS15.verify (Just SHA256) pubKey normalisedSignedInfo sig + then pure () + else throwError InvalidSignature + + -- ***ASSERTION DECRYPTION*** + -- the SAML assertion is AES-encrypted and we need to acquire the key + -- to decrypt it; the key itself is RSA-encrypted: + -- get the private key from the configuration and use it to decrypt + -- the key used to decrypt the assertion + let pk = saml2PrivateKey cfg + let encryptedAssertion = responseEncryptedAssertion samlResponse + + oaepResult <- liftIO $ OAEP.decryptSafer (OAEP.defaultOAEPParams SHA1) pk + $ BS.decodeLenient + $ cipherValue + $ encryptedKeyCipher + $ encryptedAssertionKey + $ encryptedAssertion + + aesKey <- case oaepResult of + Left err -> throwError $ DecryptionFailure err + Right cipherData -> pure cipherData + + -- next we can decrypt the assertion; initialise AES128 with + -- the key we have just decrypted + xmlData <- case cipherInit aesKey of + CryptoFailed err -> throwError $ CryptoError err + CryptoPassed aes128 -> do + -- get the AES ciphertext + let cipherText = BS.decodeLenient + $ cipherValue + $ encryptedAssertionCipher + $ encryptedAssertion + + -- the IV used for AES is 128bits (16 bytes) prepended + -- to the ciphertext + let (ivBytes, xmlBytes) = BS.splitAt 16 cipherText + + -- convert the bytes into the IV + case makeIV ivBytes of + Nothing -> throwError InvalidIV + Just iv -> do + -- run AES to decrypt the assertion + let plaintext = cbcDecrypt (aes128 :: AES128) iv xmlBytes + + -- remove padding from the plaintext + case ansiX923 plaintext of + Nothing -> throwError InvalidPadding + Just xmlData -> pure xmlData + + -- try to parse the assertion that we decrypted earlier + assertion <- case XML.parseLBS def (LBS.fromStrict xmlData) of + Left err -> throwError $ InvalidAssertionXml err + Right assertDoc -> do + -- try to convert the assertion document into a more + -- structured representation + assertParseResult <- liftIO $ try $ + parseXML (XML.fromDocument assertDoc) + + case assertParseResult of + Left err -> throwError $ InvalidAssertion err + Right assertion -> pure assertion + + -- validate that the assertion is valid at this point in time + let Conditions{..} = assertionConditions assertion + + if (now < conditionsNotBefore || now >= conditionsNotOnOrAfter) && + not (saml2DisableTimeValidation cfg) + then throwError NotValid + else pure () + + -- all checks out, return the assertion + pure assertion + +-- | 'ansiX923' @plaintext@ removes ANSI X9.23 padding from @plaintext@. +-- See https://en.wikipedia.org/wiki/Padding_(cryptography)#ANSI_X9.23 +ansiX923 :: BS.ByteString -> Maybe BS.ByteString +ansiX923 d + | len == 0 = Nothing + | padLen < 1 || padLen > len = Nothing + | otherwise = Just content + where len = BS.length d + padBytes = BS.index d (len-1) + padLen = fromIntegral padBytes + (content,_) = BS.splitAt (len - padLen) d + +-------------------------------------------------------------------------------- diff --git a/src/Network/Wai/SAML2/XML.hs b/src/Network/Wai/SAML2/XML.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/SAML2/XML.hs @@ -0,0 +1,85 @@ +-------------------------------------------------------------------------------- +-- SAML2 Middleware for WAI -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the MIT license found in the LICENSE -- +-- file in the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +-- | Utility functions related to XML parsing. +module Network.Wai.SAML2.XML ( + -- * Namespaces + saml2Name, + saml2pName, + xencName, + dsName, + + -- * Utility functions + toMaybeText, + parseUTCTime, + + -- * XML parsing + FromXML(..), + oneOrFail +) where + +-------------------------------------------------------------------------------- + +import qualified Data.Text as T +import Data.Time + +import Text.XML +import Text.XML.Cursor + +-------------------------------------------------------------------------------- + +-- | 'saml2Name' @name@ constructs a 'Name' for @name@ in the +-- urn:oasis:names:tc:SAML:2.0:assertion namespace. +saml2Name :: T.Text -> Name +saml2Name name = + Name name (Just "urn:oasis:names:tc:SAML:2.0:assertion") (Just "saml2") + +-- | 'saml2pName' @name@ constructs a 'Name' for @name@ in the +-- urn:oasis:names:tc:SAML:2.0:protocol namespace. +saml2pName :: T.Text -> Name +saml2pName name = + Name name (Just "urn:oasis:names:tc:SAML:2.0:protocol") (Just "saml2p") + +-- | 'xencName' @name@ constructs a 'Name' for @name@ in the +-- http://www.w3.org/2001/04/xmlenc# namespace. +xencName :: T.Text -> Name +xencName name = + Name name (Just "http://www.w3.org/2001/04/xmlenc#") (Just "xenc") + +-- | 'dsName' @name@ constructs a 'Name' for @name@ in the +-- http://www.w3.org/2000/09/xmldsig# namespace. +dsName :: T.Text -> Name +dsName name = + Name name (Just "http://www.w3.org/2000/09/xmldsig#") (Just "ds") + +-- | 'toMaybeText' @xs@ returns 'Nothing' if @xs@ is the empty list, or +-- the result of concatenating @xs@ wrapped in 'Just' otherwise. +toMaybeText :: [T.Text] -> Maybe T.Text +toMaybeText [] = Nothing +toMaybeText xs = Just $ T.concat xs + +-- | The time format used by SAML2. +timeFormat :: String +timeFormat = "%Y-%m-%dT%H:%M:%S%QZ" + +-- | 'parseUTCTime' @text@ parses @text@ into a 'UTCTime' value. +parseUTCTime :: MonadFail m => T.Text -> m UTCTime +parseUTCTime value = + parseTimeM False defaultTimeLocale timeFormat (T.unpack value) + +-- | A class of types which can be parsed from XML. +class FromXML a where + parseXML :: MonadFail m => Cursor -> m a + +-- | 'oneOrFail' @message xs@ throws an 'XMLException' with @message@ if +-- @xs@ is the empty list. If @xs@ has at least one element, the first is +-- returned and all others are discarded. +oneOrFail :: MonadFail m => String -> [a] -> m a +oneOrFail err [] = fail err +oneOrFail _ (x:_) = pure x + +-------------------------------------------------------------------------------- diff --git a/src/Network/Wai/SAML2/XML/Encrypted.hs b/src/Network/Wai/SAML2/XML/Encrypted.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/SAML2/XML/Encrypted.hs @@ -0,0 +1,138 @@ +-------------------------------------------------------------------------------- +-- SAML2 Middleware for WAI -- +-------------------------------------------------------------------------------- +-- This source code is licensed under the MIT license found in the LICENSE -- +-- file in the root directory of this source tree. -- +-------------------------------------------------------------------------------- + +-- | Types representing elements of the encrypted XML standard. +-- See https://www.w3.org/TR/2002/REC-xmlenc-core-20021210/Overview.html +module Network.Wai.SAML2.XML.Encrypted ( + CipherData(..), + EncryptionMethod(..), + EncryptedKey(..), + EncryptedAssertion(..) +) where + +-------------------------------------------------------------------------------- + +import qualified Data.Text as T +import Data.Text.Encoding +import qualified Data.ByteString as BS + +import Text.XML.Cursor + +import Network.Wai.SAML2.XML +import Network.Wai.SAML2.KeyInfo + +-------------------------------------------------------------------------------- + +-- | Represents some ciphertext. +data CipherData = CipherData { + cipherValue :: !BS.ByteString +} deriving (Eq, Show) + +instance FromXML CipherData where + parseXML cursor = pure CipherData{ + cipherValue = encodeUtf8 + $ T.concat + $ cursor + $/ element (xencName "CipherValue") + &/ content + } + +-------------------------------------------------------------------------------- + +-- | Describes an encryption method. +data EncryptionMethod = EncryptionMethod { + -- | The name of the algorithm. + encryptionMethodAlgorithm :: !T.Text, + -- | The name of the digest algorithm, if any. + encryptionMethodDigestAlgorithm :: !(Maybe T.Text) +} deriving (Eq, Show) + +instance FromXML EncryptionMethod where + parseXML cursor = pure EncryptionMethod{ + encryptionMethodAlgorithm = + T.concat $ attribute "Algorithm" cursor, + encryptionMethodDigestAlgorithm = + toMaybeText $ cursor + $/ element (dsName "DigestMethod") + >=> attribute "Algorithm" + } + +-------------------------------------------------------------------------------- + +-- | Represents an encrypted key. +data EncryptedKey = EncryptedKey { + -- | The ID of the key. + encryptedKeyId :: !T.Text, + -- | The intended recipient of the key. + encryptedKeyRecipient :: !T.Text, + -- | The method used to encrypt the key. + encryptedKeyMethod :: !EncryptionMethod, + -- | The key data. + encryptedKeyData :: !KeyInfo, + -- | The ciphertext. + encryptedKeyCipher :: !CipherData +} deriving (Eq, Show) + +instance FromXML EncryptedKey where + parseXML cursor = do + method <- oneOrFail "EncryptionMethod is required" $ + cursor $/ element (xencName "EncryptionMethod") + >=> parseXML + + keyData <- oneOrFail "KeyInfo is required" $ + cursor $/ element (dsName "KeyInfo") + >=> parseXML + + cipher <- oneOrFail "CipherData is required" $ + cursor $/ element (xencName "CipherData") + >=> parseXML + + pure EncryptedKey{ + encryptedKeyId = T.concat $ attribute "Id" cursor, + encryptedKeyRecipient = T.concat $ attribute "Recipient" cursor, + encryptedKeyMethod = method, + encryptedKeyData = keyData, + encryptedKeyCipher = cipher + } + +-------------------------------------------------------------------------------- + +-- | Represents an encrypted SAML assertion. +data EncryptedAssertion = EncryptedAssertion { + -- | Information about the encryption method used. + encryptedAssertionAlgorithm :: !EncryptionMethod, + -- | The encrypted key. + encryptedAssertionKey :: !EncryptedKey, + -- | The ciphertext. + encryptedAssertionCipher :: !CipherData +} deriving (Eq, Show) + +instance FromXML EncryptedAssertion where + parseXML cursor = do + algorithm <- oneOrFail "Algorithm is required" + $ cursor + $/ element (xencName "EncryptionMethod") + >=> parseXML + + keyInfo <- oneOrFail "KeyInfo is required" + $ cursor + $/ element (dsName "KeyInfo") + &/ element (xencName "EncryptedKey") + >=> parseXML + + cipher <- oneOrFail "CipherData is required" + $ cursor + $/ element (xencName "CipherData") + >=> parseXML + + pure EncryptedAssertion{ + encryptedAssertionAlgorithm = algorithm, + encryptedAssertionKey = keyInfo, + encryptedAssertionCipher = cipher + } + +-------------------------------------------------------------------------------- diff --git a/wai-saml2.cabal b/wai-saml2.cabal new file mode 100644 --- /dev/null +++ b/wai-saml2.cabal @@ -0,0 +1,66 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: c0664fef77f28dfe3a12d2dfaff84d77d236c7b0b2641d4da57a4889dce066f1 + +name: wai-saml2 +version: 0.1.0.0 +synopsis: SAML2 assertion validation as WAI middleware +description: A Haskell library which implements SAML2 assertion validation as WAI middleware +category: Security +homepage: https://github.com/mbg/wai-saml2#readme +bug-reports: https://github.com/mbg/wai-saml2/issues +author: Michael B. Gale +maintainer: m.gale@warwick.ac.uk +copyright: Copyright (c) Michael B. Gale +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/mbg/wai-saml2 + +library + exposed-modules: + Network.Wai.SAML2 + Network.Wai.SAML2.Assertion + Network.Wai.SAML2.C14N + Network.Wai.SAML2.Config + Network.Wai.SAML2.Error + Network.Wai.SAML2.KeyInfo + Network.Wai.SAML2.Response + Network.Wai.SAML2.Signature + Network.Wai.SAML2.StatusCode + Network.Wai.SAML2.Validation + Network.Wai.SAML2.XML + Network.Wai.SAML2.XML.Encrypted + other-modules: + Paths_wai_saml2 + hs-source-dirs: + src + default-extensions: OverloadedStrings MultiWayIf RecordWildCards FlexibleInstances + ghc-options: -W + build-depends: + base >=4.8 && <5 + , base64-bytestring >=0.1 && <2 + , bytestring >=0.9 && <0.11 + , c14n >=0.1.0.1 && <1 + , cryptonite <1 + , data-default-class <1 + , http-types <1 + , mtl >=2.2.1 && <3 + , text <2 + , time >=1.9 && <2 + , vault >=0.3 && <1 + , wai >=3.0 && <4 + , wai-extra >=3.0 && <4 + , x509 <2 + , x509-store <2 + , xml-conduit <2 + default-language: Haskell2010