From 82fb11604685273a2071e75f725280dfed884730 Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 15 Jun 2018 20:41:56 -0400 Subject: tox: Converted Contact struct to use TVar fields. --- src/Network/Tox/ContactInfo.hs | 130 ++++++++++++++++++++--------------------- 1 file changed, 63 insertions(+), 67 deletions(-) (limited to 'src/Network/Tox/ContactInfo.hs') 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 -- cgit v1.2.3