summaryrefslogtreecommitdiff
path: root/Presence/main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/main.hs')
-rw-r--r--Presence/main.hs35
1 files changed, 19 insertions, 16 deletions
diff --git a/Presence/main.hs b/Presence/main.hs
index b0721292..ed247bca 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -87,11 +87,14 @@ instance XMPPSession UnixSession where
87 return (JID (Just user) host rsc) 87 return (JID (Just user) host rsc)
88 closeSession _ = L.putStrLn "SESSION: close" 88 closeSession _ = L.putStrLn "SESSION: close"
89 subscribe session Nothing = do 89 subscribe session Nothing = do
90 let tmvar = greedySubscriber (presence_state session) 90 let tmvar = localSubscriber (presence_state session)
91 atomically $ subscribeToChan tmvar 91 atomically $ subscribeToChan tmvar
92 subscribe session (Just jid) = do 92 subscribe session (Just jid) = do
93 let tvar = subscriberMap (presence_state session) 93 let tvar = subscriberMap (presence_state session)
94 atomically $ subscribeToMap tvar jid 94 atomically $ subscribeToMap tvar jid
95 announcePresence session (Presence jid status) = do
96 subs <- readTVarIO $ subscriberMap (presence_state session)
97 update_presence Nothing (fmap snd subs) (Set.singleton jid) (const status)
95 98
96 99
97subscribeToChan tmvar = 100subscribeToChan tmvar =
@@ -128,14 +131,14 @@ sendPresence chan jid status =
128 131
129lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers 132lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers
130 133
131update_presence greedy subscribers state getStatus = 134update_presence locals_greedy subscribers state getStatus =
132 forM_ (Set.toList state) $ \jid -> do 135 forM_ (Set.toList state) $ \jid -> do
133 let status = getStatus jid 136 let status = getStatus jid
134 runMaybeT $ do 137 runMaybeT $ do
135 chan <- lookupT jid subscribers 138 chan <- lookupT jid subscribers
136 sendPresence chan jid status 139 sendPresence chan jid status
137 runMaybeT $ do 140 runMaybeT $ do
138 chan <- MaybeT . return $ greedy 141 chan <- MaybeT . return $ locals_greedy
139 sendPresence chan jid status 142 sendPresence chan jid status
140 putStrLn $ bshow jid <++> " " <++> bshow status 143 putStrLn $ bshow jid <++> " " <++> bshow status
141 144
@@ -146,15 +149,15 @@ data PresenceState = PresenceState
146 , currentTTY :: TVar ByteString 149 , currentTTY :: TVar ByteString
147 , activeUsers :: TVar (Set JID) 150 , activeUsers :: TVar (Set JID)
148 , subscriberMap :: TVar (Map JID (RefCount,TChan Presence)) 151 , subscriberMap :: TVar (Map JID (RefCount,TChan Presence))
149 , greedySubscriber :: TMVar (RefCount,TChan Presence) 152 , localSubscriber :: TMVar (RefCount,TChan Presence)
150 } 153 }
151 154
152newPresenceState hostname = atomically $ do 155newPresenceState hostname = atomically $ do
153 tty <- newTVar "" 156 tty <- newTVar ""
154 us <- newTVar (Set.empty) 157 us <- newTVar (Set.empty)
155 subs <- newTVar (Map.empty) 158 subs <- newTVar (Map.empty)
156 greedy <- newEmptyTMVar 159 locals_greedy <- newEmptyTMVar
157 return $ PresenceState hostname tty us subs greedy 160 return $ PresenceState hostname tty us subs locals_greedy
158 161
159track_login host state e = do 162track_login host state e = do
160#ifndef NOUTMP 163#ifndef NOUTMP
@@ -167,27 +170,27 @@ track_login host state e = do
167 then Just (jid user host tty) 170 then Just (jid user host tty)
168 else Nothing 171 else Nothing
169 new_users = Set.fromList $ mapMaybe (toJabberId host) us 172 new_users = Set.fromList $ mapMaybe (toJabberId host) us
170 (tty,known_users,subs,greedy) <- atomically $ do 173 (tty,known_users,subs,locals_greedy) <- atomically $ do
171 tty <- readTVar $ currentTTY state 174 tty <- readTVar $ currentTTY state
172 st <- flip swapTVar new_users $ activeUsers state 175 st <- flip swapTVar new_users $ activeUsers state
173 xs <- readTVar $ subscriberMap state 176 xs <- readTVar $ subscriberMap state
174 greedy <- tryReadTMVar $ greedySubscriber state 177 locals_greedy <- tryReadTMVar $ localSubscriber state
175 return (tty,st,fmap snd xs,fmap snd greedy) 178 return (tty,st,fmap snd xs,fmap snd locals_greedy)
176 let arrivals = new_users \\ known_users 179 let arrivals = new_users \\ known_users
177 departures = known_users \\ new_users 180 departures = known_users \\ new_users
178 update_presence greedy subs departures $ const Offline 181 update_presence locals_greedy subs departures $ const Offline
179 update_presence greedy subs arrivals $ matchResource tty 182 update_presence locals_greedy subs arrivals $ matchResource tty
180 183
181on_chvt state vtnum = do 184on_chvt state vtnum = do
182 let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum) 185 let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum)
183 L.putStrLn $ "VT switch: " <++> tty 186 L.putStrLn $ "VT switch: " <++> tty
184 (users,subs,greedy) <- atomically $ do 187 (users,subs,locals_greedy) <- atomically $ do
185 us <- readTVar $ activeUsers state 188 us <- readTVar $ activeUsers state
186 subs <- readTVar $ subscriberMap state 189 subs <- readTVar $ subscriberMap state
187 writeTVar (currentTTY state) tty 190 writeTVar (currentTTY state) tty
188 greedy <- tryReadTMVar $ greedySubscriber state 191 locals_greedy <- tryReadTMVar $ localSubscriber state
189 return (us,fmap snd subs,fmap snd greedy) 192 return (us,fmap snd subs,fmap snd locals_greedy)
190 update_presence greedy subs users $ matchResource tty 193 update_presence locals_greedy subs users $ matchResource tty
191 194
192data UnixConfig = UnixConfig 195data UnixConfig = UnixConfig
193 196
@@ -201,7 +204,7 @@ start host = do
201 let dologin e = track_login host tracked e 204 let dologin e = track_login host tracked e
202 dologin :: t -> IO () 205 dologin :: t -> IO ()
203 206
204 chan <- atomically $ subscribeToChan (greedySubscriber tracked) 207 chan <- atomically $ subscribeToChan (localSubscriber tracked)
205 remotes <- forkIO $ seekRemotePeers (/=host) UnixConfig chan 208 remotes <- forkIO $ seekRemotePeers (/=host) UnixConfig chan
206 209
207 installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing 210 installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing