2 files changed, 40 insertions, 11 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 04de4056..8fc986a5 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1078,8 +1078,20 @@ toxman tox = ToxManager
             --      Stop the recurring search for that contact
             return ()
     , setToxConnectionPolicy = \me them -> \case
-        TryingToConnect -> return () -- Add a contact.
-        _               -> return () -- Remove contact.
+        TryingToConnect -> do
+            let db@ContactInfo{ accounts } = Tox.toxContactInfo tox
+            sequence_ $ do
+            meid   <- readMaybe $ T.unpack $ T.take 43 me
+            themid <- readMaybe $ T.unpack $ T.take 43 them
+            Just $ atomically $ do
+            accs <- readTVar accounts
+            case HashMap.lookup meid accs of
+                Nothing  -> return () -- Unknown account.
+                Just acc -> modifyTVar' (contacts acc)
+                    $ HashMap.alter (mergeContact nullContact { contactPolicy = Just TryingToConnect })
+                                    themid
+            -- If unscheduled and unconnected, schedule recurring search for this contact.
+        _ -> return () -- Remove contact.
     }
 
 #ifdef XMPP
diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs
index 0d8a9f8a..6cadc944 100644
--- a/src/Network/Tox/ContactInfo.hs
+++ b/src/Network/Tox/ContactInfo.hs
@@ -2,6 +2,7 @@
 module Network.Tox.ContactInfo where
 
 import ConnectionKey
+import Connection
 
 import Control.Concurrent.STM
 import Control.Monad
@@ -16,7 +17,10 @@ import Network.Tox.NodeId
 import Network.Tox.Onion.Transport   as Onion
 import System.IO
 
-newtype ContactInfo = ContactInfo { accounts :: TVar (HashMap NodeId Account) }
+newtype ContactInfo = ContactInfo
+      -- | Map our toxid public key to an Account record.
+    { accounts :: TVar (HashMap NodeId Account)
+    }
 
 data Account = Account
     { userSecret :: SecretKey                     -- local secret key
@@ -27,18 +31,29 @@ data Account = Account
 data Contact = Contact
     { contactKeyPacket     :: Maybe (DHT.DHTPublicKey)
     , contactFriendRequest :: Maybe (DHT.FriendRequest)
+    , contactPolicy        :: Maybe (Connection.Policy)
+    }
+
+nullContact :: Contact
+nullContact = Contact
+    { contactKeyPacket     = Nothing
+    , contactFriendRequest = Nothing
+    , contactPolicy        = Nothing
     }
 
 mergeContact :: Contact -> Maybe Contact -> Maybe Contact
-mergeContact (Contact newk newf) (Just (Contact oldk oldf)) =
-    Just (Contact mergek mergef)
+mergeContact (Contact newk newf newp) (Just (Contact oldk oldf oldp)) =
+    Just $ Contact mergek -- Prefer newer public key packet as long as its stamp
+                          -- is later than the stored one.
+                  (mplus newf oldf) -- Prefer newer friend request.
+                  (mplus newp oldp) -- Prefer newer connection policy.
  where
-    mergek = mplus oldk $ do
+    mergek = flip mplus oldk $ do
         n <- newk
         stamp <- fmap DHT.dhtpkNonce oldk `mplus` return minBound
         guard (stamp <= DHT.dhtpkNonce n)
         return n
-    mergef = mplus oldf newf
+
 mergeContact new Nothing = Just new
 
 newContactInfo :: IO ContactInfo
@@ -68,12 +83,14 @@ updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,
 
 updateAccount :: PublicKey -> Onion.OnionData -> Account -> STM ()
 updateAccount remoteUserKey (Onion.OnionDHTPublicKey dhtpk) acc = do
-    modifyTVar' (contacts acc) $ HashMap.alter (mergeContact $ Contact (Just dhtpk) Nothing)
-                                               (key2id remoteUserKey)
+    modifyTVar' (contacts acc)
+        $ HashMap.alter (mergeContact nullContact { contactKeyPacket = Just dhtpk })
+                        (key2id remoteUserKey)
 
 updateAccount remoteUserKey (Onion.OnionFriendRequest fr) acc = do
-    modifyTVar' (contacts acc) $ HashMap.alter (mergeContact $ Contact Nothing (Just fr))
-                                               (key2id remoteUserKey)
+    modifyTVar' (contacts acc)
+        $ HashMap.alter (mergeContact nullContact { contactFriendRequest = Just fr })
+                        (key2id remoteUserKey)
 
 dnsPresentation :: ContactInfo -> STM String
 dnsPresentation (ContactInfo accsvar) = do