~singpolyma/network-protocol-xmpp

78b7d475c6e27eedad02d3412e39e076199dde1d — John Millikin 14 years ago 3b50a3b 
Clean up a few internal modules, provide a smaller external interface to streams.
patch browse .tar.gz 
7 files changed, 114 insertions(+), 446 deletions(-)

M Network/Protocol/XMPP.hs
R Network/Protocol/XMPP/{SASL.hs => Internal/Authentication.hs}
M Network/Protocol/XMPP/Internal/Stanza.hs
M Network/Protocol/XMPP/Stanza.hs
M Network/Protocol/XMPP/Stream.hs
D Network/Protocol/XMPP/Util.hs
M network-protocol-xmpp.cabal

M Network/Protocol/XMPP.hs => Network/Protocol/XMPP.hs +21 -23
@@ 1,27 1,25 @@
{- Copyright (C) 2009 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
   the Free Software Foundation, either version 3 of the License, or
   any later version.
   
   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
   
   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}
-- 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
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Network.Protocol.XMPP (
	 module Network.Protocol.XMPP.JID
	,module Network.Protocol.XMPP.Client
	,module Network.Protocol.XMPP.Component
	,module Network.Protocol.XMPP.Stanzas

module Network.Protocol.XMPP
	( module Network.Protocol.XMPP.JID
	, module Network.Protocol.XMPP.Stanza
	, module Network.Protocol.XMPP.Stream
	) where

import Network.Protocol.XMPP.JID
import Network.Protocol.XMPP.Client
import Network.Protocol.XMPP.Component
import Network.Protocol.XMPP.Stanzas
import Network.Protocol.XMPP.Stanza
import Network.Protocol.XMPP.Stream


R Network/Protocol/XMPP/SASL.hs => Network/Protocol/XMPP/Internal/Authentication.hs +40 -44
@@ 1,60 1,61 @@
{- Copyright (C) 2009 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
   the Free Software Foundation, either version 3 of the License, or
   any later version.
   
   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
   
   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}
-- Copyright (C) 2009-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
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Network.Protocol.XMPP.SASL (
	 Result(..)
	,authenticate
module Network.Protocol.XMPP.Internal.Authentication
	( Result(..)
	, authenticate
	) where
import qualified Data.Text as T

import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Network.Protocol.SASL.GSASL as G

import Network.Protocol.XMPP.JID (JID, jidFormat)
import Network.Protocol.XMPP.Util (mkElement, mkQName)
import qualified Network.Protocol.XMPP.Stream as S

type Username = String
type Password = String
type Mechanism = String
import Network.Protocol.XMPP.JID (JID, formatJID)
import Network.Protocol.XMPP.Internal.XML (mkElement, mkQName)
import qualified Network.Protocol.XMPP.Internal.Stream as S

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

authenticate :: S.Stream -> JID -> JID -> Username -> Password -> IO Result
authenticate stream userJID serverJID username password = do
	let mechanisms = (advertisedMechanisms . S.streamFeatures) stream
	let authz = jidFormat userJID
	let hostname = jidFormat serverJID
authenticate :: S.Stream stream => stream
             -> [T.Text] -- ^ Mechanisms
             -> JID -- ^ User JID
             -> JID -- ^ Server JID
             -> T.Text -- ^ Username
             -> T.Text -- ^ Password
             -> IO Result
authenticate stream mechanisms userJID serverJID username password = do
	let authz = formatJID userJID
	let hostname = formatJID serverJID
	
	G.withContext $ \ctxt -> do
	
	suggested <- G.clientSuggestMechanism ctxt mechanisms
	suggested <- G.clientSuggestMechanism ctxt (map T.unpack mechanisms)
	mechanism <- case suggested of
		Just m -> return m
		Nothing -> error "No supported SASL mechanisms advertised"
	
	G.withSession (G.clientStart ctxt mechanism) $ \s -> do
	
	G.propertySet s G.GSASL_AUTHZID authz
	G.propertySet s G.GSASL_AUTHID username
	G.propertySet s G.GSASL_PASSWORD password
	G.propertySet s G.GSASL_AUTHZID $ T.unpack authz
	G.propertySet s G.GSASL_AUTHID $ T.unpack username
	G.propertySet s G.GSASL_PASSWORD $ T.unpack password
	G.propertySet s G.GSASL_SERVICE "xmpp"
	G.propertySet s G.GSASL_HOSTNAME hostname
	G.propertySet s G.GSASL_HOSTNAME $ T.unpack hostname
	
	(b64text, rc) <- G.step64 s ""
	S.putTree stream $ mkElement ("", "auth")


@@ 65,8 66,9 @@ authenticate stream userJID serverJID username password = do
	case rc of
		G.GSASL_OK -> saslFinish stream
		G.GSASL_NEEDS_MORE -> saslLoop stream s
		_ -> error "Unknown GNU SASL response"

saslLoop :: S.Stream -> G.Session -> IO Result
saslLoop :: S.Stream s => s -> G.Session -> IO Result
saslLoop stream session = do
	challengeText <- A.runX (
		A.arrIO (\_ -> S.getTree stream)


@@ 83,8 85,9 @@ saslLoop stream session = do
			case rc of
				G.GSASL_OK -> saslFinish stream
				G.GSASL_NEEDS_MORE -> saslLoop stream session
				_ -> error "Unknown GNU SASL response"

saslFinish :: S.Stream -> IO Result
saslFinish :: S.Stream s => s -> IO Result
saslFinish stream = do
	successElem <- A.runX (
		A.arrIO (\_ -> S.getTree stream)


@@ 92,10 95,3 @@ saslFinish stream = do
		>>> A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "success"))
	
	return $ if null successElem then Failure else Success

advertisedMechanisms :: [S.StreamFeature] -> [Mechanism]
advertisedMechanisms [] = []
advertisedMechanisms (f:fs) = case f of
	(S.FeatureSASL ms) -> ms
	_ -> advertisedMechanisms fs



M Network/Protocol/XMPP/Internal/Stanza.hs => Network/Protocol/XMPP/Internal/Stanza.hs +7 -4
@@ 24,7 24,7 @@ class Stanza a where
	stanzaID       :: a -> Maybe T.Text
	stanzaLang     :: a -> Maybe T.Text
	stanzaPayloads :: a -> [XmlTree]
	stanzaTree     :: a -> XmlTree
	stanzaToTree   :: a -> XmlTree

data ReceivedStanza
	= ReceivedMessage Message


@@ 46,7 46,7 @@ instance Stanza Message where
	stanzaID = messageID
	stanzaLang = messageLang
	stanzaPayloads = messagePayloads
	stanzaTree = undefined
	stanzaToTree = undefined

data MessageType
	= MessageNormal


@@ 71,7 71,7 @@ instance Stanza Presence where
	stanzaID = presenceID
	stanzaLang = presenceLang
	stanzaPayloads = presencePayloads
	stanzaTree = undefined
	stanzaToTree = undefined

data PresenceType
	= PresenceUnavailable


@@ 98,7 98,7 @@ instance Stanza IQ where
	stanzaID = iqID
	stanzaLang = iqLang
	stanzaPayloads iq = [iqPayload iq]
	stanzaTree = undefined
	stanzaToTree = undefined

data IQType
	= IQGet


@@ 106,3 106,6 @@ data IQType
	| IQResult
	| IQError
	deriving (Show, Eq)

treeToStanza :: XmlTree -> Maybe ReceivedStanza
treeToStanza = undefined


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

module Network.Protocol.XMPP.Stanza
	( Stanza (stanzaTo, stanzaFrom, stanzaID, stanzaLang, stanzaPayloads)
	( Stanza
	  ( stanzaTo
	  , stanzaFrom
	  , stanzaID
	  , stanzaLang
	  , stanzaPayloads
	  )
	
	, ReceivedStanza (..)
	, Message (..)
	, Presence (..)


M Network/Protocol/XMPP/Stream.hs => Network/Protocol/XMPP/Stream.hs +25 -273
@@ 1,276 1,28 @@
{- Copyright (C) 2009 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
   the Free Software Foundation, either version 3 of the License, or
   any later version.
   
   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
   
   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

module Network.Protocol.XMPP.Stream (
	 Stream (
	 	 streamLanguage
	 	,streamVersion
		,streamID
	 	,streamFeatures
	 	)
	,XMPPStreamID(XMPPStreamID)
	,StreamFeature (
		 FeatureStartTLS
		,FeatureSASL
		,FeatureRegister
		,FeatureBind
		,FeatureSession
		)
	,beginStream
	,restartStream
	,getTree
	,putTree
-- 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
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Network.Protocol.XMPP.Stream
	( Stream
	, putStanza
	, getStanza
	) where
import Network.Protocol.XMPP.Internal.Stream
import Network.Protocol.XMPP.Internal.Stanza

import qualified System.IO as IO
import Data.AssocList (lookupDef)
import Data.Char (toUpper)
import Control.Applicative

-- 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 Text.XML.LibXML.SAX as SAX

-- TLS support
import qualified Network.GnuTLS as GnuTLS
import Foreign (allocaBytes)
import Foreign.C (peekCAStringLen)

import Network.Protocol.XMPP.JID (JID, jidFormat)
import qualified Network.Protocol.XMPP.Util as Util

maxXMPPVersion :: XMPPVersion
maxXMPPVersion = XMPPVersion 1 0

data Stream = Stream
	{
		 streamHandle   :: Handle
		,streamJID      :: JID
		,streamNS       :: String
		,streamParser   :: SAX.Parser
		,streamLanguage :: XMLLanguage
		,streamVersion  :: XMPPVersion
		,streamID       :: XMPPStreamID
		,streamFeatures :: [StreamFeature]
	}

data StreamFeature =
	  FeatureStartTLS Bool
	| FeatureSASL [String]
	| FeatureRegister
	| FeatureBind
	| FeatureSession
	| FeatureUnknown DOM.XmlTree
	deriving (Show, Eq)

newtype XMLLanguage = XMLLanguage String
	deriving (Show, Eq)

data XMPPVersion = XMPPVersion Int Int
	deriving (Show, Eq)

newtype XMPPStreamID = XMPPStreamID String

data Handle =
	  PlainHandle IO.Handle
	| SecureHandle IO.Handle (GnuTLS.Session GnuTLS.Client)

------------------------------------------------------------------------------

restartStream :: Stream -> IO Stream
restartStream s = beginStream' (streamJID s) (streamNS s) (streamHandle s)

beginStream :: JID -> String -> IO.Handle -> IO Stream
beginStream jid ns rawHandle = do
	IO.hSetBuffering rawHandle IO.NoBuffering
	
	plainStream <- beginStream' jid ns (PlainHandle rawHandle)

	let startTLS = do
	      putTree plainStream $ Util.mkElement ("", "starttls")
				    [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-tls")]
				    []
	      getTree plainStream
	
	      session <- GnuTLS.tlsClient [
				GnuTLS.handle GnuTLS.:= rawHandle
			       ,GnuTLS.priorities GnuTLS.:= [GnuTLS.CrtX509]
			       ,GnuTLS.credentials GnuTLS.:= GnuTLS.certificateCredentials
			       ]
	      GnuTLS.handshake session
	      beginStream' jid ns (SecureHandle rawHandle session)

	case streamCanTLS plainStream of
	  True -> startTLS
	  False -> return plainStream

beginStream' :: JID -> String -> Handle -> IO Stream
beginStream' jid ns h = do
	-- Since only the opening tag should be written, normal XML
	-- serialization cannot be used. Be careful to escape any embedded
	-- attributes.
	let xmlHeader =
		"<?xml version='1.0'?>\n" ++
		"<stream:stream xmlns='" ++ DOM.attrEscapeXml ns ++ "'" ++
		" to='" ++ (DOM.attrEscapeXml . jidFormat) jid ++ "'" ++
		" version='1.0'" ++
		" xmlns:stream='http://etherx.jabber.org/streams'>"
	
	parser <- SAX.mkParser
	hPutStr h xmlHeader
	initialEvents <- readEventsUntil startOfStream h parser
	
	let startStreamEvent = last initialEvents
	let (language, version, streamID) = parseStartStream startStreamEvent
	features <- (case ns of
		       "jabber:client" ->
			   parseFeatures <$> getTree' h parser
		       _ ->
			   return []
		    )
	
	return $ Stream h jid ns parser language version streamID features
	
	where
		streamName = Util.mkQName "http://etherx.jabber.org/streams" "stream"
		
		startOfStream depth event = case (depth, event) of
			(1, (SAX.BeginElement elemName _)) ->
				streamName == Util.convertQName elemName
			_ -> False

parseStartStream :: SAX.Event -> (XMLLanguage, XMPPVersion, XMPPStreamID)
parseStartStream e = (XMLLanguage lang, XMPPVersion 1 0, XMPPStreamID id)
    where SAX.BeginElement _ attrs = e
	  attr name = maybe "" SAX.attributeValue $
		      m1 $ filter ((name ==) . SAX.qnameLocalName . SAX.attributeName) attrs
	      where m1 (x:_) = Just x
		    m1 _ = Nothing
	  lang = attr "lang"
	  id = attr "id"

parseFeatures :: DOM.XmlTree -> [StreamFeature]
parseFeatures t =
	A.runLA (A.getChildren
		>>> A.hasQName featuresName
		>>> A.getChildren
		>>> A.arrL (\t' -> [parseFeature t'])) t
	where
		featuresName = Util.mkQName "http://etherx.jabber.org/streams" "features"

parseFeature :: DOM.XmlTree -> StreamFeature
parseFeature t = lookupDef FeatureUnknown qname [
	 (("urn:ietf:params:xml:ns:xmpp-tls", "starttls"), parseFeatureTLS)
	,(("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms"), parseFeatureSASL)
	,(("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))
	] t
	where
		qname = maybe ("", "") (\n -> (DOM.namespaceUri n, DOM.localPart n)) (XN.getName t)

parseFeatureTLS :: DOM.XmlTree -> StreamFeature
parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required

parseFeatureSASL :: DOM.XmlTree -> StreamFeature
parseFeatureSASL t = let
	mechName = Util.mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism"
	mechanisms = A.runLA (
		A.getChildren
		>>> A.hasQName mechName
		>>> A.getChildren
		>>> A.getText) t
	
	in FeatureSASL $ map (map toUpper) mechanisms

streamCanTLS :: Stream -> Bool
streamCanTLS = (> 0) . length .
	       filter (\feature ->
			   case feature of
			     FeatureStartTLS _ -> True
			     _ -> False
		      ) . streamFeatures

-------------------------------------------------------------------------------

getTree :: Stream -> IO DOM.XmlTree
getTree s = getTree' (streamHandle s) (streamParser s)

getTree' :: Handle -> SAX.Parser -> IO DOM.XmlTree
getTree' h p = do
	events <- readEventsUntil finished h p
	return $ Util.eventsToTree events
	where
		finished 0 (SAX.EndElement _) = True
		finished _ _ = False

putTree :: Stream -> DOM.XmlTree -> IO ()
putTree s t = do
	let root = XN.mkRoot [] [t]
	let h = streamHandle s
	[text] <- A.runX (A.constA root >>> A.writeDocumentToString [
		(A.a_no_xml_pi, "1")
		])
	hPutStr h text

-------------------------------------------------------------------------------

readEventsUntil :: (Int -> SAX.Event -> Bool) -> Handle -> SAX.Parser -> IO [SAX.Event]
readEventsUntil done h parser = readEventsUntil' done 0 [] $ do
	char <- hGetChar h
	SAX.parse parser [char] False

readEventsUntil' :: (Int -> SAX.Event -> Bool) -> Int -> [SAX.Event] -> IO [SAX.Event] -> IO [SAX.Event]
readEventsUntil' done depth accum getEvents = do
	events <- getEvents
	let (done', depth', accum') = readEventsStep done events depth accum
	if done'
		then return accum'
		else readEventsUntil' done depth' accum' getEvents

readEventsStep :: (Int -> SAX.Event -> Bool) -> [SAX.Event] -> Int -> [SAX.Event] -> (Bool, Int, [SAX.Event])
readEventsStep _ [] depth accum = (False, depth, accum)
readEventsStep done (e:es) depth accum = let
	depth' = depth + case e of
		(SAX.BeginElement _ _) -> 1
		(SAX.EndElement _) -> (- 1)
		_ -> 0
	accum' = accum ++ [e]
	in if done depth' e then (True, depth', accum')
	else readEventsStep done es depth' accum'

-------------------------------------------------------------------------------

hPutStr :: Handle -> String -> IO ()
hPutStr (PlainHandle h) = IO.hPutStr h
hPutStr (SecureHandle _ session) = GnuTLS.tlsSendString session
putStanza :: (Stream stream, Stanza stanza) => stream -> stanza -> IO ()
putStanza stream = putTree stream . stanzaToTree

hGetChar :: Handle -> IO Char
hGetChar (PlainHandle h) = IO.hGetChar h
hGetChar (SecureHandle h session) = allocaBytes 1 $ \ptr -> do
	pending <- GnuTLS.tlsCheckPending session
	if pending == 0
		then do
			IO.hWaitForInput h (-1)
			return ()
		else return ()
	
	len <- GnuTLS.tlsRecv session ptr 1
	[char] <- peekCAStringLen (ptr, len)
	return char
getStanza :: Stream stream => stream -> IO (Maybe ReceivedStanza)
getStanza stream = treeToStanza `fmap` getTree stream


D Network/Protocol/XMPP/Util.hs => Network/Protocol/XMPP/Util.hs +0 -97
@@ 1,97 0,0 @@
{- Copyright (C) 2009 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
   the Free Software Foundation, either version 3 of the License, or
   any later version.
   
   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
   
   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

module Network.Protocol.XMPP.Util (
	 eventsToTree
	,convertAttr
	,convertQName
	,mkElement
	,mkAttr
	,mkQName
	) where

import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.LibXML.SAX as SAX

-------------------------------------------------------------------------------
-- 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 es = XN.mkRoot [] (eventsToTrees es)

eventsToTrees :: [SAX.Event] -> [DOM.XmlTree]
eventsToTrees es = concatMap blockToTrees (splitBlocks es)

-- 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 s]
	(_, SAX.ParseError text) -> error text
	_ -> []

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

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

-------------------------------------------------------------------------------
-- Utility function for building XML trees
-------------------------------------------------------------------------------

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

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

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


M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +13 -4
@@ 17,20 17,29 @@ source-repository head
  location: http://ianen.org/haskell/xmpp/

library
  ghc-options: -Wall -fno-warn-unused-do-bind

  build-depends:
      base >=3 && < 5
    , text
    , stringprep
    , ranges
    , hxt
    , hsgnutls
    , bytestring
    , libxml-sax
    , gsasl

  exposed-modules:
    -- Network.Protocol.XMPP
    Network.Protocol.XMPP
    -- Network.Protocol.XMPP.Client
    Network.Protocol.XMPP.JID
    -- Network.Protocol.XMPP.SASL
    Network.Protocol.XMPP.Stanza
    -- Network.Protocol.XMPP.Stream
    -- Network.Protocol.XMPP.Util
    Network.Protocol.XMPP.Stream

  other-modules:
    Network.Protocol.XMPP.Internal.Authentication
    Network.Protocol.XMPP.Internal.Handle
    Network.Protocol.XMPP.Internal.Stanza
    Network.Protocol.XMPP.Internal.Stream
    Network.Protocol.XMPP.Internal.XML