diff --git a/Network/DNS/Decode.hs b/Network/DNS/Decode.hs --- a/Network/DNS/Decode.hs +++ b/Network/DNS/Decode.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/DNS/Internal.hs b/Network/DNS/Internal.hs --- a/Network/DNS/Internal.hs +++ b/Network/DNS/Internal.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs --- a/Network/DNS/Lookup.hs +++ b/Network/DNS/Lookup.hs @@ -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 diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs --- a/Network/DNS/Resolver.hs +++ b/Network/DNS/Resolver.hs @@ -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 diff --git a/Network/DNS/Types.hs b/Network/DNS/Types.hs --- a/Network/DNS/Types.hs +++ b/Network/DNS/Types.hs @@ -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 diff --git a/dns.cabal b/dns.cabal --- a/dns.cabal +++ b/dns.cabal @@ -1,5 +1,5 @@ Name: dns -Version: 1.2.3 +Version: 1.3.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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