writeStatus::(Status ToxProgress -> STM ()) changed to statusVar:: TVar (Status ToxProgress)

1 files changed, 22 insertions, 18 deletions

diff --git a/Connection/Tox/Threads.hs b/Connection/Tox/Threads.hs
index b3527ed2..f3357215 100644
--- a/Connection/Tox/Threads.hs
+++ b/Connection/Tox/Threads.hs
@@ -65,13 +65,13 @@ acceptContact getPolicy AcceptContactMethods{..} writeState = fix $ \loop -> do
 
 whileTryingAndNotEstablished :: STM Policy
                                 -> STM (Status t)
-                                -> (Status ToxProgress -> STM ())
+                                -> TVar (Status ToxProgress)
                                 -> ((Int -> IO ()) -> STM (IO ()))
                                 -> IO ()
-whileTryingAndNotEstablished getPolicy getStatus writeStatus body = fix $ \loop -> do
+whileTryingAndNotEstablished getPolicy getStatus statusVar body = fix $ \loop -> do
     let retryWhileTrying k = getPolicy >>= \case
             TryingToConnect -> retry
-            _               -> do writeStatus Dormant
+            _               -> do writeTVar statusVar Dormant
                                   return k
         ifEstablished t e = getStatus >>= \case
             Established -> t
@@ -87,7 +87,7 @@ whileTryingAndNotEstablished getPolicy getStatus writeStatus body = fix $ \loop
         (ifEstablished retry
                        (body retryAfterTimeout))
 
-data PersueContactMethods params = PersueContactMethods
+data PersueContactMethods = PersueContactMethods
     { allsessions        :: NetCryptoSessions
     , myseckey           :: SecretKey
     , theirpubkey        :: PublicKey
@@ -107,28 +107,32 @@ retryUntilJust tvar = maybe retry return =<< readTVar tvar
 -- connection, this function will continue.
 persueContact :: STM Policy
                  -> STM (Status t)
-                 -> PersueContactMethods a
-                 -> (Status ToxProgress -> STM ())
+                 -> PersueContactMethods
+                 -> TVar (Status ToxProgress)
                  -> IO ()
-persueContact getPolicy getStatus PersueContactMethods{..} writeStatus = do
+persueContact getPolicy getStatus PersueContactMethods{..} statusVar = do
     -- AwaitingDHTKey
-    atomically $ writeStatus (InProgress AwaitingDHTKey)
-    whileTryingAndNotEstablished getPolicy getStatus writeStatus
+    atomically $ writeTVar statusVar (InProgress AwaitingDHTKey)
+    whileTryingAndNotEstablished getPolicy getStatus statusVar
         $ \retryAfterTimeout ->
             orElse (do
                     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 $ writeStatus (InProgress AcquiringIPAddress)
-                                retryAfterTimeout 0)
+                        atomically $ do
+                            status <- readTVar statusVar
+                            if status == InProgress AcquiringIPAddress
+                                then retry
+                                else writeTVar statusVar (InProgress AcquiringIPAddress)
+                        retryAfterTimeout 0)
                    (do
                     theirDhtKey <- DHT.dhtpk <$> retryUntilJust (contactKeyPacket contact)
                     saddr <- retryUntilJust (contactLastSeenAddr contact)
                     ni <- either (const retry) return $ nodeInfo (key2id theirDhtKey) saddr
                     return $ do
                     -- AcquiringCookie
-                    atomically $ writeStatus (InProgress AcquiringCookie)
+                    atomically $ writeTVar statusVar (InProgress AcquiringCookie)
                     let mykeyAsId    = key2id (toPublic myseckey)
                         theirkeyAsId = key2id theirpubkey
                         crypto       = transportCrypto allsessions
@@ -156,7 +160,7 @@ persueContact getPolicy getStatus PersueContactMethods{..} writeStatus = do
                             -- send handshake
                             forM myhandshake $ \response_handshake -> do
                                     sendHandshake allsessions saddr response_handshake
-                            atomically $ writeStatus $ InProgress AwaitingHandshake
+                            atomically $ writeTVar statusVar $ InProgress AwaitingHandshake
                             return shortRetryInterval
                     -- AwaitingHandshake
                     -- AwaitingSessionPacket
@@ -192,10 +196,10 @@ data FreshenContactMethods = FreshenContactMethods
 -- As long as getPolicy is TryingToConnect and there is no established
 -- connection, this function will continue.
 freshenContact :: STM Policy -> STM (Status t) -> FreshenContactMethods
-                  -> (Status ToxProgress -> STM ())
+                  -> TVar (Status ToxProgress)
                   -> IO ()
-freshenContact getPolicy getStatus FreshenContactMethods{..} writeStatus
-    = whileTryingAndNotEstablished getPolicy getStatus writeStatus
+freshenContact getPolicy getStatus FreshenContactMethods{..} statusVar
+    = whileTryingAndNotEstablished getPolicy getStatus statusVar
          -- retryAfterTimeout :: Int -> IO ()
         $ \retryAfterTimeout ->
             getDHTKey >>= \case
@@ -203,7 +207,7 @@ freshenContact getPolicy getStatus FreshenContactMethods{..} writeStatus
                            retry
                 Just dk -> getSockAddr >>= \case
                     Nothing -> do -- AcquiringIPAddress
-                           writeStatus (InProgress AcquiringIPAddress)
+                           writeTVar statusVar (InProgress AcquiringIPAddress)
                            return $
                                do bkts <- atomically $ getBuckets
                                   st <- search nodeSch bkts dk $
@@ -213,7 +217,7 @@ freshenContact getPolicy getStatus FreshenContactMethods{..} writeStatus
                                                -- TODO: searchCancel on stop condition
                                   retryAfterTimeout sockAddrInterval
                     Just a  -> do
-                            writeStatus (InProgress AcquiringCookie)
+                            writeTVar statusVar (InProgress AcquiringCookie)
                             return $
                                -- AcquiringCookie
                                -- AwaitingHandshake