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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
module Network.Tox.ContactInfo where
import Connection
import Data.Time.Clock.POSIX
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 Network.Tox.DHT.Transport as DHT
import Network.Tox.NodeId (id2key)
import Network.Tox.Onion.Transport as Onion
import DPut
import DebugTag
newtype ContactInfo extra = ContactInfo
-- | Map our toxid public key to an Account record.
{ accounts :: TVar (HashMap NodeId{-my userkey-} (Account extra))
}
data Account extra = Account
{ userSecret :: SecretKey -- local secret key
, contacts :: TVar (HashMap NodeId{-friend's userkey-} Contact) -- received contact info
, accountExtra :: TVar extra
, eventChan :: TChan ContactEvent
}
data ContactEvent = OnionRouted { contact :: PublicKey, onionRouted :: OnionData }
| PolicyChange { contact :: PublicKey, policyChange :: Policy }
| AddrChange { contact :: PublicKey, addrChange :: NodeInfo }
| SessionEstablished { contact :: PublicKey }
| SessionTerminated { contact :: PublicKey }
data Contact = Contact
{ contactKeyPacket :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey))
, contactLastSeenAddr :: TVar (Maybe (POSIXTime,NodeInfo))
, contactFriendRequest :: TVar (Maybe (POSIXTime,DHT.FriendRequest))
, contactPolicy :: TVar (Maybe Connection.Policy)
}
newContactInfo :: IO (ContactInfo extra)
newContactInfo = atomically $ ContactInfo <$> newTVar HashMap.empty
myKeyPairs :: ContactInfo extra -> STM [(SecretKey,PublicKey)]
myKeyPairs (ContactInfo accounts) = do
acnts <- readTVar accounts
forM (HashMap.toList acnts) $ \(nid, Account{userSecret}) -> do
return (userSecret,id2key nid)
updateContactInfo :: ContactInfo extra -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO ()
updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do
dput XMisc "updateContactInfo!!!"
now <- getPOSIXTime
atomically $ do
as <- readTVar (accounts roster)
maybe (return ())
(updateAccount now remoteUserKey omsg)
$ HashMap.lookup (key2id localUserKey) as
initContact :: STM Contact
initContact = Contact <$> newTVar Nothing
<*> newTVar Nothing
<*> newTVar Nothing
<*> newTVar Nothing
getContact :: PublicKey -> Account extra -> STM (Maybe Contact)
getContact remoteUserKey acc = do
let rkey = key2id remoteUserKey
cmap <- readTVar (contacts acc)
return $ HashMap.lookup rkey cmap
updateAccount' :: PublicKey -> Account extra -> (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 :: POSIXTime -> PublicKey -> Onion.OnionData -> Account extra -> STM ()
updateAccount now remoteUserKey omsg acc = do
updateAccount' remoteUserKey acc $ onionUpdate now omsg
writeTChan (eventChan acc) $ OnionRouted remoteUserKey omsg
onionUpdate :: POSIXTime -> OnionData -> Contact -> STM ()
onionUpdate now (Onion.OnionDHTPublicKey dhtpk) contact
= writeTVar (contactKeyPacket contact) $ Just (now,dhtpk)
onionUpdate now (Onion.OnionFriendRequest fr) contact
= writeTVar (contactFriendRequest contact) $ Just (now,fr)
policyUpdate :: Policy -> Contact -> STM ()
policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy
addrUpdate :: POSIXTime -> NodeInfo -> Contact -> STM ()
addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr)
setContactPolicy :: PublicKey -> Policy -> Account extra -> STM ()
setContactPolicy remoteUserKey policy acc = do
updateAccount' remoteUserKey acc $ policyUpdate policy
writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy
setContactAddr :: POSIXTime -> PublicKey -> NodeInfo -> Account extra -> STM ()
setContactAddr now remoteUserKey addr acc = do
contact <- getContact remoteUserKey acc
let update = updateAccount' remoteUserKey acc $ addrUpdate now addr
let notify = writeTChan (eventChan acc) $ AddrChange remoteUserKey addr
join <$> traverse (readTVar . contactLastSeenAddr) contact >>= \case
Just (_, a) | addr == a -> update -- updates time only
Just (t, _) | now > t + 60 -> update >> notify -- update IP if existing one is old
Nothing -> update >> notify -- or if we don't have any
_ -> return () -- otherwise just wait
setEstablished :: PublicKey -> Account extra -> STM ()
setEstablished remoteUserKey acc =
writeTChan (eventChan acc) $ SessionEstablished remoteUserKey
setTerminated :: PublicKey -> Account extra -> STM ()
setTerminated remoteUserKey acc =
writeTChan (eventChan acc) $ SessionTerminated remoteUserKey
addContactInfo :: ContactInfo extra -> SecretKey -> extra -> STM ()
addContactInfo (ContactInfo as) sk extra = do
a <- newAccount sk extra
modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a
delContactInfo :: ContactInfo extra -> PublicKey -> STM ()
delContactInfo (ContactInfo as) pk = modifyTVar' as $ HashMap.delete (key2id pk)
newAccount :: SecretKey -> extra -> STM (Account extra)
newAccount sk extra = Account sk <$> newTVar HashMap.empty
<*> newTVar extra
<*> newBroadcastTChan
dnsPresentation :: ContactInfo extra -> 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 (\(_,d) -> (nid,d)) mkpkt
return $
"; local key = " ++ show (key2id $ toPublic sec) ++ "\n"
++ concatMap dnsPresentation1 (catMaybes rs)
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 extra -> STM (HashMap LocalKey [(RemoteKey,DHT.FriendRequest)])
friendRequests (ContactInfo roster) = do
accs <- readTVar roster
forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
cs <- readTVar cvar
rs <- forM (HashMap.toList cs) $ \(nid,c) -> do
mfr <- readTVar (contactFriendRequest c)
return $ fmap (\(_,x) -> (nid,x)) mfr
return $ catMaybes rs
|
