MUC: It works.

1 files changed, 102 insertions, 9 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index e44ae37b..d26e8c03 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -1364,6 +1364,28 @@ monitor sv params xmpp = do
                                             , EventEndElement "{http://jabber.org/protocol/muc#user}x"
                                             ]
                                 ioWriteChan replyto stanza
+                            Part        -> do
+                                stanza <- makePresenceStanzaEx "jabber:client" (Just $ roomjid muckey me rkey cnick) Offline
+                                          $ [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" [] ]
+                                            ++ (do guard mine
+                                                   [ 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
+                                when mine $ atomically $ do
+                                    jrs <- readTVar joined_rooms
+                                    let m = Map.findWithDefault Map.empty k jrs
+                                        m' = Map.delete (rkey,muckey) m
+                                        jrs' = if Map.null m' then Map.delete k jrs
+                                                              else Map.insert k m' jrs
+                                    writeTVar joined_rooms jrs'
+                            Talk talk   -> do
+                                them <- xmppTellClientHisName xmpp k
+                                stanza <- makeMessageEx "jabber:client" (roomjid muckey me rkey cnick) them GroupChatMsg talk
+                                ioWriteChan replyto stanza
+                                return ()
                             _           -> return ()
       ]
     action
@@ -1409,7 +1431,7 @@ data ServiceMatch a
     | TopLevelService             -- ^ This server's exact hostname.
 
 
-lookupService :: Text -> Map.Map Text a -> Text -> (ServiceMatch a)
+lookupService :: Text {- ^ hostname -} -> Map.Map Text a {- ^ service map -} -> Text {- ^ JID -} -> (ServiceMatch a)
 lookupService me mucs to = case Text.toLower to of
     nm | nm == Text.toLower me
          -> TopLevelService
@@ -1432,7 +1454,9 @@ applyStanza :: Server PeerAddress ConnectionData releaseKey Event
                      -> StanzaWrap (LockedChan Event)
                      -> IO ()
 
-applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of
+applyStanza sv joined_rooms quitVar xmpp stanza = do
+  dput XJabber $ "applyStanza: " ++ show (stanzaType stanza)
+  case stanzaOrigin stanza of
     ClientOrigin k replyto ->
         case stanzaType stanza of
             RequestResource clientsNameForMe wanted -> do
@@ -1479,8 +1503,7 @@ applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of
             PresenceStatus {} -> do
                 let mucs = xmppGroupChat xmpp
                 me <- xmppTellMyNameToClient xmpp k
-                if | Available <- presenceShow (stanzaType stanza)
-                   , Just to <- stanzaTo stanza
+                if | Just to <- stanzaTo stanza
                    , (Just room,h,mnick) <- splitJID to
                    , let roomjid = unsplitJID ((Just room,h,Nothing))
                    , Service (Just _) mucname muc <- lookupService me mucs roomjid
@@ -1490,13 +1513,34 @@ applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of
                                 reply <- makeErrorStanza' stanza JidMalformed
                                     [ ("by", [ContentText roomjid]) ]
                                 sendReply quitVar (Error JidMalformed (head reply)) reply replyto
-                            Just nick -> do
-                                jid <- xmppTellClientHisName xmpp k
-                                r <- mucJoinRoom muc jid nick room k -- stanza
-                                atomically $ do
+                            Just nick -> case presenceShow (stanzaType stanza) of
+                                Available -> do
+                                    jid <- xmppTellClientHisName xmpp k
+                                    join $ 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
+                                    case Map.lookup (room,mucname) m of
+                                        Nothing -> do r <- mucJoinRoom muc jid nick room k -- stanza
+                                                      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
+                                                      return $ return ()
+                                        Just r -> return $ dput XJabber "MUC: already joined."
+                                Offline   -> do
+                                    jid <- xmppTellClientHisName xmpp k
+                                    atomically $ do
+                                        jrs <- readTVar joined_rooms
+                                        let m = Map.findWithDefault Map.empty k jrs
+                                        case Map.lookup (room,mucname) m of
+                                            Just (_,r) -> do
+                                                partRoom r (Just jid)  -- joinedNick r == nick
+                                                {-
+                                                let m' = Map.delete (room,mucname) m
+                                                    jrs' = if Map.null m' then Map.delete k jrs
+                                                                          else Map.insert k m' jrs
+                                                writeTVar joined_rooms jrs'
+                                                -}
+                                            _          -> return ()
                    | otherwise -> do
                         -- Handle presence stanza that is not a chatroom join.
                         xmppInformClientPresence xmpp k stanza
@@ -1541,6 +1585,24 @@ applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of
                                     let reply = makeNodeInfo (stanzaId stanza) "x-roomuser-item" (room <> "@" <> a <> "." <> me)
                                                     (stanzaFrom stanza) n
                                     return (Info, reply)
+                     (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#traffic" <- mnode
+                        -> do
+                            dput XJabber $ "TODO: 18.1.1 Allowable Traffic"
+                            reply <- makeErrorStanza' stanza FeatureNotImplemented
+                                        [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
+                            return (Error FeatureNotImplemented (head reply), reply)
+                     (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#rooms" <- mnode
+                        -> do
+                            dput XJabber $ "TODO: 6.7 Discovering Client Support for MUC"
+                            reply <- makeErrorStanza' stanza FeatureNotImplemented
+                                        [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
+                            return (Error FeatureNotImplemented (head reply), reply)
+                     (Service (Just room) a muc) | Just nodename <- mnode
+                        -> do
+                            dput XJabber $ "Uknown info node: " ++ Text.unpack nodename
+                            reply <- makeErrorStanza' stanza FeatureNotImplemented
+                                        [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
+                            return (Error FeatureNotImplemented (head reply), reply)
                      TopLevelService
                          -> case mnode of
                             Just _  -> unavail
@@ -1579,6 +1641,36 @@ applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of
                 me <- xmppTellMyNameToClient xmpp k
                 let reply = iq_service_unavailable (stanzaId stanza) me query
                 sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto
+            Message { msgType = GroupChatMsg } -> do
+                let mucs = xmppGroupChat xmpp
+                me <- xmppTellMyNameToClient xmpp k
+                if | Just to <- stanzaTo stanza
+                   , (Just room,h,mnick) <- splitJID to
+                   , let roomjid = unsplitJID ((Just room,h,Nothing))
+                   , Service (Just _) mucname muc <- lookupService me mucs roomjid
+                        -> case mnick of
+                            Nothing -> do
+                                -- Send message.
+                                jid <- xmppTellClientHisName xmpp k -- This should match stanzaFrom
+                                join $ atomically $ do
+                                    jrs <- readTVar joined_rooms
+                                    let m = Map.findWithDefault Map.empty k jrs
+                                    case Map.lookup (room,mucname) m of
+                                        Just (_,r) -> do
+                                            let RH v = roomHandle r
+                                            oldt <- readTVar v
+                                            expected <- readTVar (roomFutureSeqNo $ joinedRoom r)
+                                            b <- sendChat r (Just jid) $ do
+                                                            (_,msg) <- msgLangMap (stanzaType stanza)
+                                                            talk <- maybeToList $ msgBody msg
+                                                            [ Talk talk ]
+                                            return $ dput XJabber $ "sendChat: " ++ show (b,expected,oldt,msgLangMap (stanzaType stanza))
+                                        _          -> return $ dput XJabber $ "uknown room" ++ show (room,mucname)
+                            Just nick -> do
+                                -- Private message. TODO
+                                dput XJabber $ "TODO: Private messasge. " ++ show nick
+
+                   | otherwise -> dput XJabber $ "Failed groupchat parse. to=" ++ show (stanzaTo stanza)
             Message {} -> do
                 -- wlog $ "LANGMAP "++show (stanzaId stanza, msgLangMap (stanzaType stanza))
                 maybe (return ()) (flip cacheMessageId replyto) $ do
@@ -1615,6 +1707,7 @@ forwardStanza quitVar xmpp stanza = do
             -- let newStream = greet'' "jabber:client" "blackbird"
             -- sendReply quitVar Error newStream replyto
     case stanzaType stanza of
+        Message { msgType = GroupChatMsg } -> return () -- Group chat handled elsewhere.
         Message {} -> do
           case stanzaOrigin stanza of
             LocalPeer {} -> return ()