hsaml2 0.1.1 → 0.1.2
raw patch · 6 files changed
+117/−71 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- SAML2/Bindings/HTTPRedirect.hs +1/−1
- SAML2/XML/Signature.hs +3/−4
- hsaml2.cabal +3/−1
- test/Bindings/HTTPRedirect.hs +42/−32
- test/XML/Keys.hs +47/−0
- test/XML/Signature.hs +21/−33
SAML2/Bindings/HTTPRedirect.hs view
@@ -98,8 +98,8 @@ 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)+ (snd pq <> foldMap (BSC.cons '&' . snd) rsq <> BSC.cons '&' sas) unless (SAMLP.protocolDestination (p ^. SAMLP.samlProtocol') == Just ru{ uriQuery = "" }) $ fail "Destination incorrect" Nothing -> return ()
SAML2/XML/Signature.hs view
@@ -172,7 +172,7 @@ 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+verifyBase64 pk alg sig m = either (const $ Just False) (\s -> verifyBytes pk alg s m) $ Base64.decode sig generateSignature :: SigningKey -> SignedInfo -> IO Signature generateSignature sk si = do@@ -203,9 +203,8 @@ 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)- verified :: Maybe Bool- verified = verifyBytes keys (signatureMethodAlgorithm $ signedInfoSignatureMethod si) (signatureValue $ signatureSignatureValue s) six+ let verified :: Maybe Bool+ verified = verifyBytes pks (signatureMethodAlgorithm $ signedInfoSignatureMethod si) (signatureValue $ signatureSignatureValue s) six valid :: Bool valid = elem (Just xid) rl && all isJust rl return $ (valid &&) <$> verified
hsaml2.cabal view
@@ -1,5 +1,5 @@ name: hsaml2-version: 0.1.1+version: 0.1.2 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@@ -104,6 +104,7 @@ Metadata.Metadata XML XML.Canonical+ XML.Keys XML.Encryption XML.Signature default-language: Haskell2010@@ -116,6 +117,7 @@ hsaml2, hxt, hxt-http,+ http-types, network-uri, semigroups, string-conversions,
test/Bindings/HTTPRedirect.hs view
@@ -3,6 +3,8 @@ import qualified Data.ByteString.Char8 as BSC import Data.Time (UTCTime(..), fromGregorian) import qualified Test.HUnit as U+import Data.ByteString.Char8 (unpack)+import Network.HTTP.Types.URI (renderQuery) import SAML2.XML import SAML2.Core.Versioning@@ -12,39 +14,47 @@ import SAML2.Bindings.HTTPRedirect import XML+import XML.Keys 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")- ["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")+ [ U.TestCase $ do + let baseURI = "https://ServiceProvider.com/SAML/SLO/Browser"+ request = + (RequestLogoutRequest $ LogoutRequest+ (RequestAbstractType $ ProtocolType+ "d2b7c388cec36fa7c39c28fd298644a8"+ SAML20+ (UTCTime (fromGregorian 2004 1 21) (19*60*60+49))+ (Just $ uri baseURI)+ (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")+ ["1"])+ query <- unpack . renderQuery True <$> encodeQuery (Just privkey1) request+ decodedRequest <- decodeURI pubkey1 (uri $ baseURI ++ query)+ U.assertEqual "request" request decodedRequest+ , U.TestCase $ do+ let baseURI = "https://IdentityProvider.com/SAML" + resp = (LogoutResponse $ StatusResponseType+ (ProtocolType+ "b0730d21b628110d8b7e004005b13a2b"+ SAML20+ (UTCTime (fromGregorian 2004 1 21) (19*60*60+49))+ (Just $ uri baseURI)+ (Identified ConsentUnspecified)+ (Just $ Issuer $ simpleNameID NameIDFormatEntity "https://ServiceProvider.com/SAML")+ Nothing+ []+ (Just $ BSC.pack "0043bfc1bc45110dae17004005b13a2b"))+ (Just "d2b7c388cec36fa7c39c28fd298644a8")+ successStatus)+ query <- unpack . renderQuery True <$> encodeQuery (Just privkey1) resp+ decodedResponse <- decodeURI pubkey1 (uri $ baseURI ++ query)+ U.assertEqual "response" resp decodedResponse ]
+ test/XML/Keys.hs view
@@ -0,0 +1,47 @@+module XML.Keys (privkey1, pubkey1, pubkey2, privkeyRsa, dummyPubkeyRSA) where++import SAML2.XML.Signature+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.Types as RSA+import qualified Crypto.PubKey.DSA as DSA+import System.IO.Unsafe (unsafePerformIO)++{-# NOINLINE keypair1 #-}+keypair1 :: (SigningKey, PublicKeys)+keypair1 = unsafePerformIO mkkeypair++{-# NOINLINE keypair2 #-}+keypair2 :: (SigningKey, PublicKeys)+keypair2 = unsafePerformIO mkkeypair++privkey1, _privkey2 :: SigningKey+pubkey1, pubkey2 :: PublicKeys+((privkey1, pubkey1), (_privkey2, pubkey2)) = (keypair1, keypair2)++mkkeypair :: IO (SigningKey, PublicKeys)+mkkeypair = do+ privnum <- DSA.generatePrivate params+ let pubnum = DSA.calculatePublic params privnum+ kp = DSA.KeyPair params pubnum privnum+ pure (SigningKeyDSA kp, PublicKeys (Just $ DSA.toPublicKey kp) Nothing)+ where+ params = DSA.Params+ { DSA.params_p = 13232376895198612407547930718267435757728527029623408872245156039757713029036368719146452186041204237350521785240337048752071462798273003935646236777459223+ , DSA.params_q = 857393771208094202104259627990318636601332086981+ , DSA.params_g = 5421644057436475141609648488325705128047428394380474376834667300766108262613900542681289080713724597310673074119355136085795982097390670890367185141189796+ }++privkeyRsa :: SigningKey+_pubkeyRsa :: PublicKeys+(privkeyRsa, _pubkeyRsa) = unsafePerformIO mkRsaKeypair++_dummyPrivkeyRSA :: SigningKey+dummyPubkeyRSA :: PublicKeys+(_dummyPrivkeyRSA, dummyPubkeyRSA) = unsafePerformIO mkRsaKeypair++mkRsaKeypair :: IO (SigningKey, PublicKeys)+mkRsaKeypair = do+ let rsaexp = 17+ size = 96+ (pubkey, privkey) <- RSA.generate size rsaexp+ pure (SigningKeyRSA (RSA.KeyPair privkey), PublicKeys Nothing (Just pubkey))
test/XML/Signature.hs view
@@ -5,13 +5,12 @@ import Control.Exception (SomeException, try) import Data.ByteString.Base64 import Data.Either (isLeft)-import qualified Crypto.PubKey.DSA as DSA+import Data.List (isInfixOf) import Data.List.NonEmpty (NonEmpty(..)) import Data.String.Conversions import Data.Time import qualified Data.X509 as X509 import GHC.Stack-import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS@@ -31,6 +30,7 @@ import Data.Tree.NTree.TypeDefs import Text.XML.HXT.DOM.TypeDefs import XML+import XML.Keys tests :: U.Test tests = U.test [serializationTests, signVerifyTests, counterExamples]@@ -188,49 +188,37 @@ [ U.TestCase $ do let req = somereq req' <- signSAMLProtocol privkey1 req- let reqlbs = samlToXML req'- req'' :: AuthnRequest <- verifySAMLProtocol reqlbs- U.assertEqual "AuthnRequest with verifySAMLProtocol (no pubkeys)" req' req''+ let reqdoc = samlToDoc req'+ req'' :: AuthnRequest <- verifySAMLProtocol' pubkey1 reqdoc+ U.assertEqual "AuthnRequest with verifySAMLProtocol' (matching pubkeys)" req' req'' , U.TestCase $ do let req = somereq- req' <- signSAMLProtocol privkey1 req+ req' <- signSAMLProtocol privkeyRsa req let reqdoc = samlToDoc req'- req'' :: AuthnRequest <- verifySAMLProtocol' pubkey1 reqdoc- U.assertEqual "AuthnRequest with verifySAMLProtocol' (matching pubkeys)" req' req''+ req'' :: Either SomeException AuthnRequest <- try $ verifySAMLProtocol' pubkey1 reqdoc+ U.assertBool "AuthnRequest with verifySAMLProtocol' (bad pubkeys): isLeft"+ $ isLeft req''+ U.assertBool "AuthnRequest with verifySAMLProtocol' (bad pubkeys): error message matches"+ $ "Left user error (signature verification failed: no matching key/alg pair.)" `isInfixOf` show req'' , U.TestCase $ do let req = somereq+ req' <- signSAMLProtocol privkeyRsa req+ let reqdoc = samlToDoc req'+ req'' :: Either SomeException AuthnRequest <- try $ verifySAMLProtocol' (pubkey1 <> dummyPubkeyRSA) reqdoc+ U.assertBool "AuthnRequest with verifySAMLProtocol' (bad pubkeys): isLeft"+ $ isLeft req''+ U.assertBool "AuthnRequest with verifySAMLProtocol' (bad pubkeys): error message matches"+ $ "Left user error (signature verification failed: verification failed.)" `isInfixOf` show req''++ , U.TestCase $ do+ let req = somereq req' <- signSAMLProtocol privkey1 req let reqdoc = samlToDoc req' req'' :: Either SomeException AuthnRequest <- try $ verifySAMLProtocol' pubkey2 reqdoc U.assertBool "AuthnRequest with verifySAMLProtocol' (bad pubkeys)" $ isLeft req'' ]--{-# NOINLINE keypair1 #-}-keypair1 :: (SigningKey, PublicKeys)-keypair1 = unsafePerformIO mkkeypair--{-# NOINLINE keypair2 #-}-keypair2 :: (SigningKey, PublicKeys)-keypair2 = unsafePerformIO mkkeypair--privkey1, _privkey2 :: SigningKey-pubkey1, pubkey2 :: PublicKeys-((privkey1, pubkey1), (_privkey2, pubkey2)) = (keypair1, keypair2)--mkkeypair :: IO (SigningKey, PublicKeys)-mkkeypair = do- privnum <- DSA.generatePrivate params- let pubnum = DSA.calculatePublic params privnum- kp = DSA.KeyPair params pubnum privnum- pure (SigningKeyDSA kp, PublicKeys (Just $ DSA.toPublicKey kp) Nothing)- where- params = DSA.Params- { DSA.params_p = 13232376895198612407547930718267435757728527029623408872245156039757713029036368719146452186041204237350521785240337048752071462798273003935646236777459223- , DSA.params_q = 857393771208094202104259627990318636601332086981- , DSA.params_g = 5421644057436475141609648488325705128047428394380474376834667300766108262613900542681289080713724597310673074119355136085795982097390670890367185141189796- } somereq :: AuthnRequest somereq = AuthnRequest