From 971b23b40e2b519107923dcb6976145e2b83b9cf Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Tue, 13 Nov 2018 16:53:24 -0500
Subject: MUC: Two-step nominate/comit chat transactions.

---
 Presence/MUC.hs | 61 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 61 insertions(+)
 create mode 100644 Presence/MUC.hs

(limited to 'Presence/MUC.hs')

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
+
+
-- 
cgit v1.2.3