MUC: Two-step nominate/comit chat transactions.

6 files changed, 231 insertions, 32 deletions

diff --git a/Presence/Chat.hs b/Presence/Chat.hs
index 47512bf1..172c5242 100644
--- a/Presence/Chat.hs
+++ b/Presence/Chat.hs
@@ -1,12 +1,16 @@
+{-# LANGUAGE LambdaCase #-}
 module Chat where
 
+import Debug.Trace
 import Control.Concurrent.STM
 import Control.Monad
-import qualified Data.Map     as Map
-         ;import Data.Map     (Map)
-import Data.Text
+import qualified Data.Map as Map
+         ;import Data.Map (Map)
+import Data.Text (Text)
 import Data.Word
 
+import Util (stripResource)
+
 -- To join a chat room, add a 'ClientRoomLink' to 'roomDesiredLink' with
 -- 'desireStreamEvent' set to 'Nothing'.
 --
@@ -16,9 +20,20 @@ data Room k = Room
     { roomDesiredTransaction :: TVar (Map k (TVar (Maybe ChatTransaction)))
     , roomChan               :: TChan ChatTransaction
     , roomFutureSeqNo        :: TVar Word64
+    , roomMembers            :: TVar (Map Text{-nick-} (PerMember k))
+    , roomAffiliations       :: TVar (Map Text{-jid-} Affiliation)
+    , roomReservations       :: TVar (Map Text{-nick-} Text{-jid-})
+    }
+
+newtype PerMember k = PerMember
+    { memberKey :: k
+    }
+
+newtype Affiliation = Affiliation
+    { reservedNick :: Text
     }
 
-data ChatEvent = Join | Part | Action Text | Talk Text | NickChange Text
+data ChatEvent = Join | Part | Action Text | Talk Text -- | NickChange Text
  deriving (Eq,Ord,Show)
 
 data Membership = Outside | Inside
@@ -62,6 +77,7 @@ newtype RoomHandle = RH (TVar (Maybe ChatTransaction))
 data JoinedRoom k = JoinedRoom
     { joinedRoom :: Room k
     , roomHandle :: RoomHandle
+    , roomTransactions :: TChan ChatTransaction
     }
 
 newRoom :: STM (Room k)
@@ -69,10 +85,16 @@ newRoom = do
     m <- newTVar Map.empty
     c <- newTChan -- newBroadcastTChan
     n <- newTVar 0
+    cs <- newTVar Map.empty
+    as <- newTVar Map.empty
+    rs <- newTVar Map.empty
     return Room
         { roomDesiredTransaction = m
         , roomChan               = c
         , roomFutureSeqNo        = n
+        , roomMembers            = cs
+        , roomAffiliations       = as
+        , roomReservations       = rs
         }
 
 
@@ -86,18 +108,18 @@ joinRoom :: Ord k => k
 joinRoom k room jid nick = do
     no <- readTVar $ roomFutureSeqNo room
     v <- newTVar (Just $ ChatTransaction no jid nick [Join])
-    modifyTVar' (roomDesiredTransaction room)
-        $ Map.insert k v
-    return $ JoinedRoom room (RH v)
+    modifyTVar' (roomDesiredTransaction room) $ Map.insert k v
+    c <- dupTChan (roomChan room)
+    return $ JoinedRoom room (RH v) c
 
 partRoom :: JoinedRoom k -> Maybe Text -> Text -> STM ()
-partRoom (JoinedRoom room (RH v)) jid nick = do
+partRoom (JoinedRoom room (RH v) c) jid nick = do
     writeTVar v Nothing -- Cancel pending chat.
-    sendChat (JoinedRoom room (RH v)) jid nick [Part]
+    sendChat (JoinedRoom room (RH v) c) jid nick [Part]
     return ()
 
 sendChat :: JoinedRoom k -> Maybe Text -> Text -> [ChatEvent] -> STM Bool
-sendChat (JoinedRoom room (RH v)) jid nick chat = do
+sendChat (JoinedRoom room (RH v) _) jid nick chat = do
     mpending <- readTVar v
     case mpending of
         Nothing -> do
@@ -110,9 +132,9 @@ sendChat (JoinedRoom room (RH v)) jid nick chat = do
 -- | 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)) = do
+readRoom k (JoinedRoom room (RH v) c) = do
     mpending <- readTVar v
-    final <- readTChan $ roomChan room
+    final <- readTChan c
     case mpending of
         Just pending -> do
             if pending == final
@@ -128,9 +150,75 @@ readRoom k (JoinedRoom room (RH v)) = do
                     return (False,final)
         Nothing -> return (False,final)
 
+roomOccupants :: Room k-> STM [(Text{-nick-},Maybe Text{-friendly name-})]
+roomOccupants room = do
+    ns <- Map.keys <$> readTVar (roomMembers room)
+    return $ map (\n -> (n,Just n)) ns
+
+roomReservedNick :: Room k -> Text{-JID-} -> STM (Maybe Text{-nick-})
+roomReservedNick room jid = do
+    a <- Map.lookup jid <$> readTVar (roomAffiliations room)
+    return $ reservedNick <$> a
+
+roomFriendlyName :: Room k -> STM (Maybe Text)
+roomFriendlyName _ = return Nothing
+
 -- Room implementation interface
 
-roomCommit :: Room k -> ChatTransaction -> STM ()
-roomCommit room t = do
-    modifyTVar' (roomFutureSeqNo room) succ
-    writeTChan (roomChan room) t
+data Validation = Malformed | Requires Membership | Denied | Valid Membership Membership
+ deriving (Eq,Ord,Show,Read)
+
+validateTransaction :: Ord k => Room k -> k -> ChatTransaction -> STM Validation
+validateTransaction room k t@(ChatTransaction no mjid nick xs)
+    | null xs   = return Malformed
+    | otherwise = case membershipEffect xs of
+        MembershipEffect Inside what ->
+            Map.lookup nick <$> readTVar (roomMembers room) >>= \case
+                Nothing                   -> return (Requires Inside)
+                Just p | memberKey p /= k -> return Denied
+                _                         -> return (Valid Inside what)
+        MembershipEffect Outside what -> do
+            Map.lookup k <$> return Map.empty {- readTVar (roomDesiredTransaction room) -} >>= \case
+                Nothing -> Map.lookup nick <$> readTVar (roomMembers room) >>= \case
+                            Nothing -> Map.lookup nick <$> readTVar (roomReservations room) >>= \case
+                                        Just rjid | Just jid <- mjid
+                                                  , stripResource jid == rjid
+                                                 -> return (Valid Outside what)
+                                        Just _   -> return Denied
+                                        Nothing  -> return (Valid Outside what)
+                            Just _  -> return Denied -- Nick already taken.
+                Just _ -> return (Requires Outside)
+        _ -> return Malformed
+
+
+roomCommit :: Ord k => Room k -> k -> ChatTransaction -> STM ()
+roomCommit room k t = do
+    let fin = do
+            trace "increment seqno!" $ return ()
+            modifyTVar' (roomFutureSeqNo room) succ
+            writeTChan (roomChan room) t
+    v <- validateTransaction room k t
+    trace ("roomCommit " ++ show v) $ return ()
+    case v of
+        Valid Outside Inside -> do
+            modifyTVar' (roomMembers room) $ Map.insert (chatSender t) PerMember
+                { memberKey = k
+                }
+            fin
+        Valid Inside Outside -> do
+            modifyTVar' (roomMembers room) $ Map.delete (chatSender t)
+            fin
+        Valid _ _ -> fin
+        _ -> return ()
+
+roomPending :: Ord k => Room k -> STM (Map k ChatTransaction)
+roomPending room = do
+    no <- readTVar $ roomFutureSeqNo room
+    m <- Map.mapMaybe (>>= \t -> do guard (chatSeqNo t == no)
+                                    return t)
+          <$> do readTVar (roomDesiredTransaction room)
+                    >>= mapM readTVar
+    fmap (Map.mapMaybe id)
+        $ sequence $ Map.mapWithKey (\k t -> validateTransaction room k t >>= \case
+                        Valid _ _ -> return (Just t)
+                        _         -> return Nothing) m
diff --git a/Presence/MUC.hs b/Presence/MUC.hs
new file mode 100644
index 00000000..76c53391
--- /dev/null
+++ b/Presence/MUC.hs
@@ -0,0 +1,61 @@
+module MUC where
+
+import Control.Monad
+import Control.Concurrent.STM
+
+import qualified Data.Map.Strict as Map
+         ;import Data.Map.Strict (Map)
+
+import Chat
+import ConnectionKey
+import Data.Text (Text)
+
+data MUC = MUC
+    { mucRooms :: TVar (Map Text (Room ClientAddress))
+    , mucChan  :: TChan MUCEvent
+    }
+
+data MUCEvent = MUCCreate Text{-room-} Text{-JID-} Text{-nick-} (Room ClientAddress)
+
+
+newMUC :: STM MUC
+newMUC = MUC <$> newTVar Map.empty <*> newBroadcastTChan
+
+mucRoomList :: MUC -> IO [(Text{-room-},Maybe Text{-friendly room name-})]
+mucRoomList muc = atomically $ do
+    rs <- Map.toList <$> readTVar (mucRooms muc)
+    forM rs $ \(rkey,r) -> do
+        fn <- roomFriendlyName r
+        return (rkey,fn)
+
+mucRoomOccupants :: MUC -> Text{-room-} -> IO [(Text{-nick-},Maybe Text{-friendly name-})]
+mucRoomOccupants muc rkey = atomically $ do
+    mr <- Map.lookup rkey <$> readTVar (mucRooms muc)
+    case mr of
+        Nothing -> return []
+        Just r  -> roomOccupants r
+
+mucReservedNick :: MUC -> Text{-room-} -> IO (Maybe (Text{-JID-} -> IO (Maybe Text)))
+mucReservedNick muc rkey = atomically $ do
+    mr <- Map.lookup rkey <$> readTVar (mucRooms muc)
+    case mr of
+        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
+    mr <- Map.lookup rkey <$> readTVar (mucRooms muc)
+    case mr of
+        Nothing -> do
+            -- create room.
+            r <- newRoom
+            v <- joinRoom k r (Just jid) nick
+            modifyTVar' (mucRooms muc) $ Map.insert rkey r
+            writeTChan (mucChan muc) $ MUCCreate rkey jid nick r
+            return v
+        Just r  -> do
+            -- join room.
+            v <- joinRoom k r (Just jid) nick
+            return v
+
+
diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 0a73aced..f8a18388 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -144,10 +144,12 @@ nameForClient state k = do
             "."     -> textHostName
             profile -> return profile
 
-presenceHooks :: PresenceState stat -> Int -> Maybe SockAddr -- ^ client-to-server bind address
+presenceHooks :: PresenceState stat -> Map Text MUC
+                                      -> Int
+                                      -> Maybe SockAddr -- ^ client-to-server bind address
                                       -> Maybe SockAddr -- ^ server-to-server bind address
                                       -> XMPPServerParameters
-presenceHooks state verbosity mclient mpeer = XMPPServerParameters
+presenceHooks state chats verbosity mclient mpeer = XMPPServerParameters
     { xmppChooseResourceName        = chooseResourceName state
     , xmppTellClientHisName         = tellClientHisName state
     , xmppTellMyNameToClient        = nameForClient state
@@ -169,7 +171,7 @@ presenceHooks state verbosity mclient mpeer = XMPPServerParameters
     , xmppClientInformSubscription  = clientInformSubscription state
     , xmppPeerInformSubscription    = peerInformSubscription state
     , xmppVerbosity                 = return verbosity
-    , xmppGroupChat                 = Map.singleton "chat" MUC
+    , xmppGroupChat                 = chats {- Map.singleton "chat" chat
         { mucRoomList      = return [("testroom",Just "testroom")]
         , mucRoomOccupants = \case
             "testroom" -> return [("fakeperson",Nothing)]
@@ -183,7 +185,7 @@ presenceHooks state verbosity mclient mpeer = XMPPServerParameters
                             ++ " with nick: " ++ Text.unpack nick
             -- TODO: broadcast presence to all participants.
             -- See 7.2.3 of XEP-0045
-        }
+        -}
     , xmppClientBind                = mclient
     , xmppPeerBind                  = mpeer
     }
diff --git a/Presence/Stanza/Build.hs b/Presence/Stanza/Build.hs
index 5c4d371a..e02684f5 100644
--- a/Presence/Stanza/Build.hs
+++ b/Presence/Stanza/Build.hs
@@ -48,7 +48,10 @@ makeInformSubscription namespace from to approved =
         , EventEndElement (mkname namespace "presence")]
 
 makePresenceStanza :: Text -> Maybe Text -> JabberShow -> IO Stanza
-makePresenceStanza namespace mjid pstat = do
+makePresenceStanza ns mjid pstat = makePresenceStanzaEx ns mjid pstat []
+
+makePresenceStanzaEx :: Text -> Maybe Text -> JabberShow -> [XML.Event]-> IO Stanza
+makePresenceStanzaEx namespace mjid pstat es = do
     stanzaFromList PresenceStatus { presenceShow = pstat
                                   , presencePriority = Nothing
                                   , presenceStatus = []
@@ -56,7 +59,7 @@ makePresenceStanza namespace mjid pstat = do
                                   }
       $ [ EventBeginElement (mkname namespace "presence")
             (setFrom $ typ pstat) ]
-        ++ (shw pstat >>= jabberShow) ++
+        ++ (shw pstat >>= jabberShow) ++ es ++
         [ EventEndElement (mkname namespace "presence")]
  where
     setFrom = maybe id
diff --git a/Presence/Util.hs b/Presence/Util.hs
index ef98d415..e19b35fd 100644
--- a/Presence/Util.hs
+++ b/Presence/Util.hs
@@ -14,6 +14,9 @@ import Network.Address (setPort)
 type UserName = Text
 type ResourceName = Text
 
+stripResource :: Text -> Text
+stripResource jid = let (n,h,_) = splitJID jid
+                    in unsplitJID (n,h,Nothing)
 
 unsplitJID :: (Maybe UserName,Text,Maybe ResourceName) -> Text
 unsplitJID (n,h,r) = username <> h <> resource
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