{-# 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 :: Maybe MessageThread
-> [MessageSubject] -> [MessageBody] -> InstantMessage
InstantMessage { imThread :: Maybe MessageThread
imThread = Maybe MessageThread
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 = (UnpickleError -> Maybe InstantMessage)
-> (InstantMessage -> Maybe InstantMessage)
-> Either UnpickleError InstantMessage
-> Maybe InstantMessage
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe InstantMessage -> UnpickleError -> Maybe InstantMessage
forall a b. a -> b -> a
const Maybe InstantMessage
forall a. Maybe a
Nothing) InstantMessage -> Maybe InstantMessage
forall a. a -> Maybe a
Just (Either UnpickleError InstantMessage -> Maybe InstantMessage)
-> ([Element] -> Either UnpickleError InstantMessage)
-> [Element]
-> Maybe InstantMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PU [Element] InstantMessage
-> [Element] -> Either UnpickleError InstantMessage
forall t a. PU t a -> t -> Either UnpickleError a
unpickle PU [Element] InstantMessage
xpIM ([Element] -> Maybe InstantMessage)
-> [Element] -> Maybe InstantMessage
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 = (MessageBody -> MessageBody -> Bool)
-> [MessageBody] -> [MessageBody]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Maybe LangTag -> Maybe LangTag -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe LangTag -> Maybe LangTag -> Bool)
-> (MessageBody -> Maybe LangTag)
-> MessageBody
-> MessageBody
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` MessageBody -> Maybe LangTag
bodyLang) ([MessageBody] -> [MessageBody]) -> [MessageBody] -> [MessageBody]
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
[Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ PU [Element] InstantMessage -> InstantMessage -> [Element]
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 = PU [Element] InstantMessage -> InstantMessage -> [Element]
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 = Jid -> Maybe Jid
forall a. a -> Maybe a
Just Jid
to}
InstantMessage
instantMessage{imBody :: [MessageBody]
imBody = [Maybe LangTag -> Text -> MessageBody
MessageBody Maybe LangTag
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 -> Maybe Message
forall a. Maybe a
Nothing
Just InstantMessage
im -> Message -> Maybe Message
forall a. a -> Maybe a
Just (Message -> Maybe Message) -> Message -> Maybe Message
forall a b. (a -> b) -> a -> b
$ (Message -> InstantMessage -> Message)
-> InstantMessage -> Message -> Message
forall a b c. (a -> b -> c) -> b -> a -> c
flip Message -> InstantMessage -> Message
withIM (InstantMessage
im{imBody :: [MessageBody]
imBody = [MessageBody]
bd}) (Message -> Message) -> Message -> Message
forall a b. (a -> b) -> a -> b
$
Message
message { messageID :: Maybe Text
messageID = Message -> Maybe Text
messageID Message
msg
, messageFrom :: Maybe Jid
messageFrom = Maybe Jid
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 = ((Maybe MessageThread, [MessageSubject], [MessageBody])
-> InstantMessage)
-> (InstantMessage
-> (Maybe MessageThread, [MessageSubject], [MessageBody]))
-> PU
[Element] (Maybe MessageThread, [MessageSubject], [MessageBody])
-> PU [Element] InstantMessage
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))
(PU
[Element] (Maybe MessageThread, [MessageSubject], [MessageBody])
-> PU [Element] InstantMessage)
-> (PU
[Element] (Maybe MessageThread, [MessageSubject], [MessageBody])
-> PU
[Element] (Maybe MessageThread, [MessageSubject], [MessageBody]))
-> PU
[Element] (Maybe MessageThread, [MessageSubject], [MessageBody])
-> PU [Element] InstantMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PU [Element] (Maybe MessageThread, [MessageSubject], [MessageBody])
-> PU
[Element] (Maybe MessageThread, [MessageSubject], [MessageBody])
forall t a. PU t a -> PU t a
xpClean
(PU
[Element] (Maybe MessageThread, [MessageSubject], [MessageBody])
-> PU [Element] InstantMessage)
-> PU
[Element] (Maybe MessageThread, [MessageSubject], [MessageBody])
-> PU [Element] InstantMessage
forall a b. (a -> b) -> a -> b
$ PU [Element] (Maybe MessageThread)
-> PU [Element] [MessageSubject]
-> PU [Element] [MessageBody]
-> PU
[Element] (Maybe MessageThread, [MessageSubject], [MessageBody])
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 = PU [Node] [MessageSubject] -> PU [Element] [MessageSubject]
forall a. PU [Node] a -> PU [Element] a
xpUnliftElems (PU [Node] [MessageSubject] -> PU [Element] [MessageSubject])
-> (PU [Node] [(Maybe LangTag, Text)]
-> PU [Node] [MessageSubject])
-> PU [Node] [(Maybe LangTag, Text)]
-> PU [Element] [MessageSubject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
([(Maybe LangTag, Text)] -> [MessageSubject])
-> ([MessageSubject] -> [(Maybe LangTag, Text)])
-> PU [Node] [(Maybe LangTag, Text)]
-> PU [Node] [MessageSubject]
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap (((Maybe LangTag, Text) -> MessageSubject)
-> [(Maybe LangTag, Text)] -> [MessageSubject]
forall a b. (a -> b) -> [a] -> [b]
map (((Maybe LangTag, Text) -> MessageSubject)
-> [(Maybe LangTag, Text)] -> [MessageSubject])
-> ((Maybe LangTag, Text) -> MessageSubject)
-> [(Maybe LangTag, Text)]
-> [MessageSubject]
forall a b. (a -> b) -> a -> b
$ \(Maybe LangTag
l, Text
s) -> Maybe LangTag -> Text -> MessageSubject
MessageSubject Maybe LangTag
l Text
s)
((MessageSubject -> (Maybe LangTag, Text))
-> [MessageSubject] -> [(Maybe LangTag, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((MessageSubject -> (Maybe LangTag, Text))
-> [MessageSubject] -> [(Maybe LangTag, Text)])
-> (MessageSubject -> (Maybe LangTag, Text))
-> [MessageSubject]
-> [(Maybe LangTag, Text)]
forall a b. (a -> b) -> a -> b
$ \(MessageSubject Maybe LangTag
l Text
s) -> (Maybe LangTag
l,Text
s))
(PU [Node] [(Maybe LangTag, Text)]
-> PU [Element] [MessageSubject])
-> PU [Node] [(Maybe LangTag, Text)]
-> PU [Element] [MessageSubject]
forall a b. (a -> b) -> a -> b
$ Name
-> PU [Attribute] (Maybe LangTag)
-> PU [Node] Text
-> PU [Node] [(Maybe LangTag, Text)]
forall a n.
Name -> PU [Attribute] a -> PU [Node] n -> PU [Node] [(a, n)]
xpElems Name
"{jabber:client}subject" PU [Attribute] (Maybe LangTag)
xpLangTag (PU [Node] Text -> PU [Node] [(Maybe LangTag, Text)])
-> PU [Node] Text -> PU [Node] [(Maybe LangTag, Text)]
forall a b. (a -> b) -> a -> b
$ PU Text Text -> PU [Node] Text
forall a. PU Text a -> PU [Node] a
xpContent PU Text Text
forall a. PU a a
xpId
xpMessageBody :: PU [Element] [MessageBody]
xpMessageBody :: PU [Element] [MessageBody]
xpMessageBody = PU [Node] [MessageBody] -> PU [Element] [MessageBody]
forall a. PU [Node] a -> PU [Element] a
xpUnliftElems (PU [Node] [MessageBody] -> PU [Element] [MessageBody])
-> (PU [Node] [(Maybe LangTag, Text)] -> PU [Node] [MessageBody])
-> PU [Node] [(Maybe LangTag, Text)]
-> PU [Element] [MessageBody]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
([(Maybe LangTag, Text)] -> [MessageBody])
-> ([MessageBody] -> [(Maybe LangTag, Text)])
-> PU [Node] [(Maybe LangTag, Text)]
-> PU [Node] [MessageBody]
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap (((Maybe LangTag, Text) -> MessageBody)
-> [(Maybe LangTag, Text)] -> [MessageBody]
forall a b. (a -> b) -> [a] -> [b]
map (((Maybe LangTag, Text) -> MessageBody)
-> [(Maybe LangTag, Text)] -> [MessageBody])
-> ((Maybe LangTag, Text) -> MessageBody)
-> [(Maybe LangTag, Text)]
-> [MessageBody]
forall a b. (a -> b) -> a -> b
$ \(Maybe LangTag
l, Text
s) -> Maybe LangTag -> Text -> MessageBody
MessageBody Maybe LangTag
l Text
s)
((MessageBody -> (Maybe LangTag, Text))
-> [MessageBody] -> [(Maybe LangTag, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((MessageBody -> (Maybe LangTag, Text))
-> [MessageBody] -> [(Maybe LangTag, Text)])
-> (MessageBody -> (Maybe LangTag, Text))
-> [MessageBody]
-> [(Maybe LangTag, Text)]
forall a b. (a -> b) -> a -> b
$ \(MessageBody Maybe LangTag
l Text
s) -> (Maybe LangTag
l,Text
s))
(PU [Node] [(Maybe LangTag, Text)] -> PU [Element] [MessageBody])
-> PU [Node] [(Maybe LangTag, Text)] -> PU [Element] [MessageBody]
forall a b. (a -> b) -> a -> b
$ Name
-> PU [Attribute] (Maybe LangTag)
-> PU [Node] Text
-> PU [Node] [(Maybe LangTag, Text)]
forall a n.
Name -> PU [Attribute] a -> PU [Node] n -> PU [Node] [(a, n)]
xpElems Name
"{jabber:client}body" PU [Attribute] (Maybe LangTag)
xpLangTag (PU [Node] Text -> PU [Node] [(Maybe LangTag, Text)])
-> PU [Node] Text -> PU [Node] [(Maybe LangTag, Text)]
forall a b. (a -> b) -> a -> b
$ PU Text Text -> PU [Node] Text
forall a. PU Text a -> PU [Node] a
xpContent PU Text Text
forall a. PU a a
xpId
xpMessageThread :: PU [Element] (Maybe MessageThread)
xpMessageThread :: PU [Element] (Maybe MessageThread)
xpMessageThread = PU [Node] (Maybe MessageThread)
-> PU [Element] (Maybe MessageThread)
forall a. PU [Node] a -> PU [Element] a
xpUnliftElems
(PU [Node] (Maybe MessageThread)
-> PU [Element] (Maybe MessageThread))
-> (PU [Node] (Maybe Text, Text)
-> PU [Node] (Maybe MessageThread))
-> PU [Node] (Maybe Text, Text)
-> PU [Element] (Maybe MessageThread)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PU [Node] MessageThread -> PU [Node] (Maybe MessageThread)
forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption
(PU [Node] MessageThread -> PU [Node] (Maybe MessageThread))
-> (PU [Node] (Maybe Text, Text) -> PU [Node] MessageThread)
-> PU [Node] (Maybe Text, Text)
-> PU [Node] (Maybe MessageThread)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Text, Text) -> MessageThread)
-> (MessageThread -> (Maybe Text, Text))
-> PU [Node] (Maybe Text, Text)
-> PU [Node] MessageThread
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))
(PU [Node] (Maybe Text, Text)
-> PU [Element] (Maybe MessageThread))
-> PU [Node] (Maybe Text, Text)
-> PU [Element] (Maybe MessageThread)
forall a b. (a -> b) -> a -> b
$ Name
-> PU [Attribute] (Maybe Text)
-> PU [Node] Text
-> PU [Node] (Maybe Text, Text)
forall a n.
Name -> PU [Attribute] a -> PU [Node] n -> PU [Node] (a, n)
xpElem Name
"{jabber:client}thread"
(Name -> PU Text Text -> PU [Attribute] (Maybe Text)
forall a. Name -> PU Text a -> PU [Attribute] (Maybe a)
xpAttrImplied Name
"parent" PU Text Text
forall a. PU a a
xpId)
(PU Text Text -> PU [Node] Text
forall a. PU Text a -> PU [Node] a
xpContent PU Text Text
forall a. PU a a
xpId)