{-# LANGUAGE NamedFieldPuns #-} module Network.Tox.ContactInfo where import ConnectionKey import Connection import Control.Concurrent.STM import Control.Monad import Crypto.PubKey.Curve25519 import qualified Data.HashMap.Strict as HashMap ;import Data.HashMap.Strict (HashMap) import Data.Maybe import qualified Data.Set as Set ;import Data.Set (Set) import Network.Tox.DHT.Transport as DHT import Network.Tox.NodeId import Network.Tox.Onion.Transport as Onion import System.IO 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 , contacts :: TVar (HashMap NodeId Contact) -- received contact info , clientRefs :: TVar (Set ConnectionKey) } 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 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 = 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 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) updateContactInfo :: ContactInfo -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO () updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do hPutStrLn stderr "updateContactInfo!!!" atomically $ do as <- readTVar (accounts roster) maybe (return ()) (updateAccount remoteUserKey omsg) $ HashMap.lookup (key2id localUserKey) as updateAccount :: PublicKey -> Onion.OnionData -> Account -> STM () updateAccount remoteUserKey (Onion.OnionDHTPublicKey dhtpk) acc = do 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 nullContact { contactFriendRequest = Just fr }) (key2id remoteUserKey) dnsPresentation :: ContactInfo -> STM String dnsPresentation (ContactInfo accsvar) = do accs <- readTVar accsvar ms <- forM accs $ \Account { userSecret = sec, contacts = cvar } -> do cs <- readTVar cvar return $ "; local key = " ++ show (key2id $ toPublic sec) ++ "\n" ++ concatMap dnsPresentation1 (mapMaybe (\(nid,m) -> ((,) nid) <$> contactKeyPacket m) $ HashMap.toList cs) return $ concat ms dnsPresentation1 :: (NodeId,DHTPublicKey) -> String dnsPresentation1 (nid,dk) = unlines [ concat [ show nid, ".tox. IN CNAME ", show (key2id $ dhtpk dk), ".dht." ] ] type LocalKey = NodeId type RemoteKey = NodeId friendRequests :: ContactInfo -> STM (HashMap LocalKey [(RemoteKey,DHT.FriendRequest)]) 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