Reply to presence probes.

1 files changed, 26 insertions, 18 deletions

diff --git a/Presence/main.hs b/Presence/main.hs
index e02b4348..7981f00b 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -78,7 +78,7 @@ data ClientSession = ClientSession {
     presence_state :: PresenceState
 }
 
-instance XMPPSession ClientSession where
+instance JabberClientSession ClientSession where
     data XMPPClass ClientSession = ClientSessions PresenceState
 
     newSession (ClientSessions state) sock = do
@@ -119,29 +119,23 @@ instance XMPPSession ClientSession where
         let tvar = subscriberMap (presence_state session)
         atomically $ subscribeToMap tvar jid
 
-    announcePresence _ _ = error "announcePresence on client session?"
-
 
 data PeerSession = PeerSession {
     announced :: TVar (Set JID),
     peer_name :: Peer,
     peer_global :: PresenceState
 }
-instance XMPPSession PeerSession where
-    data XMPPClass PeerSession = PeerSessions PresenceState
-
-    setResource _ _ = error "setResource on peer session?"
-    getJID _        = error "getJID on peer session?"
-    subscribe _ _   = error "subscribe on peer session?"
+instance JabberPeerSession PeerSession where
+    data XMPPPeerClass PeerSession = PeerSessions PresenceState
 
-    newSession (PeerSessions state) sock = do
+    newPeerSession (PeerSessions state) sock = do
         me <- fmap (RemotePeer . withoutPort) (getPeerName sock)
         L.putStrLn $ "PEER SESSION: open "<++>showPeer me
         let remotes = remoteUsers state
         jids <- atomically $ getRefFromMap remotes me (newTVar Set.empty) return
         return $ PeerSession jids me state
 
-    closeSession session  = do
+    closePeerSession session  = do
         L.putStrLn $ "PEER SESSION: close "<++>showPeer (peer_name session)
         let offline jid = Presence jid Offline
         unrefFromMap (remoteUsers . peer_global $ session) (peer_name session)
@@ -149,6 +143,22 @@ instance XMPPSession PeerSession where
                 js <- fmap Set.toList (readTVarIO . announced $ session)
                 forM_ js $ announcePresence session . offline
 
+    peerSessionFactory session = PeerSessions (peer_global session)
+
+    peerAddress session = peer_name session
+
+    userStatus session user = do
+        let state = peer_global session
+        (tty,users) <- atomically $ do
+            tty <- readTVar $ currentTTY state
+            users <- readTVar $ activeUsers state
+            return (tty,users)
+        let jids = Set.filter (\jid->name jid==Just user) users
+            ps = map (\jid -> Presence jid (matchResource tty jid)) . Set.toList $ jids
+        if null ps
+            then return [Presence (JID { name=Just user, peer=LocalHost, resource=Nothing }) Offline]
+            else return ps
+
     announcePresence session (Presence jid status) = do
         (greedy,subs) <- atomically $ do
             subs <- readTVar $ subscriberMap (peer_global session)
@@ -162,6 +172,10 @@ instance XMPPSession PeerSession where
                     Offline -> Set.delete jid jids
                     _       -> Set.insert jid jids
 
+    getBuddies     _ user = ConfigFiles.getBuddies user
+    getSubscribers _ user = ConfigFiles.getSubscribers user
+
+
 subscribeToChan tmvar =
             (do (cnt,chan) <- takeTMVar tmvar
                 putTMVar tmvar (cnt+1,chan)
@@ -284,12 +298,6 @@ on_chvt state vtnum = do
         return (us,fmap snd subs,fmap snd locals_greedy)
     update_presence locals_greedy subs users $ matchResource tty
 
-data UnixConfig = UnixConfig
-
-instance XMPPConfig UnixConfig where
-    getBuddies     _ user = ConfigFiles.getBuddies user
-    getSubscribers _ user = ConfigFiles.getSubscribers user
-
 start :: Network.Socket.Family -> IO ()
 start ip4or6 = do
     let host = LocalHost
@@ -298,7 +306,7 @@ start ip4or6 = do
         dologin :: t -> IO ()
 
     chan <- atomically $ subscribeToChan (localSubscriber global_state)
-    remotes <- forkIO $ seekRemotePeers UnixConfig chan (outGoingConnections global_state)
+    remotes <- forkIO $ seekRemotePeers (PeerSessions global_state) chan (outGoingConnections global_state)
 
     installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing
     -- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing