cleanup code for netcrypto sessions

2 files changed, 83 insertions, 3 deletions

diff --git a/src/Data/PacketQueue.hs b/src/Data/PacketQueue.hs
index cb308bce..f9d9f28f 100644
--- a/src/Data/PacketQueue.hs
+++ b/src/Data/PacketQueue.hs
@@ -17,6 +17,7 @@ module Data.PacketQueue
     , packetQueueViewList
     , newOutGoing
     , readyOutGoing
+    , peekPacket
     , tryAppendQueueOutgoing
     , dequeueOutgoing
     , getHighestHandledPacketPlus1
@@ -187,6 +188,27 @@ data OutGoingResult = OGSuccess | OGFull | OGEncodeFail
 readyOutGoing :: PacketOutQueue extra msg wire fromwire -> IO (STM extra)
 readyOutGoing (PacketOutQueue {pktoToWireIO }) = pktoToWireIO
 
+peekPacket :: STM extra -> PacketOutQueue extra msg wire fromwire -> msg -> STM (Maybe (wire,Word32))
+peekPacket getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoToWireIO, pktoToWire }) msg
+ = do
+    be <- readTVar (buffend pktoOutPQ)
+    let i = be `mod` (qsize pktoOutPQ)
+    let arrayEmpty :: MArray a e m => a Word32 e -> m Bool
+        arrayEmpty ar = do (lowB,highB) <- getBounds ar
+                           let result= lowB > highB
+                           return $ trace ("arrayEmpty result=" ++ show result
+                                        ++ " lowB="    ++ show lowB
+                                        ++ " highB = " ++ show highB
+                                        ++ " i = " ++ show i) result
+    mbPkt <- do emp <- arrayEmpty (pktq pktoOutPQ)
+                if emp then trace "(peekPacket empty)"    $ return Nothing
+                       else trace "(peekPacket nonempty)" $ do
+                                result <- readArray (pktq pktoOutPQ) i
+                                return $ trace ("readArray (isJust result)=="  ++ show (isJust result)) result
+    pktno <- readTVar pktoPacketNo
+    nextno <- readTVar (seqno pktoInPQ)
+    pktoToWire getExtra nextno be pktno msg
+
 -- | Convert a message to packet format and append it to the front of a queue
 --   used for outgoing messages. (Note that ‘front‛ usually means the higher
 --   index in this implementation.)
@@ -210,6 +232,7 @@ tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPac
     pktno <- readTVar pktoPacketNo
     nextno <- readTVar (seqno pktoInPQ)
     mbWire <- pktoToWire getExtra nextno be pktno msg
+    -- TODO all the above lines ^^ can be replaced with call to peekPacket
     case trace "(tryAppendQueueOutgoing mbWire)" mbWire of
         Just (pkt,pktno')
             -> trace "(tryAppendQueueOutgoing A)"
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