2 files changed, 84 insertions, 23 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 224d3282..7a784fa1 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -170,6 +170,11 @@ presenceHooks state verbosity mclient mpeer = XMPPServerParameters
     , xmppPeerInformSubscription    = peerInformSubscription state
     , xmppVerbosity                 = return verbosity
     , xmppGroupChat                 = Map.singleton "chat" MUC
+        { mucRoomList      = return [("testroom",Just "testroom")]
+        , mucRoomOccupants = \case
+            "testroom" -> return [("fakeperson",Nothing)]
+            _          -> return []
+        }
     , xmppClientBind                = mclient
     , xmppPeerBind                  = mpeer
     }
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index bc64ecd8..218e60e0 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -86,6 +86,7 @@ import Data.Conduit.ByteString.Builder (builderToByteStringFlush)
 import Data.Conduit.Blaze (builderToByteStringFlush)
 #endif
 
+import Control.Arrow
 import Control.Concurrent.STM.Util
 import DNSCache (withPort)
 import qualified Text.XML.Stream.Render as XML hiding (content)
@@ -120,7 +121,8 @@ newtype Local a = Local a deriving (Eq,Ord,Show)
 newtype Remote a = Remote a deriving (Eq,Ord,Show)
 
 data MUC = MUC
-    { -- todo
+    { mucRoomList      :: IO [(Text,Maybe Text)]
+    , mucRoomOccupants :: Text -> IO [(Text,Maybe Text)]
     }
 
 data XMPPServerParameters =
@@ -655,8 +657,15 @@ makeInfo mid from mto = concat
       , EventEndElement "{jabber:client}iq" ]
     ]
 
-makeMUCInfo :: Maybe Text -> Text -> Maybe Text -> [Event]
-makeMUCInfo mid from mto = concat
+features :: [Text] -> [XML.Event]
+features fs = do
+    t <- fs
+    [ EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
+            [("var",[ContentText t])],
+      EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
+
+makeMUCInfo :: Maybe Text -> Text -> Maybe Text -> [XML.Event] -> [XML.Event]
+makeMUCInfo mid from mto fs = concat
     [ [ EventBeginElement "{jabber:client}iq"
             $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
                             [("from", [ContentText from])
@@ -677,7 +686,7 @@ makeMUCInfo mid from mto = concat
       , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
             [("var",[ContentText "http://jabber.org/protocol/muc"])]
       , EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
-    , []
+    , fs
     , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
       , EventEndElement "{jabber:client}iq" ]
     ]
@@ -1313,6 +1322,29 @@ monitor sv params xmpp = do
 stanzaTypeString :: StanzaWrap a -> String
 stanzaTypeString stanza = concat . take 1 . words $ show (stanzaType stanza)
 
+data ServiceMatch a
+    = NotMe                       -- ^ Hostname of another server.
+    | UnknownService Text         -- ^ Unknown subdomain of this host.
+    | Service (Maybe Text) Text a -- ^ A known subdomain of this host.  Optionally, a specific room name.
+    | TopLevelService             -- ^ This server's exact hostname.
+
+
+lookupService :: Text -> Map.Map Text a -> Text -> (ServiceMatch a)
+lookupService me mucs to = case Text.toLower to of
+    nm | nm == Text.toLower me
+         -> TopLevelService
+    nm | let (a0,b) = Text.break (=='.') nm
+       , Text.drop 1 b == Text.toLower me
+       , let (a,service) = second (Text.drop 1) $ Text.break (=='@') a0
+         -> if Text.null service -- No '@' means that variable /a/ is the service.
+                then case Map.lookup a mucs of
+                    Just muc -> Service Nothing a muc
+                    Nothing  -> UnknownService a -- ItemNotFound
+                else case Map.lookup service mucs of
+                    Just muc -> Service (Just a) service muc
+                    Nothing  -> UnknownService service
+    _ -> NotMe
+
 applyStanza :: Server PeerAddress ConnectionData releaseKey Event
                      -> TMVar ()
                      -> XMPPServerParameters
@@ -1375,29 +1407,53 @@ applyStanza sv quitVar xmpp stanza = case stanzaOrigin stanza of
                 enableClientHacks name version replyto
             RequestInfo -> do
                 me <- xmppTellMyNameToClient xmpp k
-                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 unavail = let query = "{http://jabber.org/protocol/disco#info}info"
+                                  reply = iq_service_unavailable (stanzaId stanza) me query
+                               in (Error ServiceUnavailable (head reply), reply)
+                    sto = fromMaybe me (stanzaTo stanza)
+                let (rtyp,reply) = case lookupService me (xmppGroupChat xmpp) sto of
+                     NotMe              -> unavail
+                     (UnknownService a) -> unavail -- TODO ItemNotFound instead?
+                     (Service Nothing a muc)
+                         -> let reply = makeMUCInfo (stanzaId stanza) (a <> "." <> me) (stanzaFrom stanza) []
+                            in (Info, reply)
+                     (Service (Just room) a muc)
+                         -> let reply = makeMUCInfo (stanzaId stanza) (room <> "@" <> a <> "." <> me) (stanzaFrom stanza)
+                                        $ features
+                                            [ "http://jabber.org/protocol/muc#stable_id" ]
+                            in (Info, reply)
+                     TopLevelService
                          -> 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
+                            in (Info, reply)
+                sendReply quitVar rtyp reply replyto
             RequestItems -> do
                 -- let query = "{http://jabber.org/protocol/disco#items}query"
                 me <- xmppTellMyNameToClient xmpp k
-                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
+                let unavail = let query = "{http://jabber.org/protocol/disco#info}info"
+                                  reply = iq_service_unavailable (stanzaId stanza) me query
+                              in return (Error ServiceUnavailable (head reply), reply)
+                    sto = fromMaybe me (stanzaTo stanza)
+                (rtyp,reply) <- case lookupService me (xmppGroupChat xmpp) sto of
+                     NotMe                   -> unavail
+                     (UnknownService a)      -> unavail -- TODO ItemNotFound instead?
+                     (Service Nothing a muc) -> do
+                        items <- map (\(n,m) -> (n <> "@" <> a <> "." <> me, m))
+                                    <$> mucRoomList muc
+                        let reply = makeItemList (stanzaId stanza) items (a <> "." <> me) (stanzaFrom stanza)
+                        return (Items, reply)
+                     (Service (Just room) a muc) -> do
+                        items <- map (\(n,m) -> (room <> "@" <> a <> "." <> me <> "/" <> n, m))
+                                    <$> mucRoomOccupants muc room
+                            -- Note: I'm assuming 'mucRoomOccupants' returns an empty list for
+                            -- private rooms.
+                        let reply = makeItemList (stanzaId stanza) items (a <> "." <> me) (stanzaFrom stanza)
+                        return (Items, reply)
+                     TopLevelService    -> do
+                         let items = do (name,MUC {}) <- Map.toList $ xmppGroupChat xmpp
+                                        return (name <> "." <> me, Nothing)
+                             reply = makeItemList (stanzaId stanza) items me (stanzaFrom stanza)
+                         return (Items, reply)
+                sendReply quitVar rtyp reply replyto
             UnrecognizedQuery query -> do
                 me <- xmppTellMyNameToClient xmpp k
                 let reply = iq_service_unavailable (stanzaId stanza) me query