~singpolyma/network-protocol-xmpp

3a40e58a4ca8b68a71dc907d09298168fd7ec00f — John Millikin 12 years ago 1eb63b4
Replace SaxEvent with plain Event
M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +2 -2
@@ 61,8 61,8 @@ beginStream jid = do
		Nothing -> throwError M.NoComponentStreamID
		Just x -> return x

parseStreamID :: X.SaxEvent -> Maybe Text
parseStreamID (X.BeginElement name attrs) = X.attributeText
parseStreamID :: X.Event -> Maybe Text
parseStreamID (X.EventBeginElement name attrs) = X.attributeText
	"{jabber:component:accept}jid"
	(X.Element name attrs [])
parseStreamID _ = Nothing

M Network/Protocol/XMPP/Connections.hs => Network/Protocol/XMPP/Connections.hs +2 -2
@@ 51,9 51,9 @@ xmlHeader ns jid = encodeUtf8 header where
		, " xmlns:stream=\"http://etherx.jabber.org/streams\">"
		]

startOfStream :: Integer -> X.SaxEvent -> Bool
startOfStream :: Integer -> X.Event -> Bool
startOfStream depth event = case (depth, event) of
	(1, (X.BeginElement elemName _)) -> qnameStream == elemName
	(1, (X.EventBeginElement elemName _)) -> qnameStream == elemName
	_ -> False

qnameStream :: X.Name

M Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +2 -2
@@ 157,7 157,7 @@ putElement = putBytes . encodeUtf8 . X.serialiseElement
putStanza :: S.Stanza a => a -> XMPP ()
putStanza = withLock sessionWriteLock . putElement . S.stanzaToElement

readEvents :: (Integer -> X.SaxEvent -> Bool) -> XMPP [X.SaxEvent]
readEvents :: (Integer -> X.Event -> Bool) -> XMPP [X.Event]
readEvents done = xmpp where
	xmpp = do
		Session h _ p _ _ <- getSession


@@ 179,7 179,7 @@ getElement = xmpp where
			Just x -> return x
			Nothing -> E.throwError $ TransportError "getElement: invalid event list"
	
	endOfTree 0 (X.EndElement _) = True
	endOfTree 0 (X.EventEndElement _) = True
	endOfTree _ _ = False

getStanza :: XMPP S.ReceivedStanza

M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +20 -28
@@ 29,7 29,6 @@ module Network.Protocol.XMPP.XML
	
	-- * libxml-sax-0.4 API imitation
	, Parser
	, SaxEvent (..)
	, newParser
	, parse
	, eventsToElement


@@ 91,7 90,7 @@ serialiseElement e = text where

-- quick-and-dirty imitation of libxml-sax-0.4 API; later, this should
-- probably be rewritten to use ST and discard the list parsing
data Parser = Parser (SAX.Parser IO) (IORef (Either Text [SaxEvent]))
data Parser = Parser (SAX.Parser IO) (IORef (Either Text [Event]))

newParser :: IO Parser
newParser = do


@@ 105,16 104,16 @@ newParser = do
			Right es -> writeIORef ref (Right (e:es))
		return True
	
	SAX.setCallback p SAX.parsedBeginElement (\name' attrs -> addEvent $ BeginElement name' attrs)
	SAX.setCallback p SAX.parsedEndElement (\name' -> addEvent $ EndElement name')
	SAX.setCallback p SAX.parsedCharacters (\txt -> addEvent $ Characters txt)
	SAX.setCallback p SAX.parsedComment (\txt -> addEvent $ Comment txt)
	SAX.setCallback p SAX.parsedInstruction (\i -> addEvent $ ProcessingInstruction i)
	SAX.setCallback p SAX.parsedBeginElement (\name attrs -> addEvent (EventBeginElement name attrs))
	SAX.setCallback p SAX.parsedEndElement (\name -> addEvent (EventEndElement name))
	SAX.setCallback p SAX.parsedCharacters (\txt -> addEvent (EventContent (ContentText txt)))
	SAX.setCallback p SAX.parsedComment (\txt -> addEvent (EventComment txt))
	SAX.setCallback p SAX.parsedInstruction (\i -> addEvent (EventInstruction i))
	SAX.setCallback p SAX.reportError (\err -> writeIORef ref (Left err) >> return False)
	
	return $ Parser p ref

parse :: Parser -> ByteString -> Bool -> IO (Either Text [SaxEvent])
parse :: Parser -> ByteString -> Bool -> IO (Either Text [Event])
parse (Parser p ref) bytes finish = do
	writeIORef ref (Right [])
	SAX.parseBytes p bytes


@@ 124,17 123,10 @@ parse (Parser p ref) bytes finish = do
		Left err -> Left err
		Right events -> Right $ reverse events

data SaxEvent
	= BeginElement Name [(Name, [Content])]
	| EndElement Name
	| Characters Text
	| Comment Text
	| ProcessingInstruction Instruction

readEvents :: Monad m
           => (Integer -> SaxEvent -> Bool)
           -> m [SaxEvent]
           -> m [SaxEvent]
           => (Integer -> Event -> Bool)
           -> m [Event]
           -> m [Event]
readEvents done nextEvents = readEvents' 0 [] where
	readEvents' depth acc = do
		events <- nextEvents


@@ 146,8 138,8 @@ readEvents done nextEvents = readEvents' 0 [] where
	step [] depth acc = (False, depth, acc)
	step (e:es) depth acc = let
		depth' = depth + case e of
			(BeginElement _ _) -> 1
			(EndElement _) -> (- 1)
			(EventBeginElement _ _) -> 1
			(EventEndElement _) -> (- 1)
			_ -> 0
		acc' = e : acc
		in if done depth' e


@@ 156,18 148,18 @@ readEvents done nextEvents = readEvents' 0 [] where

-- | Convert a list of events to a single 'Element'. If the events do not
-- contain at least one valid element, 'Nothing' will be returned instead.
eventsToElement :: [SaxEvent] -> Maybe Element
eventsToElement :: [Event] -> Maybe Element
eventsToElement es = case eventsToNodes es >>= isElement of
	(e:_) -> Just e
	_ -> Nothing

eventsToNodes :: [SaxEvent] -> [Node]
eventsToNodes :: [Event] -> [Node]
eventsToNodes = concatMap blockToNodes . splitBlocks

-- 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
-- single blocks.
splitBlocks :: [SaxEvent] -> [[SaxEvent]]
splitBlocks :: [Event] -> [[Event]]
splitBlocks es = ret where
	(_, _, ret) = foldl splitBlocks' (0, [], []) es
	


@@ 178,17 170,17 @@ splitBlocks es = ret where
		accum' = accum ++ [e]
		depth' :: Integer
		depth' = depth + case e of
			(BeginElement _ _) -> 1
			(EndElement _) -> (- 1)
			(EventBeginElement _ _) -> 1
			(EventEndElement _) -> (- 1)
			_ -> 0

blockToNodes :: [SaxEvent] -> [Node]
blockToNodes :: [Event] -> [Node]
blockToNodes [] = []
blockToNodes (begin:rest) = nodes where
	end = last rest
	nodes = case (begin, end) of
		(BeginElement name' attrs, EndElement _) -> [node name' attrs]
		(Characters t, _) -> [NodeContent (ContentText t)]
		(EventBeginElement name attrs, EventEndElement _) -> [node name attrs]
		(EventContent c, _) -> [NodeContent c]
		_ -> []
	
	node n as = NodeElement $ Element n as $ eventsToNodes $ init rest