Experimental Connection.Tox integration

1 files changed, 20 insertions, 2 deletions

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