Preparation to move DPut to a separate project.

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"]