{-# 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
                                     }

-- | The instant message (IM) specific part of a message.
data InstantMessage = InstantMessage { InstantMessage -> Maybe MessageThread
imThread  :: Maybe MessageThread
                                     , InstantMessage -> [MessageSubject]
imSubject :: [MessageSubject]
                                     , InstantMessage -> [MessageBody]
imBody    :: [MessageBody]
                                     }

-- | Empty instant message.
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

-- | Get the IM specific parts of a message. Returns 'Nothing' when the received
-- payload is not valid IM data.
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}

-- | Append IM data to a message. Additional IM bodies with the same Langtag are
-- discarded.
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)

-- | Generate a simple message
simpleIM :: Jid -- ^ recipient
         -> Text -- ^ body
         -> 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]}

-- | Generate an answer from a received message. The recepient is
-- taken from the original sender, the sender is set to 'Nothing',
-- message ID, language tag, message type as well as subject and
-- thread are inherited.
--
-- Additional IM bodies with the same Langtag are discarded.
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
                }

--------------------------
-- Picklers --------------
--------------------------
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)