@@ 15,13 15,10 @@
-}
module Network.Protocol.XMPP.Stanzas (
- Stanza(..)
- ,GenericStanza(..)
- ,Message(..)
- ,Presence(..)
- ,toStanza
- ,toMessage
- ,toPresence
+ StanzaType(..)
+ ,Stanza(..)
+ ,treeToStanza
+ ,stanzaToTree
) where
import Text.XML.HXT.DOM.Interface (XmlTree)
@@ 32,167 29,116 @@ 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
- 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
- }
+data StanzaType =
+ MessageNormal
+ | MessageChat
+ | MessageGroupChat
+ | MessageHeadline
+ | MessageError
+
+ | PresenceUnavailable
+ | PresenceSubscribe
+ | PresenceSubscribed
+ | PresenceUnsubscribe
+ | PresenceUnsubscribed
+ | PresenceProbe
+ | PresenceError
+
+ | IQGet
+ | IQSet
+ | IQResult
+ | IQError
deriving (Show, Eq)
-data Presence = Presence
+data Stanza = Stanza
{
- presenceTo :: Maybe JID
- ,presenceFrom :: Maybe JID
- ,presenceID :: String
- ,presenceType :: String
- ,presenceLang :: String
- ,presenceShow :: String
- ,presenceStatus :: String
+ stanzaType :: StanzaType
+ ,stanzaTo :: Maybe JID
+ ,stanzaFrom :: Maybe JID
+ ,stanzaID :: String
+ ,stanzaLang :: String
+ ,stanzaPayloads :: [XmlTree]
}
- 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)
-
--------------------------------------------------------------------------------
-
-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)
-
-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
+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)]