~singpolyma/network-protocol-xmpp

fa4477d23aacb9745b349aaa063892c705861346 — John Millikin 12 years ago 6831ae3
Use 'xml-types' instead of HXT for basic XML processing.
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +18 -30
@@ 20,14 20,10 @@ module Network.Protocol.XMPP.Client
	) where
import Control.Monad.Error (throwError)
import Control.Monad.Trans (liftIO)
import Network (connectTo)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified System.IO as IO
import Data.ByteString (ByteString)
import qualified Data.Text.Lazy as T
import Network (connectTo)
import qualified System.IO as IO

import qualified Network.Protocol.XMPP.Client.Authentication as A
import qualified Network.Protocol.XMPP.Connections as C


@@ 35,7 31,7 @@ import qualified Network.Protocol.XMPP.Client.Features as F
import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.JID as J
import qualified Network.Protocol.XMPP.Monad as M
import Network.Protocol.XMPP.XML (element, qname)
import qualified Network.Protocol.XMPP.XML as X
import Network.Protocol.XMPP.ErrorT
import Network.Protocol.XMPP.Stanza



@@ 64,14 60,14 @@ newStream :: J.JID -> M.XMPP [F.Feature]
newStream jid = do
	M.putBytes $ C.xmlHeader "jabber:client" jid
	M.readEvents C.startOfStream
	F.parseFeatures `fmap` M.getTree
	F.parseFeatures `fmap` M.getElement

tryTLS :: J.JID -> [F.Feature] -> ([F.Feature] -> M.XMPP a) -> M.XMPP a
tryTLS sjid features m
	| not (streamSupportsTLS features) = m features
	| otherwise = do
		M.putTree xmlStartTLS
		M.getTree
		M.putElement xmlStartTLS
		M.getElement
		h <- M.getHandle
		eitherTLS <- liftIO $ runErrorT $ H.startTLS h
		case eitherTLS of


@@ 90,11 86,11 @@ bindJID jid = do
	-- Bind
	M.putStanza . bindStanza . J.jidResource $ jid
	bindResult <- M.getStanza
	
	let jidArrow =
		A.deep (A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-bind" "jid"))
		>>> A.getChildren
		>>> A.getText
	let getJID e =
		X.elementChildren e
		>>= X.hasName (X.Name "jid" (Just "urn:ietf:params:xml:ns:xmpp-bind") Nothing)
		>>= X.elementNodes
		>>= X.getText
	
	let maybeJID = do
		iq <- case bindResult of


@@ 102,9 98,9 @@ bindJID jid = do
			_ -> Nothing
		payload <- iqPayload iq
		
		case A.runLA jidArrow payload of
		case getJID payload of
			[] -> Nothing
			(str:_) -> J.parseJID (T.pack str)
			(str:_) -> J.parseJID str
	
	returnedJID <- case maybeJID of
		Just x -> return x


@@ 121,27 117,19 @@ bindJID jid = do

bindStanza :: Maybe J.Resource -> IQ
bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where
	payload = element ("", "bind")
		[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-bind")]
		requested
	payload = X.nselement "urn:ietf:params:xml:ns:xmpp-bind" "bind" [] requested
	requested = case fmap J.strResource resource of
		Nothing -> []
		Just x -> [element ("", "resource")
			[]
			[XN.mkText (T.unpack x)]]
		Just x -> [X.NodeElement $ X.element "resource" [] [X.NodeText x]]

sessionStanza :: IQ
sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where
	payload = element ("", "session")
		[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")]
		[]
	payload = X.nselement "urn:ietf:params:xml:ns:xmpp-session" "session" [] []

streamSupportsTLS :: [F.Feature] -> Bool
streamSupportsTLS = any isStartTLS where
	isStartTLS (F.FeatureStartTLS _) = True
	isStartTLS _                     = False

xmlStartTLS :: DOM.XmlTree
xmlStartTLS = element ("", "starttls")
	[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-tls")]
	[]
xmlStartTLS :: X.Element
xmlStartTLS = X.nselement "urn:ietf:params:xml:ns:xmpp-tls" "starttls" [] []

M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +26 -33
@@ 28,16 28,11 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import Data.Typeable (Typeable)

import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.XmlNode as XN
import Text.XML.HXT.DOM.Interface (XmlTree)
import qualified Network.Protocol.SASL.GNU as SASL

import qualified Network.Protocol.XMPP.Monad as M
import qualified Network.Protocol.XMPP.XML as X
import Network.Protocol.XMPP.JID (JID, formatJID, jidResource)
import Network.Protocol.XMPP.XML (element, qname)

data Result = Success | Failure
	deriving (Show, Eq)


@@ 68,7 63,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
				Just mechanism -> authSasl ctx mechanism
		case res of
			Right Success -> return ()
			Right Failure -> E.throwError $ M.AuthenticationFailure
			Right Failure -> E.throwError M.AuthenticationFailure
			Left (XmppError err) -> E.throwError err
			Left (SaslError err) -> E.throwError $ M.AuthenticationError err
	


@@ 82,10 77,9 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
			SASL.setProperty SASL.PropertyHostname $ utf8 hostname
			
			(b64text, rc) <- SASL.step64 $ B.pack ""
			putTree ctx $ element ("", "auth")
				[ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")
				, ("", "mechanism", B.unpack mechBytes)]
				[XN.mkText $ B.unpack b64text]
			putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "auth"
				[("mechanism", TL.pack $ B.unpack mechBytes)]
				[X.NodeText $ TL.pack $ B.unpack b64text]
			
			case rc of
				SASL.Complete -> saslFinish ctx


@@ 97,40 91,39 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where

saslLoop :: M.Context -> SASL.Session Result
saslLoop ctx = do
	challengeText <- liftIO $ A.runX (
		A.arrIO (\_ -> getTree ctx)
		>>> A.getChildren
		>>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "challenge")
		>>> A.getChildren >>> A.getText)
	elemt <- getElement ctx
	let challengeText =
		return elemt
		>>= X.hasName (X.Name "challenge" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing)
		>>= X.elementNodes
		>>= X.getText
	when (null challengeText) $ saslError "Received empty challenge"
	
	(b64text, rc) <- SASL.step64 $ B.pack $ concat challengeText
	putTree ctx $ element ("", "response")
		[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")]
		[XN.mkText $ B.unpack b64text]
	(b64text, rc) <- SASL.step64 . B.pack . concatMap TL.unpack $ challengeText
	putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "response"
		[] [X.NodeText $ TL.pack $ B.unpack b64text]
	case rc of
		SASL.Complete -> saslFinish ctx
		SASL.NeedsMore -> saslLoop ctx

saslFinish :: M.Context -> SASL.Session Result
saslFinish ctx = liftIO $ do
	successElem <- A.runX (
		A.arrIO (\_ -> getTree ctx)
		>>> A.getChildren
		>>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "success"))
	
	return $ if null successElem then Failure else Success
saslFinish ctx = do
	elemt <- getElement ctx
	let success =
		return elemt
		>>= X.hasName (X.Name "success" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing)
	return $ if null success then Failure else Success

putTree :: M.Context -> XmlTree -> SASL.Session ()
putTree ctx tree = liftIO $ do
	res <- M.runXMPP ctx $ M.putTree tree
putElement :: M.Context -> X.Element -> SASL.Session ()
putElement ctx elemt = liftIO $ do
	res <- M.runXMPP ctx $ M.putElement elemt
	case res of
		Left err -> Exc.throwIO $ XmppError err
		Right x -> return x

getTree :: M.Context -> IO XmlTree
getTree ctx = do
	res <- M.runXMPP ctx $ M.getTree
getElement :: M.Context -> SASL.Session X.Element
getElement ctx = liftIO $ do
	res <- M.runXMPP ctx M.getElement
	case res of
		Left err -> Exc.throwIO $ XmppError err
		Right x -> return x

M Network/Protocol/XMPP/Client/Features.hs => Network/Protocol/XMPP/Client/Features.hs +30 -32
@@ 13,17 13,16 @@
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Client.Features
	( Feature (..)
	, parseFeatures
	, parseFeature
	) where
import Control.Arrow ((&&&))
import qualified Data.ByteString.Char8 as B
import Text.XML.HXT.Arrow ((>>>), (&&&))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import Network.Protocol.XMPP.XML (qname)
import qualified Data.Text.Lazy as TL
import qualified Network.Protocol.XMPP.XML as X

data Feature =
	  FeatureStartTLS Bool


@@ 31,40 30,39 @@ data Feature =
	| FeatureRegister
	| FeatureBind
	| FeatureSession
	| FeatureUnknown DOM.XmlTree
	| FeatureUnknown X.Element
	deriving (Show, Eq)

parseFeatures :: DOM.XmlTree -> [Feature]
parseFeatures = A.runLA $
	A.getChildren
	>>> A.hasQName qnameFeatures
	>>> A.getChildren
	>>> A.arrL (\t' -> [parseFeature t'])
parseFeatures :: X.Element -> [Feature]
parseFeatures elemt =
	X.hasName nameFeatures elemt
	>>= X.elementChildren
	>>= return . parseFeature

parseFeature :: DOM.XmlTree -> Feature
parseFeature t = feature where
	mkPair = maybe ("", "") $ DOM.namespaceUri &&& DOM.localPart
	feature = case mkPair (XN.getName t) of
		("urn:ietf:params:xml:ns:xmpp-tls", "starttls") -> parseFeatureTLS t
		("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms") -> parseFeatureSASL t
parseFeature :: X.Element -> Feature
parseFeature elemt = feature where
	unpackName = (maybe "" id . X.nameNamespace) &&& X.nameLocalName
	feature = case unpackName (X.elementName elemt) of
		("urn:ietf:params:xml:ns:xmpp-tls", "starttls") -> parseFeatureTLS elemt
		("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms") -> parseFeatureSASL elemt
		("http://jabber.org/features/iq-register", "register") -> FeatureRegister
		("urn:ietf:params:xml:ns:xmpp-bind", "bind") -> FeatureBind
		("urn:ietf:params:xml:ns:xmpp-session", "session") -> FeatureSession
		_ -> FeatureUnknown t
		_ -> FeatureUnknown elemt

parseFeatureTLS :: DOM.XmlTree -> Feature
parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required
parseFeatureTLS :: X.Element -> Feature
parseFeatureTLS _ = FeatureStartTLS True -- TODO: detect whether or not required

parseFeatureSASL :: DOM.XmlTree -> Feature
parseFeatureSASL = FeatureSASL . A.runLA (
	A.getChildren
	>>> A.hasQName qnameMechanism
	>>> A.getChildren
	>>> A.getText
	>>> A.arr B.pack)
parseFeatureSASL :: X.Element -> Feature
parseFeatureSASL e = FeatureSASL $
	X.elementChildren e
	>>= X.hasName nameMechanism
	>>= X.elementNodes
	>>= X.getText
	>>= return . B.pack . TL.unpack

qnameMechanism :: DOM.QName
qnameMechanism = qname "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism"
nameMechanism :: X.Name
nameMechanism = X.Name "mechanism" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing

qnameFeatures :: DOM.QName
qnameFeatures = qname "http://etherx.jabber.org/streams" "features"
nameFeatures :: X.Name
nameFeatures = X.Name "features" (Just "http://etherx.jabber.org/streams") Nothing

M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +11 -21
@@ 27,10 27,6 @@ import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as TE
import Network (connectTo)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import Network.Protocol.SASL.GNU (sha1)
import qualified System.IO as IO
import qualified Text.XML.LibXML.SAX as SAX


@@ 38,7 34,7 @@ import qualified Text.XML.LibXML.SAX as SAX
import qualified Network.Protocol.XMPP.Connections as C
import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.Monad as M
import Network.Protocol.XMPP.XML (element, qname)
import qualified Network.Protocol.XMPP.XML as X
import Network.Protocol.XMPP.JID (JID)

runComponent :: C.Server


@@ 66,33 62,27 @@ beginStream jid = do
parseStreamID :: SAX.Event -> Maybe T.Text
parseStreamID (SAX.BeginElement _ attrs) = sid where
	sid = case idAttrs of
		(x:_) -> Just . T.pack . SAX.attributeValue $ x
		(x:_) -> Just . X.attributeValue $ x
		_ -> Nothing
	idAttrs = filter (matchingName . SAX.attributeName) attrs
	matchingName n = and
		[ SAX.qnameNamespace n == "jabber:component:accept"
		, SAX.qnameLocalName n == "id"
		]
	idAttrs = filter (matchingName . X.attributeName) attrs
	matchingName = (== X.Name "jid" (Just "jabber:component:accept") Nothing)
parseStreamID _ = Nothing

authenticate :: T.Text -> T.Text -> M.XMPP ()
authenticate streamID password = do
	let bytes = buildSecret streamID password
	let digest = showDigest $ sha1 bytes
	M.putTree $ element ("", "handshake") [] [XN.mkText digest]
	result <- M.getTree
	let accepted = A.runLA $
		A.getChildren
		>>> A.hasQName (qname "jabber:component:accept" "handshake")
	when (null (accepted result)) $
	M.putElement $ X.element "handshake" [] [X.NodeText digest]
	result <- M.getElement
	let nameHandshake = X.Name "handshake" (Just "jabber:component:accept") Nothing
	when (null (X.hasName nameHandshake result)) $
		throwError M.ComponentHandshakeFailed

buildSecret :: T.Text -> T.Text -> B.ByteString
buildSecret sid password = B.concat . BL.toChunks $ bytes where
	escape = T.pack . DOM.attrEscapeXml . T.unpack
	bytes = TE.encodeUtf8 $ escape $ T.append sid password
	bytes = TE.encodeUtf8 $ X.escape $ T.append sid password

showDigest :: B.ByteString -> String
showDigest = concatMap wordToHex . B.unpack where
showDigest :: B.ByteString -> T.Text
showDigest = T.pack . concatMap wordToHex . B.unpack where
	wordToHex x = [hexDig $ shiftR x 4, hexDig $ x .&. 0xF]
	hexDig = intToDigit . fromIntegral

M Network/Protocol/XMPP/Connections.hs => Network/Protocol/XMPP/Connections.hs +5 -8
@@ 24,11 24,10 @@ 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.HXT.DOM.Interface as DOM
import qualified Text.XML.LibXML.SAX as SAX

import qualified Network.Protocol.XMPP.XML as X
import Network.Protocol.XMPP.JID (JID, formatJID)
import Network.Protocol.XMPP.XML (qname, convertQName)

data Server = Server
	{ serverJID      :: JID


@@ 41,8 40,7 @@ data Server = Server
-- attributes.
xmlHeader :: T.Text -> JID -> B.ByteString
xmlHeader ns jid = encodeUtf8 header where
	escape = T.pack . DOM.attrEscapeXml . T.unpack
	attr x = T.concat ["\"", escape x, "\""]
	attr x = T.concat ["\"", X.escape x, "\""]
	header = T.concat
		[ "<?xml version='1.0'?>\n"
		, "<stream:stream xmlns=" , attr ns


@@ 53,9 51,8 @@ xmlHeader ns jid = encodeUtf8 header where

startOfStream :: Integer -> SAX.Event -> Bool
startOfStream depth event = case (depth, event) of
	(1, (SAX.BeginElement elemName _)) ->
		qnameStream == convertQName elemName
	(1, (SAX.BeginElement elemName _)) -> qnameStream == elemName
	_ -> False

qnameStream :: DOM.QName
qnameStream = qname "http://etherx.jabber.org/streams" "stream"
qnameStream :: X.Name
qnameStream = X.Name "stream" (Just "http://etherx.jabber.org/streams") Nothing

M Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +40 -31
@@ 14,6 14,7 @@
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Monad
	( XMPP (..)
	, Error (..)


@@ 26,11 27,11 @@ module Network.Protocol.XMPP.Monad
	, getContext
	
	, readEvents
	, getTree
	, getElement
	, getStanza
	
	, putBytes
	, putTree
	, putElement
	, putStanza
	) where
import Control.Monad.Trans (MonadIO, liftIO)


@@ 38,11 39,8 @@ import qualified Control.Monad.Error as E
import qualified Control.Monad.Reader as R
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Text.Lazy (Text)

import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
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


@@ 51,11 49,12 @@ import qualified Network.Protocol.XMPP.Stanza as S
import qualified Network.Protocol.XMPP.XML as X

data Error
	= InvalidStanza DOM.XmlTree
	= InvalidStanza X.Element
	| InvalidBindResult S.ReceivedStanza
	| AuthenticationFailure
	| AuthenticationError Text
	| TransportError Text
	| MarkupError Text
	| NoComponentStreamID
	| ComponentHandshakeFailed
	deriving (Show)


@@ 84,13 83,13 @@ runXMPP ctx xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) ctx

startXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a)
startXMPP h ns xmpp = do
	sax <- SAX.mkParser
	sax <- SAX.newParser
	runXMPP (Context h ns sax) xmpp

restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a
restartXMPP newH xmpp = do
	Context oldH ns _ <- getContext
	sax <- liftIO $ SAX.mkParser
	sax <- liftIO SAX.newParser
	let ctx = Context (maybe oldH id newH) ns sax
	XMPP $ R.local (const ctx) (unXMPP xmpp)



@@ 114,35 113,45 @@ putBytes bytes = do
	h <- getHandle
	liftTLS $ H.hPutBytes h bytes

putTree :: DOM.XmlTree -> XMPP ()
putTree t = do
	let root = XN.mkRoot [] [t]
	[text] <- liftIO $ A.runX (A.constA root >>> A.writeDocumentToString [
		(A.a_no_xml_pi, "1")
		])
	putBytes $ B.pack text
putElement :: X.Element -> XMPP ()
putElement = putBytes . encodeUtf8 . X.serialiseElement

putStanza :: S.Stanza a => a -> XMPP ()
putStanza = putTree . S.stanzaToTree
putStanza = putElement . S.stanzaToElement

readEvents :: (Integer -> SAX.Event -> Bool) -> XMPP [SAX.Event]
readEvents done = do
	Context h _ p <- getContext
	let nextChar = do
		-- TODO: read in larger increments
		bytes <- liftTLS $ H.hGetBytes h 1
		return $ B.unpack bytes
	X.readEvents done nextChar p

getTree :: XMPP DOM.XmlTree
getTree = X.eventsToTree `fmap` readEvents endOfTree where
readEvents done = xmpp where
	xmpp = do
		Context h _ p <- getContext
		let nextEvents = do
			-- TODO: read in larger increments
			bytes <- liftTLS $ H.hGetBytes h 1
			failable <- liftIO $ SAX.parse p bytes False
			failableToList failable
		X.readEvents done nextEvents
	
	failableToList f = case f of
		FL.Fail (SAX.Error e) -> E.throwError $ MarkupError e
		FL.Done -> return []
		FL.Next e es -> do
			es' <- failableToList es
			return $ e : es'

getElement :: XMPP X.Element
getElement = xmpp where
	xmpp = do
		events <- readEvents endOfTree
		case X.eventsToElement events of
			Just x -> return x
			Nothing -> E.throwError $ MarkupError "getElement: invalid event list"
	
	endOfTree 0 (SAX.EndElement _) = True
	endOfTree _ _ = False

getStanza :: XMPP S.ReceivedStanza
getStanza = do
	tree <- getTree
	elemt <- getElement
	Context _ ns _ <- getContext
	case S.treeToStanza ns tree of
	case S.elementToStanza ns elemt of
		Just x -> return x
		Nothing -> E.throwError $ InvalidStanza tree
		Nothing -> E.throwError $ InvalidStanza elemt

M Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +60 -66
@@ 13,6 13,7 @@
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Stanza
	( Stanza (..)
	


@@ 28,24 29,21 @@ module Network.Protocol.XMPP.Stanza
	, emptyPresence
	, emptyIQ
	
	, treeToStanza
	, elementToStanza
	) where

import Control.Monad (when)
import qualified Data.Text.Lazy as T
import Text.XML.HXT.DOM.Interface (XmlTree)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A

import Network.Protocol.XMPP.XML (element)
import qualified Network.Protocol.XMPP.XML as X
import Network.Protocol.XMPP.JID (JID, parseJID, formatJID)

class Stanza a where
	stanzaTo       :: a -> Maybe JID
	stanzaFrom     :: a -> Maybe JID
	stanzaID       :: a -> Maybe T.Text
	stanzaLang     :: a -> Maybe T.Text
	stanzaPayloads :: a -> [XmlTree]
	stanzaToTree   :: a -> XmlTree
	stanzaTo        :: a -> Maybe JID
	stanzaFrom      :: a -> Maybe JID
	stanzaID        :: a -> Maybe T.Text
	stanzaLang      :: a -> Maybe T.Text
	stanzaPayloads  :: a -> [X.Element]
	stanzaToElement :: a -> X.Element

data ReceivedStanza
	= ReceivedMessage Message


@@ 59,7 57,7 @@ data Message = Message
	, messageFrom     :: Maybe JID
	, messageID       :: Maybe T.Text
	, messageLang     :: Maybe T.Text
	, messagePayloads :: [XmlTree]
	, messagePayloads :: [X.Element]
	}
	deriving (Show)



@@ 69,7 67,7 @@ instance Stanza Message where
	stanzaID = messageID
	stanzaLang = messageLang
	stanzaPayloads = messagePayloads
	stanzaToTree x = stanzaToTree' x "message" typeStr where
	stanzaToElement x = stanzaToElement' x "message" typeStr where
		typeStr = case messageType x of
			MessageNormal -> "normal"
			MessageChat -> "chat"


@@ 101,7 99,7 @@ data Presence = Presence
	, presenceFrom     :: Maybe JID
	, presenceID       :: Maybe T.Text
	, presenceLang     :: Maybe T.Text
	, presencePayloads :: [XmlTree]
	, presencePayloads :: [X.Element]
	}
	deriving (Show)



@@ 111,7 109,7 @@ instance Stanza Presence where
	stanzaID = presenceID
	stanzaLang = presenceLang
	stanzaPayloads = presencePayloads
	stanzaToTree x = stanzaToTree' x "presence" typeStr where
	stanzaToElement x = stanzaToElement' x "presence" typeStr where
		typeStr = case presenceType x of
			PresenceAvailable -> ""
			PresenceUnavailable -> "unavailable"


@@ 149,7 147,7 @@ data IQ = IQ
	, iqFrom    :: Maybe JID
	, iqID      :: Maybe T.Text
	, iqLang    :: Maybe T.Text
	, iqPayload :: Maybe XmlTree
	, iqPayload :: Maybe X.Element
	}
	deriving (Show)



@@ 159,9 157,9 @@ instance Stanza IQ where
	stanzaID = iqID
	stanzaLang = iqLang
	stanzaPayloads iq = case iqPayload iq of
		Just tree -> [tree]
		Just elemt -> [elemt]
		Nothing -> []
	stanzaToTree x = stanzaToTree' x "iq" typeStr where
	stanzaToElement x = stanzaToElement' x "iq" typeStr where
		typeStr = case iqType x of
			IQGet -> "get"
			IQSet -> "set"


@@ 185,36 183,35 @@ emptyIQ t = IQ
	, iqPayload = Nothing
	}

stanzaToTree' :: Stanza a => a -> String -> String -> XmlTree
stanzaToTree' stanza name typeStr = element ("", name) attrs payloads where
	payloads = stanzaPayloads stanza
stanzaToElement' :: Stanza a => a -> T.Text -> T.Text -> X.Element
stanzaToElement' stanza name typeStr = X.element name attrs payloads where
	payloads = map X.NodeElement $ stanzaPayloads stanza
	attrs = concat
		[ mattr "to" $ fmap formatJID . stanzaTo
		, mattr "from" $ fmap formatJID . stanzaFrom
		, mattr "id" stanzaID
		, mattr "xml:lang" stanzaLang
		, if null typeStr then [] else [("", "type", typeStr)]
		, if T.null typeStr then [] else [("type", typeStr)]
		]
	mattr label f = case f stanza of
		Nothing -> []
		Just text -> [("", label, T.unpack text)]
		Just text -> [(label, text)]

treeToStanza :: T.Text -> XmlTree -> Maybe ReceivedStanza
treeToStanza ns root = do
	tree <- runMA (A.getChildren >>> A.isElem) root
	treeNS <- runMA A.getNamespaceUri tree
	if T.pack treeNS == ns then Just () else Nothing
elementToStanza :: T.Text -> X.Element -> Maybe ReceivedStanza
elementToStanza ns elemt = do
	let elemNS = X.nameNamespace . X.elementName $ elemt
	when (elemNS /= Just ns) Nothing
	
	treeName <- runMA A.getLocalPart tree
	case treeName of
		"message" -> ReceivedMessage `fmap` parseMessage tree
		"presence" -> ReceivedPresence `fmap` parsePresence tree
		"iq" -> ReceivedIQ `fmap` parseIQ tree
	let elemName = X.nameLocalName . X.elementName $ elemt
	case elemName of
		"message" -> ReceivedMessage `fmap` parseMessage elemt
		"presence" -> ReceivedPresence `fmap` parsePresence elemt
		"iq" -> ReceivedIQ `fmap` parseIQ elemt
		_ -> Nothing

parseMessage :: XmlTree -> Maybe Message
parseMessage t = do
	typeStr <- runMA (A.getAttrValue "type") t
parseMessage :: X.Element -> Maybe Message
parseMessage elemt = do
	typeStr <- X.getattr (X.name "type") elemt
	msgType <- case typeStr of
		"normal"    -> Just MessageNormal
		"chat"      -> Just MessageChat


@@ 222,16 219,16 @@ parseMessage t = do
		"headline"  -> Just MessageHeadline
		"error"     -> Just MessageError
		_           -> Nothing
	msgTo <- xmlJID "to" t
	msgFrom <- xmlJID "from" t
	let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
	let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
	let payloads = A.runLA (A.getChildren >>> A.isElem) t
	msgTo <- xmlJID "to" elemt
	msgFrom <- xmlJID "from" elemt
	let msgID = X.getattr (X.name "id") elemt
	let msgLang = X.getattr (X.name "lang") elemt
	let payloads = X.elementChildren elemt
	return $ Message msgType msgTo msgFrom msgID msgLang payloads

parsePresence :: XmlTree -> Maybe Presence
parsePresence t = do
	let typeStr = maybe "" id $ runMA (A.getAttrValue "type") t
parsePresence :: X.Element -> Maybe Presence
parsePresence elemt = do
	let typeStr = maybe "" id $ X.getattr (X.name "type") elemt
	pType <- case typeStr of
		""             -> Just PresenceAvailable
		"unavailable"  -> Just PresenceUnavailable


@@ 243,16 240,16 @@ parsePresence t = do
		"error"        -> Just PresenceError
		_              -> Nothing
		
	msgTo <- xmlJID "to" t
	msgFrom <- xmlJID "from" t
	let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
	let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
	let payloads = A.runLA (A.getChildren >>> A.isElem) t
	msgTo <- xmlJID "to" elemt
	msgFrom <- xmlJID "from" elemt
	let msgID = X.getattr (X.name "id") elemt
	let msgLang = X.getattr (X.name "lang") elemt
	let payloads = X.elementChildren elemt
	return $ Presence pType msgTo msgFrom msgID msgLang payloads

parseIQ :: XmlTree -> Maybe IQ
parseIQ t = do
	typeStr <- runMA (A.getAttrValue "type") t
parseIQ :: X.Element -> Maybe IQ
parseIQ elemt = do
	typeStr <- X.getattr (X.name "type") elemt
	iqType <- case typeStr of
		"get"    -> Just IQGet
		"set"    -> Just IQSet


@@ 260,21 257,18 @@ parseIQ t = do
		"error"  -> Just IQError
		_        -> Nothing
	
	msgTo <- xmlJID "to" t
	msgFrom <- xmlJID "from" t
	let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
	let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
	let payload = runMA (A.getChildren >>> A.isElem) t
	msgTo <- xmlJID "to" elemt
	msgFrom <- xmlJID "from" elemt
	let msgID = X.getattr (X.name "id") elemt
	let msgLang = X.getattr (X.name "lang") elemt
	let payload = case X.elementChildren elemt of
		[] -> Nothing
		child:_ -> Just child
	return $ IQ iqType msgTo msgFrom msgID msgLang payload

xmlJID :: String -> XmlTree -> Maybe (Maybe JID)
xmlJID attr t = case runMA (A.getAttrValue attr) t of
xmlJID :: T.Text -> X.Element -> Maybe (Maybe JID)
xmlJID name elemt = case X.getattr (X.name name) elemt of
	Nothing -> Just Nothing
	Just raw -> case parseJID (T.pack raw) of
	Just raw -> case parseJID raw of
		Just jid -> Just (Just jid)
		Nothing -> Nothing

runMA :: A.LA a b -> a -> Maybe b
runMA arr x = case A.runLA arr x of
	[] -> Nothing
	(y:_) -> Just y

M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +84 -94
@@ 1,4 1,4 @@
-- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com>
-- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
-- 
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by


@@ 13,32 13,94 @@
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.XML
	( readEvents
	, eventsToTree
	, convertQName
	( module Data.XML.Types
	, elementChildren
	, hasName
	, getattr
	, getText
	, name
	, nsname
	, element
	, attr
	, qname
	, nselement
	, escape
	, serialiseElement
	, readEvents
	, SAX.eventsToElement
	) where
import Control.Monad.Trans (MonadIO, liftIO)
import qualified Data.ByteString.Char8 as C8
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE

-- XML Parsing
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Data.Text.Lazy as T
import Data.XML.Types
import qualified Text.XML.LibXML.SAX as SAX

readEvents :: MonadIO m => (Integer -> SAX.Event -> Bool) -> m String -> SAX.Parser -> m [SAX.Event]
readEvents done getChars parser = readEvents' 0 [] where
	nextEvents = do
		chars <- getChars
		liftIO $ SAX.parse parser chars False
elementChildren :: Element -> [Element]
elementChildren = concatMap isElement . elementNodes

hasName :: Name -> Element -> [Element]
hasName n e = [e | elementName e == n]

isElement :: Node -> [Element]
isElement (NodeElement e) = [e]
isElement _ = []

getattr :: Name -> Element -> Maybe T.Text
getattr attrname elemt = case filter ((attrname ==) . attributeName) $ elementAttributes elemt of
	[] -> Nothing
	attr:_ -> Just $ attributeValue attr

getText :: Node -> [T.Text]
getText (NodeText t) = [t]
getText _ = []

name :: T.Text -> Name
name t = Name t Nothing Nothing

nsname :: T.Text -> T.Text -> Name
nsname ns n = Name n (Just ns) Nothing

escape :: T.Text -> T.Text
escape = T.concatMap escapeChar where
	escapeChar c = case c of
		'&' -> "&amp;"
		'<' -> "&lt;"
		'>' -> "&gt;"
		'"' -> "&quot;"
		'\'' -> "&apos;"
		_ -> T.singleton c

element :: T.Text -> [(T.Text, T.Text)] -> [Node] -> Element
element elemName attrs children = Element (name elemName) attrs' children where
	attrs' = [Attribute (name n) value | (n, value) <- attrs]

nselement :: T.Text -> T.Text -> [(T.Text, T.Text)] -> [Node] -> Element
nselement ns ln attrs children = Element (nsname ns ln) attrs' children where
	attrs' = [Attribute (name n) value | (n, value) <- attrs]

-- A somewhat primitive serialisation function
--
-- TODO: better namespace / prefix handling
serialiseElement :: Element -> T.Text
serialiseElement e = text where
	text = T.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"]
	eName = formatName $ elementName e
	formatName = escape . nameLocalName
	attrs = T.intercalate " " $ map attr $ elementAttributes e ++ nsattr
	attr (Attribute n v) = T.concat [formatName n, "=\"", escape v, "\""]
	nsattr = case nameNamespace $ elementName e of
		Nothing -> []
		Just ns -> [Attribute (name "xmlns") ns]
	contents = T.concat $ map serialiseNode $ elementNodes e
	
	serialiseNode (NodeElement e') = serialiseElement e'
	serialiseNode (NodeText t) = escape t
	serialiseNode (NodeComment _) = ""
	serialiseNode (NodeInstruction _) = ""

readEvents :: Monad m
           => (Integer -> SAX.Event -> Bool)
           -> m [SAX.Event]
           -> m [SAX.Event]
readEvents done nextEvents = readEvents' 0 [] where
	readEvents' depth acc = do
		events <- nextEvents
		let (done', depth', acc') = step events depth acc


@@ 46,7 108,7 @@ readEvents done getChars parser = readEvents' 0 [] where
			then return acc'
			else readEvents' depth' acc'
	
	step []     depth acc = (False, depth, acc)
	step [] depth acc = (False, depth, acc)
	step (e:es) depth acc = let
		depth' = depth + case e of
			(SAX.BeginElement _ _) -> 1


@@ 56,75 118,3 @@ readEvents done getChars parser = readEvents' 0 [] where
		in if done depth' e
			then (True, depth', reverse acc')
			else step es depth' acc'

-------------------------------------------------------------------------------
-- For converting incremental XML event lists to HXT trees
-------------------------------------------------------------------------------

-- This function assumes the input list is valid. No validation is performed.
eventsToTree :: [SAX.Event] -> DOM.XmlTree
eventsToTree = XN.mkRoot [] . eventsToTrees

eventsToTrees :: [SAX.Event] -> [DOM.XmlTree]
eventsToTrees = concatMap blockToTrees . 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 :: [SAX.Event] -> [[SAX.Event]]
splitBlocks es = ret where (_, _, ret) = foldl splitBlocks' (0, [], []) es

splitBlocks' :: (Int, [SAX.Event], [[SAX.Event]])
                -> SAX.Event
                -> (Int, [SAX.Event], [[SAX.Event]])
splitBlocks' (depth, accum, allAccum) e =
	if depth' == 0 then
		(depth', [], allAccum ++ [accum'])
	else
		(depth', accum', allAccum)
	where
		accum' = accum ++ [e]
		depth' = depth + case e of
			(SAX.BeginElement _ _) -> 1
			(SAX.EndElement _) -> (- 1)
			_ -> 0

blockToTrees :: [SAX.Event] -> [DOM.XmlTree]
blockToTrees [] = []
blockToTrees (begin:rest) = let end = (last rest) in case (begin, end) of
	(SAX.BeginElement qname' attrs, SAX.EndElement _) ->
		[XN.mkElement (convertQName qname')
			(map convertAttr attrs)
			(eventsToTrees (init rest))]
	(SAX.Characters s, _) -> [XN.mkText $ utf8 s]
	(_, SAX.ParseError text) -> error text
	_ -> []

convertAttr :: SAX.Attribute -> DOM.XmlTree
convertAttr (SAX.Attribute qname' value) = XN.NTree
	(XN.mkAttrNode (convertQName qname'))
	[XN.mkText $ utf8 value]

convertQName :: SAX.QName -> DOM.QName
convertQName (SAX.QName ns _ local) = qname (utf8 ns) (utf8 local)

-------------------------------------------------------------------------------
-- Utility functions for building XML trees
-------------------------------------------------------------------------------

element :: (String, String) -> [(String, String, String)] -> [DOM.XmlTree] -> DOM.XmlTree
element (ns, localpart) attrs children = let
	qname' = qname ns localpart
	attrs' = [attr ans alp text | (ans, alp, text) <- attrs]
	in XN.mkElement qname' attrs' children

attr :: String -> String -> String -> DOM.XmlTree
attr ns localpart text = XN.mkAttr (qname ns localpart) [XN.mkText text]

qname :: String -> String -> DOM.QName
qname ns localpart = case ns of
	"" -> DOM.mkName localpart
	_ -> DOM.mkNsName localpart ns

utf8 :: String -> String
utf8 = T.unpack . TE.decodeUtf8 . C8.pack

M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +3 -2
@@ 23,14 23,15 @@ library
      base >=3 && < 5
    , text >= 0.7 && < 0.8
    , gnuidn >= 0.1 && < 0.2
    , hxt >= 8.5 && < 8.6
    , gnutls >= 0.1 && < 0.3
    , bytestring >= 0.9 && < 0.10
    , libxml-sax >= 0.3 && < 0.4
    , 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
    , xml-types >= 0.1 && < 0.2
    , failable-list >= 0.2 && < 0.3

  exposed-modules:
    Network.Protocol.XMPP