OutGoingResult now offers packet for convenience

Also, don't send anohter Online, just send duplicate packet.

3 files changed, 39 insertions, 28 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 628a58bd..4a246660 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1426,7 +1426,7 @@ newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar, ncPacketQueue
                         rTry <- tryAppendQueueOutgoing extra outq msg
                         case rTry of
                             OGFull -> retry
-                            OGSuccess -> return OGSuccess
+                            OGSuccess x -> return (OGSuccess x)
                             OGEncodeFail -> return OGEncodeFail
             when (r == OGEncodeFail) $
                 dput XMisc ("FAILURE to Encode Outgoing: " ++ show msg)
diff --git a/src/Data/PacketQueue.hs b/src/Data/PacketQueue.hs
index 59b41d91..82b6f8f0 100644
--- a/src/Data/PacketQueue.hs
+++ b/src/Data/PacketQueue.hs
@@ -208,8 +208,15 @@ newOutGoing inq towire toWireIO num capacity seqstart = do
                 , pktoToWire = towire
                 }
 
-data OutGoingResult = OGSuccess | OGFull | OGEncodeFail
-    deriving (Eq,Show)
+data OutGoingResult a = OGSuccess a | OGFull | OGEncodeFail
+    deriving (Show)
+
+instance Eq (OutGoingResult a) where
+    OGSuccess _ == OGSuccess _   = True
+    OGFull == OGFull             = True
+    OGEncodeFail == OGEncodeFail = True
+    _ == _ = False
+
 
 -- | do something in IO before appending to the queue
 readyOutGoing :: PacketOutQueue extra msg wire fromwire -> IO (STM extra)
@@ -265,7 +272,7 @@ peekPacket getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoT
 -- | 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.)
-tryAppendQueueOutgoing :: STM extra -> PacketOutQueue extra msg wire fromwire -> msg -> STM OutGoingResult
+tryAppendQueueOutgoing :: STM extra -> PacketOutQueue extra msg wire fromwire -> msg -> STM (OutGoingResult wire)
 tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoToWireIO, pktoToWire }) msg
   = do
     be <- readTVar (buffend pktoOutPQ)
@@ -288,7 +295,7 @@ tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPac
                         modifyTVar' (buffend pktoOutPQ) (+1)
                         writeTVar pktoPacketNo $! pktno'
                         writeArray (pktq pktoOutPQ) i (Just (pktno,pkt))
-                        return OGSuccess
+                        return (OGSuccess pkt)
                     -- queue is full
                     Just (n,_) -> do
                         nn <- getHighestHandledPacketPlus1 q
@@ -298,7 +305,7 @@ tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPac
                             modifyTVar' (buffend pktoOutPQ) (+1)
                             writeTVar pktoPacketNo $! pktno'
                             writeArray (pktq pktoOutPQ) i (Just (pktno,pkt))
-                            return OGSuccess
+                            return (OGSuccess pkt)
                           --  uh oh this packet is still needed...
                           else return OGFull
         -- don't know how to send this message
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 7a7567cf..73e5f686 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -796,7 +796,7 @@ runUponHandshake netCryptoSession0 addr pktoq = do
                 seqno <- PQ.getLastDequeuedPlus1 pktq
                 ogresult <- PQ.tryAppendQueueOutgoing getOutGoingParam pktoq (createRequestPacket seqno nums)
                 case ogresult of
-                    PQ.OGSuccess -> return ()
+                    PQ.OGSuccess _ -> return ()
                     _ -> retry
             loop
     dput XNetCrypto $ "runUponHandshake: " ++ show threadid ++ " = NetCryptoRequest." ++ show (key2id remotePublicKey) ++ sidStr
@@ -851,13 +851,6 @@ runUponHandshake netCryptoSession0 addr pktoq = do
     dput XNetCrypto $ "runUponHandshake: Announcing new session"
     hooks <- atomically $ readTVar (announceNewSessionHooks sessions)
     sendOnline crypto netCryptoSession
-    -- in case ONLINE packet is dropped, send anohter after delay
-    forkIO $ do
-        tid <- myThreadId
-        labelThread tid ("Second Online." ++ show (key2id remotePublicKey) ++ sidStr)
-        threadDelay 1000
-        _ <- sendOnline crypto netCryptoSession
-        return ()
     -- Run new session hooks
     flip fix (hooks,netCryptoSession) $ \loop (hooks,session) ->
         case hooks of
@@ -1228,7 +1221,7 @@ allMsgTypes fDefault = A.listArray (minBound,maxBound) (0:knownMsgs)
              , map (const 0)                 [ 200 .. 255 ] -- All lossy, exept the last
              ]
 
-sendCrypto :: TransportCrypto -> NetCryptoSession -> (STM ()) -> CryptoMessage -> IO (Either String ())
+sendCrypto :: TransportCrypto -> NetCryptoSession -> (STM ()) -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
 sendCrypto crypto session updateLocal cm = do
     HaveHandshake outq <- atomically $ readTVar (ncOutgoingQueue session)
     -- XXX: potential race? if shared secret comes out of sync with cache?
@@ -1238,30 +1231,40 @@ sendCrypto crypto session updateLocal cm = do
     atomically $ do
         result <- PQ.tryAppendQueueOutgoing getOutGoingParam outq cm
         case result of
-            PQ.OGSuccess    -> updateLocal >> return (Right())
+            PQ.OGSuccess x  -> updateLocal >> return (Right x)
             PQ.OGFull       -> return (Left "Outgoing packet buffer is full")
             PQ.OGEncodeFail -> return (Left "Failed to encode outgoing packet")
 
-sendPing :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
+sendPing :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
 sendPing crypto session = do
     let cm=OneByte PING
     addMsgToLastN False (cm ^. messageType) session (Out cm)
     sendCrypto crypto session (return ()) (OneByte PING)
 
-sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
+sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
 sendOnline crypto session = do
     let cm=OneByte ONLINE
     addMsgToLastN False (cm ^. messageType) session (Out cm)
-    sendCrypto crypto session (return ()) (OneByte ONLINE)
-
-sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
+    result <- sendCrypto crypto session (return ()) (OneByte ONLINE)
+    -- double this packet
+    case result of
+        Right pkt -> do
+            void . forkIO $ do
+                tid <- myThreadId
+                labelThread tid "TEMPORARY.PACKET.DOUBLE.ONLINE"
+                threadDelay 100000 -- delay 10th of a second
+                case ncSockAddr session of
+                    HaveDHTKey saddr -> sendSessionPacket (ncAllSessions session) saddr pkt
+            return (Right pkt)
+
+sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
 sendOffline crypto session = do
     let cm=OneByte OFFLINE
     addMsgToLastN False (cm ^. messageType) session (Out cm)
     sendCrypto crypto session (return ()) (OneByte OFFLINE)
 
 
-sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
+sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
 sendKill crypto session = do
     let cm=OneByte KillPacket
     mbOutQ <- atomically $ readTVar (ncOutgoingQueue session)
@@ -1294,9 +1297,10 @@ sendKill crypto session = do
                       HaveDHTKey saddr -> do
                         sendSessionPacket (ncAllSessions session) saddr pkt
                         dput XNetCrypto $ "sent kill packet (sessionid: " ++ show (ncSessionId session) ++ ")... now destroying session..."
-                        Right <$> destroySession session
+                        destroySession session
+                        return (Right pkt)
 
-setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ())
+setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
 setNick crypto session nick = do
     let Just (_,maxlen) = msgSizeParam NICKNAME
     if B.length nick > maxlen
@@ -1310,7 +1314,7 @@ setNick crypto session nick = do
         addMsgToLastN False (cm ^. messageType) session (Out cm)
         sendCrypto crypto session updateLocal cm
 
-setTyping :: TransportCrypto -> NetCryptoSession -> TypingStatus -> IO (Either String ())
+setTyping :: TransportCrypto -> NetCryptoSession -> TypingStatus -> IO (Either String (CryptoPacket Encrypted))
 setTyping crypto session status = do
    let updateLocal = do
         view <- readTVar (ncView session)
@@ -1327,7 +1331,7 @@ setNoSpam crypto session mbnospam = do
     writeTVar (svNoSpam view) mbnospam
    return (Right ())
 
-setStatus :: TransportCrypto -> NetCryptoSession -> UserStatus -> IO (Either String ())
+setStatus :: TransportCrypto -> NetCryptoSession -> UserStatus -> IO (Either String (CryptoPacket Encrypted))
 setStatus crypto session status = do
    let updateLocal = do
         view <- readTVar (ncView session)
@@ -1336,7 +1340,7 @@ setStatus crypto session status = do
    addMsgToLastN False (cm ^. messageType) session (Out cm)
    sendCrypto crypto session updateLocal cm
 
-setStatusMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ())
+setStatusMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
 setStatusMsg crypto session msg = do
     let Just (_,maxlen) = msgSizeParam STATUSMESSAGE
     if B.length msg > maxlen
@@ -1349,7 +1353,7 @@ setStatusMsg crypto session msg = do
         addMsgToLastN False (cm ^. messageType) session (Out cm)
         sendCrypto crypto session updateLocal cm
 
-sendChatMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ())
+sendChatMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
 sendChatMsg crypto session msg = do
     let Just (_,maxlen) = msgSizeParam MESSAGE
     if B.length msg > maxlen