diff options
-rw-r--r-- | dht-client.cabal | 11 | ||||
-rw-r--r-- | src/DPut.hs | 75 |
2 files changed, 6 insertions, 80 deletions
diff --git a/dht-client.cabal b/dht-client.cabal index 38f4b8c6..91171084 100644 --- a/dht-client.cabal +++ b/dht-client.cabal | |||
@@ -69,8 +69,7 @@ library | |||
69 | , RecordWildCards | 69 | , RecordWildCards |
70 | , NondecreasingIndentation | 70 | , NondecreasingIndentation |
71 | hs-source-dirs: src, ., Presence | 71 | hs-source-dirs: src, ., Presence |
72 | exposed-modules: DPut | 72 | exposed-modules: DebugTag |
73 | DebugTag | ||
74 | Network.SocketLike | 73 | Network.SocketLike |
75 | Data.Digest.CRC32C | 74 | Data.Digest.CRC32C |
76 | Data.Bits.ByteString | 75 | Data.Bits.ByteString |
@@ -155,6 +154,7 @@ library | |||
155 | Network.Tox.Session | 154 | Network.Tox.Session |
156 | 155 | ||
157 | build-depends: base | 156 | build-depends: base |
157 | , dput-hslogger | ||
158 | , containers | 158 | , containers |
159 | , dependent-sum | 159 | , dependent-sum |
160 | , array | 160 | , array |
@@ -267,21 +267,21 @@ executable avahi | |||
267 | hs-source-dirs: examples | 267 | hs-source-dirs: examples |
268 | main-is: avahi.hs | 268 | main-is: avahi.hs |
269 | default-language: Haskell2010 | 269 | default-language: Haskell2010 |
270 | build-depends: base-prelude, dht-client, avahi, network | 270 | build-depends: base-prelude, dht-client, avahi, network, dput-hslogger |
271 | ghc-options: -fobject-code | 271 | ghc-options: -fobject-code |
272 | 272 | ||
273 | executable dht | 273 | executable dht |
274 | hs-source-dirs: examples | 274 | hs-source-dirs: examples |
275 | main-is: dht.hs | 275 | main-is: dht.hs |
276 | default-language: Haskell2010 | 276 | default-language: Haskell2010 |
277 | build-depends: base, haskeline, network, bytestring, transformers | 277 | build-depends: base, haskeline, network, bytestring, transformers, dput-hslogger |
278 | ghc-options: -fobject-code | 278 | ghc-options: -fobject-code |
279 | 279 | ||
280 | executable dhtd | 280 | executable dhtd |
281 | hs-source-dirs: examples | 281 | hs-source-dirs: examples |
282 | main-is: dhtd.hs | 282 | main-is: dhtd.hs |
283 | default-language: Haskell2010 | 283 | default-language: Haskell2010 |
284 | build-depends: base, network, bytestring, hashable, deepseq | 284 | build-depends: base, network, bytestring, hashable, deepseq, dput-hslogger |
285 | , aeson | 285 | , aeson |
286 | , array | 286 | , array |
287 | , pretty | 287 | , pretty |
@@ -324,6 +324,7 @@ executable testTox | |||
324 | main-is: testTox.hs | 324 | main-is: testTox.hs |
325 | default-language: Haskell2010 | 325 | default-language: Haskell2010 |
326 | build-depends: base | 326 | build-depends: base |
327 | , dput-hslogger | ||
327 | , dht-client | 328 | , dht-client |
328 | , stm | 329 | , stm |
329 | , stm-chans | 330 | , stm-chans |
diff --git a/src/DPut.hs b/src/DPut.hs deleted file mode 100644 index 38e532d0..00000000 --- a/src/DPut.hs +++ /dev/null | |||
@@ -1,75 +0,0 @@ | |||
1 | {-# LANGUAGE ConstraintKinds #-} | ||
2 | {-# LANGUAGE ScopedTypeVariables #-} | ||
3 | module DPut where | ||
4 | |||
5 | import Control.Monad.IO.Class | ||
6 | import qualified Data.Map.Strict as Map | ||
7 | import Data.Maybe | ||
8 | import Data.IORef | ||
9 | import System.IO.Unsafe (unsafePerformIO) | ||
10 | import System.Log.Logger | ||
11 | import qualified Data.ByteString.Char8 as B | ||
12 | import qualified Data.Text as T | ||
13 | import qualified Data.Text.Encoding as T | ||
14 | import Debug.Trace | ||
15 | import Data.Typeable | ||
16 | import Data.Dynamic | ||
17 | |||
18 | type IsDebugTag t = (Eq t, Ord t, Show t, Read t, Enum t, Bounded t,Typeable t) | ||
19 | |||
20 | appName :: String | ||
21 | appName = "toxmpp" | ||
22 | |||
23 | (<.>) :: String -> String -> String | ||
24 | a <.> b = a ++ "." ++ b | ||
25 | |||
26 | dput :: (MonadIO m, IsDebugTag tag) => tag -> String -> m () | ||
27 | dput tag msg = liftIO $ debugM (appName <.> show tag) msg | ||
28 | |||
29 | dputB :: (MonadIO m, IsDebugTag tag) => tag -> B.ByteString -> m () | ||
30 | dputB tag msg = liftIO $ debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 $ msg) | ||
31 | |||
32 | {-# NOINLINE verbosityMap #-} | ||
33 | verbosityMap :: IORef (Map.Map TypeRep Dynamic) | ||
34 | verbosityMap = unsafePerformIO $ newIORef (Map.empty) | ||
35 | |||
36 | -- | Trace version of 'dput' works in arbitrary monad, using unsafePerformIO. | ||
37 | tput :: (Applicative m, IsDebugTag tag) => tag -> String -> m () | ||
38 | tput tag msg = | ||
39 | let mp = unsafePerformIO $ readIORef verbosityMap | ||
40 | in if maybe True (fromMaybe True . Map.lookup tag . flip fromDyn Map.empty) (Map.lookup (typeOf tag) mp) | ||
41 | then trace msg (pure ()) | ||
42 | else pure () | ||
43 | |||
44 | -- | like 'trace' but parameterized with 'DebugTag' | ||
45 | dtrace :: forall a tag. IsDebugTag tag => tag -> String -> a -> a | ||
46 | dtrace tag msg result = let mp = unsafePerformIO $ readIORef verbosityMap | ||
47 | mp' :: Map.Map tag Bool | ||
48 | mp' = maybe Map.empty (flip fromDyn Map.empty) (Map.lookup (typeOf tag) mp) | ||
49 | in if fromMaybe True (Map.lookup tag mp') | ||
50 | then trace msg result | ||
51 | else result | ||
52 | |||
53 | setTagLevel :: forall tag. IsDebugTag tag => Priority -> tag -> IO () | ||
54 | setTagLevel level tag = do | ||
55 | updateGlobalLogger (appName <.> show tag) (setLevel level) | ||
56 | modifyIORef verbosityMap $ \mpByType -> do | ||
57 | case Map.lookup (typeOf tag) mpByType of | ||
58 | Nothing -> Map.insert (typeOf tag) (toDyn $ Map.fromList [(tag,(level <= DEBUG))]) mpByType | ||
59 | Just dyn -> let mpByTag :: Map.Map tag Bool | ||
60 | mpByTag = fromDyn dyn Map.empty | ||
61 | in Map.insert (typeOf tag) (toDyn $ Map.insert tag (level <= DEBUG) mpByTag) mpByType | ||
62 | |||
63 | setQuiet :: forall tag. IsDebugTag tag => tag -> IO () | ||
64 | setQuiet = setTagLevel WARNING | ||
65 | |||
66 | setVerbose :: forall tag. IsDebugTag tag => tag -> IO () | ||
67 | setVerbose = setTagLevel DEBUG | ||
68 | |||
69 | getVerbose :: forall tag. IsDebugTag tag => tag -> IO Bool | ||
70 | getVerbose tag = do | ||
71 | logger <- getLogger (appName <.> show tag) | ||
72 | case getLevel logger of | ||
73 | Just p | p <= DEBUG -> return True | ||
74 | _ -> return False | ||
75 | |||