1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
{-# LANGUAGE NamedFieldPuns #-}
module Network.Tox.ContactInfo where
import ConnectionKey
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 { 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)
}
mergeContact :: Contact -> Maybe Contact -> Maybe Contact
mergeContact (Contact newk newf) (Just (Contact oldk oldf)) =
Just (Contact mergek mergef)
where
mergek = 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
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 $ Contact (Just dhtpk) Nothing)
(key2id remoteUserKey)
updateAccount remoteUserKey (Onion.OnionFriendRequest fr) acc = do
modifyTVar' (contacts acc) $ HashMap.alter (mergeContact $ Contact Nothing (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
|
