Replace 'UserDomain' with 'Host' in the library.

[dead/harbl.git] / harbl / src / Network / DNS / RBL / Host.hs

diff --git a/harbl/src/Network/DNS/RBL/Host.hs b/harbl/src/Network/DNS/RBL/Host.hs
new file mode 100644 (file)
index 0000000..93deeb8
--- /dev/null
+++ b/harbl/src/Network/DNS/RBL/Host.hs
@@ -0,0 +1,130 @@
+module Network.DNS.RBL.Host
+where
+
+import Data.ByteString.Char8 (
+  intercalate,
+  pack,
+  split )
+import qualified Network.DNS as DNS ( Domain )
+import Text.Parsec (
+  (<|>),
+  char,
+  try )
+import Text.Parsec.String ( Parser )
+
+import Network.DNS.RBL.Domain ( Domain, domain )
+import Network.DNS.RBL.Pretty ( Pretty(..) )
+
+
+-- | This type helps clarify some murkiness in the DNS \"domain\" name
+--   specification. In RFC1034, it is acknowledged that a domain name
+--   input with a trailing \".\" will represent an absolute domain
+--   name (i.e. with respect to the DNS root). However, the grammar in
+--   RFC1035 disallows a trailing dot.
+--
+--   This makes some sense: within the DNS, everything knows its
+--   position in the tree. The relative/absolute distinction only
+--   makes sense on the client side, where a user's resolver might
+--   decide to append some suffix to a relative
+--   request. Unfortunately, that's where we live. So we have to deal
+--   with the possibility of having a trailing dot at the end of any
+--   domain name.
+--
+data Host =
+  HostRelative Domain |
+  HostAbsolute Domain
+  deriving (Eq, Show)
+
+instance Pretty Host where
+  pretty_show (HostRelative d) = pretty_show d
+  pretty_show (HostAbsolute d) = (pretty_show d) ++ "."
+
+
+-- | Parse a 'Host'. This is what we'll be using to read user
+--   input, since it supports both relative and absolute domain names
+--   (unlike the implicitly-absolute 'Domain').
+--
+--   ==== _Examples_
+--
+--   >>> import Text.Parsec ( parse, parseTest )
+--
+--   We can really parse the root now!
+--
+--   >>> parseTest user_domain "."
+--   HostAbsolute DomainRoot
+--
+--   But multiple dots aren't (only the first):
+--
+--   >>> pretty_print $ parse user_domain "" ".."
+--   .
+--
+--   We can also optionally have a trailing dot at the end of a
+--   non-empty name:
+--
+--   >>>  pretty_print $ parse user_domain "" "www.example.com"
+--   www.example.com
+--
+--   >>>  pretty_print $ parse user_domain "" "www.example.com."
+--   www.example.com.
+--
+--   A \"relative root\" can also be parsed, letting the user's
+--   resolver deal with it:
+--
+--   >>> parseTest user_domain ""
+--   HostRelative DomainRoot
+--
+host :: Parser Host
+host = try absolute <|> relative
+  where
+    absolute :: Parser Host
+    absolute = do
+      d <- domain
+      _ <- char '.'
+      return $ HostAbsolute d
+
+    relative :: Parser Host
+    relative = fmap HostRelative domain
+
+
+
+-- | Reverse the labels of this host in preparation for making a
+--   lookup (using the DNS library). We need to reverse the labels
+--   (the stuff between the dots) whether we're looking up a host or a
+--   name. The only tricky part here is that we need to turn an
+--   absolute 'Host' into a relative one.
+--
+--   ==== _Examples_
+--
+--   >>> import Text.Parsec ( parse )
+--
+--   >>> let (Right r) = parse host "" "1.2.3.4"
+--   >>> reverse_labels r
+--   "4.3.2.1"
+--
+--   >>> let (Right r) = parse host "" "www.example.com"
+--   >>> reverse_labels r
+--   "com.example.www"
+--
+--   Make sure absolute names are made relative:
+--
+--   >>> let (Right r) = parse host "" "www.example.com."
+--   >>> reverse_labels r
+--   "com.example.www"
+--
+reverse_labels :: Host -> DNS.Domain
+reverse_labels h = reversed
+  where
+    -- | It's possible that we are given an absolute domain name to
+    --   look up. This is legit; say I want to look up
+    --   \"www.example.com.\" That's fine, but before we make the
+    --   actual query we'll need to make it relative and then append
+    --   the DNSBL's suffix to it.
+    relative_host_string :: String
+    relative_host_string =
+      case h of
+        (HostRelative _) -> pretty_show h
+        (HostAbsolute d) -> pretty_show d
+
+    dot = pack "."
+    labels = split '.' (pack relative_host_string)
+    reversed = intercalate dot (reverse labels)