testTox: a pair of simulated tox nodes.

2 files changed, 81 insertions, 1 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 2bb4ca88..e4b10b8d 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1750,7 +1750,7 @@ main = do
                               addrTox
                               (Just _netCryptoSessionsState)
                               (dhtkey opts)
-            (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox
+            (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox True
 
             toxSearches <- atomically $ newTVar Map.empty
 
diff --git a/examples/testTox.hs b/examples/testTox.hs
new file mode 100644
index 00000000..45bc661e
--- /dev/null
+++ b/examples/testTox.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE NamedFieldPuns #-}
+import Control.Concurrent.STM.TChan
+import Control.Concurrent.STM.TMChan
+import Control.Concurrent.STM.TVar
+import Control.Concurrent.Supply
+import Control.Monad.STM
+import Crypto.Tox
+import qualified Data.IntMap.Strict          as IntMap
+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.Onion.Transport           (UDPTransport)
+import DPut
+
+
+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
+
+
+    DHT.ping (toxDHT a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) b
+
+    putStrLn "Type Enter to quit..."
+    getLine
+
+    return ()