wip: Transactional chat.

1 files changed, 136 insertions, 0 deletions

diff --git a/Presence/Chat.hs b/Presence/Chat.hs
new file mode 100644
index 00000000..47512bf1
--- /dev/null
+++ b/Presence/Chat.hs
@@ -0,0 +1,136 @@
+module Chat where
+
+import Control.Concurrent.STM
+import Control.Monad
+import qualified Data.Map     as Map
+         ;import Data.Map     (Map)
+import Data.Text
+import Data.Word
+
+-- To join a chat room, add a 'ClientRoomLink' to 'roomDesiredLink' with
+-- 'desireStreamEvent' set to 'Nothing'.
+--
+-- To leave a chat room, remove the 'ClientRoomLink' from the map.
+
+data Room k = Room
+    { roomDesiredTransaction :: TVar (Map k (TVar (Maybe ChatTransaction)))
+    , roomChan               :: TChan ChatTransaction
+    , roomFutureSeqNo        :: TVar Word64
+    }
+
+data ChatEvent = Join | Part | Action Text | Talk Text | NickChange Text
+ deriving (Eq,Ord,Show)
+
+data Membership = Outside | Inside
+ deriving (Eq,Ord,Read,Show)
+
+data MembershipEffect = MembershipEffect { fromMembership :: Membership
+                                         , toMembership   :: Membership
+                                         }
+                      | NoMembershipEffect
+                      | InvalidMembershipEffect
+ deriving (Eq,Ord,Read,Show)
+
+instance Monoid MembershipEffect where
+    mempty = NoMembershipEffect
+    MembershipEffect a x `mappend` MembershipEffect y b
+        | x == y    = MembershipEffect a b
+        | otherwise = InvalidMembershipEffect
+    NoMembershipEffect `mappend` b                  = b
+    a                  `mappend` NoMembershipEffect = a
+    _                  `mappend` _                  = InvalidMembershipEffect
+
+chatEffect :: ChatEvent -> MembershipEffect
+chatEffect Join = MembershipEffect Outside Inside
+chatEffect Part = MembershipEffect Inside  Outside
+chatEffect _    = MembershipEffect Inside  Inside
+
+membershipEffect :: [ChatEvent] -> MembershipEffect
+membershipEffect xs =  foldMap chatEffect xs
+
+
+data ChatTransaction = ChatTransaction
+    { chatSeqNo     :: Word64
+    , chatSenderJID :: Maybe Text
+    , chatSender    :: Text
+    , chatMessage   :: [ChatEvent]
+    }
+ deriving (Eq,Ord,Show)
+
+newtype RoomHandle = RH (TVar (Maybe ChatTransaction))
+
+data JoinedRoom k = JoinedRoom
+    { joinedRoom :: Room k
+    , roomHandle :: RoomHandle
+    }
+
+newRoom :: STM (Room k)
+newRoom = do
+    m <- newTVar Map.empty
+    c <- newTChan -- newBroadcastTChan
+    n <- newTVar 0
+    return Room
+        { roomDesiredTransaction = m
+        , roomChan               = c
+        , roomFutureSeqNo        = n
+        }
+
+
+--- Client interface
+
+joinRoom :: Ord k => k
+                     -> Room k
+                     -> Maybe Text
+                     -> Text
+                     -> STM (JoinedRoom 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)
+
+partRoom :: JoinedRoom k -> Maybe Text -> Text -> STM ()
+partRoom (JoinedRoom room (RH v)) jid nick = do
+    writeTVar v Nothing -- Cancel pending chat.
+    sendChat (JoinedRoom room (RH v)) jid nick [Part]
+    return ()
+
+sendChat :: JoinedRoom k -> Maybe Text -> Text -> [ChatEvent] -> STM Bool
+sendChat (JoinedRoom room (RH v)) jid nick chat = do
+    mpending <- readTVar v
+    case mpending of
+        Nothing -> do
+            no <- readTVar $ roomFutureSeqNo room
+            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)) = do
+    mpending <- readTVar v
+    final <- readTChan $ roomChan room
+    case mpending of
+        Just pending -> do
+            if pending == final
+                then do
+                    writeTVar v Nothing
+                    when (Part `elem` chatMessage final) $ do
+                        modifyTVar' (roomDesiredTransaction room)
+                            $ Map.delete k
+                    return (True,final)
+                else do
+                    no <- readTVar $ roomFutureSeqNo room
+                    writeTVar v $ Just pending { chatSeqNo = no }
+                    return (False,final)
+        Nothing -> return (False,final)
+
+-- Room implementation interface
+
+roomCommit :: Room k -> ChatTransaction -> STM ()
+roomCommit room t = do
+    modifyTVar' (roomFutureSeqNo room) succ
+    writeTChan (roomChan room) t