2 files changed, 104 insertions, 74 deletions

diff --git a/Connection/Tox.hs b/Connection/Tox.hs
index 1d133628..c8ce9a53 100644
--- a/Connection/Tox.hs
+++ b/Connection/Tox.hs
@@ -1,82 +1,26 @@
+{-# LANGUAGE CPP   #-}
 {-# LANGUAGE GADTs #-}
 module Connection.Tox where
 
 import qualified Connection   as G
          ;import Connection   (Manager (..), Policy (..))
 import Control.Concurrent.STM
--- import Crypto.Tox
+import Control.Monad
 import Data.Dependent.Sum
 import Data.Functor.Identity
-import qualified Data.Map     as Map
--- import Data.Maybe
--- import Network.Tox
+import qualified Data.Map    as Map
+import Connection.Tox.Threads
 import Network.Tox.NodeId
 import PingMachine
 import Text.Read
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
 
 
--- | This type indicates the progress of a tox encrypted friend link
--- connection.  Two scenarios are illustrated below.  The parenthesis show the
--- current 'G.Status' 'ToxProgress' of the session.
---
---
--- Perfect handshake scenario:
---
---  Peer 1                                  Peer 2
---  (InProgress AcquiringCookie)            (Dormant/InProgress AcquiringCookie)
---                     Cookie request ->
---                                       <- Cookie response
---  (InProgress AwaitingHandshake)          (Dormant/InProgress AcquiringCookie)
---                   Handshake packet ->
---                                          * accepts connection
---                                          (InProgress AwaitingSessionPacket)
---                                       <- Handshake packet
---  *accepts connection
---  (InProgress AwaitingSessionPacket)
---                   Encrypted packet -> <- Encrypted packet
---  *confirms connection                    *confirms connection
---  (Established)                           (Established)
---
---                           Connection successful.
---
---                  Encrypted packets -> <- Encrypted packets
---
---
---
---
---  More realistic handshake scenario:
---  Peer 1                                  Peer 2
---  (InProgress AcquiringCookie)            (Dormant/InProgress AcquiringCookie)
---                      Cookie request ->   *packet lost*
---                      Cookie request ->
---                                        <- Cookie response
---  (InProgress AwaitingHandshake)           (Dormant/InProgress AcquiringCookie)
---
---                                           *Peer 2 randomly starts new connection to peer 1
---                                           (InProgress AcquiringCookie)
---                                        <- Cookie request
---                     Cookie response ->
---                                           (InProgress AwaitingHandshake)
---
---                    Handshake packet -> <- Handshake packet
---  *accepts connection                      * accepts connection
---  (InProgress AwaitingSessionPacket)      (InProgress AwaitingSessionPacket)
---
---                    Encrypted packet -> <- Encrypted packet
---  *confirms connection                     *confirms connection
---  (Established)                           (Established)
---
---                              Connection successful.
---
---                   Encrypted packets -> <- Encrypted packets
-data ToxProgress
-    = AwaitingDHTKey        -- ^ Waiting to receive their DHT key.
-    | AcquiringIPAddress    -- ^ Searching DHT to obtain their node's IP & port.
-    | AcquiringCookie       -- ^ Attempting to obtain a cookie.
-    | AwaitingHandshake     -- ^ Waiting to receive a handshake.
-    | AwaitingSessionPacket -- ^ Connection is "accepted" but not yet "confirmed".
-    deriving (Eq,Ord,Enum,Show)
-
 
 data Parameters = Parameters
     { -- | Various Tox transports and clients.
@@ -87,6 +31,7 @@ data Parameters = Parameters
     }
 
 data Key = Key NodeId{-me-} NodeId{-them-}
+ deriving (Eq,Ord)
 
 instance Show Key where show = show . showKey_
 
@@ -126,6 +71,16 @@ sessionStatus st = G.Connection
     , G.connPingLogic = connPingLogic st
     }
 
+lookupForPolicyChange :: TVar (Map.Map Key SessionState)
+                         -> Key -> Policy -> IO (Maybe SessionState)
+lookupForPolicyChange conmap k policy = atomically $ do
+    cons <- readTVar conmap
+    fmap join $ forM (Map.lookup k cons) $ \st -> do
+        p <- readTVar (connPolicy st)
+        writeTVar (connPolicy st) policy
+        return $ do
+            guard $ p /= policy
+            return st
 
 -- | This function will fork threads as necessary.
 setToxPolicy :: Parameters
@@ -135,15 +90,26 @@ setToxPolicy :: Parameters
              -> IO ()
 setToxPolicy params conmap k policy = case policy of
     TryingToConnect -> do
-        -- TODO initiate connecting if we haven't already
-        -- When established, invoke 'onToxSession'.
-        return ()
-    RefusingToConnect -> do
-        -- TODO disconnect or cancel any pending connection
+        mst <- lookupForPolicyChange conmap k policy
+        forM_ mst $ \st -> do
+            let getPolicy = readTVar $ connPolicy st
+            --TODO accept_thread may already be started if policy was OpenToConnect
+            accept_thread  <- forkIO $ acceptContact  getPolicy _accept_methods
+            persue_thread  <- forkIO $ persueContact  getPolicy _get_status _persue_methods
+            freshen_thread <- forkIO $ freshenContact getPolicy _get_status _freshen_methods
+            return ()
         return ()
-    OpenToConnect -> do
-        -- TODO passively accept connections if they initiate.
+    RefusingToConnect -> do -- disconnect or cancel any pending connection
+        mst <- lookupForPolicyChange conmap k policy
+        -- Since the 3 connection threads poll the current policy, they should
+        -- all terminate on their own.
         return ()
+    OpenToConnect -> do -- passively accept connections if they initiate.
+        mst <- lookupForPolicyChange conmap k policy
+        forM_ mst $ \st -> do
+            let getPolicy = readTVar $ connPolicy st
+            accept_thread  <- forkIO $ acceptContact  getPolicy _accept_methods
+            return ()
 
 
 showKey_ :: Key -> String
diff --git a/Connection/Tox/Threads.hs b/Connection/Tox/Threads.hs
index 8b19c7cf..dcee37d1 100644
--- a/Connection/Tox/Threads.hs
+++ b/Connection/Tox/Threads.hs
@@ -12,7 +12,7 @@
 module Connection.Tox.Threads where
 
 import Connection
-import Connection.Tox
+-- import Connection.Tox
 import Data.IP (IP)
 import Network.Tox.Crypto.Transport
 import Network.Tox.NodeId
@@ -27,6 +27,70 @@ import Data.Function
 import Data.Functor.Identity
 import System.Timeout
 
+
+-- | This type indicates the progress of a tox encrypted friend link
+-- connection.  Two scenarios are illustrated below.  The parenthesis show the
+-- current 'G.Status' 'ToxProgress' of the session.
+--
+--
+-- Perfect handshake scenario:
+--
+--  Peer 1                                  Peer 2
+--  (InProgress AcquiringCookie)            (Dormant/InProgress AcquiringCookie)
+--                     Cookie request ->
+--                                       <- Cookie response
+--  (InProgress AwaitingHandshake)          (Dormant/InProgress AcquiringCookie)
+--                   Handshake packet ->
+--                                          * accepts connection
+--                                          (InProgress AwaitingSessionPacket)
+--                                       <- Handshake packet
+--  *accepts connection
+--  (InProgress AwaitingSessionPacket)
+--                   Encrypted packet -> <- Encrypted packet
+--  *confirms connection                    *confirms connection
+--  (Established)                           (Established)
+--
+--                           Connection successful.
+--
+--                  Encrypted packets -> <- Encrypted packets
+--
+--
+--
+--
+--  More realistic handshake scenario:
+--  Peer 1                                  Peer 2
+--  (InProgress AcquiringCookie)            (Dormant/InProgress AcquiringCookie)
+--                      Cookie request ->   *packet lost*
+--                      Cookie request ->
+--                                        <- Cookie response
+--  (InProgress AwaitingHandshake)           (Dormant/InProgress AcquiringCookie)
+--
+--                                           *Peer 2 randomly starts new connection to peer 1
+--                                           (InProgress AcquiringCookie)
+--                                        <- Cookie request
+--                     Cookie response ->
+--                                           (InProgress AwaitingHandshake)
+--
+--                    Handshake packet -> <- Handshake packet
+--  *accepts connection                      * accepts connection
+--  (InProgress AwaitingSessionPacket)      (InProgress AwaitingSessionPacket)
+--
+--                    Encrypted packet -> <- Encrypted packet
+--  *confirms connection                     *confirms connection
+--  (Established)                           (Established)
+--
+--                              Connection successful.
+--
+--                   Encrypted packets -> <- Encrypted packets
+data ToxProgress
+    = AwaitingDHTKey        -- ^ Waiting to receive their DHT key.
+    | AcquiringIPAddress    -- ^ Searching DHT to obtain their node's IP & port.
+    | AcquiringCookie       -- ^ Attempting to obtain a cookie.
+    | AwaitingHandshake     -- ^ Waiting to receive a handshake.
+    | AwaitingSessionPacket -- ^ Connection is "accepted" but not yet "confirmed".
+    deriving (Eq,Ord,Enum,Show)
+
+
 type NodeSearch = Search NodeId (IP,PortNumber) () NodeInfo NodeInfo
 
 data AcceptContactMethods = AcceptContactMethods