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.
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
:}
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.
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
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
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
import Data.List ( intercalate )
import Data.Maybe ( catMaybes )
import Network.DNS (
+ Domain,
DNSError,
Resolver,
defaultResolvConf,
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 )
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.
--
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
-- (octets).
--
module Network.DNS.RBL.Domain (
- Domain,
+ Domain(..),
domain )
where
import Text.Parsec.String ( Parser )
import Network.DNS.RBL.Pretty ( Pretty(..) )
+import Network.DNS.RBL.Reversible ( Reversible(..) )
-- * Digits
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>
+
-- * Domains
-- | An RFC1035 domain. According to RFC1035 a domain can be either a
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
-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
--
-- 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
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
--- /dev/null
+-- | 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
--- /dev/null
+-- | 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 )
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 ]
projects / dead / harbl.git / commitdiff