~singpolyma/network-protocol-xmpp

fb16bfd50b4a383e0f3dbe8aa3d3f10501d14193 — John Millikin 13 years ago 6106147
Use multiple stanza data types, with a common class.
4 files changed, 138 insertions(+), 146 deletions(-)

A Network/Protocol/XMPP/Internal/Stanza.hs
A Network/Protocol/XMPP/Stanza.hs
D Network/Protocol/XMPP/Stanzas.hs
M network-protocol-xmpp.cabal
A Network/Protocol/XMPP/Internal/Stanza.hs => Network/Protocol/XMPP/Internal/Stanza.hs +108 -0
@@ 0,0 1,108 @@
-- 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.Internal.Stanza where
import Network.Protocol.XMPP.JID (JID)
import qualified Data.Text as T
import Text.XML.HXT.DOM.Interface (XmlTree)

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]
	stanzaTree     :: a -> XmlTree

data ReceivedStanza
	= ReceivedMessage Message
	| ReceivedPresence Presence
	| ReceivedIQ IQ

data Message = Message
	{ messageType     :: MessageType
	, messageTo       :: Maybe JID
	, messageFrom     :: Maybe JID
	, messageID       :: Maybe T.Text
	, messageLang     :: Maybe T.Text
	, messagePayloads :: [XmlTree]
	}

instance Stanza Message where
	stanzaTo = messageTo
	stanzaFrom = messageFrom
	stanzaID = messageID
	stanzaLang = messageLang
	stanzaPayloads = messagePayloads
	stanzaTree = undefined

data MessageType
	= MessageNormal
	| MessageCHat
	| MessageGroupChat
	| MessageHeadline
	| MessageError
	deriving (Show, Eq)

data Presence = Presence
	{ presenceType     :: PresenceType
	, presenceTo       :: Maybe JID
	, presenceFrom     :: Maybe JID
	, presenceID       :: Maybe T.Text
	, presenceLang     :: Maybe T.Text
	, presencePayloads :: [XmlTree]
	}

instance Stanza Presence where
	stanzaTo = presenceTo
	stanzaFrom = presenceFrom
	stanzaID = presenceID
	stanzaLang = presenceLang
	stanzaPayloads = presencePayloads
	stanzaTree = undefined

data PresenceType
	= PresenceUnavailable
	| PresenceSubscribe
	| PresenceSubscribed
	| PresenceUnsubscribe
	| PresenceUnsubscribed
	| PresenceProbe
	| PresenceError
	deriving (Show, Eq)

data IQ = IQ
	{ iqType    :: IQType
	, iqTo      :: Maybe JID
	, iqFrom    :: Maybe JID
	, iqID      :: Maybe T.Text
	, iqLang    :: Maybe T.Text
	, iqPayload :: XmlTree
	}

instance Stanza IQ where
	stanzaTo = iqTo
	stanzaFrom = iqFrom
	stanzaID = iqID
	stanzaLang = iqLang
	stanzaPayloads iq = [iqPayload iq]
	stanzaTree = undefined

data IQType
	= IQGet
	| IQSet
	| IQResult
	| IQError
	deriving (Show, Eq)

A Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +26 -0
@@ 0,0 1,26 @@
-- 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.Stanza
	( Stanza (stanzaTo, stanzaFrom, stanzaID, stanzaLang, stanzaPayloads)
	, ReceivedStanza (..)
	, Message (..)
	, Presence (..)
	, IQ (..)
	, MessageType (..)
	, PresenceType (..)
	, IQType (..)
	) where
import Network.Protocol.XMPP.Internal.Stanza

D Network/Protocol/XMPP/Stanzas.hs => Network/Protocol/XMPP/Stanzas.hs +0 -145
@@ 1,145 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.Stanzas (
	 StanzaType(..)
	,Stanza(..)
	,treeToStanza
	,stanzaToTree
	) where

import Text.XML.HXT.DOM.Interface (XmlTree)
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

data StanzaType =
	  MessageNormal
	| MessageChat
	| MessageGroupChat
	| MessageHeadline
	| MessageError
	
	| PresenceUnavailable
	| PresenceSubscribe
	| PresenceSubscribed
	| PresenceUnsubscribe
	| PresenceUnsubscribed
	| PresenceProbe
	| PresenceError
	
	| IQGet
	| IQSet
	| IQResult
	| IQError
	deriving (Show, Eq)

data Stanza = Stanza
	{
		 stanzaType     :: StanzaType
		,stanzaTo       :: Maybe JID
		,stanzaFrom     :: Maybe JID
		,stanzaID       :: String
		,stanzaLang     :: String
		,stanzaPayloads :: [XmlTree]
	}
	deriving (Show, Eq)

stanzaTypeMap :: [((String, String, String), StanzaType)]
stanzaTypeMap = mkStanzaTypeMap $ [
	 ("jabber:client", "message", [
		 ("normal",    MessageNormal)
		,("chat",      MessageChat)
		,("groupchat", MessageGroupChat)
		,("headline",  MessageHeadline)
		,("error",     MessageError)
		])
	,("jabber:client", "presence", [
		 ("unavailable",  PresenceUnavailable)
		,("subscribe",    PresenceSubscribe)
		,("subscribed",   PresenceSubscribed)
		,("unsubscribe",  PresenceUnsubscribe)
		,("unsubscribed", PresenceUnsubscribed)
		,("probe",        PresenceProbe)
		,("error",        PresenceError)
		])
	,("jabber:client", "iq", [
		 ("get", IQGet)
		,("set", IQSet)
		,("result", IQResult)
		,("error", IQError)
		])
	]
	where mkStanzaTypeMap raw = do
		(ns, elementName, typeStrings) <- raw
		(typeString, type') <- typeStrings
		return ((ns, elementName, typeString), type')

stanzaTypeToStr :: StanzaType -> (String, String, String)
stanzaTypeToStr t = let
	step []              = undefined
	step ((ret, t'):tms)
		| t == t'    = ret
		| otherwise  = step tms
	in step stanzaTypeMap

stanzaTypeFromStr :: String -> String -> String -> Maybe StanzaType
stanzaTypeFromStr ns elementName typeString = let
	key = (ns, elementName, typeString)
	step [] = Nothing
	step ((key', ret):tms)
		| key == key' = Just ret
		| otherwise = step tms
	in step stanzaTypeMap

treeToStanza :: XmlTree -> [Stanza]
treeToStanza t = do
	to <- return . jidParse =<< A.runLA (A.getAttrValue "to") t
	from <- return . jidParse =<< A.runLA (A.getAttrValue "from") t
	id' <- A.runLA (A.getAttrValue "id") t
	lang <- A.runLA (A.getAttrValue "lang") t
	
	ns <- A.runLA A.getNamespaceUri t
	elementName <- A.runLA A.getLocalPart t
	typeString <- A.runLA (A.getAttrValue "type") t
	
	let payloads = A.runLA (A.getChildren >>> A.isElem) t
	
	case stanzaTypeFromStr ns elementName typeString of
		Nothing    -> []
		Just type' -> [Stanza type' to from id' lang payloads]

stanzaToTree :: Stanza -> XmlTree
stanzaToTree s = let
	(ns, elementName, typeString) = stanzaTypeToStr (stanzaType s)
	
	attrs' = [
		 autoAttr "to" (maybe "" jidFormat . stanzaTo)
		,autoAttr "from" (maybe "" jidFormat . stanzaFrom)
		,autoAttr "id" stanzaID
		,autoAttr "xml:lang" stanzaLang
		,\_ -> [("", "type", typeString)]
		]
	attrs = concatMap ($ s) attrs'
	in mkElement (ns, elementName) attrs (stanzaPayloads s)

autoAttr :: String -> (Stanza -> String) -> Stanza -> [(String, String, String)]
autoAttr attr f stanza = case f stanza of
	"" -> []
	text -> [("", attr, text)]

M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +4 -1
@@ 28,6 28,9 @@ library
    -- Network.Protocol.XMPP.Client
    Network.Protocol.XMPP.JID
    -- Network.Protocol.XMPP.SASL
    -- Network.Protocol.XMPP.Stanzas
    Network.Protocol.XMPP.Stanza
    -- Network.Protocol.XMPP.Stream
    -- Network.Protocol.XMPP.Util

  other-modules:
    Network.Protocol.XMPP.Internal.Stanza