forked from kazu-yamamoto/concurrent-dns-cache
-
Notifications
You must be signed in to change notification settings - Fork 0
/
main.hs
53 lines (47 loc) · 1.36 KB
/
main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Concurrent (forkIO)
import Control.Exception (try, SomeException(..))
import Control.Monad (void, when)
import qualified Data.ByteString.Char8 as BS
import Network.DNS
import Network.DNS.Cache as DNSC
import Data.Time
confs :: [ResolvConf]
confs = [
defaultResolvConf { resolvInfo = RCHostName "8.8.8.8" }
, defaultResolvConf { resolvInfo = RCHostName "8.8.4.4" }
]
maxCon :: Int
maxCon = 50
cacheConf :: DNSCacheConf
cacheConf = DNSCacheConf {
resolvConfs = confs
, maxConcurrency = maxCon
, minTTL = 60
, maxTTL = 300
, negativeTTL = 300
}
main :: IO ()
main = do
beg <- getCurrentTime
withDNSCache cacheConf (loop 1 beg)
where
loop :: Int -> UTCTime -> DNSCache -> IO ()
loop n beg cache = do
when (n `mod` 1000 == 0) $ do
cur <- getCurrentTime
putStrLn $ show n ++ ": " ++ show (cur `diffUTCTime` beg)
edom <- try BS.getLine
case edom of
Left (SomeException _) -> do
wait cache (== 0)
putStrLn "Done."
Right dom -> do
wait cache (< maxCon)
void $ forkIO (DNSC.resolve cache dom >>= p dom)
loop (n+1) beg cache
p _ (Right _) = return ()
p dom (Left e) = do
putStr $ show e ++ " "
BS.putStrLn dom