summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorGravatar Kazu Yamamoto <kazu@iij.ad.jp>2011-10-24 15:57:04 +0900
committerGravatar Kazu Yamamoto <kazu@iij.ad.jp>2011-10-24 15:57:04 +0900
commitee8d2b9c69dd7dd4d47e5d88f47150770a15129a (patch)
tree6b2eed3e41ffadafa5d47e7411a4b1a24aa9f1d3
parent2b3919681b49d6f31311bfaf4bc3a958a076618d (diff)
Supporting server side and brushing up.
-rw-r--r--Network/DNS.hs13
-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.hs24
-rw-r--r--SimpleServer.hs31
-rw-r--r--TestProtocol.hs10
-rw-r--r--dns.cabal11
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
diff --git a/dns.cabal b/dns.cabal
index 1d1856a..7c975ed 100644
--- a/dns.cabal
+++ b/dns.cabal
@@ -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,