diff --git a/Network/DNS.hs b/Network/DNS.hs --- a/Network/DNS.hs +++ b/Network/DNS.hs @@ -1,29 +1,34 @@ -{-| - Thread-safe DNS library written in Haskell. - - This code is written in Haskell, not using FFI. - - Sample code for DNS lookup: - -@ - import qualified Network.DNS as DNS (lookup) - import Network.DNS hiding (lookup) - main :: IO () - main = do - rs <- makeResolvSeed defaultResolvConf - withResolver rs $ \\resolver -> do - DNS.lookup resolver \"www.example.com\" A >>= print -@ --} - +-- | A thread-safe DNS library for both clients and servers written +-- in pure Haskell. +-- The Network.DNS module re-exports all other exposed modules for +-- convenience. +-- Applications will most likely use the high-level interface, while +-- library/daemon authors may need to use the lower-level one. +-- module Network.DNS ( -- * High level module Network.DNS.Lookup + -- | The "Network.DNS.Lookup" module contains simple functions to + -- perform various DNS lookups. If you simply want to resolve a + -- hostname ('lookupA'), or find a domain's MX record + -- ('lookupMX'), this is the easiest way to do it. + , module Network.DNS.Resolver + -- | The "Network.DNS.Resolver" module is slightly more low-level + -- than "Network.DNS.Lookup". If you need to do something unusual, + -- you may need to use the 'lookup', 'lookupAuth', or 'lookupRaw' + -- functions. + , module Network.DNS.Types + -- | All of the types that the other modules use. + -- * Low level , module Network.DNS.Decode + -- | Decoding a response. + , module Network.DNS.Encode + -- | Encoding a query. + ) where import Network.DNS.Lookup @@ -31,5 +36,3 @@ import Network.DNS.Types import Network.DNS.Decode import Network.DNS.Encode - - diff --git a/Network/DNS/Decode.hs b/Network/DNS/Decode.hs --- a/Network/DNS/Decode.hs +++ b/Network/DNS/Decode.hs @@ -21,16 +21,15 @@ ---------------------------------------------------------------- -{-| Receiving DNS data from 'Socket' and parse it. - The second argument is a buffer size for the socket. --} +-- | Receiving DNS data from 'Socket' and parse it. + receive :: Socket -> IO DNSFormat receive sock = receiveDNSFormat $ sourceSocket sock ---------------------------------------------------------------- -{-| Parsing DNS data. --} +-- | Parsing DNS data. + decode :: BL.ByteString -> Either String DNSFormat decode bs = fst <$> runSGet decodeResponse bs diff --git a/Network/DNS/Encode.hs b/Network/DNS/Encode.hs --- a/Network/DNS/Encode.hs +++ b/Network/DNS/Encode.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} + module Network.DNS.Encode ( encode , composeQuery @@ -20,8 +21,8 @@ ---------------------------------------------------------------- -{-| Composing query. First argument is a number to identify response. --} +-- | Composing query. First argument is a number to identify response. + composeQuery :: Int -> [Question] -> BL.ByteString composeQuery idt qs = encode qry where @@ -36,8 +37,8 @@ ---------------------------------------------------------------- -{-| Composing DNS data. --} +-- | Composing DNS data. + encode :: DNSFormat -> BL.ByteString encode fmt = runSPut (encodeDNSFormat fmt) diff --git a/Network/DNS/Internal.hs b/Network/DNS/Internal.hs --- a/Network/DNS/Internal.hs +++ b/Network/DNS/Internal.hs @@ -8,16 +8,12 @@ ---------------------------------------------------------------- -{-| - Type for domain. --} +-- | Type for domain. type Domain = ByteString ---------------------------------------------------------------- -{-| - Types for resource records. --} +-- | Types for resource records. data TYPE = A | AAAA | NS | TXT | MX | CNAME | SOA | PTR | SRV | UNKNOWN Int deriving (Eq, Show, Read) @@ -51,9 +47,19 @@ ---------------------------------------------------------------- -{-| - Raw data format for DNS Query and Response. --} +-- | An enumeration of all possible DNS errors that can occur. +data DNSError = + -- | The sequence number of the answer doesn't match our query. This + -- could indicate foul play. + SequenceNumberMismatch + -- | The request simply timed out. + | TimeoutExpired + -- | The answer has the correct sequence number, but returned an + -- unexpected RDATA format. + | UnexpectedRDATA + deriving (Eq, Show) + +-- | Raw data format for DNS Query and Response. data DNSFormat = DNSFormat { header :: DNSHeader , question :: [Question] @@ -62,9 +68,7 @@ , additional :: [ResourceRecord] } deriving (Eq, Show) -{-| - Raw data format for the header of DNS Query and Response. --} +-- | Raw data format for the header of DNS Query and Response. data DNSHeader = DNSHeader { identifier :: Int , flags :: DNSFlags @@ -74,9 +78,7 @@ , arCount :: Int } deriving (Eq, Show) -{-| - Raw data format for the flags of DNS Query and Response. --} +-- | Raw data format for the flags of DNS Query and Response. data DNSFlags = DNSFlags { qOrR :: QorR , opcode :: OPCODE @@ -97,25 +99,19 @@ ---------------------------------------------------------------- -{-| - Raw data format for DNS questions. --} +-- | Raw data format for DNS questions. data Question = Question { qname :: Domain , qtype :: TYPE } deriving (Eq, Show) -{-| - Making "Question". --} +-- | Making "Question". makeQuestion :: Domain -> TYPE -> Question makeQuestion = Question ---------------------------------------------------------------- -{-| - Raw data format for resource records. --} +-- | Raw data format for resource records. data ResourceRecord = ResourceRecord { rrname :: Domain , rrtype :: TYPE @@ -124,9 +120,7 @@ , rdata :: RDATA } deriving (Eq, Show) -{-| - Raw data format for each type. --} +-- | Raw data format for each type. data RDATA = RD_NS Domain | RD_CNAME Domain | RD_MX Int Domain | RD_PTR Domain | RD_SOA Domain Domain Int Int Int Int Int | RD_A IPv4 | RD_AAAA IPv6 | RD_TXT ByteString diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs --- a/Network/DNS/Lookup.hs +++ b/Network/DNS/Lookup.hs @@ -1,123 +1,411 @@ -{-| - Upper level DNS lookup functions. --} - +-- | Simple, high-level DNS lookup functions. +-- +-- All of the lookup functions necessary run in IO, since they +-- interact with the network. The return types are similar, but +-- differ in what can be returned from a successful lookup. +-- +-- We can think of the return type as \"either what I asked for, or +-- an error\". For example, the 'lookupA' function, if successful, +-- will return a list of 'IPv4'. The 'lookupMX' function will +-- instead return a list of @('Domain',Int)@ pairs, where each pair +-- represents a hostname and its associated priority. +-- +-- The order of multiple results may not be consistent between +-- lookups. If you require consistent results, apply +-- 'Data.List.sort' to the returned list. +-- +-- The errors that can occur are the same for all lookups. Namely: +-- +-- * Timeout +-- +-- * Wrong sequence number (foul play?) +-- +-- * Unexpected data in the response +-- +-- If an error occurs, you should be able to pattern match on the +-- 'DNSError' constructor to determine which of these is the case. +-- +-- /Note/: A result of \"no records\" is not considered an +-- error. If you perform, say, an \'AAAA\' lookup for a domain with +-- no such records, the \"success\" result would be @Right []@. +-- +-- We perform a successful lookup of \"www.example.com\": +-- +-- >>> let hostname = Data.ByteString.Char8.pack "www.example.com" +-- >>> +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupA resolver hostname +-- Right [93.184.216.119] +-- +-- The only error that we can easily cause is a timeout. We do this +-- by creating and utilizing a 'ResolvConf' which has a timeout of +-- one millisecond: +-- +-- >>> let hostname = Data.ByteString.Char8.pack "www.example.com" +-- >>> let badrc = defaultResolvConf { resolvTimeout = 1 } +-- >>> +-- >>> rs <- makeResolvSeed badrc +-- >>> withResolver rs $ \resolver -> lookupA resolver hostname +-- Left TimeoutExpired +-- +-- As is the convention, successful results will always be wrapped +-- in a 'Right', while errors will be wrapped in a 'Left'. +-- +-- For convenience, you may wish to enable GHC's OverloadedStrings +-- extension. This will allow you to avoid calling +-- 'Data.ByteString.Char8.pack' on each domain name. See +-- +-- for more information. +-- module Network.DNS.Lookup ( lookupA, lookupAAAA , lookupMX, lookupAviaMX, lookupAAAAviaMX , lookupNS + , lookupNSAuth , lookupTXT , lookupPTR + , lookupRDNS , lookupSRV ) where -import Control.Applicative import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS (append, intercalate, pack, split) import Data.IP -import Data.Maybe import Network.DNS.Resolver as DNS import Network.DNS.Types ---------------------------------------------------------------- -{-| - Resolving 'IPv4' by 'A'. --} -lookupA :: Resolver -> Domain -> IO (Maybe [IPv4]) -lookupA rlv dom = toV4 <$> DNS.lookup rlv dom A +-- | Look up all \'A\' records for the given hostname. +-- +-- A straightforward example: +-- +-- >>> let hostname = Data.ByteString.Char8.pack "www.mew.org" +-- >>> +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupA resolver hostname +-- Right [202.232.15.101] +-- +-- This function will also follow a CNAME and resolve its target if +-- one exists for the queries hostname: +-- +-- >>> let hostname = Data.ByteString.Char8.pack "www.kame.net" +-- >>> +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupA resolver hostname +-- Right [203.178.141.194] +-- +lookupA :: Resolver -> Domain -> IO (Either DNSError [IPv4]) +lookupA rlv dom = do + erds <- DNS.lookup rlv dom A + case erds of + -- See lookupXviaMX for an explanation of this construct. + Left err -> return (Left err) + Right rds -> return $ mapM unTag rds where - toV4 = fmap (map unTag) - unTag (RD_A x) = x - unTag _ = error "lookupA" + unTag :: RDATA -> Either DNSError IPv4 + unTag (RD_A x) = Right x + unTag _ = Left UnexpectedRDATA -{-| - Resolving 'IPv6' by 'AAAA'. --} -lookupAAAA :: Resolver -> Domain -> IO (Maybe [IPv6]) -lookupAAAA rlv dom = toV6 <$> DNS.lookup rlv dom AAAA + +-- | Look up all (IPv6) \'AAAA\' records for the given hostname. +-- +-- Examples: +-- +-- >>> let hostname = Data.ByteString.Char8.pack "www.mew.org" +-- >>> +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupAAAA resolver hostname +-- Right [2001:240:11e:c00:00:00:00:101] +-- +lookupAAAA :: Resolver -> Domain -> IO (Either DNSError [IPv6]) +lookupAAAA rlv dom = do + erds <- DNS.lookup rlv dom AAAA + case erds of + -- See lookupXviaMX for an explanation of this construct. + Left err -> return (Left err) + Right rds -> return $ mapM unTag rds where - toV6 = fmap (map unTag) - unTag (RD_AAAA x) = x - unTag _ = error "lookupAAAA" + unTag :: RDATA -> Either DNSError IPv6 + unTag (RD_AAAA x) = Right x + unTag _ = Left UnexpectedRDATA ---------------------------------------------------------------- -{-| - Resolving 'Domain' and its preference by 'MX'. --} -lookupMX :: Resolver -> Domain -> IO (Maybe [(Domain,Int)]) -lookupMX rlv dom = toMX <$> DNS.lookup rlv dom MX +-- | Look up all \'MX\' records for the given hostname. Two parts +-- constitute an MX record: a hostname , and an integer priority. We +-- therefore return each record as a @('Domain', Int)@. +-- +-- In this first example, we look up the MX for the domain +-- \"example.com\". It has no MX (to prevent a deluge of spam from +-- examples posted on the internet). But remember, \"no results\" is +-- still a successful result. +-- +-- >>> let hostname = Data.ByteString.Char8.pack "example.com" +-- >>> +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupMX resolver hostname +-- Right [] +-- +-- The domain \"mew.org\" does however have a single MX: +-- +-- >>> let hostname = Data.ByteString.Char8.pack "mew.org" +-- >>> +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupMX resolver hostname +-- Right [("mail.mew.org.",10)] +-- +-- Also note that all hostnames are returned with a trailing dot to +-- indicate the DNS root. +-- +lookupMX :: Resolver -> Domain -> IO (Either DNSError [(Domain,Int)]) +lookupMX rlv dom = do + erds <- DNS.lookup rlv dom MX + case erds of + -- See lookupXviaMX for an explanation of this construct. + Left err -> return (Left err) + Right rds -> return $ mapM unTag rds where - toMX = fmap (map unTag) - unTag (RD_MX pr dm) = (dm,pr) - unTag _ = error "lookupMX" + unTag :: RDATA -> Either DNSError (Domain,Int) + unTag (RD_MX pr dm) = Right (dm,pr) + unTag _ = Left UnexpectedRDATA -{-| - Resolving 'IPv4' by 'A' via 'MX'. --} -lookupAviaMX :: Resolver -> Domain -> IO (Maybe [IPv4]) +-- | Look up all \'MX\' records for the given hostname, and then +-- resolve their hostnames to IPv4 addresses by calling +-- 'lookupA'. The priorities are not retained. +-- +-- Examples: +-- +-- >>> import Data.List (sort) +-- >>> let hostname = Data.ByteString.Char8.pack "mixi.jp" +-- >>> +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> ips <- withResolver rs $ \resolver -> lookupAviaMX resolver hostname +-- >>> fmap sort ips +-- Right [202.32.29.4,202.32.29.5] +-- +-- Since there is more than one result, it is necessary to sort the +-- list in order to check for equality. +-- +lookupAviaMX :: Resolver -> Domain -> IO (Either DNSError [IPv4]) lookupAviaMX rlv dom = lookupXviaMX rlv dom (lookupA rlv) -{-| - Resolving 'IPv6' by 'AAAA' via 'MX'. --} -lookupAAAAviaMX :: Resolver -> Domain -> IO (Maybe [IPv6]) +-- | Look up all \'MX\' records for the given hostname, and then +-- resolve their hostnames to IPv6 addresses by calling +-- 'lookupAAAA'. The priorities are not retained. +-- +lookupAAAAviaMX :: Resolver -> Domain -> IO (Either DNSError [IPv6]) lookupAAAAviaMX rlv dom = lookupXviaMX rlv dom (lookupAAAA rlv) -lookupXviaMX :: Show a => Resolver -> Domain -> (Domain -> IO (Maybe [a])) -> IO (Maybe [a]) +lookupXviaMX :: Show a + => Resolver + -> Domain + -> (Domain -> IO (Either DNSError [a])) + -> IO (Either DNSError [a]) lookupXviaMX rlv dom func = do - mdps <- lookupMX rlv dom - maybe (return Nothing) lookup' mdps - where - lookup' dps = check . catMaybes <$> mapM (func . fst) dps - check as = case as of - [] -> Nothing - ass -> Just (concat ass) + edps <- lookupMX rlv dom + case edps of + -- We have to deconstruct and reconstruct the error so that the + -- typechecker does not conclude that a ~ (Domain, Int). + Left err -> return (Left err) + Right dps -> do + -- We'll get back a [Either DNSError a] here. + responses <- mapM (func . fst) dps + -- We can use 'sequence' to join all of the Eithers + -- together. If any of them are (Left _), we'll get a Left + -- overall. Otherwise, we'll get Right [a]. + let overall = sequence responses + -- Finally, we use (fmap concat) to concatenate the responses + -- if there were no errors. + return $ fmap concat overall + + ---------------------------------------------------------------- -{-| - Resolving 'Domain' by 'NS'. --} -lookupNS :: Resolver -> Domain -> IO (Maybe [Domain]) -lookupNS rlv dom = toNS <$> DNS.lookup rlv dom NS +-- | This function performs the real work for both 'lookupNS' and +-- 'lookupNSAuth'. The only difference between those two is which +-- function, 'lookup' or 'lookupAuth', is used to perform the +-- lookup. We take either of those as our first parameter. +lookupNSImpl :: (Resolver -> Domain -> TYPE -> IO (Either DNSError [RDATA])) + -> Resolver + -> Domain + -> IO (Either DNSError [Domain]) +lookupNSImpl lookup_function rlv dom = do + erds <- lookup_function rlv dom NS + case erds of + -- See lookupXviaMX for an explanation of this construct. + Left err -> return (Left err) + Right rds -> return $ mapM unTag rds where - toNS = fmap (map unTag) - unTag (RD_NS dm) = dm - unTag _ = error "lookupNS" + unTag :: RDATA -> Either DNSError Domain + unTag (RD_NS dm) = Right dm + unTag _ = Left UnexpectedRDATA +-- | Look up all \'NS\' records for the given hostname. The results +-- are taken from the ANSWER section of the response (as opposed to +-- AUTHORITY). For details, see e.g. +-- . +-- +-- There will typically be more than one name server for a +-- domain. It is therefore extra important to sort the results if +-- you prefer them to be at all deterministic. +-- +-- Examples: +-- +-- >>> import Data.List (sort) +-- >>> let hostname = Data.ByteString.Char8.pack "mew.org" +-- >>> +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> ns <- withResolver rs $ \resolver -> lookupNS resolver hostname +-- >>> fmap sort ns +-- Right ["ns1.mew.org.","ns2.mew.org."] +-- +lookupNS :: Resolver -> Domain -> IO (Either DNSError [Domain]) +lookupNS = lookupNSImpl DNS.lookup + +-- | Look up all \'NS\' records for the given hostname. The results +-- are taken from the AUTHORITY section of the response and not the +-- usual ANSWER (use 'lookupNS' for that). For details, see e.g. +-- . +-- +-- There will typically be more than one name server for a +-- domain. It is therefore extra important to sort the results if +-- you prefer them to be at all deterministic. +-- +-- For an example, we can look up the nameservers for +-- \"example.com\" from one of the root servers, a.gtld-servers.net, +-- the IP address of which was found beforehand: +-- +-- >>> import Data.List (sort) +-- >>> let hostname = Data.ByteString.Char8.pack "example.com" +-- >>> +-- >>> let ri = RCHostName "192.5.6.30" -- a.gtld-servers.net +-- >>> let rc = defaultResolvConf { resolvInfo = ri } +-- >>> rs <- makeResolvSeed rc +-- >>> ns <- withResolver rs $ \resolver -> lookupNSAuth resolver hostname +-- >>> fmap sort ns +-- Right ["a.iana-servers.net.","b.iana-servers.net."] +-- +lookupNSAuth :: Resolver -> Domain -> IO (Either DNSError [Domain]) +lookupNSAuth = lookupNSImpl DNS.lookupAuth + + ---------------------------------------------------------------- -{-| - Resolving 'String' by 'TXT'. --} -lookupTXT :: Resolver -> Domain -> IO (Maybe [ByteString]) -lookupTXT rlv dom = toTXT <$> DNS.lookup rlv dom TXT +-- | Look up all \'TXT\' records for the given hostname. The results +-- are free-form 'ByteString's. +-- +-- Two common uses for \'TXT\' records are +-- and +-- . As an +-- example, we find the SPF record for \"mew.org\": +-- +-- >>> let hostname = Data.ByteString.Char8.pack "mew.org" +-- >>> +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupTXT resolver hostname +-- Right ["v=spf1 +mx -all"] +-- +lookupTXT :: Resolver -> Domain -> IO (Either DNSError [ByteString]) +lookupTXT rlv dom = do + erds <- DNS.lookup rlv dom TXT + case erds of + -- See lookupXviaMX for an explanation of this construct. + Left err -> return (Left err) + Right rds -> return $ mapM unTag rds where - toTXT = fmap (map unTag) - unTag (RD_TXT x) = x - unTag _ = error "lookupTXT" + unTag :: RDATA -> Either DNSError ByteString + unTag (RD_TXT x) = Right x + unTag _ = Left UnexpectedRDATA ---------------------------------------------------------------- -{-| - Resolving 'Domain' and its preference by 'PTR'. --} -lookupPTR :: Resolver -> Domain -> IO (Maybe [Domain]) -lookupPTR rlv dom = toPTR <$> DNS.lookup rlv dom PTR +-- | Look up all \'PTR\' records for the given hostname. To perform a +-- reverse lookup on an IP address, you must first reverse its +-- octets and then append the suffix \".in-addr.arpa.\" +-- +-- We look up the PTR associated with the IP address +-- 210.130.137.80, i.e., 80.137.130.210.in-addr.arpa: +-- +-- >>> let hostname = Data.ByteString.Char8.pack "80.137.130.210.in-addr.arpa" +-- >>> +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupPTR resolver hostname +-- Right ["www-v4.iij.ad.jp."] +-- +-- The 'lookupRDNS' function is more suited to this particular task. +-- +lookupPTR :: Resolver -> Domain -> IO (Either DNSError [Domain]) +lookupPTR rlv dom = do + erds <- DNS.lookup rlv dom PTR + case erds of + -- See lookupXviaMX for an explanation of this construct. + Left err -> return (Left err) + Right rds -> return $ mapM unTag rds where - toPTR = fmap (map unTag) - unTag (RD_PTR dm) = dm - unTag _ = error "lookupPTR" + unTag :: RDATA -> Either DNSError Domain + unTag (RD_PTR dm) = Right dm + unTag _ = Left UnexpectedRDATA + +-- | Convenient wrapper around 'lookupPTR' to perform a reverse lookup +-- on a single IP address. +-- +-- We repeat the example from 'lookupPTR', except now we pass the IP +-- address directly: +-- +-- >>> let hostname = Data.ByteString.Char8.pack "210.130.137.80" +-- >>> +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupRDNS resolver hostname +-- Right ["www-v4.iij.ad.jp."] +-- +lookupRDNS :: Resolver -> Domain -> IO (Either DNSError [Domain]) +lookupRDNS rlv ip = lookupPTR rlv dom + where + -- ByteString constants. + dot = BS.pack "." + suffix = BS.pack ".in-addr.arpa" + + octets = BS.split '.' ip + reverse_ip = BS.intercalate dot (reverse octets) + dom = reverse_ip `BS.append` suffix + ---------------------------------------------------------------- -{-| - Resolving 'Domain' and its preference by 'SRV'. --} -lookupSRV :: Resolver -> Domain -> IO (Maybe [(Int,Int,Int,Domain)]) -lookupSRV rlv dom = toSRV <$> DNS.lookup rlv dom SRV +-- | Look up all \'SRV\' records for the given hostname. A SRV record +-- comprises four fields, +-- +-- * Priority (lower is more-preferred) +-- +-- * Weight (relative frequency with which to use this record +-- amongst all results with the same priority) +-- +-- * Port (the port on which the service is offered) +-- +-- * Target (the hostname on which the service is offered) +-- +-- The first three are integral, and the target is another DNS +-- hostname. We therefore return a four-tuple +-- @(Int,Int,Int,'Domain')@. +-- +-- Examples: +-- +-- >>> let hostname = Data.ByteString.Char8.pack "_sip._tcp.cisco.com" +-- >>> +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupSRV resolver hostname +-- Right [(1,0,5060,"vcsgw.cisco.com.")] +-- +lookupSRV :: Resolver -> Domain -> IO (Either DNSError [(Int,Int,Int,Domain)]) +lookupSRV rlv dom = do + erds <- DNS.lookup rlv dom SRV + case erds of + -- See lookupXviaMX for an explanation of this construct. + Left err -> return (Left err) + Right rds -> return $ mapM unTag rds where - toSRV = fmap (map unTag) - unTag (RD_SRV pri wei prt dm) = (pri,wei,prt,dm) - unTag _ = error "lookupSRV" + unTag :: RDATA -> Either DNSError (Int,Int,Int,Domain) + unTag (RD_SRV pri wei prt dm) = Right (pri,wei,prt,dm) + unTag _ = Left UnexpectedRDATA diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs --- a/Network/DNS/Resolver.hs +++ b/Network/DNS/Resolver.hs @@ -1,20 +1,6 @@ {-# LANGUAGE CPP #-} -{-| - DNS Resolver and lookup functions. - Sample code: - -@ - import qualified Network.DNS as DNS (lookup) - import Network.DNS hiding (lookup) - main :: IO () - main = do - rs <- makeResolvSeed defaultResolvConf - withResolver rs $ \\resolver -> do - DNS.lookup resolver \"www.example.com\" A >>= print -@ --} - +-- | DNS Resolver and generic (lower-level) lookup functions. module Network.DNS.Resolver ( -- * Documentation -- ** Configuration for resolver @@ -24,7 +10,7 @@ -- ** Type and function for resolver , Resolver(..), withResolver -- ** Looking up functions - , lookup, lookupRaw + , lookup, lookupAuth, lookupRaw ) where import Control.Applicative @@ -49,15 +35,21 @@ #endif ---------------------------------------------------------------- -{-| - Union type for 'FilePath' and 'HostName'. Specify 'FilePath' to - \"resolv.conf\" or numeric IP address in 'String' form. --} + +-- | Union type for 'FilePath' and 'HostName'. Specify 'FilePath' to +-- \"resolv.conf\" or numeric IP address in 'String' form. +-- +-- /Warning/: Only numeric IP addresses are valid @RCHostName@s. +-- +-- Example (using Google's public DNS cache): +-- +-- >>> let cache = RCHostName "8.8.8.8" +-- data FileOrNumericHost = RCFilePath FilePath | RCHostName HostName -{-| - Type for resolver configuration --} + +-- | Type for resolver configuration. The easiest way to construct a +-- @ResolvConf@ object is to modify the 'defaultResolvConf'. data ResolvConf = ResolvConf { resolvInfo :: FileOrNumericHost , resolvTimeout :: Int @@ -65,12 +57,20 @@ , resolvBufsize :: Integer } -{-| - Default 'ResolvConf'. - 'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\". - 'resolvTimeout' is 3,000,000 micro seconds. - 'resolvBufsize' is 512. (obsoleted) --} + +-- | Return a default 'ResolvConf': +-- +-- * 'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\". +-- +-- * 'resolvTimeout' is 3,000,000 micro seconds. +-- +-- * 'resolvBufsize' is 512. (obsoleted) +-- +-- Example (use Google's public DNS cache instead of resolv.conf): +-- +-- >>> let cache = RCHostName "8.8.8.8" +-- >>> let rc = defaultResolvConf { resolvInfo = cache } +-- defaultResolvConf :: ResolvConf defaultResolvConf = ResolvConf { resolvInfo = RCFilePath "/etc/resolv.conf" @@ -80,18 +80,14 @@ ---------------------------------------------------------------- -{-| - Abstract data type of DNS Resolver seed --} +-- | Abstract data type of DNS Resolver seed data ResolvSeed = ResolvSeed { addrInfo :: AddrInfo , rsTimeout :: Int , rsBufsize :: Integer } -{-| - Abstract data type of DNS Resolver --} +-- | Abstract data type of DNS Resolver data Resolver = Resolver { genId :: IO Int , dnsSock :: Socket @@ -101,9 +97,13 @@ ---------------------------------------------------------------- -{-| - Making 'ResolvSeed' from an IP address of a DNS cache server. --} + +-- | Make a 'ResolvSeed' from a 'ResolvConf'. +-- +-- Examples: +-- +-- >>> rs <- makeResolvSeed defaultResolvConf +-- makeResolvSeed :: ResolvConf -> IO ResolvSeed makeResolvSeed conf = ResolvSeed <$> addr <*> pure (resolvTimeout conf) @@ -129,11 +129,10 @@ ---------------------------------------------------------------- -{-| - Giving a thread-safe 'Resolver' to the function of the second - argument. 'withResolver' should be passed to 'forkIO'. --} +-- | Giving a thread-safe 'Resolver' to the function of the second +-- argument. 'withResolver' should be passed to 'forkIO'. For +-- examples, see "Network.DNS.Lookup". withResolver :: ResolvSeed -> (Resolver -> IO a) -> IO a withResolver seed func = do let ai = addrInfo seed @@ -152,29 +151,93 @@ ---------------------------------------------------------------- -{-| - Looking up resource records of a domain. --} -lookup :: Resolver -> Domain -> TYPE -> IO (Maybe [RDATA]) -lookup rlv dom typ = (>>= toRDATA) <$> lookupRaw rlv dom typ +-- | Looking up resource records of a domain. The first parameter is one of +-- the field accessors of the 'DNSFormat' type -- this allows you to +-- choose which section (answer, authority, or additional) you would like +-- to inspect for the result. + +lookupSection :: (DNSFormat -> [ResourceRecord]) + -> Resolver + -> Domain + -> TYPE + -> IO (Either DNSError [RDATA]) +lookupSection section rlv dom typ = (>>= toRDATA) <$> lookupRaw rlv dom typ where {- CNAME hack dom' = if "." `isSuffixOf` dom then dom else dom ++ "." correct r = rrname r == dom' && rrtype r == typ -} correct r = rrtype r == typ - listToMaybe [] = Nothing - listToMaybe xs = Just xs - toRDATA = listToMaybe . map rdata . filter correct . answer + toRDATA = Right . map rdata . filter correct . section -{-| - Looking up a domain and returning an entire DNS Response. --} -lookupRaw :: Resolver -> Domain -> TYPE -> IO (Maybe DNSFormat) +-- | Look up resource records for a domain, collecting the results +-- from the ANSWER section of the response. +-- +-- We repeat an example from "Network.DNS.Lookup": +-- +-- >>> let hostname = Data.ByteString.Char8.pack "www.example.com" +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookup resolver hostname A +-- Right [93.184.216.119] +-- +lookup :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RDATA]) +lookup = lookupSection answer + +-- | Look up resource records for a domain, collecting the results +-- from the AUTHORITY section of the response. +lookupAuth :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RDATA]) +lookupAuth = lookupSection authority + + +-- | Look up a name and return the entire DNS Response. Sample output +-- is included below, however it is /not/ tested -- the sequence +-- number is unpredictable (it has to be!). +-- +-- The example code: +-- +-- @ +-- let hostname = Data.ByteString.Char8.pack \"www.example.com\" +-- rs <- makeResolvSeed defaultResolvConf +-- withResolver rs $ \resolver -> lookupRaw resolver hostname A +-- @ +-- +-- And the (formatted) expected output: +-- +-- @ +-- Right (DNSFormat +-- { header = DNSHeader +-- { identifier = 1, +-- flags = DNSFlags +-- { qOrR = QR_Response, +-- opcode = OP_STD, +-- authAnswer = False, +-- trunCation = False, +-- recDesired = True, +-- recAvailable = True, +-- rcode = NoErr }, +-- qdCount = 1, +-- anCount = 1, +-- nsCount = 0, +-- arCount = 0}, +-- question = [Question { qname = \"www.example.com.\", +-- qtype = A}], +-- answer = [ResourceRecord {rrname = \"www.example.com.\", +-- rrtype = A, +-- rrttl = 800, +-- rdlen = 4, +-- rdata = 93.184.216.119}], +-- authority = [], +-- additional = []}) +-- @ +-- +lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSFormat) lookupRaw rlv dom typ = do seqno <- genId rlv sendAll sock (composeQuery seqno [q]) - (>>= check seqno) <$> timeout tm (receive sock) + response <- timeout tm (receive sock) + return $ case response of + Nothing -> Left TimeoutExpired + Just y -> check seqno y where sock = dnsSock rlv tm = dnsTimeout rlv @@ -182,9 +245,9 @@ check seqno res = do let hdr = header res if identifier hdr == seqno then - Just res + Right res else - Nothing + Left SequenceNumberMismatch #if mingw32_HOST_OS == 1 -- Windows does not support sendAll in Network.ByteString.Lazy. diff --git a/Network/DNS/Types.hs b/Network/DNS/Types.hs --- a/Network/DNS/Types.hs +++ b/Network/DNS/Types.hs @@ -1,12 +1,13 @@ -{-| - Data types for DNS Query and Response. For more information, see . --} +-- | Data types for DNS Query and Response. +-- For more information, see . module Network.DNS.Types ( -- * Domain Domain -- * TYPE , TYPE (..), intToType, typeToInt, toType + -- * DNS Error + , DNSError (..) -- * DNS Format , DNSFormat (..) -- * DNS Header diff --git a/dns.cabal b/dns.cabal --- a/dns.cabal +++ b/dns.cabal @@ -1,11 +1,13 @@ Name: dns -Version: 0.3.8 +Version: 1.0.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: DNS library in Haskell -Description: DNS library for clients and servers. +Description: + A thread-safe DNS library for both clients and servers written + in pure Haskell. Category: Network Cabal-Version: >= 1.10 Build-Type: Simple @@ -85,6 +87,15 @@ , network >= 2.3 , network-conduit , random + +Test-Suite doctest + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Hs-Source-Dirs: test2 + Ghc-Options: -Wall + Main-Is: doctests.hs + Build-Depends: base + , doctest Source-Repository head Type: git diff --git a/test2/LookupSpec.hs b/test2/LookupSpec.hs --- a/test2/LookupSpec.hs +++ b/test2/LookupSpec.hs @@ -2,66 +2,17 @@ module LookupSpec where -import Control.Applicative -import qualified Data.ByteString.Char8 as BS -import Data.List import Network.DNS as DNS import Test.Hspec spec :: Spec spec = do - describe "lookupA" $ do - it "gets IPv4 addresses" $ do - rs <- makeResolvSeed defaultResolvConf - withResolver rs $ \resolver -> - DNS.lookupA resolver "www.mew.org" `shouldReturn` Just ["202.232.15.101"] - it "gets IPv4 addresses via CNAME" $ do - rs <- makeResolvSeed defaultResolvConf - withResolver rs $ \resolver -> - DNS.lookupA resolver "www.kame.net" `shouldReturn` Just ["203.178.141.194"] - describe "lookupAAAA" $ do it "gets IPv6 addresses" $ do rs <- makeResolvSeed defaultResolvConf withResolver rs $ \resolver -> do - DNS.lookupAAAA resolver "mew.org" `shouldReturn` Nothing - DNS.lookupAAAA resolver "www.mew.org" `shouldReturn` Just ["2001:240:11e:c00::101"] - - describe "lookupNS" $ do - it "gets NS" $ do - rs <- makeResolvSeed defaultResolvConf - withResolver rs $ \resolver -> do - actual <- DNS.lookupNS resolver "mew.org" - let expected = Just ["ns1.mew.org.", "ns2.mew.org."] - -- The order of NS records is variable, so we sort the - -- result. - sort <$> actual `shouldBe` expected - - describe "lookupTXT" $ do - it "gets TXT" $ do - rs <- makeResolvSeed defaultResolvConf - withResolver rs $ \resolver -> - DNS.lookupTXT resolver "mew.org" `shouldReturn` Just ["v=spf1 +mx -all"] - - describe "lookupAviaMX" $ do - it "gets IPv4 addresses via MX" $ do - rs <- makeResolvSeed defaultResolvConf - withResolver rs $ \resolver -> do - as <- DNS.lookupAviaMX resolver "mixi.jp" - sort <$> as `shouldBe` Just ["202.32.29.4", "202.32.29.5"] - - describe "lookupPTR" $ do - it "gets PTR" $ do - rs <- makeResolvSeed defaultResolvConf - withResolver rs $ \resolver -> do - let target = "210.130.137.80" - rev = BS.intercalate "." (reverse (BS.split '.' target)) - `BS.append` ".in-addr.arpa" - DNS.lookupPTR resolver rev `shouldReturn` Just ["www-v4.iij.ad.jp."] + DNS.lookupAAAA resolver "mew.org" + `shouldReturn` + Right [] - describe "lookupSRV" $ do - it "gets SRV" $ do - rs <- makeResolvSeed defaultResolvConf - withResolver rs $ \resolver -> - DNS.lookupSRV resolver "_sip._tcp.cisco.com" `shouldReturn` Just [(1,0,5060,"vcsgw.cisco.com.")] diff --git a/test2/doctests.hs b/test2/doctests.hs new file mode 100644 --- /dev/null +++ b/test2/doctests.hs @@ -0,0 +1,9 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest [ + "-XOverloadedStrings" + , "Network/DNS.hs" + ]