network-protocol-xmpp 0.3.1 → 0.3.2
raw patch · 5 files changed
+113/−31 lines, 5 filesdep −failable-listdep ~libxml-saxPVP ok
version bump matches the API change (PVP)
Dependencies removed: failable-list
Dependency ranges changed: libxml-sax
API changes (from Hackage documentation)
Files
- Network/Protocol/XMPP/Component.hs +2/−3
- Network/Protocol/XMPP/Connections.hs +2/−3
- Network/Protocol/XMPP/Monad.hs +9/−16
- Network/Protocol/XMPP/XML.hs +98/−6
- network-protocol-xmpp.cabal +2/−3
Network/Protocol/XMPP/Component.hs view
@@ -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
Network/Protocol/XMPP/Connections.hs view
@@ -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
Network/Protocol/XMPP/Monad.hs view
@@ -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
Network/Protocol/XMPP/XML.hs view
@@ -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. <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
network-protocol-xmpp.cabal view
@@ -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