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
|
{-# 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
import Network.Socket
newtype ContactInfo = ContactInfo
-- | Map our toxid public key to an Account record.
{ accounts :: TVar (HashMap NodeId{-my userkey-} Account)
}
data Account = Account
{ userSecret :: SecretKey -- local secret key
, contacts :: TVar (HashMap NodeId{-friend's userkey-} Contact) -- received contact info
, clientRefs :: TVar (Set ConnectionKey) -- reference count so we know when to send offline etc
}
data Contact = Contact
{ contactKeyPacket :: Maybe (DHT.DHTPublicKey)
, contactLastSeenAddr :: Maybe SockAddr
, contactFriendRequest :: Maybe (DHT.FriendRequest)
, contactPolicy :: Maybe (Connection.Policy)
-- Possible semantics
-- RefusingToConnect : rejected friend-request or blocked.
-- OpenToConnect : pending friend-request.
-- TryingToConnect : roster entry.
}
nullContact :: Contact
nullContact = Contact
{ contactKeyPacket = 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
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
|
