Experimental Connection.Tox integration

3 files changed, 42 insertions, 18 deletions

diff --git a/Connection/Tox.hs b/Connection/Tox.hs
index 5a9dc5eb..08a930bf 100644
--- a/Connection/Tox.hs
+++ b/Connection/Tox.hs
@@ -13,9 +13,9 @@ import Control.Monad
 import Data.Functor.Identity
 import qualified Data.Map    as Map
 import Connection.Tox.Threads
-import Network.Tox
 import Network.Tox.NodeId
 import Network.Tox.DHT.Handlers
+import Network.Tox.Crypto.Handlers
 import PingMachine
 import Text.Read
 #ifdef THREAD_DEBUG
@@ -31,16 +31,12 @@ import GHC.Conc (threadStatus,ThreadStatus(..))
 
 data Parameters = Parameters
     { -- | Various Tox transports and clients.
-      toxTransports :: Tox
+      dhtRouting :: Routing
       -- | Thread to be forked when a connection is established.
       -- TODO: this function should accept relevant parameters.
     , onToxSession  :: IO ()
     }
 
-data Key = Key NodeId{-me-} NodeId{-them-}
- deriving (Eq,Ord)
-
-instance Show Key where show = show . showKey_
 
 {-
 -- | A conneciton status that is tagged with a state type that is specific to
@@ -165,7 +161,7 @@ setToxPolicy params conmap k policy = case policy of
                                $ freshenContact getPolicy _get_status freshen_methods
             atomically $ do
                 writeTVar (sessionTasks st) $ SessionTasks accepting persuing refreshing
-                let routing   = toxRouting $ toxTransports params
+                let routing   = dhtRouting params
                     Key _ nid = k
                 registerNodeCallback routing $ NodeInfoCallback
                     { interestingNodeId = nid
@@ -182,7 +178,7 @@ setToxPolicy params conmap k policy = case policy of
         -- Here we block until they finish.
         forM_ mst $ \st -> do
             atomically $ do
-                let routing   = toxRouting $ toxTransports params
+                let routing   = dhtRouting params
                     Key _ nid = k
                 unregisterNodeCallback callbackId routing nid
             atomically $ do
@@ -201,7 +197,7 @@ setToxPolicy params conmap k policy = case policy of
                                      (G.InProgress $ toEnum 0)
                                      $ acceptContact  getPolicy _accept_methods
             atomically $ do
-                let routing   = toxRouting $ toxTransports params
+                let routing   = dhtRouting params
                     Key _ nid = k
                 registerNodeCallback routing $ NodeInfoCallback
                     { interestingNodeId = nid
@@ -210,10 +206,6 @@ setToxPolicy params conmap k policy = case policy of
                     , rumoredAddress    = \saddr ni -> return () -- TODO
                     }
 
-
-showKey_ :: Key -> String
-showKey_ (Key me them) = show me ++ ":" ++ show them
-
 stringToKey_ :: String -> Maybe Key
 stringToKey_ s = let (xs,ys) = break (==':') s
                  in if null ys then Nothing
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 41deff42..3324c934 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -98,6 +98,7 @@ import Network.BitTorrent.DHT.Token           as Token
 import GHC.TypeLits
 
 import Connection
+import Connection.Tox
 import Crypto.Tox
 import Data.Word64Map                        (fitsInInt)
 import qualified Data.Word64Map              (empty)
@@ -254,6 +255,7 @@ data Tox = Tox
     , toxOnionRoutes    :: OnionRouter
     , toxContactInfo    :: ContactInfo
     , toxAnnounceToLan  :: IO ()
+    , toxMgr :: Manager ToxProgress Key
     }
 
 -- | initiate a netcrypto session, blocking
@@ -440,14 +442,26 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do
     orouter <- newOnionRouter ignoreErrors
     (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) <- toxTransport crypto orouter lookupClose udp
 
-    let sessionsState = sessionsState0 { sendHandshake     = sendMessage handshakes
-                                       , sendSessionPacket = sendMessage cryptonet
-                                       , transportCrypto   = crypto }
     let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
         tbl4 = DHT.routing4 $ mkrouting (error "missing client")
         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
+                                       }
 
     orouter' <- forkRouteBuilder orouter
         $ \nid ni -> fmap (\(_,ns,_)->ns)
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 20560a48..61b2ab3c 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -55,9 +55,18 @@ import DPut
 import Debug.Trace
 import Text.Printf
 import Data.Bool
-import Connection (Status(..))
+import Connection (Status(..), Policy(..))
 import Connection.Tox.Threads (ToxProgress(..))
 
+type LookupPolicyFunction = Key -> STM Policy
+
+data Key = Key NodeId{-me-} NodeId{-them-}
+ deriving (Eq,Ord)
+
+instance Show Key where show = show . showKey_
+
+showKey_ :: Key -> String
+showKey_ (Key me them) = show me ++ ":" ++ show them
 
 -- * These types are isomorphic to Maybe, but have the advantage of documenting
 --   when an item is expected to become known.
@@ -296,6 +305,7 @@ data NetCryptoSession = NCrypto
 data NetCryptoSessions = NCSessions
     { netCryptoSessions       :: TVar (Map.Map SockAddr NetCryptoSession)
     , netCryptoSessionsByKey  :: TVar (Map.Map PublicKey [NetCryptoSession])
+    , netCryptoPolicyByKey    :: LookupPolicyFunction
     , transportCrypto         :: TransportCrypto
     , defaultHooks            :: Map.Map MessageType [NetCryptoHook]
     , defaultUnrecognizedHook :: MessageType -> NetCryptoHook
@@ -361,6 +371,7 @@ newSessionsState crypto unrechook hooks = do
     lsupplyVar <- atomically (newTVar lsupply)
     return NCSessions { netCryptoSessions       = x
                       , netCryptoSessionsByKey  = x2
+                      , netCryptoPolicyByKey    = \_ -> return OpenToConnect
                       , transportCrypto         = crypto
                       , defaultHooks            = hooks
                       , defaultUnrecognizedHook = unrechook
@@ -872,7 +883,14 @@ handshakeH sessions addrRaw hshake@(Handshake (Cookie n24 ecookie) nonce24 encry
                     case Map.lookup addr sessionsmap of
                         Nothing -> do
                             dmsg $ "sockaddr(" ++ show addr ++ ") not in session map(" ++ show (map (second ncSessionId) (Map.assocs sessionsmap)) ++ "), so freshCryptoSession"
-                            freshCryptoSession sessions addr newsession timestamp hp -- create new session
+                            let k = Key (key2id . toPublic $ key) (key2id remotePublicKey)
+                            policy <- netCryptoPolicyByKey sessions k
+                            case policy of
+                                x | x `elem` [OpenToConnect,TryingToConnect] -> 
+                                    freshCryptoSession sessions addr newsession timestamp hp -- create new session
+                                x -> do
+                                    dmsg $ "Ignoring Handshake from " ++ show (key2id remotePublicKey) ++ " due to policy: " ++ show x
+                                    return (Nothing,return ())
                         Just session -> do
                             dmsg "sockaddr ALREADY in session map, so updateCryptoSession"
                             updateCryptoSession sessions addr (ncSessionSecret session) timestamp hp session hshake -- update existing session