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

-- | 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 = (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}

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

-- | 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 = 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]}

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

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