summaryrefslogtreecommitdiff
path: root/Roster.hs
blob: 7c40e371915f833745b83f2ca4b6e804630475e0 (plain)
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
{-# LANGUAGE NamedFieldPuns #-}
module Roster where

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
import Network.Tox.Onion.Transport   as Onion
import System.IO

newtype Roster = Roster { accounts :: TVar (HashMap NodeId Account) }

data Account = Account
    { userSecret :: SecretKey                   -- local secret key
    , contacts :: TVar (HashMap NodeId Contact) -- received contact info
    }

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

newRoster :: IO Roster
newRoster = atomically $ Roster <$> newTVar HashMap.empty

newAccount :: SecretKey -> STM Account
newAccount sk = Account sk <$> newTVar HashMap.empty

addRoster :: Roster -> SecretKey -> STM ()
addRoster (Roster as) sk = do
    a <- newAccount sk
    modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a

delRoster :: Roster -> PublicKey -> STM ()
delRoster (Roster as) pk = modifyTVar' as $ HashMap.delete (key2id pk)

updateRoster :: Roster -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO ()
updateRoster roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do
    hPutStrLn stderr "updateRoster!!!"
    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 :: Roster -> STM String
dnsPresentation (Roster 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 :: Roster -> STM (HashMap LocalKey [(RemoteKey,DHT.FriendRequest)])
friendRequests (Roster 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