From 349c5a80e0b729b0e030a1ff3e47667d8afa0d36 Mon Sep 17 00:00:00 2001
From: Michael Orlitzky <michael@orlitzky.com>
Date: Sat, 11 Jul 2015 02:34:50 -0400
Subject: [PATCH] Add the Reversible class. Make the Host reversing oh so much
 more complicated (and fun) with Reversible. Add a Network.DNS.RBL.Tests
 module that only exports tests. Get the test suite working again.

---
 .ghci                                   |  2 +
 harbl.cabal                             | 18 ++---
 harbl/src/Network/DNS/RBL.hs            | 20 +++++-
 harbl/src/Network/DNS/RBL/Domain.hs     | 87 ++++++++++++++++++++++++-
 harbl/src/Network/DNS/RBL/Host.hs       | 86 +++++++++---------------
 harbl/src/Network/DNS/RBL/Reversible.hs | 11 ++++
 harbl/src/Network/DNS/RBL/Tests.hs      | 12 ++++
 test/TestSuite.hs                       |  3 +-
 8 files changed, 169 insertions(+), 70 deletions(-)
 create mode 100644 harbl/src/Network/DNS/RBL/Reversible.hs
 create mode 100644 harbl/src/Network/DNS/RBL/Tests.hs

diff --git a/.ghci b/.ghci
index dae4f7c..6632251 100644
--- a/.ghci
+++ b/.ghci
@@ -8,6 +8,7 @@
   src/Network/DNS/RBL/Host.hs
   src/Network/DNS/RBL/IPv4Pattern.hs
   src/Network/DNS/RBL/Pretty.hs
+  src/Network/DNS/RBL/Reversible.hs
   src/Network/DNS/RBL/Site.hs
 :}
 
@@ -16,6 +17,7 @@ import Network.DNS.RBL.Domain
 import Network.DNS.RBL.Host
 import Network.DNS.RBL.IPv4Pattern
 import Network.DNS.RBL.Pretty
+import Network.DNS.RBL.Reversible
 import Network.DNS.RBL.Site
 
 -- And import the stuff from Parsec we need for debugging.
diff --git a/harbl.cabal b/harbl.cabal
index 8f4401f..8a5191b 100644
--- a/harbl.cabal
+++ b/harbl.cabal
@@ -25,16 +25,17 @@ library
 
   exposed-modules:
     Network.DNS.RBL
+    Network.DNS.RBL.Tests
 
   other-modules:
     Network.DNS.RBL.Domain
     Network.DNS.RBL.Host
     Network.DNS.RBL.IPv4Pattern
     Network.DNS.RBL.Pretty
+    Network.DNS.RBL.Reversible
     Network.DNS.RBL.Site
 
-  hs-source-dirs:
-    harbl/src/
+  hs-source-dirs: harbl/src
 
   ghc-options:
     -Wall
@@ -65,11 +66,9 @@ executable harbl
     harbl,
     parsec                      >= 3
 
-  main-is:
-    Main.hs
+  main-is: Main.hs
 
-  hs-source-dirs:
-    harbl-cli/src/
+  hs-source-dirs: harbl-cli/src
 
   ghc-options:
     -Wall
@@ -92,14 +91,11 @@ executable harbl
 
 test-suite testsuite
   type: exitcode-stdio-1.0
-  hs-source-dirs: src test
+  hs-source-dirs: test
   main-is: TestSuite.hs
   build-depends:
     base                        >= 4.6 && < 5,
-    bytestring                  >= 0.9,
-    dns                         >= 2,
-    iproute                     >= 1.4,
-    parsec                      >= 3,
+    harbl,
     tasty                       >= 0.8,
     tasty-hunit                 >= 0.8
 
diff --git a/harbl/src/Network/DNS/RBL.hs b/harbl/src/Network/DNS/RBL.hs
index c3268fd..c166901 100644
--- a/harbl/src/Network/DNS/RBL.hs
+++ b/harbl/src/Network/DNS/RBL.hs
@@ -14,6 +14,7 @@ import Data.IP ( IPv4 )
 import Data.List ( intercalate )
 import Data.Maybe ( catMaybes )
 import Network.DNS (
+  Domain,
   DNSError,
   Resolver,
   defaultResolvConf,
@@ -21,9 +22,10 @@ import Network.DNS (
   makeResolvSeed,
   withResolver )
 
-import Network.DNS.RBL.Host ( Host, host, reverse_labels )
+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 )
 
 
@@ -49,6 +51,20 @@ listing_message (ListingDetails h (Site d _ w) codes) =
     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.
 --
@@ -56,7 +72,7 @@ dnslookup :: Resolver -> Host -> Host -> IO (Either DNSError [IPv4])
 dnslookup rlv rbl h = lookupA rlv dom
   where
     suffix = pack $ "." ++ (pretty_show rbl)
-    dom = (reverse_labels h) `append` suffix
+    dom = (reverse_host h) `append` suffix
 
 
 -- | See 'lookup_single'. The \"prime\" version here takes an
diff --git a/harbl/src/Network/DNS/RBL/Domain.hs b/harbl/src/Network/DNS/RBL/Domain.hs
index 75170a7..4dd5d1d 100644
--- a/harbl/src/Network/DNS/RBL/Domain.hs
+++ b/harbl/src/Network/DNS/RBL/Domain.hs
@@ -15,7 +15,7 @@
 --   (octets).
 --
 module Network.DNS.RBL.Domain (
-  Domain,
+  Domain(..),
   domain )
 where
 
@@ -30,6 +30,7 @@ import qualified Text.Parsec as Parsec ( digit, letter)
 import Text.Parsec.String ( Parser )
 
 import Network.DNS.RBL.Pretty ( Pretty(..) )
+import Network.DNS.RBL.Reversible ( Reversible(..) )
 
 -- * Digits
 
@@ -496,6 +497,68 @@ instance Pretty Subdomain where
   pretty_show (SubdomainMultipleLabel l s) =
     (pretty_show l) ++ "." ++ (pretty_show s)
 
+
+instance Reversible Subdomain where
+  -- | Reverse the labels of the given subdomain.
+  --
+  --   ==== _Examples_
+  --
+  --   >>> import Text.Parsec ( parse )
+  --
+  --   Standard usage:
+  --
+  --   >>> let (Right r) = parse subdomain "" "com"
+  --   >>> pretty_print $ backwards r
+  --   com
+  --
+  --   >>> let (Right r) = parse subdomain "" "example.com"
+  --   >>> pretty_print $ backwards r
+  --   com.example
+  --
+  --   >>> let (Right r) = parse subdomain "" "www.example.com"
+  --   >>> pretty_print $ backwards r
+  --   com.example.www
+  --
+  --   >>> let (Right r) = parse subdomain "" "new.www.example.com"
+  --   >>> pretty_print $ backwards r
+  --   com.example.www.new
+  --
+
+  -- It's easy to reverse a single label...
+  backwards s@(SubdomainSingleLabel _) = s
+
+  -- For multiple labels we have two cases. The first is where we have
+  -- exactly two labels, and we just need to swap them.
+  backwards (SubdomainMultipleLabel l (SubdomainSingleLabel m)) =
+    SubdomainMultipleLabel m (SubdomainSingleLabel l)
+
+  -- And now the hard case. If we reversed @s@, then the "head" of
+  -- the result (@last_s@) should be the last label in the entire
+  -- subdomain. Stick @last_s@ on the front of the result. That makes
+  -- enough sense.
+  --
+  -- But what to do about the rest? We need to get \"init s\"
+  -- somehow. Well, we have the reverse of it... why not waste a bunch
+  -- of time and reverse that, too? With @init s@ in hand, we can
+  -- prepend @l@ to that, and THEN reverse the entire thing. What we'll
+  -- wind up with looks like @[last_s, init_s_rev, l]@ which you can
+  -- pretend you recognize as the subdomain in reverse.
+  --
+  backwards (SubdomainMultipleLabel l s) =
+    case (backwards s) of
+      SubdomainMultipleLabel last_s init_s_rev ->
+        let init_s = backwards init_s_rev
+        in
+          SubdomainMultipleLabel
+            last_s
+            (backwards (SubdomainMultipleLabel l init_s))
+
+      -- Reversing a multiple label thing gives you back a multiple
+      -- label thing but there's no way to promise that.
+      impossible -> impossible
+
+
+
 -- | Parse an RFC1035 \"subdomain\". The given grammar is,
 --
 --     <subdomain> ::= <label> | <subdomain> "." <label>
@@ -627,6 +690,7 @@ subdomain_has_equal_neighbors s =
 
 
 
+
 -- * Domains
 
 -- | An RFC1035 domain. According to RFC1035 a domain can be either a
@@ -717,3 +781,24 @@ domain = try parse_subdomain <|> parse_empty
 
     parse_empty :: Parser Domain
     parse_empty = string "" >> return DomainRoot
+
+
+instance Reversible Domain where
+  -- | Reverse the labels of a 'Domain'.
+  --
+  --   --   ==== _Examples_
+  --
+  --   >>> import Text.Parsec ( parse )
+  --
+  --   The root reverses to itself:
+  --
+  --   >>> let (Right r) = parse domain "" ""
+  --   >>> backwards r
+  --   DomainRoot
+  --
+  --   >>> let (Right r) = parse domain "" "new.www.example.com"
+  --   >>> pretty_print $ backwards r
+  --   com.example.www.new
+  --
+  backwards DomainRoot = DomainRoot
+  backwards (DomainName s) = DomainName $ backwards s
diff --git a/harbl/src/Network/DNS/RBL/Host.hs b/harbl/src/Network/DNS/RBL/Host.hs
index 93deeb8..8d9fab9 100644
--- a/harbl/src/Network/DNS/RBL/Host.hs
+++ b/harbl/src/Network/DNS/RBL/Host.hs
@@ -1,19 +1,19 @@
-module Network.DNS.RBL.Host
+module Network.DNS.RBL.Host (
+  Host(..),
+  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.Domain (
+  Domain(..),
+  domain )
 import Network.DNS.RBL.Pretty ( Pretty(..) )
+import Network.DNS.RBL.Reversible ( Reversible(..) )
 
 
 -- | This type helps clarify some murkiness in the DNS \"domain\" name
@@ -50,27 +50,27 @@ instance Pretty Host where
 --
 --   We can really parse the root now!
 --
---   >>> parseTest user_domain "."
+--   >>> parseTest host "."
 --   HostAbsolute DomainRoot
 --
 --   But multiple dots aren't (only the first):
 --
---   >>> pretty_print $ parse user_domain "" ".."
+--   >>> pretty_print $ parse host "" ".."
 --   .
 --
 --   We can also optionally have a trailing dot at the end of a
 --   non-empty name:
 --
---   >>>  pretty_print $ parse user_domain "" "www.example.com"
+--   >>>  pretty_print $ parse host "" "www.example.com"
 --   www.example.com
 --
---   >>>  pretty_print $ parse user_domain "" "www.example.com."
+--   >>>  pretty_print $ parse host "" "www.example.com."
 --   www.example.com.
 --
 --   A \"relative root\" can also be parsed, letting the user's
 --   resolver deal with it:
 --
---   >>> parseTest user_domain ""
+--   >>> parseTest host ""
 --   HostRelative DomainRoot
 --
 host :: Parser Host
@@ -86,45 +86,23 @@ host = try absolute <|> relative
     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)
+instance Reversible Host where
+  -- | 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.
+  --
+  --   ==== _Examples_
+  --
+  --   >>> import Text.Parsec ( parse )
+  --
+  --   >>> let (Right r) = parse host "" "1.2.3.4"
+  --   >>> pretty_print $ backwards r
+  --   4.3.2.1
+  --
+  --   >>> let (Right r) = parse host "" "new.www.example.com"
+  --   >>> pretty_print $ backwards r
+  --   com.example.www.new
+  --
+  backwards (HostRelative d) = HostRelative $ backwards d
+  backwards (HostAbsolute d) = HostAbsolute $ backwards d
diff --git a/harbl/src/Network/DNS/RBL/Reversible.hs b/harbl/src/Network/DNS/RBL/Reversible.hs
new file mode 100644
index 0000000..cbd1529
--- /dev/null
+++ b/harbl/src/Network/DNS/RBL/Reversible.hs
@@ -0,0 +1,11 @@
+-- | The 'Reversible' typeclass.
+
+module Network.DNS.RBL.Reversible ( Reversible(..) )
+where
+
+-- | This class is pretty straightforward. It's for things that you
+-- can reverse, or flip around, or make backwards, or however you want
+-- to think of it. Our primary application is to hostname components.
+--
+class Reversible a where
+  backwards :: a -> a
diff --git a/harbl/src/Network/DNS/RBL/Tests.hs b/harbl/src/Network/DNS/RBL/Tests.hs
new file mode 100644
index 0000000..b9f0912
--- /dev/null
+++ b/harbl/src/Network/DNS/RBL/Tests.hs
@@ -0,0 +1,12 @@
+-- | This module exists solely to export tests to the test suite
+--   \"project\". We need these to be exported, but we also want it to
+--   be kinda clear that they're not for you to look at, which is why
+--   we don't just export them from "Network.DNS.RBL".
+--
+module Network.DNS.RBL.Tests (
+  ipv4pattern_tests,
+  site_tests )
+where
+
+import Network.DNS.RBL.IPv4Pattern ( ipv4pattern_tests )
+import Network.DNS.RBL.Site ( site_tests )
diff --git a/test/TestSuite.hs b/test/TestSuite.hs
index 67fc01a..5008785 100644
--- a/test/TestSuite.hs
+++ b/test/TestSuite.hs
@@ -1,6 +1,5 @@
 import Test.Tasty ( TestTree, defaultMain, testGroup )
-import Network.DNS.RBL.Site ( site_tests )
-import Network.DNS.RBL.IPv4Pattern ( ipv4pattern_tests )
+import Network.DNS.RBL.Tests ( ipv4pattern_tests, site_tests )
 
 tests :: TestTree
 tests = testGroup "All Tests" [ site_tests, ipv4pattern_tests ]
-- 
2.43.2