From e0234fece9ceedb7b2739b9eba903a8addbc7a43 Mon Sep 17 00:00:00 2001
From: Jon Kristensen <info@jonkristensen.com>
Date: Mon, 18 Jul 2011 16:31:09 +0200
Subject: [PATCH] started using the presence and message types again

---
 Network/XMPP/Stream.hs | 64 ++++++++++++++++++++++++++++++++++++++----
 Network/XMPP/Types.hs  | 25 +++++++++++++++--
 2 files changed, 81 insertions(+), 8 deletions(-)

diff --git a/Network/XMPP/Stream.hs b/Network/XMPP/Stream.hs
index 7f5c430..f905103 100644
--- a/Network/XMPP/Stream.hs
+++ b/Network/XMPP/Stream.hs
@@ -198,7 +198,9 @@ presenceToXML p = "<presence" ++ from ++ id' ++ to ++ type' ++ ">" ++
       Nothing -> ""
 
     type' :: String
-    type' = " type='" ++ (presenceType p) ++ "'"
+    type' = case presenceType p of
+      Available -> ""
+      t -> " type='" ++ (presenceTypeToString t) ++ "'"
 
 iqToXML :: IQ -> String
 iqToXML (IQReq (IQGet { iqRequestID = i, iqRequestPayload = p, iqRequestFrom = f, iqRequestTo = t })) =
@@ -285,7 +287,9 @@ messageToXML Message { messageID = i, messageFrom = f, messageTo = t, messagePay
       Nothing -> ""
 
     type' :: String
-    type' = " type='" ++ ty ++ "'"
+    type' = case ty of
+      Normal -> ""
+      t -> " type='" ++ (messageTypeToString t) ++ "'"
 
 
 parseIQ :: Element -> IQ
@@ -347,8 +351,8 @@ parsePresence e = Presence idAttr fromAttr toAttr Nothing typeAttr (elementChild
 
     typeAttr :: PresenceType
     typeAttr = case attributeText typeName e of
-      Just t -> DT.unpack t
-      Nothing -> ""
+      Just t -> stringToPresenceType $ DT.unpack t
+      Nothing -> Available
 
     fromAttr :: Maybe Address
     fromAttr = case attributeText fromName e of
@@ -384,8 +388,8 @@ parseMessage e = Message idAttr fromAttr toAttr Nothing typeAttr (elementChildre
 
     typeAttr :: MessageType
     typeAttr = case attributeText typeName e of
-      Just t -> DT.unpack t
-      Nothing -> ""
+      Just t -> stringToMessageType $ DT.unpack t
+      Nothing -> Normal
 
     fromAttr :: Maybe Address
     fromAttr = case attributeText fromName e of
@@ -413,3 +417,51 @@ parseMessage e = Message idAttr fromAttr toAttr Nothing typeAttr (elementChildre
 
     idName :: Name
     idName = fromString "id"
+
+-- stringToPresenceType "available" = Available
+-- stringToPresenceType "away" = Away
+-- stringToPresenceType "chat" = Chat
+-- stringToPresenceType "dnd" = DoNotDisturb
+-- stringToPresenceType "xa" = ExtendedAway
+
+stringToPresenceType "available" = Available -- TODO: Some client sent this
+
+stringToPresenceType "probe" = Probe
+-- stringToPresenceType "error" = PresenceError -- TODO: Special case
+
+stringToPresenceType "unavailable" = Unavailable
+stringToPresenceType "subscribe" = Subscribe
+stringToPresenceType "subscribed" = Subscribed
+stringToPresenceType "unsubscribe" = Unsubscribe
+stringToPresenceType "unsubscribed" = Unsubscribed
+
+-- presenceTypeToString Available = "available"
+
+-- presenceTypeToString Away = "away"
+-- presenceTypeToString Chat = "chat"
+-- presenceTypeToString DoNotDisturb = "dnd"
+-- presenceTypeToString ExtendedAway = "xa"
+
+presenceTypeToString Unavailable = "unavailable"
+
+presenceTypeToString Probe = "probe"
+-- presenceTypeToString PresenceError = "error" -- TODO: Special case
+
+presenceTypeToString Subscribe = "subscribe"
+presenceTypeToString Subscribed = "subscribed"
+presenceTypeToString Unsubscribe = "unsubscribe"
+presenceTypeToString Unsubscribed = "unsubscribed"
+
+stringToMessageType "chat" = Chat
+stringToMessageType "error" = Error
+stringToMessageType "groupchat" = Groupchat
+stringToMessageType "headline" = Headline
+stringToMessageType "normal" = Normal
+stringToMessageType s = OtherMessageType s
+
+messageTypeToString Chat = "chat"
+messageTypeToString Error = "error"
+messageTypeToString Groupchat = "groupchat"
+messageTypeToString Headline = "headline"
+messageTypeToString Normal = "normal"
+messageTypeToString (OtherMessageType s) = s
diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs
index 9ebea09..c06a854 100644
--- a/Network/XMPP/Types.hs
+++ b/Network/XMPP/Types.hs
@@ -185,7 +185,16 @@ data Message = Message { messageID :: Maybe StanzaID
                deriving (Eq, Show)
 
 
-type MessageType = String
+-- |
+-- @MessageType@ holds XMPP message types as defined in XMPP-IM. @Normal@ is the
+-- default message type.
+
+data MessageType = Chat |
+                   Error |
+                   Groupchat |
+                   Headline |
+                   Normal |
+                   OtherMessageType String deriving (Eq, Show)
 
 
 -- |
@@ -206,7 +215,19 @@ data Presence = Presence { presenceID :: Maybe StanzaID
                 deriving (Eq, Show)
 
 
-type PresenceType = String
+-- |
+-- @PresenceType@ holds XMPP presence types. When a presence type is not
+-- provided, we assign the @PresenceType@ value @Available@.
+
+data PresenceType = Subscribe    | -- ^ Sender wants to subscribe to presence
+                    Subscribed   | -- ^ Sender has approved the subscription
+                    Unsubscribe  | -- ^ Sender is unsubscribing from presence
+                    Unsubscribed | -- ^ Sender has denied or cancelled a
+                                   --   subscription
+                    Probe        | -- ^ Sender requests current presence;
+                                   --   should only be used by servers
+                    Available    | -- ^ Sender did not specify a type attribute
+                    Unavailable deriving (Eq, Show)
 
 
 -- |