Experimental Connection.Tox integration

2 files changed, 37 insertions, 5 deletions

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