summaryrefslogtreecommitdiff
path: root/examples/testTox.hs
diff options
context:
space:
mode:
authorJames Crayne <jim.crayne@gmail.com>2019-09-28 13:43:29 -0400
committerJoe Crayne <joe@jerkface.net>2020-01-01 19:27:53 -0500
commit11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch)
tree5716463275c2d3e902889db619908ded2a73971c /examples/testTox.hs
parentadd2c76bced51fde5e9917e7449ef52be70faf87 (diff)
Factor out some new libraries
word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search
Diffstat (limited to 'examples/testTox.hs')
-rw-r--r--examples/testTox.hs185
1 files changed, 0 insertions, 185 deletions
diff --git a/examples/testTox.hs b/examples/testTox.hs
deleted file mode 100644
index 67c4daef..00000000
--- a/examples/testTox.hs
+++ /dev/null
@@ -1,185 +0,0 @@
1{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE LambdaCase #-}
5#ifdef THREAD_DEBUG
6import Control.Concurrent.Lifted.Instrument
7#else
8import Control.Concurrent.Lifted
9#endif
10import Control.Concurrent.STM.TChan
11import Control.Concurrent.STM.TMChan
12import Control.Concurrent.STM.TVar
13import Control.Monad
14import Control.Monad.STM
15import Crypto.Tox
16import qualified Data.IntMap.Strict as IntMap
17import Data.Function
18import DebugUtil
19import DPut
20import DebugTag
21import HandshakeCache
22import Network.QueryResponse
23import Network.Socket
24import Network.Tox
25import Network.Tox.ContactInfo
26import Network.Tox.Session
27import Network.Tox.Crypto.Transport
28import Network.Tox.DHT.Handlers as DHT
29import Network.Tox.DHT.Transport
30import Network.Tox.Onion.Transport
31import Connection
32import qualified Data.HashMap.Strict as HashMap
33 ;import Data.HashMap.Strict (HashMap)
34import qualified Data.Map.Strict as Map
35import Data.Time.Clock.POSIX
36import System.Exit
37import Data.Dependent.Sum
38import Data.Tox.Msg
39
40makeToxNode :: UDPTransport -> Maybe SecretKey
41 -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
42 -> IO (Tox extra)
43makeToxNode udp sec onSessionF = do
44 keysdb <- newKeysDatabase
45 newToxOverTransport keysdb
46 (SockAddrInet 0 0)
47 onSessionF
48 sec
49 udp
50 (\_ _ -> return ())
51
52
53setToxID :: Tox () -> Maybe SecretKey -> IO ()
54setToxID tox (Just sec) = atomically $ addContactInfo (toxContactInfo tox) sec ()
55
56sessionChan :: TVar (Map.Map PublicKey [Session]) -> TChan (TMChan CryptoMessage)
57 -> ContactInfo extra -> SockAddr -> Session -> IO ()
58sessionChan remotes tchan acnt saddr s = do
59 ch <- atomically $ do
60 modifyTVar' remotes $ (`Map.alter` sTheirUserKey s) $ \case
61 Just ss -> Just (s : ss)
62 Nothing -> Just [s]
63 session_chan <- newTMChan
64 writeTChan tchan session_chan
65 return session_chan
66 let onPacket loop Nothing = return ()
67 onPacket loop (Just (Left e)) = dput XUnused e >> loop
68 onPacket loop (Just (Right (x,()))) = do
69 atomically $ writeTMChan ch x
70 loop
71 -- forkIO $ fix $ awaitMessage (sTransport s) . onPacket
72 return ()
73
74netCrypto :: Tox extra -> SecretKey -> NodeInfo -> PublicKey -> IO ()
75netCrypto tox me ni them = do
76 mcookie <- cookieRequest (toxCryptoKeys tox) (toxDHT tox) (toPublic me) ni
77 case mcookie of
78 Just cookie -> do
79 hs <- cacheHandshake (toxHandshakeCache tox) me them ni cookie
80 sendMessage (toxHandshakes tox) (nodeAddr ni) hs
81 Nothing -> do
82 dput XUnused "Timeout requesting cookie."
83
84
85main :: IO ()
86main = do
87 mapM_ setVerbose ([ minBound .. maxBound ]::[DebugTag])
88 setQuiet XRoutes
89
90 (udpA,udpB) <- testPairTransport
91
92 a_remotes <- atomically (newTVar Map.empty)
93 a_sessions <- atomically newTChan
94 a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
95 <- makeToxNode udpA (decodeSecret "YrJQFG7Xppg4WAyhooONNGSCRVQbrRF9L4VoQQsetF")
96 (sessionChan a_remotes a_sessions)
97 a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
98 `setToxID` -- BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI
99 decodeSecret "UdZUB9Mf1RD3pVGh02OsRJM6YpmGqJiVxYGVIVHkAG"
100
101 -- a_sessions <- sessionChan a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
102
103 b_remotes <- atomically (newTVar Map.empty)
104 b_sessions <- atomically newTChan
105 let b = read "OM7znaPMYkTbm.9GcZJAdnDATXmZxZ9fnaSTP3qNCZk@2.0.0.0:2"
106 b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk
107 <- makeToxNode udpB (decodeSecret "Lm2pnsu1+80I8h9txMoZyGgcNwfaoqBlIfg5TwWUXL")
108 (sessionChan b_remotes b_sessions)
109 b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk
110 `setToxID` -- AvETKhO-YqnNRopZrj8K3xUpGtGbX0sLhZZjh2VufJB
111 decodeSecret "L7WNtNIbm0ajNlPrkWvSRpn0nypTUZxlHBckZPlTje"
112
113 -- b_sessions <- sessionChan b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk
114
115 (a_quit,_,_) <- forkTox a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf False
116 (b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False
117
118 threadReport False >>= putStrLn
119
120 [(a_secret,a_public)] <- atomically (userKeys (toxCryptoKeys a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf))
121 [(_,b_public)] <- atomically (userKeys (toxCryptoKeys b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk))
122 mbAccount <- atomically $ do
123 accs <- readTVar (accounts $ toxContactInfo a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf)
124 return $ HashMap.lookup (key2id a_public) accs
125 now <- getPOSIXTime
126 case mbAccount of
127 Just account -> atomically $ do
128 setContactPolicy b_public TryingToConnect account
129 setContactAddr now b_public b account
130 Nothing -> dput XUnused "MISSING Account!"
131
132 dput XUnused $ "a_public = " ++ show (key2id a_public)
133 dput XUnused $ "BDD... = " ++ show (read "BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI":: NodeId)
134
135 -- Tell /a/ about /b/'s DHT-key.
136 updateContactInfo (toxContactInfo a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf)
137 (AnnouncedRendezvous (id2key $ read "AvETKhO-YqnNRopZrj8K3xUpGtGbX0sLhZZjh2VufJB") -- b toxid
138 (Rendezvous (error "pointless mitm key") b))
139 $ ( id2key $ read "BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI" -- a toxid
140 , OnionDHTPublicKey DHTPublicKey
141 { dhtpkNonce = 0
142 , dhtpk = id2key $ nodeId b
143 , dhtpkNodes = SendNodes []
144 }
145 )
146
147 DHT.ping (toxDHT a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) b
148
149 -- sendMessage (toxHandshakes a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) (nodeAddr b) hs
150
151 (b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False
152
153 forkIO $ do
154 tid <- myThreadId
155 labelThread tid "testToxLaunch"
156 netCrypto a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf a_secret b b_public
157 dput XUnused "REACHEDREACHEDREACHEDREACHED"
158 dput XUnused "REACHEDREACHEDREACHEDREACHED"
159 dput XUnused "REACHEDREACHEDREACHEDREACHED"
160 threadDelay 1000000
161 -- a says "Howdy"
162 mp_a <- atomically . readTVar $ a_remotes
163 case Map.lookup b_public mp_a of
164 Just [session] -> do
165 dput XUnused "----------------- HOWDY ---------------"
166 sendMessage (sTransport session) () (Pkt MESSAGE :=> "Howdy")
167 Just xs -> dput XUnused "Unexpectedly a has TOO MANY sesions for b"
168 Nothing -> dput XUnused "Unexpectedly a has NO session for b"
169 -- b says "Hey you!"
170 mp_b <- atomically . readTVar $ b_remotes
171 case Map.lookup a_public mp_b of
172 Just [session] -> do
173 dput XUnused "----------------- HEY YOU ---------------"
174 sendMessage (sTransport session) () (Pkt MESSAGE :=> "Hey you!")
175 Just xs -> dput XUnused "Unexpectedly b has TOO MANY sesions for a"
176 Nothing -> dput XUnused "Unexpectedly b has NO session for a"
177
178 putStrLn "Type Enter to quit..."
179 getLine
180
181 a_quit
182 b_quit
183
184 threadDelay 500000
185 threadReport False >>= putStrLn
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 12:15:01 +0000