harbl/src/Network/DNS/RBL.hs

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