From bb4dfca01169ef53b09082baaefd85219541f336 Mon Sep 17 00:00:00 2001 From: John Millikin Date: Sun, 15 Aug 2010 04:35:21 +0000 Subject: [PATCH] Update to use libxml-sax 0.6 --- Network/Protocol/XMPP/Component.hs | 5 +- Network/Protocol/XMPP/Connections.hs | 5 +- Network/Protocol/XMPP/Monad.hs | 25 +++---- Network/Protocol/XMPP/XML.hs | 104 +++++++++++++++++++++++++-- network-protocol-xmpp.cabal | 5 +- 5 files changed, 113 insertions(+), 31 deletions(-) diff --git a/Network/Protocol/XMPP/Component.hs b/Network/Protocol/XMPP/Component.hs index 9cfb70b..c7dc6af 100644 --- a/Network/Protocol/XMPP/Component.hs +++ b/Network/Protocol/XMPP/Component.hs @@ -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 diff --git a/Network/Protocol/XMPP/Connections.hs b/Network/Protocol/XMPP/Connections.hs index 59272ac..0c9c710 100644 --- a/Network/Protocol/XMPP/Connections.hs +++ b/Network/Protocol/XMPP/Connections.hs @@ -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 diff --git a/Network/Protocol/XMPP/Monad.hs b/Network/Protocol/XMPP/Monad.hs index 0b17fe7..7b4f977 100644 --- a/Network/Protocol/XMPP/Monad.hs +++ b/Network/Protocol/XMPP/Monad.hs @@ -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 diff --git a/Network/Protocol/XMPP/XML.hs b/Network/Protocol/XMPP/XML.hs index a8c2dd2..bb11f79 100644 --- a/Network/Protocol/XMPP/XML.hs +++ b/Network/Protocol/XMPP/XML.hs @@ -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. 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 index 0f642b6..0264687 100644 --- 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 @@ 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 -- 2.45.2