From fb16bfd50b4a383e0f3dbe8aa3d3f10501d14193 Mon Sep 17 00:00:00 2001 From: John Millikin Date: Sat, 27 Mar 2010 04:44:08 +0000 Subject: [PATCH] Use multiple stanza data types, with a common class. --- Network/Protocol/XMPP/Internal/Stanza.hs | 108 +++++++++++++++++ Network/Protocol/XMPP/Stanza.hs | 26 ++++ Network/Protocol/XMPP/Stanzas.hs | 145 ----------------------- network-protocol-xmpp.cabal | 5 +- 4 files changed, 138 insertions(+), 146 deletions(-) create mode 100644 Network/Protocol/XMPP/Internal/Stanza.hs create mode 100644 Network/Protocol/XMPP/Stanza.hs delete mode 100644 Network/Protocol/XMPP/Stanzas.hs diff --git a/Network/Protocol/XMPP/Internal/Stanza.hs b/Network/Protocol/XMPP/Internal/Stanza.hs new file mode 100644 index 0000000..7452dff --- /dev/null +++ b/Network/Protocol/XMPP/Internal/Stanza.hs @@ -0,0 +1,108 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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 . + +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) diff --git a/Network/Protocol/XMPP/Stanza.hs b/Network/Protocol/XMPP/Stanza.hs new file mode 100644 index 0000000..03c558e --- /dev/null +++ b/Network/Protocol/XMPP/Stanza.hs @@ -0,0 +1,26 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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 . + +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 diff --git a/Network/Protocol/XMPP/Stanzas.hs b/Network/Protocol/XMPP/Stanzas.hs deleted file mode 100644 index 2bad350..0000000 --- a/Network/Protocol/XMPP/Stanzas.hs +++ /dev/null @@ -1,145 +0,0 @@ -{- Copyright (C) 2009 John Millikin - - 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 . --} - -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)] diff --git a/network-protocol-xmpp.cabal b/network-protocol-xmpp.cabal index db49f81..818f30c 100644 --- a/network-protocol-xmpp.cabal +++ b/network-protocol-xmpp.cabal @@ -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 -- 2.38.4