diff options
-rw-r--r-- | Presence/UTmp.hs | 8 | ||||
-rw-r--r-- | Presence/main.hs | 32 | ||||
-rw-r--r-- | whosocket.hs | 8 |
3 files changed, 32 insertions, 16 deletions
diff --git a/Presence/UTmp.hs b/Presence/UTmp.hs index 481612e3..898e05e0 100644 --- a/Presence/UTmp.hs +++ b/Presence/UTmp.hs | |||
@@ -1,5 +1,11 @@ | |||
1 | {-# LANGUAGE TemplateHaskell #-} | 1 | {-# LANGUAGE TemplateHaskell #-} |
2 | module UTmp (users, utmp_file) where | 2 | module UTmp |
3 | ( users | ||
4 | , utmp_file | ||
5 | , UserName | ||
6 | , Tty | ||
7 | , ProcessID | ||
8 | ) where | ||
3 | 9 | ||
4 | import qualified Data.ByteString as S | 10 | import qualified Data.ByteString as S |
5 | import qualified Data.ByteString.Char8 as C | 11 | import qualified Data.ByteString.Char8 as C |
diff --git a/Presence/main.hs b/Presence/main.hs index e8c07788..7b3a7826 100644 --- a/Presence/main.hs +++ b/Presence/main.hs | |||
@@ -75,7 +75,7 @@ unsplitResource (JabberUser n p) r = JID (Just n) p r | |||
75 | data PresenceState = PresenceState | 75 | data PresenceState = PresenceState |
76 | { hostname :: Peer -- ByteString, TODO: remove this, its always LocalHost now | 76 | { hostname :: Peer -- ByteString, TODO: remove this, its always LocalHost now |
77 | , currentTTY :: TVar ByteString | 77 | , currentTTY :: TVar ByteString |
78 | , activeUsers :: TVar (Set JID) | 78 | , activeUsers :: TVar (Set (UserName, Tty, ProcessID)) |
79 | , subscriberMap :: TVar (Map JID (RefCount,TChan Presence)) -- UNUSED as yet | 79 | , subscriberMap :: TVar (Map JID (RefCount,TChan Presence)) -- UNUSED as yet |
80 | , localSubscriber :: TMVar (RefCount,TChan Presence) -- TODO: rename this, its not just locals | 80 | , localSubscriber :: TMVar (RefCount,TChan Presence) -- TODO: rename this, its not just locals |
81 | -- ... or make a seperate channel for remotes | 81 | -- ... or make a seperate channel for remotes |
@@ -159,6 +159,8 @@ instance JabberClientSession ClientSession where | |||
159 | L.putStrLn $ "cached presence: " <++> bshow p | 159 | L.putStrLn $ "cached presence: " <++> bshow p |
160 | action p | 160 | action p |
161 | 161 | ||
162 | tupleToJID (user,tty,pid) = jid user LocalHost tty | ||
163 | |||
162 | data PeerSession = PeerSession { | 164 | data PeerSession = PeerSession { |
163 | announced :: TVar (MultiMap JabberUser (JabberResource,JabberShow)), | 165 | announced :: TVar (MultiMap JabberUser (JabberResource,JabberShow)), |
164 | peer_name :: Peer, | 166 | peer_name :: Peer, |
@@ -194,8 +196,8 @@ instance JabberPeerSession PeerSession where | |||
194 | tty <- readTVar $ currentTTY state | 196 | tty <- readTVar $ currentTTY state |
195 | users <- readTVar $ activeUsers state | 197 | users <- readTVar $ activeUsers state |
196 | return (tty,users) | 198 | return (tty,users) |
197 | let jids = Set.filter (\jid->name jid==Just user) users | 199 | let jids = Set.filter (\(name,tty,pid) -> name ==user) users |
198 | ps = map (\jid -> Presence jid (matchResource tty jid)) . Set.toList $ jids | 200 | ps = map (\jid -> Presence (tupleToJID jid) (matchResource' tty jid)) . Set.toList $ jids |
199 | if null ps | 201 | if null ps |
200 | then return [Presence (JID { name=Just user, peer=LocalHost, resource=Nothing }) Offline] | 202 | then return [Presence (JID { name=Just user, peer=LocalHost, resource=Nothing }) Offline] |
201 | else return ps | 203 | else return ps |
@@ -205,7 +207,7 @@ instance JabberPeerSession PeerSession where | |||
205 | subs <- readTVar $ subscriberMap (peer_global session) | 207 | subs <- readTVar $ subscriberMap (peer_global session) |
206 | greedy <- fmap snd $ readTMVar $ localSubscriber (peer_global session) | 208 | greedy <- fmap snd $ readTMVar $ localSubscriber (peer_global session) |
207 | return (greedy,subs) | 209 | return (greedy,subs) |
208 | update_presence (Just greedy) (fmap snd subs) (Set.singleton jid) (const status) | 210 | update_presence (Just greedy) (fmap snd subs) [jid] (const status) |
209 | liftIO . atomically $ do | 211 | liftIO . atomically $ do |
210 | jids <- readTVar . announced $ session | 212 | jids <- readTVar . announced $ session |
211 | withJust (splitResource jid) $ \(u,rsc) -> do | 213 | withJust (splitResource jid) $ \(u,rsc) -> do |
@@ -264,13 +266,18 @@ matchResource tty jid = maybe Away (avail . (==tty)) $ resource jid | |||
264 | avail True = Available | 266 | avail True = Available |
265 | avail False = Away | 267 | avail False = Away |
266 | 268 | ||
269 | matchResource' tty (_,rsc,_) = avail (rsc==tty) | ||
270 | where | ||
271 | avail True = Available | ||
272 | avail False = Away | ||
273 | |||
267 | sendPresence chan jid status = | 274 | sendPresence chan jid status = |
268 | (liftIO . atomically . writeTChan chan . Presence jid $ status) :: MaybeT IO () | 275 | (liftIO . atomically . writeTChan chan . Presence jid $ status) :: MaybeT IO () |
269 | 276 | ||
270 | lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers | 277 | lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers |
271 | 278 | ||
272 | update_presence locals_greedy subscribers state getStatus = | 279 | update_presence locals_greedy subscribers state getStatus = |
273 | forM_ (Set.toList state) $ \jid -> do | 280 | forM_ state $ \jid -> do |
274 | let status = getStatus jid | 281 | let status = getStatus jid |
275 | runMaybeT $ do | 282 | runMaybeT $ do |
276 | chan <- lookupT jid subscribers | 283 | chan <- lookupT jid subscribers |
@@ -316,9 +323,9 @@ track_login host state e = do | |||
316 | #else | 323 | #else |
317 | let us = [] | 324 | let us = [] |
318 | #endif | 325 | #endif |
319 | let toJabberId host (user,tty,_) = | 326 | let toJabberId host (user,tty,pid) = |
320 | if L.take 3 tty == "tty" | 327 | if L.take 3 tty == "tty" |
321 | then Just (jid user host tty) | 328 | then Just (user,tty,pid) -- (jid user host tty) |
322 | else Nothing | 329 | else Nothing |
323 | new_users = Set.fromList $ mapMaybe (toJabberId host) us | 330 | new_users = Set.fromList $ mapMaybe (toJabberId host) us |
324 | (tty,known_users,subs,locals_greedy) <- atomically $ do | 331 | (tty,known_users,subs,locals_greedy) <- atomically $ do |
@@ -327,11 +334,11 @@ track_login host state e = do | |||
327 | xs <- readTVar $ subscriberMap state | 334 | xs <- readTVar $ subscriberMap state |
328 | locals_greedy <- tryReadTMVar $ localSubscriber state | 335 | locals_greedy <- tryReadTMVar $ localSubscriber state |
329 | return (tty,st,fmap snd xs,fmap snd locals_greedy) | 336 | return (tty,st,fmap snd xs,fmap snd locals_greedy) |
330 | let arrivals = new_users \\ known_users | 337 | let arrivals = map tupleToJID . Set.toList $ new_users \\ known_users |
331 | departures = known_users \\ new_users | 338 | departures = map tupleToJID . Set.toList $ known_users \\ new_users |
332 | update_presence locals_greedy subs departures $ const Offline | 339 | update_presence locals_greedy subs departures $ const Offline |
333 | update_presence locals_greedy subs arrivals $ matchResource tty | 340 | update_presence locals_greedy subs arrivals $ matchResource tty |
334 | forM_ (Set.toList arrivals) | 341 | forM_ arrivals |
335 | $ sendProbes state | 342 | $ sendProbes state |
336 | 343 | ||
337 | on_chvt state vtnum = do | 344 | on_chvt state vtnum = do |
@@ -343,7 +350,10 @@ on_chvt state vtnum = do | |||
343 | writeTVar (currentTTY state) tty | 350 | writeTVar (currentTTY state) tty |
344 | locals_greedy <- tryReadTMVar $ localSubscriber state | 351 | locals_greedy <- tryReadTMVar $ localSubscriber state |
345 | return (us,fmap snd subs,fmap snd locals_greedy) | 352 | return (us,fmap snd subs,fmap snd locals_greedy) |
346 | update_presence locals_greedy subs users $ matchResource tty | 353 | update_presence locals_greedy |
354 | subs | ||
355 | (map tupleToJID . Set.toList $ users) | ||
356 | $ matchResource tty | ||
347 | 357 | ||
348 | start :: Network.Socket.Family -> IO () | 358 | start :: Network.Socket.Family -> IO () |
349 | start ip4or6 = do | 359 | start ip4or6 = do |
diff --git a/whosocket.hs b/whosocket.hs index a8dcdff9..cbf3cbec 100644 --- a/whosocket.hs +++ b/whosocket.hs | |||
@@ -142,14 +142,14 @@ ttyToXorgs tty_pids = do | |||
142 | 142 | ||
143 | identifyTTY tty_pids uid inode = do | 143 | identifyTTY tty_pids uid inode = do |
144 | pid <- scanProc (show uid) (L.unpack inode) | 144 | pid <- scanProc (show uid) (L.unpack inode) |
145 | putStrLn $ "scanProc --> "++show pid | 145 | -- putStrLn $ "scanProc --> "++show pid |
146 | flip (maybe (return Nothing)) pid $ \(pid,ttydev) -> do | 146 | flip (maybe (return Nothing)) pid $ \(pid,ttydev) -> do |
147 | tty <- ttyOrDisplay pid ttydev | 147 | tty <- ttyOrDisplay pid ttydev |
148 | putStrLn $ "users = " ++ show tty_pids | 148 | -- putStrLn $ "users = " ++ show tty_pids |
149 | dts <- ttyToXorgs tty_pids | 149 | dts <- ttyToXorgs tty_pids |
150 | 150 | ||
151 | putStrLn $ "displays = " ++ show dts | 151 | -- putStrLn $ "displays = " ++ show dts |
152 | putStrLn $ "tty = " ++ show tty | 152 | -- putStrLn $ "tty = " ++ show tty |
153 | -- -- displays = [(":5",Chunk "tty7" Empty)] | 153 | -- -- displays = [(":5",Chunk "tty7" Empty)] |
154 | 154 | ||
155 | let tty' = if take 3 tty=="tty" then Just (L.pack tty) else lookup (parseTty tty) (map (first parseTty) dts) | 155 | let tty' = if take 3 tty=="tty" then Just (L.pack tty) else lookup (parseTty tty) (map (first parseTty) dts) |