From 217823867e3874cb4d3d8d619bc192aaf6c78028 Mon Sep 17 00:00:00 2001 From: "jim@bo" Date: Thu, 21 Jun 2018 17:02:47 -0400 Subject: DPut Trace Variations tput - like dput, but works in any Applicative dtrace - like trace, but takes DebugTag --- src/DPut.hs | 8 ++++++++ src/Data/PacketQueue.hs | 38 ++++++++++++++++++++++---------------- src/Network/Tox/Crypto/Handlers.hs | 6 +++--- 3 files changed, 33 insertions(+), 19 deletions(-) (limited to 'src') diff --git a/src/DPut.hs b/src/DPut.hs index 52714086..1b87eb93 100644 --- a/src/DPut.hs +++ b/src/DPut.hs @@ -27,6 +27,14 @@ dput tag msg = liftIO $ debugM (appName <.> show tag) msg dputB :: MonadIO m => DebugTag -> B.ByteString -> m () dputB tag msg = liftIO $ debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 $ msg) +-- | Trace version of 'dput' works in arbitrary monad, using unsafePerformIO. +tput :: Applicative m => DebugTag -> String -> m () +tput tag msg = (unsafePerformIO $ dput tag msg) `seq` pure () + +-- | like 'trace' but parameterized with 'DebugTag' +dtrace :: DebugTag -> String -> a -> a +dtrace tag msg result = (unsafePerformIO $ dput tag msg) `seq` result + setTagLevel :: Priority -> DebugTag -> IO () setTagLevel level tag = updateGlobalLogger (appName <.> show tag) (setLevel level) diff --git a/src/Data/PacketQueue.hs b/src/Data/PacketQueue.hs index e0221f5a..8182706e 100644 --- a/src/Data/PacketQueue.hs +++ b/src/Data/PacketQueue.hs @@ -35,7 +35,7 @@ import Control.Applicative import Data.Word import Data.Array.MArray import Data.Maybe -import Debug.Trace +import DPut data PacketQueue a = PacketQueue { pktq :: TArray Word32 (Maybe a) @@ -234,15 +234,18 @@ peekPacket getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoT 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 + tput XNetCrypto + ("arrayEmpty result=" ++ show result ++ " lowB=" ++ show lowB ++ " highB = " ++ show highB - ++ " i = " ++ show i) result + ++ " i = " ++ show i) + return result mbPkt <- do emp <- arrayEmpty (pktq pktoOutPQ) - if emp then trace "(peekPacket empty)" $ return Nothing - else trace "(peekPacket nonempty)" $ do + if emp then tput XNetCrypto "(peekPacket empty)" >> return Nothing + else do tput XNetCrypto "(peekPacket nonempty)" result <- readArray (pktq pktoOutPQ) i - return $ trace ("readArray (isJust result)==" ++ show (isJust result)) result + tput XNetCrypto ("readArray (isJust result)==" ++ show (isJust result)) + return result pktno <- readTVar pktoPacketNo nextno <- readTVar (seqno pktoInPQ) pktoToWire getExtra nextno be pktno msg @@ -252,37 +255,40 @@ peekPacket getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoT -- index in this implementation.) tryAppendQueueOutgoing :: STM extra -> PacketOutQueue extra msg wire fromwire -> msg -> STM OutGoingResult tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoToWireIO, pktoToWire }) msg - = trace "(tryAppendQueueOutgoing)" $ do + = dtrace XNetCrypto "(tryAppendQueueOutgoing)" $ 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 + tput XNetCrypto + ("arrayEmpty result=" ++ show result ++ " lowB=" ++ show lowB ++ " highB = " ++ show highB - ++ " i = " ++ show i) result + ++ " i = " ++ show i) + return result mbPkt <- do emp <- arrayEmpty (pktq pktoOutPQ) - if emp then trace "(tryAppendQueueOutgoing empty)" $ return Nothing - else trace "(tryAppendQueueOutgoing nonempty)" $ do + if emp then tput XNetCrypto "(tryAppendQueueOutgoing empty)" >> return Nothing + else do tput XNetCrypto "(tryAppendQueueOutgoing nonempty)" result <- readArray (pktq pktoOutPQ) i - return $ trace ("readArray (isJust result)==" ++ show (isJust result)) result + tput XNetCrypto ("readArray (isJust result)==" ++ show (isJust result)) + return result 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 + case dtrace XNetCrypto "(tryAppendQueueOutgoing mbWire)" mbWire of Just (pkt,pktno') - -> trace "(tryAppendQueueOutgoing A)" + -> dtrace XNetCrypto "(tryAppendQueueOutgoing A)" $ case mbPkt of -- slot is free, insert element - Nothing -> trace "(tryAppendQueueOutgoing Nothing case)" $ do + Nothing -> dtrace XNetCrypto "(tryAppendQueueOutgoing Nothing case)" $ do modifyTVar' (buffend pktoOutPQ) (+1) writeTVar pktoPacketNo $! pktno' writeArray (pktq pktoOutPQ) i (Just (pktno,pkt)) return OGSuccess -- queue is full - Just (n,_) -> trace "tryAppendQueueOutgoing Just case)" $ do + Just (n,_) -> dtrace XNetCrypto "tryAppendQueueOutgoing Just case)" $ do nn <- getHighestHandledPacketPlus1 q if (n < nn) -- but we can overwrite an old packet diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index 457171a9..44b2f26f 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs @@ -681,7 +681,7 @@ createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce addSessionToMap :: NetCryptoSessions -> SockAddr -> NetCryptoSession -> STM () addSessionToMap sessions addrRaw netCryptoSession = do let addr = either id id $ either4or6 addrRaw - let dmsg msg = trace msg (return ()) + let dmsg msg = tput XNetCrypto msg dmsg $ "addSessionToMapIfNotThere sockaddr = " ++ show addr ++ ", sessionid = " ++ show (ncSessionId netCryptoSession) let remotePublicKey = ncTheirPublicKey netCryptoSession allsessions = netCryptoSessions sessions @@ -695,7 +695,7 @@ addSessionToMap sessions addrRaw netCryptoSession = do addSessionToMapIfNotThere :: NetCryptoSessions -> SockAddr -> NetCryptoSession -> STM () addSessionToMapIfNotThere sessions addrRaw netCryptoSession = do let addr = either id id $ either4or6 addrRaw - let dmsg msg = trace msg (return ()) + let dmsg msg = tput XNetCrypto msg dmsg $ "addSessionToMapIfNotThere sockaddr = " ++ show addr ++ ", sessionid = " ++ show (ncSessionId netCryptoSession) let remotePublicKey = ncTheirPublicKey netCryptoSession allsessions = netCryptoSessions sessions @@ -857,7 +857,7 @@ destroySession session = do updateCryptoSession :: NetCryptoSessions -> SockAddr -> SecretKey -> POSIXTime -> HandshakeParams -> NetCryptoSession -> Handshake Encrypted -> STM (Maybe (Handshake Encrypted), IO ()) updateCryptoSession sessions addr newsession timestamp hp session handshake = do - let dmsg msg = trace msg (return ()) + let dmsg msg = tput XNetCrypto msg ncState0 <- readTVar (ncState session) ncTheirBaseNonce0 <- readTVar (ncTheirBaseNonce session) if (ncState0 >= {-Accepted-}InProgress AwaitingSessionPacket) -- cgit v1.2.3