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
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent.Lifted
#endif
import Control.Concurrent.STM.TChan
import Control.Concurrent.STM.TMChan
import Control.Concurrent.STM.TVar
import Control.Monad
import Control.Monad.STM
import Crypto.Tox
import qualified Data.IntMap.Strict as IntMap
import Data.Function
import DebugUtil
import DPut
import DebugTag
import HandshakeCache
import Network.QueryResponse
import Network.Socket
import Network.Tox
import Network.Tox.ContactInfo
import Network.Tox.Session
import Network.Tox.Crypto.Transport
import Network.Tox.DHT.Handlers as DHT
import Network.Tox.DHT.Transport
import Network.Tox.Onion.Transport
import Connection
import qualified Data.HashMap.Strict as HashMap
;import Data.HashMap.Strict (HashMap)
import qualified Data.Map.Strict as Map
import Data.Time.Clock.POSIX
import System.Exit
makeToxNode :: UDPTransport -> Maybe SecretKey
-> ( ContactInfo extra -> SockAddr -> Session -> IO () )
-> IO (Tox extra)
makeToxNode udp sec onSessionF = do
keysdb <- newKeysDatabase
newToxOverTransport keysdb
(SockAddrInet 0 0)
onSessionF
sec
udp
setToxID :: Tox () -> Maybe SecretKey -> IO ()
setToxID tox (Just sec) = atomically $ addContactInfo (toxContactInfo tox) sec ()
sessionChan :: TVar (Map.Map PublicKey [Session]) -> TChan (TMChan CryptoMessage)
-> ContactInfo extra -> SockAddr -> Session -> IO ()
sessionChan remotes tchan acnt saddr s = do
ch <- atomically $ do
modifyTVar' remotes $ (`Map.alter` sTheirUserKey s) $ \case
Just ss -> Just (s : ss)
Nothing -> Just [s]
session_chan <- newTMChan
writeTChan tchan session_chan
return session_chan
let onPacket loop Nothing = return ()
onPacket loop (Just (Left e)) = dput XUnused e >> loop
onPacket loop (Just (Right (x,()))) = do
atomically $ writeTMChan ch x
loop
-- forkIO $ fix $ awaitMessage (sTransport s) . onPacket
return ()
netCrypto :: Tox extra -> SecretKey -> NodeInfo -> PublicKey -> IO ()
netCrypto tox me ni them = do
mcookie <- cookieRequest (toxCryptoKeys tox) (toxDHT tox) (toPublic me) ni
case mcookie of
Just cookie -> do
hs <- cacheHandshake (toxHandshakeCache tox) me them ni cookie
sendMessage (toxHandshakes tox) (nodeAddr ni) hs
Nothing -> do
dput XUnused "Timeout requesting cookie."
main :: IO ()
main = do
mapM_ setVerbose ([ minBound .. maxBound ]::[DebugTag])
setQuiet XRoutes
(udpA,udpB) <- testPairTransport
a_remotes <- atomically (newTVar Map.empty)
a_sessions <- atomically newTChan
a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
<- makeToxNode udpA (decodeSecret "YrJQFG7Xppg4WAyhooONNGSCRVQbrRF9L4VoQQsetF")
(sessionChan a_remotes a_sessions)
a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
`setToxID` -- BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI
decodeSecret "UdZUB9Mf1RD3pVGh02OsRJM6YpmGqJiVxYGVIVHkAG"
-- a_sessions <- sessionChan a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
b_remotes <- atomically (newTVar Map.empty)
b_sessions <- atomically newTChan
let b = read "OM7znaPMYkTbm.9GcZJAdnDATXmZxZ9fnaSTP3qNCZk@2.0.0.0:2"
b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk
<- makeToxNode udpB (decodeSecret "Lm2pnsu1+80I8h9txMoZyGgcNwfaoqBlIfg5TwWUXL")
(sessionChan b_remotes b_sessions)
b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk
`setToxID` -- AvETKhO-YqnNRopZrj8K3xUpGtGbX0sLhZZjh2VufJB
decodeSecret "L7WNtNIbm0ajNlPrkWvSRpn0nypTUZxlHBckZPlTje"
-- b_sessions <- sessionChan b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk
(a_quit,_,_) <- forkTox a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf False
(b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False
threadReport False >>= putStrLn
[(a_secret,a_public)] <- atomically (userKeys (toxCryptoKeys a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf))
[(_,b_public)] <- atomically (userKeys (toxCryptoKeys b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk))
mbAccount <- atomically $ do
accs <- readTVar (accounts $ toxContactInfo a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf)
return $ HashMap.lookup (key2id a_public) accs
now <- getPOSIXTime
case mbAccount of
Just account -> atomically $ do
setContactPolicy b_public TryingToConnect account
setContactAddr now b_public b account
Nothing -> dput XUnused "MISSING Account!"
dput XUnused $ "a_public = " ++ show (key2id a_public)
dput XUnused $ "BDD... = " ++ show (read "BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI":: NodeId)
-- Tell /a/ about /b/'s DHT-key.
updateContactInfo (toxContactInfo a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf)
(AnnouncedRendezvous (id2key $ read "AvETKhO-YqnNRopZrj8K3xUpGtGbX0sLhZZjh2VufJB") -- b toxid
(Rendezvous (error "pointless mitm key") b))
$ ( id2key $ read "BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI" -- a toxid
, OnionDHTPublicKey DHTPublicKey
{ dhtpkNonce = 0
, dhtpk = id2key $ nodeId b
, dhtpkNodes = SendNodes []
}
)
DHT.ping (toxDHT a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) b
-- sendMessage (toxHandshakes a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) (nodeAddr b) hs
(b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False
forkIO $ do
tid <- myThreadId
labelThread tid "testToxLaunch"
netCrypto a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf a_secret b b_public
dput XUnused "REACHEDREACHEDREACHEDREACHED"
dput XUnused "REACHEDREACHEDREACHEDREACHED"
dput XUnused "REACHEDREACHEDREACHEDREACHED"
threadDelay 1000000
-- a says "Howdy"
mp_a <- atomically . readTVar $ a_remotes
case Map.lookup b_public mp_a of
Just [session] -> do
dput XUnused "----------------- HOWDY ---------------"
sendMessage (sTransport session) () (UpToN MESSAGE "Howdy")
Just xs -> dput XUnused "Unexpectedly a has TOO MANY sesions for b"
Nothing -> dput XUnused "Unexpectedly a has NO session for b"
-- b says "Hey you!"
mp_b <- atomically . readTVar $ b_remotes
case Map.lookup a_public mp_b of
Just [session] -> do
dput XUnused "----------------- HEY YOU ---------------"
sendMessage (sTransport session) () (UpToN MESSAGE "Hey you!")
Just xs -> dput XUnused "Unexpectedly b has TOO MANY sesions for a"
Nothing -> dput XUnused "Unexpectedly b has NO session for a"
putStrLn "Type Enter to quit..."
getLine
a_quit
b_quit
threadDelay 500000
threadReport False >>= putStrLn
|
