From 905f1032527759b10409471df7b6218a4c385d54 Mon Sep 17 00:00:00 2001
From: John Millikin <jmillikin@gmail.com>
Date: Wed, 29 May 2013 22:39:08 -0700
Subject: [PATCH] If auth fails, include the error element in
 AuthenticationFailure.

---
 lib/Network/Protocol/XMPP/Client/Authentication.hs | 8 ++++----
 lib/Network/Protocol/XMPP/Component.hs             | 2 +-
 lib/Network/Protocol/XMPP/Monad.hs                 | 6 +++++-
 3 files changed, 10 insertions(+), 6 deletions(-)

diff --git a/lib/Network/Protocol/XMPP/Client/Authentication.hs b/lib/Network/Protocol/XMPP/Client/Authentication.hs
index 162038e..7b802ae 100644
--- a/lib/Network/Protocol/XMPP/Client/Authentication.hs
+++ b/lib/Network/Protocol/XMPP/Client/Authentication.hs
@@ -37,7 +37,7 @@ import qualified Network.Protocol.XMPP.Monad as M
 import qualified Network.Protocol.XMPP.XML as X
 import           Network.Protocol.XMPP.JID (JID, formatJID, jidResource)
 
-data Result = Success | Failure
+data Result = Success | Failure X.Element
 	deriving (Show, Eq)
 
 data AuthException = XmppError M.Error | SaslError Text
@@ -65,7 +65,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
 				Just mechanism -> authSasl ctx mechanism
 		case res of
 			Right Success -> return ()
-			Right Failure -> E.throwError M.AuthenticationFailure
+			Right (Failure e) -> E.throwError (M.AuthenticationFailure e)
 			Left (XmppError err) -> E.throwError err
 			Left (SaslError err) -> E.throwError (M.AuthenticationError err)
 	
@@ -119,7 +119,7 @@ saslLoop ctx = do
 				SASL.NeedsMore -> saslError "Server didn't provide enough SASL data."
 		
 		-- The server has rejected this client's credentials.
-		n | n == "{urn:ietf:params:xml:ns:xmpp-sasl}failure" -> return Failure
+		n | n == "{urn:ietf:params:xml:ns:xmpp-sasl}failure" -> return (Failure e)
 		
 		_ -> saslError ("Server sent unexpected element during authentication.")
 
@@ -128,7 +128,7 @@ saslFinish ctx = do
 	elemt <- getElement ctx
 	return $ if X.elementName elemt == "{urn:ietf:params:xml:ns:xmpp-sasl}success"
 		then Success
-		else Failure
+		else Failure elemt
 
 putElement :: M.Session -> X.Element -> SASL.Session ()
 putElement ctx elemt = liftIO $ do
diff --git a/lib/Network/Protocol/XMPP/Component.hs b/lib/Network/Protocol/XMPP/Component.hs
index 866cb93..b3fc3ba 100644
--- a/lib/Network/Protocol/XMPP/Component.hs
+++ b/lib/Network/Protocol/XMPP/Component.hs
@@ -74,7 +74,7 @@ authenticate streamID password = do
 	M.putElement (X.element "handshake" [] [X.NodeContent (X.ContentText digest)])
 	result <- M.getElement
 	let nameHandshake = "{jabber:component:accept}handshake"
-	when (null (X.isNamed nameHandshake result)) (throwError M.AuthenticationFailure)
+	when (null (X.isNamed nameHandshake result)) (throwError (M.AuthenticationFailure result))
 
 buildSecret :: Text -> Text -> ByteString
 buildSecret sid password = encodeUtf8 (X.escape (Data.Text.append sid password))
diff --git a/lib/Network/Protocol/XMPP/Monad.hs b/lib/Network/Protocol/XMPP/Monad.hs
index 6abbdc6..d29c149 100644
--- a/lib/Network/Protocol/XMPP/Monad.hs
+++ b/lib/Network/Protocol/XMPP/Monad.hs
@@ -57,7 +57,11 @@ import qualified Network.Protocol.XMPP.XML as X
 
 data Error
 	-- | The remote host refused the specified authentication credentials.
-	= AuthenticationFailure
+	--
+	-- The included XML element is the error value that the server
+	-- provided. It may contain additional information about why
+	-- authentication failed.
+	= AuthenticationFailure X.Element
 	
 	-- | There was an error while authenticating with the remote host.
 	| AuthenticationError Text
-- 
2.38.5