diff options
Diffstat (limited to 'Presence')
-rw-r--r-- | Presence/main.hs | 166 |
1 files changed, 100 insertions, 66 deletions
diff --git a/Presence/main.hs b/Presence/main.hs index cfc7154c..86dfdacc 100644 --- a/Presence/main.hs +++ b/Presence/main.hs | |||
@@ -117,66 +117,32 @@ newPresenceState hostname = atomically $ do | |||
117 | return $ PresenceState hostname tty us subs locals_greedy rchan remotes server_connections | 117 | return $ PresenceState hostname tty us subs locals_greedy rchan remotes server_connections |
118 | 118 | ||
119 | 119 | ||
120 | {- ClientSessions | ||
121 | - | ||
122 | - This is the per-client state. It is manipulated mainly via the | ||
123 | - JabberClientSession interface. | ||
124 | -} | ||
120 | data ClientSession = ClientSession { | 125 | data ClientSession = ClientSession { |
121 | localhost :: Peer, -- ByteString, | 126 | localhost :: Peer, -- anotehr name or the LocalHost constructor, todo: remove this. |
127 | |||
128 | -- unix_uid: This is the detected uid of the user of the connecting client. | ||
129 | -- The ByteString is the numeric inode text parsed from /proc/net/tcp6 | ||
130 | -- (*not* the login name of the user) | ||
122 | unix_uid :: (IORef (Maybe (UserID,L.ByteString))), | 131 | unix_uid :: (IORef (Maybe (UserID,L.ByteString))), |
132 | |||
133 | -- unix_resource: This is the detected TTY of the connecting client. | ||
123 | unix_resource :: (IORef (Maybe L.ByteString)), | 134 | unix_resource :: (IORef (Maybe L.ByteString)), |
135 | |||
136 | -- chans: This is a list of channels that the session is reading and will be | ||
137 | -- whose counts will be decremented when the session ends. | ||
138 | -- Note: currently is likely to be only two channels, the | ||
139 | -- localSubscriber & rosterChannel of the global state record. | ||
124 | chans :: TVar [RefCountedChan], | 140 | chans :: TVar [RefCountedChan], |
141 | |||
142 | -- presence_state: a reference to the global state. | ||
125 | presence_state :: PresenceState | 143 | presence_state :: PresenceState |
126 | } | 144 | } |
127 | 145 | ||
128 | type RefCount = Int | ||
129 | |||
130 | type JabberResource = L.ByteString | ||
131 | type JabberName = L.ByteString | ||
132 | data JabberUser = JabberUser JabberName Peer | ||
133 | deriving (Eq,Ord,Show) | ||
134 | |||
135 | splitResource :: JID -> Maybe (JabberUser,Maybe JabberResource) | ||
136 | splitResource (JID Nothing _ _ ) = Nothing | ||
137 | splitResource (JID (Just n) p r ) = Just (JabberUser n p, r) | ||
138 | |||
139 | unsplitResource (JabberUser n p) r = JID (Just n) p r | ||
140 | |||
141 | |||
142 | rosterPush msg state = do | ||
143 | let rchan = rosterChannel state | ||
144 | atomically $ do | ||
145 | isempty <- isEmptyTMVar rchan | ||
146 | when (not isempty) $ do | ||
147 | (_,ch) <- readTMVar rchan | ||
148 | writeTChan ch msg | ||
149 | |||
150 | getJabberUserForId muid = | ||
151 | maybe (return "nobody") | ||
152 | (\(uid,_) -> | ||
153 | handle (\(SomeException _) -> | ||
154 | return . L.append "uid." . L.pack . show $ uid) | ||
155 | $ do | ||
156 | user <- fmap userName $ getUserEntryForID uid | ||
157 | return (L.pack user) | ||
158 | ) | ||
159 | muid | ||
160 | |||
161 | cmpJID newitem jid = do | ||
162 | -- putStrLn $ "Comparing "<++>bshow jid | ||
163 | olditem <- parseHostNameJID jid | ||
164 | if olditem==newitem then return Nothing | ||
165 | else return $ Just jid | ||
166 | |||
167 | |||
168 | addRawJid modify user jid = do | ||
169 | newitem <- parseHostNameJID jid | ||
170 | modify user (cmpJID newitem) (Just jid) | ||
171 | return () | ||
172 | |||
173 | addJid modify user jid = do | ||
174 | hjid <- asHostNameJID jid | ||
175 | putStrLn $ "addJid (asHostNameJID) --> "<++>bshow hjid | ||
176 | withJust hjid $ \hjid -> do | ||
177 | modify user (cmpJID jid) (Just hjid) | ||
178 | return () | ||
179 | |||
180 | instance JabberClientSession ClientSession where | 146 | instance JabberClientSession ClientSession where |
181 | data XMPPClass ClientSession = ClientSessions PresenceState | 147 | data XMPPClass ClientSession = ClientSessions PresenceState |
182 | 148 | ||
@@ -374,25 +340,25 @@ instance JabberClientSession ClientSession where | |||
374 | (peer cjid) | 340 | (peer cjid) |
375 | return () | 341 | return () |
376 | 342 | ||
377 | tupleToJID (user,tty,pid) = jid user LocalHost tty | ||
378 | |||
379 | getUserStatus state user = do | ||
380 | (tty,users) <- atomically $ do | ||
381 | tty <- readTVar $ currentTTY state | ||
382 | users <- readTVar $ activeUsers state | ||
383 | return (tty,users) | ||
384 | let jids = Set.filter (\(name,tty,pid) -> name ==user) users | ||
385 | ps = map (\jid -> Presence (tupleToJID jid) (matchResource' tty jid)) . Set.toList $ jids | ||
386 | if null ps | ||
387 | then return [Presence (JID { name=Just user, peer=LocalHost, resource=Nothing }) Offline] | ||
388 | else return ps | ||
389 | |||
390 | 343 | ||
344 | {- PeerSession | ||
345 | - | ||
346 | - This is the per-remote-peer state. It is manipulated mainly via the | ||
347 | - JabberPeerSession interface. | ||
348 | -} | ||
391 | data PeerSession = PeerSession { | 349 | data PeerSession = PeerSession { |
350 | -- announced: a list of users that were announced by the remote peer. | ||
351 | -- This list is kept in order to mark them all offline in | ||
352 | -- case the peer connection is lost or goes down. | ||
392 | announced :: TVar (MultiMap JabberUser (JabberResource,JabberShow)), | 353 | announced :: TVar (MultiMap JabberUser (JabberResource,JabberShow)), |
354 | |||
355 | -- peer_name: This the address of the remote peer. | ||
393 | peer_name :: Peer, | 356 | peer_name :: Peer, |
357 | |||
358 | -- peer_global: a reference to the global state. | ||
394 | peer_global :: PresenceState | 359 | peer_global :: PresenceState |
395 | } | 360 | } |
361 | |||
396 | instance JabberPeerSession PeerSession where | 362 | instance JabberPeerSession PeerSession where |
397 | data XMPPPeerClass PeerSession = PeerSessions PresenceState | 363 | data XMPPPeerClass PeerSession = PeerSessions PresenceState |
398 | 364 | ||
@@ -486,6 +452,74 @@ instance JabberPeerSession PeerSession where | |||
486 | rosterPush (PendingSubscriber user buddy) (peer_global session) | 452 | rosterPush (PendingSubscriber user buddy) (peer_global session) |
487 | 453 | ||
488 | 454 | ||
455 | |||
456 | type RefCount = Int | ||
457 | |||
458 | type JabberResource = L.ByteString | ||
459 | type JabberName = L.ByteString | ||
460 | data JabberUser = JabberUser JabberName Peer | ||
461 | deriving (Eq,Ord,Show) | ||
462 | |||
463 | splitResource :: JID -> Maybe (JabberUser,Maybe JabberResource) | ||
464 | splitResource (JID Nothing _ _ ) = Nothing | ||
465 | splitResource (JID (Just n) p r ) = Just (JabberUser n p, r) | ||
466 | |||
467 | unsplitResource (JabberUser n p) r = JID (Just n) p r | ||
468 | |||
469 | |||
470 | rosterPush msg state = do | ||
471 | let rchan = rosterChannel state | ||
472 | atomically $ do | ||
473 | isempty <- isEmptyTMVar rchan | ||
474 | when (not isempty) $ do | ||
475 | (_,ch) <- readTMVar rchan | ||
476 | writeTChan ch msg | ||
477 | |||
478 | getJabberUserForId muid = | ||
479 | maybe (return "nobody") | ||
480 | (\(uid,_) -> | ||
481 | handle (\(SomeException _) -> | ||
482 | return . L.append "uid." . L.pack . show $ uid) | ||
483 | $ do | ||
484 | user <- fmap userName $ getUserEntryForID uid | ||
485 | return (L.pack user) | ||
486 | ) | ||
487 | muid | ||
488 | |||
489 | cmpJID newitem jid = do | ||
490 | -- putStrLn $ "Comparing "<++>bshow jid | ||
491 | olditem <- parseHostNameJID jid | ||
492 | if olditem==newitem then return Nothing | ||
493 | else return $ Just jid | ||
494 | |||
495 | |||
496 | addRawJid modify user jid = do | ||
497 | newitem <- parseHostNameJID jid | ||
498 | modify user (cmpJID newitem) (Just jid) | ||
499 | return () | ||
500 | |||
501 | addJid modify user jid = do | ||
502 | hjid <- asHostNameJID jid | ||
503 | putStrLn $ "addJid (asHostNameJID) --> "<++>bshow hjid | ||
504 | withJust hjid $ \hjid -> do | ||
505 | modify user (cmpJID jid) (Just hjid) | ||
506 | return () | ||
507 | |||
508 | tupleToJID (user,tty,pid) = jid user LocalHost tty | ||
509 | |||
510 | getUserStatus state user = do | ||
511 | (tty,users) <- atomically $ do | ||
512 | tty <- readTVar $ currentTTY state | ||
513 | users <- readTVar $ activeUsers state | ||
514 | return (tty,users) | ||
515 | let jids = Set.filter (\(name,tty,pid) -> name ==user) users | ||
516 | ps = map (\jid -> Presence (tupleToJID jid) (matchResource' tty jid)) . Set.toList $ jids | ||
517 | if null ps | ||
518 | then return [Presence (JID { name=Just user, peer=LocalHost, resource=Nothing }) Offline] | ||
519 | else return ps | ||
520 | |||
521 | |||
522 | |||
489 | data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a)) | 523 | data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a)) |
490 | 524 | ||
491 | subscribeToChan :: TMVar (RefCount, TChan a) -> STM (TChan a) | 525 | subscribeToChan :: TMVar (RefCount, TChan a) -> STM (TChan a) |