process peer subscription approval and notify client of new buddy.

5 files changed, 143 insertions, 46 deletions

diff --git a/Presence/ConfigFiles.hs b/Presence/ConfigFiles.hs
index 32ed8b86..39442ffd 100644
--- a/Presence/ConfigFiles.hs
+++ b/Presence/ConfigFiles.hs
@@ -60,12 +60,13 @@ modifyFile ::
   -> ByteString
   -> (ByteString -> IO (Maybe ByteString))
   -> Maybe ByteString
-  -> IO ()
+  -> IO Bool -- Returns True if test function ever returned Nothing
 modifyFile (tag,file) user test appending = configPath user file >>= doit
     where
         doit path = do
-         handle (\e -> when (isDoesNotExistError e) 
-                       (createConfigFile tag path >> doit path))
+         handle (\e -> if (isDoesNotExistError e) 
+                        then (createConfigFile tag path >> doit path)
+                        else return False)
            $ do exists <- fileExist path
                 if exists
                   then do
@@ -79,12 +80,17 @@ modifyFile (tag,file) user test appending = configPath user file >>= doit
                         L.hPutStrLn h tag
                         forM_ (catMaybes keepers) (L.hPutStrLn h)
                         withJust appending (L.hPutStrLn h)
-                  else withFile path WriteMode $ \h -> do
-                         L.hPutStrLn h tag
-                         withJust appending (L.hPutStrLn h)
+                    return . not . Prelude.null $ deleted
+                  else do
+                    withFile path WriteMode $ \h -> do
+                        L.hPutStrLn h tag
+                        withJust appending (L.hPutStrLn h)
+                    return False 
 
 
-modifySolicited = modifyFile ("<? solicited ?>",solicitedFile)
+modifySolicited = modifyFile ("<? solicited ?>", solicitedFile)
+modifyBuddies   = modifyFile ("<? buddies ?>"  , buddyFile)
+modifyOthers    = modifyFile ("<? others ?>"   , otherFile)
 
 addBuddy :: User -> ByteString -> IO ()
 addBuddy user buddy =
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 ()
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index 275f644e..e05d0782 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -13,9 +13,14 @@ import Network.Socket
     , AddrInfo(..)
     , AddrInfoFlag(..)
     )
-import Network.BSD (getHostName)
+import Network.BSD 
+    ( getHostName
+    , hostName
+    , hostAliases
+    )
 import System.IO (Handle)
 import Control.Concurrent.STM (TChan)
+import qualified Data.ByteString.Char8 as S (ByteString,pack,putStr,putStrLn,append)
 import Data.ByteString.Lazy.Char8 as L  
     ( ByteString
     , unpack
@@ -23,6 +28,7 @@ import Data.ByteString.Lazy.Char8 as L
     , splitWith
     , uncons
     , takeWhile
+    , fromChunks
     )
 import Text.Show.ByteString as L
 import Data.Binary.Builder as B
@@ -30,6 +36,8 @@ import Data.Binary.Put
 import Control.DeepSeq
 import ByteStringOperators
 import SocketLike
+import GetHostByAddr
+import Data.Maybe (listToMaybe,catMaybes)
 
 class JabberClientSession session where
     data XMPPClass session
@@ -46,6 +54,7 @@ class JabberClientSession session where
     getMyPending       :: session -> IO [ByteString]
     getMySolicited     :: session -> IO [ByteString]
     addSolicited :: session -> ByteString -> JID ->  IO ()
+    isSubscribed :: session -> ByteString -> IO Bool
 
 class JabberPeerSession session where
     data XMPPPeerClass session
@@ -58,6 +67,7 @@ class JabberPeerSession session where
     sendPeerMessage  :: session -> OutBoundMessage -> IO ()
     getBuddies       :: XMPPPeerClass session -> ByteString -> IO [ByteString]
     getSubscribers   :: XMPPPeerClass session -> ByteString -> IO [ByteString]
+    processApproval  :: session -> ByteString -> JID -> IO ()
 
 -- | Jabber ID (JID) datatype
 data JID = JID { name :: Maybe ByteString
@@ -77,6 +87,9 @@ data Presence = Presence JID JabberShow
 data RosterEvent = RequestedSubscription 
                     {- user: -} ByteString 
                     {- contact: -} ByteString
+                 | NewBuddy 
+                    {- user: -} ByteString
+                    {- contact: -} ByteString
  deriving Prelude.Show
 
 data Peer = LocalHost | RemotePeer SockAddr
@@ -198,3 +211,19 @@ data OutBoundMessage = OutBoundPresence Presence
                         | Approval JID JID
  deriving Prelude.Show
 
+getNamesForPeer :: Peer -> IO [S.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
+
+
+asHostNameJID :: JID -> IO (Maybe ByteString)
+asHostNameJID jid = do
+    let n   = name jid
+        rsc = resource jid
+    names <- getNamesForPeer (peer jid)
+    let tostr p = n <$++> "@" <?++> L.fromChunks [p] <++?>  "/" <++$> rsc
+        jidstrs = fmap tostr names
+    return (listToMaybe jidstrs)
diff --git a/Presence/main.hs b/Presence/main.hs
index 303c4b05..eab02e88 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -106,14 +106,24 @@ data ClientSession = ClientSession {
     presence_state :: PresenceState
 }
 
-addJid modify user jid = do
+cmpJID newitem jid = do
+    -- putStrLn $ "Comparing "<++>bshow jid
+    olditem <- parseHostNameJID jid
+    if olditem==newitem then return Nothing
+                        else return $ Just jid
+
+
+addRawJid modify user jid = do
     newitem <- parseHostNameJID jid
-    let cmp jid = do
-            -- putStrLn $ "Comparing "<++>bshow jid
-            olditem <- parseHostNameJID jid
-            if olditem==newitem then return Nothing
-                                else return $ Just jid
-    modify user cmp (Just jid)
+    modify user (cmpJID newitem) (Just jid)
+    return ()
+
+addJid modify user jid = do
+    hjid <- asHostNameJID jid
+    putStrLn $ "addJid (asHostNameJID) --> "<++>bshow hjid
+    withJust hjid $ \hjid -> do
+    modify user (cmpJID jid) (Just hjid)
+    return ()
 
 instance JabberClientSession ClientSession where
     data XMPPClass ClientSession = ClientSessions PresenceState
@@ -200,7 +210,7 @@ instance JabberClientSession ClientSession where
     addSolicited s jid_str jid = do
         me <- getJID s
         withJust (name me) $ \user -> do
-        addJid ConfigFiles.modifySolicited user jid_str
+        addRawJid ConfigFiles.modifySolicited user jid_str
         let rchan = rosterChannel . presence_state $ s
         atomically $ do
             isempty <- isEmptyTMVar rchan
@@ -228,6 +238,14 @@ instance JabberClientSession ClientSession where
         user <- readIORef (unix_uid s) >>= getJabberUserForId
         ConfigFiles.getSolicited user
 
+    isSubscribed s contact = do
+        handleIO (\e -> return False) $ do
+        user <- readIORef (unix_uid s) >>= getJabberUserForId
+        subs <- ConfigFiles.getSubscribers user
+        putStrLn $ "isSubscribed parsing: "<++>contact
+        cjid <- parseHostNameJID contact
+        msubs <- mapM (cmpJID cjid) subs
+        return (Nothing `elem` msubs)
 
 tupleToJID (user,tty,pid) = jid user LocalHost tty
 
@@ -295,6 +313,25 @@ instance JabberPeerSession PeerSession where
     getBuddies     _ user = ConfigFiles.getBuddies user
     getSubscribers _ user = ConfigFiles.getSubscribers user
 
+    processApproval session user buddy = do
+        solicited <- ConfigFiles.getSolicited user
+        let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
+        was_sol <- rmjid ConfigFiles.modifySolicited user buddy
+        putStrLn $ "was_sol = "<++>bshow was_sol
+        when was_sol $ do -- if buddy ∈ solicited:
+        addJid ConfigFiles.modifyBuddies user buddy --   add buddies
+        rmjid ConfigFiles.modifyOthers user buddy --   remove others
+        let rchan = rosterChannel . peer_global $ session
+        mbuddy <- asHostNameJID buddy
+        withJust mbuddy $ \buddy -> do
+        atomically $ do
+            isempty <- isEmptyTMVar rchan
+            when (not isempty) $ do
+            (_,ch) <- readTMVar rchan
+            writeTChan ch (NewBuddy user buddy)
+        return ()
+        
+
 
 data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a))
 
diff --git a/b b/b
index 88474475..a116163e 100755
--- a/b
+++ b/b
@@ -1,5 +1,5 @@
 #!/bin/bash
-args="-O2 -fwarn-unused-imports -rtsopts -DRENDERFLUSH"
+args="-fwarn-unused-imports -rtsopts -DRENDERFLUSH"
 
 root=${0%/*}
 cd "$root"