Reply to presence probes.

3 files changed, 68 insertions, 35 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index eb1774d1..99e7b3f1 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -345,7 +345,7 @@ handleIQGet session cmdChan tag = do
         req -> unhandledGet req
     
 
-fromClient :: (MonadThrow m,MonadIO m, XMPPSession session) => 
+fromClient :: (MonadThrow m,MonadIO m, JabberClientSession session) => 
     session -> TChan Commands -> Sink XML.Event m ()
 fromClient session cmdChan = doNestingXML $ do
     let log  = liftIO . L.putStrLn . ("(C) " <++>)
@@ -402,7 +402,7 @@ toClient pchan cmdChan = fix $ \loop -> do
 
 handleClient
   :: (SocketLike sock, HHead l (XMPPClass session),
-      XMPPSession session) =>
+      JabberClientSession session) =>
      HCons sock (HCons t l) -> Source IO ByteString -> Sink ByteString IO () -> IO ()
 handleClient st src snk = do
     let HCons sock (HCons _ st') = st
@@ -431,7 +431,7 @@ handleClient st src snk = do
 
 listenForXmppClients ::
   (HList l, HHead l (XMPPClass session), HExtend e1 l2 l1,
-   HExtend e l1 (HCons PortNumber l), XMPPSession session) =>
+   HExtend e l1 (HCons PortNumber l), JabberClientSession session) =>
   Family -> e1 -> e -> l2 -> IO ServerHandle
 listenForXmppClients addr_family session_factory port st = do
     doServer (addr_family .*. port .*. session_factory .*. st) handleClient
@@ -462,28 +462,28 @@ renderChunks = fixMaybeT $  \loop -> do
 
 
 listenForRemotePeers
-  :: (HList l, HHead l (XMPPClass session),
+  :: (HList l, HHead l (XMPPPeerClass session),
       HExtend e l1 (HCons PortNumber l), HExtend e1 l2 l1,
-      XMPPSession session) =>
+      JabberPeerSession session) =>
      Family -> e1 -> e -> l2 -> IO ServerHandle
 listenForRemotePeers addrfamily session_factory port st = do
     doServer (addrfamily .*. port .*. session_factory .*. st) handlePeer
 
 handlePeer
-  :: (SocketLike sock, HHead l (XMPPClass session),
-      XMPPSession session) =>
+  :: (SocketLike sock, HHead l (XMPPPeerClass session),
+      JabberPeerSession session) =>
      HCons sock (HCons t1 l) -> Source IO ByteString -> t -> IO ()
 handlePeer st src snk = do
     let HCons sock (HCons _ st') = st
         session_factory = hHead st'
     name <- fmap bshow $ getPeerName sock
     L.putStrLn $ "(P) connected " <++> name
-    session <- newSession session_factory sock
+    session <- newPeerSession session_factory sock
 
     finally ( src $= parseBytes def $$ fromPeer session )
         $ do 
             L.putStrLn $ "(P) disconnected " <++> name
-            closeSession session
+            closePeerSession session
 
 
 handlePeerPresence session stanza False = do
@@ -527,6 +527,7 @@ matchAttribMaybe name Nothing attrs
 
 presenceTypeOffline = Just "unavailable"
 presenceTypeOnline  = Nothing
+presenceTypeProbe   = Just "probe"
 
 isPresenceOf (EventBeginElement name attrs) testType
     | name=="{jabber:server}presence"
@@ -534,7 +535,23 @@ isPresenceOf (EventBeginElement name attrs) testType
     = True
 isPresenceOf _ _ = False
 
-fromPeer :: (MonadThrow m,MonadIO m, XMPPSession session) => 
+handlePresenceProbe session stanza = do
+    withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to -> do
+    -- withJust (lookupAttrib "from" (tagAttrs stanza)) $ \from -> do
+    jid <- liftIO $ parseAddressJID $ L.fromChunks [S.encodeUtf8 to]
+    withJust (name jid) $ \user -> do
+    liftIO $ L.putStrLn $ "RECEIVED PROBE "<++>bshow (peerAddress session,to)
+    liftIO $ do
+        subs <- getSubscribers (peerSessionFactory session) user
+        forM_ subs $ \jidstr -> do
+            handle (\(SomeException _) -> return ()) $ do
+                sub <- parseHostNameJID jidstr
+                when (peer sub == peer jid) $ do
+                ps <- userStatus session user
+                mapM_ (announcePresence session) ps
+    return ()
+
+fromPeer :: (MonadThrow m,MonadIO m, JabberPeerSession session) => 
     session -> Sink XML.Event m ()
 fromPeer session = doNestingXML $ do
     let log  = liftIO . L.putStrLn . ("(P) " <++>)
@@ -558,6 +575,8 @@ fromPeer session = doNestingXML $ do
                     -> handlePeerPresence session stanza True
               _ | stanza `isPresenceOf` presenceTypeOffline
                     -> handlePeerPresence session stanza False
+              _ | stanza `isPresenceOf` presenceTypeProbe
+                    -> handlePresenceProbe session stanza
               _ -> unhandledStanza
 
             awaitCloser stanza_lvl
@@ -761,8 +780,8 @@ sendMessage cons msg peer = do
 
 
 
-seekRemotePeers :: XMPPConfig config =>
-     config -> TChan Presence -> TVar (Map Peer (TChan OutBoundMessage, ThreadId)) -> IO b0
+seekRemotePeers :: JabberPeerSession config =>
+     XMPPPeerClass config -> TChan Presence -> TVar (Map Peer (TChan OutBoundMessage, ThreadId)) -> IO b0
 seekRemotePeers config chan server_connections = do
     fix $ \loop -> do
         event <- atomically $ readTChan chan
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index b46b4294..6e054708 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -31,18 +31,24 @@ import Control.DeepSeq
 import ByteStringOperators
 import SocketLike
 
-class XMPPSession session where
+class JabberClientSession session where
     data XMPPClass session
     newSession   :: SocketLike sock => XMPPClass session -> sock -> IO session
     setResource  :: session -> ByteString -> IO ()
     getJID       :: session -> IO JID
     closeSession :: session -> IO ()
     subscribe :: session -> Maybe JID -> IO (TChan Presence)
-    announcePresence :: session -> Presence -> IO ()
 
-class XMPPConfig config where
-    getBuddies :: config -> ByteString -> IO [ByteString]
-    getSubscribers :: config -> ByteString -> IO [ByteString]
+class JabberPeerSession session where
+    data XMPPPeerClass session
+    newPeerSession   :: SocketLike sock => XMPPPeerClass session -> sock -> IO session
+    closePeerSession :: session -> IO ()
+    peerAddress      :: session -> Peer
+    userStatus       :: session -> ByteString -> IO [Presence]
+    announcePresence :: session -> Presence -> IO ()
+    peerSessionFactory :: session -> XMPPPeerClass session
+    getBuddies       :: XMPPPeerClass session -> ByteString -> IO [ByteString]
+    getSubscribers   :: XMPPPeerClass session -> ByteString -> IO [ByteString]
 
 -- | Jabber ID (JID) datatype
 data JID = JID { name :: Maybe ByteString
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