MUC: Two-step nominate/comit chat transactions.

1 files changed, 104 insertions, 16 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