{-# LANGUAGE DoAndIfThenElse #-}

module Network.DNS.RBL (
  Host,
  Site,
  host,
  listing_message,
  lookup_rbl,
  sites )
where

import Data.ByteString.Char8 ( append, pack )
import Data.IP ( IPv4 )
import Data.List ( intercalate )
import Data.Maybe ( catMaybes )
import Network.DNS (
  Domain,
  DNSError,
  Resolver,
  defaultResolvConf,
  lookupA,
  makeResolvSeed,
  withResolver )

import Network.DNS.RBL.Host ( Host(..), host )
import Network.DNS.RBL.IPv4Pattern ( addresses )
import Network.DNS.RBL.Pretty ( Pretty(..) )
import Network.DNS.RBL.Reversible ( Reversible(..) )
import Network.DNS.RBL.Site ( Site(..), sites )



-- | In most applications, you will want to know /why/ a host is
--   blacklisted. This type stores those details: the host itself, the
--   site on which the host was listed, and the return codes that we
--   got back from the blacklist.
data ListingDetails = ListingDetails Host Site [IPv4]


-- | Create a nice \"error\" message from a host and the details of
--   why it was listed.
--
listing_message :: ListingDetails -> String
listing_message (ListingDetails h (Site d _ w) codes) =
  "host " ++ (pretty_show h) ++ " " ++
  "listed on " ++ (pretty_show d) ++ " " ++
  "with return code(s) " ++ return_codes ++ " " ++
  "having weight " ++ (pretty_show w)
  where
    return_codes :: String
    return_codes = intercalate "," (map show codes)


-- | Make the given 'Host' relative (if it was absolute), and reverse
--   its labels. This is done in order to look it up in the DNS in
--   standard reverse lookup form. For example, if we wanted to look
--   up @192.168.0.1@ on @rbl.example.com@, we would want to look up
--   the name @1.0.168.192.rbl.example.com@.
--
reverse_host :: Host -> Domain
reverse_host h =
  pack $ case (backwards h) of
           (HostRelative _) -> pretty_show h
           (HostAbsolute d) -> pretty_show d



-- | This code is stolen from 'Network.DNS.lookupRDNS', which I'm
--   pretty sure I wrote anyway.
--
dnslookup :: Resolver -> Host -> Host -> IO (Either DNSError [IPv4])
dnslookup rlv rbl h = lookupA rlv dom
  where
    suffix = pack $ "." ++ (pretty_show rbl)
    dom = (reverse_host h) `append` suffix


-- | See 'lookup_single'. The \"prime\" version here takes an
--   additional @resolver@ argument for performance reasons.
--
lookup_single' :: Resolver
               -> Host
               -> Site
               -> IO (Maybe ListingDetails)
lookup_single' resolver h site@(Site d p _) = do
  response <- dnslookup resolver d h
  case response of
    Left _ -> return Nothing -- Not listed, no error to report
    Right ipv4s ->
      case p of
        -- No pattern given, but we got a hit.
        Nothing -> return $ Just (ListingDetails h site ipv4s)
        Just pat -> do
          let ipv4_strings = map show ipv4s
          let codes = addresses pat
          let hits = map (`elem` codes) ipv4_strings
          if or hits -- if any of the returned addresses match the pattern
          then return $ Just (ListingDetails h site ipv4s)
          else return Nothing


lookup_rbl :: [Site] -> Host -> IO [ListingDetails]
lookup_rbl rbl_sites h = do
  rs <- makeResolvSeed defaultResolvConf
  withResolver rs $ \resolver -> do
    results <- mapM (lookup_single' resolver h) rbl_sites
    return $ catMaybes results