~singpolyma/network-protocol-xmpp

bb4dfca01169ef53b09082baaefd85219541f336 — John Millikin 13 years ago 0563144
Update to use libxml-sax 0.6
M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +2 -3
@@ 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

M Network/Protocol/XMPP/Connections.hs => Network/Protocol/XMPP/Connections.hs +2 -3
@@ 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

M Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +9 -16
@@ 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

M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +98 -6
@@ 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

M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +2 -3
@@ 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