module DNS (
LookupResult,
+ dns_properties,
+ dns_tests,
lookupMX',
lookupNS',
- normalize
- )
+ normalize,
+ normalize_case,
+ resolve_address )
where
+import Control.Applicative ((<$>))
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,
+ DNSFormat(..),
Resolver,
+ RDATA(..),
+ TYPE(..),
+ defaultResolvConf,
+ lookupA,
lookupMX,
- lookupNS )
+ lookupNS,
+ lookupRaw,
+ makeResolvSeed,
+ rdata,
+ rrtype,
+ 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)
type LookupResult = (Domain, Maybe [Domain])
+-- | Perform a query, but take the result from the authority section
+-- of the response rather than the answer section. Code shamelessly
+-- stolen from Network.DNS.lookup.
+lookup_authority :: Resolver -> Domain -> TYPE -> IO (Maybe [RDATA])
+lookup_authority rlv dom typ = (>>= toRDATA) <$> lookupRaw rlv dom typ
+ where
+ correct r = rrtype r == typ
+ listToMaybe [] = Nothing
+ listToMaybe xs = Just xs
+ toRDATA = listToMaybe . map rdata . filter correct . authority
+
+-- | Like lookupNS, except we take the result from the authority
+-- section of the response (as opposed to the answer section).
+lookupNS_authority :: Resolver -> Domain -> IO (Maybe [Domain])
+lookupNS_authority rlv dom = toNS <$> DNS.lookup_authority rlv dom NS
+ where
+ toNS = fmap (map unTag)
+ 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
+ Just _ -> return read_result
+ Nothing -> do
+ default_rs <- makeResolvSeed defaultResolvConf
+ withResolver default_rs $ \resolver -> do
+ result <- lookupA resolver (BS.pack s)
+ return $ case result of
+ Just (x:_) -> Just x
+ _ -> Nothing
+ 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.",Nothing)
+--
lookupMX' :: Resolver -> Domain -> IO LookupResult
lookupMX' resolver domain =
liftM (pair_em . drop_priority) $ 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 =
- liftM pair_em $ lookupNS resolver domain
+lookupNS' resolver domain = do
+ answer_result <- lookupNS resolver domain
+ auth_result <- lookupNS_authority resolver domain
+ liftM pair_em $ return $ combine answer_result auth_result
where
pair_em :: a -> (Domain, a)
pair_em = (,) domain
--- | Normalize the given name by lowercasing and appending a trailing
--- dot (the root) if necessary.
+ combine :: (Maybe [Domain]) -> (Maybe [Domain]) -> (Maybe [Domain])
+ combine Nothing Nothing = Nothing
+ combine m1 Nothing = m1
+ combine Nothing m2 = m2
+ combine (Just ds1) (Just ds2) = Just (ds1 ++ ds2)
+
+-- | 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
+
+
+test_normalize_case :: Test
+test_normalize_case =
+ testCase desc $
+ assertEqual desc expected actual
+ where
+ desc = "normalize_case lowercases DNS names"
+ 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_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 ]
projects / haeredes.git / blobdiff