diff options
Diffstat (limited to 'Presence/main.hs')
-rw-r--r-- | Presence/main.hs | 35 |
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 | ||
97 | subscribeToChan tmvar = | 100 | subscribeToChan tmvar = |
@@ -128,14 +131,14 @@ sendPresence chan jid status = | |||
128 | 131 | ||
129 | lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers | 132 | lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers |
130 | 133 | ||
131 | update_presence greedy subscribers state getStatus = | 134 | update_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 | ||
152 | newPresenceState hostname = atomically $ do | 155 | newPresenceState 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 | ||
159 | track_login host state e = do | 162 | track_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 | ||
181 | on_chvt state vtnum = do | 184 | on_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 | ||
192 | data UnixConfig = UnixConfig | 195 | data 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 |