dns 1.2.3 → 1.3.0

raw patch · 6 files changed

+148/−41 lines, 6 filesdep −attoparsec-conduitdep ~conduit-extraPVP ok

version bump matches the API change (PVP)

Dependencies removed: attoparsec-conduit

Dependency ranges changed: conduit-extra

API changes (from Hackage documentation)

Files

• Network/DNS/Decode.hs +42/−9
• Network/DNS/Internal.hs +68/−12
• Network/DNS/Lookup.hs +6/−6
• Network/DNS/Resolver.hs +17/−3
• Network/DNS/Types.hs +11/−4
• dns.cabal +4/−7

@@ -1,13 +1,15 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, ViewPatterns, DeriveDataTypeable #-}  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.Char8 as BS@@ -15,34 +17,65 @@ import Data.Conduit (($$), Source) import Data.Conduit.Network (sourceSocket) import Data.IP (toIPv4, toIPv6)-import Data.Maybe (fromMaybe)+import Data.Traversable (traverse)+import Data.Typeable (Typeable) import Network (Socket) import Network.DNS.Internal import Network.DNS.StateBinary  ---------------------------------------------------------------- ++data RDATAParseError = RDATAParseError String+ deriving (Show, Typeable)++instance ControlException.Exception RDATAParseError++ -- | Receiving DNS data from 'Socket' and parse it.  receive :: Socket -> IO DNSFormat-receive sock = receiveDNSFormat $ sourceSocket sock+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++ ----------------------------------------------------------------  -- | Parsing DNS data.  decode :: BL.ByteString -> Either String DNSFormat decode bs = fst <$> runSGet decodeResponse bs+            >>= traverse unpackBytes +unpackBytes :: RD ByteString -> Either String (RD [Int])+unpackBytes (RD_OTH dta) = fmap (RD_OTH . fst) $ unpack $ dta'+ where+    len = fromIntegral $ BS.length dta+    dta' = BL.fromChunks [dta]+    unpack = runSGet (getNBytes len)+unpackBytes rd = Right $ cast rd+ where+    cast = fmap (error "unhandled case in decode")+++ -----------------------------------------------------------------receiveDNSFormat :: Source (ResourceT IO) ByteString -> IO DNSFormat+receiveDNSFormat :: Source (ResourceT IO) ByteString -> IO (DNSMessage (RD ByteString)) receiveDNSFormat src = fst <$> runResourceT (src $$ sink)   where     sink = sinkSGet decodeResponse  ---------------------------------------------------------------- -decodeResponse :: SGet DNSFormat+decodeResponse :: SGet (DNSMessage (RD ByteString)) decodeResponse = do     hd <- decodeHeader     DNSFormat hd <$> decodeQueries (qdCount hd)@@ -98,10 +131,10 @@ decodeQuery = Question <$> decodeDomain                        <*> (decodeType <* ignoreClass) -decodeRRs :: Int -> SGet [ResourceRecord]+decodeRRs :: Int -> SGet [RR (RD ByteString)] decodeRRs n = replicateM n decodeRR -decodeRR :: SGet ResourceRecord+decodeRR :: SGet (RR (RD ByteString)) decodeRR = do     Question dom typ <- decodeQuery     ttl <- decodeTTL@@ -117,7 +150,7 @@     decodeTTL = fromIntegral <$> get32     decodeRLen = getInt16 -decodeRData :: TYPE -> Int -> SGet RDATA+decodeRData :: TYPE -> Int -> SGet (RD ByteString) decodeRData NS _ = RD_NS <$> decodeDomain decodeRData MX _ = RD_MX <$> decodePreference <*> decodeDomain   where@@ -155,7 +188,7 @@     decodeWeight   = getInt16     decodePort     = getInt16 -decodeRData _  len = RD_OTH <$> getNBytes len+decodeRData _  len = RD_OTH <$> getNByteString len  ---------------------------------------------------------------- 

@@ -1,14 +1,17 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable #-}  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.Maybe (fromMaybe) import Data.Typeable (Typeable)+import Data.Foldable (Foldable)+import Data.Traversable  ---------------------------------------------------------------- @@ -86,14 +89,49 @@ instance Exception DNSError  -- | Raw data format for DNS Query and Response.-data DNSFormat = DNSFormat {+data DNSMessage a = DNSFormat {     header     :: DNSHeader   , question   :: [Question]-  , answer     :: [ResourceRecord]-  , authority  :: [ResourceRecord]-  , additional :: [ResourceRecord]-  } deriving (Eq, Show)+  , 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 = fmap (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 = fmap (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++ -- | Raw data format for the header of DNS Query and Response. data DNSHeader = DNSHeader {     identifier :: Int@@ -138,22 +176,32 @@ ----------------------------------------------------------------  -- | Raw data format for resource records.-data ResourceRecord = ResourceRecord {+data RR a = ResourceRecord {     rrname :: Domain   , rrtype :: TYPE   , rrttl  :: Int   , rdlen  :: Int-  , rdata  :: RDATA-  } deriving (Eq, Show)+  , rdata  :: a+  } deriving (Eq, Show, Functor, Foldable) +type ResourceRecord = RR RDATA+ -- | Raw data format for each type.-data RDATA = RD_NS Domain | RD_CNAME Domain | RD_MX Int Domain | RD_PTR Domain+data RD a = 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            | RD_SRV Int Int Int Domain-           | RD_OTH [Int] deriving (Eq)+           | RD_OTH a deriving (Eq, Functor, Foldable) -instance Show RDATA where+type RDATA = RD [Int]++instance Traversable RD where+  sequenceA (RD_OTH a) = fmap RD_OTH a+  sequenceA rd         = pure cast+    where+        cast = fmap (error "unhandled case in squenceA (RD)") rd++instance Show a => Show (RD a) 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@@ -164,6 +212,14 @@   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_OTH is) = show is++instance Traversable RR where+  sequenceA rr = fmap (\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) `fmap` rr  ---------------------------------------------------------------- 

@@ -177,12 +177,12 @@ --   Examples: -- --   >>> import Data.List (sort)---   >>> let hostname = Data.ByteString.Char8.pack "mixi.jp"+--   >>> let hostname = Data.ByteString.Char8.pack "iij.ad.jp" --   >>> --   >>> rs <- makeResolvSeed defaultResolvConf --   >>> ips <- withResolver rs $ \resolver -> lookupAviaMX resolver hostname --   >>> fmap sort ips---   Right [202.32.29.4,202.32.29.5]+--   Right [202.232.30.70,202.232.30.144] -- --   Since there is more than one result, it is necessary to sort the --   list in order to check for equality.@@ -328,11 +328,11 @@ --   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"+--   >>> let hostname = Data.ByteString.Char8.pack "164.2.232.202.in-addr.arpa" --   >>> --   >>> rs <- makeResolvSeed defaultResolvConf --   >>> withResolver rs $ \resolver -> lookupPTR resolver hostname---   Right ["www-v4.iij.ad.jp."]+--   Right ["www.iij.ad.jp."] -- --   The 'lookupRDNS' function is more suited to this particular task. --@@ -355,11 +355,11 @@ --   We repeat the example from 'lookupPTR', except now we pass the IP --   address directly: -----   >>> let hostname = Data.ByteString.Char8.pack "210.130.137.80"+--   >>> let hostname = Data.ByteString.Char8.pack "202.232.2.164" --   >>> --   >>> rs <- makeResolvSeed defaultResolvConf --   >>> withResolver rs $ \resolver -> lookupRDNS resolver hostname---   Right ["www-v4.iij.ad.jp."]+--   Right ["www.iij.ad.jp."] -- lookupRDNS :: Resolver -> Domain -> IO (Either DNSError [Domain]) lookupRDNS rlv ip = lookupPTR rlv dom

@@ -14,6 +14,7 @@   , lookupAuth   -- ** Raw looking up function   , lookupRaw+  , lookupRaw'   , fromDNSFormat   ) where @@ -286,9 +287,22 @@ --  @ -- lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSFormat)-lookupRaw _   dom _+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))+    -> Resolver+    -> Domain+    -> TYPE+    -> IO (Either DNSError (DNSMessage a))+lookupRawInternal _ _   dom _   | isIllegal dom     = return $ Left IllegalDomain-lookupRaw rlv dom typ = do+lookupRawInternal rcv rlv dom typ = do     seqno <- genId rlv     let query = composeQuery seqno [q]         checkSeqno = check seqno@@ -301,7 +315,7 @@           return $ Left ret       | otherwise    = do           sendAll sock query-          response <- timeout tm (receive sock)+          response <- timeout tm (rcv sock)           case response of               Nothing  -> loop query checkSeqno (cnt + 1) False               Just res -> do

@@ -4,12 +4,21 @@ module Network.DNS.Types (   -- * Domain     Domain-  -- * TYPE+  -- * Resource Records+  , ResourceRecord+  , RR (..)+  , RDATA+  , RD (..)+  , rrMapWithType+  -- ** Resource Record Type   , TYPE (..), intToType, typeToInt, toType   -- * DNS Error   , DNSError (..)   -- * DNS Format-  , DNSFormat (..)+  , DNSFormat+  , DNSMessage (..)+  , dnsMapWithType+  , dnsTraverseWithType   -- * DNS Header   , DNSHeader (..)   -- * DNS Flags@@ -18,9 +27,7 @@   , QorR (..)   , OPCODE (..)   , RCODE (..)-  , ResourceRecord (..)   , Question (..)-  , RDATA (..)   , responseA, responseAAAA   ) where 

@@ -1,5 +1,5 @@ Name:                   dns-Version:                1.2.3+Version:                1.3.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -26,12 +26,11 @@   if impl(ghc >= 7)     Build-Depends:      base >= 4 && < 5                       , attoparsec-                      , attoparsec-conduit                       , binary                       , blaze-builder                       , bytestring                       , conduit >= 1.1-                      , conduit-extra+                      , conduit-extra >= 1.1                       , containers                       , iproute >= 1.2.4                       , mtl@@ -41,12 +40,11 @@   else     Build-Depends:      base >= 4 && < 5                       , attoparsec-                      , attoparsec-conduit                       , binary                       , blaze-builder                       , bytestring                       , conduit >= 1.1-                      , conduit-extra+                      , conduit-extra >= 1.1                       , containers                       , iproute >= 1.2.4                       , mtl@@ -76,12 +74,11 @@   Other-Modules:        EncodeSpec   Build-Depends:        base                       , attoparsec-                      , attoparsec-conduit                       , binary                       , blaze-builder                       , bytestring                       , conduit >= 1.1-                      , conduit-extra+                      , conduit-extra >= 1.1                       , containers                       , dns                       , hspec