Add the Reversible class.

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

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 (
-  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