From a3997c8158c36ef3b59a789e240aa2c0e6189c89 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 1 Nov 2018 21:51:43 -0400 Subject: Updated testTox. --- examples/testTox.hs | 79 +++++++++++++++++++++++++++++++++++------------------ 1 file changed, 53 insertions(+), 26 deletions(-) (limited to 'examples') 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" -- cgit v1.2.3