module DNS ( LookupResult, dns_properties, dns_tests, lookupMX', lookupNS', normalize, normalize_case, resolve_address ) where import Control.Monad (liftM) import qualified Data.ByteString.Char8 as BS ( append, last, map, null, pack ) import Data.Char (toLower) import Data.IP (IPv4) import Network.DNS ( Domain, DNSError, Resolver, defaultResolvConf, lookupA, lookupMX, lookupNS, lookupNSAuth, makeResolvSeed, withResolver ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Test.Tasty.QuickCheck ( testProperty ) import Text.Read (readMaybe) type LookupResult = (Domain, Either DNSError [Domain]) -- | Takes a String representing either a hostname or an IP -- address. If a hostname was supplied, it is resolved to either an -- [IPv4] or an error. If an IP address is supplied, it is returned -- as a singleton [IPv4]. -- -- Examples: -- -- >>> resolve_address "example.com" -- Right [93.184.216.119] -- >>> resolve_address "93.184.216.119" -- Right [93.184.216.119] -- resolve_address :: String -> IO (Either DNSError [IPv4]) resolve_address s = case read_result of Just addr -> return $ Right [addr] Nothing -> do default_rs <- makeResolvSeed defaultResolvConf withResolver default_rs $ \resolver -> lookupA resolver (BS.pack s) where 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.",Right []) -- lookupMX' :: Resolver -> Domain -> IO LookupResult lookupMX' resolver domain = liftM (pair_em . drop_priority) $ lookupMX resolver domain where drop_priority :: Either DNSError [(Domain, Int)] -> Either DNSError [Domain] drop_priority = fmap (map fst) pair_em :: a -> (Domain, a) pair_em = (,) domain -- | 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) -- >>> import Control.Applicative ((<$>)) -- >>> -- >>> 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.",Right ["a.iana-servers.net.","b.iana-servers.net."]) -- lookupNS' :: Resolver -> Domain -> IO LookupResult lookupNS' resolver domain = do answer_result <- lookupNS resolver domain auth_result <- lookupNSAuth resolver domain liftM pair_em $ return $ combine answer_result auth_result where pair_em :: a -> (Domain, a) pair_em = (,) domain combine :: (Either DNSError [Domain]) -> (Either DNSError [Domain]) -> (Either DNSError [Domain]) combine e1 e2 = do l1 <- e1 l2 <- e2 return (l1 ++ l2) -- | 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 -- * Tests test_normalize_case :: TestTree test_normalize_case = testCase desc $ actual @?= expected where desc = "normalize_case lowercases DNS names" expected = BS.pack "example.com" actual = normalize_case $ BS.pack "ExAmPlE.COM" prop_normalize_case_idempotent :: TestTree prop_normalize_case_idempotent = testProperty desc $ prop where desc = "normalize_case is idempotent" prop :: String -> Bool prop s = (normalize_case . normalize_case) bs == normalize_case bs where bs = BS.pack s test_normalize_root_adds_dot :: TestTree test_normalize_root_adds_dot = testCase desc $ actual @?= expected where desc = "normalize_root adds a trailing dot" expected = BS.pack "example.com." actual = normalize_root $ BS.pack "example.com" prop_normalize_root_idempotent :: TestTree prop_normalize_root_idempotent = testProperty desc prop where desc = "normalize_root is idempotent" prop :: String -> Bool prop s = (normalize_root . normalize_root) bs == normalize_root bs where bs = BS.pack s dns_tests :: TestTree dns_tests = testGroup "DNS Tests" [ test_normalize_case, test_normalize_root_adds_dot ] dns_properties :: TestTree dns_properties = testGroup "DNS Properties" [ prop_normalize_case_idempotent, prop_normalize_root_idempotent ]