~singpolyma/network-protocol-xmpp

480217e1779fd85125d61be2d74e81a61af4e17c — John Millikin 13 years ago 1445ab4
Moved utility functions into Util module.
3 files changed, 30 insertions(+), 17 deletions(-)

M Network/Protocol/XMPP/Client.hs
M Network/Protocol/XMPP/Stream.hs
R Network/Protocol/XMPP/{XMLBuilder.hs => Util.hs}
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +1 -12
@@ 37,6 37,7 @@ import Network.Protocol.XMPP.JID (JID)
import Network.Protocol.XMPP.SASL (Mechanism, bestMechanism)
import qualified Network.Protocol.XMPP.Stream as S
import Network.Protocol.XMPP.Stanzas (Stanza)
import Network.Protocol.XMPP.Util (mkElement)

data ConnectedClient = ConnectedClient JID S.Stream Handle



@@ 121,15 122,3 @@ putTree (AuthenticatedClient _ _ s _) = S.putTree s
getTree :: AuthenticatedClient -> IO XmlTree
getTree (AuthenticatedClient _ _ s _) = S.getTree s

-- Utility function for building XML trees
mkElement :: (String, String) -> [(String, String, String)] -> [XmlTree] -> 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 ns localpart text = XN.mkAttr (mkQname ns localpart) [XN.mkText text]

mkQname ns localpart = case ns of
	"" -> QN.mkName localpart
	otherwise -> QN.mkNsName ns localpart

M Network/Protocol/XMPP/Stream.hs => Network/Protocol/XMPP/Stream.hs +4 -4
@@ 46,7 46,7 @@ import qualified Text.XML.HXT.Arrow as A

import Network.Protocol.XMPP.JID (JID)
import Network.Protocol.XMPP.SASL (Mechanism, findMechanism)
import Network.Protocol.XMPP.XMLBuilder (eventsToTree)
import Network.Protocol.XMPP.Util (eventsToTree, mkQName, mkElement)

maxXMPPVersion = XMPPVersion 1 0



@@ 96,7 96,7 @@ beginStream jid handle = do
	featureTree <- getTree' handle parser
	return $ beginStream' handle parser startStreamEvent featureTree
	where
		streamName = QN.mkNsName "stream" "http://etherx.jabber.org/streams"
		streamName = mkQName "http://etherx.jabber.org/streams" "stream"
		startOfStream depth event = case (depth, event) of
			(1, (XML.BeginElement streamName _)) -> True
			otherwise -> False


@@ 106,7 106,7 @@ beginStream' handle parser streamStart featureTree = let
	language = XMLLanguage "en"
	version = XMPPVersion 1 0
	
	featuresName = QN.mkNsName "features" "http://etherx.jabber.org/streams"
	featuresName = mkQName "http://etherx.jabber.org/streams" "features"
	
	featureRoots = A.runLA (
		A.getChildren


@@ 133,7 133,7 @@ parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required

parseFeatureSASL :: XmlTree -> StreamFeature
parseFeatureSASL t = let
	mechName = QN.mkNsName "mechanism" "urn:ietf:params:xml:ns:xmpp-sasl"
	mechName = mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism"
	rawMechanisms = A.runLA (
		A.getChildren
		>>> A.hasQName mechName

R Network/Protocol/XMPP/XMLBuilder.hs => Network/Protocol/XMPP/Util.hs +25 -1
@@ 14,14 14,22 @@
   along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

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

import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Text.XML.HXT.DOM.QualifiedName as QN
import Text.XML.HXT.DOM.TypeDefs (XmlTree)
import qualified Network.Protocol.XMPP.IncrementalXML as XML

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

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


@@ 57,3 65,19 @@ blockToTree (begin:rest) = let end = (last rest) in case (begin, end) of

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

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

mkElement :: (String, String) -> [(String, String, String)] -> [XmlTree] -> 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 ns localpart text = XN.mkAttr (mkQName ns localpart) [XN.mkText text]

mkQName ns localpart = case ns of
	"" -> QN.mkName localpart
	otherwise -> QN.mkNsName ns localpart