diff options
-rw-r--r-- | dht/dht-client.cabal | 8 | ||||
-rw-r--r-- | dht/src/DPut.hs | 75 |
2 files changed, 3 insertions, 80 deletions
diff --git a/dht/dht-client.cabal b/dht/dht-client.cabal index 7efc2392..1cc93e3d 100644 --- a/dht/dht-client.cabal +++ b/dht/dht-client.cabal | |||
@@ -70,9 +70,7 @@ library | |||
70 | , RecordWildCards | 70 | , RecordWildCards |
71 | , NondecreasingIndentation | 71 | , NondecreasingIndentation |
72 | hs-source-dirs: src, ., Presence | 72 | hs-source-dirs: src, ., Presence |
73 | exposed-modules: DPut | 73 | exposed-modules: Network.SocketLike |
74 | DebugTag | ||
75 | Network.SocketLike | ||
76 | Data.Digest.CRC32C | 74 | Data.Digest.CRC32C |
77 | Data.Bits.ByteString | 75 | Data.Bits.ByteString |
78 | Data.TableMethods | 76 | Data.TableMethods |
@@ -212,7 +210,7 @@ library | |||
212 | , exceptions | 210 | , exceptions |
213 | , hinotify | 211 | , hinotify |
214 | , avahi >= 0.2.0 | 212 | , avahi >= 0.2.0 |
215 | , hslogger | 213 | , dput-hslogger |
216 | , word64-map | 214 | , word64-map |
217 | , network-addr | 215 | , network-addr |
218 | , tox-crypto | 216 | , tox-crypto |
@@ -238,7 +236,7 @@ library | |||
238 | Build-depends: network >= 2.4 && < 2.6 | 236 | Build-depends: network >= 2.4 && < 2.6 |
239 | 237 | ||
240 | 238 | ||
241 | other-modules: Paths_dht_client | 239 | other-modules: Paths_dht_client, DebugTag |
242 | 240 | ||
243 | C-sources: Presence/monitortty.c | 241 | C-sources: Presence/monitortty.c |
244 | 242 | ||
diff --git a/dht/src/DPut.hs b/dht/src/DPut.hs deleted file mode 100644 index 38e532d0..00000000 --- a/dht/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 | |||