diff options
author | Kazu Yamamoto <kazu@iij.ad.jp> | 2011-10-24 15:57:04 +0900 |
---|---|---|
committer | Kazu Yamamoto <kazu@iij.ad.jp> | 2011-10-24 15:57:04 +0900 |
commit | ee8d2b9c69dd7dd4d47e5d88f47150770a15129a (patch) | |
tree | 6b2eed3e41ffadafa5d47e7411a4b1a24aa9f1d3 | |
parent | 2b3919681b49d6f31311bfaf4bc3a958a076618d (diff) |
Supporting server side and brushing up.
-rw-r--r-- | Network/DNS.hs | 13 | ||||
-rw-r--r-- | Network/DNS/Decode.hs (renamed from Network/DNS/Response.hs) | 43 | ||||
-rw-r--r-- | Network/DNS/Encode.hs (renamed from Network/DNS/Query.hs) | 20 | ||||
-rw-r--r-- | Network/DNS/Resolver.hs | 24 | ||||
-rw-r--r-- | SimpleServer.hs | 31 | ||||
-rw-r--r-- | TestProtocol.hs | 10 | ||||
-rw-r--r-- | dns.cabal | 11 |
7 files changed, 83 insertions, 69 deletions
diff --git a/Network/DNS.hs b/Network/DNS.hs index acf56c6..73b44db 100644 --- a/Network/DNS.hs +++ b/Network/DNS.hs @@ -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 + + diff --git a/Network/DNS/Response.hs b/Network/DNS/Decode.hs index 523335b..c84a06d 100644 --- a/Network/DNS/Response.hs +++ b/Network/DNS/Decode.hs @@ -1,33 +1,46 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.DNS.Response (responseIter, parseResponse, runDNSFormat, runDNSFormat_) where +module Network.DNS.Decode ( + receive + , decode + ) 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 Data.Enumerator (Enumerator, Iteratee, run_, ($$)) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as BL +import Network.Socket.Enumerator -runDNSFormat :: BL.ByteString -> Either String (DNSFormat, PState) -runDNSFormat = runSGet decodeResponse +---------------------------------------------------------------- -runDNSFormat_ :: BL.ByteString -> Either String DNSFormat -runDNSFormat_ bs = fst <$> runDNSFormat bs +{-| 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 -responseIter :: Monad m => Iteratee ByteString m (DNSFormat, PState) -responseIter = iterSGet decodeResponse +---------------------------------------------------------------- -parseResponse :: (Functor m, Monad m) - => Enumerator ByteString m (a,b) - -> Iteratee ByteString m (a,b) - -> m a -parseResponse enum iter = fst <$> run_ (enum $$ iter) +receiveDNSFormat :: Enumerator ByteString IO (DNSFormat, PState) + -> IO DNSFormat +receiveDNSFormat enum = fst <$> run_ (enum $$ iter) + where + iter = iterSGet decodeResponse ---------------------------------------------------------------- diff --git a/Network/DNS/Query.hs b/Network/DNS/Encode.hs index bdf86bc..6116a04 100644 --- a/Network/DNS/Query.hs +++ b/Network/DNS/Encode.hs @@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards #-} -module Network.DNS.Query (composeQuery, composeDNSFormat) where +module Network.DNS.Encode (encode) where import qualified Data.ByteString.Lazy.Char8 as BL (ByteString) import qualified Data.ByteString.Char8 as BS (length, null, break, drop) @@ -16,20 +16,10 @@ import Data.IP ---------------------------------------------------------------- -composeDNSFormat :: DNSFormat -> BL.ByteString -composeDNSFormat fmt = runSPut (encodeDNSFormat fmt) - -composeQuery :: Int -> [Question] -> BL.ByteString -composeQuery idt qs = composeDNSFormat 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) ---------------------------------------------------------------- diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs index b3182f6..44aee7d 100644 --- a/Network/DNS/Resolver.hs +++ b/Network/DNS/Resolver.hs @@ -28,19 +28,20 @@ module Network.DNS.Resolver ( 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 ---------------------------------------------------------------- @@ -170,8 +171,7 @@ lookupRaw :: Resolver -> Domain -> TYPE -> IO (Maybe DNSFormat) 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 @@ -182,3 +182,17 @@ lookupRaw rlv dom typ = do if identifier hdr == seqno && anCount hdr /= 0 then Just res else Nothing + +---------------------------------------------------------------- + +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 + } diff --git a/SimpleServer.hs b/SimpleServer.hs index 401e7f4..8e12a29 100644 --- a/SimpleServer.hs +++ b/SimpleServer.hs @@ -1,23 +1,20 @@ {-# LANGUAGE RecordWildCards, OverloadedStrings #-} -import System.Environment -import Debug.Trace -import Control.Monad -import Control.Concurrent import Control.Applicative -import Data.Monoid -import Data.Maybe +import Control.Concurrent +import Control.Monad import qualified Data.ByteString as S import Data.ByteString.Lazy hiding (putStrLn, filter, length) -import System.Timeout +import Data.Default +import Data.Maybe +import Data.Monoid +import Debug.Trace import Network.BSD import Network.DNS hiding (lookup) -import Network.DNS.Response -import Network.DNS.Query import Network.Socket hiding (recvFrom) import Network.Socket.ByteString -import Network.Socket.Enumerator -import Data.Default +import System.Environment +import System.Timeout data Conf = Conf { bufSize :: Int @@ -42,11 +39,9 @@ proxyRequest :: Conf -> ResolvConf -> DNSFormat -> IO (Maybe DNSFormat) proxyRequest Conf{..} rc req = do let worker Resolver{..} = do - let packet = mconcat . toChunks $ composeDNSFormat req + let packet = mconcat . toChunks $ encode req sendAll dnsSock packet - let responseEnum = enumSocket dnsBufsize dnsSock - parseResponse responseEnum responseIter - + receive dnsSock dnsBufsize rs <- makeResolvSeed rc withResolver rs $ \r -> (>>= check) <$> timeout' "proxy timeout" timeOut (worker r) @@ -76,7 +71,7 @@ handleRequest conf rc req = maybe (proxyRequest conf rc req) (trace "return A re ] handlePacket :: Conf -> Socket -> SockAddr -> S.ByteString -> IO () -handlePacket conf@Conf{..} sock addr bs = case runDNSFormat_ (fromChunks [bs]) of +handlePacket conf@Conf{..} sock addr bs = case decode (fromChunks [bs]) of Right req -> do print req let rc = defaultResolvConf { resolvInfo = RCHostName realDNS } @@ -84,7 +79,7 @@ handlePacket conf@Conf{..} sock addr bs = case runDNSFormat_ (fromChunks [bs]) o print mrsp case mrsp of Just rsp -> - let packet = mconcat . toChunks $ composeDNSFormat rsp + let packet = mconcat . toChunks $ encode rsp in timeout' "send timeout" timeOut (sendAllTo sock packet addr) >> print (S.length packet) >> return () @@ -95,7 +90,7 @@ main :: IO () main = withSocketsDo $ do dns <- fromMaybe (realDNS def) . listToMaybe <$> getArgs let conf = def { realDNS=dns } - addrinfos <- getAddrInfo + addrinfos <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) Nothing (Just "domain") addrinfo <- maybe (fail "no addr info") return (listToMaybe addrinfos) diff --git a/TestProtocol.hs b/TestProtocol.hs index 3c78cb6..5e2abe7 100644 --- a/TestProtocol.hs +++ b/TestProtocol.hs @@ -2,17 +2,15 @@ module TestProtocol where +import Data.IP import Network.DNS import Network.DNS.Internal -import Network.DNS.Query -import Network.DNS.Response -import Data.IP import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) tests :: [Test] -tests = +tests = [ testGroup "Test case" [ testCase "QueryA" (test_Format testQueryA) , testCase "QueryAAAA" (test_Format testQueryAAAA) @@ -155,8 +153,8 @@ test_Format fmt = do let (Right fmt') = result assertEqual "fail" fmt fmt' where - bs = composeDNSFormat fmt - result = runDNSFormat_ bs + bs = encode fmt + result = decode bs main :: IO () main = defaultMain tests @@ -1,14 +1,11 @@ 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 @@ -22,10 +19,10 @@ library 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, |