diff --git a/Network/DNS.hs b/Network/DNS.hs --- a/Network/DNS.hs +++ b/Network/DNS.hs @@ -1,10 +1,9 @@ {-| Thread-safe DNS library written in Haskell. - Currently, only resolver side is supported. This code is written in - Haskell, not using FFI. + This code is written in Haskell, not using FFI. - Sample code: + Sample code for DNS lookup: @ import qualified Network.DNS as DNS (lookup) @@ -18,11 +17,19 @@ -} module Network.DNS ( + -- * High level module Network.DNS.Lookup , module Network.DNS.Resolver , module Network.DNS.Types + -- * Low level + , module Network.DNS.Decode + , module Network.DNS.Encode ) where import Network.DNS.Lookup import Network.DNS.Resolver import Network.DNS.Types +import Network.DNS.Decode +import Network.DNS.Encode + + diff --git a/Network/DNS/Decode.hs b/Network/DNS/Decode.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/Decode.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.DNS.Decode ( + decode + , receive + ) where + +import Control.Applicative +import Control.Monad +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL +import Data.Enumerator (Enumerator, run_, ($$)) +import Data.IP +import Data.Maybe +import Network +import Network.DNS.Internal +import Network.DNS.StateBinary +import Network.Socket.Enumerator + +---------------------------------------------------------------- + +{-| Receiving DNS data from 'Socket' and parse it. + The second argument is a buffer size for the socket. +-} +receive :: Socket -> Integer -> IO DNSFormat +receive sock bufsize = receiveDNSFormat responseEnum + where + responseEnum = enumSocket bufsize sock + +---------------------------------------------------------------- + +{-| Parsing DNS data. +-} +decode :: BL.ByteString -> Either String DNSFormat +decode bs = fst <$> runSGet decodeResponse bs + +---------------------------------------------------------------- + +receiveDNSFormat :: Enumerator ByteString IO (DNSFormat, PState) + -> IO DNSFormat +receiveDNSFormat enum = fst <$> run_ (enum $$ iter) + where + iter = iterSGet decodeResponse + +---------------------------------------------------------------- + +decodeResponse :: SGet DNSFormat +decodeResponse = do + hd <- decodeHeader + DNSFormat hd <$> decodeQueries (qdCount hd) + <*> decodeRRs (anCount hd) + <*> decodeRRs (nsCount hd) + <*> decodeRRs (arCount hd) + +---------------------------------------------------------------- + +decodeFlags :: SGet DNSFlags +decodeFlags = toFlags <$> get16 + where + toFlags flgs = DNSFlags (getQorR flgs) + (getOpcode flgs) + (getAuthAnswer flgs) + (getTrunCation flgs) + (getRecDesired flgs) + (getRecAvailable flgs) + (getRcode flgs) + getQorR w = if testBit w 15 then QR_Response else QR_Query + getOpcode w = toEnum $ fromIntegral $ shiftR w 11 .&. 0x0f + getAuthAnswer w = testBit w 10 + getTrunCation w = testBit w 9 + getRecDesired w = testBit w 8 + getRecAvailable w = testBit w 7 + getRcode w = toEnum $ fromIntegral $ w .&. 0x0f + +---------------------------------------------------------------- + +decodeHeader :: SGet DNSHeader +decodeHeader = DNSHeader <$> decodeIdentifier + <*> decodeFlags + <*> decodeQdCount + <*> decodeAnCount + <*> decodeNsCount + <*> decodeArCount + where + decodeIdentifier = getInt16 + decodeQdCount = getInt16 + decodeAnCount = getInt16 + decodeNsCount = getInt16 + decodeArCount = getInt16 + +---------------------------------------------------------------- + +decodeQueries :: Int -> SGet [Question] +decodeQueries n = replicateM n decodeQuery + +decodeType :: SGet TYPE +decodeType = intToType <$> getInt16 + +decodeQuery :: SGet Question +decodeQuery = Question <$> decodeDomain + <*> (decodeType <* ignoreClass) + +decodeRRs :: Int -> SGet [ResourceRecord] +decodeRRs n = replicateM n decodeRR + +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 + } + where + decodeTTL = fromIntegral <$> get32 + decodeRLen = getInt16 + +decodeRData :: TYPE -> Int -> SGet RDATA +decodeRData NS _ = RD_NS <$> decodeDomain +decodeRData MX _ = RD_MX <$> decodePreference <*> decodeDomain + where + decodePreference = getInt16 +decodeRData CNAME _ = RD_CNAME <$> decodeDomain +decodeRData TXT len = (RD_TXT . ignoreLength) <$> getNByteString len + where + ignoreLength = BS.tail +decodeRData A len = (RD_A . toIPv4) <$> getNBytes len +decodeRData AAAA len = (RD_AAAA . toIPv6 . combine) <$> getNBytes len + where + combine [] = [] + combine [_] = error "combine" + combine (a:b:cs) = a * 256 + b : combine cs +decodeRData SOA _ = RD_SOA <$> decodeDomain + <*> decodeDomain + <*> decodeSerial + <*> decodeRefesh + <*> decodeRetry + <*> decodeExpire + <*> decodeMinumun + where + decodeSerial = getInt32 + decodeRefesh = getInt32 + decodeRetry = getInt32 + decodeExpire = getInt32 + decodeMinumun = getInt32 +decodeRData PTR _ = RD_PTR <$> decodeDomain +decodeRData SRV _ = RD_SRV <$> decodePriority + <*> decodeWeight + <*> decodePort + <*> decodeDomain + where + decodePriority = getInt16 + decodeWeight = getInt16 + decodePort = getInt16 + +decodeRData _ len = RD_OTH <$> getNBytes 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 + d <- getInt8 + let offset = n * 256 + d + fromMaybe (error $ "decodeDomain: " ++ show offset) <$> pop offset + else do + hs <- getNByteString n + ds <- decodeDomain + let dom = hs `BS.append` "." `BS.append` ds + push pos dom + return dom + where + getValue c = c .&. 0x3f + isPointer c = testBit c 7 && testBit c 6 + +ignoreClass :: SGet () +ignoreClass = () <$ get16 diff --git a/Network/DNS/Encode.hs b/Network/DNS/Encode.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/Encode.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE RecordWildCards #-} +module Network.DNS.Encode ( + encode + , composeQuery + ) where + +import qualified Data.ByteString.Lazy.Char8 as BL (ByteString) +import qualified Data.ByteString.Char8 as BS (length, null, break, drop) +import Network.DNS.StateBinary +import Network.DNS.Internal +import Data.Monoid +import Control.Monad.State +import Data.Bits +import Data.Word +import Data.IP + +(+++) :: Monoid a => a -> a -> a +(+++) = mappend + +---------------------------------------------------------------- + +{-| Composing query. First argument is a number to identify response. +-} +composeQuery :: Int -> [Question] -> BL.ByteString +composeQuery idt qs = encode qry + where + hdr = header defaultQuery + qry = defaultQuery { + header = hdr { + identifier = idt + , qdCount = length qs + } + , question = qs + } + +---------------------------------------------------------------- + +{-| Composing DNS data. +-} +encode :: DNSFormat -> BL.ByteString +encode fmt = runSPut (encodeDNSFormat fmt) + +---------------------------------------------------------------- + +encodeDNSFormat :: DNSFormat -> SPut +encodeDNSFormat fmt = encodeHeader hdr + +++ 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 + +encodeHeader :: DNSHeader -> SPut +encodeHeader hdr = encodeIdentifier (identifier hdr) + +++ encodeFlags (flags hdr) + +++ decodeQdCount (qdCount hdr) + +++ decodeAnCount (anCount hdr) + +++ decodeNsCount (nsCount hdr) + +++ decodeArCount (arCount hdr) + where + encodeIdentifier = putInt16 + decodeQdCount = putInt16 + decodeAnCount = putInt16 + decodeNsCount = putInt16 + decodeArCount = putInt16 + +encodeFlags :: DNSFlags -> SPut +encodeFlags DNSFlags{..} = put16 word + where + word16 :: Enum a => a -> Word16 + word16 = toEnum . fromEnum + + set :: Word16 -> State Word16 () + set byte = modify (.|. byte) + + st :: State Word16 () + st = sequence_ + [ set (word16 rcode) + , when recAvailable $ set (bit 7) + , when recDesired $ set (bit 8) + , when trunCation $ set (bit 9) + , when authAnswer $ set (bit 10) + , set (word16 opcode `shiftL` 11) + , when (qOrR==QR_Response) $ set (bit 15) + ] + + word = execState st 0 + +encodeQuestion :: Question -> SPut +encodeQuestion Question{..} = + encodeDomain qname + +++ putInt16 (typeToInt qtype) + +++ put16 1 + +encodeRR :: ResourceRecord -> SPut +encodeRR ResourceRecord{..} = + mconcat + [ encodeDomain rrname + , putInt16 (typeToInt rrtype) + , put16 1 + , putInt32 rrttl + , putInt16 rdlen + , encodeRDATA rdata + ] + +encodeRDATA :: RDATA -> SPut +encodeRDATA rd = case rd of + (RD_A ip) -> mconcat $ map putInt8 (fromIPv4 ip) + (RD_AAAA ip) -> mconcat $ map putInt16 (fromIPv6 ip) + (RD_NS dom) -> encodeDomain dom + (RD_CNAME dom) -> encodeDomain dom + (RD_PTR dom) -> encodeDomain dom + (RD_MX prf dom) -> mconcat [putInt16 prf, encodeDomain dom] + (RD_TXT txt) -> putByteString txt + (RD_OTH bytes) -> mconcat $ map putInt8 bytes + (RD_SOA d1 d2 serial refresh retry expire min') -> mconcat + [ encodeDomain d1 + , encodeDomain d2 + , putInt32 serial + , putInt32 refresh + , putInt32 retry + , putInt32 expire + , putInt32 min' + ] + (RD_SRV prio weight port dom) -> mconcat + [ putInt16 prio + , putInt16 weight + , putInt16 port + , encodeDomain dom + ] + +---------------------------------------------------------------- + +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 + ] + 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 + +encodePartialDomain :: Domain -> SPut +encodePartialDomain sub = putInt8 (BS.length sub) + +++ putByteString sub diff --git a/Network/DNS/Internal.hs b/Network/DNS/Internal.hs --- a/Network/DNS/Internal.hs +++ b/Network/DNS/Internal.hs @@ -151,7 +151,15 @@ defaultQuery = DNSFormat { header = DNSHeader { identifier = 0 - , flags = undefined + , flags = DNSFlags { + qOrR = QR_Query + , opcode = OP_STD + , authAnswer = False + , trunCation = False + , recDesired = True + , recAvailable = False + , rcode = NoErr + } , qdCount = 0 , anCount = 0 , nsCount = 0 @@ -162,3 +170,39 @@ , authority = [] , additional = [] } + +defaultResponse :: DNSFormat +defaultResponse = + let hd = header defaultQuery + flg = flags hd + in defaultQuery { + header = hd { + flags = flg { + qOrR = QR_Response + , authAnswer = True + , recAvailable = True + } + } + } + +responseA :: Int -> Question -> IPv4 -> DNSFormat +responseA ident q ip = + let hd = header defaultResponse + dom = qname q + an = ResourceRecord dom A 300 4 (RD_A ip) + in defaultResponse { + header = hd { identifier=ident, qdCount = 1, anCount = 1 } + , question = [q] + , answer = [an] + } + +responseAAAA :: Int -> Question -> IPv6 -> DNSFormat +responseAAAA ident q ip = + let hd = header defaultResponse + dom = qname q + an = ResourceRecord dom AAAA 300 16 (RD_AAAA ip) + in defaultResponse { + header = hd { identifier=ident, qdCount = 1, anCount = 1 } + , question = [q] + , answer = [an] + } diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs --- a/Network/DNS/Lookup.hs +++ b/Network/DNS/Lookup.hs @@ -25,7 +25,7 @@ lookupA :: Resolver -> Domain -> IO (Maybe [IPv4]) lookupA rlv dom = toV4 <$> DNS.lookup rlv dom A where - toV4 = maybe Nothing (Just . map unTag) + toV4 = fmap (map unTag) unTag (RD_A x) = x unTag _ = error "lookupA" @@ -35,7 +35,7 @@ lookupAAAA :: Resolver -> Domain -> IO (Maybe [IPv6]) lookupAAAA rlv dom = toV6 <$> DNS.lookup rlv dom AAAA where - toV6 = maybe Nothing (Just . map unTag) + toV6 = fmap (map unTag) unTag (RD_AAAA x) = x unTag _ = error "lookupAAAA" @@ -47,7 +47,7 @@ lookupMX :: Resolver -> Domain -> IO (Maybe [(Domain,Int)]) lookupMX rlv dom = toMX <$> DNS.lookup rlv dom MX where - toMX = maybe Nothing (Just . map unTag) + toMX = fmap (map unTag) unTag (RD_MX pr dm) = (dm,pr) unTag _ = error "lookupMX" @@ -81,7 +81,7 @@ lookupTXT :: Resolver -> Domain -> IO (Maybe [ByteString]) lookupTXT rlv dom = toTXT <$> DNS.lookup rlv dom TXT where - toTXT = maybe Nothing (Just . map unTag) + toTXT = fmap (map unTag) unTag (RD_TXT x) = x unTag _ = error "lookupTXT" @@ -93,7 +93,7 @@ lookupPTR :: Resolver -> Domain -> IO (Maybe [Domain]) lookupPTR rlv dom = toPTR <$> DNS.lookup rlv dom PTR where - toPTR = maybe Nothing (Just . map unTag) + toPTR = fmap (map unTag) unTag (RD_PTR dm) = dm unTag _ = error "lookupPTR" @@ -105,6 +105,6 @@ lookupSRV :: Resolver -> Domain -> IO (Maybe [(Int,Int,Int,Domain)]) lookupSRV rlv dom = toSRV <$> DNS.lookup rlv dom SRV where - toSRV = maybe Nothing (Just . map unTag) + toSRV = fmap (map unTag) unTag (RD_SRV pri wei prt dm) = (pri,wei,prt,dm) unTag _ = error "lookupSRV" diff --git a/Network/DNS/Query.hs b/Network/DNS/Query.hs deleted file mode 100644 --- a/Network/DNS/Query.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Network.DNS.Query (composeQuery) where - -import qualified Data.ByteString.Lazy.Char8 as BL (ByteString) -import qualified Data.ByteString as BS (unpack) -import qualified Data.ByteString.Char8 as BS (length, split, null) -import Network.DNS.StateBinary -import Network.DNS.Internal -import Data.Monoid - -(+++) :: Monoid a => a -> a -> a -(+++) = mappend - ----------------------------------------------------------------- - -composeQuery :: Int -> [Question] -> BL.ByteString -composeQuery idt qs = runSPut (encodeQuery qry) - where - hdr = header defaultQuery - qry = defaultQuery { - header = hdr { - identifier = idt - , qdCount = length qs - } - , question = qs - } - ----------------------------------------------------------------- - -encodeQuery :: DNSFormat -> SPut -encodeQuery fmt = encodeHeader hdr - +++ encodeQuestion qs - where - hdr = header fmt - qs = question fmt - -encodeHeader :: DNSHeader -> SPut -encodeHeader hdr = encodeIdentifier (identifier hdr) - +++ encodeFlags (flags hdr) - +++ decodeQdCount (qdCount hdr) - +++ decodeAnCount (anCount hdr) - +++ decodeNsCount (nsCount hdr) - +++ decodeArCount (arCount hdr) - where - encodeIdentifier = putInt16 - decodeQdCount = putInt16 - decodeAnCount = putInt16 - decodeNsCount = putInt16 - decodeArCount = putInt16 - -encodeFlags :: DNSFlags -> SPut -encodeFlags _ = put16 0x0100 -- xxx - -encodeQuestion :: [Question] -> SPut -encodeQuestion qs = encodeDomain dom - +++ putInt16 (typeToInt typ) - +++ put16 1 - where - q = head qs - dom = qname q - typ = qtype q - ----------------------------------------------------------------- - -encodeDomain :: Domain -> SPut -encodeDomain dom = foldr ((+++) . encodeSubDomain) (put8 0) $ zip ls ss - where - ss = filter (not . BS.null) $ BS.split '.' dom - ls = map BS.length ss - -encodeSubDomain :: (Int, Domain) -> SPut -encodeSubDomain (len,sub) = putInt8 len - +++ foldr ((+++) . put8) mempty ss - where - ss = BS.unpack sub diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs --- a/Network/DNS/Resolver.hs +++ b/Network/DNS/Resolver.hs @@ -21,26 +21,27 @@ -- ** Intermediate data type for resolver , ResolvSeed, makeResolvSeed -- ** Type and function for resolver - , Resolver, withResolver + , Resolver(..), withResolver -- ** Looking up functions , lookup, lookupRaw ) where import Control.Applicative import Control.Exception +import qualified Data.ByteString.Lazy as BL import Data.Char import Data.Int import Data.List hiding (find, lookup) import Network.BSD -import Network.DNS.Query -import Network.DNS.Response +import Network.DNS.Decode +import Network.DNS.Encode +import Network.DNS.Internal import Network.DNS.Types import Network.Socket hiding (send, sendTo, recv, recvFrom) import Network.Socket.ByteString.Lazy import Prelude hiding (lookup) import System.Random import System.Timeout -import Network.Socket.Enumerator ---------------------------------------------------------------- @@ -128,7 +129,7 @@ argument. 'withResolver' should be passed to 'forkIO'. -} -withResolver :: ResolvSeed -> (Resolver -> IO ()) -> IO () +withResolver :: ResolvSeed -> (Resolver -> IO a) -> IO a withResolver seed func = do let ai = addrInfo seed sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai) @@ -170,8 +171,7 @@ lookupRaw rlv dom typ = do seqno <- genId rlv sendAll sock (composeQuery seqno [q]) - let responseEnum = enumSocket bufsize sock - (>>= check seqno) <$> timeout tm (parseResponse responseEnum responseIter) + (>>= check seqno) <$> timeout tm (receive sock bufsize) where sock = dnsSock rlv bufsize = dnsBufsize rlv diff --git a/Network/DNS/Response.hs b/Network/DNS/Response.hs deleted file mode 100644 --- a/Network/DNS/Response.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Network.DNS.Response (responseIter, parseResponse) where - -import Control.Applicative -import Control.Monad -import Data.Bits -import qualified Data.ByteString.Char8 as BS -import Data.IP -import Data.Maybe -import Network.DNS.Internal -import Network.DNS.StateBinary -import Data.Enumerator (Enumerator, Iteratee, run_, ($$)) -import Data.ByteString (ByteString) - -responseIter :: Iteratee ByteString IO (DNSFormat, PState) -responseIter = runSGet decodeResponse - -parseResponse :: Enumerator ByteString IO (a,b) - -> Iteratee ByteString IO (a,b) - -> IO a -parseResponse enum iter = fst <$> run_ (enum $$ iter) - ----------------------------------------------------------------- - -decodeResponse :: SGet DNSFormat -decodeResponse = do - hd <- decodeHeader - DNSFormat hd <$> decodeQueries (qdCount hd) - <*> decodeRRs (anCount hd) - <*> decodeRRs (nsCount hd) - <*> decodeRRs (arCount hd) - ----------------------------------------------------------------- - -decodeFlags :: SGet DNSFlags -decodeFlags = toFlags <$> get16 - where - toFlags flgs = DNSFlags (getQorR flgs) - (getOpcode flgs) - (getAuthAnswer flgs) - (getTrunCation flgs) - (getRecDesired flgs) - (getRecAvailable flgs) - (getRcode flgs) - getQorR w = if testBit w 15 then QR_Response else QR_Query - getOpcode w = toEnum $ fromIntegral $ shiftR w 11 .&. 0x0f - getAuthAnswer w = testBit w 10 - getTrunCation w = testBit w 9 - getRecDesired w = testBit w 8 - getRecAvailable w = testBit w 7 - getRcode w = toEnum $ fromIntegral $ w .&. 0x0f - ----------------------------------------------------------------- - -decodeHeader :: SGet DNSHeader -decodeHeader = DNSHeader <$> decodeIdentifier - <*> decodeFlags - <*> decodeQdCount - <*> decodeAnCount - <*> decodeNsCount - <*> decodeArCount - where - decodeIdentifier = getInt16 - decodeQdCount = getInt16 - decodeAnCount = getInt16 - decodeNsCount = getInt16 - decodeArCount = getInt16 - ----------------------------------------------------------------- - -decodeQueries :: Int -> SGet [Question] -decodeQueries n = replicateM n decodeQuery - -decodeType :: SGet TYPE -decodeType = intToType <$> getInt16 - -decodeQuery :: SGet Question -decodeQuery = Question <$> decodeDomain - <*> (decodeType <* ignoreClass) - -decodeRRs :: Int -> SGet [ResourceRecord] -decodeRRs n = replicateM n decodeRR - -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 - } - where - decodeTTL = fromIntegral <$> get32 - decodeRLen = getInt16 - -decodeRData :: TYPE -> Int -> SGet RDATA -decodeRData NS _ = RD_NS <$> decodeDomain -decodeRData MX _ = RD_MX <$> decodePreference <*> decodeDomain - where - decodePreference = getInt16 -decodeRData CNAME _ = RD_CNAME <$> decodeDomain -decodeRData TXT len = (RD_TXT . ignoreLength) <$> getNByteString len - where - ignoreLength = BS.tail -decodeRData A len = (RD_A . toIPv4) <$> getNBytes len -decodeRData AAAA len = (RD_AAAA . toIPv6 . combine) <$> getNBytes len - where - combine [] = [] - combine [_] = error "combine" - combine (a:b:cs) = a * 256 + b : combine cs -decodeRData SOA _ = RD_SOA <$> decodeDomain - <*> decodeDomain - <*> decodeSerial - <*> decodeRefesh - <*> decodeRetry - <*> decodeExpire - <*> decodeMinumun - where - decodeSerial = getInt32 - decodeRefesh = getInt32 - decodeRetry = getInt32 - decodeExpire = getInt32 - decodeMinumun = getInt32 -decodeRData PTR _ = RD_PTR <$> decodeDomain -decodeRData SRV _ = RD_SRV <$> decodePriority - <*> decodeWeight - <*> decodePort - <*> decodeDomain - where - decodePriority = getInt16 - decodeWeight = getInt16 - decodePort = getInt16 - -decodeRData _ len = RD_OTH <$> getNBytes 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 - d <- getInt8 - let offset = n * 256 + d - fromMaybe (error $ "decodeDomain: " ++ show offset) <$> pop offset - else do - hs <- getNByteString n - ds <- decodeDomain - let dom = hs `BS.append` "." `BS.append` ds - push pos dom - return dom - where - getValue c = c .&. 0x3f - isPointer c = testBit c 7 && testBit c 6 - -ignoreClass :: SGet () -ignoreClass = () <$ get16 diff --git a/Network/DNS/StateBinary.hs b/Network/DNS/StateBinary.hs --- a/Network/DNS/StateBinary.hs +++ b/Network/DNS/StateBinary.hs @@ -1,43 +1,86 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Network.DNS.StateBinary where import Blaze.ByteString.Builder import Control.Applicative import Control.Monad.State +import Data.Monoid import Data.Attoparsec import Data.Attoparsec.Enumerator +import qualified Data.Attoparsec.Lazy as AL import Data.ByteString (ByteString) -import qualified Data.ByteString as BS (unpack) +import qualified Data.ByteString as BS (unpack, length) import qualified Data.ByteString.Lazy as BL (ByteString) import Data.Enumerator (Iteratee) import Data.Int import Data.IntMap (IntMap) import qualified Data.IntMap as IM (insert, lookup, empty) +import Data.Map (Map) +import qualified Data.Map as M (insert, lookup, empty) import Data.Word import Network.DNS.Types import Prelude hiding (lookup, take) ---------------------------------------------------------------- -type SPut = Write +type SPut = State WState Write +data WState = WState { + wsDomain :: Map Domain Int + , wsPosition :: Int +} + +initialWState :: WState +initialWState = WState M.empty 0 + +instance Monoid SPut where + mempty = return mempty + mappend a b = mconcat <$> sequence [a, b] + put8 :: Word8 -> SPut -put8 = writeWord8 +put8 = fixedSized 1 writeWord8 put16 :: Word16 -> SPut -put16 = writeWord16be +put16 = fixedSized 2 writeWord16be put32 :: Word32 -> SPut -put32 = writeWord32be +put32 = fixedSized 4 writeWord32be putInt8 :: Int -> SPut -putInt8 = writeInt8 . fromIntegral +putInt8 = fixedSized 1 (writeInt8 . fromIntegral) putInt16 :: Int -> SPut -putInt16 = writeInt16be . fromIntegral +putInt16 = fixedSized 2 (writeInt16be . fromIntegral) putInt32 :: Int -> SPut -putInt32 = writeInt32be . fromIntegral +putInt32 = fixedSized 4 (writeInt32be . fromIntegral) +putByteString :: ByteString -> SPut +putByteString = writeSized BS.length writeByteString + +addPositionW :: Int -> State WState () +addPositionW n = do + (WState m cur) <- get + put $ WState m (cur+n) + +fixedSized :: Int -> (a -> Write) -> a -> SPut +fixedSized n f a = do addPositionW n + return (f a) + +writeSized :: Show a => (a -> Int) -> (a -> Write) -> a -> SPut +writeSized n f a = do addPositionW (n a) + return (f a) + +wsPop :: Domain -> State WState (Maybe Int) +wsPop dom = do + doms <- gets wsDomain + return $ M.lookup dom doms + +wsPush :: Domain -> Int -> State WState () +wsPush dom pos = do + (WState m cur) <- get + put $ WState (M.insert dom pos m) cur + ---------------------------------------------------------------- type SGet = StateT PState Parser @@ -114,8 +157,11 @@ initialState :: PState initialState = PState IM.empty 0 -runSGet :: SGet a -> Iteratee ByteString IO (a, PState) -runSGet parser = iterParser (runStateT parser initialState) +iterSGet :: Monad m => SGet a -> Iteratee ByteString m (a, PState) +iterSGet parser = iterParser (runStateT parser initialState) +runSGet :: SGet a -> BL.ByteString -> Either String (a, PState) +runSGet parser bs = AL.eitherResult $ AL.parse (runStateT parser initialState) bs + runSPut :: SPut -> BL.ByteString -runSPut = toLazyByteString . fromWrite +runSPut = toLazyByteString . fromWrite . flip evalState initialWState diff --git a/Network/DNS/Types.hs b/Network/DNS/Types.hs --- a/Network/DNS/Types.hs +++ b/Network/DNS/Types.hs @@ -8,18 +8,19 @@ -- * TYPE , TYPE (..), intToType, typeToInt, toType -- * DNS Format - , DNSFormat, header, question, answer, authority, additional + , DNSFormat (DNSFormat), header, question, answer, authority, additional -- * DNS Header - , DNSHeader, identifier, flags, qdCount, anCount, nsCount, arCount + , DNSHeader (DNSHeader), identifier, flags, qdCount, anCount, nsCount, arCount -- * DNS Flags - , DNSFlags, qOrR, opcode, authAnswer, trunCation, recDesired, recAvailable, rcode + , DNSFlags (DNSFlags), qOrR, opcode, authAnswer, trunCation, recDesired, recAvailable, rcode -- * DNS Body , QorR (..) , OPCODE (..) , RCODE (..) - , ResourceRecord, rrname, rrtype, rrttl, rdlen, rdata - , Question, qname, qtype, makeQuestion + , ResourceRecord (ResourceRecord), rrname, rrtype, rrttl, rdlen, rdata + , Question (Question), qname, qtype, makeQuestion , RDATA (..) + , responseA, responseAAAA ) where import Network.DNS.Internal diff --git a/TestProtocol.hs b/TestProtocol.hs new file mode 100644 --- /dev/null +++ b/TestProtocol.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestProtocol where + +import Data.IP +import Network.DNS +import Network.DNS.Internal +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +tests :: [Test] +tests = + [ testGroup "Test case" + [ testCase "QueryA" (test_Format testQueryA) + , testCase "QueryAAAA" (test_Format testQueryAAAA) + , testCase "ResponseA" (test_Format testResponseA) + ] + ] + +defaultHeader :: DNSHeader +defaultHeader = header defaultQuery + +testQueryA :: DNSFormat +testQueryA = defaultQuery + { header = defaultHeader + { identifier = 1000 + , qdCount = 1 + } + , question = [makeQuestion "www.mew.org." A] + } + +testQueryAAAA :: DNSFormat +testQueryAAAA = defaultQuery + { header = defaultHeader + { identifier = 1000 + , qdCount = 1 + } + , question = [makeQuestion "www.mew.org." AAAA] + } + +testResponseA :: DNSFormat +testResponseA = DNSFormat { header = DNSHeader { identifier = 61046 + , flags = DNSFlags { qOrR = QR_Response + , opcode = OP_STD + , authAnswer = False + , trunCation = False + , recDesired = True + , recAvailable = True + , rcode = NoErr + } + , qdCount = 1 + , anCount = 8 + , nsCount = 2 + , arCount = 4 + } + , question = [Question {qname = "492056364.qzone.qq.com.", qtype = A}] + , answer = [ ResourceRecord { 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] + } + ] + , authority = [ ResourceRecord { 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." + } + ] + , additional = [ ResourceRecord { 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] + } + ] + } + +assertEither :: (a -> String) -> Either a b -> IO () +assertEither f = either (assertFailure . f) (const $ return ()) + +test_Format :: DNSFormat -> IO () +test_Format fmt = do + assertEither id result + let (Right fmt') = result + assertEqual "fail" fmt fmt' + where + bs = encode fmt + result = decode bs + +main :: IO () +main = defaultMain tests diff --git a/dns.cabal b/dns.cabal --- a/dns.cabal +++ b/dns.cabal @@ -1,18 +1,15 @@ Name: dns -Version: 0.2.1 +Version: 0.3.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: DNS libary in Haskell -Description: DNS libary. Currently only resolver side - is supported. That is, this library includes - a composer of DNS query and a parser of DNS - response. +Description: DNS libary for clients and servers. Category: Network Cabal-Version: >= 1.6 Build-Type: Simple -Extra-Source-Files: Test.hs +Extra-Source-Files: Test.hs, TestProtocol.hs library if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind @@ -22,10 +19,10 @@ Network.DNS.Lookup Network.DNS.Resolver Network.DNS.Types + Network.DNS.Encode + Network.DNS.Decode Other-Modules: Network.DNS.Internal Network.DNS.StateBinary - Network.DNS.Query - Network.DNS.Response if impl(ghc >= 7) Build-Depends: base >= 4 && < 5, binary, iproute,