diff --git a/Changelog b/Changelog new file mode 100644 --- /dev/null +++ b/Changelog @@ -0,0 +1,8 @@ +2.0.0 + - DNSMessage is now monomorphic + - RDATA is now monomorphic + - Removed traversal instance for DNSMessage + - EDNS0 encoding/decoding is now supported + - Removed dnsMapWithType and dnsTraverseWithType functions + - responseA and responseAAAA now take lists of IP addresses as their arguments + - DNSHeader type no longer has qdCount, anCount, nsCount, and arCount fields diff --git a/Network/DNS/Decode.hs b/Network/DNS/Decode.hs --- a/Network/DNS/Decode.hs +++ b/Network/DNS/Decode.hs @@ -1,28 +1,30 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, CPP #-} module Network.DNS.Decode ( decode , receive - , receive' ) where -import Control.Applicative ((<$), (<$>), (<*), (<*>)) import Control.Monad (replicateM) import Control.Monad.Trans.Resource (ResourceT, runResourceT) import qualified Control.Exception as ControlException import Data.Bits ((.&.), shiftR, testBit) import Data.ByteString (ByteString) +import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BL import Data.Conduit (($$), Source) import Data.Conduit.Network (sourceSocket) -import Data.IP (toIPv4, toIPv6b) -import Data.Traversable (traverse) +import Data.IP (IP(..), toIPv4, toIPv6b) import Data.Typeable (Typeable) import Network (Socket) import Network.DNS.Internal import Network.DNS.StateBinary +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif + ---------------------------------------------------------------- @@ -34,50 +36,31 @@ -- | Receiving DNS data from 'Socket' and parse it. -receive :: Socket -> IO DNSFormat -receive sock = do - dns <- receiveDNSFormat $ sourceSocket sock - case traverse unpackBytes dns of - Left e -> ControlException.throwIO (RDATAParseError e) - Right d -> return d - --- | Receiving DNS data from 'Socket' and partially parse it. --- Unknown RDATA sections will be left as 'ByteString' -receive' :: Socket -> IO (DNSMessage (RD ByteString)) -receive' sock = receiveDNSFormat $ sourceSocket sock - +receive :: Socket -> IO DNSMessage +receive = receiveDNSFormat . sourceSocket ---------------------------------------------------------------- -- | Parsing DNS data. -decode :: BL.ByteString -> Either String DNSFormat +decode :: BL.ByteString -> Either String DNSMessage decode bs = fst <$> runSGet decodeResponse bs - >>= traverse unpackBytes -unpackBytes :: RD ByteString -> Either String (RD [Int]) -unpackBytes (RD_OTH dta) = RD_OTH . fst <$> unpack dta' - where - len = fromIntegral $ BS.length dta - dta' = BL.fromChunks [dta] - unpack = runSGet (getNBytes len) -unpackBytes rd = Right $ error "unhandled case in decode" <$> rd - ---------------------------------------------------------------- -receiveDNSFormat :: Source (ResourceT IO) ByteString -> IO (DNSMessage (RD ByteString)) +receiveDNSFormat :: Source (ResourceT IO) ByteString -> IO DNSMessage receiveDNSFormat src = fst <$> runResourceT (src $$ sink) where sink = sinkSGet decodeResponse ---------------------------------------------------------------- -decodeResponse :: SGet (DNSMessage (RD ByteString)) +decodeResponse :: SGet DNSMessage decodeResponse = do - hd <- decodeHeader - DNSFormat hd <$> decodeQueries (qdCount hd) - <*> decodeRRs (anCount hd) - <*> decodeRRs (nsCount hd) - <*> decodeRRs (arCount hd) + (hd,qdCount,anCount,nsCount,arCount) <- decodeHeader + DNSMessage hd <$> decodeQueries qdCount + <*> decodeRRs anCount + <*> decodeRRs nsCount + <*> decodeRRs arCount ---------------------------------------------------------------- @@ -101,13 +84,20 @@ ---------------------------------------------------------------- -decodeHeader :: SGet DNSHeader -decodeHeader = DNSHeader <$> decodeIdentifier - <*> decodeFlags - <*> decodeQdCount - <*> decodeAnCount - <*> decodeNsCount - <*> decodeArCount +decodeHeader :: SGet (DNSHeader,Int,Int,Int,Int) +decodeHeader = do + hd <- DNSHeader <$> decodeIdentifier + <*> decodeFlags + qdCount <- decodeQdCount + anCount <- decodeAnCount + nsCount <- decodeNsCount + arCount <- decodeArCount + pure (hd + ,qdCount + ,anCount + ,nsCount + ,arCount + ) where decodeIdentifier = getInt16 decodeQdCount = getInt16 @@ -123,30 +113,54 @@ decodeType :: SGet TYPE decodeType = intToType <$> getInt16 +decodeOptType :: SGet OPTTYPE +decodeOptType = intToOptType <$> getInt16 + decodeQuery :: SGet Question decodeQuery = Question <$> decodeDomain - <*> (decodeType <* ignoreClass) + <*> decodeType + <* ignoreClass -decodeRRs :: Int -> SGet [RR (RD ByteString)] +decodeRRs :: Int -> SGet [ResourceRecord] decodeRRs n = replicateM n decodeRR -decodeRR :: SGet (RR (RD ByteString)) +decodeRR :: SGet ResourceRecord decodeRR = do - Question dom typ <- decodeQuery - ttl <- decodeTTL - len <- decodeRLen - dat <- decodeRData typ len - return ResourceRecord { rrname = dom - , rrtype = typ - , rrttl = ttl - , rdlen = len - , rdata = dat - } + dom <- decodeDomain + typ <- decodeType + decodeRR' dom typ where + decodeRR' _ OPT = do + udps <- decodeUDPSize + _ <- decodeERCode + ver <- decodeOPTVer + dok <- decodeDNSOK + len <- decodeRLen + dat <- decodeRData OPT len + return OptRecord { orudpsize = udps + , ordnssecok = dok + , orversion = ver + , rdata = dat + } + + decodeRR' dom t = do + ignoreClass + ttl <- decodeTTL + len <- decodeRLen + dat <- decodeRData t len + return ResourceRecord { rrname = dom + , rrtype = t + , rrttl = ttl + , rdata = dat + } + decodeUDPSize = fromIntegral <$> getInt16 + decodeERCode = getInt8 + decodeOPTVer = fromIntegral <$> getInt8 + decodeDNSOK = flip testBit 15 <$> getInt16 decodeTTL = fromIntegral <$> get32 decodeRLen = getInt16 -decodeRData :: TYPE -> Int -> SGet (RD ByteString) +decodeRData :: TYPE -> Int -> SGet RData decodeRData NS _ = RD_NS <$> decodeDomain decodeRData MX _ = RD_MX <$> decodePreference <*> decodeDomain where @@ -180,31 +194,55 @@ decodePriority = getInt16 decodeWeight = getInt16 decodePort = getInt16 - +decodeRData OPT ol = RD_OPT <$> decode' ol + where + decode' :: Int -> SGet [OData] + decode' l + | l < 0 = fail "decodeOPTData: length inconsistency" + | l == 0 = pure [] + | otherwise = do + optCode <- decodeOptType + optLen <- getInt16 + dat <- decodeOData optCode optLen + (dat:) <$> decode' (l - optLen - 4) decodeRData _ len = RD_OTH <$> getNByteString len +decodeOData :: OPTTYPE -> Int -> SGet OData +decodeOData ClientSubnet len = do + fam <- getInt16 + srcMask <- getInt8 + scpMask <- getInt8 + rawip <- fmap fromIntegral . B.unpack <$> getNByteString (len - 4) -- 4 = 2 + 1 + 1 + ip <- case fam of + 1 -> pure . IPv4 . toIPv4 $ take 4 (rawip ++ repeat 0) + 2 -> pure . IPv6 . toIPv6b $ take 16 (rawip ++ repeat 0) + _ -> fail "Unsupported address family" + pure $ OD_ClientSubnet srcMask scpMask ip +decodeOData (OUNKNOWN i) len = OD_Unknown i <$> getNByteString len + ---------------------------------------------------------------- decodeDomain :: SGet Domain decodeDomain = do pos <- getPosition c <- getInt8 - if c == 0 then - return "" - else do - let n = getValue c - if isPointer c then do + let n = getValue c + -- Syntax hack to avoid using MultiWayIf + case () of + _ | c == 0 -> return "" + _ | isPointer c -> do d <- getInt8 let offset = n * 256 + d mo <- pop offset case mo of Nothing -> fail $ "decodeDomain: " ++ show offset - Just o -> do - -- A pointer may refer to another pointer. - -- So, register this position for the domain. - push pos o - return o - else do + -- A pointer may refer to another pointer. + -- So, register this position for the domain. + Just o -> push pos o >> return o + -- As for now, extended labels have no use. + -- This may change some time in the future. + _ | isExtLabel c -> return "" + _ | otherwise -> do hs <- getNByteString n ds <- decodeDomain let dom = hs `BS.append` "." `BS.append` ds @@ -213,6 +251,7 @@ where getValue c = c .&. 0x3f isPointer c = testBit c 7 && testBit c 6 + isExtLabel c = (not $ testBit c 7) && testBit c 6 ignoreClass :: SGet () ignoreClass = () <$ get16 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,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, CPP #-} module Network.DNS.Encode ( encode @@ -9,16 +9,18 @@ import Control.Monad (when) import Control.Monad.State (State, modify, execState, gets) import Data.Binary (Word16) -import Data.Bits ((.|.), bit, shiftL) +import Data.Bits ((.|.), bit, shiftL, setBit) import qualified Data.ByteString.Char8 as BS import Data.ByteString.Lazy.Char8 (ByteString) -import Data.IP (fromIPv4, fromIPv6b) -import Data.Monoid (Monoid, mappend, mconcat) +import Data.IP (IP(..),fromIPv4, fromIPv6b) +import Data.List (dropWhileEnd) +import Data.Monoid ((<>)) import Network.DNS.Internal import Network.DNS.StateBinary -(+++) :: Monoid a => a -> a -> a -(+++) = mappend +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid (mconcat) +#endif ---------------------------------------------------------------- @@ -31,7 +33,6 @@ qry = defaultQuery { header = hdr { identifier = idt - , qdCount = length qs } , question = qs } @@ -40,37 +41,35 @@ -- | Composing DNS data. -encode :: DNSFormat -> ByteString -encode fmt = runSPut (encodeDNSFormat fmt) +encode :: DNSMessage -> ByteString +encode msg = runSPut (encodeDNSMessage msg) ---------------------------------------------------------------- -encodeDNSFormat :: DNSFormat -> SPut -encodeDNSFormat fmt = encodeHeader hdr - +++ mconcat (map encodeQuestion qs) - +++ mconcat (map encodeRR an) - +++ mconcat (map encodeRR au) - +++ mconcat (map encodeRR ad) +encodeDNSMessage :: DNSMessage -> SPut +encodeDNSMessage msg = encodeHeader hdr + <> encodeNums + <> mconcat (map encodeQuestion qs) + <> mconcat (map encodeRR an) + <> mconcat (map encodeRR au) + <> mconcat (map encodeRR ad) where - hdr = header fmt - qs = question fmt - an = answer fmt - au = authority fmt - ad = additional fmt + encodeNums = mconcat $ fmap putInt16 [length qs + ,length an + ,length au + ,length ad + ] + hdr = header msg + qs = question msg + an = answer msg + au = authority msg + ad = additional msg encodeHeader :: DNSHeader -> SPut encodeHeader hdr = encodeIdentifier (identifier hdr) - +++ encodeFlags (flags hdr) - +++ decodeQdCount (qdCount hdr) - +++ decodeAnCount (anCount hdr) - +++ decodeNsCount (nsCount hdr) - +++ decodeArCount (arCount hdr) + <> encodeFlags (flags hdr) where encodeIdentifier = putInt16 - decodeQdCount = putInt16 - decodeAnCount = putInt16 - decodeNsCount = putInt16 - decodeArCount = putInt16 encodeFlags :: DNSFlags -> SPut encodeFlags DNSFlags{..} = put16 word @@ -95,30 +94,36 @@ word = execState st 0 encodeQuestion :: Question -> SPut -encodeQuestion Question{..} = - encodeDomain qname - +++ putInt16 (typeToInt qtype) - +++ put16 1 +encodeQuestion Question{..} = encodeDomain qname + <> putInt16 (typeToInt qtype) + <> put16 1 +putRData :: RData -> SPut +putRData rd = do + addPositionW 2 -- "simulate" putInt16 + rDataWrite <- encodeRDATA rd + let rdataLength = fromIntegral . BS.length . BB.toByteString . BB.fromWrite $ rDataWrite + let rlenWrite = BB.writeInt16be rdataLength + return rlenWrite <> return rDataWrite + encodeRR :: ResourceRecord -> SPut -encodeRR ResourceRecord{..} = - mconcat - [ encodeDomain rrname - , putInt16 (typeToInt rrtype) - , put16 1 - , putInt32 rrttl - , rlenRDATA - ] - where - -- Encoding rdata without using rdlen - rlenRDATA = do - addPositionW 2 -- "simulate" putInt16 - rDataWrite <- encodeRDATA rdata - let rdataLength = fromIntegral . BS.length . BB.toByteString . BB.fromWrite $ rDataWrite - let rlenWrite = BB.writeInt16be rdataLength - return rlenWrite +++ return rDataWrite +encodeRR ResourceRecord{..} = mconcat [ encodeDomain rrname + , putInt16 (typeToInt rrtype) + , put16 1 + , putInt32 rrttl + , putRData rdata + ] -encodeRDATA :: RDATA -> SPut +encodeRR OptRecord{..} = mconcat [ encodeDomain BS.empty + , putInt16 (typeToInt OPT) + , putInt16 orudpsize + , putInt32 $ if ordnssecok + then setBit 0 15 + else 0 + , putRData rdata + ] + +encodeRDATA :: RData -> SPut encodeRDATA rd = case rd of (RD_A ip) -> mconcat $ map putInt8 (fromIPv4 ip) (RD_AAAA ip) -> mconcat $ map putInt8 (fromIPv6b ip) @@ -128,7 +133,8 @@ (RD_PTR dom) -> encodeDomain dom (RD_MX prf dom) -> mconcat [putInt16 prf, encodeDomain dom] (RD_TXT txt) -> putByteStringWithLength txt - (RD_OTH bytes) -> mconcat $ map putInt8 bytes + (RD_OTH bytes) -> putByteString bytes + (RD_OPT opts) -> mconcat $ fmap encodeOData opts (RD_SOA d1 d2 serial refresh retry expire min') -> mconcat [ encodeDomain d1 , encodeDomain d2 @@ -145,32 +151,49 @@ , encodeDomain dom ] +encodeOData :: OData -> SPut +encodeOData (OD_ClientSubnet srcNet scpNet ip) = let dropZeroes = dropWhileEnd (==0) + (fam,raw) = case ip of + IPv4 ip4 -> (1,dropZeroes $ fromIPv4 ip4) + IPv6 ip6 -> (2,dropZeroes $ fromIPv6b ip6) + dataLen = 2 + 2 + length raw + in mconcat [putInt16 (optTypeToInt ClientSubnet) + ,putInt16 dataLen + ,putInt16 fam + ,putInt8 srcNet + ,putInt8 scpNet + ,mconcat $ fmap putInt8 raw + ] +encodeOData (OD_Unknown code bs) = mconcat [putInt16 code + ,putInt16 $ BS.length bs + ,putByteString bs + ] + -- In the case of the TXT record, we need to put the string length putByteStringWithLength :: BS.ByteString -> SPut -putByteStringWithLength bs = - putInt8 (fromIntegral $ BS.length bs) -- put the length of the given string - +++ putByteString bs +putByteStringWithLength bs = putInt8 (fromIntegral $ BS.length bs) -- put the length of the given string + <> putByteString bs ---------------------------------------------------------------- encodeDomain :: Domain -> SPut -encodeDomain dom | BS.null dom = put8 0 -encodeDomain dom = do - mpos <- wsPop dom - cur <- gets wsPosition - case mpos of - Just pos -> encodePointer pos - Nothing -> wsPush dom cur >> - mconcat [ encodePartialDomain hd - , encodeDomain tl - ] +encodeDomain dom + | BS.null dom = put8 0 + | otherwise = do + mpos <- wsPop dom + cur <- gets wsPosition + case mpos of + Just pos -> encodePointer pos + Nothing -> wsPush dom cur >> + mconcat [ encodePartialDomain hd + , encodeDomain tl + ] where (hd, tl') = BS.break (=='.') dom tl = if BS.null tl' then tl' else BS.drop 1 tl' encodePointer :: Int -> SPut -encodePointer pos = let w = (pos .|. 0xc000) in putInt16 w +encodePointer pos = putInt16 (pos .|. 0xc000) encodePartialDomain :: Domain -> SPut -encodePartialDomain sub = putInt8 (BS.length sub) - +++ putByteString sub +encodePartialDomain = putByteStringWithLength diff --git a/Network/DNS/Internal.hs b/Network/DNS/Internal.hs --- a/Network/DNS/Internal.hs +++ b/Network/DNS/Internal.hs @@ -1,17 +1,13 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable #-} +{-# LANGUAGE DeriveDataTypeable #-} module Network.DNS.Internal where import Control.Exception (Exception) -import Control.Applicative import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS -import Data.Char (toUpper) -import Data.IP (IPv4, IPv6) +import Data.IP (IP, IPv4, IPv6) import Data.Maybe (fromMaybe) import Data.Typeable (Typeable) -import Data.Foldable (Foldable) -import Data.Traversable ---------------------------------------------------------------- @@ -21,7 +17,17 @@ ---------------------------------------------------------------- -- | Types for resource records. -data TYPE = A | AAAA | NS | TXT | MX | CNAME | SOA | PTR | SRV | DNAME +data TYPE = A + | AAAA + | NS + | TXT + | MX + | CNAME + | SOA + | PTR + | SRV + | DNAME + | OPT | UNKNOWN Int deriving (Eq, Show, Read) rrDB :: [(TYPE, Int)] @@ -36,8 +42,18 @@ , (AAAA, 28) , (SRV, 33) , (DNAME, 39) -- RFC 2672 + , (OPT, 41) -- RFC 6891 ] +data OPTTYPE = ClientSubnet + | OUNKNOWN Int + deriving (Eq) + +orDB :: [(OPTTYPE, Int)] +orDB = [ + (ClientSubnet, 8) + ] + rookup :: (Eq b) => b -> [(a,b)] -> Maybe a rookup _ [] = Nothing rookup key ((x,y):xys) @@ -48,10 +64,13 @@ intToType n = fromMaybe (UNKNOWN n) $ rookup n rrDB typeToInt :: TYPE -> Int typeToInt (UNKNOWN x) = x -typeToInt t = fromMaybe 0 $ lookup t rrDB +typeToInt t = fromMaybe (error "typeToInt") $ lookup t rrDB -toType :: String -> TYPE -toType = read . map toUpper +intToOptType :: Int -> OPTTYPE +intToOptType n = fromMaybe (OUNKNOWN n) $ rookup n orDB +optTypeToInt :: OPTTYPE -> Int +optTypeToInt (OUNKNOWN x) = x +optTypeToInt t = fromMaybe (error "optTypeToInt") $ lookup t orDB ---------------------------------------------------------------- @@ -85,61 +104,28 @@ -- or a name server may not wish to perform -- a particular operation (e.g., zone transfer) for particular data. | OperationRefused + -- | The server detected a malformed OPT RR. + | BadOptRecord deriving (Eq, Show, Typeable) instance Exception DNSError -- | Raw data format for DNS Query and Response. -data DNSMessage a = DNSFormat { +data DNSMessage = DNSMessage { header :: DNSHeader , question :: [Question] - , answer :: [RR a] - , authority :: [RR a] - , additional :: [RR a] - } deriving (Eq, Show, Functor, Foldable) - -type DNSFormat = DNSMessage RDATA - -instance Traversable DNSMessage where - sequenceA dns = liftA3 build answer' authority' additional' - where - answer' = traverse sequenceA $ answer dns - authority' = traverse sequenceA $ authority dns - additional' = traverse sequenceA $ additional dns - build ans auth add = cast { answer = ans - , authority = auth - , additional = add } - where - cast = error "unhandled case in sequenceA (DNSMessage)" <$> dns - --- | Like 'fmap' except that RR 'TYPE' context is available --- within the map. -dnsMapWithType :: (TYPE -> a -> b) -> DNSMessage a -> DNSMessage b -dnsMapWithType parse dns = - cast { answer = mapParse $ answer dns - , authority = mapParse $ authority dns - , additional = mapParse $ additional dns - } - where - cast = error "unhandled case in dnsMapWithType" <$> dns - mapParse = map (rrMapWithType parse) - --- | Behaves exactly like a regular 'traverse' except that the traversing --- function also has access to the RR 'TYPE' associated with a value. -dnsTraverseWithType :: - Applicative f => - (TYPE -> a -> f b) -> DNSMessage a -> f (DNSMessage b) -dnsTraverseWithType parse = sequenceA . dnsMapWithType parse + , answer :: [ResourceRecord] + , authority :: [ResourceRecord] + , additional :: [ResourceRecord] + } deriving (Eq, Show) +-- | For backward compatibility. +type DNSFormat = DNSMessage -- | Raw data format for the header of DNS Query and Response. data DNSHeader = DNSHeader { identifier :: Int , flags :: DNSFlags - , qdCount :: Int - , anCount :: Int - , nsCount :: Int - , arCount :: Int } deriving (Eq, Show) -- | Raw data format for the flags of DNS Query and Response. @@ -159,7 +145,7 @@ data OPCODE = OP_STD | OP_INV | OP_SSR deriving (Eq, Show, Enum) -data RCODE = NoErr | FormatErr | ServFail | NameErr | NotImpl | Refused deriving (Eq, Show, Enum) +data RCODE = NoErr | FormatErr | ServFail | NameErr | NotImpl | Refused | BadOpt deriving (Eq, Show, Enum) ---------------------------------------------------------------- @@ -176,33 +162,36 @@ ---------------------------------------------------------------- -- | Raw data format for resource records. -data RR a = ResourceRecord { - rrname :: Domain - , rrtype :: TYPE - , rrttl :: Int - , rdlen :: Int - , rdata :: a - } deriving (Eq, Show, Functor, Foldable) - -type ResourceRecord = RR RDATA +data ResourceRecord = ResourceRecord { + rrname :: Domain + , rrtype :: TYPE + , rrttl :: Int + , rdata :: RData + } + | OptRecord { + orudpsize :: Int + , ordnssecok :: Bool + , orversion :: Int + , rdata :: RData + } + deriving (Eq,Show) -- | Raw data format for each type. -data RD a = RD_NS Domain | RD_CNAME Domain | RD_DNAME Domain - | RD_MX Int Domain | RD_PTR Domain +data RData = RD_NS Domain + | RD_CNAME Domain + | RD_DNAME 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 + | RD_A IPv4 + | RD_AAAA IPv6 + | RD_TXT ByteString | RD_SRV Int Int Int Domain - | RD_OTH a deriving (Eq, Functor, Foldable) - -type RDATA = RD [Int] - -instance Traversable RD where - sequenceA (RD_OTH a) = RD_OTH <$> a - sequenceA rd = pure cast - where - cast = error "unhandled case in squenceA (RD)" <$> rd + | RD_OPT [OData] + | RD_OTH ByteString + deriving (Eq) -instance Show a => Show (RD a) where +instance Show RData where show (RD_NS dom) = BS.unpack dom show (RD_MX prf dom) = BS.unpack dom ++ " " ++ show prf show (RD_CNAME dom) = BS.unpack dom @@ -213,20 +202,18 @@ show (RD_SOA mn _ _ _ _ _ mi) = BS.unpack mn ++ " " ++ show mi show (RD_PTR dom) = BS.unpack dom show (RD_SRV pri wei prt dom) = show pri ++ " " ++ show wei ++ " " ++ show prt ++ BS.unpack dom + show (RD_OPT od) = show od show (RD_OTH is) = show is -instance Traversable RR where - sequenceA rr = (\x -> fmap (const x) rr) <$> rdata rr --- | Like 'fmap' except that RR 'TYPE' context is available --- within the map. -rrMapWithType :: (TYPE -> a -> b) -> RR a -> RR b -rrMapWithType parse rr = parse (rrtype rr) <$> rr +data OData = OD_ClientSubnet Int Int IP + | OD_Unknown Int ByteString + deriving (Eq,Show) ---------------------------------------------------------------- -defaultQuery :: DNSFormat -defaultQuery = DNSFormat { +defaultQuery :: DNSMessage +defaultQuery = DNSMessage { header = DNSHeader { identifier = 0 , flags = DNSFlags { @@ -238,10 +225,6 @@ , recAvailable = False , rcode = NoErr } - , qdCount = 0 - , anCount = 0 - , nsCount = 0 - , arCount = 0 } , question = [] , answer = [] @@ -249,7 +232,7 @@ , additional = [] } -defaultResponse :: DNSFormat +defaultResponse :: DNSMessage defaultResponse = let hd = header defaultQuery flg = flags hd @@ -263,24 +246,24 @@ } } -responseA :: Int -> Question -> IPv4 -> DNSFormat -responseA ident q ip = +responseA :: Int -> Question -> [IPv4] -> DNSMessage +responseA ident q ips = let hd = header defaultResponse dom = qname q - an = ResourceRecord dom A 300 4 (RD_A ip) + an = fmap (ResourceRecord dom A 300 . RD_A) ips in defaultResponse { - header = hd { identifier=ident, qdCount = 1, anCount = 1 } + header = hd { identifier=ident } , question = [q] - , answer = [an] + , answer = an } -responseAAAA :: Int -> Question -> IPv6 -> DNSFormat -responseAAAA ident q ip = +responseAAAA :: Int -> Question -> [IPv6] -> DNSMessage +responseAAAA ident q ips = let hd = header defaultResponse dom = qname q - an = ResourceRecord dom AAAA 300 16 (RD_AAAA ip) + an = fmap (ResourceRecord dom AAAA 300 . RD_AAAA) ips in defaultResponse { - header = hd { identifier=ident, qdCount = 1, anCount = 1 } + header = hd { identifier=ident } , question = [q] - , answer = [an] + , answer = an } diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs --- a/Network/DNS/Lookup.hs +++ b/Network/DNS/Lookup.hs @@ -35,7 +35,7 @@ -- >>> -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupA resolver hostname --- Right [93.184.216.119] +-- Right [93.184.216.34] -- -- 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 @@ -103,7 +103,7 @@ Left err -> return (Left err) Right rds -> return $ mapM unTag rds where - unTag :: RDATA -> Either DNSError IPv4 + unTag :: RData -> Either DNSError IPv4 unTag (RD_A x) = Right x unTag _ = Left UnexpectedRDATA @@ -126,7 +126,7 @@ Left err -> return (Left err) Right rds -> return $ mapM unTag rds where - unTag :: RDATA -> Either DNSError IPv6 + unTag :: RData -> Either DNSError IPv6 unTag (RD_AAAA x) = Right x unTag _ = Left UnexpectedRDATA @@ -166,7 +166,7 @@ Left err -> return (Left err) Right rds -> return $ mapM unTag rds where - unTag :: RDATA -> Either DNSError (Domain,Int) + unTag :: RData -> Either DNSError (Domain,Int) unTag (RD_MX pr dm) = Right (dm,pr) unTag _ = Left UnexpectedRDATA @@ -227,7 +227,7 @@ -- '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])) +lookupNSImpl :: (Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])) -> Resolver -> Domain -> IO (Either DNSError [Domain]) @@ -238,7 +238,7 @@ Left err -> return (Left err) Right rds -> return $ mapM unTag rds where - unTag :: RDATA -> Either DNSError Domain + unTag :: RData -> Either DNSError Domain unTag (RD_NS dm) = Right dm unTag _ = Left UnexpectedRDATA @@ -315,7 +315,7 @@ Left err -> return (Left err) Right rds -> return $ mapM unTag rds where - unTag :: RDATA -> Either DNSError ByteString + unTag :: RData -> Either DNSError ByteString unTag (RD_TXT x) = Right x unTag _ = Left UnexpectedRDATA @@ -344,7 +344,7 @@ Left err -> return (Left err) Right rds -> return $ mapM unTag rds where - unTag :: RDATA -> Either DNSError Domain + unTag :: RData -> Either DNSError Domain unTag (RD_PTR dm) = Right dm unTag _ = Left UnexpectedRDATA @@ -406,6 +406,6 @@ Left err -> return (Left err) Right rds -> return $ mapM unTag rds where - unTag :: RDATA -> Either DNSError (Int,Int,Int,Domain) + 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 @@ -14,11 +14,10 @@ , lookupAuth -- ** Raw looking up function , lookupRaw - , lookupRaw' + , fromDNSMessage , fromDNSFormat ) where -import Control.Applicative ((<$>), (<*>), pure) import Control.Exception (bracket) import Data.Char (isSpace) import Data.List (isPrefixOf) @@ -34,6 +33,10 @@ import System.Random (getStdRandom, randomR) import System.Timeout (timeout) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>), (<*>), pure) +#endif + #if mingw32_HOST_OS == 1 import Network.Socket (send) import qualified Data.ByteString.Lazy.Char8 as LB @@ -199,40 +202,45 @@ ---------------------------------------------------------------- -- | Looking up resource records of a domain. The first parameter is one of --- the field accessors of the 'DNSFormat' type -- this allows you to +-- the field accessors of the 'DNSMessage' type -- this allows you to -- choose which section (answer, authority, or additional) you would like -- to inspect for the result. -lookupSection :: (DNSFormat -> [ResourceRecord]) +lookupSection :: (DNSMessage -> [ResourceRecord]) -> Resolver -> Domain -> TYPE - -> IO (Either DNSError [RDATA]) + -> IO (Either DNSError [RData]) lookupSection section rlv dom typ = do eans <- lookupRaw rlv dom typ case eans of Left err -> return $ Left err - Right ans -> return $ fromDNSFormat ans toRDATA + Right ans -> return $ fromDNSMessage ans toRData where {- CNAME hack dom' = if "." `isSuffixOf` dom then dom else dom ++ "." correct r = rrname r == dom' && rrtype r == typ -} correct r = rrtype r == typ - toRDATA = map rdata . filter correct . section + toRData = map rdata . filter correct . section --- | Extract necessary information from 'DNSFormat' -fromDNSFormat :: DNSFormat -> (DNSFormat -> a) -> Either DNSError a -fromDNSFormat ans conv = case errcode ans of +-- | Extract necessary information from 'DNSMessage' +fromDNSMessage :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a +fromDNSMessage ans conv = case errcode ans of NoErr -> Right $ conv ans FormatErr -> Left FormatError ServFail -> Left ServerFailure NameErr -> Left NameError NotImpl -> Left NotImplemented Refused -> Left OperationRefused + BadOpt -> Left BadOptRecord where errcode = rcode . flags . header +-- | For backward compatibility. +fromDNSFormat :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a +fromDNSFormat = fromDNSMessage + -- | Look up resource records for a domain, collecting the results -- from the ANSWER section of the response. -- @@ -241,14 +249,14 @@ -- >>> let hostname = Data.ByteString.Char8.pack "www.example.com" -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookup resolver hostname A --- Right [93.184.216.119] +-- Right [93.184.216.34] -- -lookup :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RDATA]) +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 :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData]) lookupAuth = lookupSection authority @@ -267,7 +275,7 @@ -- And the (formatted) expected output: -- -- @ --- Right (DNSFormat +-- Right (DNSMessage -- { header = DNSHeader -- { identifier = 1, -- flags = DNSFlags @@ -278,10 +286,7 @@ -- 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.\", @@ -293,20 +298,15 @@ -- additional = []}) -- @ -- -lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSFormat) +lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage) lookupRaw = lookupRawInternal receive --- | Like 'lookupRaw' except that no unknown RDATA records are not split up --- into 'Int's. -lookupRaw' :: Resolver -> Domain -> TYPE -> IO (Either DNSError (DNSMessage (RD BS.ByteString))) -lookupRaw' = lookupRawInternal receive' - lookupRawInternal :: - (Socket -> IO (DNSMessage a)) + (Socket -> IO DNSMessage) -> Resolver -> Domain -> TYPE - -> IO (Either DNSError (DNSMessage a)) + -> IO (Either DNSError DNSMessage) lookupRawInternal _ _ dom _ | isIllegal dom = return $ Left IllegalDomain lookupRawInternal rcv rlv dom typ = do diff --git a/Network/DNS/StateBinary.hs b/Network/DNS/StateBinary.hs --- a/Network/DNS/StateBinary.hs +++ b/Network/DNS/StateBinary.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-} module Network.DNS.StateBinary where import Blaze.ByteString.Builder (Write) import qualified Blaze.ByteString.Builder as BB -import Control.Applicative ((<$>), (<*)) import Control.Monad.State (State, StateT) import qualified Control.Monad.State as ST import Control.Monad.Trans.Resource (ResourceT) @@ -19,9 +18,13 @@ import qualified Data.IntMap as IM import Data.Map (Map) import qualified Data.Map as M -import Data.Monoid (Monoid, mconcat, mappend, mempty) import Data.Word (Word8, Word16, Word32) import Network.DNS.Types + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>), (<*)) +import Data.Monoid (Monoid, mconcat, mappend, mempty) +#endif ---------------------------------------------------------------- diff --git a/Network/DNS/Types.hs b/Network/DNS/Types.hs --- a/Network/DNS/Types.hs +++ b/Network/DNS/Types.hs @@ -5,20 +5,16 @@ -- * Domain Domain -- * Resource Records - , ResourceRecord - , RR (..) - , RDATA - , RD (..) - , rrMapWithType + , ResourceRecord (..) + , RData (..), OData (..) -- ** Resource Record Type - , TYPE (..), intToType, typeToInt, toType + , TYPE (..), intToType, typeToInt + , OPTTYPE (..), intToOptType, optTypeToInt -- * DNS Error , DNSError (..) - -- * DNS Format - , DNSFormat + -- * DNS Message , DNSMessage (..) - , dnsMapWithType - , dnsTraverseWithType + , DNSFormat -- * DNS Header , DNSHeader (..) -- * DNS Flags diff --git a/dns.cabal b/dns.cabal --- a/dns.cabal +++ b/dns.cabal @@ -1,5 +1,5 @@ Name: dns -Version: 1.4.5 +Version: 2.0.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -11,6 +11,7 @@ Category: Network Cabal-Version: >= 1.10 Build-Type: Simple +Extra-Source-Files: Changelog Library Default-Language: Haskell2010 diff --git a/test/DecodeSpec.hs b/test/DecodeSpec.hs --- a/test/DecodeSpec.hs +++ b/test/DecodeSpec.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, CPP #-} module DecodeSpec where import Data.ByteString.Internal (ByteString(..), unsafeCreate) +#if !MIN_VERSION_bytestring(0,10,0) +import qualified Data.ByteString as BS +#endif import qualified Data.ByteString.Lazy as BL import Data.Word8 import Foreign.ForeignPtr (withForeignPtr) @@ -49,7 +52,11 @@ ---------------------------------------------------------------- fromHexString :: BL.ByteString -> BL.ByteString +#if MIN_VERSION_bytestring(0,10,0) fromHexString = BL.fromStrict . fromHexString' . BL.toStrict +#else +fromHexString = BL.pack . BS.unpack . fromHexString' . BS.pack . BL.unpack +#endif fromHexString' :: ByteString -> ByteString fromHexString' (PS fptr off len) = unsafeCreate size $ \dst -> diff --git a/test/EncodeSpec.hs b/test/EncodeSpec.hs --- a/test/EncodeSpec.hs +++ b/test/EncodeSpec.hs @@ -10,26 +10,26 @@ spec :: Spec spec = do describe "encode" $ do - it "encodes DNSFormat correctly" $ do + it "encodes DNSMessage correctly" $ do check1 testQueryA check1 testQueryAAAA check1 testResponseA check1 testResponseTXT describe "decode" $ do - it "decodes DNSFormat correctly" $ do + it "decodes DNSMessage correctly" $ do check2 testQueryA check2 testQueryAAAA check2 testResponseA check2 testResponseTXT -check1 :: DNSFormat -> Expectation +check1 :: DNSMessage -> Expectation check1 inp = out `shouldBe` Right inp where bs = encode inp out = decode bs -check2 :: DNSFormat -> Expectation +check2 :: DNSMessage -> Expectation check2 inp = bs' `shouldBe` bs where bs = encode inp @@ -39,26 +39,24 @@ defaultHeader :: DNSHeader defaultHeader = header defaultQuery -testQueryA :: DNSFormat +testQueryA :: DNSMessage testQueryA = defaultQuery { header = defaultHeader { identifier = 1000 - , qdCount = 1 } , question = [makeQuestion "www.mew.org." A] } -testQueryAAAA :: DNSFormat +testQueryAAAA :: DNSMessage testQueryAAAA = defaultQuery { header = defaultHeader { identifier = 1000 - , qdCount = 1 } , question = [makeQuestion "www.mew.org." AAAA] } -testResponseA :: DNSFormat -testResponseA = DNSFormat { +testResponseA :: DNSMessage +testResponseA = DNSMessage { header = DNSHeader { identifier = 61046 , flags = DNSFlags { @@ -70,10 +68,6 @@ , recAvailable = True , rcode = NoErr } - , qdCount = 1 - , anCount = 8 - , nsCount = 2 - , arCount = 4 } , question = [Question { qname = "492056364.qzone.qq.com." @@ -84,56 +78,48 @@ rrname = "492056364.qzone.qq.com." , rrtype = A , rrttl = 568 - , rdlen = 4 , rdata = RD_A $ toIPv4 [119, 147, 15, 122] } , ResourceRecord { rrname = "492056364.qzone.qq.com." , rrtype = A , rrttl = 568 - , rdlen = 4 , rdata = RD_A $ toIPv4 [119, 147, 79, 106] } , ResourceRecord { rrname = "492056364.qzone.qq.com." , rrtype = A , rrttl = 568 - , rdlen = 4 , rdata = RD_A $ toIPv4 [183, 60, 55, 43] } , ResourceRecord { rrname = "492056364.qzone.qq.com." , rrtype = A , rrttl = 568 - , rdlen = 4 , rdata = RD_A $ toIPv4 [183, 60, 55, 107] } , ResourceRecord { rrname = "492056364.qzone.qq.com." , rrtype = A , rrttl = 568 - , rdlen = 4 , rdata = RD_A $ toIPv4 [113, 108, 7, 172] } , ResourceRecord { rrname = "492056364.qzone.qq.com." , rrtype = A , rrttl = 568 - , rdlen = 4 , rdata = RD_A $ toIPv4 [113, 108, 7, 174] } , ResourceRecord { rrname = "492056364.qzone.qq.com." , rrtype = A , rrttl = 568 - , rdlen = 4 , rdata = RD_A $ toIPv4 [113, 108, 7, 175] } , ResourceRecord { rrname = "492056364.qzone.qq.com." , rrtype = A , rrttl = 568 - , rdlen = 4 , rdata = RD_A $ toIPv4 [119, 147, 15, 100] } ] @@ -141,14 +127,12 @@ rrname = "qzone.qq.com." , rrtype = NS , rrttl = 45919 - , rdlen = 10 , rdata = RD_NS "ns-tel2.qq.com." } , ResourceRecord { rrname = "qzone.qq.com." , rrtype = NS , rrttl = 45919 - , rdlen = 10 , rdata = RD_NS "ns-tel1.qq.com." } ] @@ -156,35 +140,31 @@ rrname = "ns-tel1.qq.com." , rrtype = A , rrttl = 46520 - , rdlen = 4 , rdata = RD_A $ toIPv4 [121, 14, 73, 115] } , ResourceRecord { rrname = "ns-tel2.qq.com." , rrtype = A , rrttl = 2890 - , rdlen = 4 , rdata = RD_A $ toIPv4 [222, 73, 76, 226] } , ResourceRecord { rrname = "ns-tel2.qq.com." , rrtype = A , rrttl = 2890 - , rdlen = 4 , rdata = RD_A $ toIPv4 [183, 60, 3, 202] } , ResourceRecord { rrname = "ns-tel2.qq.com." , rrtype = A , rrttl = 2890 - , rdlen = 4 , rdata = RD_A $ toIPv4 [218, 30, 72, 180] } ] } -testResponseTXT :: DNSFormat -testResponseTXT = DNSFormat { +testResponseTXT :: DNSMessage +testResponseTXT = DNSMessage { header = DNSHeader { identifier = 48724 , flags = DNSFlags { @@ -196,10 +176,6 @@ , recAvailable = True , rcode = NoErr } - , qdCount = 1 - , anCount = 1 - , nsCount = 2 - , arCount = 4 } , question = [Question { qname = "492056364.qzone.qq.com." @@ -210,7 +186,6 @@ rrname = "492056364.qzone.qq.com." , rrtype = TXT , rrttl = 0 - , rdlen = 16 , rdata = RD_TXT "simple txt line" } ] @@ -218,14 +193,12 @@ rrname = "qzone.qq.com." , rrtype = NS , rrttl = 45919 - , rdlen = 10 , rdata = RD_NS "ns-tel2.qq.com." } , ResourceRecord { rrname = "qzone.qq.com." , rrtype = NS , rrttl = 45919 - , rdlen = 10 , rdata = RD_NS "ns-tel1.qq.com." } ] @@ -233,28 +206,24 @@ rrname = "ns-tel1.qq.com." , rrtype = A , rrttl = 46520 - , rdlen = 4 , rdata = RD_A $ toIPv4 [121, 14, 73, 115] } , ResourceRecord { rrname = "ns-tel2.qq.com." , rrtype = A , rrttl = 2890 - , rdlen = 4 , rdata = RD_A $ toIPv4 [222, 73, 76, 226] } , ResourceRecord { rrname = "ns-tel2.qq.com." , rrtype = A , rrttl = 2890 - , rdlen = 4 , rdata = RD_A $ toIPv4 [183, 60, 3, 202] } , ResourceRecord { rrname = "ns-tel2.qq.com." , rrtype = A , rrttl = 2890 - , rdlen = 4 , rdata = RD_A $ toIPv4 [218, 30, 72, 180] } ]