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   Domain,
  18   DNSError,
  19   Resolver,
  20   defaultResolvConf,
  21   lookupA,
  22   makeResolvSeed,
  23   withResolver )
  24
  25 import Network.DNS.RBL.Host ( Host(..), host )
  26 import Network.DNS.RBL.IPv4Pattern ( addresses )
  27 import Network.DNS.RBL.Pretty ( Pretty(..) )
  28 import Network.DNS.RBL.Reversible ( Reversible(..) )
  29 import Network.DNS.RBL.Site ( Site(..), sites )
  30
  31
  32
  33 -- | In most applications, you will want to know /why/ a host is
  34 --   blacklisted. This type stores those details: the host itself, the
  35 --   site on which the host was listed, and the return codes that we
  36 --   got back from the blacklist.
  37 data ListingDetails = ListingDetails Host Site [IPv4]
  38
  39
  40 -- | Create a nice \"error\" message from a host and the details of
  41 --   why it was listed.
  42 --
  43 listing_message :: ListingDetails -> String
  44 listing_message (ListingDetails h (Site d _ w) codes) =
  45   "host " ++ (pretty_show h) ++ " " ++
  46   "listed on " ++ (pretty_show d) ++ " " ++
  47   "with return code(s) " ++ return_codes ++ " " ++
  48   "having weight " ++ (pretty_show w)
  49   where
  50     return_codes :: String
  51     return_codes = intercalate "," (map show codes)
  52
  53
  54 -- | Make the given 'Host' relative (if it was absolute), and reverse
  55 --   its labels. This is done in order to look it up in the DNS in
  56 --   standard reverse lookup form. For example, if we wanted to look
  57 --   up @192.168.0.1@ on @rbl.example.com@, we would want to look up
  58 --   the name @1.0.168.192.rbl.example.com@.
  59 --
  60 reverse_host :: Host -> Domain
  61 reverse_host h =
  62   pack $ case (backwards h) of
  63            (HostRelative _) -> pretty_show h
  64            (HostAbsolute d) -> pretty_show d
  65
  66
  67
  68 -- | This code is stolen from 'Network.DNS.lookupRDNS', which I'm
  69 --   pretty sure I wrote anyway.
  70 --
  71 dnslookup :: Resolver -> Host -> Host -> IO (Either DNSError [IPv4])
  72 dnslookup rlv rbl h = lookupA rlv dom
  73   where
  74     suffix = pack $ "." ++ (pretty_show rbl)
  75     dom = (reverse_host h) `append` suffix
  76
  77
  78 -- | See 'lookup_single'. The \"prime\" version here takes an
  79 --   additional @resolver@ argument for performance reasons.
  80 --
  81 lookup_single' :: Resolver
  82                -> Host
  83                -> Site
  84                -> IO (Maybe ListingDetails)
  85 lookup_single' resolver h site@(Site d p _) = do
  86   response <- dnslookup resolver d h
  87   case response of
  88     Left _ -> return Nothing -- Not listed, no error to report
  89     Right ipv4s ->
  90       case p of
  91         -- No pattern given, but we got a hit.
  92         Nothing -> return $ Just (ListingDetails h site ipv4s)
  93         Just pat -> do
  94           let ipv4_strings = map show ipv4s
  95           let codes = addresses pat
  96           let hits = map (`elem` codes) ipv4_strings
  97           if or hits -- if any of the returned addresses match the pattern
  98           then return $ Just (ListingDetails h site ipv4s)
  99           else return Nothing
 100
 101
 102 lookup_rbl :: [Site] -> Host -> IO [ListingDetails]
 103 lookup_rbl rbl_sites h = do
 104   rs <- makeResolvSeed defaultResolvConf
 105   withResolver rs $ \resolver -> do
 106     results <- mapM (lookup_single' resolver h) rbl_sites
 107     return $ catMaybes results