1 files changed, 67 insertions, 3 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 004f7472..52933440 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -38,6 +38,8 @@ import Data.Monoid ( (<>) )
 import Data.Text (Text)
 import qualified Data.Text as Text (pack,unpack)
 import Data.Char (toUpper)
+import Data.Map (Map)
+import qualified Data.Map as Map
 
 import qualified Control.Concurrent.STM.UpdateStream as Slotted
 import ControlMaybe
@@ -75,8 +77,15 @@ data LangSpecificMessage =
                         }
   deriving (Show,Eq)
 
-data StanzaType = Unrecognized | Ping | Pong | RequestResource (Maybe Text) | SetResource
-                  | SessionRequest | UnrecognizedQuery Name | Error
+data StanzaType
+    = Unrecognized
+    | Ping
+    | Pong
+    | RequestResource (Maybe Text)
+    | SetResource
+    | SessionRequest
+    | UnrecognizedQuery Name
+    | Error
     | PresenceStatus { presenceShow :: JabberShow
                      , presencePriority :: Maybe Int8
                      , presenceStatus :: [(Lang,Text)]
@@ -298,13 +307,67 @@ grokPresence ns stanzaTag = do
         Just "probe" -> return . Just $ PresenceRequestStatus
         Just "unsubscribe" -> return . Just $ PresenceRequestSubscription False
         Just "subscribe"   -> return . Just $ PresenceRequestSubscription True
-        _ -> return Nothing -- todo
+        _ -> return Nothing
+
+parseMessage ns stanza = do
+    let bodytag = Name { nameNamespace = Just ns
+                       , nameLocalName = "body"
+                       , namePrefix = Nothing }
+        subjecttag = Name { nameNamespace = Just ns
+                          , nameLocalName = "subject"
+                          , namePrefix = Nothing }
+        threadtag = Name { nameNamespace = Just ns
+                         , nameLocalName = "thread"
+                         , namePrefix = Nothing }
+    let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing }
+        parseChildren (th,cmap) = do
+            child <- nextElement
+            lvl <- nesting
+            xmllang <- xmlLang 
+            let lang = maybe "" id xmllang
+            let c = maybe emptyMsg id (Map.lookup lang cmap)
+            -- log $ " child: "<> bshow child
+            case child of
+                Just tag | tagName tag==bodytag
+                                    -> do
+                                        txt <- XML.content
+                                        awaitCloser lvl
+                                        parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
+                Just tag | tagName tag==subjecttag
+                                    -> do
+                                        txt <- XML.content
+                                        awaitCloser lvl
+                                        parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
+                Just tag | tagName tag==threadtag
+                                    -> do
+                                        txt <- XML.content
+                                        awaitCloser lvl
+                                        parseChildren (th {msgThreadContent=txt},cmap)
+                Just tag -> do
+                            -- let nm    = tagName tag
+                            --    attrs = tagAttrs tag
+                            --    -- elems = msgElements c
+                            -- txt <- XML.content
+                            awaitCloser lvl
+                            parseChildren (th,Map.insert lang c cmap)
+                Nothing -> return (th,cmap)
+    (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
+                                  , Map.empty )
+    return Message { 
+        msgLangMap = Map.toList langmap,
+        msgThread = if msgThreadContent th/="" then Just th else Nothing
+    }
+
+grokMessage ns stanzaTag = do
+    t <- parseMessage ns stanzaTag
+    return $ Just t
 
 grokStanza "jabber:server" stanzaTag = 
             case () of
                 _ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag
                 _ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag
                 _ | tagName stanzaTag == "{jabber:server}presence" -> grokPresence "jabber:server" stanzaTag
+                _ | tagName stanzaTag == "{jabber:server}message" -> grokMessage "jabber:server" stanzaTag
                 _ -> return $ Just Unrecognized
 
 grokStanza "jabber:client" stanzaTag = 
@@ -313,6 +376,7 @@ grokStanza "jabber:client" stanzaTag =
                 _ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag
                 _ | stanzaTag `isClientIQOf` "result" -> grokStanzaIQResult stanzaTag
                 _ | tagName stanzaTag == "{jabber:client}presence" -> grokPresence "jabber:client" stanzaTag
+                _ | tagName stanzaTag == "{jabber:client}message" -> grokMessage "jabber:client" stanzaTag
                 _ -> return $ Just Unrecognized
 
 xmppInbound :: Server ConnectionKey