diff options
Diffstat (limited to 'examples')
-rw-r--r-- | examples/dhtd.hs | 36 |
1 files changed, 24 insertions, 12 deletions
diff --git a/examples/dhtd.hs b/examples/dhtd.hs index 4b5a1fd7..e95fa366 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs | |||
@@ -351,6 +351,9 @@ clientSession0 s sock cnum h = do | |||
351 | else throwIO e | 351 | else throwIO e |
352 | 352 | ||
353 | 353 | ||
354 | parseDebugTag :: String -> Maybe DebugTag | ||
355 | parseDebugTag s' = readMaybe ('X':map toUpper (take 1 s') ++ drop 1 s') | ||
356 | |||
354 | clientSession :: Session -> t1 -> t -> ClientHandle -> IO () | 357 | clientSession :: Session -> t1 -> t -> ClientHandle -> IO () |
355 | clientSession s@Session{..} sock cnum h = do | 358 | clientSession s@Session{..} sock cnum h = do |
356 | line <- dropWhile isSpace <$> hGetClientLine h | 359 | line <- dropWhile isSpace <$> hGetClientLine h |
@@ -638,7 +641,7 @@ clientSession s@Session{..} sock cnum h = do | |||
638 | hPutClient h "" | 641 | hPutClient h "" |
639 | 642 | ||
640 | ("quiet",s) | s' <- strp s | 643 | ("quiet",s) | s' <- strp s |
641 | , Just (tag::DebugTag) <- readMaybe ('X':map toUpper (take 1 s') ++ drop 1 s') | 644 | , Just (tag::DebugTag) <- parseDebugTag s' |
642 | -> cmd0 $ do | 645 | -> cmd0 $ do |
643 | setQuiet tag | 646 | setQuiet tag |
644 | hPutClient h $ "Suppressing " ++ show tag ++ " messages." | 647 | hPutClient h $ "Suppressing " ++ show tag ++ " messages." |
@@ -658,7 +661,7 @@ clientSession s@Session{..} sock cnum h = do | |||
658 | showDebugTags | 661 | showDebugTags |
659 | 662 | ||
660 | ("verbose",s) | s' <- strp s | 663 | ("verbose",s) | s' <- strp s |
661 | , Just (tag::DebugTag) <- readMaybe ('X':map toUpper (take 1 s') ++ drop 1 s') | 664 | , Just (tag::DebugTag) <- parseDebugTag s' |
662 | -> cmd0 $ do | 665 | -> cmd0 $ do |
663 | setVerbose tag | 666 | setVerbose tag |
664 | hPutClient h $ "Showing " ++ show tag ++ " messages." | 667 | hPutClient h $ "Showing " ++ show tag ++ " messages." |
@@ -1291,19 +1294,21 @@ data Options = Options | |||
1291 | -- | 1294 | -- |
1292 | -- [ 2 ] Log all stanzas, even pings. | 1295 | -- [ 2 ] Log all stanzas, even pings. |
1293 | , verbosity :: Int | 1296 | , verbosity :: Int |
1297 | , verboseTags :: [DebugTag] | ||
1294 | } | 1298 | } |
1295 | deriving (Eq,Show) | 1299 | deriving (Eq,Show) |
1296 | 1300 | ||
1297 | sensibleDefaults :: Options | 1301 | sensibleDefaults :: Options |
1298 | sensibleDefaults = Options | 1302 | sensibleDefaults = Options |
1299 | { portbt = "6881" | 1303 | { portbt = "6881" |
1300 | , porttox = "33445" | 1304 | , porttox = "33445" |
1301 | , portxmpp = "5222" | 1305 | , portxmpp = "5222" |
1302 | , portxmppS = "5269" | 1306 | , portxmppS = "5269" |
1303 | , ip6bt = True | 1307 | , ip6bt = True |
1304 | , ip6tox = True | 1308 | , ip6tox = True |
1305 | , dhtkey = Nothing | 1309 | , dhtkey = Nothing |
1306 | , verbosity = 2 | 1310 | , verbosity = 2 |
1311 | , verboseTags = [XMisc] | ||
1307 | } | 1312 | } |
1308 | 1313 | ||
1309 | -- bt=<port>,tox=<port> | 1314 | -- bt=<port>,tox=<port> |
@@ -1317,6 +1322,14 @@ parseArgs ("--dht-key":k:args) opts = parseArgs args opts | |||
1317 | parseArgs ("-4":args) opts = parseArgs args opts | 1322 | parseArgs ("-4":args) opts = parseArgs args opts |
1318 | { ip6bt = False | 1323 | { ip6bt = False |
1319 | , ip6tox = False } | 1324 | , ip6tox = False } |
1325 | parseArgs ("-v":tags:args) opts = parseArgs args opts | ||
1326 | { verboseTags = let gs = groupBy (const (/= ',')) tags | ||
1327 | ss = map (dropWhile (==',')) gs | ||
1328 | (ds0,as0) = partition (\s -> last (' ':s) == '-') ss | ||
1329 | as = mapMaybe parseDebugTag as0 | ||
1330 | ds = mapMaybe (parseDebugTag . init) ds0 | ||
1331 | in (verboseTags opts `union` as) \\ ds | ||
1332 | } | ||
1320 | parseArgs (arg:args) opts = parseArgs args opts | 1333 | parseArgs (arg:args) opts = parseArgs args opts |
1321 | { portbt = fromMaybe (portbt opts) $ Prelude.lookup "bt" ports | 1334 | { portbt = fromMaybe (portbt opts) $ Prelude.lookup "bt" ports |
1322 | , porttox = fromMaybe (porttox opts) $ Prelude.lookup "tox" ports | 1335 | , porttox = fromMaybe (porttox opts) $ Prelude.lookup "tox" ports |
@@ -1434,8 +1447,7 @@ main = do | |||
1434 | 1447 | ||
1435 | -- Default: quiet all tags (except XMisc). | 1448 | -- Default: quiet all tags (except XMisc). |
1436 | forM [minBound .. maxBound] setQuiet | 1449 | forM [minBound .. maxBound] setQuiet |
1437 | -- Default: verbose XMisc | 1450 | forM (verboseTags opts) setVerbose |
1438 | setVerbose XMisc | ||
1439 | 1451 | ||
1440 | (quitBt,btdhts,btips,baddrs) <- case portbt opts of | 1452 | (quitBt,btdhts,btips,baddrs) <- case portbt opts of |
1441 | "" -> return (return (), Map.empty,return [],[]) | 1453 | "" -> return (return (), Map.empty,return [],[]) |