tox: Associate a state with each connection management thread.

1 files changed, 35 insertions, 15 deletions

diff --git a/Connection/Tox/Threads.hs b/Connection/Tox/Threads.hs
index dcee37d1..2ff058b3 100644
--- a/Connection/Tox/Threads.hs
+++ b/Connection/Tox/Threads.hs
@@ -102,26 +102,33 @@ data AcceptContactMethods = AcceptContactMethods
 -- | Invokes an STM action on each incoming handshake.
 --
 -- Does not return until getPolicy yields RefusingToConnect.
-acceptContact :: STM Policy -> AcceptContactMethods -> IO ()
-acceptContact getPolicy AcceptContactMethods{..} = fix $ \loop -> do
+acceptContact :: STM Policy -> AcceptContactMethods -> (Status ToxProgress -> STM ()) -> IO ()
+acceptContact getPolicy AcceptContactMethods{..} writeState = fix $ \loop -> do
     join $ atomically $ do
         orElse
             (getPolicy >>= \case
-                RefusingToConnect -> return $ return () -- QUIT Dormant/Established
+                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) -> ((Int -> IO ()) -> STM (IO ())) -> IO ()
-whileTryingAndNotEstablished getPolicy getStatus body = fix $ \loop -> do
+whileTryingAndNotEstablished :: STM Policy
+                                -> STM (Status t)
+                                -> (Status ToxProgress -> STM ())
+                                -> ((Int -> IO ()) -> STM (IO ()))
+                                -> IO ()
+whileTryingAndNotEstablished getPolicy getStatus writeStatus body = fix $ \loop -> do
     let retryWhileTrying k = getPolicy >>= \case
             TryingToConnect -> retry
-            _               -> return k
+            _               -> do writeStatus Dormant
+                                  return k
         ifEstablished t e = getStatus >>= \case
             Established -> t
             _           -> e
@@ -147,17 +154,23 @@ data PersueContactMethods params = PersueContactMethods
 --
 -- As long as getPolicy is TryingToConnect and there is no established
 -- connection, this function will continue.
-persueContact :: STM Policy -> STM (Status t) -> PersueContactMethods a -> IO ()
-persueContact getPolicy getStatus PersueContactMethods{..}
-    = whileTryingAndNotEstablished getPolicy getStatus
+persueContact :: STM Policy
+                 -> STM (Status t)
+                 -> PersueContactMethods a
+                 -> (Status ToxProgress -> STM ())
+                 -> IO ()
+persueContact getPolicy getStatus PersueContactMethods{..} writeStatus
+    = whileTryingAndNotEstablished getPolicy getStatus writeStatus
         $ \retryAfterTimeout -> do
             -- AwaitingDHTKey
             -- AcquiringIPAddress
             params <- getHandshakeParams
+            writeStatus (InProgress AcquiringCookie)
             return $ do -- AcquiringCookie
                         -- AwaitingHandshake
                         -- AwaitingSessionPacket
                         sendHandshake params
+                        atomically $ writeStatus $ InProgress AwaitingHandshake
                         retryAfterTimeout retryInterval
 
 data FreshenContactMethods = FreshenContactMethods
@@ -189,16 +202,20 @@ 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 -> IO ()
-freshenContact getPolicy getStatus FreshenContactMethods{..}
-    = whileTryingAndNotEstablished getPolicy getStatus
+freshenContact :: STM Policy -> STM (Status t) -> FreshenContactMethods
+                  -> (Status ToxProgress -> STM ())
+                  -> IO ()
+freshenContact getPolicy getStatus FreshenContactMethods{..} writeStatus
+    = whileTryingAndNotEstablished getPolicy getStatus writeStatus
          -- retryAfterTimeout :: Int -> IO ()
         $ \retryAfterTimeout ->
             getDHTKey >>= \case
                 Nothing -> -- AwaitingDHTKey
                            retry
-                Just dk -> getSockAddr >>= return . \case
-                    Nothing -> -- AcquiringIPAddress
+                Just dk -> getSockAddr >>= \case
+                    Nothing -> do -- AcquiringIPAddress
+                           writeStatus (InProgress AcquiringIPAddress)
+                           return $
                                do bkts <- atomically $ getBuckets
                                   st <- search nodeSch bkts dk $
                                             \r -> do -- TODO: store saddr, check for finish
@@ -206,7 +223,10 @@ freshenContact getPolicy getStatus FreshenContactMethods{..}
                                   atomically $ searchIsFinished st >>= check
                                                -- TODO: searchCancel on stop condition
                                   retryAfterTimeout sockAddrInterval
-                    Just a  -> -- AcquiringCookie
+                    Just a  -> do
+                            writeStatus (InProgress AcquiringCookie)
+                            return $
+                               -- AcquiringCookie
                                -- AwaitingHandshake
                                -- AwaitingSessionPacket
                                do _todo_search_toxid_send_dhtkey -- 123 _todo_search_toxid_send_dhtkey :: IO a0