dns (empty) → 0.1.0
raw patch · 12 files changed
+946/−0 lines, 12 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, containers, haskell98, iproute, mtl, network, network-bytestring
Files
- LICENSE +29/−0
- Network/DNS.hs +29/−0
- Network/DNS/Internal.hs +158/−0
- Network/DNS/Lookup.hs +85/−0
- Network/DNS/Query.hs +78/−0
- Network/DNS/Resolver.hs +182/−0
- Network/DNS/Response.hs +155/−0
- Network/DNS/StateBinary.hs +109/−0
- Network/DNS/Types.hs +19/−0
- Setup.hs +2/−0
- Test.hs +65/−0
- dns.cabal +35/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2009, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in+ the documentation and/or other materials provided with the+ distribution.+ * Neither the name of the copyright holders nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Network/DNS.hs view
@@ -0,0 +1,29 @@+{-|+ 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.++ Sample code:++@+ import qualified Network.DNS as DNS (lookup)+ import Network.DNS hiding (lookup)+ main :: IO ()+ main = do+ rs <- makeResolvSeed defaultResolvConf+ withResolver rs $ \\resolver -> do+ DNS.lookup resolver \"www.example.com\" A >>= print+@+-}++module Network.DNS (+ module Network.DNS.Lookup+ , module Network.DNS.Resolver+ , module Network.DNS.Types+ ) where++import Network.DNS.Lookup+import Network.DNS.Resolver+import Network.DNS.Types
+ Network/DNS/Internal.hs view
@@ -0,0 +1,158 @@+module Network.DNS.Internal where++import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char+import Data.IP+import Data.Maybe++----------------------------------------------------------------++{-|+ Type for domain.+-}+type Domain = String++----------------------------------------------------------------++{-|+ Types for resource records.+-}+data TYPE = A | AAAA | NS | TXT | MX | CNAME | SOA+ | UNKNOWN Int deriving (Eq, Show, Read)++rrDB :: [(TYPE, Int)]+rrDB = [+ (A, 1)+ , (NS, 2)+ , (CNAME, 5)+ , (SOA, 6)+ , (MX, 15)+ , (TXT, 16)+ , (AAAA, 28)+ ]++rookup :: (Eq b) => b -> [(a,b)] -> Maybe a+rookup _ [] = Nothing+rookup key ((x,y):xys)+ | key == y = Just x+ | otherwise = rookup key xys++intToType :: Int -> TYPE+intToType n = fromMaybe (UNKNOWN n) $ rookup n rrDB+typeToInt :: TYPE -> Int+typeToInt (UNKNOWN x) = x+typeToInt t = fromMaybe 0 $ lookup t rrDB++toType :: String -> TYPE+toType = read . map toUpper++----------------------------------------------------------------++{-|+ Raw data format for DNS Query and Response.+-}+data DNSFormat = DNSFormat {+ header :: DNSHeader+ , question :: [Question]+ , answer :: [ResourceRecord]+ , authority :: [ResourceRecord]+ , additional :: [ResourceRecord]+ } deriving (Eq, Show)++{-|+ Raw data format for the header of DNS Query and Response.+-}+data DNSHeader = DNSHeader {+ identifier :: Int+ , flags :: DNSFlags+ , qdCount :: Int+ , anCount :: Int+ , nsCount :: Int+ , arCount :: Int+ } deriving (Eq, Show)++{-|+ Raw data format for the flags of DNS Query and Response.+-}+data DNSFlags = DNSFlags {+ qOrR :: QorR+ , opcode :: OPCODE+ , authAnswer :: Bool+ , trunCation :: Bool+ , recDesired :: Bool+ , recAvailable :: Bool+ , rcode :: RCODE+ } deriving (Eq, Show)++----------------------------------------------------------------++data QorR = QR_Query | QR_Response deriving (Eq, Show)++data OPCODE = OP_STD | OP_INV | OP_SSR deriving (Eq, Show, Enum)++data RCODE = NoErr | FormatErr | ServFail | NameErr | NotImpl | Refused deriving (Eq, Show, Enum)++----------------------------------------------------------------++{-|+ Raw data format for DNS questions.+-}+data Question = Question {+ qname :: Domain+ , qtype :: TYPE+ } deriving (Eq, Show)++{-|+ Making "Question".+-}+makeQuestion :: Domain -> TYPE -> Question+makeQuestion = Question++----------------------------------------------------------------++{-|+ Raw data format for resource records.+-}+data ResourceRecord = ResourceRecord {+ rrname :: Domain+ , rrtype :: TYPE+ , rrttl :: Int+ , rdlen :: Int+ , rdata :: RDATA+ } deriving (Eq, Show)++{-|+ Raw data format for each type.+-}+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_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_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_OTH is) = show is++----------------------------------------------------------------++defaultQuery :: DNSFormat+defaultQuery = DNSFormat {+ header = DNSHeader {+ identifier = 0+ , flags = undefined+ , qdCount = 0+ , anCount = 0+ , nsCount = 0+ , arCount = 0+ }+ , question = []+ , answer = []+ , authority = []+ , additional = []+ }
+ Network/DNS/Lookup.hs view
@@ -0,0 +1,85 @@+{-|+ Upper level DNS lookup functions.+-}++module Network.DNS.Lookup (+ lookupA, lookupAAAA+ , lookupMX, lookupAviaMX, lookupAAAAviaMX+ , lookupTXT+ ) where++import Control.Applicative+import qualified Data.ByteString.Lazy.Char8 as L+import Data.IP+import Data.Maybe+import Network.DNS.Resolver as DNS+import Network.DNS.Types++----------------------------------------------------------------++{-|+ Resolving 'IPv4' by 'A'.+-}+lookupA :: Resolver -> Domain -> IO (Maybe [IPv4])+lookupA rlv dom = toV4 <$> DNS.lookup rlv dom A+ where+ toV4 = maybe Nothing (Just . map unTag)+ unTag (RD_A x) = x+ unTag _ = error "lookupA"++{-|+ Resolving 'IPv6' by 'AAAA'.+-}+lookupAAAA :: Resolver -> Domain -> IO (Maybe [IPv6])+lookupAAAA rlv dom = toV6 <$> DNS.lookup rlv dom AAAA+ where+ toV6 = maybe Nothing (Just . map unTag)+ unTag (RD_AAAA x) = x+ unTag _ = error "lookupAAAA"++----------------------------------------------------------------++{-|+ Resolving 'Domain' and its preference by 'MX'.+-}+lookupMX :: Resolver -> Domain -> IO (Maybe [(Domain,Int)])+lookupMX rlv dom = toMX <$> DNS.lookup rlv dom MX+ where+ toMX = maybe Nothing (Just . map unTag)+ unTag (RD_MX pr dm) = (dm,pr)+ unTag _ = error "lookupMX"++{-|+ Resolving 'IPv4' by 'A' via 'MX'.+-}+lookupAviaMX :: Resolver -> Domain -> IO (Maybe [IPv4])+lookupAviaMX rlv dom = lookupXviaMX rlv dom (lookupA rlv)++{-|+ Resolving 'IPv6' by 'AAAA' via 'MX'.+-}+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 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)++----------------------------------------------------------------++{-|+ Resolving 'String' by 'TXT'.+-}+lookupTXT :: Resolver -> Domain -> IO (Maybe [L.ByteString])+lookupTXT rlv dom = toTXT <$> DNS.lookup rlv dom TXT+ where+ toTXT = maybe Nothing (Just . map unTag)+ unTag (RD_TXT x) = x+ unTag _ = error "lookupTXT"
+ Network/DNS/Query.hs view
@@ -0,0 +1,78 @@+module Network.DNS.Query (composeQuery) where++import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char+import Network.DNS.StateBinary+import Network.DNS.Internal++----------------------------------------------------------------++composeQuery :: Int -> [Question] -> L.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 = do+ let hdr = header fmt+ qs = question fmt+ encodeHeader hdr+ encodeQuestion qs+ return ()++encodeHeader :: DNSHeader -> SPut+encodeHeader hdr = do+ 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 = do+ let q = head qs+ dom = qname q+ typ = qtype q+ encodeDomain dom+ putInt16 . typeToInt $ typ+ put16 1++----------------------------------------------------------------++encodeDomain :: Domain -> SPut+encodeDomain dom = do+ let ss = split '.' dom+ ls = map length ss+ mapM_ encodeSubDomain $ zip ls ss+ put8 0+ where+ encodeSubDomain (len,sub) = do+ putInt8 len+ mapM_ (putInt8 . ord) sub++split :: Char -> String -> [String]+split _ "" = []+split c cs+ | null rest = s : split c rest+ | otherwise = s : split c (tail rest)+ where+ (s,rest) = break (c ==) cs
+ Network/DNS/Resolver.hs view
@@ -0,0 +1,182 @@+{-|+ DNS Resolver and lookup functions.++ Sample code:++@+ import qualified Network.DNS as DNS (lookup)+ import Network.DNS hiding (lookup)+ main :: IO ()+ main = do+ rs <- makeResolvSeed defaultResolvConf+ withResolver rs $ \\resolver -> do+ DNS.lookup resolver \"www.example.com\" A >>= print+@+-}++module Network.DNS.Resolver (+ -- * Documentation+ -- ** Configuration for resolver+ FileOrNumericHost(..), ResolvConf(..), defaultResolvConf+ -- ** Intermediate data type for resolver+ , ResolvSeed, makeResolvSeed+ -- ** Type and function for resolver+ , Resolver, withResolver+ -- ** Looking up functions+ , lookup, lookupRaw+ ) where++import Control.Applicative+import Control.Exception+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.Types+import Network.Socket hiding (send, sendTo, recv, recvFrom)+import Network.Socket.ByteString.Lazy+import Prelude hiding (lookup)+import Random+import System.Timeout++----------------------------------------------------------------++{-|+ Union type for 'FilePath' and 'HostName'. Specify 'FilePath' to+ \"resolv.conf\" or numeric IP address in 'String' form.+-}+data FileOrNumericHost = RCFilePath FilePath | RCHostName HostName++{-|+ Type for resolver configuration+-}+data ResolvConf = ResolvConf {+ resolvInfo :: FileOrNumericHost+ , resolvTimeout :: Int+ , resolvBufsize :: Int64+}++{-|+ Default 'ResolvConf'.+ 'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\".+ 'resolvTimeout' is 3,000,000 micro seconds.+ 'resolvBufsize' is 512.+-}+defaultResolvConf :: ResolvConf+defaultResolvConf = ResolvConf {+ resolvInfo = RCFilePath "/etc/resolv.conf"+ , resolvTimeout = 3 * 1000 * 1000+ , resolvBufsize = 512+}++----------------------------------------------------------------++{-|+ Abstract data type of DNS Resolver seed+-}+data ResolvSeed = ResolvSeed {+ addrInfo :: AddrInfo+ , rsTimeout :: Int+ , rsBufsize :: Int64+}++{-|+ Abstract data type of DNS Resolver+-}+data Resolver = Resolver {+ genId :: IO Int+ , dnsSock :: Socket+ , dnsTimeout :: Int+ , dnsBufsize :: Int64+}++----------------------------------------------------------------++{-|+ Making 'ResolvSeed' from an IP address of a DNS cache server.+-}+makeResolvSeed :: ResolvConf -> IO ResolvSeed+makeResolvSeed conf = ResolvSeed <$> addr+ <*> pure (resolvTimeout conf)+ <*> pure (resolvBufsize conf)+ where+ addr = case resolvInfo conf of+ RCHostName numhost -> makeAddrInfo numhost+ RCFilePath file -> toAddr <$> readFile file >>= makeAddrInfo+ toAddr cs = let l:_ = filter ("nameserver" `isPrefixOf`) $ lines cs+ in extract l+ extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11++makeAddrInfo :: HostName -> IO AddrInfo+makeAddrInfo addr = do+ proto <- getProtocolNumber "udp"+ let hints = defaultHints {+ addrFlags = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_PASSIVE]+ , addrSocketType = Datagram+ , addrProtocol = proto+ }+ a:_ <- getAddrInfo (Just hints) (Just addr) (Just "domain")+ return a++----------------------------------------------------------------++{-|+ Giving a thread-safe 'Resolver' to the function of the second+ argument. 'withResolver' should be passed to 'forkIO'.+-}++withResolver :: ResolvSeed -> (Resolver -> IO ()) -> IO ()+withResolver seed func = do+ let ai = addrInfo seed+ sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)+ connect sock (addrAddress ai)+ let resolv = Resolver {+ genId = getRandom+ , dnsSock = sock+ , dnsTimeout = rsTimeout seed+ , dnsBufsize = rsBufsize seed+ }+ func resolv `finally` sClose sock++getRandom :: IO Int+getRandom = getStdRandom (randomR (0,65535))++----------------------------------------------------------------++{-|+ Looking up resource records of a domain.+-}+lookup :: Resolver -> Domain -> TYPE -> IO (Maybe [RDATA])+lookup rlv dom typ = (>>= toRDATA) <$> lookupRaw rlv dom typ+ where+ {- CNAME hack+ dom' = if "." `isSuffixOf` dom+ then dom+ else dom ++ "."+ correct r = rrname r == dom' && rrtype r == typ+ -}+ correct r = rrtype r == typ+ listToMaybe [] = Nothing+ listToMaybe xs = Just xs+ toRDATA = listToMaybe . map rdata . filter correct . answer++{-|+ Looking up a domain and returning an entire DNS Response.+-}+lookupRaw :: Resolver -> Domain -> TYPE -> IO (Maybe DNSFormat)+lookupRaw rlv dom typ = do+ seqno <- genId rlv+ sendAll sock (composeQuery seqno [q])+ (>>= check seqno) <$> timeout tm (parseResponse <$> recv sock bufsize)+ where+ sock = dnsSock rlv+ bufsize = dnsBufsize rlv+ tm = dnsTimeout rlv+ q = makeQuestion dom typ+ check seqno res = do+ let hdr = header res+ if identifier hdr == seqno && anCount hdr /= 0+ then Just res+ else Nothing
+ Network/DNS/Response.hs view
@@ -0,0 +1,155 @@+module Network.DNS.Response (parseResponse) where++import Control.Monad+import Data.Bits+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char+import Data.IP+import Data.Maybe+import Network.DNS.Internal+import Network.DNS.StateBinary++----------------------------------------------------------------++parseResponse :: L.ByteString -> DNSFormat+parseResponse = runSGet 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 = do+ flgs <- get16+ return $ DNSFlags (getQorR flgs)+ (getOpcode flgs)+ (getAuthAnswer flgs)+ (getTrunCation flgs)+ (getRecDesired flgs)+ (getRecAvailable flgs)+ (getRcode flgs)+ where+ 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 = L.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 _ 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 <- decodeString n+ ds <- decodeDomain+ let dom = hs ++ "." ++ 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
+ Network/DNS/StateBinary.hs view
@@ -0,0 +1,109 @@+module Network.DNS.StateBinary where++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.IntMap (IntMap)+import qualified Data.IntMap as IM (insert, lookup, empty)+import Data.Word+import Network.DNS.Types+import Prelude hiding (lookup)++----------------------------------------------------------------++type SGet = StateT PState Get++type PState = IntMap Domain++----------------------------------------------------------------++(<$>) :: (Monad m) => (a -> b) -> m a -> m b+(<$>) = liftM++(<$) :: (Monad m) => b -> m a -> m b+x <$ y = y >> return x++(<*>) :: (Monad m) => m (a -> b) -> m a -> m b+(<*>) = ap++(<*) :: (Monad m) => m a -> m b -> m a+(<*) ma mb = do+ a <- ma+ mb+ return a++----------------------------------------------------------------++type SPut = Put++put8 :: Word8 -> SPut+put8 = putWord8++put16 :: Word16 -> SPut+put16 = putWord16be++put32 :: Word32 -> SPut+put32 = putWord32be++putInt8 :: Int -> SPut+putInt8 = put8 . fromIntegral++putInt16 :: Int -> SPut+putInt16 = put16 . fromIntegral++putInt32 :: Int -> SPut+putInt32 = put32 . fromIntegral++----------------------------------------------------------------++get8 :: SGet Word8+get8 = lift getWord8++get16 :: SGet Word16+get16 = lift getWord16be++get32 :: SGet Word32+get32 = lift getWord32be++getInt8 :: SGet Int+getInt8 = fromIntegral <$> get8++getInt16 :: SGet Int+getInt16 = fromIntegral <$> get16++getInt32 :: SGet Int+getInt32 = fromIntegral <$> get32++----------------------------------------------------------------++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)++pop :: Int -> SGet (Maybe Domain)+pop n = IM.lookup n <$> get++----------------------------------------------------------------++initialState :: IntMap Domain+initialState = IM.empty++runSGet :: SGet DNSFormat -> L.ByteString -> DNSFormat+runSGet res bs = fst $ runGet (runStateT res initialState) bs++runSPut :: Put -> L.ByteString+runSPut = runPut
+ Network/DNS/Types.hs view
@@ -0,0 +1,19 @@+{-|+ Data types for DNS Query and Response. For more information, see <http://www.ietf.org/rfc/rfc1035>.+-}++module Network.DNS.Types (+ Domain+ , TYPE (..), intToType, typeToInt, toType+ , DNSFormat, header, question, answer, authority, additional+ , DNSHeader, identifier, flags, qdCount, anCount, nsCount, arCount+ , DNSFlags, qOrR, opcode, authAnswer, trunCation, recDesired, recAvailable, rcode+ , QorR (..)+ , OPCODE (..)+ , RCODE (..)+ , ResourceRecord, rrname, rrtype, rrttl, rdlen, rdata+ , Question, qname, qtype, makeQuestion+ , RDATA (..)+ ) where++import Network.DNS.Internal
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module Test where++import Data.IP+import Data.List+import Network.DNS as DNS+import Test.Framework (defaultMain, testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)++tests :: [Test]+tests = [+ testGroup "Test case" [+ testCase "lookupA" test_lookupA+ , testCase "lookupAAAA" test_lookupAAAA+ , testCase "lookupTXT" test_lookupTXT+ , testCase "lookupAviaMX" test_lookupAviaMX+ , testCase "lookupAviaCNAME" test_lookupAviaCNAME+ ]+ ]++(?=) :: (Eq a, Show a) => IO a -> a -> IO ()+a ?= b = a >>= (@?= b)++test_lookupA :: IO ()+test_lookupA = do+ rs <- makeResolvSeed defaultResolvConf+ withResolver rs $ \resolver ->+ DNS.lookupA resolver "www.mew.org" ?= Just [toIPv4 [202,232,15,101]]++(??=) :: (Ord a, Show a) => IO (Maybe [a]) -> [a] -> IO ()+a ??= bs = do+ mas <- a+ case mas of+ Nothing -> False @? "should be Nothing"+ Just as -> sort as @?= sort bs++test_lookupAAAA :: IO ()+test_lookupAAAA = do+ 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"]++test_lookupTXT :: IO ()+test_lookupTXT = do+ rs <- makeResolvSeed defaultResolvConf+ withResolver rs $ \resolver ->+ DNS.lookupTXT resolver "mew.org" ?= Just ["v=spf1 +mx -all"]++test_lookupAviaMX :: IO ()+test_lookupAviaMX = do+ rs <- makeResolvSeed defaultResolvConf+ withResolver rs $ \resolver ->+ DNS.lookupAviaMX resolver "mixi.jp" ??= [read "202.32.29.4", read "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"]++main :: IO ()+main = defaultMain tests
+ dns.cabal view
@@ -0,0 +1,35 @@+Name: dns+Version: 0.1.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.+Category: Network+Cabal-Version: >= 1.6+Build-Type: Simple+Extra-Source-Files: Test.hs+library+ if impl(ghc >= 6.12)+ GHC-Options: -Wall -fno-warn-unused-do-bind+ else+ GHC-Options: -Wall+ Exposed-Modules: Network.DNS+ Network.DNS.Lookup+ Network.DNS.Resolver+ Network.DNS.Types+ Other-Modules: Network.DNS.Internal+ Network.DNS.StateBinary+ Network.DNS.Query+ Network.DNS.Response+ Build-Depends: base >= 4 && < 5, haskell98,+ binary, iproute,+ containers, mtl, bytestring,+ network, network-bytestring+Source-Repository head+ Type: git+ Location: git://github.com/kazu-yamamoto/dns.git