1 files changed, 54 insertions, 29 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index e4f60712..9190ee3c 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -76,7 +76,6 @@ 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)
-import GetHostByAddr
 import Data.Monoid
 import qualified Data.Sequence as Seq
 import Data.Foldable (toList)
@@ -106,13 +105,6 @@ data Commands =
     | QuitThread 
  deriving Prelude.Show
 
-getNamesForPeer :: Peer -> IO [ByteString]
-getNamesForPeer LocalHost = fmap ((:[]) . S.pack) getHostName
-getNamesForPeer peer@(RemotePeer addr) = do
-    ent <- getHostByAddr addr --  AF_UNSPEC addr
-    let names = hostName ent : hostAliases ent
-    return . map S.pack $ names
-
 
 xmlifyPresenceForClient :: Presence -> IO [XML.Event]
 xmlifyPresenceForClient (Presence jid stat) = do
@@ -343,7 +335,9 @@ iq_service_unavailable host iq_id mjid req =
     , EventEndElement "{jabber:client}iq"
     ]
 
-attr name value = (name,[ContentText value])
+attr   name value = (name,[ContentText value])
+attrbs name value = (name,[ContentText (toStrict . L.decodeUtf8 $ value)])
+
 
 getRoster session iqid = do
     let getlist f = do
@@ -524,6 +518,25 @@ toClient session pchan cmdChan rchan = toClient' False False
             r <- liftIO $ rosterPush jid (toStrict . L.decodeUtf8 $ contact) [attr "ask" "subscribe"]
             send r
         loop
+      RChan   (NewBuddy who contact) ->  do
+        liftIO . putStrLn $ "Roster push: NewBuddy "++show (isInterested,who,contact)
+        jid <- liftIO $ getJID session
+        when (isInterested && Just who==name jid) $ do
+            send [ EventBeginElement "{jabber:client}presence" 
+                    [ attrbs "from" contact
+                    , attrbs "to"   (L.show jid)
+                    , attr   "type" "subscribed"
+                    ]
+                 , EventEndElement "{jabber:client}presence" ]
+            let f True  = "from"
+                f False = "to"
+            subscription <- fmap f (liftIO $ isSubscribed session contact)
+            r <- liftIO . handleIO (\e -> putStrLn ("Roster NewBuddy error: "++show e) >> return []) $ do
+                            rosterPush jid 
+                                     (toStrict . L.decodeUtf8 $ contact) 
+                                     [attr "subscription" subscription]
+            send r
+        loop
       PChan presence   -> do 
         when isBound $ do
             xs <- liftIO $ xmlifyPresenceForClient presence
@@ -552,7 +565,7 @@ handleClient st src snk = do
                     =$= discardFlush 
                      =$ snk )
 #else
-    writer <- async ( toClient pchan cmdChan $$ renderChunks =$ snk )
+    writer <- async ( toClient session pchan cmdChan rchan $$ renderChunks =$ snk )
 #endif
     finally         ( src $= parseBytes def $$ fromClient session cmdChan )
         $ do
@@ -752,31 +765,45 @@ clientRequestsSubscription session cmdChan stanza = do
                 atomically $ writeTChan cmdChan (Send r)
     return ()
 
+
+stanzaFromTo ::
+  JabberPeerSession session =>
+  session -> Event -> IO (Maybe (JID, JID))
+stanzaFromTo session stanza = 
+    let lookup key = fmap textToByteString (lookupAttrib key (tagAttrs stanza))
+        parse jidstr =  handleIO_ (return Nothing) (fmap Just $ parseAddressJID jidstr)
+    in case liftM2 (,) (lookup "from") (lookup "to") of
+        Nothing -> return Nothing
+        Just (from,to) ->  do
+            mfrom <- parse from
+            mto   <- parse to
+            case liftM2 (,) mfrom mto of
+                Nothing -> return Nothing
+                Just (from,to) -> do
+                    let fromjid = JID (name from) (peerAddress session) Nothing
+                    return $ Just (fromjid,to)
+
 peerRequestsSubsription session stanza = do
     liftIO $ putStrLn $ "PEER PRESENCE SUBSCRIBE " ++ show stanza
-    withJust (lookupAttrib "from" (tagAttrs stanza)) $ \from0-> do
-    withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to0 -> do
-    let to = textToByteString to0
-        from = textToByteString from0
-        factory = peerSessionFactory session
-    mjid <- liftIO $  handleIO_ (return Nothing) (fmap Just $ parseAddressJID to)
-    mfrom <- liftIO $  handleIO_ (return Nothing) (fmap Just $ parseAddressJID from)
-    withJust (mfrom >>= name) $ \from -> do
-    withJust mjid $ \tojid -> do
+
+    whenJust (liftIO . handleIO (\e -> putStrLn ("peerRequestsSubsription: "++show e) >> return Nothing) 
+                $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
     withJust (name tojid) $ \user -> do
+
     subs <- liftIO $ do
-             subs <- getSubscribers factory user
+             subs <- getSubscribers (peerSessionFactory session) user
              msubs <- flip mapM subs $ \str -> do
                         handleIO_ (return Nothing) 
                                   (fmap Just $ parseHostNameJID str)
              return (catMaybes msubs)
-    let peer = peerAddress session
-        fromjid = JID (Just from) peer Nothing
     if elem fromjid subs
       then do
         liftIO . L.putStrLn $ bshow fromjid <++> " already subscribed to " <++> user
         -- if already subscribed, reply
-        liftIO $ sendPeerMessage session (Approval tojid fromjid)
+        liftIO $ do
+             sendPeerMessage session (Approval tojid fromjid)
+             ps <- userStatus session user
+             mapM_ (announcePresence session) ps
       else
         -- TODO
         -- if no client:
@@ -796,12 +823,10 @@ clientApprovesSubscription session stanza = do
 
 peerApprovesSubscription session stanza = do
     liftIO $ putStrLn $ "PEER APPROVES SUBSCRIPTION"
-    -- if solicited:
-    --   add buddies
-    --   remove others
-    --   remove solicited
-    --   notify client
-    return ()
+    whenJust (liftIO . handleIO (\e -> putStrLn ("peerApprovesSubscription: "++show e) >> return Nothing) 
+             $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
+    withJust (name tojid) $ \user -> do
+    liftIO $ processApproval session user fromjid
 
 fromPeer :: (MonadThrow m,MonadIO m, JabberPeerSession session) => 
     session -> Sink XML.Event m ()