1 files changed, 52 insertions, 10 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 3a255cdd..912bbf0b 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DoAndIfThenElse           #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleInstances         #-}
+{-# LANGUAGE LambdaCase                #-}
 {-# LANGUAGE MultiWayIf                #-}
 {-# LANGUAGE OverloadedStrings         #-}
 {-# LANGUAGE RankNTypes                #-}
@@ -71,6 +72,7 @@ import Control.Concurrent.Lifted (forkIO,myThreadId,ThreadId)
 import GHC.Conc                  (labelThread)
 #endif
 import Control.Concurrent.STM
+import Data.List hiding ((\\))
 -- import Control.Concurrent.STM.TChan
 import Network.SocketLike
 import Text.Printf
@@ -108,6 +110,8 @@ import DebugTag
 import Stanza.Build
 import Stanza.Parse
 import Stanza.Types
+import MUC
+import Chat
 
 -- peerport :: PortNumber
 -- peerport = 5269
@@ -121,13 +125,6 @@ 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
-    { mucRoomList      :: IO [(Text{-room-},Maybe Text{-friendly room name-})]
-    , mucRoomOccupants :: Text{-room-} -> IO [(Text{-nick-},Maybe Text{-friendly name-})]
-    , mucReservedNick  :: Text{-room-} -> IO (Maybe (Text{-JID-} -> IO (Maybe Text)))
-    , mucJoinRoom      :: Text{-room-} -> Text{-nick-} -> ClientAddress -> Stanza -> IO ()
-    }
-
 data XMPPServerParameters =
     XMPPServerParameters
     { -- | Called when a client requests a resource id.  The first Maybe indicates
@@ -1286,6 +1283,8 @@ monitor sv params xmpp = do
     stanzas <- atomically newTChan
     quitVar <- atomically newEmptyTMVar
     pp_mvar <- newMVar () -- Lock for synchronous pretty-printing of stanzas in log.
+    joined_rooms <- atomically
+        $ newTVar (Map.empty :: Map.Map ClientAddress (Map.Map (Text,Text) (TChan Stanza,JoinedRoom ClientAddress)))
     fix $ \loop -> do
     action <- atomically $ foldr1 orElse
       [ readTChan chan >>= \((addr,u),e) -> return $ do
@@ -1325,7 +1324,7 @@ monitor sv params xmpp = do
         -}
         dup <- cloneStanza stanza
 
-        t <- forkIO $ do applyStanza sv quitVar xmpp stanza
+        t <- forkIO $ do applyStanza sv joined_rooms quitVar xmpp stanza
                          forwardStanza quitVar xmpp stanza
         labelThread t $ "process." ++ stanzaTypeString stanza
 
@@ -1347,6 +1346,19 @@ monitor sv params xmpp = do
         liftIO $ takeMVar pp_mvar
         runConduit $ stanzaToConduit dup .| prettyPrint typ
         liftIO $ putMVar pp_mvar ()
+      , do
+            m <- readTVar joined_rooms
+            foldr orElse retry $ (`map` (do (k,rs) <- Map.toList m
+                                            i <- Map.toList rs
+                                            return (k,i)))
+                $ \(k,((rkey,muckey),(replyto,r))) -> do
+                    (mine,ChatTransaction no cjid cnick es) <- readRoom k r
+                    return $ do
+                        me <- xmppTellMyNameToClient xmpp k
+                        dput XJabber $ "CHAT " ++ Text.unpack rkey ++ ": <" ++ Text.unpack cnick ++ "> " ++ show es
+                        forM_ es $ \case
+                            Join | mine -> sendRoomOccupants muckey me cnick rkey r replyto
+                            _           -> return ()
       ]
     action
     loop
@@ -1355,6 +1367,30 @@ monitor sv params xmpp = do
         where
             _ = str :: String
 
+sendRoomOccupants :: Text -> Text -> Text -> Text -> JoinedRoom k -> TChan Stanza -> IO ()
+sendRoomOccupants a me them room r replyto = do
+    let roomjid n = room <> "@" <> a <> "." <> me <> "/" <> n
+    xs <- map (\(n,m) -> (roomjid n, m))
+             <$> atomically (roomOccupants $ joinedRoom r)
+    let (ys,xs') = partition (\(jid,_) -> jid == roomjid them) xs
+    forM_ xs $ \(jid,_) -> do
+        stanza <- makePresenceStanzaEx "jabber:client" (Just jid) Available
+            [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
+            , EventEndElement "{http://jabber.org/protocol/muc#user}x"
+            ]
+        ioWriteChan replyto stanza
+    forM_ ys $ \(jid,_) -> do
+        stanza <- makePresenceStanzaEx "jabber:client" (Just jid) Available
+            [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
+            , EventBeginElement "{http://jabber.org/protocol/muc#user}status"
+                [ ("code",[ContentText "110"]) -- self-presence code.
+                ]
+            , EventEndElement "{http://jabber.org/protocol/muc#user}status"
+            , EventEndElement "{http://jabber.org/protocol/muc#user}x"
+            ]
+        ioWriteChan replyto stanza
+
+
 stanzaTypeString :: StanzaWrap a -> String
 stanzaTypeString stanza = concat . take 1 . words $ show (stanzaType stanza)
 
@@ -1382,12 +1418,13 @@ lookupService me mucs to = case Text.toLower to of
     _ -> NotMe
 
 applyStanza :: Server PeerAddress ConnectionData releaseKey Event
+                     -> TVar (Map.Map ClientAddress (Map.Map (Text,Text) (TChan Stanza,JoinedRoom ClientAddress)))
                      -> TMVar ()
                      -> XMPPServerParameters
                      -> StanzaWrap (LockedChan Event)
                      -> IO ()
 
-applyStanza sv quitVar xmpp stanza = case stanzaOrigin stanza of
+applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of
     ClientOrigin k replyto ->
         case stanzaType stanza of
             RequestResource clientsNameForMe wanted -> do
@@ -1446,7 +1483,12 @@ applyStanza sv quitVar xmpp stanza = case stanzaOrigin stanza of
                                     [ ("by", [ContentText roomjid]) ]
                                 sendReply quitVar (Error JidMalformed (head reply)) reply replyto
                             Just nick -> do
-                                mucJoinRoom muc room nick k stanza
+                                jid <- xmppTellClientHisName xmpp k
+                                r <- mucJoinRoom muc jid nick room k -- stanza
+                                atomically $ do
+                                    jrs <- readTVar joined_rooms
+                                    let m = Map.findWithDefault Map.empty k jrs
+                                    writeTVar joined_rooms $ Map.insert k (Map.insert (room,mucname) (replyto,r) m) jrs
                    | otherwise -> do
                         -- Handle presence stanza that is not a chatroom join.
                         xmppInformClientPresence xmpp k stanza