~singpolyma/network-protocol-xmpp

22b56df3bb6bfefa5971cd18c65ebdfd2101ed90 — John Millikin 13 years ago 30ee97b
Allow the SASL mechanism used to be automatically negotiated.
2 files changed, 45 insertions(+), 15 deletions(-)

M Network/Protocol/XMPP/Client.hs
M Network/Protocol/XMPP/SASL.hs
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +1 -2
@@ 59,11 59,10 @@ clientConnect jid host port = do

clientAuthenticate :: ConnectedClient -> JID -> Username -> Password -> IO Client
clientAuthenticate (ConnectedClient serverJID stream) jid username password = do
	authed <- SASL.authenticate stream jid username password
	authed <- SASL.authenticate stream jid serverJID username password
	case authed of
		SASL.Failure -> error "Authentication failure"
		_ -> do
			putStrLn $ "About to restart stream"
			newStream <- S.restartStream stream
			return $ Client jid serverJID newStream


M Network/Protocol/XMPP/SASL.hs => Network/Protocol/XMPP/SASL.hs +44 -13
@@ 19,6 19,7 @@ module Network.Protocol.XMPP.SASL (
	,authenticate
	) where

import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Network.Protocol.SASL.GSASL as G


@@ 34,33 35,63 @@ type Mechanism = String
data Result = Success | Failure
	deriving (Show, Eq)

authenticate :: S.Stream -> JID -> Username -> Password -> IO Result
authenticate stream jid username password = do
authenticate :: S.Stream -> JID -> JID -> Username -> Password -> IO Result
authenticate stream userJID serverJID username password = do
	let mechanisms = (advertisedMechanisms . S.streamFeatures) stream
	let authz = jidFormat jid
	let authz = jidFormat userJID
	let hostname = jidFormat serverJID
	
	ctxt <- G.mkContext
	G.propertySet s G.GSASL_AUTHZID (jidFormat jid)
	
	suggested <- G.clientSuggestMechanism ctxt mechanisms
	mechanism <- case suggested of
		Just m -> return m
		Nothing -> error "No supported SASL mechanisms advertised"
	
	s <- G.clientStart ctxt mechanism
	
	G.propertySet s G.GSASL_AUTHZID authz
	G.propertySet s G.GSASL_AUTHID username
	G.propertySet s G.GSASL_PASSWORD password
	G.propertySet s G.GSASL_SERVICE "xmpp"
	G.propertySet s G.GSASL_HOSTNAME hostname
	
	-- TODO: use best mechanism
	s <- G.clientStart ctxt "PLAIN"
	(b64text, rc) <- G.step64 s ""
	
	S.putTree stream $ mkElement ("", "auth")
		[ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")
		 ,("", "mechanism", "PLAIN")]
		 ,("", "mechanism", mechanism)]
		[XN.mkText b64text]
	
	case rc of
		G.GSASL_OK -> saslFinish stream
		G.GSASL_NEEDS_MORE -> saslLoop stream s

saslLoop :: S.Stream -> G.Session -> IO Result
saslLoop stream session = do
	challengeText <- A.runX (
		A.arrIO (\_ -> S.getTree stream)
		>>> A.getChildren
		>>> A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "challenge")
		>>> A.getChildren >>> A.getText)
	
	if null challengeText then return Failure
		else do
			(b64text, rc) <- G.step64 session (concat challengeText)
			S.putTree stream $ mkElement ("", "response")
				[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")]
				[XN.mkText b64text]
			case rc of
				G.GSASL_OK -> saslFinish stream
				G.GSASL_NEEDS_MORE -> saslLoop stream session

saslFinish :: S.Stream -> IO Result
saslFinish stream = do
	successElem <- A.runX (
		A.arrIO (\_ -> S.getTree stream)
		A.>>> A.getChildren
		A.>>> A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "success"))
		>>> A.getChildren
		>>> A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "success"))
	
	if length successElem == 0
		then return Failure
		else return Success
	return $ if null successElem then Failure else Success

advertisedMechanisms :: [S.StreamFeature] -> [Mechanism]
advertisedMechanisms [] = []