~singpolyma/network-protocol-xmpp

17f9ee285e7af0726935f068425d03659577971f — John Millikin 13 years ago 93a7951
Ignore unexpected but legal SAX events, such as comments and processing instructions.
2 files changed, 12 insertions(+), 11 deletions(-)

M Network/Protocol/XMPP/Stream.hs
M Network/Protocol/XMPP/Util.hs
M Network/Protocol/XMPP/Stream.hs => Network/Protocol/XMPP/Stream.hs +4 -3
@@ 120,11 120,12 @@ beginStream' jid h = do
		" version='1.0'" ++
		" xmlns:stream='http://etherx.jabber.org/streams'>"
	
	parser <- SAX.newParser
	parser <- SAX.mkParser
	hPutStr h xmlHeader
	[startStreamEvent] <- readEventsUntil startOfStream h parser
	initialEvents <- readEventsUntil startOfStream h parser
	featureTree <- getTree' h parser
	
	let startStreamEvent = last initialEvents
	let (language, version) = parseStartStream startStreamEvent
	let features = parseFeatures featureTree
	


@@ 202,7 203,7 @@ putTree s t = do
readEventsUntil :: (Int -> SAX.Event -> Bool) -> Handle -> SAX.Parser -> IO [SAX.Event]
readEventsUntil done h parser = readEventsUntil' done 0 [] $ do
	char <- hGetChar h
	SAX.incrementalParse parser [char]
	SAX.parse parser [char] False

readEventsUntil' :: (Int -> SAX.Event -> Bool) -> Int -> [SAX.Event] -> IO [SAX.Event] -> IO [SAX.Event]
readEventsUntil' done depth accum getEvents = do

M Network/Protocol/XMPP/Util.hs => Network/Protocol/XMPP/Util.hs +8 -8
@@ 36,7 36,7 @@ eventsToTree :: [SAX.Event] -> DOM.XmlTree
eventsToTree es = XN.mkRoot [] (eventsToTrees es)

eventsToTrees :: [SAX.Event] -> [DOM.XmlTree]
eventsToTrees es = map blockToTree (splitBlocks es)
eventsToTrees es = concatMap blockToTrees (splitBlocks es)

-- Split event list into a sequence of "blocks", which are the events including
-- and between a pair of tags. <start><start2/></start> and <start/> are both


@@ 59,16 59,16 @@ splitBlocks' (depth, accum, allAccum) e =
			(SAX.EndElement _) -> (- 1)
			_ -> 0

blockToTree :: [SAX.Event] -> DOM.XmlTree
blockToTree [] = error "No blocks"
blockToTree (begin:rest) = let end = (last rest) in case (begin, end) of
blockToTrees :: [SAX.Event] -> [DOM.XmlTree]
blockToTrees [] = []
blockToTrees (begin:rest) = let end = (last rest) in case (begin, end) of
	(SAX.BeginElement qname attrs, SAX.EndElement _) ->
		XN.mkElement (convertQName qname)
		[XN.mkElement (convertQName qname)
			(map convertAttr attrs)
			(eventsToTrees (init rest))
	(SAX.Characters s, _) -> XN.mkText s
			(eventsToTrees (init rest))]
	(SAX.Characters s, _) -> [XN.mkText s]
	(_, SAX.ParseError text) -> error text
	unexpected -> error ("Got unexpected: " ++ (show unexpected))
	_ -> []

convertAttr :: SAX.Attribute -> DOM.XmlTree
convertAttr (SAX.Attribute qname value) = XN.NTree