3 files changed, 40 insertions, 11 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index c3e60239..2086133d 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -1006,7 +1006,7 @@ addToRosterFile ::
                  -> Text -- profile
                  -> Text -> [PeerAddress] -> t1
 addToRosterFile man doit whose profile to addrs =
-    modifyRosterFile man doit whose profile to addrs True
+    modifyRosterFile man doit whose profile to addrs True False
 
 removeFromRosterFile ::
                       Connection.Manager s Text
@@ -1019,7 +1019,7 @@ removeFromRosterFile ::
                       -> Text -- profile
                       -> Text -> [PeerAddress] -> t1
 removeFromRosterFile man doit whose profile to addrs =
-    modifyRosterFile man doit whose profile to addrs False
+    modifyRosterFile man doit whose profile to addrs False False
 
 -- | Sanity-checked roster file manipulation.  Primarily, this function handles
 -- hostname aliases.
@@ -1045,8 +1045,9 @@ modifyRosterFile ::
                   -> Text       -- ^ JID that will be added or removed a hostname
                   -> [PeerAddress] -- ^ Alias addresses for hostname in the JID.
                   -> Bool       -- ^ True if adding, otherwise False
+                  -> Bool       -- ^ True to allow deleting all users at a host.
                   -> t1
-modifyRosterFile man doit whose profile to addrs bAdd = do
+modifyRosterFile man doit whose profile to addrs bAdd bWildCard = do
     let (mu,_,_) = splitJID to
         -- For each jid in the file, this function will decide whether to keep
         -- it (possibly modified) which is indicated by Just _ or to remove the
@@ -1066,9 +1067,9 @@ modifyRosterFile man doit whose profile to addrs bAdd = do
                 guard $ isNothing mr -- delete if resource specified in file.
                 stored_u <- msu      -- delete if user not specified in file.
                 case mu of
-                    Nothing                -> Just keep    -- do not delete if /to/ has no user field
-                    Just u | u /= stored_u -> Just keep    -- do not delete if users don't match
-                    Just _                 -> Just iocheck -- do not delete unless hostname alias
+                    Nothing | not bWildCard -> Just keep    -- do not delete if /to/ has no user field
+                    Just u | u /= stored_u  -> Just keep    -- do not delete if users don't match
+                    _                       -> Just iocheck -- do not delete unless hostname alias
     doit (textToLazyByteString whose) (Text.unpack profile)
          cmp
          (guard bAdd >> Just (textToLazyByteString to))
diff --git a/ToxManager.hs b/ToxManager.hs
index 14b2070c..793a3b8a 100644
--- a/ToxManager.hs
+++ b/ToxManager.hs
@@ -9,16 +9,19 @@ module ToxManager where
 import Announcer
 import Announcer.Tox
 import ClientState
+import ConfigFiles
 import Control.Arrow
 import Control.Concurrent.STM
 import Control.Monad
 import Crypto.Tox
-import qualified Data.ByteArray              as BA
 import Data.Bits
+import qualified Data.ByteArray              as BA
 import Data.Function
 import qualified Data.HashMap.Strict         as HashMap
+import Data.List
 import qualified Data.Map                    as Map
 import Data.Maybe
+import Data.Ord
 import qualified Data.Set                    as Set
 import qualified Data.Text                   as T
          ;import Data.Text                   (Text)
@@ -56,9 +59,9 @@ import Control.Concurrent.Lifted.Instrument
 import Control.Concurrent.Lifted
 import GHC.Conc                  (labelThread)
 #endif
-import GHC.Conc                  (unsafeIOToSTM)
 import Connection
 import Connection.Tcp (TCPStatus)
+import GHC.Conc       (unsafeIOToSTM)
 
 
 toxAnnounceSendData :: Tox.Tox JabberClients
@@ -476,7 +479,8 @@ realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do
 
 
 dispatch :: ToxToXMPP -> ContactEvent -> IO ()
-dispatch tx (SessionEstablished theirKey)                    = stopConnecting tx theirKey "established"
+dispatch tx (SessionEstablished theirKey)                    = do stopConnecting tx theirKey "established"
+                                                                  updateRoster tx theirKey
 dispatch tx (SessionTerminated theirKey)                     = startConnecting tx theirKey "terminated"
 dispatch tx (AddrChange   theirKey saddr)                    = gotAddr saddr tx theirKey
 dispatch tx (PolicyChange theirkey TryingToConnect         ) = startConnecting tx theirkey "policy"
@@ -521,6 +525,30 @@ akeyConnect announcer me them =
     packAnnounceKey announcer $ "connect(" ++ (take 8 $ show me) ++ ")" ++ show (key2id them)
 
 
+
+-- | Because Tox does not have a friend-request response, we consider an
+-- established connection to be an implicit two-way subscription.
+updateRoster :: ToxToXMPP -> PublicKey -> IO ()
+updateRoster tx them = do
+    let me = toPublic $ userSecret $ txAccount tx
+        profile = T.pack $ show (key2id me) ++ ".tox"
+        jid = T.pack $ show (key2id them) ++ ".tox"
+        man = manager (txPresence tx) profile
+    addr <- do
+        u <- xor24 <$> hash24 me <*> hash24 them
+        return [ addrToPeerKey . Remote . peerAddress . uniqueAsKey $ u ]
+    mp <- atomically $ Map.lookup profile <$> readTVar (clientsByProfile $ txPresence tx)
+    forM_ mp $ \LocalPresence{networkClients} -> do
+    let css = groupBy ((==) `on` clientUser)  -- We treat all clients from a single user as one.
+              $ sortBy (comparing clientUser)
+              $ Map.elems networkClients
+    forM_ css $ \(c:_) -> do
+    let user = clientUser c
+    addToRosterFile man modifyBuddies     user profile jid addr
+    addToRosterFile man modifySubscribers user profile jid addr
+    -- Cancel friend-request sending.
+    modifyRosterFile man modifySolicited user profile jid addr False True
+
 -- | Returns a list of nospam values to use for friend requests to send to a
 -- remote peer.  This list is non-empty only when it is desirable to send
 -- friend requests.
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index d5428f93..481129b3 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1652,8 +1652,8 @@ onNewToxSession sv ssvar ContactInfo{accounts} addrTox netcrypto = do
           where
             toxSrc  :: ConduitT ()                         (Int, CryptoMessage) IO ()
             toxSnk  :: ConduitT (Maybe Int, CryptoMessage) Void                 IO ()
-            xmppSrc :: ConduitT ()                XML.Event IO ()
-            xmppSnk :: ConduitT (Flush XML.Event) Void      IO ()
+            xmppSrc :: ConduitT ()                         XML.Event            IO ()
+            xmppSnk :: ConduitT (Flush XML.Event)          Void                 IO ()
 
             toxSrc  = ioToSource (atomically $ orElse (awaitAny c)
                                                   $ aggregateStatus c >>= \case