5 files changed, 113 insertions(+), 31 deletions(-)

M Network/Protocol/XMPP/Component.hs
M Network/Protocol/XMPP/Connections.hs
M Network/Protocol/XMPP/Monad.hs
M Network/Protocol/XMPP/XML.hs
M network-protocol-xmpp.cabal

@@ 29,7 29,6 @@ import qualified Data.Text.Lazy.Encoding as TE
 import Network (connectTo)
 import Network.Protocol.SASL.GNU (sha1)
 import qualified System.IO as IO
-import qualified Text.XML.LibXML.SAX as SAX
 
 import qualified Network.Protocol.XMPP.Connections as C
 import qualified Network.Protocol.XMPP.Handle as H


@@ 59,8 58,8 @@ beginStream jid = do
 		Nothing -> throwError M.NoComponentStreamID
 		Just x -> return x
 
-parseStreamID :: SAX.Event -> Maybe T.Text
-parseStreamID (SAX.BeginElement _ attrs) = sid where
+parseStreamID :: X.Event -> Maybe T.Text
+parseStreamID (X.BeginElement _ attrs) = sid where
 	sid = case idAttrs of
 		(x:_) -> Just . X.attributeText $ x
 		_ -> Nothing

@@ 24,7 24,6 @@ import Network (HostName, PortID)
 import qualified Data.ByteString.Lazy as B
 import qualified Data.Text.Lazy as T
 import Data.Text.Lazy.Encoding (encodeUtf8)
-import qualified Text.XML.LibXML.SAX as SAX
 
 import qualified Network.Protocol.XMPP.XML as X
 import Network.Protocol.XMPP.JID (JID, formatJID)


@@ 49,9 48,9 @@ xmlHeader ns jid = encodeUtf8 header where
 		, " xmlns:stream=\"http://etherx.jabber.org/streams\">"
 		]
 
-startOfStream :: Integer -> SAX.Event -> Bool
+startOfStream :: Integer -> X.Event -> Bool
 startOfStream depth event = case (depth, event) of
-	(1, (SAX.BeginElement elemName _)) -> qnameStream == elemName
+	(1, (X.BeginElement elemName _)) -> qnameStream == elemName
 	_ -> False
 
 qnameStream :: X.Name

@@ 44,8 44,6 @@ import qualified Control.Monad.Reader as R
 import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Text.Lazy (Text)
 import Data.Text.Lazy.Encoding (encodeUtf8)
-import qualified Data.FailableList as FL
-import qualified Text.XML.LibXML.SAX as SAX
 
 import Network.Protocol.XMPP.ErrorT
 import qualified Network.Protocol.XMPP.Handle as H


@@ 77,7 75,7 @@ data Error
 data Session = Session
 	{ sessionHandle :: H.Handle
 	, sessionNamespace :: Text
-	, sessionParser :: SAX.Parser
+	, sessionParser :: X.Parser
 	, sessionReadLock :: M.MVar ()
 	, sessionWriteLock :: M.MVar ()
 	}


@@ 111,7 109,7 @@ runXMPP s xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) s
 
 startXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a)
 startXMPP h ns xmpp = do
-	sax <- SAX.newParser
+	sax <- X.newParser
 	readLock <- M.newMVar ()
 	writeLock <- M.newMVar ()
 	runXMPP (Session h ns sax readLock writeLock) xmpp


@@ 119,7 117,7 @@ startXMPP h ns xmpp = do
 restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a
 restartXMPP newH xmpp = do
 	Session oldH ns _ readLock writeLock <- getSession
-	sax <- liftIO SAX.newParser
+	sax <- liftIO $ X.newParser
 	let s = Session (maybe oldH id newH) ns sax readLock writeLock
 	XMPP $ R.local (const s) (unXMPP xmpp)
 


@@ 156,23 154,18 @@ putElement = putBytes . encodeUtf8 . X.serialiseElement
 putStanza :: S.Stanza a => a -> XMPP ()
 putStanza = withLock sessionWriteLock . putElement . S.stanzaToElement
 
-readEvents :: (Integer -> SAX.Event -> Bool) -> XMPP [SAX.Event]
+readEvents :: (Integer -> X.Event -> Bool) -> XMPP [X.Event]
 readEvents done = xmpp where
 	xmpp = do
 		Session h _ p _ _ <- getSession
 		let nextEvents = do
 			-- TODO: read in larger increments
 			bytes <- liftTLS $ H.hGetBytes h 1
-			failable <- liftIO $ SAX.parse p bytes False
-			failableToList failable
+			parsed <- liftIO $ X.parse p bytes False
+			case parsed of
+				Left err -> E.throwError $ TransportError err
+				Right events -> return events
 		X.readEvents done nextEvents
-	
-	failableToList f = case f of
-		FL.Fail (SAX.Error e) -> E.throwError $ TransportError e
-		FL.Done -> return []
-		FL.Next e es -> do
-			es' <- failableToList es
-			return $ e : es'
 
 getElement :: XMPP X.Element
 getElement = xmpp where


@@ 182,7 175,7 @@ getElement = xmpp where
 			Just x -> return x
 			Nothing -> E.throwError $ TransportError "getElement: invalid event list"
 	
-	endOfTree 0 (SAX.EndElement _) = True
+	endOfTree 0 (X.EndElement _) = True
 	endOfTree _ _ = False
 
 getStanza :: XMPP S.ReceivedStanza

@@ 30,10 30,20 @@ module Network.Protocol.XMPP.XML
 	, escape
 	, serialiseElement
 	, readEvents
-	, SAX.eventsToElement
+	
+	-- * libxml-sax-0.4 API imitation
+	, Parser
+	, Event (..)
+	, newParser
+	, parse
+	, eventsToElement
+	
 	) where
+import Control.Monad (when)
+import qualified Data.ByteString.Lazy as B
 import qualified Data.Text.Lazy as T
 import Data.XML.Types
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import qualified Text.XML.LibXML.SAX as SAX
 
 getattr :: Name -> Element -> Maybe T.Text


@@ 99,10 109,53 @@ serialiseElement e = text where
 	serialiseNode (NodeComment _) = ""
 	serialiseNode (NodeInstruction _) = ""
 
+-- 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 T.Text [Event]))
+
+newParser :: IO Parser
+newParser = do
+	let toLazy t = T.fromChunks [t]
+	
+	ref <- newIORef (Right [])
+	p <- SAX.newParserIO (\err -> writeIORef ref (Left $ toLazy err)) Nothing
+	
+	let addEvent e = do
+		x <- readIORef ref
+		case x of
+			Left _ -> return ()
+			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 $ toLazy txt)
+	SAX.setCallback p SAX.parsedComment (\txt -> addEvent $ Comment $ toLazy txt)
+	SAX.setCallback p SAX.parsedInstruction (\i -> addEvent $ ProcessingInstruction i)
+	
+	return $ Parser p ref
+
+parse :: Parser -> B.ByteString -> Bool -> IO (Either T.Text [Event])
+parse (Parser p ref) bytes finish = do
+	writeIORef ref (Right [])
+	SAX.parseLazyBytes p bytes
+	when finish $ SAX.parseComplete p
+	eitherEvents <- readIORef ref
+	return $ case eitherEvents of
+		Left err -> Left err
+		Right events -> Right $ reverse events
+
+data Event
+	= BeginElement Name [Attribute]
+	| EndElement Name
+	| Characters T.Text
+	| Comment T.Text
+	| ProcessingInstruction Instruction
+
 readEvents :: Monad m
-           => (Integer -> SAX.Event -> Bool)
-           -> m [SAX.Event]
-           -> m [SAX.Event]
+           => (Integer -> Event -> Bool)
+           -> m [Event]
+           -> m [Event]
 readEvents done nextEvents = readEvents' 0 [] where
 	readEvents' depth acc = do
 		events <- nextEvents


@@ 114,10 167,49 @@ readEvents done nextEvents = readEvents' 0 [] where
 	step [] depth acc = (False, depth, acc)
 	step (e:es) depth acc = let
 		depth' = depth + case e of
-			(SAX.BeginElement _ _) -> 1
-			(SAX.EndElement _) -> (- 1)
+			(BeginElement _ _) -> 1
+			(EndElement _) -> (- 1)
 			_ -> 0
 		acc' = e : acc
 		in if done depth' e
 			then (True, depth', reverse acc')
 			else step es depth' acc'
+
+-- | Convert a list of events to a single 'X.Element'. If the events do not
+-- contain at least one valid element, 'Nothing' will be returned instead.
+eventsToElement :: [Event] -> Maybe Element
+eventsToElement es = case eventsToNodes es >>= isElement of
+	(e:_) -> Just e
+	_ -> Nothing
+
+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 :: [Event] -> [[Event]]
+splitBlocks es = ret where
+	(_, _, ret) = foldl splitBlocks' (0, [], []) es
+	
+	splitBlocks' (depth, accum, allAccum) e = split where
+		split = if depth' == 0
+			then (depth', [], allAccum ++ [accum'])
+			else (depth', accum', allAccum)
+		accum' = accum ++ [e]
+		depth' :: Integer
+		depth' = depth + case e of
+			(BeginElement _ _) -> 1
+			(EndElement _) -> (- 1)
+			_ -> 0
+
+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)]
+		_ -> []
+	
+	node n as = NodeElement $ Element n as $ eventsToNodes $ init rest

@@ 1,5 1,5 @@
 name: network-protocol-xmpp
-version: 0.3.1
+version: 0.3.2
 synopsis: Client <-> Server communication over XMPP
 license: GPL-3
 license-file: License.txt


@@ 25,13 25,12 @@ library
     , gnuidn >= 0.1 && < 0.2
     , gnutls >= 0.1 && < 0.3
     , bytestring >= 0.9 && < 0.10
-    , libxml-sax >= 0.4 && < 0.5
     , gsasl >= 0.3 && < 0.4
     , network >= 2.2 && < 2.3
     , transformers >= 0.2 && < 0.3
     , monads-tf >= 0.1 && < 0.2
+    , libxml-sax >= 0.6 && < 0.7
     , xml-types >= 0.1 && < 0.2
-    , failable-list >= 0.2 && < 0.3
 
   exposed-modules:
     Network.Protocol.XMPP