diff --git a/Network/Protocol/XMPP/Component.hs b/Network/Protocol/XMPP/Component.hs
--- a/Network/Protocol/XMPP/Component.hs
+++ b/Network/Protocol/XMPP/Component.hs
@@ -29,7 +29,6 @@
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 @@
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
diff --git a/Network/Protocol/XMPP/Connections.hs b/Network/Protocol/XMPP/Connections.hs
--- a/Network/Protocol/XMPP/Connections.hs
+++ b/Network/Protocol/XMPP/Connections.hs
@@ -24,7 +24,6 @@
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 @@
, " 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
diff --git a/Network/Protocol/XMPP/Monad.hs b/Network/Protocol/XMPP/Monad.hs
--- a/Network/Protocol/XMPP/Monad.hs
+++ b/Network/Protocol/XMPP/Monad.hs
@@ -44,8 +44,6 @@
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 Session = Session
{ sessionHandle :: H.Handle
, sessionNamespace :: Text
- , sessionParser :: SAX.Parser
+ , sessionParser :: X.Parser
, sessionReadLock :: M.MVar ()
, sessionWriteLock :: M.MVar ()
}
@@ -111,7 +109,7 @@
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 @@
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 @@
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 @@
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
diff --git a/Network/Protocol/XMPP/XML.hs b/Network/Protocol/XMPP/XML.hs
--- a/Network/Protocol/XMPP/XML.hs
+++ b/Network/Protocol/XMPP/XML.hs
@@ -30,10 +30,20 @@
, 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 @@
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 @@
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. and 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
diff --git a/network-protocol-xmpp.cabal b/network-protocol-xmpp.cabal
--- a/network-protocol-xmpp.cabal
+++ b/network-protocol-xmpp.cabal
@@ -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 @@
, 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