improve IM/Message

source/Network/Xmpp/Concurrent/Channels/Message.hs

@@ -33,6 +33,10 @@ pullMessage session = do
     c <- getMessageChan session
     atomically $ readTChan c
 
+-- | Get the next received message
+getMessage :: Context -> IO Message
+getMessage = waitForMessage (const True)
+
 -- | Pulls a (non-error) message and returns it if the given predicate returns
 -- @True@.
 waitForMessage :: (Message -> Bool) -> Context -> IO Message

source/Network/Xmpp/IM.hs

@@ -3,6 +3,7 @@ module Network.Xmpp.IM
     subject
   , thread
   , body
+  , bodies
   , newIM
   , simpleIM
   , answerIM
@@ -11,4 +12,4 @@ module Network.Xmpp.IM
   ) where
 
 import Network.Xmpp.IM.Message
-import Network.Xmpp.IM.Presence
+import Network.Xmpp.IM.Presence

source/Network/Xmpp/IM/Message.hs

@@ -6,7 +6,7 @@ module Network.Xmpp.IM.Message
 
 import Control.Applicative ((<$>))
 
-import Data.Maybe (maybeToList)
+import Data.Maybe (maybeToList, listToMaybe)
 import Data.Text (Text)
 import Data.XML.Pickle
 import Data.XML.Types
@@ -14,11 +14,17 @@ import Data.XML.Types
 import Network.Xmpp.Types
 import Network.Xmpp.Pickle
 
-data MessageBody = MessageBody (Maybe LangTag) Text
+data MessageBody = MessageBody { bodyLang :: (Maybe LangTag)
-data MessageThread = MessageThread
+                               , bodyContent :: Text
-                        Text          -- Thread ID
+                               }
-                        (Maybe Text)  -- Parent Thread
+
-data MessageSubject = MessageSubject (Maybe LangTag) Text
+data MessageThread = MessageThread { theadID :: Text
+                                   , threadParent :: (Maybe Text)
+                                   }
+
+data MessageSubject = MessageSubject { subjectLang :: (Maybe LangTag)
+                                     , subjectContent :: Text
+                                     }
 
 xpMessageSubject :: PU [Element] MessageSubject
 xpMessageSubject = xpUnliftElems .
@@ -61,12 +67,16 @@ thread m = ms
 
 -- | 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]
+bodies :: Message -> [MessageBody]
-body m = ms
+bodies m = ms
   where
     -- xpFindMatches will _always_ return Right
     Right ms = unpickle (xpFindMatches xpMessageBody) $ messagePayload m
 
+-- | Return the first body element, regardless of it's language.
+body :: Message -> Maybe Text
+body m = bodyContent <$> listToMaybe (bodies m)
+
 -- | Generate a new instant message
 newIM
   :: Jid
@@ -109,8 +119,10 @@ simpleIM t bd = newIM
 -- 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, the remaining payload is replaced by the
--- given one
+-- given one.
-answerIM :: Maybe MessageBody -> [Element] -> Message -> Message
+--
+-- If multiple message bodies are given they must have different language tags
+answerIM :: [MessageBody] -> [Element] -> Message -> Message
 answerIM bd payload msg = Message
     { messageID      = messageID msg
     , messageFrom    = Nothing
@@ -120,6 +132,6 @@ answerIM bd payload msg = Message
     , messagePayload =  concat $
                         (pickle xpMessageSubject <$> subject msg)
                         ++ maybeToList (pickle xpMessageThread <$> thread msg)
-                        ++ maybeToList (pickle xpMessageBody <$> bd)
+                        ++ (pickle xpMessageBody <$> bd)
                         ++ [payload]
     }