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

@@ 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 ()

@@ 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

@@ 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
 
 -------------------------------------------------------------------------------