send subscription requests to remote peers

3 files changed, 71 insertions, 35 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index a08c1a0e..735eaf3a 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -71,6 +71,7 @@ import Control.Monad as Monad
 import Text.XML.Stream.Parse (parseBytes,content)
 import Text.XML.Stream.Render
 import Data.XML.Types as XML
+import qualified Data.Text as S (takeWhile)
 import Data.Text.Encoding      as S (decodeUtf8,encodeUtf8)
 import Data.Text.Lazy.Encoding as L (decodeUtf8,encodeUtf8)
 import Data.Text.Lazy (toStrict)
@@ -512,7 +513,7 @@ toClient session pchan cmdChan rchan = toClient' False False
       CmdChan (Send xs)  -> send xs >> loop
       CmdChan BoundToResource    -> toClient' True    isInterested
       CmdChan InterestedInRoster -> toClient' isBound True
-      CmdChan cmd        -> liftIO (putStrLn $ "unhandled event: "++show cmd) >> loop
+      -- CmdChan cmd        -> liftIO (putStrLn $ "unhandled event: "++show cmd) >> loop
       RChan   (RequestedSubscription who contact) ->  do
         jid <- liftIO $ getJID session
         when (isInterested && Just who==name jid) $ do
@@ -712,18 +713,20 @@ presenceErrorRemoteNotFound iqid from to = return
     , EventEndElement "{stream:client}presence"
     ]
 
+presenceSubscribed from = return
+    [ EventBeginElement "{stream:client}presence" 
+        [ attr "from" from
+        , attr "type" "subscribed"
+        ]
+    , EventEndElement   "{stream:client}presence"
+    ]
+
 clientRequestsSubscription session cmdChan stanza = do
-    -- make bare jid
-    -- check local server and obey rules 3.1.3 of rfc 6121
-    -- or forward to remote peer
-    -- or bail with type='error' as shown in 3.1.2
-    -- if not bailed,
-    --  add to solicited
-    --  do roster push with subscription=none ask=subscribe
     liftIO $ do
         putStrLn $ "CLIENT PRESENCE SUBSCRIBE " ++ show stanza
-        withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
-        let from = lookupAttrib "from" (tagAttrs stanza)
+        withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str0 -> do
+        let to_str = S.takeWhile (/='/') to_str0
+            from = lookupAttrib "from" (tagAttrs stanza)
             iqid = lookupAttrib "id" (tagAttrs stanza)
         let handleError e | isDoesNotExistError e = do
                 putStrLn $ "remote-server-not-found"
@@ -732,12 +735,18 @@ clientRequestsSubscription session cmdChan stanza = do
             handleError e = do
                 putStrLn $ "ERROR: "++ show e
         handleIO handleError $ do
-            to_jid <- parseHostNameJID (L.fromChunks [S.encodeUtf8 to_str])
-            addSolicited session (L.fromChunks [S.encodeUtf8 to_str]) -- jid
-            putStrLn $ "added to solicited: " ++ show to_jid
-            -- TODO: create roster item and push to interested clients
-            -- addSolicited should write event to a roster channel
-            -- that toClient will be listening on.
+            let to_str' = (L.fromChunks [S.encodeUtf8 to_str])
+            to_jid <- fmap bare $ parseHostNameJID to_str'
+            if (is_remote . peer) to_jid 
+             then do
+                addSolicited session to_str' to_jid
+                putStrLn $ "added to solicited: " ++ show to_jid
+                -- TODO: notify peer.
+             else do
+                -- addLocalSubscriber session to_str
+                -- self <- getJID session
+                r <- presenceSubscribed to_str -- self
+                atomically $ writeTChan cmdChan (Send r)
     return ()
 
 peerRequestsSubsription session stanza = do
@@ -807,14 +816,16 @@ fromPeer session = doNestingXML $ do
 
 
 
-data OutBoundMessage = OutBoundPresence Presence | PresenceProbe JID JID
+data OutBoundMessage = OutBoundPresence Presence 
+                        | PresenceProbe JID JID
+                        | Solicitation  JID JID
  deriving Prelude.Show
 
 newServerConnections = newTVar Map.empty
 
 data CachedMessages = CachedMessages 
     { presences :: Map JID JabberShow
-    , probes :: Map JID (Set JID)
+    , probes :: Map JID (Set (Bool,JID))
     }
 
 connect_to_server chan peer = (>> return ()) . runMaybeT $ do
@@ -831,7 +842,11 @@ 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 from) to $ probes cache
+                    let probes' = Map.adjust (Set.insert (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
                     writeIORef cached (cache { probes=probes' })
 
     fix $ \sendmsgs -> do
@@ -873,7 +888,7 @@ goodbyePeer =
     , EventEndDocument
     ]
 
-presenceProbe sock fromjid tojid = do
+presenceProbe sock fromjid tojid typ = do
     addr <- getSocketName sock
     let jidstr jid = toStrict . L.decodeUtf8 
                       $ name jid <$++> "@" 
@@ -887,7 +902,7 @@ presenceProbe sock fromjid tojid = do
       [ EventBeginElement "{jabber:server}presence"
             [ attr "from" from
             , attr "to"   to
-            , attr "type" "probe"
+            , attr "type" typ
             ]
       , EventEndElement "{jabber:server}presence"
       ]
@@ -928,20 +943,29 @@ toPeer sock cache chan fail = do
             checkConnection cmd
             yieldOr r (fail . Just $ cmd)
             prettyPrint ">P: " r
-        sendProbe from to = do
-            r <- liftIO $ presenceProbe sock from to
+        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"
 
     send greetPeer
     forM_ (Map.assocs . presences $ cache) $ \(jid,st) -> do
         sendPresence (Presence jid st)
     forM_ (Map.assocs . probes $ cache) $ \(to,froms) -> do
-        forM_ (Set.toList froms) $ \from -> do
-            liftIO $ L.putStrLn "sending cached probe..."
-            sendProbe from to
+        forM_ (Set.toList froms) $ \(got,from) -> do
+            if got 
+              then do
+                    liftIO $ L.putStrLn "sending cached probe..."
+                    sendProbe from to
+              else do
+                    liftIO $ L.putStrLn "sending cached solicitation..."
+                    sendSolicitation from to
+
+                    
     fix $ \loop -> do
         event <- lift . atomically $ readTChan chan
         case event of
@@ -949,6 +973,9 @@ toPeer sock cache chan fail = do
           PresenceProbe from to -> do
             liftIO $ L.putStrLn "sending live probe..."
             sendProbe from to
+          Solicitation from to -> do
+            liftIO $ L.putStrLn "sending live solicitation..."
+            sendSolicitation from to
         loop
     send goodbyePeer
 
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index 2bba8614..2bad795a 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -45,7 +45,7 @@ class JabberClientSession session where
     getMyOthers        :: session -> IO [ByteString]
     getMyPending       :: session -> IO [ByteString]
     getMySolicited     :: session -> IO [ByteString]
-    addSolicited :: session -> ByteString ->  IO ()
+    addSolicited :: session -> ByteString -> JID ->  IO ()
 
 class JabberPeerSession session where
     data XMPPPeerClass session
diff --git a/Presence/main.hs b/Presence/main.hs
index bbaac97a..036d7237 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies      #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE TupleSections     #-}
 module Main where
 
 import System.Directory
@@ -196,15 +197,19 @@ instance JabberClientSession ClientSession where
             L.putStrLn $ "cached presence: " <++> bshow p
             action p
 
-    addSolicited s jid = do
-        user <- readIORef (unix_uid s) >>= getJabberUserForId
-        addJid ConfigFiles.modifySolicited user jid
+    addSolicited s jid_str jid = do
+        me <- getJID s
+        withJust (name me) $ \user -> do
+        addJid ConfigFiles.modifySolicited user jid_str
         let rchan = rosterChannel . presence_state $ s
         atomically $ do
             isempty <- isEmptyTMVar rchan
             when (not isempty) $ do
             (_,ch) <- readTMVar rchan
-            writeTChan ch (RequestedSubscription user jid)
+            writeTChan ch (RequestedSubscription user jid_str)
+        sendMessage (outGoingConnections . presence_state $ s) 
+                    (Solicitation me jid)
+                    (peer jid)
             
 
     getMyBuddies s = do
@@ -381,16 +386,20 @@ sendProbes state jid = do
         buddies <- ConfigFiles.getBuddies user
         fmap catMaybes (mapM parseHostNameJID' buddies)
     L.putStrLn $ "buddies for " <++> bshow jid <++> " = " <++> bshow buddies
+    wanted <- do
+        wanted <- ConfigFiles.getSolicited user
+        fmap catMaybes (mapM parseHostNameJID' wanted)
     remotes <- readTVarIO (remoteUsers state)
-    forM_ buddies $ \buddy -> do
+    forM_ (map (True,) buddies ++ map (False,) wanted) $ \(got,buddy) -> do
         let mjids = fmap snd $ Map.lookup (peer buddy) remotes
         jids <- maybe (return MM.empty) readTVarIO mjids
         withJust (splitResource buddy) $ \(buddyU,_) -> do
         let noinfo = not (MM.member buddyU jids)
         when noinfo $ do
-        L.putStrLn $ "sendMessage " <++> bshow (PresenceProbe jid buddy)
-        sendMessage (outGoingConnections state) (PresenceProbe jid buddy) (peer buddy) 
-        return ()
+        let msg = if got then PresenceProbe jid buddy else Solicitation jid buddy
+        L.putStrLn $ "sendMessage " <++> bshow msg
+        sendMessage (outGoingConnections state) msg (peer buddy) 
+
 
 track_login host state e = do
 #ifndef NOUTMP