3 files changed, 141 insertions(+), 29 deletions(-)

M Network/Protocol/XMPP/Client.hs
A Network/Protocol/XMPP/SASL.hs
M Network/Protocol/XMPP/Stream.hs

@@ 24,13 24,19 @@ module Network.Protocol.XMPP.Client (
 
 import System.IO (Handle)
 import Network (HostName, PortID, connectTo)
+import Text.XML.HXT.Arrow ((>>>))
+import qualified Text.XML.HXT.Arrow as A
+import qualified Text.XML.HXT.DOM.XmlNode as XN
+import qualified Text.XML.HXT.DOM.QualifiedName as QN
+
 import Network.Protocol.XMPP.JID (JID)
-import Network.Protocol.XMPP.Stream (beginStream, streamFeatures)
+import Network.Protocol.XMPP.SASL (Mechanism, bestMechanism)
+import qualified Network.Protocol.XMPP.Stream as S
 import Network.Protocol.XMPP.Stanzas (Stanza)
 
-data ConnectedClient = ConnectedClient JID Handle
+data ConnectedClient = ConnectedClient JID S.Stream
 
-data AuthenticatedClient = AuthenticatedClient Handle HostName PortID
+data AuthenticatedClient = AuthenticatedClient JID S.Stream
 
 type Username = String
 type Password = String


@@ 38,13 44,42 @@ type Password = String
 clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient
 clientConnect jid host port = do
 	handle <- connectTo host port
-	stream <- beginStream jid host handle
-	putStrLn $ "streamFeatures = " ++ (show (streamFeatures stream))
-	return $ ConnectedClient jid handle
+	stream <- S.beginStream jid host handle
+	
+	-- TODO: TLS support
+	
+	return $ ConnectedClient jid stream
 
-clientAuthenticate :: ConnectedClient -> Username -> Password -> AuthenticatedClient
-clientAuthenticate = undefined
+clientAuthenticate :: ConnectedClient -> Username -> Password -> IO AuthenticatedClient
+clientAuthenticate (ConnectedClient jid stream) username password = let
+	mechanisms = (advertisedMechanisms . S.streamFeatures) stream
+	saslMechanism = case bestMechanism mechanisms of
+		Nothing -> error "No supported SASL mechanism"
+		Just m -> m
+	in do
+		putStrLn $ "mechanism = " ++ (show saslMechanism)
+		
+		-- TODO: use detected mechanism
+		S.putTree stream $ XN.mkElement
+			(QN.mkName "auth")
+			[
+				 XN.mkAttr (QN.mkName "xmlns") [XN.mkText "urn:ietf:params:xml:ns:xmpp-sasl"]
+				,XN.mkAttr (QN.mkName "mechanism") [XN.mkText "PLAIN"]
+			]
+			[XN.mkText "="]
+		
+		response <- S.getTree stream
+		putStrLn $ "response:"
+		A.runX (A.constA response >>> A.putXmlTree "-")
+		
+		return $ AuthenticatedClient jid stream
 
 clientSend :: (Stanza s) => AuthenticatedClient -> s -> IO ()
 clientSend = undefined
 
+advertisedMechanisms :: [S.StreamFeature] -> [Mechanism]
+advertisedMechanisms [] = []
+advertisedMechanisms (f:fs) = case f of
+	(S.FeatureSASL ms) -> ms
+	otherwise -> advertisedMechanisms fs
+

@@ 0,0 1,43 @@
+{- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
+   
+   This program is free software: you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation, either version 3 of the License, or
+   any later version.
+   
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+   
+   You should have received a copy of the GNU General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.
+-}
+
+module Network.Protocol.XMPP.SASL (
+	 Mechanism
+	,supportedMechanisms
+	,bestMechanism
+	,findMechanism
+	) where
+
+import Data.List (intersect)
+import Data.AssocList (lookupDef)
+
+type Username = String
+type Password = String
+
+type Mechanism = String
+
+-- TODO: validation
+supportedMechanisms :: [Mechanism]
+supportedMechanisms = ["PLAIN"] -- TODO: Digest-MD5
+
+bestMechanism :: [Mechanism] -> Maybe Mechanism
+bestMechanism ms = let
+	in case intersect supportedMechanisms ms of
+		[] -> Nothing
+		(m:_) -> Just m
+
+findMechanism :: String -> Mechanism
+findMechanism s = s -- TODO: validate

@@ 21,8 21,14 @@ module Network.Protocol.XMPP.Stream (
 	 	,streamVersion
 	 	,streamFeatures
 	 	)
+	,StreamFeature (
+		 FeatureStartTLS
+		,FeatureSASL
+		,FeatureRegister
+		)
 	,beginStream
-	,send
+	,getTree
+	,putTree
 	) where
 
 import qualified System.IO as IO


@@ 37,7 43,9 @@ import Text.XML.HXT.DOM.Util (attrEscapeXml)
 import Text.XML.HXT.Arrow ((>>>), (>>.))
 import Data.Tree.NTree.TypeDefs (NTree(NTree))
 import qualified Text.XML.HXT.Arrow as A
+
 import Network.Protocol.XMPP.JID (JID)
+import Network.Protocol.XMPP.SASL (Mechanism, findMechanism)
 import Network.Protocol.XMPP.Stanzas (Stanza)
 import Network.Protocol.XMPP.XMLBuilder (eventsToTree)
 


@@ 55,7 63,7 @@ data Stream = Stream
 
 data StreamFeature =
 	  FeatureStartTLS Bool
-	| FeatureSASL [SASLMechanism]
+	| FeatureSASL [Mechanism]
 	| FeatureRegister
 	| FeatureUnknown XmlTree
 	| FeatureDebug String


@@ 64,9 72,6 @@ data StreamFeature =
 newtype XMLLanguage = XMLLanguage String
 	deriving (Show, Eq)
 
-newtype SASLMechanism = SASLMechanism String
-	deriving (Show, Eq)
-
 data XMPPVersion = XMPPVersion Int Int
 	deriving (Show, Eq)
 


@@ 87,12 92,15 @@ beginStream jid host handle = do
 		" to='" ++ (attrEscapeXml . show) jid ++ "'" ++
 		" version='1.0'" ++
 		" xmlns:stream='http://etherx.jabber.org/streams'>"
-	
 	IO.hFlush handle
 	
-	xmlChars <- hGetChars handle 100
-	events <- (XML.incrementalParse parser xmlChars)
+	events <- readEventsUntil endOfFeatures handle parser 1000
 	return $ beginStream' handle parser events
+	where
+		featuresName = QN.mkNsName "features" "http://etherx.jabber.org/streams"
+		endOfFeatures depth event = case (depth, event) of
+			(1, (XML.EndElement featuresName)) -> True
+			otherwise -> False
 
 beginStream' handle parser (streamStart:events) = let
 	-- TODO: parse from streamStart


@@ 135,22 143,48 @@ parseFeatureSASL t = let
 	
 	-- TODO: validate mechanism names according to SASL rules
 	-- <20 chars, uppercase, alphanum, etc
-	in FeatureSASL [SASLMechanism n | n <- rawMechanisms]
+	in FeatureSASL (map findMechanism rawMechanisms)
 
 -------------------------------------------------------------------------------
 
-send :: (Stanza s) => Stream -> s -> IO ()
-send = undefined
+getTree :: Stream -> IO XmlTree
+getTree s = do
+	events <- readEventsUntil finished (streamHandle s) (streamParser s) 1000
+	return $ eventsToTree events
+	where
+		finished 0 (XML.EndElement _) = True
+		finished _ _ = False
+
+putTree :: Stream -> XmlTree -> IO ()
+putTree s t = do
+	let root = XN.mkRoot [] [t]
+	let h = streamHandle s
+	[text] <- A.runX (A.constA root >>> A.writeDocumentToString [
+		(A.a_no_xml_pi, "1")
+		])
+	IO.hPutStr h text
+	IO.hFlush h
 
 -------------------------------------------------------------------------------
 
-hGetChars :: IO.Handle -> Int -> IO String
-hGetChars h timeout = do
-	have_input <- IO.hWaitForInput h timeout
-	case have_input of
-		False -> return []
-		True -> do
-			chr <- IO.hGetChar h
-			next <- hGetChars h timeout
-			return $ chr : next
-
+readEventsUntil :: (Int -> XML.Event -> Bool) -> IO.Handle -> XML.Parser -> Int -> IO [XML.Event]
+readEventsUntil done h parser timeout = readEventsUntil' done 0 [] $ do
+	char <- IO.hGetChar h
+	XML.incrementalParse parser [char]
+
+readEventsUntil' done depth accum getEvents = do
+	events <- getEvents
+	let (done', depth', accum') = readEventsStep done events depth accum
+	if done'
+		then return accum'
+		else readEventsUntil' done depth' accum' getEvents
+
+readEventsStep _ [] depth accum = (False, depth, accum)
+readEventsStep done (e:es) depth accum = let
+	depth' = depth + case e of
+		(XML.BeginElement _ _) -> 1
+		(XML.EndElement _) -> (- 1)
+		otherwise -> 0
+	accum' = accum ++ [e]
+	in if done depth' e then (True, depth', accum')
+	else readEventsStep done es depth' accum'