From 2104fcab31ed92c308ce6b05c03d10f9f8b4cf16 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Wed, 31 Jul 2013 17:54:48 -0400 Subject: [PATCH] Add a doctest suite. Add a quickcheck property for normalize_case. Add another test/property for normalize_root. --- haeredes.cabal | 34 +++++++++++++++++-- makefile | 7 +++- src/DNS.hs | 91 +++++++++++++++++++++++++++++++++++++++++++++++--- src/Main.hs | 12 ++++++- 4 files changed, 135 insertions(+), 9 deletions(-) diff --git a/haeredes.cabal b/haeredes.cabal index 1851e78..22743ca 100644 --- a/haeredes.cabal +++ b/haeredes.cabal @@ -78,8 +78,10 @@ executable haeredes parallel-io == 0.3.*, -- Test deps HUnit == 1.2.*, + QuickCheck == 2.*, test-framework == 0.8.*, - test-framework-hunit == 0.3.* + test-framework-hunit == 0.3.*, + test-framework-quickcheck2 == 0.3.* main-is: Main.hs @@ -122,8 +124,10 @@ test-suite testsuite parallel-io == 0.3.*, -- Test deps HUnit == 1.2.*, + QuickCheck == 2.*, test-framework == 0.8.*, - test-framework-hunit == 0.3.* + test-framework-hunit == 0.3.*, + test-framework-quickcheck2 == 0.3.* -- It's not entirely clear to me why I have to reproduce all of this. ghc-options: @@ -142,6 +146,32 @@ test-suite testsuite -optc-O3 -optc-march=native +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Doctests.hs + build-depends: + base == 4.*, + -- Additional test dependencies. + doctest == 0.9.*, + filemanip == 0.3.6.* + + -- It's not entirely clear to me why I have to reproduce all of this. + ghc-options: + -Wall + -fwarn-hi-shadowing + -fwarn-missing-signatures + -fwarn-name-shadowing + -fwarn-orphans + -fwarn-type-defaults + -fwarn-tabs + -fwarn-incomplete-record-updates + -fwarn-monomorphism-restriction + -fwarn-unused-do-bind + -rtsopts + -threaded + -optc-O3 + -optc-march=native source-repository head type: git diff --git a/makefile b/makefile index a590187..08b02ce 100644 --- a/makefile +++ b/makefile @@ -1,5 +1,6 @@ BIN = dist/build/haeredes/haeredes TESTSUITE_BIN = dist/build/testsuite/testsuite +DOCTESTS_BIN = dist/build/doctests/doctests .PHONY : dist doc test @@ -12,10 +13,14 @@ $(TESTSUITE_BIN): src/*.hs test/TestSuite.hs runghc Setup.hs configure --user --enable-tests runghc Setup.hs build +$(DOCTESTS_BIN): src/*.hs test/Doctests.hs + runghc Setup.hs configure --user --enable-tests + runghc Setup.hs build + clean: runghc Setup.hs clean -test: $(BIN) $(TESTSUITE_BIN) +test: $(BIN) $(TESTSUITE_BIN) $(DOCTESTS_BIN) runghc Setup.hs test doc: diff --git a/src/DNS.hs b/src/DNS.hs index cda8b96..61b96aa 100644 --- a/src/DNS.hs +++ b/src/DNS.hs @@ -1,5 +1,6 @@ module DNS ( LookupResult, + dns_properties, dns_tests, lookupMX', lookupNS', @@ -14,6 +15,7 @@ import qualified Data.ByteString.Char8 as BS ( append, last, map, + null, pack ) import Data.Char (toLower) import Data.IP (IPv4) @@ -34,6 +36,7 @@ import Network.DNS ( withResolver ) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (assertEqual) import Text.Read (readMaybe) @@ -59,6 +62,19 @@ lookupNS_authority rlv dom = toNS <$> DNS.lookup_authority rlv dom NS unTag (RD_NS dm) = dm unTag _ = error "lookupNS_authority" + +-- | Takes a String representing either a hostname or an IP +-- address. If a hostname was supplied, it is resolved to either an +-- IPv4 or Nothing. If an IP address is supplied, it is returned as an +-- IPv4. +-- +-- Examples: +-- +-- >>> resolve_address "example.com" +-- Just 93.184.216.119 +-- >>> resolve_address "93.184.216.119" +-- Just 93.184.216.119 +-- resolve_address :: String -> IO (Maybe IPv4) resolve_address s = case read_result of @@ -74,6 +90,20 @@ resolve_address s = read_result :: Maybe IPv4 read_result = readMaybe s + +-- | This calls lookupMX, and returns the result as the second +-- component of a tuple whose first component is the domain name +-- itself. +-- +-- Examples: +-- +-- The example domain, example.com, has no MX record. +-- +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> let domain = BS.pack "example.com." +-- >>> withResolver rs $ \resolver -> lookupMX' resolver domain +-- ("example.com.",Nothing) +-- lookupMX' :: Resolver -> Domain -> IO LookupResult lookupMX' resolver domain = liftM (pair_em . drop_priority) $ lookupMX resolver domain @@ -84,7 +114,24 @@ lookupMX' resolver domain = pair_em :: a -> (Domain, a) pair_em = (,) domain --- This function keeps the domain matches with its NS records. + +-- | This calls lookupNS, and returns the result as the second +-- component of a tuple whose first component is the domain name +-- itself. +-- +-- Examples: +-- +-- The example domain, example.com, does have NS records, but the +-- order in which they are returned is variable, so we have to sort +-- them to get a reliable result. +-- +-- >>> import Data.List (sort) +-- >>> let sort_snd (x,y) = (x, sort <$> y) +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> let domain = BS.pack "example.com." +-- >>> withResolver rs $ \resolver -> sort_snd <$> lookupNS' resolver domain +-- ("example.com.",Just ["a.iana-servers.net.","b.iana-servers.net."]) +-- lookupNS' :: Resolver -> Domain -> IO LookupResult lookupNS' resolver domain = do answer_result <- lookupNS resolver domain @@ -100,20 +147,22 @@ lookupNS' resolver domain = do combine Nothing m2 = m2 combine (Just ds1) (Just ds2) = Just (ds1 ++ ds2) --- | Normalize the given name by lowercasing and appending a trailing --- dot (the root) if necessary. +-- | Perform both normalize_case and normalize_root. normalize :: Domain -> Domain normalize = normalize_case . normalize_root - +-- | Normalize the given name by appending a trailing dot (the DNS +-- root) if necessary. normalize_root :: Domain -> Domain normalize_root d + | BS.null d = BS.pack "." | BS.last d == '.' = d | otherwise = d `BS.append` trailing_dot where trailing_dot = BS.pack "." +-- | Normalize the given name by lowercasing it. normalize_case :: Domain -> Domain normalize_case = BS.map toLower @@ -127,7 +176,39 @@ test_normalize_case = expected = BS.pack "example.com" actual = normalize_case $ BS.pack "ExAmPlE.COM" +prop_normalize_case_idempotent :: String -> Bool +prop_normalize_case_idempotent s = + (normalize_case . normalize_case) bs == normalize_case bs + where + bs = BS.pack s + +test_normalize_root_adds_dot :: Test +test_normalize_root_adds_dot = + testCase desc $ + assertEqual desc expected actual + where + desc = "normalize_root adds a trailing dot" + expected = BS.pack "example.com." + actual = normalize_root $ BS.pack "example.com" + +prop_normalize_root_idempotent :: String -> Bool +prop_normalize_root_idempotent s = + (normalize_root . normalize_root) bs == normalize_root bs + where + bs = BS.pack s + dns_tests :: Test dns_tests = testGroup "DNS Tests" [ - test_normalize_case ] + test_normalize_case, + test_normalize_root_adds_dot ] + +dns_properties :: Test +dns_properties = + testGroup "DNS Properties" [ + testProperty + "normalize_case is idempotent" + prop_normalize_case_idempotent, + testProperty + "normalize_root is idempotent" + prop_normalize_root_idempotent ] diff --git a/src/Main.hs b/src/Main.hs index 5c6f401..f322baa 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -32,7 +32,12 @@ import DNS ( resolve_address ) import ExitCodes (exit_bad_server) -report :: (Domain, Maybe [Domain]) -> IO () + +-- | Report results for this LookupResult. If there's a Nothing in the +-- second component, there were no query results, so we report that +-- the domain was not delegated. If there were some results and +-- there are leftovers (after "cleaning"), we report those as well. +report :: LookupResult -> IO () report (d, Nothing) = putStrLn $ "Domain " ++ (show d) ++ " not delegated." report (d, Just leftovers) = @@ -42,6 +47,11 @@ report (d, Just leftovers) = " delegates somewhere else: " ++ (join " " (map show leftovers)) + +-- | "Clean" a lookup result by subtracting out the list of delegates. +-- There shouldn't be anything left over. If there were no lookup +-- results, we leave the Nothing in place so that 'report' can +-- pattern match on it. clean :: [Domain] -- ^ List of delegates, @ds@ -> LookupResult -> LookupResult -- 2.44.2