2 files changed, 56 insertions, 11 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 0ae9653f..224d3282 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -169,6 +169,7 @@ presenceHooks state verbosity mclient mpeer = XMPPServerParameters
     , xmppClientInformSubscription  = clientInformSubscription state
     , xmppPeerInformSubscription    = peerInformSubscription state
     , xmppVerbosity                 = return verbosity
+    , xmppGroupChat                 = Map.singleton "chat" MUC
     , xmppClientBind                = mclient
     , xmppPeerBind                  = mpeer
     }
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index dcbc9bf5..bc64ecd8 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -15,6 +15,7 @@ module XMPPServer
     , Remote(..)
     , ConnectionData(..)
     , ConnectionType(..)
+    , MUC(..)
     , XMPPServerParameters(..)
     , XMPPServer
     , classifyConnection
@@ -93,7 +94,7 @@ import Data.XML.Types as XML
 import Data.Maybe
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
-import qualified Data.Text as Text (pack,unpack,intercalate,drop,toLower)
+import qualified Data.Text as Text
 import qualified Data.Map as Map
 import Data.Set (Set, (\\) )
 import qualified Data.Set as Set
@@ -118,6 +119,10 @@ my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574"
 newtype Local a = Local a deriving (Eq,Ord,Show)
 newtype Remote a = Remote a deriving (Eq,Ord,Show)
 
+data MUC = MUC
+    { -- todo
+    }
+
 data XMPPServerParameters =
     XMPPServerParameters
     { -- | Called when a client requests a resource id.  The first Maybe indicates
@@ -155,6 +160,7 @@ data XMPPServerParameters =
     , xmppClientInformSubscription :: IO () -> ClientAddress -> Stanza -> IO ()
     , -- | Called when a remote peer informs us of our subscription status.
       xmppPeerInformSubscription :: IO () -> PeerAddress -> Stanza -> IO ()
+    , xmppGroupChat          :: Map.Map Text MUC -- Key should be lowercase identifier.
     , xmppVerbosity          :: IO Int
     , xmppClientBind         :: Maybe SockAddr
     , xmppPeerBind           :: Maybe SockAddr
@@ -640,12 +646,42 @@ makeInfo mid from mto = concat
       , EventEndElement "{http://jabber.org/protocol/disco#info}identity"
       , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
             [("var",[ContentText "http://jabber.org/protocol/disco#info"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}feature"
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
+            [("var",[ContentText "http://jabber.org/protocol/disco#items"])]
       , EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
     , [] -- todo
     , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
       , EventEndElement "{jabber:client}iq" ]
     ]
 
+makeMUCInfo :: Maybe Text -> Text -> Maybe Text -> [Event]
+makeMUCInfo mid from mto = concat
+    [ [ EventBeginElement "{jabber:client}iq"
+            $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
+                            [("from", [ContentText from])
+                            ,("type", [ContentText "result"])]
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}query" []
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}identity"
+            [("category",[ContentText "conference"])
+            ,("type",[ContentText "text"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}identity"
+      {-
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
+            [("var",[ContentText "http://jabber.org/protocol/disco#info"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}feature"
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
+            [("var",[ContentText "http://jabber.org/protocol/disco#items"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}feature"
+      -}
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
+            [("var",[ContentText "http://jabber.org/protocol/muc"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
+    , []
+    , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
+      , EventEndElement "{jabber:client}iq" ]
+    ]
+
 makeItemList :: Maybe Text -> [(Text,Maybe Text)] -> Text -> Maybe Text -> [Event]
 makeItemList mid items from mto = concat
     [ [ EventBeginElement "{jabber:client}iq"
@@ -1338,20 +1374,28 @@ applyStanza sv quitVar xmpp stanza = case stanzaOrigin stanza of
             NotifyClientVersion name version -> do
                 enableClientHacks name version replyto
             RequestInfo -> do
-                -- TODO ItemNotFound
                 me <- xmppTellMyNameToClient xmpp k
-                if fmap Text.toLower (stanzaTo stanza) == Just (Text.toLower me)
-                    then
-                        let reply = makeInfo (stanzaId stanza) me (stanzaFrom stanza)
-                        in sendReply quitVar Info reply replyto
-                    else
-                        let query = "{http://jabber.org/protocol/disco#info}info"
-                            reply = iq_service_unavailable (stanzaId stanza) me query
-                        in sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto
+                let fail = let query = "{http://jabber.org/protocol/disco#info}info"
+                               reply = iq_service_unavailable (stanzaId stanza) me query
+                            in sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto
+                case fmap Text.toLower (stanzaTo stanza) of
+                    Nothing -> fail
+                    Just nm | nm == Text.toLower me
+                         -> let reply = makeInfo (stanzaId stanza) me (stanzaFrom stanza)
+                            in sendReply quitVar Info reply replyto
+                    Just nm | let (a,b) = Text.break (=='.') nm
+                            , Text.drop 1 b == Text.toLower me
+                            , Just muc <- Map.lookup a (xmppGroupChat xmpp)
+                         -> let reply = makeMUCInfo (stanzaId stanza) (a <> "." <> me) (stanzaFrom stanza)
+                            in sendReply quitVar Info reply replyto
+                    -- TODO ItemNotFound
+                    _ -> fail
             RequestItems -> do
                 -- let query = "{http://jabber.org/protocol/disco#items}query"
                 me <- xmppTellMyNameToClient xmpp k
-                let items = []
+                let items = do
+                        (name,MUC {}) <- Map.toList $ xmppGroupChat xmpp
+                        return (name <> "." <> me, Nothing)
                     reply = makeItemList (stanzaId stanza) items me (stanzaFrom stanza)
                 sendReply quitVar Items reply replyto
             UnrecognizedQuery query -> do