From: PHO <pho@cielonegro.org>
Date: Mon, 25 May 2009 06:38:23 +0000 (+0900)
Subject: Response builder
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=5015e5caa39e015e6ffa28a87fc5f189e7ba3c71;p=haskell-dns.git

Response builder
---

diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index 137bdd5..57d9ea4 100644
--- a/Network/DNS/Named.hs
+++ b/Network/DNS/Named.hs
@@ -15,6 +15,7 @@ import qualified Network.Socket.ByteString as NB
 import           Network.DNS.Message
 import           Network.DNS.Named.Config
 import           Network.DNS.Named.Responder
+import           Network.DNS.Named.ResponseBuilder
 import           Network.DNS.Named.Zone
 import           System.Posix.Signals
 
@@ -56,14 +57,22 @@ runNamed cnf zf
       handleMessage msg
           = case validateQuery msg of
               NoError
-                  -> fail "FIXME: not impl" -- msgQuestions msg
+                  -> do builders <- mapM handleQuestion $ msgQuestions msg
+
+                        let builder = foldl (>>) (return ()) builders
+                            msg'    = runBuilder msg builder
+
+                        return msg'
+
               err -> return $ mkErrorReply err msg
 
-      handleQuestion :: SomeQ -> IO [SomeRR]
+      handleQuestion :: SomeQ -> IO (Builder ())
       handleQuestion (SomeQ q)
-          = do zone       <- findZone zf (qName q)
-               results    <- mapM (runResponder' q) (zoneResponders zone)
-               return $ concat results
+          = do zone    <- findZone zf (qName q)
+               -- FIXME: this is merely a bogus implementation.
+               -- It considers no additional or authoritative sections.
+               results <- mapM (runResponder' q) (zoneResponders zone)
+               return $ mapM_ addAnswer $ concat results
 
 
 validateQuery :: Message -> ResponseCode
diff --git a/Network/DNS/Named/ResponseBuilder.hs b/Network/DNS/Named/ResponseBuilder.hs
new file mode 100644
index 0000000..487a678
--- /dev/null
+++ b/Network/DNS/Named/ResponseBuilder.hs
@@ -0,0 +1,81 @@
+module Network.DNS.Named.ResponseBuilder
+    ( Builder
+
+    , runBuilder
+
+    , unauthorise
+    , addAnswer
+    , addAuthority
+    , addAdditional
+    )
+    where
+
+import Control.Monad
+import Network.DNS.Message
+
+
+newtype Builder a = B { unB :: Message -> (a, Message) }
+
+instance Monad Builder where
+    return a = B $ \ s -> (a, s)
+    m >>= k  = B $ \ s -> let (a, s') = unB m s
+                          in
+                            unB (k a) s'
+    fail err = B $ error err
+
+
+runBuilder :: Message -> Builder () -> Message
+runBuilder query builder
+    = let initialReply = query {
+                           msgAnswers     = []
+                         , msgAuthorities = []
+                         , msgAdditionals = []
+                         }
+          modHeader'   = modifyHeader $
+                         \ h -> h {
+                                  hdMessageType           = Response
+                                , hdIsAuthoritativeAnswer = True
+                                , hdIsTruncated           = False
+                                , hdIsRecursionAvailable  = False
+                                , hdResponseCode          = NoError
+                                }
+          (_, result)  = unB (modHeader' >> builder) initialReply
+      in
+        result
+
+get :: (Message -> a) -> Builder a
+get f = B $ \ s -> (f s, s)
+
+modify :: (Message -> Message) -> Builder ()
+modify f = B $ \ s -> ((), f s)
+
+modifyHeader :: (Header -> Header) -> Builder ()
+modifyHeader f
+    = modify $ \ s -> s { msgHeader = f (msgHeader s) }
+
+addAnswer :: SomeRR -> Builder ()
+addAnswer rr
+    = do anss <- get msgAnswers
+         unless (any (== rr) anss)
+             $ modify $ \ s ->
+                 s { msgAnswers = msgAnswers s ++ [rr] }
+
+addAuthority :: SomeRR -> Builder ()
+addAuthority rr
+    = do anss <- get msgAnswers
+         aths <- get msgAuthorities
+         unless (any (== rr) anss || any (== rr) aths)
+             $ modify $ \ s ->
+                 s { msgAuthorities = msgAuthorities s ++ [rr] }
+
+addAdditional :: SomeRR -> Builder ()
+addAdditional rr
+    = do anss <- get msgAnswers
+         aths <- get msgAuthorities
+         adds <- get msgAdditionals
+         unless (any (== rr) anss || any (== rr) aths || any (== rr) adds)
+             $ modify $ \ s ->
+                 s { msgAdditionals = msgAdditionals s ++ [rr] }
+
+unauthorise :: Builder ()
+unauthorise = modifyHeader (\ h -> h { hdIsAuthoritativeAnswer = False })
diff --git a/Network/DNS/Named/Zone.hs b/Network/DNS/Named/Zone.hs
index da27c3e..8311376 100644
--- a/Network/DNS/Named/Zone.hs
+++ b/Network/DNS/Named/Zone.hs
@@ -34,4 +34,8 @@ instance ZoneFinder (DomainName -> IO (Maybe Zone)) where
 
 
 defaultRootZone :: Zone
-defaultRootZone = error "FIXME: defaultRootZone is not implemented yet"
\ No newline at end of file
+defaultRootZone
+    = Zone {
+        zoneName       = mkDomainName "."
+      , zoneResponders = [] -- FIXME
+      }
diff --git a/dns.cabal b/dns.cabal
index e55cc17..7fc84fc 100644
--- a/dns.cabal
+++ b/dns.cabal
@@ -31,6 +31,7 @@ Library
         Network.DNS.Named
         Network.DNS.Named.Config
         Network.DNS.Named.Responder
+        Network.DNS.Named.ResponseBuilder
         Network.DNS.Named.Sanity
         Network.DNS.Named.Zone
         Network.DNS.Packer