dns 0.1.2 → 0.2.0

raw patch · 10 files changed

+169/−148 lines, 10 filesdep +attoparsecdep +attoparsec-enumeratordep +blaze-builderdep −haskell98PVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, attoparsec-enumerator, blaze-builder, enumerator, network-enumerator, random

Dependencies removed: haskell98

API changes (from Hackage documentation)

Files

• Network/DNS.hs +1/−2
• Network/DNS/Internal.hs +9/−8
• Network/DNS/Lookup.hs +7/−8
• Network/DNS/Query.hs +33/−37
• Network/DNS/Resolver.hs +7/−5
• Network/DNS/Response.hs +24/−21
• Network/DNS/StateBinary.hs +67/−55
• Network/DNS/Types.hs +6/−0
• Test.hs +4/−5
• dns.cabal +11/−7

@@ -2,8 +2,7 @@   Thread-safe DNS library written in Haskell.    Currently, only resolver side is supported. This code is written in-  Haskell, not using FFI. So, the \"-threaded\" option for GHC is not-  necessary.+  Haskell, not using FFI.    Sample code: 

@@ -1,6 +1,7 @@ module Network.DNS.Internal where -import qualified Data.ByteString.Lazy.Char8 as L+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS import Data.Char import Data.IP import Data.Maybe@@ -10,7 +11,7 @@ {-|   Type for domain. -}-type Domain = String+type Domain = ByteString  ---------------------------------------------------------------- @@ -126,17 +127,17 @@ -} data RDATA = RD_NS Domain | RD_CNAME Domain | RD_MX Int Domain            | RD_SOA Domain Domain Int Int Int Int Int-           | RD_A IPv4 | RD_AAAA IPv6 | RD_TXT L.ByteString+           | RD_A IPv4 | RD_AAAA IPv6 | RD_TXT ByteString            | RD_OTH [Int] deriving (Eq)  instance Show RDATA where-  show (RD_NS dom) = dom-  show (RD_MX prf dom) = dom ++ " " ++ show prf-  show (RD_CNAME dom) = dom+  show (RD_NS dom) = BS.unpack dom+  show (RD_MX prf dom) = BS.unpack dom ++ " " ++ show prf+  show (RD_CNAME dom) = BS.unpack dom   show (RD_A a) = show a   show (RD_AAAA aaaa) = show aaaa-  show (RD_TXT txt) = L.unpack txt-  show (RD_SOA mn _ _ _ _ _ mi) = mn ++ " " ++ show mi+  show (RD_TXT txt) = BS.unpack txt+  show (RD_SOA mn _ _ _ _ _ mi) = BS.unpack mn ++ " " ++ show mi   show (RD_OTH is) = show is  ----------------------------------------------------------------

@@ -9,7 +9,7 @@   ) where  import Control.Applicative-import qualified Data.ByteString.Lazy.Char8 as L+import Data.ByteString (ByteString) import Data.IP import Data.Maybe import Network.DNS.Resolver as DNS@@ -61,23 +61,22 @@ lookupAAAAviaMX :: Resolver -> Domain -> IO (Maybe [IPv6]) lookupAAAAviaMX rlv dom = lookupXviaMX rlv dom (lookupAAAA rlv) -lookupXviaMX :: Resolver -> Domain -> (Domain -> IO (Maybe [a])) -> IO (Maybe [a])+lookupXviaMX :: Show a => Resolver -> Domain -> (Domain -> IO (Maybe [a])) -> IO (Maybe [a]) lookupXviaMX rlv dom func = do     mdps <- lookupMX rlv dom     maybe (return Nothing) lookup' mdps   where-    lookup' dps = do-        as <- catMaybes <$> mapM (func . fst) dps-        case as of-          []  -> return Nothing-          ass -> return $ Just (concat ass)+    lookup' dps = check . catMaybes <$> mapM (func . fst) dps+    check as = case as of+        []  -> Nothing+        ass -> Just (concat ass)  ----------------------------------------------------------------  {-|   Resolving 'String' by 'TXT'. -}-lookupTXT :: Resolver -> Domain -> IO (Maybe [L.ByteString])+lookupTXT :: Resolver -> Domain -> IO (Maybe [ByteString]) lookupTXT rlv dom = toTXT <$> DNS.lookup rlv dom TXT   where     toTXT = maybe Nothing (Just . map unTag)

@@ -1,13 +1,18 @@ module Network.DNS.Query (composeQuery) where -import qualified Data.ByteString.Lazy.Char8 as L-import Data.Char+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] -> L.ByteString+composeQuery :: Int -> [Question] -> BL.ByteString composeQuery idt qs = runSPut (encodeQuery qry)   where     hdr = header defaultQuery@@ -22,21 +27,19 @@ ----------------------------------------------------------------  encodeQuery :: DNSFormat -> SPut-encodeQuery fmt = do-  let hdr = header fmt-      qs = question fmt-  encodeHeader hdr-  encodeQuestion qs-  return ()+encodeQuery fmt = encodeHeader hdr+              +++ encodeQuestion qs+  where+    hdr = header fmt+    qs = question fmt  encodeHeader :: DNSHeader -> SPut-encodeHeader hdr = do-    encodeIdentifier $ identifier hdr-    encodeFlags $ flags hdr-    decodeQdCount $ qdCount hdr-    decodeAnCount $ anCount hdr-    decodeNsCount $ nsCount hdr-    decodeArCount $ arCount hdr+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@@ -48,31 +51,24 @@ encodeFlags _ = put16 0x0100 -- xxx  encodeQuestion :: [Question] -> SPut-encodeQuestion qs = do-  let q = head qs-      dom = qname q-      typ = qtype q-  encodeDomain dom-  putInt16 . typeToInt $ typ-  put16 1+encodeQuestion qs = encodeDomain dom+                +++ putInt16 (typeToInt typ)+                +++ put16 1+  where+    q = head qs+    dom = qname q+    typ = qtype q  ----------------------------------------------------------------  encodeDomain :: Domain -> SPut-encodeDomain dom = do-    let ss = split '.' dom-        ls = map length ss-    mapM_ encodeSubDomain $ zip ls ss-    put8 0+encodeDomain dom = foldr ((+++) . encodeSubDomain) (put8 0) $ zip ls ss   where-    encodeSubDomain (len,sub) = do-      putInt8 len-      mapM_ (putInt8 . ord) sub+    ss = filter (not . BS.null) $ BS.split '.' dom+    ls = map BS.length ss -split :: Char -> String -> [String]-split _ "" = []-split c cs-  | null rest = s : split c rest-  | otherwise = s : split c (tail rest)+encodeSubDomain :: (Int, Domain) -> SPut+encodeSubDomain (len,sub) = putInt8 len+                        +++ foldr ((+++) . put8) mempty ss   where-    (s,rest) = break (c ==) cs+    ss = BS.unpack sub

@@ -38,8 +38,9 @@ import Network.Socket hiding (send, sendTo, recv, recvFrom) import Network.Socket.ByteString.Lazy import Prelude hiding (lookup)-import Random+import System.Random import System.Timeout+import Network.Socket.Enumerator  ---------------------------------------------------------------- @@ -55,7 +56,7 @@ data ResolvConf = ResolvConf {     resolvInfo :: FileOrNumericHost   , resolvTimeout :: Int-  , resolvBufsize :: Int64+  , resolvBufsize :: Integer }  {-|@@ -79,7 +80,7 @@ data ResolvSeed = ResolvSeed {     addrInfo :: AddrInfo   , rsTimeout :: Int-  , rsBufsize :: Int64+  , rsBufsize :: Integer }  {-|@@ -89,7 +90,7 @@     genId   :: IO Int   , dnsSock :: Socket   , dnsTimeout :: Int-  , dnsBufsize :: Int64+  , dnsBufsize :: Integer }  ----------------------------------------------------------------@@ -169,7 +170,8 @@ lookupRaw rlv dom typ = do     seqno <- genId rlv     sendAll sock (composeQuery seqno [q])-    (>>= check seqno) <$> timeout tm (parseResponse <$> recv sock bufsize)+    let responseEnum = enumSocket bufsize sock+    (>>= check seqno) <$> timeout tm (parseResponse responseEnum responseIter)   where     sock = dnsSock rlv     bufsize = dnsBufsize rlv

@@ -1,18 +1,25 @@-module Network.DNS.Response (parseResponse) where+{-# LANGUAGE OverloadedStrings #-} +module Network.DNS.Response (responseIter, parseResponse) where++import Control.Applicative import Control.Monad import Data.Bits-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Char+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 :: L.ByteString -> DNSFormat-parseResponse = runSGet decodeResponse+parseResponse :: Enumerator ByteString IO (a,b)+              -> Iteratee ByteString IO (a,b)+              -> IO a+parseResponse enum iter = fst <$> run_ (enum $$ iter)  ---------------------------------------------------------------- @@ -27,16 +34,15 @@ ----------------------------------------------------------------  decodeFlags :: SGet DNSFlags-decodeFlags = do-  flgs <- get16-  return $ DNSFlags (getQorR flgs)-                    (getOpcode flgs)-                    (getAuthAnswer flgs)-                    (getTrunCation flgs)-                    (getRecDesired flgs)-                    (getRecAvailable flgs)-                    (getRcode flgs)+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@@ -100,7 +106,7 @@ decodeRData CNAME _ = RD_CNAME <$> decodeDomain decodeRData TXT len = (RD_TXT . ignoreLength) <$> getNByteString len   where-    ignoreLength = L.tail+    ignoreLength = BS.tail decodeRData A len  = (RD_A . toIPv4) <$> getNBytes len decodeRData AAAA len  = (RD_AAAA . toIPv6 . combine) <$> getNBytes len   where@@ -139,17 +145,14 @@             let offset = n * 256 + d             fromMaybe (error $ "decodeDomain: " ++ show offset) <$> pop offset           else do-            hs <- decodeString n+            hs <- getNByteString n             ds <- decodeDomain-            let dom = hs ++ "." ++ ds+            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--decodeString :: Int -> SGet String-decodeString n = map chr <$> getNBytes n  ignoreClass :: SGet () ignoreClass = () <$ get16

@@ -1,71 +1,94 @@ module Network.DNS.StateBinary where +import Blaze.ByteString.Builder+import Control.Applicative import Control.Monad.State-import Data.Binary.Get-import Data.Binary.Put-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Char+import Data.Attoparsec+import Data.Attoparsec.Enumerator+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS (unpack)+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.Word import Network.DNS.Types-import Prelude hiding (lookup)+import Prelude hiding (lookup, take)  ---------------------------------------------------------------- -type SGet = StateT PState Get+type SPut = Write -type PState = IntMap Domain+put8 :: Word8 -> SPut+put8  = writeWord8 -----------------------------------------------------------------+put16 :: Word16 -> SPut+put16 = writeWord16be -(<$>) :: (Monad m) => (a -> b) -> m a -> m b-(<$>) = liftM+put32 :: Word32 -> SPut+put32 = writeWord32be -(<$) :: (Monad m) => b -> m a -> m b-x <$ y = y >> return x+putInt8 :: Int -> SPut+putInt8  = writeInt8 . fromIntegral -(<*>) :: (Monad m) => m (a -> b) -> m a -> m b-(<*>) = ap+putInt16 :: Int -> SPut+putInt16 = writeInt16be . fromIntegral -(<*) :: (Monad m) => m a -> m b -> m a-(<*) ma mb = do-    a <- ma-    mb-    return a+putInt32 :: Int -> SPut+putInt32 = writeInt32be . fromIntegral  ---------------------------------------------------------------- -type SPut = Put+type SGet = StateT PState Parser -put8 :: Word8 -> SPut-put8  = putWord8+data PState = PState {+    psDomain :: IntMap Domain+  , psPosition :: Int+  } -put16 :: Word16 -> SPut-put16 = putWord16be+---------------------------------------------------------------- -put32 :: Word32 -> SPut-put32 = putWord32be+getPosition :: SGet Int+getPosition = psPosition <$> get -putInt8 :: Int -> SPut-putInt8  = put8  . fromIntegral+addPosition :: Int -> SGet ()+addPosition n = do+    PState dom pos <- get+    put $ PState dom (pos + n) -putInt16 :: Int -> SPut-putInt16 = put16 . fromIntegral+push :: Int -> Domain -> SGet ()+push n d = do+    PState dom pos <- get+    put $ PState (IM.insert n d dom) pos -putInt32 :: Int -> SPut-putInt32 = put32 . fromIntegral+pop :: Int -> SGet (Maybe Domain)+pop n = IM.lookup n . psDomain <$> get  ----------------------------------------------------------------  get8 :: SGet Word8-get8  = lift getWord8+get8  = lift anyWord8 <* addPosition 1  get16 :: SGet Word16-get16 = lift getWord16be+get16 = lift getWord16be <* addPosition 2+  where+    word8' = fromIntegral <$> anyWord8+    getWord16be = do+        a <- word8'+        b <- word8'+        return $ a * 256 + b  get32 :: SGet Word32-get32 = lift getWord32be+get32 = lift getWord32be <* addPosition 4+  where+    word8' = fromIntegral <$> anyWord8+    getWord32be = do+        a <- word8'+        b <- word8'+        c <- word8'+        d <- word8'+        return $ a * 1677721 + b * 65536 + c * 256 + d  getInt8 :: SGet Int getInt8 = fromIntegral <$> get8@@ -78,32 +101,21 @@  ---------------------------------------------------------------- -getPosition :: SGet Int-getPosition = fromIntegral <$> lift bytesRead- getNBytes :: Int -> SGet [Int] getNBytes len = toInts <$> getNByteString len   where-    toInts = map ord . L.unpack--getNByteString :: Int -> SGet L.ByteString-getNByteString len = lift . getLazyByteString . fromIntegral $ len--------------------------------------------------------------------push :: Int -> Domain -> SGet ()-push n d = modify (IM.insert n d)+    toInts = map fromIntegral . BS.unpack -pop :: Int -> SGet (Maybe Domain)-pop n = IM.lookup n <$> get+getNByteString :: Int -> SGet ByteString+getNByteString n = lift (take n) <* addPosition n  ---------------------------------------------------------------- -initialState :: IntMap Domain-initialState = IM.empty+initialState :: PState+initialState = PState IM.empty 0 -runSGet :: SGet DNSFormat -> L.ByteString -> DNSFormat-runSGet res bs = fst $ runGet (runStateT res initialState) bs+runSGet :: SGet a -> Iteratee ByteString IO (a, PState)+runSGet parser = iterParser (runStateT parser initialState) -runSPut :: Put -> L.ByteString-runSPut = runPut+runSPut :: SPut -> BL.ByteString+runSPut = toLazyByteString . fromWrite

@@ -3,11 +3,17 @@ -}  module Network.DNS.Types (+  -- * Domain     Domain+  -- * TYPE   , TYPE (..), intToType, typeToInt, toType+  -- * DNS Format   , DNSFormat, header, question, answer, authority, additional+  -- * DNS Header   , DNSHeader, identifier, flags, qdCount, anCount, nsCount, arCount+  -- * DNS Flags   , DNSFlags, qOrR, opcode, authAnswer, trunCation, recDesired, recAvailable, rcode+  -- * DNS Body   , QorR (..)   , OPCODE (..)   , RCODE (..)

@@ -2,7 +2,6 @@  module Test where -import Data.IP import Data.List import Network.DNS as DNS import Test.Framework (defaultMain, testGroup, Test)@@ -27,7 +26,7 @@ test_lookupA = do     rs <- makeResolvSeed defaultResolvConf     withResolver rs $ \resolver ->-        DNS.lookupA resolver "www.mew.org" ?= Just [toIPv4 [202,232,15,101]]+        DNS.lookupA resolver "www.mew.org" ?= Just ["202.232.15.101"]  (??=) :: (Ord a, Show a) => IO (Maybe [a]) -> [a] -> IO () a ??= bs = do@@ -41,7 +40,7 @@     rs <- makeResolvSeed defaultResolvConf     withResolver rs $ \resolver -> do         DNS.lookupAAAA resolver "mew.org" ?= Nothing-        DNS.lookupAAAA resolver "www.mew.org" ?= Just [read "2001:240:11e:c00::101"]+        DNS.lookupAAAA resolver "www.mew.org" ?= Just ["2001:240:11e:c00::101"]  test_lookupTXT :: IO () test_lookupTXT = do@@ -53,13 +52,13 @@ test_lookupAviaMX = do     rs <- makeResolvSeed defaultResolvConf     withResolver rs $ \resolver ->-        DNS.lookupAviaMX resolver "mixi.jp" ??= [read "202.32.29.4", read "202.32.29.5"]+        DNS.lookupAviaMX resolver "mixi.jp" ??= ["202.32.29.4", "202.32.29.5"]  test_lookupAviaCNAME :: IO () test_lookupAviaCNAME = do     rs <- makeResolvSeed defaultResolvConf     withResolver rs $ \resolver ->-        DNS.lookupA resolver "foundry1.hongo.wide.ad.jp" ??= [read "203.178.135.1", read "203.178.138.230"]+        DNS.lookupA resolver "ghs.google.com" ??= ["72.14.203.121"]  main :: IO () main = defaultMain tests

@@ -1,5 +1,5 @@ Name:                   dns-Version:                0.1.2+Version:                0.2.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -27,15 +27,19 @@                         Network.DNS.Query                         Network.DNS.Response   if impl(ghc >= 7)-    Build-Depends:      base >= 4 && < 5, haskell98,+    Build-Depends:      base >= 4 && < 5,                         binary, iproute,-                        containers, mtl, bytestring,-                        network >= 2.3+                        containers, mtl, bytestring, random,+                        network >= 2.3, blaze-builder,+                        attoparsec, enumerator, attoparsec-enumerator,+                        network-enumerator   else-    Build-Depends:      base >= 4 && < 5, haskell98,+    Build-Depends:      base >= 4 && < 5,                         binary, iproute,-                        containers, mtl, bytestring,-                        network, network-bytestring+                        containers, mtl, bytestring, random,+                        network, network-bytestring, blaze-builder,+                        attoparsec, enumerator, attoparsec-enumerator,+                        network-enumerator Source-Repository head   Type:                 git   Location:             git://github.com/kazu-yamamoto/dns.git