From 93a795122e5128201753d443243d2e6571c31a01 Mon Sep 17 00:00:00 2001
From: John Millikin <jmillikin@gmail.com>
Date: Sun, 28 Jun 2009 05:18:45 +0000
Subject: [PATCH] Added stanza functions for converting XML trees into generic
 stanzas, messages, and presence notifications.

---
 Network/Protocol/XMPP/Stanzas.hs | 61 ++++++++++++++++++++++++++++++--
 1 file changed, 59 insertions(+), 2 deletions(-)

diff --git a/Network/Protocol/XMPP/Stanzas.hs b/Network/Protocol/XMPP/Stanzas.hs
index 8e94cd4..abe3783 100644
--- a/Network/Protocol/XMPP/Stanzas.hs
+++ b/Network/Protocol/XMPP/Stanzas.hs
@@ -19,11 +19,17 @@ module Network.Protocol.XMPP.Stanzas (
 	,GenericStanza(..)
 	,Message(..)
 	,Presence(..)
+	,toStanza
+	,toMessage
+	,toPresence
 	) where
 
 import Text.XML.HXT.DOM.Interface (XmlTree)
-import Network.Protocol.XMPP.JID (JID, jidFormat)
-import Network.Protocol.XMPP.Util (mkElement)
+import Text.XML.HXT.Arrow ((>>>), (&&&))
+import qualified Text.XML.HXT.Arrow as A
+
+import Network.Protocol.XMPP.JID (JID, jidFormat, jidParse)
+import Network.Protocol.XMPP.Util (mkElement, mkQName)
 import qualified Text.XML.HXT.DOM.XmlNode as XN
 
 class Stanza a where
@@ -128,6 +134,57 @@ instance Stanza Presence where
 
 -------------------------------------------------------------------------------
 
+toStanza :: XmlTree -> [GenericStanza]
+toStanza t = let
+	getFrom = A.getAttrValue "from" >>> A.arrL (\x -> [jidParse x])
+	getTo = A.getAttrValue "to" >>> A.arrL (\x -> [jidParse x])
+	getID = A.getAttrValue "id"
+	getType = A.getAttrValue "type"
+	getLang = A.getAttrValue "lang"
+	attrArrow = (getTo &&& getFrom &&& getID &&& getType &&& getLang)
+	in do
+		(to, (from, (id', (type', lang)))) <- A.runLA attrArrow t
+		return $ GenericStanza to from id' type' lang t
+
+toMessage :: (Stanza a) => a -> [Message]
+toMessage s = let
+	getBody = (
+		A.arr stanzaXML
+		>>> A.hasQName (mkQName "jabber:client" "message")
+		>>> A.getChildren
+		>>> A.hasQName (mkQName "jabber:client" "body")
+		>>> A.getChildren
+		>>> A.getText
+		)
+	bodyText = concat (A.runLA getBody s)
+	in case (bodyText, stanzaTo s) of
+		("", _) -> []
+		(_, Nothing) -> []
+		(_, Just to) -> [Message to (stanzaFrom s)
+		                         (stanzaID s) (stanzaType s)
+		                         (stanzaLang s) bodyText]
+
+toPresence :: (Stanza a) => a -> [Presence]
+toPresence s = let
+	getChildText qname = (A.getChildren >>> A.hasQName qname >>>
+	                      A.getChildren >>> A.getText)
+	getShow = getChildText $ mkQName "jabber:client" "show"
+	getStatus = getChildText $ mkQName "jabber:client" "status"
+	getShowStatus = (
+		A.arr stanzaXML
+		>>> A.hasQName (mkQName "jabber:client" "presence")
+		>>> A.withDefault getShow []
+		&&& A.withDefault getStatus []
+		)
+	in case A.runLA getShowStatus s of
+		[(show', status)] -> [Presence (stanzaTo s) (stanzaFrom s)
+		                               (stanzaID s) (stanzaType s)
+		                               (stanzaLang s) show' status]
+		_ -> []
+
+
+-------------------------------------------------------------------------------
+
 unmap :: a -> [(a -> b)] -> [b]
 unmap _ [] = []
 unmap x (f:fs) = (f x):(unmap x fs)
-- 
2.45.2