src/Network/DNS/RBL.hs

   1 module Network.DNS.RBL ( lookup_single )
   2 where
   3
   4 import qualified Data.ByteString.Char8 as BS (
   5   append,
   6   intercalate,
   7   pack,
   8   split )
   9 import Data.IP ( IPv4 )
  10 import Data.List ( intercalate )
  11 import Data.Maybe ( catMaybes )
  12 import Network.DNS (
  13   DNSError,
  14   Resolver,
  15   defaultResolvConf,
  16   lookupA,
  17   makeResolvSeed,
  18   withResolver )
  19
  20 import Network.DNS.RBL.Domain ( UserDomain )
  21 import Network.DNS.RBL.IPv4Pattern ( addresses )
  22 import Network.DNS.RBL.Pretty ( Pretty(..) )
  23 import Network.DNS.RBL.Site ( Site(..), Weight(..) )
  24
  25 -- | A dumb wrapper around an IP address input as a 'String'.
  26 --
  27 newtype Host = Host String
  28 instance Pretty Host where pretty_show (Host h) = h
  29
  30
  31 -- | In most applications, you will want to know /why/ a host is
  32 --   blacklisted. This type stores those details: the site on which
  33 --   the host was listed, and the return codes that we got back from
  34 --   the blacklist.
  35 data ListingDetails = ListingDetails 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 :: Host -> ListingDetails -> String
  42 listing_message host (ListingDetails (Site d _ w) codes) =
  43   "host " ++ (pretty_show host) ++ " " ++
  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 -> UserDomain -> Host -> IO (Either DNSError [IPv4])
  56 dnslookup rlv rbl (Host ip) = lookupA rlv dom
  57   where
  58     -- ByteString constants.
  59     dot = BS.pack "."
  60     suffix = BS.pack $ "." ++ (pretty_show rbl)
  61
  62     octets = BS.split '.' (BS.pack ip)
  63     reverse_ip = BS.intercalate dot (reverse octets)
  64     dom = reverse_ip `BS.append` suffix
  65
  66
  67
  68 -- | Look up the given @host@ on a single RBL, and return the number
  69 --   of \"points\" it scores. If the host is listed, it should score the
  70 --   weight of the given blacklist. Otherwise, it scores zero.
  71 --
  72 lookup_single :: Host -> Site -> IO Int
  73 lookup_single host site = do
  74   rs <- makeResolvSeed defaultResolvConf
  75   withResolver rs $ \resolver -> lookup_single' resolver host site
  76
  77
  78 -- | See 'lookup_single'.
  79 --
  80 --   The \"prime\" version of this function takes a pre-existing
  81 --   resolver as an argument for performance reasons.
  82 --
  83 lookup_single' :: Resolver -> Host -> Site -> IO Int
  84 lookup_single' resolver host (Site d p (Weight w)) = do
  85   response <- dnslookup resolver d host
  86   case response of
  87     Left _ -> return 0 -- Not listed
  88     Right ipv4s ->
  89       case p of
  90         -- No pattern given, but we got a hit.
  91         Nothing -> return w
  92         Just pat -> do
  93           let ipv4_strings = map show ipv4s
  94           let codes = addresses pat
  95           let hits = map (`elem` codes) ipv4_strings
  96           if or hits -- if any of the returned addresses match the pattern
  97           then return w
  98           else return 0
  99
 100
 101 -- | Look up the given @host@ on all of the white/blacklists contained
 102 --   in @sites@. Return the total \"score\" for the @host@; that is,
 103 --   the sum of the weights for each site whose pattern the host
 104 --   matches.
 105 --
 106 lookup_simple :: Host -> [Site] -> IO Int
 107 lookup_simple host sites = do
 108   rs <- makeResolvSeed defaultResolvConf
 109   withResolver rs $ \resolver -> do
 110     results <- mapM (lookup_single' resolver host) sites
 111     return $ sum results
 112
 113 -- | Look up the given @host@ on all of the white/blacklists contained
 114 --   in @sites@. If the results, multiplied by their weights, add up to
 115 --   (at least) @threshold@, then @True@ is returned; that is, the
 116 --   @host@ is \"listed\". Otherwise, @False@ is returned.
 117 --
 118 lookup_threshold :: Host -> [Site] -> Int -> IO Bool
 119 lookup_threshold host sites threshold = do
 120   score <- lookup_simple host sites
 121   if score >= threshold
 122   then return True
 123   else return False
 124
 125
 126 -- | See 'lookup_single_details'. The \"prime\" version here takes an
 127 --   additional @resolver@ argument for performance reasons.
 128 --
 129 lookup_single_details' :: Resolver
 130                        -> Host
 131                        -> Site
 132                        -> IO (Maybe ListingDetails)
 133 lookup_single_details' resolver host site@(Site d p (Weight w)) = do
 134   response <- dnslookup resolver d host
 135   case response of
 136     Left _ -> return Nothing -- Not listed, no error to report
 137     Right ipv4s ->
 138       case p of
 139         -- No pattern given, but we got a hit.
 140         Nothing -> return $ Just (ListingDetails site ipv4s)
 141         Just pat -> do
 142           let ipv4_strings = map show ipv4s
 143           let codes = addresses pat
 144           let hits = map (`elem` codes) ipv4_strings
 145           if or hits -- if any of the returned addresses match the pattern
 146           then return $ Just (ListingDetails site ipv4s)
 147           else return Nothing
 148
 149
 150 -- | Look up a single...
 151 lookup_single_details :: Host
 152                       -> Site
 153                       -> IO (Maybe ListingDetails)
 154 lookup_single_details host site = do
 155   rs <- makeResolvSeed defaultResolvConf
 156   withResolver rs $ \resolver -> lookup_single_details' resolver host site
 157
 158
 159 lookup_details :: Host -> [Site] -> IO [ListingDetails]
 160 lookup_details host sites = do
 161   rs <- makeResolvSeed defaultResolvConf
 162   withResolver rs $ \resolver -> do
 163     results <- mapM (lookup_single_details' resolver host) sites
 164     return $ catMaybes results