send subscription requests to remote peers

1 files changed, 53 insertions, 26 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