summaryrefslogtreecommitdiff
path: root/src/Network/Tox/ContactInfo.hs
blob: 9f29d587dbdf2a6763dfa3e049288f019eb8a7c5 (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
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
{-# LANGUAGE NamedFieldPuns #-}
module Network.Tox.ContactInfo where

import ConnectionKey
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 qualified Data.Set            as Set
         ;import Data.Set            (Set)
import Network.Socket
import Network.Tox.DHT.Transport     as DHT
import Network.Tox.NodeId            (id2key)
import Network.Tox.Onion.Transport   as Onion
import System.IO

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
    , eventChan  :: TChan ContactEvent
    }

data ContactEvent = OnionRouted  { contact :: PublicKey, onionRouted :: OnionData }
                  | PolicyChange { contact :: PublicKey, policyChange :: Policy }
                  | AddrChange   { contact :: PublicKey, addrChange :: SockAddr }
                  | SessionEstablished { contact :: PublicKey }
                  | SessionTerminated  { contact :: PublicKey }

data Contact = Contact
    { contactKeyPacket     :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey))
    , contactLastSeenAddr  :: TVar (Maybe (POSIXTime,SockAddr))
    , contactFriendRequest :: TVar (Maybe (POSIXTime,DHT.FriendRequest))
    , contactPolicy        :: TVar (Maybe Connection.Policy)
    }

newContactInfo :: IO ContactInfo
newContactInfo = atomically $ ContactInfo <$> newTVar HashMap.empty

myKeyPairs :: ContactInfo -> STM [(SecretKey,PublicKey)]
myKeyPairs (ContactInfo accounts) = do
    acnts <- readTVar accounts
    forM (HashMap.toList acnts) $ \(nid, Account{userSecret}) -> do
        return (userSecret,id2key nid)

updateContactInfo :: ContactInfo -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO ()
updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do
    hPutStrLn stderr "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

updateAccount' :: PublicKey -> Account -> (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 -> 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 -> SockAddr -> Contact -> STM ()
addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr)

setContactPolicy :: PublicKey -> Policy -> Account -> STM ()
setContactPolicy remoteUserKey policy acc = do
    updateAccount' remoteUserKey acc $ policyUpdate policy
    writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy

setContactAddr :: POSIXTime -> PublicKey -> SockAddr -> Account -> STM ()
setContactAddr now remoteUserKey addr acc = do
    updateAccount' remoteUserKey acc $ addrUpdate now addr
    writeTChan (eventChan acc) $ AddrChange remoteUserKey addr

setEstablished :: POSIXTime -> PublicKey -> Account -> STM ()
setEstablished now remoteUserKey acc =
    writeTChan (eventChan acc) $ SessionEstablished remoteUserKey

setTerminated :: POSIXTime -> PublicKey -> Account -> STM ()
setTerminated now remoteUserKey acc =
    writeTChan (eventChan acc) $ SessionTerminated remoteUserKey


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)

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

dnsPresentation :: ContactInfo -> 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 -> 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