~singpolyma/network-protocol-xmpp

30ee97bf566aecefee0e115fa81452a4ed6a88b9 — John Millikin 13 years ago b44e8c3
Ported authentication to GNU SASL. Currently, only the PLAIN mechanism is supported.
3 files changed, 56 insertions(+), 50 deletions(-)

M Network/Protocol/XMPP/Client.hs
M Network/Protocol/XMPP/SASL.hs
M Network/Protocol/XMPP/Stream.hs
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +8 -27
@@ 35,7 35,7 @@ import Text.XML.HXT.DOM.TypeDefs (XmlTree)
import qualified Text.XML.HXT.DOM.XmlNode as XN

import Network.Protocol.XMPP.JID (JID, jidParse, jidFormat, jidResource)
import Network.Protocol.XMPP.SASL (Mechanism, bestMechanism)
import qualified Network.Protocol.XMPP.SASL as SASL
import qualified Network.Protocol.XMPP.Stream as S
import Network.Protocol.XMPP.Util (mkElement, mkQName)
import Network.Protocol.XMPP.Stanzas (Stanza, stanzaXML)


@@ 59,26 59,13 @@ clientConnect jid host port = do

clientAuthenticate :: ConnectedClient -> JID -> Username -> Password -> IO Client
clientAuthenticate (ConnectedClient serverJID stream) jid username password = do
	let mechanisms = (advertisedMechanisms . S.streamFeatures) stream
	let saslMechanism = case bestMechanism mechanisms of
		Nothing -> error "No supported SASL mechanism"
		Just m -> m
	
	-- TODO: use detected mechanism
	let saslText = concat [(jidFormat jid), "\x00", username, "\x00", password]
	let b64Text = encode saslText
	
	S.putTree stream $ mkElement ("", "auth")
		[ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")
		 ,("", "mechanism", "PLAIN")]
		[XN.mkText b64Text]
	
	response <- S.getTree stream
	
	-- TODO: check if response is success or failure
	
	newStream <- S.restartStream stream
	return $ Client jid serverJID newStream
	authed <- SASL.authenticate stream jid 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

clientBind :: Client -> IO JID
clientBind c = do


@@ 119,12 106,6 @@ clientBind c = do
	getTree c
	return jid

advertisedMechanisms :: [S.StreamFeature] -> [Mechanism]
advertisedMechanisms [] = []
advertisedMechanisms (f:fs) = case f of
	(S.FeatureSASL ms) -> ms
	_ -> advertisedMechanisms fs

-------------------------------------------------------------------------------

putTree :: Client -> XmlTree -> IO ()

M Network/Protocol/XMPP/SASL.hs => Network/Protocol/XMPP/SASL.hs +44 -17
@@ 15,29 15,56 @@
-}

module Network.Protocol.XMPP.SASL (
	 Mechanism
	,supportedMechanisms
	,bestMechanism
	,findMechanism
	 Result(..)
	,authenticate
	) where

import Data.List (intersect)
import Data.AssocList (lookupDef)
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

import Network.Protocol.XMPP.JID (JID, jidFormat)
import Network.Protocol.XMPP.Util (mkElement, mkQName)
import qualified Network.Protocol.XMPP.Stream as S

type Username = String
type Password = String

type Mechanism = String

-- TODO: validation
supportedMechanisms :: [Mechanism]
supportedMechanisms = ["PLAIN"] -- TODO: Digest-MD5
data Result = Success | Failure
	deriving (Show, Eq)

authenticate :: S.Stream -> JID -> Username -> Password -> IO Result
authenticate stream jid username password = do
	let mechanisms = (advertisedMechanisms . S.streamFeatures) stream
	let authz = jidFormat jid
	
	ctxt <- G.mkContext
	G.propertySet s G.GSASL_AUTHZID (jidFormat jid)
	G.propertySet s G.GSASL_AUTHID username
	G.propertySet s G.GSASL_PASSWORD password
	
	-- 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")]
		[XN.mkText b64text]
	
	successElem <- A.runX (
		A.arrIO (\_ -> S.getTree stream)
		A.>>> A.getChildren
		A.>>> A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "success"))
	
	if length successElem == 0
		then return Failure
		else return Success

bestMechanism :: [Mechanism] -> Maybe Mechanism
bestMechanism ms = let
	in case intersect supportedMechanisms ms of
		[] -> Nothing
		(m:_) -> Just m
advertisedMechanisms :: [S.StreamFeature] -> [Mechanism]
advertisedMechanisms [] = []
advertisedMechanisms (f:fs) = case f of
	(S.FeatureSASL ms) -> ms
	_ -> advertisedMechanisms fs

findMechanism :: String -> Mechanism
findMechanism s = s -- TODO: validate

M Network/Protocol/XMPP/Stream.hs => Network/Protocol/XMPP/Stream.hs +4 -6
@@ 35,6 35,7 @@ module Network.Protocol.XMPP.Stream (

import qualified System.IO as IO
import Data.AssocList (lookupDef)
import Data.Char (toUpper)

-- XML Parsing
import Text.XML.HXT.Arrow ((>>>))


@@ 49,7 50,6 @@ import Foreign (allocaBytes)
import Foreign.C (peekCAStringLen)

import Network.Protocol.XMPP.JID (JID, jidFormat)
import Network.Protocol.XMPP.SASL (Mechanism, findMechanism)
import qualified Network.Protocol.XMPP.Util as Util

maxXMPPVersion :: XMPPVersion


@@ 67,7 67,7 @@ data Stream = Stream

data StreamFeature =
	  FeatureStartTLS Bool
	| FeatureSASL [Mechanism]
	| FeatureSASL [String]
	| FeatureRegister
	| FeatureBind
	| FeatureSession


@@ 167,15 167,13 @@ parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required
parseFeatureSASL :: DOM.XmlTree -> StreamFeature
parseFeatureSASL t = let
	mechName = Util.mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism"
	rawMechanisms = A.runLA (
	mechanisms = A.runLA (
		A.getChildren
		>>> A.hasQName mechName
		>>> A.getChildren
		>>> A.getText) t
	
	-- TODO: validate mechanism names according to SASL rules
	-- <20 chars, uppercase, alphanum, etc
	in FeatureSASL (map findMechanism rawMechanisms)
	in FeatureSASL $ map (map toUpper) mechanisms

-------------------------------------------------------------------------------