ensure setTerminated not called if there is another NetCryptoSessoin on same key

1 files changed, 16 insertions, 1 deletions

diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 26488657..93d42eca 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -68,6 +68,8 @@ import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Map.Strict as Map
 import DPut
 import Network.Tox.Avahi
+import Text.Printf
+import Data.List
 
 newCrypto :: IO TransportCrypto
 newCrypto = do
@@ -361,7 +363,20 @@ mkDefaultDestroyHook roster = \session -> do
            accounts <- readTVar (accounts roster) -- :: STM (HashMap NodeId (Account extra)
            let mbAccount = HashMap.lookup (key2id $ ncMyPublicKey session) accounts -- :: STM (Maybe (Account extra)
            case mbAccount of
-            Just account -> Right <$> setTerminated now (ncTheirPublicKey session) account
+            Just account -> do
+                mp <- readTVar (netCryptoSessionsByKey (ncAllSessions session))
+                case Map.lookup (ncTheirPublicKey session) mp of
+                    Just sessionsWithThisPublicKey
+                        | relevantSessions <- filter ((/=ncSessionId session) . ncSessionId) sessionsWithThisPublicKey
+                        , not (null relevantSessions)
+                        -> do
+                     let showsession x = printf "%x" (ncSessionId x)
+                     return . Left $ "Not calling setTerminated on " ++ show (key2id (ncTheirPublicKey session))
+                                            ++" despite session(" ++ showsession session
+                                            ++ ") failure. (Still have sessions: ["
+                                            ++ Data.List.intercalate "," (map showsession relevantSessions)
+                                            ++ "]"
+                    _ -> Right <$> setTerminated now (ncTheirPublicKey session) account
             Nothing -> return . Left $ "(defaultDestroyHook) their is no account! pubkey=" ++ show (key2id (ncTheirPublicKey session))
    case r of
     Left msg -> dput XMan msg