dns 1.4.5 → 2.0.0

raw patch · 11 files changed

+352/−323 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Changelog +8/−0
• Network/DNS/Decode.hs +106/−67
• Network/DNS/Encode.hs +90/−67
• Network/DNS/Internal.hs +81/−98
• Network/DNS/Lookup.hs +9/−9
• Network/DNS/Resolver.hs +26/−26
• Network/DNS/StateBinary.hs +6/−3
• Network/DNS/Types.hs +6/−10
• dns.cabal +2/−1
• test/DecodeSpec.hs +8/−1
• test/EncodeSpec.hs +10/−41

@@ -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

@@ -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

@@ -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

@@ -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       }

@@ -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

@@ -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

@@ -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  ---------------------------------------------------------------- 

@@ -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

@@ -1,5 +1,5 @@ Name:                   dns-Version:                1.4.5+Version:                2.0.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -11,6 +11,7 @@ Category:               Network Cabal-Version:          >= 1.10 Build-Type:             Simple+Extra-Source-Files:     Changelog  Library   Default-Language:     Haskell2010

@@ -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 ->

@@ -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]                       }                  ]