From 5f5aa818f8484570349e75a061d7b37cc9fe826a Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sun, 4 Nov 2018 03:25:21 -0500 Subject: Preparation to move DPut to a separate project. --- Connection/Tcp.hs | 1 + HandshakeCache.hs | 1 + Presence/ConfigFiles.hs | 1 + Presence/ConsoleWriter.hs | 1 + Presence/DNSCache.hs | 1 + Presence/Presence.hs | 1 + Presence/XMPPServer.hs | 1 + ToxManager.hs | 1 + dht-client.cabal | 1 + examples/dhtd.hs | 4 ++- examples/testTox.hs | 3 +- src/Control/Concurrent/Lifted/Instrument.hs | 1 + src/DPut.hs | 55 +++++++++++++---------------- src/Data/PacketBuffer.hs | 1 + src/Network/Address.hs | 1 + src/Network/BitTorrent/MainlineDHT.hs | 1 + src/Network/Kademlia/Bootstrap.hs | 1 + src/Network/Lossless.hs | 1 + src/Network/QueryResponse.hs | 1 + src/Network/StreamServer.hs | 1 + src/Network/Tox.hs | 1 + src/Network/Tox/AggregateSession.hs | 1 + src/Network/Tox/ContactInfo.hs | 1 + src/Network/Tox/Crypto/Handlers.hs | 1 + src/Network/Tox/Crypto/Transport.hs | 1 + src/Network/Tox/DHT/Handlers.hs | 1 + src/Network/Tox/Handshake.hs | 1 + src/Network/Tox/Onion/Handlers.hs | 1 + src/Network/Tox/Onion/Transport.hs | 1 + src/Network/Tox/Session.hs | 1 + src/Network/UPNP.hs | 1 + 31 files changed, 57 insertions(+), 33 deletions(-) diff --git a/Connection/Tcp.hs b/Connection/Tcp.hs index 97b78eda..a59f35d1 100644 --- a/Connection/Tcp.hs +++ b/Connection/Tcp.hs @@ -82,6 +82,7 @@ import Network.SocketLike hiding (sClose) import qualified Connection as G ;import Connection (Manager (..), PeerAddress (..), Policy (..)) import DPut +import DebugTag type Microseconds = Int diff --git a/HandshakeCache.hs b/HandshakeCache.hs index c4dd090c..61735e8a 100644 --- a/HandshakeCache.hs +++ b/HandshakeCache.hs @@ -15,6 +15,7 @@ import Crypto.Tox import qualified Data.MinMaxPSQ as MM ;import Data.MinMaxPSQ (MinMaxPSQ') import DPut +import DebugTag import Network.Tox.Crypto.Transport (Handshake, HandshakeData (..)) import Network.Tox.DHT.Handlers (createCookieSTM) import Network.Tox.DHT.Transport (Cookie (..), CookieData (..), NodeInfo, diff --git a/Presence/ConfigFiles.hs b/Presence/ConfigFiles.hs index 27a65bbf..d0164e33 100644 --- a/Presence/ConfigFiles.hs +++ b/Presence/ConfigFiles.hs @@ -17,6 +17,7 @@ import Data.List (partition) import Data.Maybe (catMaybes,isJust) import DPut +import DebugTag type User = ByteString type Profile = String diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs index 7c377d83..c6e1871a 100644 --- a/Presence/ConsoleWriter.hs +++ b/Presence/ConsoleWriter.hs @@ -36,6 +36,7 @@ import qualified Data.Text as Text import qualified Network.BSD as BSD import DPut +import DebugTag import UTmp ( users2, utmp_file, UtmpRecord(..), UT_Type(..) ) import FGConsole ( forkTTYMonitor ) import XMPPServer ( Stanza, makePresenceStanza, JabberShow(..), stanzaType diff --git a/Presence/DNSCache.hs b/Presence/DNSCache.hs index c5154e34..e28655c5 100644 --- a/Presence/DNSCache.hs +++ b/Presence/DNSCache.hs @@ -53,6 +53,7 @@ import ControlMaybe ( handleIO_ ) import GetHostByAddr ( getHostByAddr ) import InterruptibleDelay import DPut +import DebugTag type TimeStamp = UTCTime diff --git a/Presence/Presence.hs b/Presence/Presence.hs index cc3f488b..0ae9653f 100644 --- a/Presence/Presence.hs +++ b/Presence/Presence.hs @@ -53,6 +53,7 @@ import qualified Connection import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgress,ToxContact(..)) import Crypto.Tox (decodeSecret) import DPut +import DebugTag {- isPeerKey :: ClientAddress -> Bool diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index 2345cb67..42425c5e 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs @@ -105,6 +105,7 @@ import Data.String ( IsString(..) ) import qualified System.Random import Data.Void (Void) import DPut +import DebugTag -- peerport :: PortNumber -- peerport = 5269 diff --git a/ToxManager.hs b/ToxManager.hs index 4ea6736d..40377b62 100644 --- a/ToxManager.hs +++ b/ToxManager.hs @@ -28,6 +28,7 @@ import qualified Data.Text as T import Data.Time.Clock.POSIX import Data.Word import DPut +import DebugTag import Foreign.Storable import HandshakeCache import Network.Address diff --git a/dht-client.cabal b/dht-client.cabal index da9e5366..38f4b8c6 100644 --- a/dht-client.cabal +++ b/dht-client.cabal @@ -70,6 +70,7 @@ library , NondecreasingIndentation hs-source-dirs: src, ., Presence exposed-modules: DPut + DebugTag Network.SocketLike Data.Digest.CRC32C Data.Bits.ByteString diff --git a/examples/dhtd.hs b/examples/dhtd.hs index 7c66fd73..27403971 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs @@ -113,6 +113,7 @@ import ToxToXMPP import XMPPToTox import qualified Connection.Tcp as Tcp (ConnectionEvent(..),noCleanUp,TCPStatus) import DPut +import DebugTag pshow :: Show a => a -> B.ByteString @@ -361,6 +362,7 @@ clientSession s@Session{..} sock cnum h = do case B.unsnoc x of Just (str,c) | isSpace c -> (str,False) _ -> (x,True) + allDebugTags :: [DebugTag] allDebugTags = [minBound .. maxBound] showDebugTags = do vs <- mapM getVerbose allDebugTags @@ -1535,7 +1537,7 @@ main = do announcer <- forkAnnouncer -- Default: quiet all tags (except XMisc). - forM [minBound .. maxBound] setQuiet + forM ([minBound .. maxBound]::[DebugTag]) setQuiet forM (verboseTags opts) setVerbose (quitBt,btdhts,btips,baddrs) <- case portbt opts of diff --git a/examples/testTox.hs b/examples/testTox.hs index cc8bd45f..e82ca2d3 100644 --- a/examples/testTox.hs +++ b/examples/testTox.hs @@ -17,6 +17,7 @@ import qualified Data.IntMap.Strict as IntMap import Data.Function import DebugUtil import DPut +import DebugTag import HandshakeCache import Network.QueryResponse import Network.Socket @@ -81,7 +82,7 @@ netCrypto tox me ni them = do main :: IO () main = do - mapM_ setVerbose [ minBound .. maxBound ] + mapM_ setVerbose ([ minBound .. maxBound ]::[DebugTag]) setQuiet XRoutes (udpA,udpB) <- testPairTransport diff --git a/src/Control/Concurrent/Lifted/Instrument.hs b/src/Control/Concurrent/Lifted/Instrument.hs index 680b264f..fc3b6369 100644 --- a/src/Control/Concurrent/Lifted/Instrument.hs +++ b/src/Control/Concurrent/Lifted/Instrument.hs @@ -21,6 +21,7 @@ import qualified GHC.Conc as GHC import Data.Time() import Data.Time.Clock import DPut +import DebugTag data PerThread = PerThread diff --git a/src/DPut.hs b/src/DPut.hs index 6fd69040..38e532d0 100644 --- a/src/DPut.hs +++ b/src/DPut.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} module DPut where import Control.Monad.IO.Class @@ -10,26 +12,10 @@ import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import qualified Data.Text.Encoding as T import Debug.Trace +import Data.Typeable +import Data.Dynamic --- | Debug Tags, add more as needed, but ensure XAnnounce is always first, XMisc last -data DebugTag - = XAnnounce - | XBitTorrent - | XDHT - | XLan - | XMan - | XNetCrypto - | XNetCryptoOut - | XOnion - | XRoutes - | XPing - | XRefresh - | XJabber - | XMisc - | XNodeinfoSearch - | XUnexpected -- Used only for special anomalous errors that we didn't expect to happen. - | XUnused -- Never commit code that uses XUnused. - deriving (Eq, Ord, Show, Read, Enum, Bounded) +type IsDebugTag t = (Eq t, Ord t, Show t, Read t, Enum t, Bounded t,Typeable t) appName :: String appName = "toxmpp" @@ -37,43 +23,50 @@ appName = "toxmpp" (<.>) :: String -> String -> String a <.> b = a ++ "." ++ b -dput :: MonadIO m => DebugTag -> String -> m () +dput :: (MonadIO m, IsDebugTag tag) => tag -> String -> m () dput tag msg = liftIO $ debugM (appName <.> show tag) msg -dputB :: MonadIO m => DebugTag -> B.ByteString -> m () +dputB :: (MonadIO m, IsDebugTag tag) => tag -> B.ByteString -> m () dputB tag msg = liftIO $ debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 $ msg) {-# NOINLINE verbosityMap #-} -verbosityMap :: IORef (Map.Map DebugTag Bool) +verbosityMap :: IORef (Map.Map TypeRep Dynamic) verbosityMap = unsafePerformIO $ newIORef (Map.empty) -- | Trace version of 'dput' works in arbitrary monad, using unsafePerformIO. -tput :: Applicative m => DebugTag -> String -> m () +tput :: (Applicative m, IsDebugTag tag) => tag -> String -> m () tput tag msg = let mp = unsafePerformIO $ readIORef verbosityMap - in if fromMaybe True (Map.lookup tag mp) + in if maybe True (fromMaybe True . Map.lookup tag . flip fromDyn Map.empty) (Map.lookup (typeOf tag) mp) then trace msg (pure ()) else pure () -- | like 'trace' but parameterized with 'DebugTag' -dtrace :: DebugTag -> String -> a -> a +dtrace :: forall a tag. IsDebugTag tag => tag -> String -> a -> a dtrace tag msg result = let mp = unsafePerformIO $ readIORef verbosityMap - in if fromMaybe True (Map.lookup tag mp) + mp' :: Map.Map tag Bool + mp' = maybe Map.empty (flip fromDyn Map.empty) (Map.lookup (typeOf tag) mp) + in if fromMaybe True (Map.lookup tag mp') then trace msg result else result -setTagLevel :: Priority -> DebugTag -> IO () +setTagLevel :: forall tag. IsDebugTag tag => Priority -> tag -> IO () setTagLevel level tag = do updateGlobalLogger (appName <.> show tag) (setLevel level) - modifyIORef verbosityMap (Map.insert tag (level <= DEBUG)) + modifyIORef verbosityMap $ \mpByType -> do + case Map.lookup (typeOf tag) mpByType of + Nothing -> Map.insert (typeOf tag) (toDyn $ Map.fromList [(tag,(level <= DEBUG))]) mpByType + Just dyn -> let mpByTag :: Map.Map tag Bool + mpByTag = fromDyn dyn Map.empty + in Map.insert (typeOf tag) (toDyn $ Map.insert tag (level <= DEBUG) mpByTag) mpByType -setQuiet :: DebugTag -> IO () +setQuiet :: forall tag. IsDebugTag tag => tag -> IO () setQuiet = setTagLevel WARNING -setVerbose :: DebugTag -> IO () +setVerbose :: forall tag. IsDebugTag tag => tag -> IO () setVerbose = setTagLevel DEBUG -getVerbose :: DebugTag -> IO Bool +getVerbose :: forall tag. IsDebugTag tag => tag -> IO Bool getVerbose tag = do logger <- getLogger (appName <.> show tag) case getLevel logger of diff --git a/src/Data/PacketBuffer.hs b/src/Data/PacketBuffer.hs index 343cb04e..17745664 100644 --- a/src/Data/PacketBuffer.hs +++ b/src/Data/PacketBuffer.hs @@ -19,6 +19,7 @@ module Data.PacketBuffer import Data.PacketQueue as Q import DPut +import DebugTag import Control.Concurrent.STM import Control.Monad diff --git a/src/Network/Address.hs b/src/Network/Address.hs index 3adfdc91..246463c0 100644 --- a/src/Network/Address.hs +++ b/src/Network/Address.hs @@ -130,6 +130,7 @@ import System.Locale (defaultTimeLocale) #endif import System.Entropy import DPut +import DebugTag -- import Paths_bittorrent (version) diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs index c5b99234..573efcba 100644 --- a/src/Network/BitTorrent/MainlineDHT.hs +++ b/src/Network/BitTorrent/MainlineDHT.hs @@ -83,6 +83,7 @@ import Text.Read import System.Global6 import Control.TriadCommittee import DPut +import DebugTag newtype NodeId = NodeId ByteString deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable) diff --git a/src/Network/Kademlia/Bootstrap.hs b/src/Network/Kademlia/Bootstrap.hs index 1a70a9c5..aad8a81e 100644 --- a/src/Network/Kademlia/Bootstrap.hs +++ b/src/Network/Kademlia/Bootstrap.hs @@ -32,6 +32,7 @@ import Data.Ord import System.Entropy import System.Timeout import DPut +import DebugTag import qualified Data.Wrapper.PSQInt as Int ;import Data.Wrapper.PSQInt (pattern (:->)) diff --git a/src/Network/Lossless.hs b/src/Network/Lossless.hs index 4d5521fd..861792ab 100644 --- a/src/Network/Lossless.hs +++ b/src/Network/Lossless.hs @@ -18,6 +18,7 @@ import System.IO.Error import Data.PacketBuffer as PB import DPut +import DebugTag import Network.QueryResponse #ifdef THREAD_DEBUG diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs index fdfbdbae..4e110ec3 100644 --- a/src/Network/QueryResponse.hs +++ b/src/Network/QueryResponse.hs @@ -38,6 +38,7 @@ import System.IO import System.IO.Error import System.Timeout import DPut +import DebugTag -- | Three methods are required to implement a datagram based query\/response protocol. data TransportA err addr x y = Transport diff --git a/src/Network/StreamServer.hs b/src/Network/StreamServer.hs index 2734f0cd..afa35675 100644 --- a/src/Network/StreamServer.hs +++ b/src/Network/StreamServer.hs @@ -44,6 +44,7 @@ import Control.Concurrent.MVar (newMVar) import Network.SocketLike import DPut +import DebugTag data ServerHandle = ServerHandle Socket (Weak ThreadId) diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs index 88228c50..ddb22d50 100644 --- a/src/Network/Tox.hs +++ b/src/Network/Tox.hs @@ -61,6 +61,7 @@ import OnionRouter import Network.Tox.ContactInfo import Text.XXD import DPut +import DebugTag import Network.Tox.Avahi import Network.Tox.Session import Network.SessionTransports diff --git a/src/Network/Tox/AggregateSession.hs b/src/Network/Tox/AggregateSession.hs index 2323673a..b248c96f 100644 --- a/src/Network/Tox/AggregateSession.hs +++ b/src/Network/Tox/AggregateSession.hs @@ -41,6 +41,7 @@ import Connection (Status (..)) import Crypto.Tox (PublicKey, toPublic) import Data.Wrapper.PSQInt as PSQ import DPut +import DebugTag import Network.QueryResponse import Network.Tox.Crypto.Transport (CryptoMessage (..), pattern KillPacket, pattern ONLINE, pattern PING, diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs index 387a6e47..e7cb48c1 100644 --- a/src/Network/Tox/ContactInfo.hs +++ b/src/Network/Tox/ContactInfo.hs @@ -15,6 +15,7 @@ import Network.Tox.DHT.Transport as DHT import Network.Tox.NodeId (id2key) import Network.Tox.Onion.Transport as Onion import DPut +import DebugTag newtype ContactInfo extra = ContactInfo -- | Map our toxid public key to an Account record. diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index bf01e1b5..94dde8e3 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs @@ -51,6 +51,7 @@ import qualified Data.IntMap.Strict as IntMap import Control.Concurrent.Supply import Data.InOrOut import DPut +import DebugTag import Text.Printf import Data.Bool import Network.Tox.Handshake diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs index 84929e63..555164f2 100644 --- a/src/Network/Tox/Crypto/Transport.hs +++ b/src/Network/Tox/Crypto/Transport.hs @@ -87,6 +87,7 @@ import Data.Text.Encoding as T import Data.Serialize as S import Control.Arrow import DPut +import DebugTag import Data.PacketBuffer as PB showCryptoMsg :: Word32 -> CryptoMessage -> [Char] diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs index b1db9044..d7f05dbc 100644 --- a/src/Network/Tox/DHT/Handlers.hs +++ b/src/Network/Tox/DHT/Handlers.hs @@ -40,6 +40,7 @@ import Data.Maybe import Data.Serialize (Serialize) import Data.Word import DPut +import DebugTag data TransactionId = TransactionId { transactionKey :: Nonce8 -- ^ Used to lookup pending query. diff --git a/src/Network/Tox/Handshake.hs b/src/Network/Tox/Handshake.hs index 0ca99fe2..6df9edab 100644 --- a/src/Network/Tox/Handshake.hs +++ b/src/Network/Tox/Handshake.hs @@ -23,6 +23,7 @@ import Control.Concurrent import GHC.Conc (labelThread) #endif import DPut +import DebugTag anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1) diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs index 80a6ae3a..0d8a9151 100644 --- a/src/Network/Tox/Onion/Handlers.hs +++ b/src/Network/Tox/Onion/Handlers.hs @@ -38,6 +38,7 @@ import Data.IP import Data.Maybe import Data.Functor.Identity import DPut +import DebugTag type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message type Message = OnionMessage Identity diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs index 7ed9702a..10bd5a44 100644 --- a/src/Network/Tox/Onion/Transport.hs +++ b/src/Network/Tox/Onion/Transport.hs @@ -82,6 +82,7 @@ import Network.Socket import qualified Text.ParserCombinators.ReadP as RP import Data.Hashable import DPut +import DebugTag type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a diff --git a/src/Network/Tox/Session.hs b/src/Network/Tox/Session.hs index 968b3503..18e17fb6 100644 --- a/src/Network/Tox/Session.hs +++ b/src/Network/Tox/Session.hs @@ -20,6 +20,7 @@ import Crypto.Tox import Data.PacketBuffer (PacketInboundEvent (..)) import Data.Tox.Message import DPut +import DebugTag import Network.Lossless import Network.QueryResponse import Network.SessionTransports diff --git a/src/Network/UPNP.hs b/src/Network/UPNP.hs index e89471c2..01d222bf 100644 --- a/src/Network/UPNP.hs +++ b/src/Network/UPNP.hs @@ -6,6 +6,7 @@ import Network.Socket import System.Directory import System.Process as Process import DPut +import DebugTag protocols :: SocketType -> [String] protocols Stream = ["tcp"] -- cgit v1.2.3