{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.Xmpp.IM.Message where
import Data.Default
import Data.Function
import Data.List
import Data.Text (Text)
import Data.XML.Pickle
import Data.XML.Types
import Network.Xmpp.Marshal
import Network.Xmpp.Types
data MessageBody = MessageBody { MessageBody -> Maybe LangTag
bodyLang :: Maybe LangTag
, MessageBody -> Text
bodyContent :: Text
}
data MessageThread = MessageThread { MessageThread -> Text
threadID :: Text
, MessageThread -> Maybe Text
threadParent :: Maybe Text
}
data MessageSubject = MessageSubject { MessageSubject -> Maybe LangTag
subjectLang :: Maybe LangTag
, MessageSubject -> Text
subjectContent :: Text
}
data InstantMessage = InstantMessage { InstantMessage -> Maybe MessageThread
imThread :: Maybe MessageThread
, InstantMessage -> [MessageSubject]
imSubject :: [MessageSubject]
, InstantMessage -> [MessageBody]
imBody :: [MessageBody]
}
instantMessage :: InstantMessage
instantMessage :: InstantMessage
instantMessage = InstantMessage { imThread :: Maybe MessageThread
imThread = forall a. Maybe a
Nothing
, imSubject :: [MessageSubject]
imSubject = []
, imBody :: [MessageBody]
imBody = []
}
instance Default InstantMessage where
def :: InstantMessage
def = InstantMessage
instantMessage
getIM :: Message -> Maybe InstantMessage
getIM :: Message -> Maybe InstantMessage
getIM Message
im = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. PU t a -> t -> Either UnpickleError a
unpickle PU [Element] InstantMessage
xpIM forall a b. (a -> b) -> a -> b
$ Message -> [Element]
messagePayload Message
im
sanitizeIM :: InstantMessage -> InstantMessage
sanitizeIM :: InstantMessage -> InstantMessage
sanitizeIM InstantMessage
im = InstantMessage
im{imBody :: [MessageBody]
imBody = forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` MessageBody -> Maybe LangTag
bodyLang) forall a b. (a -> b) -> a -> b
$ InstantMessage -> [MessageBody]
imBody InstantMessage
im}
withIM :: Message -> InstantMessage -> Message
withIM :: Message -> InstantMessage -> Message
withIM Message
m InstantMessage
im = Message
m{ messagePayload :: [Element]
messagePayload = Message -> [Element]
messagePayload Message
m
forall a. [a] -> [a] -> [a]
++ forall t a. PU t a -> a -> t
pickleTree PU [Element] InstantMessage
xpIM (InstantMessage -> InstantMessage
sanitizeIM InstantMessage
im) }
imToElements :: InstantMessage -> [Element]
imToElements :: InstantMessage -> [Element]
imToElements InstantMessage
im = forall t a. PU t a -> a -> t
pickle PU [Element] InstantMessage
xpIM (InstantMessage -> InstantMessage
sanitizeIM InstantMessage
im)
simpleIM :: Jid
-> Text
-> Message
simpleIM :: Jid -> Text -> Message
simpleIM Jid
to Text
bd = Message -> InstantMessage -> Message
withIM Message
message{messageTo :: Maybe Jid
messageTo = forall a. a -> Maybe a
Just Jid
to}
InstantMessage
instantMessage{imBody :: [MessageBody]
imBody = [Maybe LangTag -> Text -> MessageBody
MessageBody forall a. Maybe a
Nothing Text
bd]}
answerIM :: [MessageBody] -> Message -> Maybe Message
answerIM :: [MessageBody] -> Message -> Maybe Message
answerIM [MessageBody]
bd Message
msg = case Message -> Maybe InstantMessage
getIM Message
msg of
Maybe InstantMessage
Nothing -> forall a. Maybe a
Nothing
Just InstantMessage
im -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip Message -> InstantMessage -> Message
withIM (InstantMessage
im{imBody :: [MessageBody]
imBody = [MessageBody]
bd}) forall a b. (a -> b) -> a -> b
$
Message
message { messageID :: Maybe Text
messageID = Message -> Maybe Text
messageID Message
msg
, messageFrom :: Maybe Jid
messageFrom = forall a. Maybe a
Nothing
, messageTo :: Maybe Jid
messageTo = Message -> Maybe Jid
messageFrom Message
msg
, messageLangTag :: Maybe LangTag
messageLangTag = Message -> Maybe LangTag
messageLangTag Message
msg
, messageType :: MessageType
messageType = Message -> MessageType
messageType Message
msg
}
xpIM :: PU [Element] InstantMessage
xpIM :: PU [Element] InstantMessage
xpIM = forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap (\(Maybe MessageThread
t, [MessageSubject]
s, [MessageBody]
b) -> Maybe MessageThread
-> [MessageSubject] -> [MessageBody] -> InstantMessage
InstantMessage Maybe MessageThread
t [MessageSubject]
s [MessageBody]
b)
(\(InstantMessage Maybe MessageThread
t [MessageSubject]
s [MessageBody]
b) -> (Maybe MessageThread
t, [MessageSubject]
s, [MessageBody]
b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. PU t a -> PU t a
xpClean
forall a b. (a -> b) -> a -> b
$ forall a a1 a2 a3.
PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] (a1, a2, a3)
xp3Tuple
PU [Element] (Maybe MessageThread)
xpMessageThread
PU [Element] [MessageSubject]
xpMessageSubject
PU [Element] [MessageBody]
xpMessageBody
xpMessageSubject :: PU [Element] [MessageSubject]
xpMessageSubject :: PU [Element] [MessageSubject]
xpMessageSubject = forall a. PU [Node] a -> PU [Element] a
xpUnliftElems forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \(Maybe LangTag
l, Text
s) -> Maybe LangTag -> Text -> MessageSubject
MessageSubject Maybe LangTag
l Text
s)
(forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \(MessageSubject Maybe LangTag
l Text
s) -> (Maybe LangTag
l,Text
s))
forall a b. (a -> b) -> a -> b
$ forall a n.
Name -> PU [Attribute] a -> PU [Node] n -> PU [Node] [(a, n)]
xpElems Name
"{jabber:client}subject" PU [Attribute] (Maybe LangTag)
xpLangTag forall a b. (a -> b) -> a -> b
$ forall a. PU Text a -> PU [Node] a
xpContent forall a. PU a a
xpId
xpMessageBody :: PU [Element] [MessageBody]
xpMessageBody :: PU [Element] [MessageBody]
xpMessageBody = forall a. PU [Node] a -> PU [Element] a
xpUnliftElems forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \(Maybe LangTag
l, Text
s) -> Maybe LangTag -> Text -> MessageBody
MessageBody Maybe LangTag
l Text
s)
(forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \(MessageBody Maybe LangTag
l Text
s) -> (Maybe LangTag
l,Text
s))
forall a b. (a -> b) -> a -> b
$ forall a n.
Name -> PU [Attribute] a -> PU [Node] n -> PU [Node] [(a, n)]
xpElems Name
"{jabber:client}body" PU [Attribute] (Maybe LangTag)
xpLangTag forall a b. (a -> b) -> a -> b
$ forall a. PU Text a -> PU [Node] a
xpContent forall a. PU a a
xpId
xpMessageThread :: PU [Element] (Maybe MessageThread)
xpMessageThread :: PU [Element] (Maybe MessageThread)
xpMessageThread = forall a. PU [Node] a -> PU [Element] a
xpUnliftElems
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap (\(Maybe Text
t, Text
p) -> Text -> Maybe Text -> MessageThread
MessageThread Text
p Maybe Text
t)
(\(MessageThread Text
p Maybe Text
t) -> (Maybe Text
t,Text
p))
forall a b. (a -> b) -> a -> b
$ forall a n.
Name -> PU [Attribute] a -> PU [Node] n -> PU [Node] (a, n)
xpElem Name
"{jabber:client}thread"
(forall a. Name -> PU Text a -> PU [Attribute] (Maybe a)
xpAttrImplied Name
"parent" forall a. PU a a
xpId)
(forall a. PU Text a -> PU [Node] a
xpContent forall a. PU a a
xpId)