1 files changed, 63 insertions, 67 deletions

diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs
index df3365a2..7f74caff 100644
--- a/src/Network/Tox/ContactInfo.hs
+++ b/src/Network/Tox/ContactInfo.hs
@@ -35,55 +35,24 @@ data ContactEvent = OnionRouted  { contact :: PublicKey, onionRouted :: OnionDat
                   | AddrChange   { contact :: PublicKey, addrChange :: SockAddr }
 
 data Contact = Contact
-    { contactKeyPacket     :: Maybe (DHT.DHTPublicKey)
-    , contactLastSeenAddr  :: Maybe SockAddr
-    , contactFriendRequest :: Maybe (DHT.FriendRequest)
-    , contactPolicy        :: Maybe (Connection.Policy)
+    { contactKeyPacket     :: TVar (Maybe (DHT.DHTPublicKey))
+    , contactLastSeenAddr  :: TVar (Maybe SockAddr)
+    , contactFriendRequest :: TVar (Maybe (DHT.FriendRequest))
+    , contactPolicy        :: TVar (Maybe (Connection.Policy))
         -- Possible semantics
         --  RefusingToConnect : rejected friend-request or blocked or unknown.
         --  OpenToConnect     : pending friend-request.
         --  TryingToConnect   : roster entry.
     }
 
-nullContact :: Contact
-nullContact = Contact
-    { contactKeyPacket     = Nothing
-    , contactLastSeenAddr  = Nothing
-    , contactFriendRequest = Nothing
-    , contactPolicy        = Nothing
-    }
-
-mergeContact :: Contact -> Maybe Contact -> Maybe Contact
-mergeContact (Contact newk news newf newp) (Just (Contact oldk olds oldf oldp)) =
-    Just $ Contact mergek -- Prefer newer public key packet as long as its stamp
-                          -- is later than the stored one.
-                  (mplus news olds) -- Prefer newer last-seen
-                  (mplus newf oldf) -- Prefer newer friend request.
-                  (mplus newp oldp) -- Prefer newer connection policy.
- where
-    mergek = flip mplus oldk $ do
-        n <- newk
-        stamp <- fmap DHT.dhtpkNonce oldk `mplus` return minBound
-        guard (stamp <= DHT.dhtpkNonce n)
-        return n
-
-mergeContact new Nothing = Just new
-
 newContactInfo :: IO ContactInfo
 newContactInfo = atomically $ ContactInfo <$> newTVar HashMap.empty
 
-newAccount :: SecretKey -> STM Account
-newAccount sk = Account sk <$> newTVar HashMap.empty
-                           <*> newTVar Set.empty
-                           <*> newBroadcastTChan
-
-addContactInfo :: ContactInfo -> SecretKey -> STM ()
-addContactInfo (ContactInfo as) sk = do
-    a <- newAccount sk
-    modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a
-
-delContactInfo :: ContactInfo -> PublicKey -> STM ()
-delContactInfo (ContactInfo as) pk = modifyTVar' as $ HashMap.delete (key2id pk)
+myKeyPairs :: ContactInfo -> STM [(SecretKey,PublicKey)]
+myKeyPairs (ContactInfo accounts) = do
+    acnts <- readTVar accounts
+    forM (HashMap.toList acnts) $ \(nid, Account{userSecret}) -> do
+        return (userSecret,id2key nid)
 
 updateContactInfo :: ContactInfo -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO ()
 updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do
@@ -94,44 +63,76 @@ updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,
               (updateAccount remoteUserKey omsg)
               $ HashMap.lookup (key2id localUserKey) as
 
-
-onionUpdate :: OnionData -> Maybe Contact -> Maybe Contact
-onionUpdate (Onion.OnionDHTPublicKey dhtpk)
-                = mergeContact nullContact { contactKeyPacket     = Just dhtpk }
-onionUpdate (Onion.OnionFriendRequest fr)
-                = mergeContact nullContact { contactFriendRequest = Just fr    }
-
-policyUpdate :: Policy -> Maybe Contact -> Maybe Contact
-policyUpdate policy = mergeContact nullContact { contactPolicy = Just policy }
-
-addrUpdate :: SockAddr -> Maybe Contact -> Maybe Contact
-addrUpdate addr = mergeContact nullContact { contactLastSeenAddr = Just addr }
+initContact :: STM Contact
+initContact = Contact <$> newTVar Nothing
+                      <*> newTVar Nothing
+                      <*> newTVar Nothing
+                      <*> newTVar Nothing
+
+updateAccount' :: PublicKey -> Account -> (Contact -> STM ()) -> STM ()
+updateAccount' remoteUserKey acc updater = do
+    let rkey = key2id remoteUserKey
+    cmap <- readTVar (contacts acc)
+    contact <- case HashMap.lookup rkey cmap of
+        Just contact -> return contact
+        Nothing      -> do contact <- initContact
+                           writeTVar (contacts acc) $ HashMap.insert rkey contact cmap
+                           return contact
+    updater contact
 
 updateAccount :: PublicKey -> Onion.OnionData -> Account -> STM ()
 updateAccount remoteUserKey omsg acc = do
-    modifyTVar' (contacts acc) $ HashMap.alter (onionUpdate omsg) (key2id remoteUserKey)
+    updateAccount' remoteUserKey acc $ onionUpdate omsg
     writeTChan (eventChan acc) $ OnionRouted remoteUserKey omsg
 
+onionUpdate :: OnionData -> Contact -> STM ()
+onionUpdate (Onion.OnionDHTPublicKey dhtpk) contact
+                = writeTVar (contactKeyPacket contact)     $ Just dhtpk
+onionUpdate (Onion.OnionFriendRequest fr)   contact
+                = writeTVar (contactFriendRequest contact) $ Just fr
+
+policyUpdate :: Policy -> Contact -> STM ()
+policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy
+
+addrUpdate :: SockAddr -> Contact -> STM ()
+addrUpdate addr contact = writeTVar (contactLastSeenAddr contact) $ Just addr
+
 setContactPolicy :: PublicKey -> Policy -> Account -> STM ()
 setContactPolicy remoteUserKey policy acc = do
-    modifyTVar' (contacts acc) $ HashMap.alter (policyUpdate policy) (key2id remoteUserKey)
+    updateAccount' remoteUserKey acc $ policyUpdate policy
     writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy
 
 setContactAddr :: PublicKey -> SockAddr -> Account -> STM ()
 setContactAddr remoteUserKey addr acc = do
-    modifyTVar' (contacts acc) $ HashMap.alter (addrUpdate addr) (key2id remoteUserKey)
+    updateAccount' remoteUserKey acc $ addrUpdate addr
     writeTChan (eventChan acc) $ AddrChange remoteUserKey addr
 
+
+
+addContactInfo :: ContactInfo -> SecretKey -> STM ()
+addContactInfo (ContactInfo as) sk = do
+    a <- newAccount sk
+    modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a
+
+delContactInfo :: ContactInfo -> PublicKey -> STM ()
+delContactInfo (ContactInfo as) pk = modifyTVar' as $ HashMap.delete (key2id pk)
+
+newAccount :: SecretKey -> STM Account
+newAccount sk = Account sk <$> newTVar HashMap.empty
+                           <*> newTVar Set.empty
+                           <*> newBroadcastTChan
+
 dnsPresentation :: ContactInfo -> STM String
 dnsPresentation (ContactInfo accsvar) = do
     accs <- readTVar accsvar
     ms <- forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
         cs <- readTVar cvar
+        rs <- forM (HashMap.toList cs) $ \(nid,c) -> do
+            mkpkt <- readTVar (contactKeyPacket c)
+            return $ fmap ((,) nid) mkpkt
         return $
             "; local key = " ++ show (key2id $ toPublic sec) ++ "\n"
-             ++ concatMap dnsPresentation1
-                          (mapMaybe (\(nid,m) -> ((,) nid) <$> contactKeyPacket m)
-                                    $ HashMap.toList cs)
+             ++ concatMap dnsPresentation1 (catMaybes rs)
     return $ concat ms
 
 dnsPresentation1 :: (NodeId,DHTPublicKey) -> String
@@ -147,13 +148,8 @@ friendRequests (ContactInfo roster) = do
     accs <- readTVar roster
     forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
         cs <- readTVar cvar
-        let remotes = mapMaybe (\(nid,m) -> ((,) nid) <$> contactFriendRequest m)
-                               $ HashMap.toList cs
-        return remotes
-
-myKeyPairs :: ContactInfo -> STM [(SecretKey,PublicKey)]
-myKeyPairs (ContactInfo accounts) = do
-    acnts <- readTVar accounts
-    forM (HashMap.toList acnts) $ \(nid, Account{userSecret}) -> do
-        return (userSecret,id2key nid)
+        rs <- forM (HashMap.toList cs) $ \(nid,c) -> do
+            mfr <- readTVar (contactFriendRequest c)
+            return $ fmap ((,) nid) mfr
+        return $ catMaybes rs