dnscache (empty) → 0.1.0
raw patch · 5 files changed
+452/−0 lines, 5 filesdep +basedep +containersdep +contstuffsetup-changed
Dependencies added: base, containers, contstuff, dns, iproute, time
Files
- LICENSE +32/−0
- MassDns.hs +56/−0
- Network/DnsCache.hs +318/−0
- Setup.lhs +12/−0
- dnscache.cabal +34/−0
+ LICENSE view
@@ -0,0 +1,32 @@+dnscache license+Copyright (c) 2010, Ertugrul Soeylemez++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in+ the documentation and/or other materials provided with the+ distribution.++ * Neither the name of the author nor the names of any contributors+ may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ MassDns.hs view
@@ -0,0 +1,56 @@+-- |+-- Module: Main+-- Copyright: (c) 2010 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+-- Stability: experimental++module Main where++import Network.DnsCache+import System.Environment+import System.IO+import Text.Printf+++printEntry :: String -> String -> [String] -> IO ()+printEntry _ _ [] = return ()+printEntry d t es = printf "%s %s %s\n" d t (unwords es)+++printDns :: Int -> MassType -> [String] -> IO ()+printDns numThreads mtype domains =+ seq mtype . withDnsCache numThreads 300 $ \dns ->+ massLookupReport dns mtype domains $ \res -> do+ let dom = massDomain res+ printEntry dom "A" $ map show (massA res)+ printEntry dom "AAAA" $ map show (massAAAA res)+ printEntry dom "MX" $ massMX res+++putHelp :: IO ()+putHelp = do+ progName <- getProgName+ hPrintf stderr "Usage: %s NUMTHREADS TYPE [DOMAINS]\n\n" progName+ hPutStrLn stderr "If no domains are specified, domain list is read from stdin."+ hPutStrLn stderr "TYPE can be one of 'A', 'AAAA', 'MX' and 'all'."+++toMassType :: String -> MassType+toMassType "A" = MassA+toMassType "AAAA" = MassAAAA+toMassType "MX" = MassMX+toMassType "all" = MassAll+toMassType _ = error "Unknown resource type."+++main :: IO ()+main = do+ args <- getArgs+ case args of+ ["-h"] -> putHelp+ ["--help"] -> putHelp+ [ntStr,typeStr] -> fmap lines getContents >>=+ printDns (read ntStr) (toMassType typeStr)+ ntStr:typeStr:doms -> printDns (read ntStr) (toMassType typeStr) doms+ _ -> putHelp
+ Network/DnsCache.hs view
@@ -0,0 +1,318 @@+-- |+-- Module: Network.DnsCache+-- Copyright: (c) 2010 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+-- Stability: experimental+--+-- This module implements an asynchronous, caching DNS resolver.++{-# LANGUAGE GADTs, TypeFamilies #-}++module Network.DnsCache+ ( -- * DNS cache+ DnsCache,+ withDnsCache,++ -- * DNS lookup+ resolveA,+ resolveAAAA,+ resolveMX,++ -- * DNS mass lookup+ MassResult(..),+ MassType(..),+ massLookup,+ massLookupReport+ )+ where++import qualified Control.Exception as E+import qualified Data.Map as M+import Control.Concurrent+import Control.ContStuff+import Data.Char+import Data.IP+import Data.List+import Data.Map (Map)+import Data.Ord+import Data.Time.Clock+import Network.DNS hiding (lookup)+++-- | Command to a DNS cache.++data CacheCmd res+ = CacheGet Domain (Waiter res)+ | CacheQuit (IO ())+ | CacheRequest Domain (Bool -> IO ())+ | CacheSetNotFound Domain+ | CacheSetResolved Domain [res]+++-- | DNS cache configuration.++data DnsCache =+ DnsCache {+ dnsAVar :: MVar (CacheCmd IPv4),+ dnsAaaaVar :: MVar (CacheCmd IPv6),+ dnsMxVar :: MVar (CacheCmd Domain),+ dnsResVar :: MVar ResolverCmd+ }+++-- | DNS cache entry.++data Entry res+ = NotFound+ | Resolving [Waiter res]+ | Resolved UTCTime [res]+++-- | Result of a mass lookup.++data MassResult =+ MassResult {+ massDomain :: Domain,+ massA :: [IPv4],+ massAAAA :: [IPv6],+ massMX :: [Domain]+ }+ deriving Show+++-- | The type of resources to look up.++data MassType = MassA | MassAAAA | MassMX | MassAll+++-- | DNS resolver command.++data ResolverCmd where+ Resolve ::+ Domain ->+ MVar (CacheCmd res) ->+ (Resolver -> Domain -> IO (Maybe [res])) ->+ Waiter res ->+ ResolverCmd+ ResolverQuit :: IO () -> ResolverCmd+++-- | DNS resolver waiter.++type Waiter res = Maybe [res] -> IO ()+++-- | DNS cache thread.++dnsCache :: NominalDiffTime -> MVar (CacheCmd res) -> IO ()+dnsCache timeout cmdVar =+ evalStateT M.empty . forever $ do+ cmd <- io $ takeMVar cmdVar+ case cmd of+ CacheGet dom waiter -> do+ mCache <- getField (M.lookup dom)+ case mCache of+ Nothing -> io $ waiter Nothing+ Just NotFound -> io $ waiter Nothing+ Just (Resolved _ res) -> io $ waiter (Just res)+ Just (Resolving ws) ->+ modify (M.insert dom (Resolving (waiter:ws)))++ CacheQuit c -> io c >> abort ()++ CacheRequest dom c -> do+ mCache <- getField (M.lookup dom)+ curTime <- io getCurrentTime+ case mCache of+ Just (Resolving _) -> io $ c False+ Just (Resolved time _) | diffUTCTime curTime time < timeout ->+ io $ c False+ _ -> do+ modify (M.insert dom (Resolving []))+ io $ c True++ CacheSetNotFound dom -> do+ mCache <- getField (M.lookup dom)+ case mCache of+ Just (Resolving cs) -> io $ mapM_ ($ Nothing) cs+ _ -> return ()+ modify (M.insert dom NotFound)++ CacheSetResolved dom res -> do+ mCache <- getField (M.lookup dom)+ case mCache of+ Just (Resolving cs) -> io $ mapM_ ($ Just res) cs+ _ -> return ()+ curTime <- io getCurrentTime+ modify (M.insert dom (Resolved curTime res))+++-- | Perform a mass lookup.++massLookup :: DnsCache -> MassType -> [Domain] -> IO (Map Domain MassResult)+massLookup dns mtype domains = do+ let numDomains = length domains+ resultVar <- newEmptyMVar+ massResolver dns mtype domains resultVar+ execStateT M.empty . replicateM_ numDomains $ do+ m@(MassResult dom _ _ _) <- io $ takeMVar resultVar+ modify (M.insert dom m)+++-- | Perform a mass lookup with report function.++massLookupReport ::+ (Base m ~ IO, LiftBase m, Monad m) =>+ DnsCache -> MassType -> [Domain] -> (MassResult -> m ()) -> m ()+massLookupReport dns mtype domains rep = do+ let numDomains = length domains+ resultVar <- io newEmptyMVar+ io $ massResolver dns mtype domains resultVar+ replicateM_ numDomains $ io (takeMVar resultVar) >>= rep+++-- | Mass resolver.++massResolver :: DnsCache -> MassType -> [Domain] -> MVar MassResult -> IO ()+massResolver dns mtype domains resultVar = do+ forM_ domains $ \domain ->+ forkIO $ do+ case mtype of+ MassA -> do+ resVar <- newEmptyMVar+ forkIO $ resolveA dns domain >>= putMVar resVar . maybe [] id+ res <- takeMVar resVar+ putMVar resultVar (MassResult domain res [] [])++ MassAAAA -> do+ resVar <- newEmptyMVar+ forkIO $ resolveAAAA dns domain >>= putMVar resVar . maybe [] id+ res <- takeMVar resVar+ putMVar resultVar (MassResult domain [] res [])++ MassMX -> do+ resVar <- newEmptyMVar+ forkIO $ resolveMX dns domain >>= putMVar resVar . maybe [] id+ res <- takeMVar resVar+ putMVar resultVar (MassResult domain [] [] res)++ MassAll -> do+ aVar <- newEmptyMVar+ aaaaVar <- newEmptyMVar+ mxVar <- newEmptyMVar++ forkIO $ resolveA dns domain >>= putMVar aVar . maybe [] id+ forkIO $ resolveAAAA dns domain >>= putMVar aaaaVar . maybe [] id+ forkIO $ resolveMX dns domain >>= putMVar mxVar . maybe [] id++ a <- takeMVar aVar+ aaaa <- takeMVar aaaaVar+ mx <- takeMVar mxVar+ putMVar resultVar (MassResult domain a aaaa mx)+++-- | Resolve an A record.++resolveA :: DnsCache -> Domain -> IO (Maybe [IPv4])+resolveA cfg dom = do+ let cacheVar = dnsAVar cfg+ let resVar = dnsResVar cfg++ answerVar <- newEmptyMVar+ putMVar resVar (Resolve dom cacheVar lookupA (putMVar answerVar))+ takeMVar answerVar+++-- | Resolve an AAAA record.++resolveAAAA :: DnsCache -> Domain -> IO (Maybe [IPv6])+resolveAAAA cfg dom = do+ let cacheVar = dnsAaaaVar cfg+ let resVar = dnsResVar cfg++ answerVar <- newEmptyMVar+ putMVar resVar (Resolve dom cacheVar lookupAAAA (putMVar answerVar))+ takeMVar answerVar+++-- | Resolve an MX record.++resolveMX :: DnsCache -> Domain -> IO (Maybe [Domain])+resolveMX cfg dom = do+ let cacheVar = dnsMxVar cfg+ let resVar = dnsResVar cfg++ let mxLookup r d = fmap (map fst . sortBy (comparing snd)) <$> lookupMX r d++ answerVar <- newEmptyMVar+ putMVar resVar (Resolve dom cacheVar mxLookup (putMVar answerVar))+ takeMVar answerVar+++-- | DNS resolver thread.++resolver :: MVar ResolverCmd -> IO ()+resolver cmdVar = do+ seed <- makeResolvSeed defaultResolvConf+ withResolver seed $ \resolver ->+ evalContT . forever $ do+ cmd <- io $ takeMVar cmdVar+ case cmd of+ Resolve dom' cacheVar dnsLookup waiter ->+ io $ do+ let dom = map toLower dom'+ mayResVar <- newEmptyMVar+ putMVar cacheVar (CacheRequest dom (putMVar mayResVar))+ mayResolve <- takeMVar mayResVar++ if mayResolve+ then do+ mRes <- dnsLookup resolver dom+ case mRes of+ Nothing ->+ putMVar cacheVar (CacheSetNotFound dom) >>+ waiter Nothing+ Just res ->+ putMVar cacheVar (CacheSetResolved dom res) >>+ waiter (Just res)+ else do+ resVar <- newEmptyMVar+ putMVar cacheVar (CacheGet dom (putMVar resVar))+ takeMVar resVar >>= waiter++ ResolverQuit c -> io c >> abort ()+++-- | Start a DNS cache with the given number of resolver threads and the+-- given cache timeout.++withDnsCache :: Int -> NominalDiffTime -> (DnsCache -> IO a) -> IO a+withDnsCache numThreads timeout comp = do+ resolverVar <- newEmptyMVar+ aVar <- newEmptyMVar+ aaaaVar <- newEmptyMVar+ mxVar <- newEmptyMVar++ replicateM_ numThreads . forkIO $ resolver resolverVar+ forkIO $ dnsCache timeout aVar+ forkIO $ dnsCache timeout aaaaVar+ forkIO $ dnsCache timeout mxVar++ let cfg = DnsCache {+ dnsAVar = aVar,+ dnsAaaaVar = aaaaVar,+ dnsMxVar = mxVar,+ dnsResVar = resolverVar+ }++ E.finally (comp cfg) $ do+ quitVar <- newEmptyMVar+ replicateM_ numThreads $ do+ putMVar resolverVar (ResolverQuit $ putMVar quitVar ())+ takeMVar quitVar++ putMVar aVar (CacheQuit (putMVar quitVar ()))+ putMVar aaaaVar (CacheQuit (putMVar quitVar ()))+ putMVar mxVar (CacheQuit (putMVar quitVar ()))+ replicateM_ 3 $ takeMVar quitVar
+ Setup.lhs view
@@ -0,0 +1,12 @@+dnscache setup script+Copyright (C) 2010, Ertugrul Soeylemez++Please see the LICENSE file for terms and conditions of use,+modification and distribution of this package, including this file.++> module Main where+>+> import Distribution.Simple+>+> main :: IO ()+> main = defaultMain
+ dnscache.cabal view
@@ -0,0 +1,34 @@+Name: dnscache+Version: 0.1.0+Category: Network+Synopsis: Caching DNS resolver library and mass DNS resolver utility+Maintainer: Ertugrul Söylemez <es@ertes.de>+Author: Ertugrul Söylemez <es@ertes.de>+Copyright: (c) 2010 Ertugrul Söylemez+License: BSD3+License-file: LICENSE+Build-type: Simple+Stability: experimental+Cabal-version: >= 1.6+Description:++ This library implements a caching, asynchronous DNS resolver and+ provides a command line utility for mass DNS resolution.++Library+ Build-depends:+ base >= 4 && <= 5,+ containers >= 0.3.0.0,+ contstuff >= 0.7.0,+ dns >= 0.1.0,+ iproute >= 1.2.0,+ time >= 1.1.4+ GHC-Options: -W+ Exposed-modules:+ Network.DnsCache++Executable massdns+ Build-depends:+ base >= 4 && <= 5+ GHC-Options: -W -threaded+ Main-is: MassDns.hs