src/Network/DNS/RBL.hs

   1 module Network.DNS.RBL ( lookup_single )
   2 where
   3
   4 import Data.ByteString.Char8 ( append, pack )
   5 import Data.IP ( IPv4 )
   6 import Data.List ( intercalate )
   7 import Data.Maybe ( catMaybes )
   8 import Network.DNS (
   9   DNSError,
  10   Resolver,
  11   defaultResolvConf,
  12   lookupA,
  13   makeResolvSeed,
  14   withResolver )
  15
  16 import Network.DNS.RBL.Domain ( UserDomain )
  17 import Network.DNS.RBL.Host ( Host, reverse_labels )
  18 import Network.DNS.RBL.IPv4Pattern ( addresses )
  19 import Network.DNS.RBL.Pretty ( Pretty(..) )
  20 import Network.DNS.RBL.Site ( Site(..), Weight(..) )
  21
  22
  23
  24 -- | In most applications, you will want to know /why/ a host is
  25 --   blacklisted. This type stores those details: the site on which
  26 --   the host was listed, and the return codes that we got back from
  27 --   the blacklist.
  28 data ListingDetails = ListingDetails Site [IPv4]
  29
  30
  31 -- | Create a nice \"error\" message from a host and the details of
  32 --   why it was listed.
  33 --
  34 listing_message :: Host -> ListingDetails -> String
  35 listing_message host (ListingDetails (Site d _ w) codes) =
  36   "host " ++ (pretty_show host) ++ " " ++
  37   "listed on " ++ (pretty_show d) ++ " " ++
  38   "with return code(s) " ++ return_codes ++ " " ++
  39   "having weight " ++ (pretty_show w)
  40   where
  41     return_codes :: String
  42     return_codes = intercalate "," (map show codes)
  43
  44
  45 -- | This code is stolen from 'Network.DNS.lookupRDNS', which I'm
  46 --   pretty sure I wrote anyway.
  47 --
  48 dnslookup :: Resolver -> UserDomain -> Host -> IO (Either DNSError [IPv4])
  49 dnslookup rlv rbl host = lookupA rlv dom
  50   where
  51     suffix = pack $ "." ++ (pretty_show rbl)
  52     dom = (reverse_labels host) `append` suffix
  53
  54
  55 -- | See 'lookup_single'. The \"prime\" version here takes an
  56 --   additional @resolver@ argument for performance reasons.
  57 --
  58 lookup_single' :: Resolver
  59                -> Host
  60                -> Site
  61                -> IO (Maybe ListingDetails)
  62 lookup_single' resolver host site@(Site d p (Weight w)) = do
  63   response <- dnslookup resolver d host
  64   case response of
  65     Left _ -> return Nothing -- Not listed, no error to report
  66     Right ipv4s ->
  67       case p of
  68         -- No pattern given, but we got a hit.
  69         Nothing -> return $ Just (ListingDetails site ipv4s)
  70         Just pat -> do
  71           let ipv4_strings = map show ipv4s
  72           let codes = addresses pat
  73           let hits = map (`elem` codes) ipv4_strings
  74           if or hits -- if any of the returned addresses match the pattern
  75           then return $ Just (ListingDetails site ipv4s)
  76           else return Nothing
  77
  78
  79 -- | Look up a single...
  80 lookup_single :: Host
  81               -> Site
  82               -> IO (Maybe ListingDetails)
  83 lookup_single host site = do
  84   rs <- makeResolvSeed defaultResolvConf
  85   withResolver rs $ \resolver -> lookup_single' resolver host site
  86
  87
  88 lookup :: Host -> [Site] -> IO [ListingDetails]
  89 lookup host sites = do
  90   rs <- makeResolvSeed defaultResolvConf
  91   withResolver rs $ \resolver -> do
  92     results <- mapM (lookup_single' resolver host) sites
  93     return $ catMaybes results
  94
  95