tox: Oops, fix endless blocking IO action in persueContact.

2 files changed, 7 insertions, 10 deletions

diff --git a/Connection/Tox.hs b/Connection/Tox.hs
index 1fe07f82..2c485edd 100644
--- a/Connection/Tox.hs
+++ b/Connection/Tox.hs
@@ -66,10 +66,10 @@ data StatefulTask st = StatefulTask
     , taskState  :: TVar st
     }
 
-launch :: String -> st -> ((st -> STM ()) -> IO ()) -> IO (StatefulTask st)
+launch :: String -> st -> (TVar st -> IO ()) -> IO (StatefulTask st)
 launch lbl st f = do
     stvar <- newTVarIO st
-    tid <- forkIO (f $ writeTVar stvar)
+    tid <- forkIO (f stvar)
     labelThread tid lbl
     return $ StatefulTask tid stvar
 
@@ -128,9 +128,7 @@ setToxPolicy params conmap k policy = case policy of
                 , transitionToState   = (\_ -> return ()) :: G.Status ToxProgress -> STM ()
                 }
             persue_methods = PersueContactMethods
-                { getHandshakeParams = retry -- :: STM params
-                , sendHandshake      = \_ -> return () -- :: params -> IO ()
-                , retryInterval      = _todo :: Int
+                { -- TODO
                 }
             freshen_methods = FreshenContactMethods
                 { dhtkeyInterval   = _todo :: Int
@@ -181,10 +179,12 @@ setToxPolicy params conmap k policy = case policy of
     OpenToConnect -> do -- passively accept connections if they initiate.
         mst <- lookupForPolicyChange conmap k policy
         forM_ mst $ \st -> do
+            {-
             let getPolicy = readTVar $ connPolicy st
             accept_thread  <- launch ("accept:"++show k)
                                      (G.InProgress $ toEnum 0)
                                      $ acceptContact  getPolicy _accept_methods
+            -}
             atomically $ do
                 let routing   = dhtRouting params
                     Key _ nid = k
diff --git a/Connection/Tox/Threads.hs b/Connection/Tox/Threads.hs
index f3357215..73c83338 100644
--- a/Connection/Tox/Threads.hs
+++ b/Connection/Tox/Threads.hs
@@ -116,15 +116,12 @@ persueContact getPolicy getStatus PersueContactMethods{..} statusVar = do
     whileTryingAndNotEstablished getPolicy getStatus statusVar
         $ \retryAfterTimeout ->
             orElse (do
+                    readTVar statusVar >>= check . (/= InProgress AcquiringIPAddress)
                     theirDhtKey <- DHT.dhtpk <$> retryUntilJust (contactKeyPacket contact)
                     -- We don't have an IP address yet.
                     maybe (return ()) (const retry) =<< readTVar (contactLastSeenAddr contact)
                     return $ do -- AcquiringIPAddress
-                        atomically $ do
-                            status <- readTVar statusVar
-                            if status == InProgress AcquiringIPAddress
-                                then retry
-                                else writeTVar statusVar (InProgress AcquiringIPAddress)
+                        atomically $ writeTVar statusVar (InProgress AcquiringIPAddress)
                         retryAfterTimeout 0)
                    (do
                     theirDhtKey <- DHT.dhtpk <$> retryUntilJust (contactKeyPacket contact)