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.

diff --git a/.ghci b/.ghci
index dae4f7ccbb4fe317e83fb6feeaed554331eaa9b0..6632251993fb242de4bb4a69271da88e3d4be062 100644 (file)
--- 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/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
 :}
 
   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.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.
 import Network.DNS.RBL.Site
 
 -- And import the stuff from Parsec we need for debugging.

diff --git a/harbl.cabal b/harbl.cabal
index 8f4401fd7e0c823baba01f34fd49ba472e2110fd..8a5191b172ccece97c856487f4460180994bfd99 100644 (file)
--- a/harbl.cabal
+++ b/harbl.cabal
@@ -25,16 +25,17 @@ library
 
   exposed-modules:
     Network.DNS.RBL
 
   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
 
   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
 
     Network.DNS.RBL.Site
 

-  hs-source-dirs:
-    harbl/src/
+  hs-source-dirs: harbl/src

 
   ghc-options:
     -Wall
 
   ghc-options:
     -Wall


@@ -65,11 +66,9 @@ executable harbl
     harbl,
     parsec                      >= 3
 
     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
 
   ghc-options:
     -Wall


@@ -92,14 +91,11 @@ executable harbl
 
 test-suite testsuite
   type: exitcode-stdio-1.0
 
 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,
   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
 
     tasty                       >= 0.8,
     tasty-hunit                 >= 0.8
 

diff --git a/harbl/src/Network/DNS/RBL.hs b/harbl/src/Network/DNS/RBL.hs
index c3268fd894ac8c1f3f151393f0739a63eb012adf..c16690154ef708815481cd0e306ebbf237ae4a3b 100644 (file)
--- 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 (
 import Data.List ( intercalate )
 import Data.Maybe ( catMaybes )
 import Network.DNS (

+  Domain,

   DNSError,
   Resolver,
   defaultResolvConf,
   DNSError,
   Resolver,
   defaultResolvConf,


@@ -21,9 +22,10 @@ import Network.DNS (
   makeResolvSeed,
   withResolver )
 
   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.IPv4Pattern ( addresses )
 import Network.DNS.RBL.Pretty ( Pretty(..) )

+import Network.DNS.RBL.Reversible ( Reversible(..) )

 import Network.DNS.RBL.Site ( Site(..), sites )
 
 
 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)
 
 
     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.
 --
 -- | 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)
 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
 
 
 -- | 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 75170a7675bf09ab3c509d41b1ada58b16fbac05..4dd5d1d43fd0548c23e7c073b4e0e3ae41deba13 100644 (file)
--- 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 (
 --   (octets).
 --
 module Network.DNS.RBL.Domain (

-  Domain,
+  Domain(..),

   domain )
 where
 
   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 Text.Parsec.String ( Parser )
 
 import Network.DNS.RBL.Pretty ( Pretty(..) )

+import Network.DNS.RBL.Reversible ( Reversible(..) )

 
 -- * Digits
 
 
 -- * Digits
 


@@ -496,6 +497,68 @@ instance Pretty Subdomain where
   pretty_show (SubdomainMultipleLabel l s) =
     (pretty_show l) ++ "." ++ (pretty_show s)
 
   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>
 -- | 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
 -- * 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
 
     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 93deeb88f1f10fcf98cf0b4abfb4ced09905c12e..8d9fab99562ca9d43d40ee0391ba62dfa33ef7b7 100644 (file)
--- 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
 
 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 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.Pretty ( Pretty(..) )

+import Network.DNS.RBL.Reversible ( Reversible(..) )

 
 
 -- | This type helps clarify some murkiness in the DNS \"domain\" name
 
 
 -- | 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!
 --
 --
 --   We can really parse the root now!
 --

---   >>> parseTest user_domain "."
+--   >>> parseTest host "."

 --   HostAbsolute DomainRoot
 --
 --   But multiple dots aren't (only the first):
 --
 --   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:
 --
 --   .
 --
 --   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
 --
 --   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:
 --
 --   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
 --   HostRelative DomainRoot
 --
 host :: Parser Host


@@ -86,45 +86,23 @@ host = try absolute <|> relative
     relative = fmap HostRelative domain
 
 
     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 (file)
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 (file)
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 67fc01aafeefa306251ae96900b6042749ce2b53..5008785748db6f151b3d2545ec98f8f6d53de1e7 100644 (file)
--- a/test/TestSuite.hs
+++ b/test/TestSuite.hs
@@ -1,6 +1,5 @@
 import Test.Tasty ( TestTree, defaultMain, testGroup )
 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 ]
 
 tests :: TestTree
 tests = testGroup "All Tests" [ site_tests, ipv4pattern_tests ]