summaryrefslogtreecommitdiff
path: root/Presence/LocalChat.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/LocalChat.hs')
-rw-r--r--Presence/LocalChat.hs71
1 files changed, 0 insertions, 71 deletions
diff --git a/Presence/LocalChat.hs b/Presence/LocalChat.hs
deleted file mode 100644
index eab54a03..00000000
--- a/Presence/LocalChat.hs
+++ /dev/null
@@ -1,71 +0,0 @@
1{-# LANGUAGE CPP #-}
2module LocalChat
3 ( module Chat
4 , module LocalChat
5 ) where
6
7import Debug.Trace
8import Control.Concurrent.STM
9import Control.Monad
10import Data.Function
11import Data.List
12import qualified Data.Map as Map
13 ;import Data.Map (Map)
14import qualified Data.Text as T
15 ;import Data.Text (Text)
16
17#ifdef THREAD_DEBUG
18import Control.Concurrent.Lifted.Instrument
19#else
20import Control.Concurrent.Lifted
21import GHC.Conc (labelThread)
22#endif
23
24import DPut
25import DebugTag
26import Chat
27import MUC
28
29forkUntilSignaled :: String -> STM (IO ()) -> IO (IO ())
30forkUntilSignaled lbl action = do
31 quitSignal <- newTVarIO False
32 t <- forkIO $ do
33 fix $ \loop -> join $ atomically
34 $ orElse (do readTVar quitSignal >>= check
35 return $ return ())
36 (fmap (>> loop) $ action)
37 labelThread t lbl
38 return $ atomically (writeTVar quitSignal True)
39
40
41chatevents rsvar = do
42 rs <- readTVar rsvar
43 if Map.null rs
44 then retry
45 else do
46 ios <- forM rs $ \r -> do
47 ps <- roomPending r
48 trace ("roomPending " ++ show ps) $ return ()
49 case Map.toList ps of
50 (k,t):ts -> do
51 roomCommit r k t
52 return $ do
53 dput XJabber $ "committed " ++ show (length ts,k,t)
54 _ -> retry
55 return $ foldl1 (>>) ios
56
57forkLocalChat :: MUC -> IO (IO ())
58forkLocalChat muc = do
59 (chan, rs) <- atomically $ do
60 c <- dupTChan (mucChan muc)
61 rs <- newTVar Map.empty
62 return (c,rs)
63 forkUntilSignaled "localchat" $ orElse (chatevents rs) $ do
64 e <- readTChan chan
65 case e of
66 MUCCreate room jid nick r -> modifyTVar' rs $ Map.insert room r
67 return $ case e of
68 MUCCreate room jid nick _ ->
69 dput XJabber $ unwords $ map T.unpack
70 [ "MUCCreate", room, jid, nick ]
71