harbl/src/Network/DNS/RBL/Host.hs

   1 module Network.DNS.RBL.Host
   2 where
   3
   4 import Data.ByteString.Char8 (
   5   intercalate,
   6   pack,
   7   split )
   8 import qualified Network.DNS as DNS ( Domain )
   9 import Text.Parsec (
  10   (<|>),
  11   char,
  12   try )
  13 import Text.Parsec.String ( Parser )
  14
  15 import Network.DNS.RBL.Domain ( Domain, domain )
  16 import Network.DNS.RBL.Pretty ( Pretty(..) )
  17
  18
  19 -- | This type helps clarify some murkiness in the DNS \"domain\" name
  20 --   specification. In RFC1034, it is acknowledged that a domain name
  21 --   input with a trailing \".\" will represent an absolute domain
  22 --   name (i.e. with respect to the DNS root). However, the grammar in
  23 --   RFC1035 disallows a trailing dot.
  24 --
  25 --   This makes some sense: within the DNS, everything knows its
  26 --   position in the tree. The relative/absolute distinction only
  27 --   makes sense on the client side, where a user's resolver might
  28 --   decide to append some suffix to a relative
  29 --   request. Unfortunately, that's where we live. So we have to deal
  30 --   with the possibility of having a trailing dot at the end of any
  31 --   domain name.
  32 --
  33 data Host =
  34   HostRelative Domain |
  35   HostAbsolute Domain
  36   deriving (Eq, Show)
  37
  38 instance Pretty Host where
  39   pretty_show (HostRelative d) = pretty_show d
  40   pretty_show (HostAbsolute d) = (pretty_show d) ++ "."
  41
  42
  43 -- | Parse a 'Host'. This is what we'll be using to read user
  44 --   input, since it supports both relative and absolute domain names
  45 --   (unlike the implicitly-absolute 'Domain').
  46 --
  47 --   ==== _Examples_
  48 --
  49 --   >>> import Text.Parsec ( parse, parseTest )
  50 --
  51 --   We can really parse the root now!
  52 --
  53 --   >>> parseTest user_domain "."
  54 --   HostAbsolute DomainRoot
  55 --
  56 --   But multiple dots aren't (only the first):
  57 --
  58 --   >>> pretty_print $ parse user_domain "" ".."
  59 --   .
  60 --
  61 --   We can also optionally have a trailing dot at the end of a
  62 --   non-empty name:
  63 --
  64 --   >>>  pretty_print $ parse user_domain "" "www.example.com"
  65 --   www.example.com
  66 --
  67 --   >>>  pretty_print $ parse user_domain "" "www.example.com."
  68 --   www.example.com.
  69 --
  70 --   A \"relative root\" can also be parsed, letting the user's
  71 --   resolver deal with it:
  72 --
  73 --   >>> parseTest user_domain ""
  74 --   HostRelative DomainRoot
  75 --
  76 host :: Parser Host
  77 host = try absolute <|> relative
  78   where
  79     absolute :: Parser Host
  80     absolute = do
  81       d <- domain
  82       _ <- char '.'
  83       return $ HostAbsolute d
  84
  85     relative :: Parser Host
  86     relative = fmap HostRelative domain
  87
  88
  89
  90 -- | Reverse the labels of this host in preparation for making a
  91 --   lookup (using the DNS library). We need to reverse the labels
  92 --   (the stuff between the dots) whether we're looking up a host or a
  93 --   name. The only tricky part here is that we need to turn an
  94 --   absolute 'Host' into a relative one.
  95 --
  96 --   ==== _Examples_
  97 --
  98 --   >>> import Text.Parsec ( parse )
  99 --
 100 --   >>> let (Right r) = parse host "" "1.2.3.4"
 101 --   >>> reverse_labels r
 102 --   "4.3.2.1"
 103 --
 104 --   >>> let (Right r) = parse host "" "www.example.com"
 105 --   >>> reverse_labels r
 106 --   "com.example.www"
 107 --
 108 --   Make sure absolute names are made relative:
 109 --
 110 --   >>> let (Right r) = parse host "" "www.example.com."
 111 --   >>> reverse_labels r
 112 --   "com.example.www"
 113 --
 114 reverse_labels :: Host -> DNS.Domain
 115 reverse_labels h = reversed
 116   where
 117     -- | It's possible that we are given an absolute domain name to
 118     --   look up. This is legit; say I want to look up
 119     --   \"www.example.com.\" That's fine, but before we make the
 120     --   actual query we'll need to make it relative and then append
 121     --   the DNSBL's suffix to it.
 122     relative_host_string :: String
 123     relative_host_string =
 124       case h of
 125         (HostRelative _) -> pretty_show h
 126         (HostAbsolute d) -> pretty_show d
 127
 128     dot = pack "."
 129     labels = split '.' (pack relative_host_string)
 130     reversed = intercalate dot (reverse labels)