add functions to extract subject, thread and body from message add newIM that creates a new message with subject, thread and body

src/Network/XMPP/IM/Message.hs

@@ -1,36 +1,77 @@
-{-# LANGUAGE RecordWildCards #-}
-
+{-# LANGUAGE OverloadedStrings #-}
 module Network.XMPP.IM.Message
-    ( Message(..)
-    , MessageError(..)
-    , MessageType(..)
-    , answerMessage
-    , message
-    ) where
+     where
 
 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          -- ^ Thread ID
+                        (Maybe Text)  -- ^ Parent Thread
+data MessageSubject = MessageSubject (Maybe LangTag) Text
+
+xpMessageSubject :: PU [Node] MessageSubject
+xpMessageSubject = xpWrap (\(l, s) ->  MessageSubject l s)
+                          (\(MessageSubject l s) -> (l,s))
+                   $ xpElem "{jabber:client}subject" xpLangTag $ xpContent xpId
+
+xpMessageBody :: PU [Node] MessageBody
+xpMessageBody = xpWrap (\(l, s) ->  MessageBody l s)
+                          (\(MessageBody l s) -> (l,s))
+                   $ xpElem "{jabber:client}body" xpLangTag $ xpContent xpId
+
+xpMessageThread :: PU [Node] MessageThread
+xpMessageThread = xpWrap (\(t, p) ->  MessageThread p t)
+                          (\(MessageThread p t) -> (t,p))
+                   $ xpElem "{jabber:client}thread"
+                      (xpAttrImplied "parent" xpId)
+                      (xpContent xpId)
+
+-- | Get the subject elements of a message (if any). Messages may
+-- contain multiple subjects if each of them has a distinct xml:lang
+-- attribute
+subject :: Message -> [MessageSubject]
+subject m = ms
+  where
+    -- xpFindMatches will _always_ return Right
+    Right ms = unpickle (xpFindMatches xpMessageSubject) $ messagePayload m
+
+-- | Get the thread elements of a message (if any). The threads is not considered human readable and no semantic mea
+thread :: Message -> Maybe MessageThread
+thread m = ms
+  where
+    -- xpFindMatches will _always_ return Right
+    Right ms = unpickle (xpOption xpMessageThread) $ messagePayload m
+
+-- | Get the body elements of a message (if any). Messages may contain
+-- multiple bodies if each of them has a distinct xml:lang attribute
+body :: Message -> [MessageBody]
+body m = ms
+  where
+    -- xpFindMatches will _always_ return Right
+    Right ms = unpickle (xpFindMatches xpMessageBody) $ messagePayload m
 
--- | An empty message.
-message :: Message
-message = Message { messageID      = Nothing
-                  , messageFrom    = Nothing
-                  , messageTo      = Nothing
-                  , messageLangTag = Nothing
-                  , messageType    = Normal
-                  , messagePayload = []
-                  }
-
--- Produce an answer message with the given payload, switching the "from" and
--- "to" attributes in the original message.
-answerMessage :: Message -> [Element] -> Maybe Message
-answerMessage Message{messageFrom = Just frm, ..} payload =
-    Just Message{ messageFrom    = messageTo
-                , messageID      = Nothing
-                , messageTo      = Just frm
-                , messagePayload = payload
-                , ..
-                }
-answerMessage _ _ = Nothing
+newIM
+  :: JID
+     -> Maybe StanzaId
+     -> Maybe LangTag
+     -> MessageType
+     -> MessageSubject
+     -> MessageThread
+     -> MessageBody
+     -> Message
+newIM t i lang tp sbj thrd bdy = Message
+    { messageID      = i
+    , messageFrom    = Nothing
+    , messageTo      = Just t
+    , messageLangTag = lang
+    , messageType    = tp
+    , messagePayload =  pickle xpMessageSubject sbj
+                        ++ pickle xpMessageThread thrd
+                        ++ pickle xpMessageBody bdy
+    }

src/Network/XMPP/Message.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE RecordWildCards #-}
+module Network.XMPP.Message
+    ( Message(..)
+    , MessageError(..)
+    , MessageType(..)
+    , answerMessage
+    , message
+    ) where
+
+import Data.XML.Types
+
+import Network.XMPP.Types
+
+-- | An empty message.
+message :: Message
+message = Message { messageID      = Nothing
+                  , messageFrom    = Nothing
+                  , messageTo      = Nothing
+                  , messageLangTag = Nothing
+                  , messageType    = Normal
+                  , messagePayload = []
+                  }
+
+-- Produce an answer message with the given payload, switching the "from" and
+-- "to" attributes in the original message.
+answerMessage :: Message -> [Node] -> Maybe Message
+answerMessage Message{messageFrom = Just frm, ..} payload =
+    Just Message{ messageFrom    = messageTo
+                , messageID      = Nothing
+                , messageTo      = Just frm
+                , messagePayload = payload
+                , ..
+                }
+answerMessage _ _ = Nothing