5 files changed, 46 insertions(+), 40 deletions(-)

M Network/Protocol/XMPP/Client.hs
M Network/Protocol/XMPP/IncrementalXML.hs
M Network/Protocol/XMPP/JID.hs
M Network/Protocol/XMPP/Stream.hs
M Network/Protocol/XMPP/Util.hs

@@ 20,23 20,22 @@ module Network.Protocol.XMPP.Client (
 	,clientConnect
 	,clientAuthenticate
 	,clientBind
+	,clientJID
+	,clientServerJID
 	,putTree
 	,getTree
 	) where
 
-import System.IO (hSetBuffering, BufferMode(NoBuffering), Handle)
 import Codec.Binary.Base64.String (encode)
 import Network (HostName, PortID, connectTo)
 import Text.XML.HXT.Arrow ((>>>))
 import qualified Text.XML.HXT.Arrow as A
 import Text.XML.HXT.DOM.TypeDefs (XmlTree)
 import qualified Text.XML.HXT.DOM.XmlNode as XN
-import qualified Text.XML.HXT.DOM.QualifiedName as QN
 
 import Network.Protocol.XMPP.JID (JID, jidParse)
 import Network.Protocol.XMPP.SASL (Mechanism, bestMechanism)
 import qualified Network.Protocol.XMPP.Stream as S
-import Network.Protocol.XMPP.Stanzas (Stanza)
 import Network.Protocol.XMPP.Util (mkElement, mkQName)
 
 data ConnectedClient = ConnectedClient JID S.Stream


@@ 53,8 52,6 @@ type Password = String
 clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient
 clientConnect jid host port = do
 	handle <- connectTo host port
-	hSetBuffering handle NoBuffering
-	
 	stream <- S.beginStream jid handle
 	return $ ConnectedClient jid stream
 


@@ 100,7 97,7 @@ clientBind c = do
 		>>> A.getText) bindResult
 	let jid = case jidParse rawJID of
 		Just x -> x
-		otherwise -> error "Couldn't parse server's returned JID"
+		_ -> error "Couldn't parse server's returned JID"
 	
 	-- Session
 	putTree c $ mkElement ("", "iq")


@@ 109,7 106,7 @@ clientBind c = do
 			[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")]
 			[]]
 	
-	sessionResult <- getTree c
+	getTree c
 	
 	putTree c $ mkElement ("", "presence") [] []
 	getTree c


@@ 119,7 116,7 @@ advertisedMechanisms :: [S.StreamFeature] -> [Mechanism]
 advertisedMechanisms [] = []
 advertisedMechanisms (f:fs) = case f of
 	(S.FeatureSASL ms) -> ms
-	otherwise -> advertisedMechanisms fs
+	_ -> advertisedMechanisms fs
 
 -------------------------------------------------------------------------------
 

@@ 63,7 63,7 @@ incrementalParse (Parser autoptr) s = do
 checkReturn :: CInt -> [Event] -> [Event]
 checkReturn r es = es ++ case r of
 	0 -> []
-	otherwise -> [ParseError (show r)]
+	_ -> [ParseError (show r)]
 
 withFunPtr :: a -> (a -> IO (F.FunPtr a)) -> (F.FunPtr a -> IO b) -> IO b
 withFunPtr f mkPtr block = bracket (mkPtr f) F.freeHaskellFunPtr block

@@ 89,9 89,12 @@ jidFormat (JID node (JIDDomain domain) resource) = let
 	resourceStr = maybe "" (\(JIDResource s) -> "/" ++ s) resource
 	in concat [nodeStr, domain, resourceStr]
 
+split :: (Eq a) => [a] -> a -> ([a], [a])
 split xs final = let
 	(before, rawAfter) = span (/= final) xs
-	after = case rawAfter of
-		[] -> []
-		xs -> tail xs
+	after = safeTail rawAfter
 	in (before, after)
+
+safeTail :: [a] -> [a]
+safeTail [] = []
+safeTail (_:xs) = xs

@@ 34,16 34,14 @@ module Network.Protocol.XMPP.Stream (
 	) where
 
 import qualified System.IO as IO
-import qualified Network.Protocol.XMPP.IncrementalXML as XML
 import Data.AssocList (lookupDef)
-import qualified Text.XML.HXT.DOM.QualifiedName as QN
-import qualified Text.XML.HXT.DOM.XmlNode as XN
-import Text.XML.HXT.DOM.TypeDefs (XmlTree)
-import Text.XML.HXT.DOM.FormatXmlTree (formatXmlTree)
-import Text.XML.HXT.DOM.Util (attrEscapeXml)
-import Text.XML.HXT.Arrow ((>>>), (>>.))
-import Data.Tree.NTree.TypeDefs (NTree(NTree))
+
+-- XML Parsing
+import Text.XML.HXT.Arrow ((>>>))
 import qualified Text.XML.HXT.Arrow as A
+import qualified Text.XML.HXT.DOM.Interface as DOM
+import qualified Text.XML.HXT.DOM.XmlNode as XN
+import qualified Network.Protocol.XMPP.IncrementalXML as XML
 
 -- TLS support
 import qualified Network.GnuTLS as GnuTLS


@@ 54,6 52,7 @@ import Network.Protocol.XMPP.JID (JID)
 import Network.Protocol.XMPP.SASL (Mechanism, findMechanism)
 import Network.Protocol.XMPP.Util (eventsToTree, mkQName, mkElement)
 
+maxXMPPVersion :: XMPPVersion
 maxXMPPVersion = XMPPVersion 1 0
 
 data Stream = Stream


@@ 72,8 71,7 @@ data StreamFeature =
 	| FeatureRegister
 	| FeatureBind
 	| FeatureSession
-	| FeatureUnknown XmlTree
-	| FeatureDebug String
+	| FeatureUnknown DOM.XmlTree
 	deriving (Show, Eq)
 
 newtype XMLLanguage = XMLLanguage String


@@ 93,6 91,8 @@ restartStream s = beginStream' (streamJID s) (streamHandle s)
 
 beginStream :: JID -> IO.Handle -> IO Stream
 beginStream jid rawHandle = do
+	IO.hSetBuffering rawHandle IO.NoBuffering
+	
 	plainStream <- beginStream' jid (PlainHandle rawHandle)
 	
 	putTree plainStream $ mkElement ("", "starttls")


@@ 116,13 116,13 @@ beginStream' jid h = do
 	let xmlHeader =
 		"<?xml version='1.0'?>\n" ++
 		"<stream:stream xmlns='jabber:client'" ++
-		" to='" ++ (attrEscapeXml . show) jid ++ "'" ++
+		" to='" ++ (DOM.attrEscapeXml . show) jid ++ "'" ++
 		" version='1.0'" ++
 		" xmlns:stream='http://etherx.jabber.org/streams'>"
 	
 	parser <- XML.newParser
 	hPutStr h xmlHeader
-	[startStreamEvent] <- readEventsUntil startOfStream h parser 1000
+	[startStreamEvent] <- readEventsUntil startOfStream h parser
 	featureTree <- getTree' h parser
 	
 	let (language, version) = parseStartStream startStreamEvent


@@ 134,13 134,13 @@ beginStream' jid h = do
 		streamName = mkQName "http://etherx.jabber.org/streams" "stream"
 		
 		startOfStream depth event = case (depth, event) of
-			(1, (XML.BeginElement streamName _)) -> True
-			otherwise -> False
+			(1, (XML.BeginElement elemName _)) -> streamName == elemName
+			_ -> False
 
 parseStartStream :: XML.Event -> (XMLLanguage, XMPPVersion)
 parseStartStream e = (XMLLanguage "en", XMPPVersion 1 0) -- TODO
 
-parseFeatures :: XmlTree -> [StreamFeature]
+parseFeatures :: DOM.XmlTree -> [StreamFeature]
 parseFeatures t =
 	A.runLA (A.getChildren
 		>>> A.hasQName featuresName


@@ 149,7 149,7 @@ parseFeatures t =
 	where
 		featuresName = mkQName "http://etherx.jabber.org/streams" "features"
 
-parseFeature :: XmlTree -> StreamFeature
+parseFeature :: DOM.XmlTree -> StreamFeature
 parseFeature t = lookupDef FeatureUnknown qname [
 	 (("urn:ietf:params:xml:ns:xmpp-tls", "starttls"), parseFeatureTLS)
 	,(("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms"), parseFeatureSASL)


@@ 158,12 158,12 @@ parseFeature t = lookupDef FeatureUnknown qname [
 	,(("urn:ietf:params:xml:ns:xmpp-session", "session"), (\_ -> FeatureSession))
 	] t
 	where
-		qname = maybe ("", "") (\n -> (QN.namespaceUri n, QN.localPart n)) (XN.getName t)
+		qname = maybe ("", "") (\n -> (DOM.namespaceUri n, DOM.localPart n)) (XN.getName t)
 
-parseFeatureTLS :: XmlTree -> StreamFeature
+parseFeatureTLS :: DOM.XmlTree -> StreamFeature
 parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required
 
-parseFeatureSASL :: XmlTree -> StreamFeature
+parseFeatureSASL :: DOM.XmlTree -> StreamFeature
 parseFeatureSASL t = let
 	mechName = mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism"
 	rawMechanisms = A.runLA (


@@ 178,18 178,18 @@ parseFeatureSASL t = let
 
 -------------------------------------------------------------------------------
 
-getTree :: Stream -> IO XmlTree
+getTree :: Stream -> IO DOM.XmlTree
 getTree s = getTree' (streamHandle s) (streamParser s)
 
-getTree' :: Handle -> XML.Parser -> IO XmlTree
+getTree' :: Handle -> XML.Parser -> IO DOM.XmlTree
 getTree' h p = do
-	events <- readEventsUntil finished h p 1000
+	events <- readEventsUntil finished h p
 	return $ eventsToTree events
 	where
 		finished 0 (XML.EndElement _) = True
 		finished _ _ = False
 
-putTree :: Stream -> XmlTree -> IO ()
+putTree :: Stream -> DOM.XmlTree -> IO ()
 putTree s t = do
 	let root = XN.mkRoot [] [t]
 	let h = streamHandle s


@@ 200,11 200,12 @@ putTree s t = do
 
 -------------------------------------------------------------------------------
 
-readEventsUntil :: (Int -> XML.Event -> Bool) -> Handle -> XML.Parser -> Int -> IO [XML.Event]
-readEventsUntil done h parser timeout = readEventsUntil' done 0 [] $ do
+readEventsUntil :: (Int -> XML.Event -> Bool) -> Handle -> XML.Parser -> IO [XML.Event]
+readEventsUntil done h parser = readEventsUntil' done 0 [] $ do
 	char <- hGetChar h
 	XML.incrementalParse parser [char]
 
+readEventsUntil' :: (Int -> XML.Event -> Bool) -> Int -> [XML.Event] -> IO [XML.Event] -> IO [XML.Event]
 readEventsUntil' done depth accum getEvents = do
 	events <- getEvents
 	let (done', depth', accum') = readEventsStep done events depth accum


@@ 212,12 213,13 @@ readEventsUntil' done depth accum getEvents = do
 		then return accum'
 		else readEventsUntil' done depth' accum' getEvents
 
+readEventsStep :: (Int -> XML.Event -> Bool) -> [XML.Event] -> Int -> [XML.Event] -> (Bool, Int, [XML.Event])
 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
+		_ -> 0
 	accum' = accum ++ [e]
 	in if done depth' e then (True, depth', accum')
 	else readEventsStep done es depth' accum'

@@ 43,6 43,9 @@ eventsToTrees es = map blockToTree (splitBlocks es)
 splitBlocks :: [XML.Event] -> [[XML.Event]]
 splitBlocks es = ret where (_, _, ret) = foldl splitBlocks' (0, [], []) es
 
+splitBlocks' :: (Int, [XML.Event], [[XML.Event]])
+                -> XML.Event
+                -> (Int, [XML.Event], [[XML.Event]])
 splitBlocks' (depth, accum, allAccum) e =
 	if depth' == 0 then
 		(depth', [], allAccum ++ [accum'])


@@ 53,9 56,10 @@ splitBlocks' (depth, accum, allAccum) e =
 		depth' = depth + case e of
 			(XML.BeginElement _ _) -> 1
 			(XML.EndElement _) -> (- 1)
-			otherwise -> 0
+			_ -> 0
 
 blockToTree :: [XML.Event] -> XmlTree
+blockToTree [] = error "No blocks"
 blockToTree (begin:rest) = let end = (last rest) in case (begin, end) of
 	(XML.BeginElement qname attrs, XML.EndElement _) ->
 		XN.mkElement qname (map convertAttr attrs) (eventsToTrees (init rest))


@@ 82,4 86,4 @@ mkAttr ns localpart text = XN.mkAttr (mkQName ns localpart) [XN.mkText text]
 mkQName :: String -> String -> QN.QName
 mkQName ns localpart = case ns of
 	"" -> QN.mkName localpart
-	otherwise -> QN.mkNsName localpart ns
+	_ -> QN.mkNsName localpart ns