summaryrefslogtreecommitdiff
path: root/ToxChat.hs
diff options
context:
space:
mode:
authorJames Crayne <jim.crayne@gmail.com>2019-09-28 13:43:29 -0400
committerJoe Crayne <joe@jerkface.net>2020-01-01 19:27:53 -0500
commit11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch)
tree5716463275c2d3e902889db619908ded2a73971c /ToxChat.hs
parentadd2c76bced51fde5e9917e7449ef52be70faf87 (diff)
Factor out some new libraries
word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search
Diffstat (limited to 'ToxChat.hs')
-rw-r--r--ToxChat.hs107
1 files changed, 0 insertions, 107 deletions
diff --git a/ToxChat.hs b/ToxChat.hs
deleted file mode 100644
index fba5d33b..00000000
--- a/ToxChat.hs
+++ /dev/null
@@ -1,107 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE PartialTypeSignatures #-}
3module ToxChat
4 ( module Chat
5 , module ToxChat
6 ) where
7
8import Control.Concurrent.STM
9import Control.Monad
10import Data.Char
11import Data.Dependent.Sum
12import Data.Function
13import qualified Data.Map as Map
14 ;import Data.Map (Map)
15import Data.Maybe
16import qualified Data.Text as T
17 ;import Data.Text (Text)
18import Debug.Trace
19
20#ifdef THREAD_DEBUG
21import Control.Concurrent.Lifted.Instrument
22#else
23import Control.Concurrent.Lifted
24import GHC.Conc (labelThread)
25#endif
26
27import Chat
28import Data.Tox.Msg
29import DebugTag
30import DPut
31import MUC
32import Network.Tox.AggregateSession
33
34forkUntilSignaled :: String -> STM (IO ()) -> IO (IO ())
35forkUntilSignaled lbl action = do
36 quitSignal <- newTVarIO False
37 t <- forkIO $ do
38 fix $ \loop -> join $ atomically
39 $ orElse (do readTVar quitSignal >>= check
40 return $ return ())
41 (fmap (>> loop) $ action)
42 labelThread t lbl
43 return $ atomically (writeTVar quitSignal True)
44
45data RoomData k = RoomData
46 { room :: Maybe (Room k)
47 , pendingInvites :: [(AggregateSession,Int,Maybe Text,Invite)]
48 }
49
50chatevents :: (Ord conkey, Show conkey) => TVar (Map Text (RoomData conkey)) -> STM (IO ())
51chatevents rsvar = do
52 rs <- readTVar rsvar
53 if Map.null rs
54 then retry
55 else do
56 ios <- flip Map.traverseWithKey rs $ \rkey r -> do
57 ps <- maybe (return mempty) roomPending $ room r
58 trace ("roomPending " ++ show ps) $ return ()
59 case Map.toList ps of
60 (k,t):ts -> do
61 roomCommit (fromJust $ room r) k t
62 modifyTVar' rsvar
63 $ Map.adjust (\d -> d { pendingInvites = take 1 (pendingInvites d)})
64 rkey
65 return $ do
66 dput XJabber $ "toxchat-committed " ++ show (rkey,length ts,k,t)
67 case membershipEffect $ chatMessage t of
68 MembershipEffect Outside Inside -> do
69 forM_ (pendingInvites r) $ \(c,i,jid,inv) -> do
70 -- TODO b <- checkCompatible me them c
71 dput XJabber $ "Replying to invite " ++ show inv
72 dispatchMessage c (Just i)
73 $ Pkt INVITE_GROUPCHAT ==> inv { invite = AcceptedInvite }
74 _ -> return ()
75 _ -> retry
76 return $ foldl1 (>>) ios
77
78data InviteCache m = InviteCache
79 { rememberInvite :: AggregateSession -> Int {- session ID -} -> Maybe Text {- origin -} -> Invite -> m ()
80 , lookupInvite :: Text {- chatroom JID -} -> m (Maybe Invite)
81 }
82
83forkToxChat :: MUC -> IO (IO (), InviteCache IO)
84forkToxChat muc = do
85 (chan, rs) <- atomically $ do
86 c <- dupTChan (mucChan muc)
87 rs <- newTVar Map.empty -- TODO: This seems to redundantly duplicate MUC{mucRooms}.
88 return (c,rs)
89 quit <- forkUntilSignaled "toxchat" $ orElse (chatevents rs) $ do
90 e <- readTChan chan
91 case e of
92 MUCCreate room jid nick r -> modifyTVar' rs $
93 Map.alter (\d -> Just $ RoomData (Just r) (maybe [] pendingInvites d))
94 (T.toLower room)
95 return $ case e of
96 MUCCreate room jid nick _ ->
97 dput XJabber $ unwords $ map T.unpack
98 [ "MUCCreate", room, jid, nick ]
99 return $ (,) quit InviteCache
100 { rememberInvite = \c i jid inv -> do
101 dput XJabber $ "remember invite " ++ show (T.pack $ show $ inviteChatID inv, i, jid )
102 atomically $ do
103 modifyTVar' rs $ Map.alter (\d -> Just $ RoomData (room =<< (d:: Maybe (RoomData _)))
104 ( ((c,i,jid,inv) :) $ maybe [] pendingInvites d))
105 (T.pack $ map toLower $ show $ inviteChatID inv)
106 , lookupInvite = \_ -> return Nothing
107 }