call setTerminated from destroySession

2 files changed, 30 insertions, 4 deletions

diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index cebbebfb..26488657 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -354,6 +354,18 @@ getOnionAlias crypto dhtself remoteNode = atomically $ do
             _ -> ni { nodeId = key2id (onionAliasPublic crypto) }
     return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing
 
+mkDefaultDestroyHook :: ContactInfo extra -> NetCryptoSession -> IO ()
+mkDefaultDestroyHook roster = \session -> do
+   now <- getPOSIXTime
+   r <- atomically $ 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
+            Nothing -> return . Left $ "(defaultDestroyHook) their is no account! pubkey=" ++ show (key2id (ncTheirPublicKey session))
+   case r of
+    Left msg -> dput XMan msg
+    _ -> return ()
 
 newTox :: TVar Onion.AnnouncedKeys   -- ^ Store of announced keys we are a rendezvous for.
        -> SockAddr                   -- ^ Bind-address to listen on.
@@ -362,14 +374,18 @@ newTox :: TVar Onion.AnnouncedKeys   -- ^ Store of announced keys we are a rende
        -> IO (Tox extra)
 newTox keydb addr mbSessionsState suppliedDHTKey = do
     (udp,sock) <- {- addVerbosity <$> -} udpTransport' addr
+    roster <- newContactInfo
     (crypto0,sessionsState0) <- case mbSessionsState of
                                  Nothing -> do
                                     crypto <- newCrypto
-                                    sessionsState <- newSessionsState crypto defaultUnRecHook defaultCryptoDataHooks
+                                    sessionsState <- newSessionsState crypto (mkDefaultDestroyHook roster) defaultUnRecHook defaultCryptoDataHooks
                                     return (crypto,sessionsState)
-                                 Just s -> return (transportCrypto s, s)
+                                 Just s -> do
+                                    let oldhook = defaultDestroyHook s
+                                        oldhook' = filter ((==0) . fst) oldhook
+                                        newhook = (0,mkDefaultDestroyHook roster):oldhook'
+                                    return (transportCrypto s, s { defaultDestroyHook = newhook})
 
-    roster <- newContactInfo
     let -- patch in supplied DHT key
         crypto1 = fromMaybe crypto0 $do
             k <- suppliedDHTKey
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 2e00d61b..85e6192a 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -326,6 +326,7 @@ data NetCryptoSession = NCrypto
                                        TVar
     , ncUnrecognizedHook   :: TVar (MessageType -> NetCryptoHook)
     , ncIdleEventHooks     :: TVar [(Int,NetCryptoSession -> IO ())]
+    , ncDestoryHooks       :: TVar [(Int,NetCryptoSession -> IO ())]
     , ncIncomingTypeArray  :: TVar MsgTypeArray
     -- ^ This array maps 255 Id bytes to MessageType
     -- It should contain all messages this session understands.
@@ -412,6 +413,7 @@ data NetCryptoSessions = NCSessions
     , defaultHooks            :: Map.Map MessageType [NetCryptoHook]
     , defaultUnrecognizedHook :: MessageType -> NetCryptoHook
     , defaultIdleEventHooks   :: [(Int,NetCryptoSession -> IO ())]
+    , defaultDestroyHook      :: [(Int,NetCryptoSession -> IO ())]
     , sessionView             :: SessionView
     , msgTypeArray            :: MsgTypeArray
     , inboundQueueCapacity    :: Word32
@@ -445,10 +447,11 @@ forgetCrypto crypto (NCSessions {netCryptoSessions,netCryptoSessionsByKey}) sess
                                                                     ys -> Just ys) sPubKey)
 
 newSessionsState :: TransportCrypto
+                 -> (NetCryptoSession -> IO ())         -- ^ default destroy hook
                  -> (MessageType -> NetCryptoHook)      -- ^ default hook
                  -> Map.Map MessageType [NetCryptoHook] -- ^ all hooks, can be empty to start
                  -> IO NetCryptoSessions
-newSessionsState crypto unrechook hooks = do
+newSessionsState crypto destroyHook unrechook hooks = do
     x <- atomically $ newTVar Map.empty
     x2 <- atomically $ newTVar Map.empty
     nick <- atomically $ newTVar B.empty
@@ -479,6 +482,7 @@ newSessionsState crypto unrechook hooks = do
                       , defaultHooks            = hooks
                       , defaultUnrecognizedHook = unrechook
                       , defaultIdleEventHooks   = [(0,handleRequestsOutOfOrder)]
+                      , defaultDestroyHook      = [(0,destroyHook)]
                       , sessionView             = SessionView
                             { svNick        = nick
                             , svStatus      = status
@@ -609,6 +613,7 @@ freshCryptoSession  sessions
     ncHooks0 <- newTVar (defaultHooks sessions)
     ncUnrecognizedHook0 <- newTVar (defaultUnrecognizedHook sessions)
     ncIdleEventHooks0 <- newTVar (defaultIdleEventHooks sessions)
+    ncDestoryHooks0 <- newTVar (defaultDestroyHook sessions)
     ncIncomingTypeArray0 <- newTVar (msgTypeArray sessions)
     let idMap = foldl (\mp (x,y) -> W64.insert x y mp) W64.empty (zip [0..255] [0..255])
     (ncOutgoingIdMap0,lossyEscapeIdMap,losslessEscapeIdMap,ncOutHooks0) <- do
@@ -684,6 +689,7 @@ freshCryptoSession  sessions
                     , ncOutHooks           = ncOutHooks0
                     , ncUnrecognizedHook   = ncUnrecognizedHook0
                     , ncIdleEventHooks     = ncIdleEventHooks0
+                    , ncDestoryHooks       = ncDestoryHooks0
                     , ncAllSessions        = sessions
                     , ncIncomingTypeArray  = ncIncomingTypeArray0
                     , ncOutgoingIdMap      = ncOutgoingIdMap0
@@ -892,6 +898,10 @@ runUponHandshake netCryptoSession0 addr pktoq = do
 
 destroySession :: NetCryptoSession -> IO ()
 destroySession session = do
+    -- first run all destory hooks
+    hooks <- atomically (readTVar (ncDestoryHooks session))
+    forM_ hooks $ \(key,hook) -> hook session
+    -- now clean up threads
     let allsessions = ncAllSessions session
         sid = ncSessionId session
         stopThread :: TVar (Maybe ThreadId) -> IO ()