Only one session at a time (per DHT node).

2 files changed, 33 insertions, 13 deletions

diff --git a/dht/src/Network/Tox/AggregateSession.hs b/dht/src/Network/Tox/AggregateSession.hs
index 33b1fafb..44bbf9b9 100644
--- a/dht/src/Network/Tox/AggregateSession.hs
+++ b/dht/src/Network/Tox/AggregateSession.hs
@@ -28,6 +28,7 @@ import Control.Exception
 import Control.Monad
 import Data.Dependent.Sum
 import Data.Function
+import Data.Functor
 import qualified Data.IntMap.Strict  as IntMap
          ;import Data.IntMap.Strict  (IntMap)
 import Data.List
@@ -219,6 +220,9 @@ forkSession c s setStatus = forkIO $ do
         atomically $ setStatus Dormant
         killThread beacon
 
+sessionIsPreferredTo :: Session -> Session -> Bool
+sessionIsPreferredTo s t = True -- TODO: Check address types.
+
 -- | Add a new session (in 'AwaitingSessionPacket' state) to the
 -- 'AggregateSession'.  If the supplied session is not compatible because it is
 -- between the wrong ToxIDs or because the AggregateSession is closed,
@@ -229,25 +233,35 @@ forkSession c s setStatus = forkIO $ do
 -- one active session).
 addSession :: AggregateSession -> Session -> IO AddResult
 addSession c s = do
-    (result,mcon,rejected) <- atomically $ do
+    (result,mcon,rejected,closed) <- atomically $ do
         let them = sTheirUserKey s
             me   = toPublic $ sOurKey s
-        compat <- checkCompatible me them c
-        let result = case compat of
+        result <- checkCompatible me them c <&> \case
                         Nothing      -> FirstSession
                         Just True    -> AddedSession
                         Just False   -> RejectedSession
         case result of
-            RejectedSession -> return (result,Nothing,Just s)
-            _               -> do
-                                statvar <- newTVar Dormant
-                                imap <- readTVar (contactSession c)
-                                let con = SingleCon s statvar
-                                    s0 = IntMap.lookup (sSessionID s) imap
-                                    imap' = IntMap.insert (sSessionID s) con imap
-                                writeTVar (contactSession c) imap'
-                                return (result,Just con,singleSession <$> s0)
-
+            RejectedSession -> return (result,Nothing,Just s,Nothing)
+            _ -> do
+                statvar <- newTVar Dormant
+                imap <- readTVar (contactSession c)
+                let nodekey = sTheirDHTKey s
+                    ts = [ t | SingleCon t _ <- IntMap.elems imap, nodekey == sTheirDHTKey t ]
+                case ts of
+                    [] -> do
+                        let con = SingleCon s statvar
+                            s0 = IntMap.lookup (sSessionID s) imap
+                            imap' = IntMap.insert (sSessionID s) con imap
+                        writeTVar (contactSession c) imap'
+                        return (result,Just con,singleSession <$> s0, Nothing)
+                    (t:_) | s `sessionIsPreferredTo` t -> do
+                        let con = SingleCon s statvar
+                            s0 = IntMap.lookup (sSessionID s) imap
+                            imap' = IntMap.insert (sSessionID s) con imap
+                        writeTVar (contactSession c) imap'
+                        return (result,Just con,singleSession <$> s0, Just (sSessionID t))
+                    (t:_) -> do
+                        error "TODO: Prefer older session (udp over tcp for example)"
     mapM_ sClose rejected
     when (isNothing mcon) $ dput XMan "addSession: Rejected session!"
     forM_ (mcon :: Maybe SingleCon) $ \con -> do
@@ -263,6 +277,7 @@ addSession c s = do
             writeTVar (contactEstablished c) emap'
             status <- aggregateStatus c
             when (status /= status0) $ notifyState c c s status
+    mapM_ (delSession c) closed
 
     return result
 
diff --git a/dht/src/Network/Tox/Session.hs b/dht/src/Network/Tox/Session.hs
index 53d63287..1b1c62c4 100644
--- a/dht/src/Network/Tox/Session.hs
+++ b/dht/src/Network/Tox/Session.hs
@@ -6,6 +6,7 @@ module Network.Tox.Session
     , SessionKey
     , Session(..)
     , sTheirUserKey
+    , sTheirDHTKey
     , sClose
     , handshakeH
     ) where
@@ -95,6 +96,10 @@ sTheirUserKey s = longTermKey $ runIdentity cookie
  where
     Cookie _ cookie = handshakeCookie (sReceivedHandshake s)
 
+sTheirDHTKey :: Session -> PublicKey
+sTheirDHTKey s = case handshakeCookie $ sReceivedHandshake s of
+    Cookie _ (Identity cd) -> dhtKey cd
+
 -- | Helper to close the 'Transport' associated with a session.
 sClose :: Session -> IO ()
 sClose s = do