group chat invite accepted message.

1 files changed, 107 insertions, 0 deletions

diff --git a/ToxChat.hs b/ToxChat.hs
new file mode 100644
index 00000000..fba5d33b
--- /dev/null
+++ b/ToxChat.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+module ToxChat
+    ( module Chat
+    , module ToxChat
+    ) where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Char
+import Data.Dependent.Sum
+import Data.Function
+import qualified Data.Map     as Map
+         ;import Data.Map     (Map)
+import Data.Maybe
+import qualified Data.Text    as T
+         ;import Data.Text    (Text)
+import Debug.Trace
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+
+import Chat
+import Data.Tox.Msg
+import DebugTag
+import DPut
+import MUC
+import Network.Tox.AggregateSession
+
+forkUntilSignaled :: String -> STM (IO ()) -> IO (IO ())
+forkUntilSignaled lbl action = do
+    quitSignal <- newTVarIO False
+    t <- forkIO $ do
+        fix $ \loop -> join $ atomically
+            $ orElse (do readTVar quitSignal >>= check
+                         return $ return ())
+                     (fmap (>> loop) $ action)
+    labelThread t lbl
+    return $ atomically (writeTVar quitSignal True)
+
+data RoomData k = RoomData
+    { room           :: Maybe (Room k)
+    , pendingInvites :: [(AggregateSession,Int,Maybe Text,Invite)]
+    }
+
+chatevents :: (Ord conkey, Show conkey) => TVar (Map Text (RoomData conkey)) -> STM (IO ())
+chatevents rsvar = do
+    rs <- readTVar rsvar
+    if Map.null rs
+      then retry
+      else do
+        ios <- flip Map.traverseWithKey rs $ \rkey r -> do
+            ps <- maybe (return mempty) roomPending $ room r
+            trace ("roomPending " ++ show ps) $ return ()
+            case Map.toList ps of
+                (k,t):ts -> do
+                    roomCommit (fromJust $ room r) k t
+                    modifyTVar' rsvar
+                        $ Map.adjust (\d -> d { pendingInvites = take 1 (pendingInvites d)})
+                                     rkey
+                    return $ do
+                        dput XJabber $ "toxchat-committed " ++ show (rkey,length ts,k,t)
+                        case membershipEffect $ chatMessage t of
+                            MembershipEffect Outside Inside -> do
+                                forM_ (pendingInvites r) $ \(c,i,jid,inv) -> do
+                                    -- TODO b <- checkCompatible me them c
+                                    dput XJabber $ "Replying to invite " ++ show inv
+                                    dispatchMessage c (Just i)
+                                        $ Pkt INVITE_GROUPCHAT ==> inv { invite = AcceptedInvite }
+                            _ -> return ()
+                _ -> retry
+        return $ foldl1 (>>) ios
+
+data InviteCache m = InviteCache
+    { rememberInvite :: AggregateSession -> Int {- session ID -} -> Maybe Text {- origin -} -> Invite -> m ()
+    , lookupInvite   :: Text {- chatroom JID -} -> m (Maybe Invite)
+    }
+
+forkToxChat :: MUC -> IO (IO (), InviteCache IO)
+forkToxChat muc = do
+    (chan, rs) <- atomically $ do
+        c <- dupTChan (mucChan muc)
+        rs <- newTVar Map.empty -- TODO: This seems to redundantly duplicate MUC{mucRooms}.
+        return (c,rs)
+    quit <- forkUntilSignaled "toxchat" $ orElse (chatevents rs) $ do
+        e <- readTChan chan
+        case e of
+            MUCCreate room jid nick r -> modifyTVar' rs $
+                Map.alter (\d -> Just $ RoomData (Just r) (maybe [] pendingInvites d))
+                          (T.toLower room)
+        return $ case e of
+            MUCCreate room jid nick _ ->
+                dput XJabber $ unwords $ map T.unpack
+                    [ "MUCCreate", room, jid, nick ]
+    return $ (,) quit InviteCache
+        { rememberInvite = \c i jid inv -> do
+            dput XJabber $ "remember invite " ++ show (T.pack $ show $ inviteChatID inv, i, jid )
+            atomically $ do
+              modifyTVar' rs $ Map.alter (\d -> Just $ RoomData (room =<< (d:: Maybe (RoomData _)))
+                                                                ( ((c,i,jid,inv) :) $ maybe [] pendingInvites d))
+                                       (T.pack $ map toLower $ show $ inviteChatID inv)
+        , lookupInvite = \_ -> return Nothing
+        }