dput: suppressible debug prints

5 files changed, 26 insertions, 9 deletions

diff --git a/dht-client.cabal b/dht-client.cabal
index fa49aff1..77ea1736 100644
--- a/dht-client.cabal
+++ b/dht-client.cabal
@@ -67,7 +67,8 @@ library
                      , RecordWildCards
                      , NondecreasingIndentation
   hs-source-dirs:      src, ., Presence
-  exposed-modules:  Network.SocketLike
+  exposed-modules:  DPut
+                    Network.SocketLike
                     Data.Digest.CRC32C
                     Data.Bits.ByteString
                     Data.Wrapper.PSQ
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index b6680f2e..ba7b0fca 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -113,6 +113,7 @@ import ToxToXMPP
 import qualified Connection.Tcp as Tcp (ConnectionEvent(..))
 import Control.Concurrent.Supply
 import qualified Data.CyclicBuffer as CB
+import DPut
 
 
 showReport :: [(String,String)] -> String
@@ -523,6 +524,8 @@ clientSession s@Session{..} sock cnum h = do
             , ["peers"]
             , ["toxids"]
             , ["c"]
+            , ["quiet"]
+            , ["verbose"]
             , ["help"]
             ]
     case (map toLower c,args) of
@@ -715,6 +718,16 @@ clientSession s@Session{..} sock cnum h = do
                 hPutClientChunk h $ unlines [ dns, "", "Friend Requests" ]
                 hPutClient h $ showReport frs
 
+        ("quiet",s) | s' <- strp s
+                    , Just (tag::DebugTag) <- readMaybe ('X':s')
+                    -> cmd0 $ do
+                setQuiet tag
+
+        ("verbose",s) | s' <- strp s
+                    , Just (tag::DebugTag) <- readMaybe ('X':s')
+                    -> cmd0 $ do
+                setVerbose tag
+
         -- list information about current netcrypto sesssions
         ("sessions", s) | "" <- strp s
             -> cmd0 $ do
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 5a52450b..95cb1bc8 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -45,6 +45,7 @@ import PingMachine
 import qualified Data.IntMap.Strict as IntMap
 import Control.Concurrent.Supply
 import Data.InOrOut
+import DPut
 
 -- util, todo: move to another module
 maybeToEither :: Maybe b -> Either String b
@@ -536,7 +537,7 @@ updateCryptoSession sessions addr hp session = do
 
 cryptoNetHandler :: NetCryptoSessions -> SockAddr -> NetCrypto -> IO (Maybe (NetCrypto -> NetCrypto))
 cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) nonce24 encrypted)) = do
-    hPutStrLn stderr ("RECIEVED HANDSHAKE from " ++ show addr)
+    dput XNetCrypto ("RECIEVED HANDSHAKE from " ++ show addr)
     -- Handle Handshake Message
     let crypto = transportCrypto sessions
         allsessions = netCryptoSessions sessions
@@ -545,7 +546,7 @@ cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) non
     seckeys <- map fst <$> atomically (readTVar (userKeys crypto))
     symkey <- atomically $ transportSymmetric crypto
     now <- getPOSIXTime
-    hPutStrLn stderr ("Decrypt cookie with n24=" ++ show n24 ++ "\n    symkey= " ++ show symkey)
+    dput XNetCrypto ("Decrypt cookie with n24=" ++ show n24 ++ "\n    symkey= " ++ show symkey)
     lr <- fmap join . sequence $ do -- Either Monad
             -- TODO: XXX: FIXME:
             --            The following call to decryptSymmetric is failing every time,
@@ -579,7 +580,7 @@ cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) non
                 , hpCookieRemoteDhtkey    = remoteDhtkey
                 }
     case lr of
-        Left s -> hPutStrLn stderr ("cryptoNetHandler: " ++ s)
+        Left s -> dput XNetCrypto ("cryptoNetHandler: " ++ s)
         Right hp@(HParam
                       { hpTheirBaseNonce        = Just theirBaseNonce
                       , hpOtherCookie           = otherCookie
diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs
index 8c3a9a86..94ece8ab 100644
--- a/src/Network/Tox/Onion/Handlers.hs
+++ b/src/Network/Tox/Onion/Handlers.hs
@@ -43,6 +43,7 @@ import Data.Maybe
 import Data.Bits
 import Data.Ord
 import Data.Functor.Identity
+import DPut
 
 type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message
 type Message = OnionMessage Identity
@@ -77,7 +78,7 @@ announceH routing toks keydb oaddr req = do
         _ -> let Nonce32 bs = announcePingId req
                  tok        = fromPaddedByteString 32 bs
              in checkToken toks (onionNodeInfo oaddr) tok >>= go
-        `catch` (\(SomeException e) -> hPutStrLn stderr ("announceH Exception! "++show e) >> throw e)
+        `catch` (\(SomeException e) -> dput XAnnounce ("announceH Exception! "++show e) >> throw e)
  where
     go withTok = do
         let naddr = onionNodeInfo oaddr
@@ -87,7 +88,7 @@ announceH routing toks keydb oaddr req = do
         let storing = case oaddr of
                         OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth
                         _                  -> Nothing
-        hPutStrLn stderr $ unlines [ "announceH: nodeId          = " ++ show (nodeId naddr)
+        dput XAnnounce   $ unlines [ "announceH: nodeId          = " ++ show (nodeId naddr)
                                    , "           announceSeeking = " ++ show (announceSeeking req)
                                    , "           withTok         = " ++ show withTok
                                    , "           storing         = " ++ maybe "False" (const "True") storing
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
index 23fd369b..550a7730 100644
--- a/src/Network/Tox/Onion/Transport.hs
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -79,6 +79,7 @@ import Network.Socket
 import System.IO
 import qualified Text.ParserCombinators.ReadP as RP
 import Data.Hashable
+import DPut
 
 type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
 
@@ -481,17 +482,17 @@ handleOnionRequest :: forall a proxy n.
                       ) => proxy n -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionRequest n -> IO a
 handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do
     let n = peanoVal rpath
-    hPutStrLn stderr $ "handleOnionRequest " ++ show n
+    dput XOnion $ "handleOnionRequest " ++ show n
     (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
                                       <*> transportNewNonce crypto )
     peeled <- peelOnion crypto nonce msg
     case peeled of
         Left e -> do
             -- todo report encryption error
-            hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), e]
+            dput XOnion $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), e]
             kont
         Right (Addressed dst msg') -> do
-            hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), "-->", either show show (either4or6 dst), "SUCCESS"]
+            dput XOnion $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), "-->", either show show (either4or6 dst), "SUCCESS"]
             sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath)
             kont