diff options
author | joe <joe@jerkface.net> | 2017-11-21 01:01:14 -0500 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-11-21 01:01:14 -0500 |
commit | 1023a3c21003c404b5c3fac466819953588a6887 (patch) | |
tree | a0d2a64c27823c5136a4ad1813c9d2b7ffe1a55e /Roster.hs | |
parent | 98cdeb49997d904cc9b7ce483ebce8ff9173f701 (diff) |
Renamed Roster -> ContactInfo, reverted toxManager stubs.
Diffstat (limited to 'Roster.hs')
-rw-r--r-- | Roster.hs | 100 |
1 files changed, 0 insertions, 100 deletions
diff --git a/Roster.hs b/Roster.hs deleted file mode 100644 index 7c40e371..00000000 --- a/Roster.hs +++ /dev/null | |||
@@ -1,100 +0,0 @@ | |||
1 | {-# LANGUAGE NamedFieldPuns #-} | ||
2 | module Roster where | ||
3 | |||
4 | import Control.Concurrent.STM | ||
5 | import Control.Monad | ||
6 | import Crypto.PubKey.Curve25519 | ||
7 | import qualified Data.HashMap.Strict as HashMap | ||
8 | ;import Data.HashMap.Strict (HashMap) | ||
9 | import Data.Maybe | ||
10 | import Network.Tox.DHT.Transport as DHT | ||
11 | import Network.Tox.NodeId | ||
12 | import Network.Tox.Onion.Transport as Onion | ||
13 | import System.IO | ||
14 | |||
15 | newtype Roster = Roster { accounts :: TVar (HashMap NodeId Account) } | ||
16 | |||
17 | data Account = Account | ||
18 | { userSecret :: SecretKey -- local secret key | ||
19 | , contacts :: TVar (HashMap NodeId Contact) -- received contact info | ||
20 | } | ||
21 | |||
22 | data Contact = Contact | ||
23 | { contactKeyPacket :: Maybe (DHT.DHTPublicKey) | ||
24 | , contactFriendRequest :: Maybe (DHT.FriendRequest) | ||
25 | } | ||
26 | |||
27 | mergeContact :: Contact -> Maybe Contact -> Maybe Contact | ||
28 | mergeContact (Contact newk newf) (Just (Contact oldk oldf)) = | ||
29 | Just (Contact mergek mergef) | ||
30 | where | ||
31 | mergek = mplus oldk $ do | ||
32 | n <- newk | ||
33 | stamp <- fmap DHT.dhtpkNonce oldk `mplus` return minBound | ||
34 | guard (stamp <= DHT.dhtpkNonce n) | ||
35 | return n | ||
36 | mergef = mplus oldf newf | ||
37 | mergeContact new Nothing = Just new | ||
38 | |||
39 | newRoster :: IO Roster | ||
40 | newRoster = atomically $ Roster <$> newTVar HashMap.empty | ||
41 | |||
42 | newAccount :: SecretKey -> STM Account | ||
43 | newAccount sk = Account sk <$> newTVar HashMap.empty | ||
44 | |||
45 | addRoster :: Roster -> SecretKey -> STM () | ||
46 | addRoster (Roster as) sk = do | ||
47 | a <- newAccount sk | ||
48 | modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a | ||
49 | |||
50 | delRoster :: Roster -> PublicKey -> STM () | ||
51 | delRoster (Roster as) pk = modifyTVar' as $ HashMap.delete (key2id pk) | ||
52 | |||
53 | updateRoster :: Roster -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO () | ||
54 | updateRoster roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do | ||
55 | hPutStrLn stderr "updateRoster!!!" | ||
56 | atomically $ do | ||
57 | as <- readTVar (accounts roster) | ||
58 | maybe (return ()) | ||
59 | (updateAccount remoteUserKey omsg) | ||
60 | $ HashMap.lookup (key2id localUserKey) as | ||
61 | |||
62 | |||
63 | updateAccount :: PublicKey -> Onion.OnionData -> Account -> STM () | ||
64 | updateAccount remoteUserKey (Onion.OnionDHTPublicKey dhtpk) acc = do | ||
65 | modifyTVar' (contacts acc) $ HashMap.alter (mergeContact $ Contact (Just dhtpk) Nothing) | ||
66 | (key2id remoteUserKey) | ||
67 | |||
68 | updateAccount remoteUserKey (Onion.OnionFriendRequest fr) acc = do | ||
69 | modifyTVar' (contacts acc) $ HashMap.alter (mergeContact $ Contact Nothing (Just fr)) | ||
70 | (key2id remoteUserKey) | ||
71 | |||
72 | dnsPresentation :: Roster -> STM String | ||
73 | dnsPresentation (Roster accsvar) = do | ||
74 | accs <- readTVar accsvar | ||
75 | ms <- forM accs $ \Account { userSecret = sec, contacts = cvar } -> do | ||
76 | cs <- readTVar cvar | ||
77 | return $ | ||
78 | "; local key = " ++ show (key2id $ toPublic sec) ++ "\n" | ||
79 | ++ concatMap dnsPresentation1 | ||
80 | (mapMaybe (\(nid,m) -> ((,) nid) <$> contactKeyPacket m) | ||
81 | $ HashMap.toList cs) | ||
82 | return $ concat ms | ||
83 | |||
84 | dnsPresentation1 :: (NodeId,DHTPublicKey) -> String | ||
85 | dnsPresentation1 (nid,dk) = unlines | ||
86 | [ concat [ show nid, ".tox. IN CNAME ", show (key2id $ dhtpk dk), ".dht." ] | ||
87 | ] | ||
88 | |||
89 | type LocalKey = NodeId | ||
90 | type RemoteKey = NodeId | ||
91 | |||
92 | friendRequests :: Roster -> STM (HashMap LocalKey [(RemoteKey,DHT.FriendRequest)]) | ||
93 | friendRequests (Roster roster) = do | ||
94 | accs <- readTVar roster | ||
95 | forM accs $ \Account { userSecret = sec, contacts = cvar } -> do | ||
96 | cs <- readTVar cvar | ||
97 | let remotes = mapMaybe (\(nid,m) -> ((,) nid) <$> contactFriendRequest m) | ||
98 | $ HashMap.toList cs | ||
99 | return remotes | ||
100 | |||