From 54af27be179f998b17ecff9b5499214df09fb0b2 Mon Sep 17 00:00:00 2001 From: "jim@bo" Date: Fri, 22 Jun 2018 15:46:43 -0400 Subject: OutGoingResult now offers packet for convenience Also, don't send anohter Online, just send duplicate packet. --- examples/dhtd.hs | 2 +- src/Data/PacketQueue.hs | 17 ++++++++++---- src/Network/Tox/Crypto/Handlers.hs | 48 +++++++++++++++++++++----------------- 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 -- cgit v1.2.3