Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

initial import.

  • Loading branch information...
commit 25bc0634cdec8d67bd92cf6265b6f0a0ca6e91aa 0 parents
@kazu-yamamoto authored
1  .gitignore
@@ -0,0 +1 @@
+dist/
29 LICENSE
@@ -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.
4 Network/DNS.hs
@@ -0,0 +1,4 @@
+module Network.DNS (parseResponse, composeQuery) where
+
+import Network.DNS.Query
+import Network.DNS.Response
78 Network/DNS/Query.hs
@@ -0,0 +1,78 @@
+module Network.DNS.Query (composeQuery) where
+
+import Data.ByteString.Lazy (ByteString)
+import Data.Char
+import Network.DNS.StateBinary
+import Network.DNS.Types
+
+----------------------------------------------------------------
+
+composeQuery :: Int -> [Question] -> 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
133 Network/DNS/Response.hs
@@ -0,0 +1,133 @@
+module Network.DNS.Response (parseResponse) where
+
+import Control.Monad
+import Data.Bits
+import Data.ByteString.Lazy (ByteString)
+import Data.Char
+import Data.IP
+import Network.DNS.StateBinary
+import Network.DNS.Types
+
+----------------------------------------------------------------
+
+parseResponse :: ByteString -> DNSFormat
+parseResponse bs = runSGet decodeResponse bs
+
+----------------------------------------------------------------
+
+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 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 _ 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
+ maybe (error "decodeDomain") id <$> 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
107 Network/DNS/StateBinary.hs
@@ -0,0 +1,107 @@
+module Network.DNS.StateBinary where
+
+import Control.Monad.State
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as BS hiding (ByteString)
+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 <$> getNbytes len
+ where
+ toInts = map fromIntegral . BS.unpack
+ getNbytes = lift . getLazyByteString . fromIntegral
+
+----------------------------------------------------------------
+
+push :: Int -> Domain -> SGet ()
+push n d = modify (\m -> IM.insert n d m)
+
+pop :: Int -> SGet (Maybe Domain)
+pop n = IM.lookup n <$> get
+
+----------------------------------------------------------------
+
+initialState :: IntMap Domain
+initialState = IM.empty
+
+runSGet :: SGet DNSFormat -> ByteString -> DNSFormat
+runSGet res bs = fst $ runGet (runStateT res initialState) bs
+
+runSPut :: Put -> ByteString
+runSPut = runPut
92 Network/DNS/Types.hs
@@ -0,0 +1,92 @@
+module Network.DNS.Types where
+
+import Data.Maybe
+import Data.IP
+
+data TYPE = A | AAAA | NS | TXT | MX | UNKNOWN deriving (Eq, Show)
+
+rrDB :: [(TYPE, Int)]
+rrDB = [
+ (A, 1)
+ , (NS, 2)
+ , (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 = maybe UNKNOWN id $ rookup n rrDB
+typeToInt :: TYPE -> Int
+typeToInt t = maybe 0 id $ lookup t rrDB
+
+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)
+
+type Domain = String
+
+data Question = Question {
+ qname :: Domain
+ , qtype :: TYPE
+ } deriving (Eq, Show)
+
+data ResourceRecord = ResourceRecord {
+ rrname :: Domain
+ , rrtype :: TYPE
+ , rrttl :: Int
+ , rdlen :: Int
+ , rdata :: RDATA
+ } deriving (Eq, Show)
+
+data RDATA = RD_NS Domain | RD_A IPv4 | RD_AAAA IPv6 | RD_OTH [Int] deriving (Eq, Show)
+
+data DNSFlags = DNSFlags {
+ qOrR :: QorR
+ , opcode :: OPCODE
+ , authAnswer :: Bool
+ , trunCation :: Bool
+ , recDesired :: Bool
+ , recAvailable :: Bool
+ , rcode :: RCODE
+ } deriving (Eq, Show)
+
+data DNSHeader = DNSHeader {
+ identifier :: Int
+ , flags :: DNSFlags
+ , qdCount :: Int
+ , anCount :: Int
+ , nsCount :: Int
+ , arCount :: Int
+ } deriving (Eq, Show)
+
+data DNSFormat = DNSFormat {
+ header :: DNSHeader
+ , question :: [Question]
+ , answer :: [ResourceRecord]
+ , authority :: [ResourceRecord]
+ , additional :: [ResourceRecord]
+ } deriving (Eq, Show)
+
+defaultQuery :: DNSFormat
+defaultQuery = DNSFormat {
+ header = DNSHeader {
+ identifier = 0
+ , flags = undefined
+ , qdCount = 0
+ , anCount = 0
+ , nsCount = 0
+ , arCount = 0
+ }
+ , question = []
+ , answer = []
+ , authority = []
+ , additional = []
+ }
2  Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
23 dns.cabal
@@ -0,0 +1,23 @@
+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
+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
+library
+ GHC-Options: -Wall
+ Exposed-Modules: Network.DNS
+ Other-Modules: Network.DNS.Types
+ Network.DNS.Query
+ Network.DNS.Response
+ Network.DNS.StateBinary
+ Build-Depends: base >= 4.0 && < 10, binary, iproute, bytestring,
+ containers, mtl
Please sign in to comment.
Something went wrong with that request. Please try again.