MUC: It works.

3 files changed, 79 insertions, 7 deletions

diff --git a/Presence/Stanza/Build.hs b/Presence/Stanza/Build.hs
index e02684f5..16552428 100644
--- a/Presence/Stanza/Build.hs
+++ b/Presence/Stanza/Build.hs
@@ -19,24 +19,34 @@ import LockedChan
 import Stanza.Types
 
 makeMessage :: Text -> Text -> Text -> Text -> IO Stanza
-makeMessage namespace from to bod =
+makeMessage namespace from to bod = makeMessageEx namespace from to NormalMsg bod
+
+makeMessageEx :: Text -> Text -> Text -> MessageType -> Text -> IO Stanza
+makeMessageEx namespace from to msgtyp bod =
     stanzaFromList typ
      $ [ EventBeginElement (mkname namespace "message")
-            [ attr "from" from
-            , attr "to" to
-            ]
+            $ addMessageType msgtyp
+                [ attr "from" from
+                , attr "to" to
+                ]
        , EventBeginElement (mkname namespace "body") []
        , EventContent (ContentText bod)
        , EventEndElement (mkname namespace "body")
        , EventEndElement (mkname namespace "message") ]
  where
-    typ = Message { msgThread = Nothing
+    typ = Message { msgThread  = Nothing
                   , msgLangMap = [("", lsm)]
+                  , msgType    = msgtyp
                   }
     lsm = LangSpecificMessage
-            { msgBody = Just bod
+            { msgBody    = Just bod
             , msgSubject = Nothing }
 
+addMessageType ChatMsg      attrs = ("type",[ContentText "chat"]) : attrs
+addMessageType GroupChatMsg attrs = ("type",[ContentText "groupchat"]) : attrs
+addMessageType HeadlineMsg  attrs = ("type",[ContentText "headline"]) : attrs
+addMessageType _            attrs = attrs
+
 makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza
 makeInformSubscription namespace from to approved =
     stanzaFromList (PresenceInformSubscription approved)
diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs
index b025f418..58bf7c51 100644
--- a/Presence/Stanza/Parse.hs
+++ b/Presence/Stanza/Parse.hs
@@ -227,9 +227,16 @@ parseMessage ns stanza = do
                                   , Map.empty )
     return Message {
         msgLangMap = Map.toList langmap,
-        msgThread = if msgThreadContent th/="" then Just th else Nothing
+        msgThread  = if msgThreadContent th/="" then Just th else Nothing,
+        msgType    = parseMessageType $ lookupAttrib "type" (tagAttrs stanza)
     }
 
+parseMessageType :: Maybe Text -> MessageType
+parseMessageType (Just "chat")      = ChatMsg
+parseMessageType (Just "groupchat") = GroupChatMsg
+parseMessageType (Just "headline")  = HeadlineMsg
+parseMessageType _                  = NormalMsg
+
 findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError)
 findErrorTag ns = do
     x <- nextElement
diff --git a/Presence/Stanza/Types.hs b/Presence/Stanza/Types.hs
index 6c5b8867..7275c8ab 100644
--- a/Presence/Stanza/Types.hs
+++ b/Presence/Stanza/Types.hs
@@ -70,6 +70,7 @@ data StanzaType
     | PresenceRequestSubscription Bool
     | Message { msgThread :: Maybe MessageThread
               , msgLangMap :: [(Lang,LangSpecificMessage)]
+              , msgType :: MessageType
               }
     | NotifyClientVersion { versionName :: Text
                           , versionVersion :: Text }
@@ -77,6 +78,60 @@ data StanzaType
     | InternalCacheId Text
  deriving (Show,Eq)
 
+data MessageType
+    = NormalMsg  -- ^ The message is a standalone message that is sent outside
+                 -- the context of a one-to-one conversation or groupchat, and
+                 -- to which it is expected that the recipient will reply.
+                 -- Typically a receiving client will present a message of type
+                 -- "normal" in an interface that enables the recipient to
+                 -- reply, but without a conversation history. The default
+                 -- value of the 'type' attribute is "normal".
+
+    | ChatMsg -- ^ The message is sent in the context of a one-to-one chat
+              -- session. Typically an interactive client will present a
+              -- message of type "chat" in an interface that enables one-to-one
+              -- chat between the two parties, including an appropriate
+              -- conversation history. Detailed recommendations regarding
+              -- one-to-one chat sessions are provided under Section 5.1.
+
+    | GroupChatMsg -- ^ The message is sent in the context of a multi-user chat
+                   -- environment (similar to that of [IRC]). Typically a
+                   -- receiving client will present a message of type
+                   -- "groupchat" in an interface that enables many-to-many
+                   -- chat between the parties, including a roster of parties
+                   -- in the chatroom and an appropriate conversation history.
+                   -- For detailed information about XMPP-based groupchat,
+                   -- refer to [XEP‑0045].
+
+    | HeadlineMsg -- ^ The message provides an alert, a notification, or other
+                  -- transient information to which no reply is expected (e.g.,
+                  -- news headlines, sports updates, near-real-time market
+                  -- data, or syndicated content). Because no reply to the
+                  -- message is expected, typically a receiving client will
+                  -- present a message of type "headline" in an interface that
+                  -- appropriately differentiates the message from standalone
+                  -- messages, chat messages, and groupchat messages (e.g., by
+                  -- not providing the recipient with the ability to reply). If
+                  -- the 'to' address is the bare JID, the receiving server
+                  -- SHOULD deliver the message to all of the recipient's
+                  -- available resources with non-negative presence priority
+                  -- and MUST deliver the message to at least one of those
+                  -- resources; if the 'to' address is a full JID and there is
+                  -- a matching resource, the server MUST deliver the message
+                  -- to that resource; otherwise the server MUST either
+                  -- silently ignore the message or return an error (see
+                  -- Section 8).
+
+    -- | ErrorMsg -- The message is generated by an entity that experiences an
+    -- error when processing a message received from another entity (for
+    -- details regarding stanza error syntax, refer to [XMPP‑CORE]). A client
+    -- that receives a message of type "error" SHOULD present an appropriate
+    -- interface informing the original sender regarding the nature of the
+    -- error.
+
+ deriving (Show,Read,Ord,Eq,Enum)
+
+
 data RosterEventType
     = RequestedSubscription
     | NewBuddy -- preceded by PresenceInformSubscription True