Forgot to check this in.

1 files changed, 71 insertions, 0 deletions

diff --git a/Presence/LocalChat.hs b/Presence/LocalChat.hs
new file mode 100644
index 00000000..39195fc9
--- /dev/null
+++ b/Presence/LocalChat.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE CPP #-}
+module LocalChat
+    ( module Chat
+    , module LocalChat
+    ) where
+
+import Debug.Trace
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Function
+import Data.List
+import qualified Data.Map as Map
+         ;import Data.Map (Map)
+import qualified Data.Text as T
+         ;import Data.Text (Text)
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+
+import DPut
+import DebugTag
+import Chat
+import MUC
+
+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)
+
+
+chatevents rsvar = do
+    rs <- readTVar rsvar
+    if Map.null rs
+      then retry
+      else do
+        ios <- forM rs $ \r -> do
+            ps <- roomPending r
+            trace ("roomPending " ++ show ps) $ return ()
+            case Map.toList ps of
+                (k,t):_ -> do
+                    roomCommit r k t
+                    return $ do
+                        dput XJabber $ "fuck " ++ show (k,t)
+                _ -> retry
+        return $ foldl1 (>>) ios
+
+forkLocalChat :: MUC -> IO (IO ())
+forkLocalChat muc = do
+    (chan, rs) <- atomically $ do
+        c <- dupTChan (mucChan muc)
+        rs <- newTVar Map.empty
+        return (c,rs)
+    forkUntilSignaled "localchat" $ orElse (chatevents rs) $ do
+        e <- readTChan chan
+        case e of
+            MUCCreate room jid nick r -> modifyTVar' rs $ Map.insert room r
+        return $ case e of
+            MUCCreate room jid nick _ ->
+                dput XJabber $ unwords $ map T.unpack
+                    [ "MUCCreate", room, jid, nick ]
+