module Network.Xmpp.IM.Message
where
import Control.Applicative ((<$>))
import Data.Maybe (maybeToList)
import Data.Text (Text)
import Data.XML.Pickle
import Data.XML.Types
import Network.Xmpp.Types
import Network.Xmpp.Pickle
data MessageBody = MessageBody (Maybe LangTag) Text
data MessageThread = MessageThread
Text
(Maybe Text)
data MessageSubject = MessageSubject (Maybe LangTag) Text
xpMessageSubject :: PU [Element] MessageSubject
xpMessageSubject = xpUnliftElems .
xpWrap (\(l, s) -> MessageSubject l s)
(\(MessageSubject l s) -> (l,s))
$ xpElem "{jabber:client}subject" xpLangTag $ xpContent xpId
xpMessageBody :: PU [Element] MessageBody
xpMessageBody = xpUnliftElems .
xpWrap (\(l, s) -> MessageBody l s)
(\(MessageBody l s) -> (l,s))
$ xpElem "{jabber:client}body" xpLangTag $ xpContent xpId
xpMessageThread :: PU [Element] MessageThread
xpMessageThread = xpUnliftElems
. xpWrap (\(t, p) -> MessageThread p t)
(\(MessageThread p t) -> (t,p))
$ xpElem "{jabber:client}thread"
(xpAttrImplied "parent" xpId)
(xpContent xpId)
subject :: Message -> [MessageSubject]
subject m = ms
where
Right ms = unpickle (xpFindMatches xpMessageSubject) $ messagePayload m
thread :: Message -> Maybe MessageThread
thread m = ms
where
Right ms = unpickle (xpOption xpMessageThread) $ messagePayload m
body :: Message -> [MessageBody]
body m = ms
where
Right ms = unpickle (xpFindMatches xpMessageBody) $ messagePayload m
newIM
:: Jid
-> Maybe StanzaId
-> Maybe LangTag
-> MessageType
-> Maybe MessageSubject
-> Maybe MessageThread
-> Maybe MessageBody
-> [Element]
-> Message
newIM t i lang tp sbj thrd bdy payload = Message
{ messageID = i
, messageFrom = Nothing
, messageTo = Just t
, messageLangTag = lang
, messageType = tp
, messagePayload = concat $
maybeToList (pickle xpMessageSubject <$> sbj)
++ maybeToList (pickle xpMessageThread <$> thrd)
++ maybeToList (pickle xpMessageBody <$> bdy)
++ [payload]
}
simpleIM :: Jid -> Text -> Message
simpleIM t bd = newIM
t
Nothing
Nothing
Normal
Nothing
Nothing
(Just $ MessageBody Nothing bd)
[]
answerIM :: Maybe MessageBody -> [Element] -> Message -> Message
answerIM bd payload msg = Message
{ messageID = messageID msg
, messageFrom = Nothing
, messageTo = messageFrom msg
, messageLangTag = messageLangTag msg
, messageType = messageType msg
, messagePayload = concat $
(pickle xpMessageSubject <$> subject msg)
++ maybeToList (pickle xpMessageThread <$> thread msg)
++ maybeToList (pickle xpMessageBody <$> bd)
++ [payload]
}