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
|
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
#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.Concurrent.Supply
import Control.Monad
import Control.Monad.STM
import Crypto.Tox
import qualified Data.IntMap.Strict as IntMap
import DebugUtil
import DPut
import Network.QueryResponse
import Network.Socket
import Network.Tox
import Network.Tox.ContactInfo
import qualified Network.Tox.Crypto.Handlers as CH
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 Data.Time.Clock.POSIX
import System.Exit
makeToxNode :: UDPTransport -> Maybe SecretKey -> IO (Tox extra)
makeToxNode udp sec = do
keysdb <- newKeysDatabase
newToxOverTransport keysdb
(SockAddrInet 0 0)
Nothing
sec
udp
setToxID :: Tox () -> Maybe SecretKey -> IO ()
setToxID tox (Just sec) = atomically $ addContactInfo (toxContactInfo tox) sec ()
sessionChan :: Tox extra -> IO (TChan (TMChan CryptoMessage))
sessionChan Tox{toxCryptoSessions} = do
tchan <- atomically newTChan
atomically $ CH.addNewSessionHook toxCryptoSessions $ \_ nc -> do
atomically $ do
session_chan <- newTMChan
writeTChan tchan session_chan
(n,supply) <- freshId <$> readTVar (CH.listenerIDSupply toxCryptoSessions)
writeTVar (CH.listenerIDSupply toxCryptoSessions) supply
modifyTVar' (CH.ncListeners nc) $ IntMap.insert n (0,session_chan)
return Nothing
return tchan
main :: IO ()
main = do
mapM_ setVerbose [ minBound .. maxBound ]
setQuiet XRoutes
(udpA,udpB) <- testPairTransport
a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
<- makeToxNode udpA $ decodeSecret "YrJQFG7Xppg4WAyhooONNGSCRVQbrRF9L4VoQQsetF"
a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
`setToxID` -- BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI
decodeSecret "UdZUB9Mf1RD3pVGh02OsRJM6YpmGqJiVxYGVIVHkAG"
a_sessions <- sessionChan a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
let b = read "OM7znaPMYkTbm.9GcZJAdnDATXmZxZ9fnaSTP3qNCZk@2.0.0.0:2"
b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk
<- makeToxNode udpB $ decodeSecret "Lm2pnsu1+80I8h9txMoZyGgcNwfaoqBlIfg5TwWUXL"
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"
void $ netCrypto a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf a_secret b_public
putStrLn "Type Enter to quit..."
getLine
a_quit
b_quit
threadDelay 500000
threadReport False >>= putStrLn
|
