Permalink
Browse files

initial import.

  • Loading branch information...
0 parents commit 25bc0634cdec8d67bd92cf6265b6f0a0ca6e91aa @kazu-yamamoto committed Mar 17, 2010
Showing with 469 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +29 −0 LICENSE
  3. +4 −0 Network/DNS.hs
  4. +78 −0 Network/DNS/Query.hs
  5. +133 −0 Network/DNS/Response.hs
  6. +107 −0 Network/DNS/StateBinary.hs
  7. +92 −0 Network/DNS/Types.hs
  8. +2 −0 Setup.hs
  9. +23 −0 dns.cabal
@@ -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.
@@ -0,0 +1,4 @@
+module Network.DNS (parseResponse, composeQuery) where
+
+import Network.DNS.Query
+import Network.DNS.Response
@@ -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
@@ -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
@@ -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
Oops, something went wrong.

0 comments on commit 25bc063

Please sign in to comment.