summaryrefslogtreecommitdiff
path: root/src/Network/Tox/ContactInfo.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/Tox/ContactInfo.hs')
-rw-r--r--src/Network/Tox/ContactInfo.hs172
1 files changed, 0 insertions, 172 deletions
diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs
deleted file mode 100644
index e7cb48c1..00000000
--- a/src/Network/Tox/ContactInfo.hs
+++ /dev/null
@@ -1,172 +0,0 @@
1{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE LambdaCase #-}
3module Network.Tox.ContactInfo where
4
5import Connection
6
7import Data.Time.Clock.POSIX
8import Control.Concurrent.STM
9import Control.Monad
10import Crypto.PubKey.Curve25519
11import qualified Data.HashMap.Strict as HashMap
12 ;import Data.HashMap.Strict (HashMap)
13import Data.Maybe
14import Network.Tox.DHT.Transport as DHT
15import Network.Tox.NodeId (id2key)
16import Network.Tox.Onion.Transport as Onion
17import DPut
18import DebugTag
19
20newtype ContactInfo extra = ContactInfo
21 -- | Map our toxid public key to an Account record.
22 { accounts :: TVar (HashMap NodeId{-my userkey-} (Account extra))
23 }
24
25data Account extra = Account
26 { userSecret :: SecretKey -- local secret key
27 , contacts :: TVar (HashMap NodeId{-friend's userkey-} Contact) -- received contact info
28 , accountExtra :: TVar extra
29 , eventChan :: TChan ContactEvent
30 }
31
32data ContactEvent = OnionRouted { contact :: PublicKey, onionRouted :: OnionData }
33 | PolicyChange { contact :: PublicKey, policyChange :: Policy }
34 | AddrChange { contact :: PublicKey, addrChange :: NodeInfo }
35 | SessionEstablished { contact :: PublicKey }
36 | SessionTerminated { contact :: PublicKey }
37
38data Contact = Contact
39 { contactKeyPacket :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey))
40 , contactLastSeenAddr :: TVar (Maybe (POSIXTime,NodeInfo))
41 , contactFriendRequest :: TVar (Maybe (POSIXTime,DHT.FriendRequest))
42 , contactPolicy :: TVar (Maybe Connection.Policy)
43 }
44
45newContactInfo :: IO (ContactInfo extra)
46newContactInfo = atomically $ ContactInfo <$> newTVar HashMap.empty
47
48myKeyPairs :: ContactInfo extra -> STM [(SecretKey,PublicKey)]
49myKeyPairs (ContactInfo accounts) = do
50 acnts <- readTVar accounts
51 forM (HashMap.toList acnts) $ \(nid, Account{userSecret}) -> do
52 return (userSecret,id2key nid)
53
54updateContactInfo :: ContactInfo extra -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO ()
55updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do
56 dput XMisc "updateContactInfo!!!"
57 now <- getPOSIXTime
58 atomically $ do
59 as <- readTVar (accounts roster)
60 maybe (return ())
61 (updateAccount now remoteUserKey omsg)
62 $ HashMap.lookup (key2id localUserKey) as
63
64initContact :: STM Contact
65initContact = Contact <$> newTVar Nothing
66 <*> newTVar Nothing
67 <*> newTVar Nothing
68 <*> newTVar Nothing
69
70getContact :: PublicKey -> Account extra -> STM (Maybe Contact)
71getContact remoteUserKey acc = do
72 let rkey = key2id remoteUserKey
73 cmap <- readTVar (contacts acc)
74 return $ HashMap.lookup rkey cmap
75
76updateAccount' :: PublicKey -> Account extra -> (Contact -> STM ()) -> STM ()
77updateAccount' remoteUserKey acc updater = do
78 let rkey = key2id remoteUserKey
79 cmap <- readTVar (contacts acc)
80 contact <- case HashMap.lookup rkey cmap of
81 Just contact -> return contact
82 Nothing -> do contact <- initContact
83 writeTVar (contacts acc) $ HashMap.insert rkey contact cmap
84 return contact
85 updater contact
86
87updateAccount :: POSIXTime -> PublicKey -> Onion.OnionData -> Account extra -> STM ()
88updateAccount now remoteUserKey omsg acc = do
89 updateAccount' remoteUserKey acc $ onionUpdate now omsg
90 writeTChan (eventChan acc) $ OnionRouted remoteUserKey omsg
91
92onionUpdate :: POSIXTime -> OnionData -> Contact -> STM ()
93onionUpdate now (Onion.OnionDHTPublicKey dhtpk) contact
94 = writeTVar (contactKeyPacket contact) $ Just (now,dhtpk)
95onionUpdate now (Onion.OnionFriendRequest fr) contact
96 = writeTVar (contactFriendRequest contact) $ Just (now,fr)
97
98policyUpdate :: Policy -> Contact -> STM ()
99policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy
100
101addrUpdate :: POSIXTime -> NodeInfo -> Contact -> STM ()
102addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr)
103
104setContactPolicy :: PublicKey -> Policy -> Account extra -> STM ()
105setContactPolicy remoteUserKey policy acc = do
106 updateAccount' remoteUserKey acc $ policyUpdate policy
107 writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy
108
109setContactAddr :: POSIXTime -> PublicKey -> NodeInfo -> Account extra -> STM ()
110setContactAddr now remoteUserKey addr acc = do
111 contact <- getContact remoteUserKey acc
112 let update = updateAccount' remoteUserKey acc $ addrUpdate now addr
113 let notify = writeTChan (eventChan acc) $ AddrChange remoteUserKey addr
114 join <$> traverse (readTVar . contactLastSeenAddr) contact >>= \case
115 Just (_, a) | addr == a -> update -- updates time only
116 Just (t, _) | now > t + 60 -> update >> notify -- update IP if existing one is old
117 Nothing -> update >> notify -- or if we don't have any
118 _ -> return () -- otherwise just wait
119
120setEstablished :: PublicKey -> Account extra -> STM ()
121setEstablished remoteUserKey acc =
122 writeTChan (eventChan acc) $ SessionEstablished remoteUserKey
123
124setTerminated :: PublicKey -> Account extra -> STM ()
125setTerminated remoteUserKey acc =
126 writeTChan (eventChan acc) $ SessionTerminated remoteUserKey
127
128
129addContactInfo :: ContactInfo extra -> SecretKey -> extra -> STM ()
130addContactInfo (ContactInfo as) sk extra = do
131 a <- newAccount sk extra
132 modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a
133
134delContactInfo :: ContactInfo extra -> PublicKey -> STM ()
135delContactInfo (ContactInfo as) pk = modifyTVar' as $ HashMap.delete (key2id pk)
136
137newAccount :: SecretKey -> extra -> STM (Account extra)
138newAccount sk extra = Account sk <$> newTVar HashMap.empty
139 <*> newTVar extra
140 <*> newBroadcastTChan
141
142dnsPresentation :: ContactInfo extra -> STM String
143dnsPresentation (ContactInfo accsvar) = do
144 accs <- readTVar accsvar
145 ms <- forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
146 cs <- readTVar cvar
147 rs <- forM (HashMap.toList cs) $ \(nid,c) -> do
148 mkpkt <- readTVar (contactKeyPacket c)
149 return $ fmap (\(_,d) -> (nid,d)) mkpkt
150 return $
151 "; local key = " ++ show (key2id $ toPublic sec) ++ "\n"
152 ++ concatMap dnsPresentation1 (catMaybes rs)
153 return $ concat ms
154
155dnsPresentation1 :: (NodeId,DHTPublicKey) -> String
156dnsPresentation1 (nid,dk) = unlines
157 [ concat [ show nid, ".tox. IN CNAME ", show (key2id $ dhtpk dk), ".dht." ]
158 ]
159
160type LocalKey = NodeId
161type RemoteKey = NodeId
162
163friendRequests :: ContactInfo extra -> STM (HashMap LocalKey [(RemoteKey,DHT.FriendRequest)])
164friendRequests (ContactInfo roster) = do
165 accs <- readTVar roster
166 forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
167 cs <- readTVar cvar
168 rs <- forM (HashMap.toList cs) $ \(nid,c) -> do
169 mfr <- readTVar (contactFriendRequest c)
170 return $ fmap (\(_,x) -> (nid,x)) mfr
171 return $ catMaybes rs
172
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 17:59:16 +0000