module Network.XMPP.Stanza
(
parse
, parseM
, outStanza
) where
import Text.XML.HaXml.Xtract.Parse (xtract)
import Network.XMPP.Types
import Network.XMPP.Print
import Network.XMPP.Stream
import Network.XMPP.Utils
import Data.Maybe
parse :: XmppMessage -> Stanza
parse m | xtractp id "/message" m = parseMessage m
| xtractp id "/presence" m = parsePresence m
| xtractp id "/iq" m = parseIQ m
| otherwise = error "Can't read stanza"
where
xtractp f p m = not . null $ xtract f p m
parseM :: XmppStateT Stanza
parseM = do
m <- nextM
let pm = parse m in do
debug $ "parseM: Got element: " ++ show pm
return pm
parseMessage :: XmppMessage -> Stanza
parseMessage m = Message from to id' messageType subject body thread x
where
from = mread $ txt "/message/@from" m
to = read $ getText_ $ xtract id "/message/@to" m
id' = getText_ $ xtract id "/message/@id" m
messageType = read $ getText_ $ xtract id "/message/@type" m
subject = getText_ $ xtract id "/message/subject/-" m
body = getText_ $ xtract id "/message/body/-" m
thread = getText_ $ xtract id "/message/thread/-" m
x = xtract id "/message/*" m
parsePresence :: XmppMessage -> Stanza
parsePresence m = Presence from to id' presenceType showType status priority x
where
from = mread $ txt "/presence/@from" m
to = mread $ txt "/presence/@to" m
id' = txt "/presence/@id" m
presenceType = read $ txt "/presence/@type" m
showType = read $ txt "/presence/show/-" m
status = txt "/presence/status/-" m
priority = mread $ txt "/presence/priority/-" m
x = xtract id "/presence/*" m
parseIQ :: XmppMessage -> Stanza
parseIQ m = IQ from to id' iqType body
where
from = mread $ txt "/iq/@from" m
to = mread $ txt "/iq/@to" m
id' = txt "/iq/@id" m
iqType = read $ txt "/iq/@type" m
body = [m]
txt :: String
-> XmppMessage
-> String
txt p m = getText_ $ xtract id p m
outStanza :: Stanza -> XmppStateT ()
outStanza s = case s of
a@(Message{}) -> outMessage a
a@(Presence{}) -> outPresence a
a@(IQ{}) -> outIQ a
outMessage :: Stanza -> XmppStateT ()
outMessage (Message from' to' id' mtype' subject' body' thread' x') =
out $ toContent $
ptag "message"
( (mattr "from" from') ++
[ strAttr "to" (show to'),
strAttr "id" id',
strAttr "type" (show mtype'),
xmllang "en" ] )
([ ptag "body" [] [literal body'] ] ++
(if subject' /= "" then [ ptag "subject" [] [literal subject'] ] else []) ++
(if thread' /= "" then [ ptag "thread" [] [literal thread'] ] else []) ++
(map toFilter x'))
outMessage _ = error "Stanza isn't message"
outPresence :: Stanza -> XmppStateT ()
outPresence (Presence from' to' id' ptype' stype' status' priority' x') =
out $ toContent $
ptag "presence"
((mattr "from" from') ++
(mattr "to" to') ++
(if id' /= "" then [strAttr "id" id'] else []) ++
(if ptype' /= Default then [strAttr "type" (show ptype')] else []) ++
[xmllang "en" ])
((if stype' /= Available then [ ptag "show" [] [literal $ show stype'] ] else []) ++
(if status' /= "" then [ ptag "status" [] [ literal status' ] ] else []) ++
(if isJust priority' then [ ptag "priority" [] [ literal $ show (fromJust priority') ] ] else []) ++
(map toFilter x'))
outPresence _ = error "Stanza isn't presence"
outIQ :: Stanza -> XmppStateT ()
outIQ (IQ from' to' id' itype' body') =
out $ toContent $
ptag "iq"
((mattr "from" from') ++
(mattr "to" to') ++
[ strAttr "id" id',
sattr "type" (show itype'),
xmllang "en" ])
(map toFilter body')
outIQ _ = error "Stanza isn't IQ"