Fill in needed parameters to toxManager.

2 files changed, 57 insertions, 28 deletions

diff --git a/Connection/Tox.hs b/Connection/Tox.hs
index 2c485edd..436e7599 100644
--- a/Connection/Tox.hs
+++ b/Connection/Tox.hs
@@ -1,21 +1,25 @@
-{-# LANGUAGE CPP   #-}
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE CPP            #-}
+{-# LANGUAGE GADTs          #-}
+{-# LANGUAGE NamedFieldPuns #-}
 module Connection.Tox
     ( module Connection.Tox
     , ToxProgress(..)
     ) where
 
-import qualified Connection   as G
-         ;import Connection   (Manager (..), Policy (..))
+import qualified Connection          as G
+         ;import Connection          (Manager (..), Policy (..))
+import Connection.Tox.Threads
 import Control.Concurrent.STM
 import Control.Monad
--- import Data.Dependent.Sum
+import Crypto.Tox
 import Data.Functor.Identity
-import qualified Data.Map    as Map
-import Connection.Tox.Threads
-import Network.Tox.NodeId
-import Network.Tox.DHT.Handlers
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Map            as Map
+import Network.Tox.ContactInfo
 import Network.Tox.Crypto.Handlers
+import Network.Tox.DHT.Handlers      as DHT
+import Network.Tox.DHT.Transport     as DHT
+import Network.Tox.NodeId
 import PingMachine
 import Text.Read
 #ifdef THREAD_DEBUG
@@ -24,7 +28,7 @@ import Control.Concurrent.Lifted.Instrument
 import Control.Concurrent.Lifted
 import GHC.Conc                  (labelThread)
 #endif
-import GHC.Conc (threadStatus,ThreadStatus(..))
+import GHC.Conc (ThreadStatus (..), threadStatus)
 
 
 
@@ -32,6 +36,9 @@ import GHC.Conc (threadStatus,ThreadStatus(..))
 data Parameters = Parameters
     { -- | Various Tox transports and clients.
       dhtRouting :: Routing
+    , roster     :: ContactInfo
+    , sessions   :: NetCryptoSessions
+    , dhtClient  :: DHT.Client
       -- | Thread to be forked when a connection is established.
       -- TODO: this function should accept relevant parameters.
     , onToxSession  :: IO ()
@@ -113,22 +120,38 @@ lookupForPolicyChange conmap k policy = atomically $ do
 callbackId :: Int
 callbackId = 1
 
+lookupContact :: Key -> ContactInfo -> STM (Maybe (SecretKey,Contact))
+lookupContact (Key me them) ContactInfo{accounts} = do
+    acnts <- readTVar accounts
+    fmap join $ forM (HashMap.lookup me acnts) $ \Account{userSecret,contacts} -> do
+        cs <- readTVar contacts
+        forM (HashMap.lookup them cs) $ \c -> do
+            return (userSecret,c)
+
 -- | This function will fork threads as necessary.
 setToxPolicy :: Parameters
              -> TVar (Map.Map Key SessionState)
              -> Key
              -> Policy
              -> IO ()
-setToxPolicy params conmap k policy = case policy of
+setToxPolicy params conmap k@(Key me them) policy = case policy of
     TryingToConnect -> do
         mst <- lookupForPolicyChange conmap k policy
+        r <- atomically $ lookupContact k (roster params)
+        forM_ r $ \(sec,c) -> do
         let accept_methods = AcceptContactMethods
                 { getHandshake        = retry -- :: STM (Handshake Identity)
                 , handshakeIsSuitable = (\_ -> return False) -- :: Handshake Identity -> STM Bool
                 , transitionToState   = (\_ -> return ()) :: G.Status ToxProgress -> STM ()
                 }
             persue_methods = PersueContactMethods
-                { -- TODO
+                { allsessions        = sessions params
+                , myseckey           = sec
+                , theirpubkey        = id2key them
+                , client             = dhtClient params
+                , shortRetryInterval = _todo
+                , longRetryInterval  = _todo
+                , contact            = c
                 }
             freshen_methods = FreshenContactMethods
                 { dhtkeyInterval   = _todo :: Int
@@ -138,6 +161,7 @@ setToxPolicy params conmap k policy = case policy of
                 , getSockAddr      = retry -- :: STM (Maybe SockAddr)
                 , getBuckets       = retry -- :: STM (BucketList NodeInfo)
                 }
+            get_status = readTVar (ncState _todo)
         forM_ mst $ \st -> do
             let getPolicy = readTVar $ connPolicy st
             tasks <- atomically $ readTVar (sessionTasks st)
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 091c268d..29b980b7 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE CPP                        #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveFoldable             #-}
@@ -12,8 +11,10 @@
 {-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE RecursiveDo                #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE ViewPatterns               #-}
 module Network.Tox where
 
 import Debug.Trace
@@ -446,21 +447,25 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do
         tbl6 = DHT.routing6 $ mkrouting (error "missing client")
     dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id
                     $ \client net -> onInbound (DHT.updateRouting client (mkrouting client) orouter) net
-    mgr <- toxManager (Parameters { dhtRouting = mkrouting dhtclient
-                                  , onToxSession = return () -- TODO
-                                  })
-
-    let policylookup key = do
-            mp <- connections mgr
-            case Map.lookup key mp of
-                Nothing -> return OpenToConnect
-                Just conn -> Connection.connPolicy conn
-
-    let sessionsState = sessionsState0 { sendHandshake     = sendMessage handshakes
-                                       , sendSessionPacket = sendMessage cryptonet
-                                       , transportCrypto   = crypto
-                                       , netCryptoPolicyByKey = policylookup
-                                       }
+    -- TODO: Refactor so this recursive do is unnecessary.
+    rec (mgr,sessionsState) <- do
+        mgr <- toxManager (Parameters { dhtRouting   = mkrouting dhtclient
+                                      , roster       = roster
+                                      , sessions     = sessionsState
+                                      , dhtClient    = dhtclient
+                                      , onToxSession = return () -- TODO
+                                      })
+        let policylookup key = do
+                mp <- connections mgr
+                case Map.lookup key mp of
+                    Nothing -> return OpenToConnect
+                    Just conn -> Connection.connPolicy conn
+
+        return (mgr, sessionsState0 { sendHandshake     = sendMessage handshakes
+                                    , sendSessionPacket = sendMessage cryptonet
+                                    , transportCrypto   = crypto
+                                    , netCryptoPolicyByKey = policylookup
+                                    })
 
     orouter' <- forkRouteBuilder orouter
         $ \nid ni -> fmap (\(_,ns,_)->ns)