Updated testTox.

1 files changed, 53 insertions, 26 deletions

diff --git a/examples/testTox.hs b/examples/testTox.hs
index 5314024f..cc8bd45f 100644
--- a/examples/testTox.hs
+++ b/examples/testTox.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 #ifdef THREAD_DEBUG
 import Control.Concurrent.Lifted.Instrument
 #else
@@ -9,18 +10,19 @@ import Control.Concurrent.Lifted
 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 Data.Function
 import DebugUtil
 import DPut
+import HandshakeCache
 import Network.QueryResponse
 import Network.Socket
 import Network.Tox
 import Network.Tox.ContactInfo
-import qualified Network.Tox.Crypto.Handlers as CH
+import Network.Tox.Session
 import Network.Tox.Crypto.Transport
 import Network.Tox.DHT.Handlers              as DHT
 import Network.Tox.DHT.Transport
@@ -33,12 +35,14 @@ import Data.Time.Clock.POSIX
 import System.Exit
 
 
-makeToxNode :: UDPTransport -> Maybe SecretKey -> IO (Tox extra)
-makeToxNode udp sec = do
+makeToxNode :: UDPTransport -> Maybe SecretKey
+        -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
+        -> IO (Tox extra)
+makeToxNode udp sec onSessionF = do
     keysdb <- newKeysDatabase
     newToxOverTransport keysdb
                         (SockAddrInet 0 0)
-                        Nothing
+                        onSessionF
                         sec
                         udp
 
@@ -46,18 +50,33 @@ makeToxNode udp sec = do
 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
+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 ()
@@ -67,22 +86,28 @@ main = do
 
     (udpA,udpB) <- testPairTransport
 
+    a_remotes <- atomically (newTVar Map.empty)
+    a_sessions <- atomically newTChan
     a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
-        <- makeToxNode udpA $ decodeSecret "YrJQFG7Xppg4WAyhooONNGSCRVQbrRF9L4VoQQsetF"
+        <- makeToxNode udpA (decodeSecret "YrJQFG7Xppg4WAyhooONNGSCRVQbrRF9L4VoQQsetF")
+                            (sessionChan a_remotes a_sessions)
     a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
         `setToxID` -- BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI
             decodeSecret "UdZUB9Mf1RD3pVGh02OsRJM6YpmGqJiVxYGVIVHkAG"
 
-    a_sessions <- sessionChan a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
+    -- 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"
+        <- makeToxNode udpB (decodeSecret "Lm2pnsu1+80I8h9txMoZyGgcNwfaoqBlIfg5TwWUXL")
+                            (sessionChan b_remotes b_sessions)
     b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk
         `setToxID` -- AvETKhO-YqnNRopZrj8K3xUpGtGbX0sLhZZjh2VufJB
             decodeSecret "L7WNtNIbm0ajNlPrkWvSRpn0nypTUZxlHBckZPlTje"
 
-    b_sessions <- sessionChan b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk
+    -- b_sessions <- sessionChan b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk
 
     (a_quit,_,_) <- forkTox a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf False
     (b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False
@@ -125,23 +150,25 @@ main = do
     forkIO $ do
         tid <- myThreadId
         labelThread tid "testToxLaunch"
-        void $ netCrypto a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf a_secret b_public
+        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 $ CH.netCryptoSessionsByKey (toxCryptoSessions a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf)
+        mp_a <- atomically . readTVar $ a_remotes
         case Map.lookup b_public mp_a of
             Just [session] -> do
                 dput XUnused "----------------- HOWDY ---------------"
-                CH.sendChatMsg (toxCryptoKeys a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) session "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 $ CH.netCryptoSessionsByKey (toxCryptoSessions b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk)
+        mp_b <- atomically . readTVar $ b_remotes
         case Map.lookup a_public mp_b of
             Just [session] -> do
                 dput XUnused "----------------- HEY YOU ---------------"
-                void $ CH.sendChatMsg (toxCryptoKeys b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk) session "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"