module Network.XMPP.Stanzas
( sendIq
, sendIqWait
, hasBody
, getMessageBody
, sendMessage
, sendPresence
, conj
, attributeMatches
, isMessage
, isPresence
, isIq
, isChat
, isFrom
, iqXmlns
, iqGet
, iqSet
, handleVersion
, getErrorCode
, hasNodeName
)
where
import Network.XMPP.XMPPMonad
import Network.XMPP.XMLParse
import System.Random
import Maybe
sendIq :: String
-> String
-> [XMLElem]
-> XMPP String
sendIq to iqtype payload =
do
iqid <- liftIO $ (randomIO::IO Int)
sendStanza $ XML "iq"
[("to", to),
("type", iqtype),
("id", show iqid)]
payload
return $ show iqid
sendIqWait :: String
-> String
-> [XMLElem]
-> XMPP XMLElem
sendIqWait to iqtype payload =
do
iqid <- sendIq to iqtype payload
waitForStanza $ (hasNodeName "iq") `conj` (attributeMatches "id" (==iqid))
sendIqResponse :: XMLElem
-> String
-> [XMLElem]
-> XMPP (Maybe ())
sendIqResponse inResponseTo iqtype payload =
case getAttr "from" inResponseTo of
Nothing ->
return Nothing
Just sender ->
let iqid = maybe "" id (getAttr "id" inResponseTo)
in do
sendStanza $ XML "iq"
[("to", sender),
("type", iqtype),
("id", iqid)]
payload
return $ Just ()
hasBody :: StanzaPredicate
hasBody stanza = isJust $ getMessageBody stanza
getMessageBody :: XMLElem -> Maybe String
getMessageBody stanza =
do
bodyTag <- xmlPath ["body"] stanza
getCdata bodyTag
sendMessage :: String
-> String
-> XMPP ()
sendMessage to body =
sendStanza $ XML "message"
[("to", to),
("type", "chat")]
[XML "body" []
[CData body]]
sendPresence :: Maybe (String, Maybe String) -> Maybe Integer -> XMPP ()
sendPresence status prio =
let priority = XML "priority" [] [CData $ show $ maybe 0 id prio] in
case status of
Nothing -> sendStanza $ XML "presence" [] [priority]
Just (sh, s) -> sendStanza $ XML "presence" [] [priority, XML "show" [] [CData sh], XML "status" [] [CData $ maybe "" id s]]
conj :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)
conj a b = \x -> a x && b x
hasNodeName :: String -> StanzaPredicate
hasNodeName name (XML name' _ _) = name == name'
isMessage :: StanzaPredicate
isMessage = hasNodeName "message"
isPresence :: StanzaPredicate
isPresence = hasNodeName "presence"
isIq :: StanzaPredicate
isIq = hasNodeName "iq"
isChat :: StanzaPredicate
isChat = isMessage `conj` attributeMatches "type" (=="chat")
attributeMatches :: String
-> (String -> Bool)
-> StanzaPredicate
attributeMatches attr p (XML _ attrs _) =
maybe False p (lookup attr attrs)
isFrom :: String -> StanzaPredicate
isFrom jid = attributeMatches "from" (==jid)
iqXmlns :: String -> StanzaPredicate
iqXmlns xmlns (XML "iq" _ els) =
case listToMaybe [x | x <- els, case x of
XML _ _ _ -> True
_ -> False] of
Just x ->
attributeMatches "xmlns" (==xmlns) x
Nothing ->
False
iqXmlns _ _ = False
iqGet :: String -> StanzaPredicate
iqGet xmlns = (attributeMatches "type" (=="get")) `conj` (iqXmlns xmlns)
iqSet :: String -> StanzaPredicate
iqSet xmlns = (attributeMatches "type" (=="set")) `conj` (iqXmlns xmlns)
handleVersion :: String
-> String
-> String
-> XMPP ()
handleVersion name version os =
addHandler (iqGet "jabber:iq:version")
(\stanza ->
do
sendIqResponse stanza "result"
$ [XML "query"
[("xmlns", "jabber:iq:version")]
[XML "name" [] [CData name],
XML "version" [] [CData version],
XML "os" [] [CData os]]]
return ())
True
getErrorCode :: XMLElem -> Integer
getErrorCode stanza =
case getAttr "type" stanza of
Just "error" -> read $ maybe "-1" id (getAttr "code" errorNode) :: Integer
_ -> 0
where errorNode = maybe (XML [] [] []) id (xmlPath ["error"] stanza)