MUC: It works.

7 files changed, 198 insertions, 33 deletions

diff --git a/Presence/Chat.hs b/Presence/Chat.hs
index 172c5242..b7343b5a 100644
--- a/Presence/Chat.hs
+++ b/Presence/Chat.hs
@@ -76,6 +76,7 @@ newtype RoomHandle = RH (TVar (Maybe ChatTransaction))
 
 data JoinedRoom k = JoinedRoom
     { joinedRoom :: Room k
+    , joinedNick :: Text
     , roomHandle :: RoomHandle
     , roomTransactions :: TChan ChatTransaction
     }
@@ -110,29 +111,28 @@ joinRoom k room jid nick = do
     v <- newTVar (Just $ ChatTransaction no jid nick [Join])
     modifyTVar' (roomDesiredTransaction room) $ Map.insert k v
     c <- dupTChan (roomChan room)
-    return $ JoinedRoom room (RH v) c
+    return $ JoinedRoom room nick (RH v) c
 
-partRoom :: JoinedRoom k -> Maybe Text -> Text -> STM ()
-partRoom (JoinedRoom room (RH v) c) jid nick = do
+partRoom :: JoinedRoom k -> Maybe Text -> STM ()
+partRoom (JoinedRoom room nick (RH v) c) jid = do
     writeTVar v Nothing -- Cancel pending chat.
-    sendChat (JoinedRoom room (RH v) c) jid nick [Part]
+    sendChat (JoinedRoom room nick (RH v) c) jid [Part]
     return ()
 
-sendChat :: JoinedRoom k -> Maybe Text -> Text -> [ChatEvent] -> STM Bool
-sendChat (JoinedRoom room (RH v) _) jid nick chat = do
+sendChat :: JoinedRoom k -> Maybe Text -> [ChatEvent] -> STM Bool
+sendChat (JoinedRoom room nick (RH v) _) jid chat = do
     mpending <- readTVar v
+    no <- readTVar $ roomFutureSeqNo room
     case mpending of
-        Nothing -> do
-            no <- readTVar $ roomFutureSeqNo room
+        Just (ChatTransaction no' _ _ _) | no' >= no -> return False
+        _ -> do
             writeTVar v (Just $ ChatTransaction no jid nick chat)
             return True
-        Just pending -> do
-            return False
 
 -- | Blocks until a transaction occurs.  Optionally, a failed transaction will
 -- be automatically renewed.
 readRoom :: Ord k => k -> JoinedRoom k -> STM (Bool, ChatTransaction)
-readRoom k (JoinedRoom room (RH v) c) = do
+readRoom k (JoinedRoom room _ (RH v) c) = do
     mpending <- readTVar v
     final <- readTChan c
     case mpending of
@@ -198,7 +198,7 @@ roomCommit room k t = do
             modifyTVar' (roomFutureSeqNo room) succ
             writeTChan (roomChan room) t
     v <- validateTransaction room k t
-    trace ("roomCommit " ++ show v) $ return ()
+    trace ("roomCommit " ++ show v ++ " " ++ show t) $ return ()
     case v of
         Valid Outside Inside -> do
             modifyTVar' (roomMembers room) $ Map.insert (chatSender t) PerMember
@@ -209,7 +209,7 @@ roomCommit room k t = do
             modifyTVar' (roomMembers room) $ Map.delete (chatSender t)
             fin
         Valid _ _ -> fin
-        _ -> return ()
+        bad -> trace ("validateTransaction: " ++ show bad) $ return ()
 
 roomPending :: Ord k => Room k -> STM (Map k ChatTransaction)
 roomPending room = do
diff --git a/Presence/LocalChat.hs b/Presence/LocalChat.hs
index 39195fc9..eab54a03 100644
--- a/Presence/LocalChat.hs
+++ b/Presence/LocalChat.hs
@@ -47,10 +47,10 @@ chatevents rsvar = do
             ps <- roomPending r
             trace ("roomPending " ++ show ps) $ return ()
             case Map.toList ps of
-                (k,t):_ -> do
+                (k,t):ts -> do
                     roomCommit r k t
                     return $ do
-                        dput XJabber $ "fuck " ++ show (k,t)
+                        dput XJabber $ "committed " ++ show (length ts,k,t)
                 _ -> retry
         return $ foldl1 (>>) ios
 
diff --git a/Presence/MUC.hs b/Presence/MUC.hs
index 76c53391..639e834b 100644
--- a/Presence/MUC.hs
+++ b/Presence/MUC.hs
@@ -42,8 +42,8 @@ mucReservedNick muc rkey = atomically $ do
         Nothing -> return Nothing
         Just r  -> return $ Just $ \jid -> atomically $ roomReservedNick r jid
 
-mucJoinRoom :: MUC -> Text{-JID-} -> Text{-nick-} -> Text{-room-} -> ClientAddress -> IO (JoinedRoom ClientAddress)
-mucJoinRoom muc jid nick rkey k = atomically $ do
+mucJoinRoom :: MUC -> Text{-JID-} -> Text{-nick-} -> Text{-room-} -> ClientAddress -> STM (JoinedRoom ClientAddress)
+mucJoinRoom muc jid nick rkey k = do
     mr <- Map.lookup rkey <$> readTVar (mucRooms muc)
     case mr of
         Nothing -> do
diff --git a/Presence/Stanza/Build.hs b/Presence/Stanza/Build.hs
index e02684f5..16552428 100644
--- a/Presence/Stanza/Build.hs
+++ b/Presence/Stanza/Build.hs
@@ -19,24 +19,34 @@ import LockedChan
 import Stanza.Types
 
 makeMessage :: Text -> Text -> Text -> Text -> IO Stanza
-makeMessage namespace from to bod =
+makeMessage namespace from to bod = makeMessageEx namespace from to NormalMsg bod
+
+makeMessageEx :: Text -> Text -> Text -> MessageType -> Text -> IO Stanza
+makeMessageEx namespace from to msgtyp bod =
     stanzaFromList typ
      $ [ EventBeginElement (mkname namespace "message")
-            [ attr "from" from
-            , attr "to" to
-            ]
+            $ addMessageType msgtyp
+                [ attr "from" from
+                , attr "to" to
+                ]
        , EventBeginElement (mkname namespace "body") []
        , EventContent (ContentText bod)
        , EventEndElement (mkname namespace "body")
        , EventEndElement (mkname namespace "message") ]
  where
-    typ = Message { msgThread = Nothing
+    typ = Message { msgThread  = Nothing
                   , msgLangMap = [("", lsm)]
+                  , msgType    = msgtyp
                   }
     lsm = LangSpecificMessage
-            { msgBody = Just bod
+            { msgBody    = Just bod
             , msgSubject = Nothing }
 
+addMessageType ChatMsg      attrs = ("type",[ContentText "chat"]) : attrs
+addMessageType GroupChatMsg attrs = ("type",[ContentText "groupchat"]) : attrs
+addMessageType HeadlineMsg  attrs = ("type",[ContentText "headline"]) : attrs
+addMessageType _            attrs = attrs
+
 makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza
 makeInformSubscription namespace from to approved =
     stanzaFromList (PresenceInformSubscription approved)
diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs
index b025f418..58bf7c51 100644
--- a/Presence/Stanza/Parse.hs
+++ b/Presence/Stanza/Parse.hs
@@ -227,9 +227,16 @@ parseMessage ns stanza = do
                                   , Map.empty )
     return Message {
         msgLangMap = Map.toList langmap,
-        msgThread = if msgThreadContent th/="" then Just th else Nothing
+        msgThread  = if msgThreadContent th/="" then Just th else Nothing,
+        msgType    = parseMessageType $ lookupAttrib "type" (tagAttrs stanza)
     }
 
+parseMessageType :: Maybe Text -> MessageType
+parseMessageType (Just "chat")      = ChatMsg
+parseMessageType (Just "groupchat") = GroupChatMsg
+parseMessageType (Just "headline")  = HeadlineMsg
+parseMessageType _                  = NormalMsg
+
 findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError)
 findErrorTag ns = do
     x <- nextElement
diff --git a/Presence/Stanza/Types.hs b/Presence/Stanza/Types.hs
index 6c5b8867..7275c8ab 100644
--- a/Presence/Stanza/Types.hs
+++ b/Presence/Stanza/Types.hs
@@ -70,6 +70,7 @@ data StanzaType
     | PresenceRequestSubscription Bool
     | Message { msgThread :: Maybe MessageThread
               , msgLangMap :: [(Lang,LangSpecificMessage)]
+              , msgType :: MessageType
               }
     | NotifyClientVersion { versionName :: Text
                           , versionVersion :: Text }
@@ -77,6 +78,60 @@ data StanzaType
     | InternalCacheId Text
  deriving (Show,Eq)
 
+data MessageType
+    = NormalMsg  -- ^ The message is a standalone message that is sent outside
+                 -- the context of a one-to-one conversation or groupchat, and
+                 -- to which it is expected that the recipient will reply.
+                 -- Typically a receiving client will present a message of type
+                 -- "normal" in an interface that enables the recipient to
+                 -- reply, but without a conversation history. The default
+                 -- value of the 'type' attribute is "normal".
+
+    | ChatMsg -- ^ The message is sent in the context of a one-to-one chat
+              -- session. Typically an interactive client will present a
+              -- message of type "chat" in an interface that enables one-to-one
+              -- chat between the two parties, including an appropriate
+              -- conversation history. Detailed recommendations regarding
+              -- one-to-one chat sessions are provided under Section 5.1.
+
+    | GroupChatMsg -- ^ The message is sent in the context of a multi-user chat
+                   -- environment (similar to that of [IRC]). Typically a
+                   -- receiving client will present a message of type
+                   -- "groupchat" in an interface that enables many-to-many
+                   -- chat between the parties, including a roster of parties
+                   -- in the chatroom and an appropriate conversation history.
+                   -- For detailed information about XMPP-based groupchat,
+                   -- refer to [XEP‑0045].
+
+    | HeadlineMsg -- ^ The message provides an alert, a notification, or other
+                  -- transient information to which no reply is expected (e.g.,
+                  -- news headlines, sports updates, near-real-time market
+                  -- data, or syndicated content). Because no reply to the
+                  -- message is expected, typically a receiving client will
+                  -- present a message of type "headline" in an interface that
+                  -- appropriately differentiates the message from standalone
+                  -- messages, chat messages, and groupchat messages (e.g., by
+                  -- not providing the recipient with the ability to reply). If
+                  -- the 'to' address is the bare JID, the receiving server
+                  -- SHOULD deliver the message to all of the recipient's
+                  -- available resources with non-negative presence priority
+                  -- and MUST deliver the message to at least one of those
+                  -- resources; if the 'to' address is a full JID and there is
+                  -- a matching resource, the server MUST deliver the message
+                  -- to that resource; otherwise the server MUST either
+                  -- silently ignore the message or return an error (see
+                  -- Section 8).
+
+    -- | ErrorMsg -- The message is generated by an entity that experiences an
+    -- error when processing a message received from another entity (for
+    -- details regarding stanza error syntax, refer to [XMPP‑CORE]). A client
+    -- that receives a message of type "error" SHOULD present an appropriate
+    -- interface informing the original sender regarding the nature of the
+    -- error.
+
+ deriving (Show,Read,Ord,Eq,Enum)
+
+
 data RosterEventType
     = RequestedSubscription
     | NewBuddy -- preceded by PresenceInformSubscription True
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 ()