cleanup code for netcrypto sessions

1 files changed, 60 insertions, 3 deletions

diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index c5c17e4e..d174b10c 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -345,6 +345,7 @@ data NetCryptoSession = NCrypto
     -- ^ when the thread which dequeues from ncPacketQueue
     -- is started, its ThreadId is stored here
     , ncPingMachine        :: Maybe PingMachine
+    , ncPingThread         :: Maybe ThreadId
     -- ^ when the ping thread is started, store it here
     , ncOutgoingQueue      :: TVar
                                 (UponHandshake
@@ -622,6 +623,7 @@ freshCryptoSession  sessions
                     , ncPacketQueue        = pktq
                     , ncDequeueThread      = Nothing -- error "you want the NetCrypto-Dequeue thread id, but is it started?"
                     , ncPingMachine        = Nothing -- error "you want the NetCrypto-PingMachine, but is it started?"
+                    , ncPingThread         = Nothing -- error "you want the NetCrypto-PingSender, but is it started?"
                     , ncOutgoingQueue      = mbpktoqVar
                     , ncLastNMsgs          = lastNQ
                     , ncListeners          = listeners
@@ -754,7 +756,9 @@ runUponHandshake netCryptoSession0 addr pktoq = do
                     Right _ -> return ()
             PingTimeOut -> dput XNetCrypto $ "(pingThread session: " ++ show (ncSessionId netCryptoSession0) ++ ") PingTimeOut TODO"
     -- update session with thread ids
-    let netCryptoSession = netCryptoSession0 {ncDequeueThread=Just threadid, ncPingMachine=Just pingMachine}
+    let netCryptoSession = netCryptoSession0 { ncDequeueThread=Just threadid
+                                             , ncPingMachine=Just pingMachine
+                                             , ncPingThread=Just pingThreadId}
     -- add this session to the lookup maps
     -- atomically $ addSessionToMapIfNotThere sessions addr netCryptoSession
     -- run announceNewSessionHooks
@@ -770,6 +774,23 @@ runUponHandshake netCryptoSession0 addr pktoq = do
                   Just f -> loop (hs, f session)
                   Nothing -> return ()
 
+destroySession :: NetCryptoSession -> IO ()
+destroySession session = do
+    let allsessions = ncAllSessions session
+        sid = ncSessionId session
+        stopThread :: Maybe ThreadId -> IO ()
+        stopThread x = maybe (return ()) killThread x
+        stopMachine :: Maybe PingMachine -> IO ()
+        stopMachine x = maybe (return ()) pingCancel x
+    atomically $ do
+        modifyTVar (netCryptoSessionsByKey allsessions)
+                   $ Map.map (filter ((/=sid) . ncSessionId))
+        modifyTVar (netCryptoSessions allsessions)
+                   $ Map.filterWithKey (\k v -> ncSessionId v /= sid)
+    stopThread (ncPingThread session)
+    stopMachine (ncPingMachine session)
+    stopThread (ncDequeueThread session)
+
 -- | Called when we get a handshake, but there's already a session entry.
 --
 --     1) duplicate packet ... ignore
@@ -1130,8 +1151,37 @@ sendOffline crypto session = do
 sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
 sendKill crypto session = do
     let cm=OneByte KillPacket
-    addMsgToLastN False (cm ^. messageType) session (Out cm)
-    sendCrypto crypto session (return ()) cm
+    mbOutQ <- atomically $ readTVar (ncOutgoingQueue session)
+    case mbOutQ of
+        NeedHandshake -> do
+            let errmsg="NetCrypto NOT SENDING Kill packet (sessionid: " ++ show (ncSessionId session) ++ ") since no handshake yet"
+            dput XNetCrypto errmsg
+            dput XNetCrypto $ "Destroying session anyway"
+            destroySession session
+            return (Left errmsg)
+        HaveHandshake outq -> do
+            dput XNetCrypto $ "NetCrypto sending Kill packet (sessionid: " ++ show (ncSessionId session) ++ ")"
+            getOutGoingParam <- PQ.readyOutGoing outq
+            mbPkt <- atomically $ PQ.peekPacket getOutGoingParam outq cm
+            case mbPkt of
+                Nothing  -> do
+                    let errmsg = "Error sending kill packet! (sessionid: " ++ show (ncSessionId session) ++ ")"
+                    dput XNetCrypto errmsg
+                    dput XNetCrypto $ "Destroying session anyway"
+                    Right <$> destroySession session
+                    return (Left errmsg)
+                Just (pkt,seqno) -> do
+                    case (ncSockAddr session) of
+                      NeedDHTKey -> do
+                        let errmsg= "NetCrypto NOT SENDING Kill packet (sessionid: " ++ show (ncSessionId session) ++ ") since no DHTkey(sockaddr) yet"
+                        dput XNetCrypto errmsg
+                        dput XNetCrypto $ "Destroying session anyway"
+                        Right <$> destroySession session
+                        return (Left errmsg)
+                      HaveDHTKey saddr -> do
+                        sendSessionPacket (ncAllSessions session) saddr pkt
+                        dput XNetCrypto $ "sent kill packet (sessionid: " ++ show (ncSessionId session) ++ ")... now destroying session..."
+                        Right <$> destroySession session
 
 setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ())
 setNick crypto session nick = do
@@ -1207,8 +1257,15 @@ defaultCryptoDataHooks
             , (Msg TYPING,[defaultTypingHook])
             , (Msg NICKNAME, [defaultNicknameHook])
             , (Msg STATUSMESSAGE, [defaultStatusMsgHook])
+            , (Msg KillPacket, [defaultKillHook])
             ]
 
+defaultKillHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
+defaultKillHook session cm@(OneByte {msgID=KillPacket}) = do
+    dput XNetCrypto $ "Recieved kill packet (sessionid: " ++ show (ncSessionId session) ++ ") destroying session"
+    destroySession session
+    return Nothing
+
 defaultUserStatusHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
 defaultUserStatusHook session cm@(TwoByte {msgID=USERSTATUS, msgByte=statusByte}) = do
     let status = toEnum8 statusByte