dns 0.2.1 → 0.3.0

raw patch · 12 files changed

+645/−282 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Network/DNS.hs +10/−3
• Network/DNS/Decode.hs +190/−0
• Network/DNS/Encode.hs +159/−0
• Network/DNS/Internal.hs +45/−1
• Network/DNS/Lookup.hs +6/−6
• Network/DNS/Query.hs +0/−74
• Network/DNS/Resolver.hs +7/−7
• Network/DNS/Response.hs +0/−167
• Network/DNS/StateBinary.hs +57/−11
• Network/DNS/Types.hs +6/−5
• TestProtocol.hs +160/−0
• dns.cabal +5/−8

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

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

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

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

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

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

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

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

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

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

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

@@ -1,18 +1,15 @@ Name:                   dns-Version:                0.2.1+Version:                0.3.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> 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,