From fb3d30fd7fb1e68623b3bffc9f42ecb2adabce66 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Wed, 22 Aug 2018 20:50:23 -0400 Subject: Removed obsolete Connection.Tox. --- Connection/Tox/Threads.hs | 239 ---------------------------------------------- 1 file changed, 239 deletions(-) delete mode 100644 Connection/Tox/Threads.hs (limited to 'Connection/Tox') diff --git a/Connection/Tox/Threads.hs b/Connection/Tox/Threads.hs deleted file mode 100644 index de719655..00000000 --- a/Connection/Tox/Threads.hs +++ /dev/null @@ -1,239 +0,0 @@ --- | --- --- This module defines three tasks intended to be run in separate threads: --- --- * 'acceptContact' --- --- * 'pursueContact' --- --- * 'freshenContact' --- -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -module Connection.Tox.Threads - ( PursueContactMethods(..) - , FreshenContactMethods(..) - , pursueContact - ) where - -import Connection --- import Connection.Tox -import Crypto.Tox -import Data.IP (IP) -import Network.Tox.Crypto.Transport -import Network.Tox.Crypto.Handlers -import Network.Tox.NodeId -import Network.Tox.ContactInfo -import Network.Tox.Handshake -import Network.Tox.DHT.Handlers {- (nodeSearch) -} as DHT -import Network.Tox.DHT.Transport as DHT (dhtpk) -import Network.Socket -import Network.Kademlia.Search -import Network.Kademlia.Routing (BucketList) -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument -#else -import Control.Concurrent.Lifted -import GHC.Conc (labelThread) -#endif - -import Control.Arrow -import Control.Concurrent.STM -import Control.Monad -import Data.Function -import Data.Functor.Identity -import Data.Time.Clock.POSIX -import System.IO -import System.Timeout -import DPut - - - -type NodeSearch = Search NodeId (IP,PortNumber) () NodeInfo NodeInfo - -data AcceptContactMethods = AcceptContactMethods - { getHandshake :: STM (Handshake Identity) - , handshakeIsSuitable :: Handshake Identity -> STM Bool - , transitionToState :: Status ToxProgress -> STM () - } - --- | Invokes an STM action on each incoming handshake. --- --- Does not return until getPolicy yields RefusingToConnect. -acceptContact :: STM Policy -> AcceptContactMethods -> (Status ToxProgress -> STM ()) -> IO () -acceptContact getPolicy AcceptContactMethods{..} writeState = fix $ \loop -> do - join $ atomically $ do - orElse - (getPolicy >>= \case - RefusingToConnect -> do writeState Dormant - return $ return () -- QUIT Dormant/Established - _ -> retry) - (do hs <- getHandshake - handshakeIsSuitable hs >>= \case - True -> do - -- Here we allocate a NetCrypto session for handling CryptoPacket. - writeState (InProgress AwaitingSessionPacket) - transitionToState (InProgress AwaitingSessionPacket) - return loop - False -> return loop) - -whileTryingAndNotEstablished :: STM Policy - -> STM (Status t) - -> TVar (Status ToxProgress) - -> ((Int -> IO ()) -> STM (IO ())) - -> IO () -whileTryingAndNotEstablished getPolicy getStatus statusVar body = fix $ \loop -> do - let retryWhileTrying k = getPolicy >>= \case - TryingToConnect -> retry - _ -> do writeTVar statusVar Dormant - return k - ifEstablished t e = getStatus >>= \case - Established -> t - _ -> e - retryAfterTimeout interval = do - timeout interval $ atomically - $ orElse - (retryWhileTrying ()) - (ifEstablished (return ()) retry) - loop - join $ atomically $ orElse - (retryWhileTrying (return ())) -- QUIT Dormant/Established - (ifEstablished retry - (body retryAfterTimeout)) - -data PursueContactMethods = PursueContactMethods - { allsessions :: NetCryptoSessions - , myseckey :: SecretKey - , theirpubkey :: PublicKey - , client :: DHT.Client - , shortRetryInterval :: Int -- successful cookie, try again soon. - , longRetryInterval :: Int -- no cookie, he's offline, give it some time. - , contact :: Contact - } - -retryUntilJust :: TVar (Maybe a) -> STM a -retryUntilJust tvar = maybe retry return =<< readTVar tvar - --- | Continuously attempt to send handshake packets until a connection is --- established. --- --- As long as getPolicy is TryingToConnect and there is no established --- connection, this function will continue. -pursueContact :: STM Policy - -> STM (Status t) - -> PursueContactMethods - -> TVar (Status ToxProgress) - -> IO () -pursueContact getPolicy getStatus PursueContactMethods{..} statusVar = do - -- AwaitingDHTKey - atomically $ writeTVar statusVar (InProgress AwaitingDHTKey) - whileTryingAndNotEstablished getPolicy getStatus statusVar - $ \retryAfterTimeout -> - orElse (do - readTVar statusVar >>= check . (/= InProgress AcquiringIPAddress) - (stamp_theirDhtKey,theirDhtKey) <- second DHT.dhtpk <$> retryUntilJust (contactKeyPacket contact) - -- We don't have an IP address yet. - maybe (return ()) (const retry) =<< readTVar (contactLastSeenAddr contact) - return $ do -- AcquiringIPAddress - atomically $ writeTVar statusVar (InProgress AcquiringIPAddress) - retryAfterTimeout 0) - (do - (stamp_theirDhtKey,theirDhtKey) <- second DHT.dhtpk <$> retryUntilJust (contactKeyPacket contact) - (stamp_saddr,saddr) <- retryUntilJust (contactLastSeenAddr contact) - ni <- either (const retry) return $ nodeInfo (key2id theirDhtKey) (_fixme saddr) - return $ do - -- AcquiringCookie - atomically $ writeTVar statusVar (InProgress AcquiringCookie) - let mykeyAsId = key2id (toPublic myseckey) - theirkeyAsId = key2id theirpubkey - crypto = transportCrypto allsessions - mbCookie <- -- TODO: Check for recent cached cookie. - DHT.cookieRequest crypto client (toPublic myseckey) ni - interval <- case mbCookie of - Nothing -> do - dput XMan ("pursueContact: (" ++ show mykeyAsId ++") <--> (" ++ show theirkeyAsId ++ ").") - dput XMan ("pursueContact: CookieRequest failed. TODO: dhtpkNodes thingy") - return longRetryInterval - Just cookie -> do - dput XMan "Have cookie, creating handshake packet..." - let hp = HParam { hpOtherCookie = cookie - , hpMySecretKey = myseckey - , hpCookieRemotePubkey = theirpubkey - , hpCookieRemoteDhtkey = theirDhtKey - , hpTheirBaseNonce = Nothing - , hpTheirSessionKeyPublic = Nothing - } - newsession <- generateSecretKey - timestamp <- getPOSIXTime - (myhandshake,ioAction) - <- atomically $ freshCryptoSession allsessions (_fixme saddr) newsession timestamp hp - ioAction - -- send handshake - forM myhandshake $ \response_handshake -> do - sendHandshake allsessions (_fixme saddr) response_handshake - atomically $ writeTVar statusVar $ InProgress AwaitingHandshake - return shortRetryInterval - -- AwaitingHandshake - -- AwaitingSessionPacket - retryAfterTimeout interval) - -data FreshenContactMethods = FreshenContactMethods - { dhtkeyInterval :: Int - , sockAddrInterval :: Int - , nodeSch :: NodeSearch - , getDHTKey :: STM (Maybe NodeId) - , getSockAddr :: STM (Maybe SockAddr) - , nearestNodes :: NodeId -> STM [NodeInfo] - } - --- send my dht key --- search for their sockaddr --- monitor new dht key --- monitor new sockaddr --- --- Keep going while TryingToConnect --- pause while Established - --- Useful: --- toxidSearch onionTimeout --- newSearch --- searchLoop --- searchCancel --- -> (r -> STM Bool) -- ^ Invoked on each result. Return False to quit searching. - --- | Continuously search the DHT to obtain ip addresses and to send your dht --- key to contacts. --- --- As long as getPolicy is TryingToConnect and there is no established --- connection, this function will continue. -freshenContact :: STM Policy -> STM (Status t) -> FreshenContactMethods - -> TVar (Status ToxProgress) - -> IO () -freshenContact getPolicy getStatus FreshenContactMethods{..} statusVar - = whileTryingAndNotEstablished getPolicy getStatus statusVar - -- retryAfterTimeout :: Int -> IO () - $ \retryAfterTimeout -> - getDHTKey >>= \case - Nothing -> -- AwaitingDHTKey - retry - Just dk -> getSockAddr >>= \case - Nothing -> do -- AcquiringIPAddress - writeTVar statusVar (InProgress AcquiringIPAddress) - return $ - do st <- atomically $ do - ns <- nearestNodes dk - newSearch nodeSch dk ns - -- forked simply to avoid relabeling this thread. - forkIO $ searchLoop nodeSch dk (const $ return True) st - -- TODO: searchCancel on stop condition - atomically $ searchIsFinished st >>= check - retryAfterTimeout sockAddrInterval - Just a -> do - writeTVar statusVar (InProgress AcquiringCookie) - return $ - -- AcquiringCookie - -- AwaitingHandshake - -- AwaitingSessionPacket - do _todo_search_toxid_send_dhtkey -- 123 _todo_search_toxid_send_dhtkey :: IO a0 - retryAfterTimeout dhtkeyInterval - -- cgit v1.2.3