From 23322af9786a077ae48945b3c9112871dc2ffef6 Mon Sep 17 00:00:00 2001 From: John Millikin Date: Sun, 21 Jun 2009 06:08:01 +0000 Subject: [PATCH] Add basic support for the ``message`` and ``presence`` stanza types, which simplify the construction of XML trees. --- Network/Protocol/XMPP.hs | 2 + Network/Protocol/XMPP/Client.hs | 4 + Network/Protocol/XMPP/Stanzas.hs | 141 +++++++++++++++++++++++++++++++ 3 files changed, 147 insertions(+) create mode 100644 Network/Protocol/XMPP/Stanzas.hs diff --git a/Network/Protocol/XMPP.hs b/Network/Protocol/XMPP.hs index a719937..182aa64 100644 --- a/Network/Protocol/XMPP.hs +++ b/Network/Protocol/XMPP.hs @@ -17,7 +17,9 @@ module Network.Protocol.XMPP ( module Network.Protocol.XMPP.JID ,module Network.Protocol.XMPP.Client + ,module Network.Protocol.XMPP.Stanzas ) where import Network.Protocol.XMPP.JID import Network.Protocol.XMPP.Client +import Network.Protocol.XMPP.Stanzas diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs index 72f2d58..96640d8 100644 --- a/Network/Protocol/XMPP/Client.hs +++ b/Network/Protocol/XMPP/Client.hs @@ -24,6 +24,7 @@ module Network.Protocol.XMPP.Client ( ,clientServerJID ,putTree ,getTree + ,putStanza ) where import Codec.Binary.Base64.String (encode) @@ -37,6 +38,7 @@ import Network.Protocol.XMPP.JID (JID, jidParse, jidFormat) import Network.Protocol.XMPP.SASL (Mechanism, bestMechanism) import qualified Network.Protocol.XMPP.Stream as S import Network.Protocol.XMPP.Util (mkElement, mkQName) +import Network.Protocol.XMPP.Stanzas (Stanza, stanzaXML) data ConnectedClient = ConnectedClient JID S.Stream @@ -126,3 +128,5 @@ putTree = S.putTree . clientStream getTree :: Client -> IO XmlTree getTree = S.getTree . clientStream +putStanza :: (Stanza a) => Client -> a -> IO () +putStanza c = (putTree c) . stanzaXML diff --git a/Network/Protocol/XMPP/Stanzas.hs b/Network/Protocol/XMPP/Stanzas.hs new file mode 100644 index 0000000..8e94cd4 --- /dev/null +++ b/Network/Protocol/XMPP/Stanzas.hs @@ -0,0 +1,141 @@ +{- 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 ( + Stanza(..) + ,GenericStanza(..) + ,Message(..) + ,Presence(..) + ) where + +import Text.XML.HXT.DOM.Interface (XmlTree) +import Network.Protocol.XMPP.JID (JID, jidFormat) +import Network.Protocol.XMPP.Util (mkElement) +import qualified Text.XML.HXT.DOM.XmlNode as XN + +class Stanza a where + stanzaTo :: a -> Maybe JID + stanzaFrom :: a -> Maybe JID + stanzaID :: a -> String + stanzaType :: a -> String + stanzaLang :: a -> String + stanzaXML :: a -> XmlTree + +data GenericStanza = GenericStanza + { + genericStanzaTo :: Maybe JID + ,genericStanzaFrom :: Maybe JID + ,genericStanzaID :: String + ,genericStanzaType :: String + ,genericStanzaLang :: String + ,genericStanzaXML :: XmlTree + } + +instance Stanza GenericStanza where + stanzaTo = genericStanzaTo + stanzaFrom = genericStanzaFrom + stanzaID = genericStanzaID + stanzaType = genericStanzaType + stanzaLang = genericStanzaLang + stanzaXML = genericStanzaXML + +data Message = Message + { + messageTo :: JID + ,messageFrom :: Maybe JID + ,messageID :: String + ,messageType :: String + ,messageLang :: String + ,messageBody :: String + } + deriving (Show, Eq) + +data Presence = Presence + { + presenceTo :: Maybe JID + ,presenceFrom :: Maybe JID + ,presenceID :: String + ,presenceType :: String + ,presenceLang :: String + ,presenceShow :: String + ,presenceStatus :: String + } + deriving (Show, Eq) + +instance Stanza Message where + stanzaTo = Just . messageTo + stanzaFrom = messageFrom + stanzaID = messageID + stanzaType = messageType + stanzaLang = messageLang + stanzaXML m = let + attrs' = [ + maybeAttr "to" $ (Just . jidFormat =<<) . stanzaTo + ,maybeAttr "from" $ (Just . jidFormat =<<) . stanzaFrom + ,mkAttr "id" $ stanzaID + ,mkAttr "type" $ stanzaType + -- ,mkAttr "lang" $ stanzaLang -- TODO: namespace support? + ] + attrs = concat $ unmap m attrs' + + in mkElement ("jabber:client", "message") + attrs + [mkElement ("jabber:client", "body") [] + [XN.mkText $ messageBody m]] + +instance Stanza Presence where + stanzaTo = presenceTo + stanzaFrom = presenceFrom + stanzaID = presenceID + stanzaType = presenceType + stanzaLang = presenceLang + stanzaXML p = let + attrs' = [ + maybeAttr "to" $ (Just . jidFormat =<<) . stanzaTo + ,maybeAttr "from" $ (Just . jidFormat =<<) . stanzaFrom + ,mkAttr "id" $ stanzaID + ,mkAttr "type" $ stanzaType + -- ,mkAttr "lang" $ stanzaLang -- TODO: namespace support? + ] + attrs = concat $ unmap p attrs' + + showElem = case presenceShow p of + "" -> [] + text -> [mkElement ("jabber:client", "show") [] + [XN.mkText text]] + + statusElem = case presenceStatus p of + "" -> [] + text -> [mkElement ("jabber:client", "status") [] + [XN.mkText text]] + + in mkElement ("jabber:client", "presence") + attrs + (showElem ++ statusElem) + +------------------------------------------------------------------------------- + +unmap :: a -> [(a -> b)] -> [b] +unmap _ [] = [] +unmap x (f:fs) = (f x):(unmap x fs) + +maybeAttr :: (Stanza a) => String -> (a -> Maybe String) -> a -> [(String, String, String)] +maybeAttr attr f = mkAttr attr (\s -> maybe "" id (f s)) + +mkAttr :: (Stanza a) => String -> (a -> String) -> a -> [(String, String, String)] +mkAttr attr f stanza = case f stanza of + "" -> [] + text -> [("", attr, text)] -- 2.38.4