summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Presence/main.hs166
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 -}
120data ClientSession = ClientSession { 125data 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
128type RefCount = Int
129
130type JabberResource = L.ByteString
131type JabberName = L.ByteString
132data JabberUser = JabberUser JabberName Peer
133 deriving (Eq,Ord,Show)
134
135splitResource :: JID -> Maybe (JabberUser,Maybe JabberResource)
136splitResource (JID Nothing _ _ ) = Nothing
137splitResource (JID (Just n) p r ) = Just (JabberUser n p, r)
138
139unsplitResource (JabberUser n p) r = JID (Just n) p r
140
141
142rosterPush 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
150getJabberUserForId 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
161cmpJID 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
168addRawJid modify user jid = do
169 newitem <- parseHostNameJID jid
170 modify user (cmpJID newitem) (Just jid)
171 return ()
172
173addJid 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
180instance JabberClientSession ClientSession where 146instance 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
377tupleToJID (user,tty,pid) = jid user LocalHost tty
378
379getUserStatus 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 -}
391data PeerSession = PeerSession { 349data 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
396instance JabberPeerSession PeerSession where 362instance 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
456type RefCount = Int
457
458type JabberResource = L.ByteString
459type JabberName = L.ByteString
460data JabberUser = JabberUser JabberName Peer
461 deriving (Eq,Ord,Show)
462
463splitResource :: JID -> Maybe (JabberUser,Maybe JabberResource)
464splitResource (JID Nothing _ _ ) = Nothing
465splitResource (JID (Just n) p r ) = Just (JabberUser n p, r)
466
467unsplitResource (JabberUser n p) r = JID (Just n) p r
468
469
470rosterPush 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
478getJabberUserForId 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
489cmpJID 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
496addRawJid modify user jid = do
497 newitem <- parseHostNameJID jid
498 modify user (cmpJID newitem) (Just jid)
499 return ()
500
501addJid 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
508tupleToJID (user,tty,pid) = jid user LocalHost tty
509
510getUserStatus 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
489data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a)) 523data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a))
490 524
491subscribeToChan :: TMVar (RefCount, TChan a) -> STM (TChan a) 525subscribeToChan :: TMVar (RefCount, TChan a) -> STM (TChan a)