{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} #ifdef THREAD_DEBUG import Control.Concurrent.Lifted.Instrument #else import Control.Concurrent.Lifted #endif import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TMChan import Control.Concurrent.STM.TVar 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 DebugTag import HandshakeCache import Network.QueryResponse import Network.Socket import Network.Tox import Network.Tox.ContactInfo import Network.Tox.Session import Network.Tox.Crypto.Transport import Network.Tox.DHT.Handlers as DHT import Network.Tox.DHT.Transport import Network.Tox.Onion.Transport import Connection import qualified Data.HashMap.Strict as HashMap ;import Data.HashMap.Strict (HashMap) import qualified Data.Map.Strict as Map import Data.Time.Clock.POSIX import System.Exit import Data.Dependent.Sum import Data.Tox.Msg makeToxNode :: UDPTransport -> Maybe SecretKey -> ( ContactInfo extra -> SockAddr -> Session -> IO () ) -> IO (Tox extra) makeToxNode udp sec onSessionF = do keysdb <- newKeysDatabase newToxOverTransport keysdb (SockAddrInet 0 0) onSessionF sec udp (\_ _ -> return ()) setToxID :: Tox () -> Maybe SecretKey -> IO () setToxID tox (Just sec) = atomically $ addContactInfo (toxContactInfo tox) sec () 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 () main = do mapM_ setVerbose ([ minBound .. maxBound ]::[DebugTag]) setQuiet XRoutes (udpA,udpB) <- testPairTransport a_remotes <- atomically (newTVar Map.empty) a_sessions <- atomically newTChan a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf <- makeToxNode udpA (decodeSecret "YrJQFG7Xppg4WAyhooONNGSCRVQbrRF9L4VoQQsetF") (sessionChan a_remotes a_sessions) a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf `setToxID` -- BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI decodeSecret "UdZUB9Mf1RD3pVGh02OsRJM6YpmGqJiVxYGVIVHkAG" -- 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") (sessionChan b_remotes b_sessions) 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 threadReport False >>= putStrLn [(a_secret,a_public)] <- atomically (userKeys (toxCryptoKeys a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf)) [(_,b_public)] <- atomically (userKeys (toxCryptoKeys b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk)) mbAccount <- atomically $ do accs <- readTVar (accounts $ toxContactInfo a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) return $ HashMap.lookup (key2id a_public) accs now <- getPOSIXTime case mbAccount of Just account -> atomically $ do setContactPolicy b_public TryingToConnect account setContactAddr now b_public b account Nothing -> dput XUnused "MISSING Account!" dput XUnused $ "a_public = " ++ show (key2id a_public) dput XUnused $ "BDD... = " ++ show (read "BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI":: NodeId) -- Tell /a/ about /b/'s DHT-key. updateContactInfo (toxContactInfo a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) (AnnouncedRendezvous (id2key $ read "AvETKhO-YqnNRopZrj8K3xUpGtGbX0sLhZZjh2VufJB") -- b toxid (Rendezvous (error "pointless mitm key") b)) $ ( id2key $ read "BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI" -- a toxid , OnionDHTPublicKey DHTPublicKey { dhtpkNonce = 0 , dhtpk = id2key $ nodeId b , dhtpkNodes = SendNodes [] } ) DHT.ping (toxDHT a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) b -- sendMessage (toxHandshakes a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) (nodeAddr b) hs (b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False forkIO $ do tid <- myThreadId labelThread tid "testToxLaunch" 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 $ a_remotes case Map.lookup b_public mp_a of Just [session] -> do dput XUnused "----------------- HOWDY ---------------" sendMessage (sTransport session) () (Pkt 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 $ b_remotes case Map.lookup a_public mp_b of Just [session] -> do dput XUnused "----------------- HEY YOU ---------------" sendMessage (sTransport session) () (Pkt 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" putStrLn "Type Enter to quit..." getLine a_quit b_quit threadDelay 500000 threadReport False >>= putStrLn