Auto-reply approval to remote peer in case a requested subscription

is already established.

3 files changed, 59 insertions, 39 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index ce1ea7c5..e4f60712 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -684,12 +684,11 @@ handlePresenceProbe session stanza = do
         subs <- getSubscribers (peerSessionFactory session) user
         liftIO $ L.putStrLn $ "subscribers for "<++>bshow user<++>": " <++>bshow subs
         forM_ subs $ \jidstr -> do
-            handle (\(IOError _ _ _ _ _ _) -> return ()) $ do
-            -- handle (\(SomeException _) -> return ()) $ do
+            handleIO_ (return ()) $ do
                 L.putStrLn $ "parsing " <++>jidstr
                 sub <- parseHostNameJID jidstr
                 putStrLn $ "comparing " ++show (peer sub , peerAddress session)
-                when (peer sub == peerAddress session) $ do
+                when (peer sub == discardPort (peerAddress session)) $ do
                 ps <- userStatus session user
                 mapM_ (announcePresence session) ps
     return ()
@@ -776,10 +775,10 @@ peerRequestsSubsription session stanza = do
     if elem fromjid subs
       then do
         liftIO . L.putStrLn $ bshow fromjid <++> " already subscribed to " <++> user
-        -- if already subscribed
-        --   reply
-        return ()
+        -- if already subscribed, reply
+        liftIO $ sendPeerMessage session (Approval tojid fromjid)
       else
+        -- TODO
         -- if no client:
         --   add pending
         -- else:
@@ -846,25 +845,25 @@ fromPeer session = doNestingXML $ do
 
 
 
-data OutBoundMessage = OutBoundPresence Presence 
-                        | PresenceProbe JID JID
-                        | Solicitation  JID JID
-                        | Approval JID JID
- deriving Prelude.Show
-
 newServerConnections = newTVar Map.empty
 
 data CachedMessages = CachedMessages 
     { presences :: Map JID JabberShow
-    , probes :: Map JID (Set (Bool,JID))
+    , probes :: Map JID (Set (Bool,JID)) -- False means solicitation rather than probe
+    , approvals :: Map JID (Set JID) 
     }
+newCache = CachedMessages Map.empty Map.empty Map.empty
 
 connect_to_server chan peer = (>> return ()) . runMaybeT $ do
     let port = 5269 :: Int
     -- We'll cache Presence notifications until the socket
     -- is ready.
-    cached <- liftIO $ newIORef (CachedMessages Map.empty Map.empty)
+    cached <- liftIO $ newIORef newCache
 
+    let mmInsert val key mm = Map.alter f key mm
+            where 
+                f Nothing    = Just $ Set.singleton val
+                f (Just set) = Just $ Set.insert val set
     let cacheCmd (OutBoundPresence (Presence jid Offline)) cached = do
                     cache <- readIORef cached
                     writeIORef cached (cache { presences=Map.delete jid . presences $ cache })
@@ -873,13 +872,16 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
                     writeIORef cached (cache { presences=Map.insert jid st . presences $ cache })
         cacheCmd (PresenceProbe from to) cached = do
                     cache <- readIORef cached
-                    let probes' = Map.adjust (Set.insert (True,from)) to $ probes cache
+                    let probes' = mmInsert  (True,from) to $ probes cache
                     writeIORef cached (cache { probes=probes' })
         cacheCmd (Solicitation from to) cached = do
                     cache <- readIORef cached
-                    let probes' = Map.adjust (Set.insert (False,from)) to $ probes cache
+                    let probes' = mmInsert (False,from) to $ probes cache
                     writeIORef cached (cache { probes=probes' })
-        cacheCmd (Approval from to) cached = return () -- Subscription approvals are not cached.
+        cacheCmd (Approval from to) cached = do
+                    cache <- readIORef cached
+                    let approvals' = mmInsert from to $ approvals cache
+                    writeIORef cached (cache { approvals=approvals' })
 
     fix $ \sendmsgs -> do
         connected <- liftIO . async $ connect' (peerAddr peer) port
@@ -898,7 +900,7 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
                 hSetBuffering h NoBuffering
                 cache <- readIORef $ cached
                 -- hint garbage collector: we're done with this...
-                writeIORef cached (CachedMessages Map.empty Map.empty) 
+                writeIORef cached newCache
                 return (cache,packetSink h)
             MaybeT $ handleOutgoingToPeer (restrictSocket sock) cache chan snk
 
@@ -920,7 +922,7 @@ goodbyePeer =
     , EventEndDocument
     ]
 
-presenceProbe sock fromjid tojid typ = do
+presenceStanza sock fromjid tojid typ = do
     addr <- getSocketName sock
     let jidstr jid = toStrict . L.decodeUtf8 
                       $ name jid <$++> "@" 
@@ -963,28 +965,31 @@ toPeer sock cache chan fail = do
         checkConnection cmd = do
             liftIO $ catch (getPeerName sock >> return ())
                            (\_ -> fail . Just $ cmd)
-        sendPresence presence = do
-            r <- lift $ xmlifyPresenceForPeer sock presence
-            {-
-            liftIO $ do
-                p' <- catch (fmap (Just . RemotePeer) $ getPeerName sock)
-                            (\_ -> (fail . Just . OutBoundPresence $ presence) >> return Nothing)
-                L.putStrLn $ "sending Presence to " <++?> fmap showPeer p'
-            -}
-            let cmd = OutBoundPresence presence
+        sendOrFail getXML cmd = do
             checkConnection cmd
+            r <- liftIO $ getXML
+                    -- handleIO (\e -> putStrLn ("ERROR: "++show e) >> return []) getXML
             yieldOr r (fail . Just $ cmd)
             prettyPrint ">P: " r
-        sendProbe' from to typ = do
-            r <- liftIO $ presenceProbe sock from to typ
-            let cmd = PresenceProbe from to
-            checkConnection cmd
-            yieldOr r (fail . Just $ cmd)
-            prettyPrint ">P: " r
-        sendProbe from to = sendProbe' from to "probe"
-        sendSolicitation from to = sendProbe' from to "subscribe"
+        sendPresence presence =
+            sendOrFail (xmlifyPresenceForPeer sock presence)
+                       (OutBoundPresence presence)
+        sendProbe from to =
+            sendOrFail (presenceStanza sock from to "probe")
+                       (PresenceProbe from to)
+        sendSolicitation from to = 
+            sendOrFail (presenceStanza sock from to "subscribe")
+                       (Solicitation from to)
+        sendApproval from to = 
+            sendOrFail (presenceStanza sock from to "subscribed")
+                       (Approval from to)
+
 
     send greetPeer
+    forM_ (Map.assocs . approvals $ cache) $ \(to,froms) -> do
+        forM_ (Set.toList froms) $ \from -> do
+            liftIO $ L.putStrLn "sending cached approval..."
+            sendApproval from to
     forM_ (Map.assocs . presences $ cache) $ \(jid,st) -> do
         sendPresence (Presence jid st)
     forM_ (Map.assocs . probes $ cache) $ \(to,froms) -> do
@@ -1010,8 +1015,7 @@ toPeer sock cache chan fail = do
             sendSolicitation from to
           Approval from to -> do
             liftIO . L.putStrLn $ "sending approval "<++>bshow (from,to)
-            r <- liftIO $ presenceProbe sock from to "subscribed"
-            send r
+            sendApproval from to
         loop
     send goodbyePeer
 
@@ -1075,7 +1079,8 @@ connect' addr port = do
 
 
 sendMessage  :: TVar (Map Peer (TChan OutBoundMessage, ThreadId)) -> OutBoundMessage -> Peer -> IO ()
-sendMessage cons msg peer = do
+sendMessage cons msg peer0 = do
+    let peer = discardPort peer0
     found <- atomically $ do
         consmap <- readTVar cons
         return (Map.lookup peer consmap)
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index 2bad795a..275f644e 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -55,6 +55,7 @@ class JabberPeerSession session where
     userStatus       :: session -> ByteString -> IO [Presence]
     announcePresence :: session -> Presence -> IO ()
     peerSessionFactory :: session -> XMPPPeerClass session
+    sendPeerMessage  :: session -> OutBoundMessage -> IO ()
     getBuddies       :: XMPPPeerClass session -> ByteString -> IO [ByteString]
     getSubscribers   :: XMPPPeerClass session -> ByteString -> IO [ByteString]
 
@@ -122,6 +123,9 @@ showPeer (RemotePeer addr@(SockAddrInet6 _ _ _ _)) = pack $ stripColon (Prelude.
 is_remote (RemotePeer _) = True
 is_remote _              = False
 
+discardPort (RemotePeer addr) = RemotePeer (withoutPort addr)
+discardPort x                 = x
+
 parseHostNameJID :: ByteString -> IO JID
 parseHostNameJID jid = do
     let (name,peer_string,rsc) = splitJID jid
@@ -188,3 +192,9 @@ withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
 
 withoutPort = (`withPort` 0)
 
+data OutBoundMessage = OutBoundPresence Presence 
+                        | PresenceProbe JID JID
+                        | Solicitation  JID JID
+                        | Approval JID JID
+ deriving Prelude.Show
+
diff --git a/Presence/main.hs b/Presence/main.hs
index 036d7237..303c4b05 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -287,6 +287,11 @@ instance JabberPeerSession PeerSession where
                     Offline -> MM.deleteElemIf u match jids
                     stat    -> maybe jids (\r -> MM.insert u (r,stat) jids) rsc
 
+    sendPeerMessage session msg = do
+        let cons = outGoingConnections . peer_global $ session
+        putStrLn $ "sendPeerMessage " <++> bshow msg <++> " --> "<++>bshow (peer_name session)
+        sendMessage cons msg (peer_name session)
+
     getBuddies     _ user = ConfigFiles.getBuddies user
     getSubscribers _ user = ConfigFiles.getSubscribers user