3 files changed, 105 insertions, 11 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 ()
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 00dfcf9f..d81ed1e3 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -389,6 +389,17 @@ newTox :: TVar Onion.AnnouncedKeys   -- ^ Store of announced keys we are a rende
        -> IO (Tox extra)
 newTox keydb addr mbSessionsState suppliedDHTKey = do
     (udp,sock) <- {- addVerbosity <$> -} udpTransport' addr
+    tox <- newToxOverTransport keydb addr mbSessionsState suppliedDHTKey udp
+    return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox) }
+
+-- | This version of 'newTox' is useful for automated tests using 'testPairTransport'.
+newToxOverTransport :: TVar Onion.AnnouncedKeys
+        -> SockAddr
+        -> Maybe NetCryptoSessions
+        -> Maybe SecretKey
+        -> Onion.UDPTransport
+        -> IO (Tox extra)
+newToxOverTransport keydb addr mbSessionsState suppliedDHTKey udp = do
     roster <- newContactInfo
     (crypto0,sessionsState0) <- case mbSessionsState of
                                  Nothing -> do
@@ -475,7 +486,7 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do
         , toxAnnouncedKeys  = keydb
         , toxOnionRoutes    = orouter
         , toxContactInfo    = roster
-        , toxAnnounceToLan  = announceToLan sock (key2id $ transportPublic crypto)
+        , toxAnnounceToLan  = return ()
         , toxMgr            = mgr
         }
 
@@ -501,21 +512,24 @@ dnssdDiscover tox ni toxid = do
 
   void $ DHT.ping (toxDHT tox) ni
 
-forkTox :: Tox extra -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ())
-forkTox tox = do
+forkTox :: Tox extra -> Bool -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ())
+forkTox tox with_avahi = do
     _ <- forkListener "toxHandshakes" (toxHandshakes tox)
     _ <- forkListener "toxToRoute" (toxToRoute tox)
     _ <- forkListener "toxOnion" (clientNet $ toxOnion tox)
     _ <- forkListener "toxDHT" (clientNet $ toxDHT tox)
     quit <- forkListener "toxCrypto" (toxCrypto tox)
-    forkPollForRefresh (DHT.refresher4 $ toxRouting tox)
-    forkPollForRefresh (DHT.refresher6 $ toxRouting tox)
-    dnssdIn <- forkIO $ queryToxService (dnssdDiscover tox)
-    dnssdOut <- forkIO $ dnssdAnnounce tox
-    labelThread dnssdIn  "tox-avahi-monitor"
-    labelThread dnssdOut "tox-avahi-publish"
+    quitAvahi <- if with_avahi then do
+                    forkPollForRefresh (DHT.refresher4 $ toxRouting tox)
+                    forkPollForRefresh (DHT.refresher6 $ toxRouting tox)
+                    dnssdIn <- forkIO $ queryToxService (dnssdDiscover tox)
+                    dnssdOut <- forkIO $ dnssdAnnounce tox
+                    labelThread dnssdIn  "tox-avahi-monitor"
+                    labelThread dnssdOut "tox-avahi-publish"
+                    return $ forM_ [dnssdIn,dnssdOut] killThread
+                 else return $ return ()
     keygc <- Onion.forkAnnouncedKeysGC (toxAnnouncedKeys tox)
-    return ( forM_ [dnssdIn, dnssdOut, keygc] killThread >> quit
+    return ( quitAvahi >> killThread keygc >> quit
            , bootstrap (DHT.refresher4 $ toxRouting tox)
            , bootstrap (DHT.refresher6 $ toxRouting tox)
            )