X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FDNS%2FNamed.hs;h=1eaf27af89975b0d4df987c8aed4c3180607235a;hb=957d3f466cea2fa642f67f477ec4ad9a0d535a9b;hp=137bdd52f2994af1f4ab4e350d10f88a820da186;hpb=7a09a987b0369db0c013fb10272329c733ffc8a1;p=haskell-dns.git

diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index 137bdd5..1eaf27a 100644
--- a/Network/DNS/Named.hs
+++ b/Network/DNS/Named.hs
@@ -9,18 +9,19 @@ import           Control.Monad
 import           Data.Binary
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
+import           Data.Dynamic
 import           Data.Maybe
 import           Network.Socket
 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
 
 
-runNamed :: ZoneFinder zf => Config -> zf -> IO ()
-runNamed cnf zf
+runNamed :: Config -> (DomainName -> IO (Maybe Zone)) -> IO ()
+runNamed cnf findZone
     = withSocketsDo $
       do installHandler sigPIPE Ignore Nothing
          _tcpListenerTID <- forkIO $ tcpListen
@@ -56,14 +57,97 @@ 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 zoneM <- findZone (qName q)
+               case zoneM of
+                 Nothing
+                     -> return $ do unauthorise
+                                    setResponseCode Refused
+                 Just zone
+                     -> handleQuestionForZone (SomeQ q) zone
+
+      handleQuestionForZone :: SomeQ -> Zone -> IO (Builder ())
+      handleQuestionForZone (SomeQ q) zone
+          | Just (qType q) == cast AXFR
+              = handleAXFR (SomeQ q) zone
+          | otherwise
+              = do allRecords <- zoneResponder zone (qName q)
+                   let filtered = filterRecords (SomeQ q) allRecords
+
+                   additionals <- do xss <- mapM (getAdditionals zone) filtered
+                                     ys  <- case zoneNSRecord zone of
+                                              Just rr -> getAdditionals zone rr
+                                              Nothing -> return []
+                                     return (concat xss ++ ys)
+
+                   return $ do mapM_ addAnswer filtered
+
+                               when (qName q == zoneName zone) $
+                                    do when (Just (qType q) == cast SOA ||
+                                             Just (qType q) == cast ANY   )
+                                                $ case zoneSOARecord zone of
+                                                    Just rr -> addAnswer rr
+                                                    Nothing -> return ()
+
+                                       when (Just (qType q) == cast NS ||
+                                             Just (qType q) == cast ANY  )
+                                                $ case zoneNSRecord zone of
+                                                    Just rr -> addAnswer rr
+                                                    Nothing -> return ()
+
+                               mapM_ addAdditional additionals
+
+                               case zoneNSRecord zone of
+                                 Just rr -> addAuthority rr
+                                 Nothing -> unauthorise
+
+      getAdditionals :: Zone -> SomeRR -> IO [SomeRR]
+      getAdditionals zone (SomeRR rr)
+          = case cast (rrData rr) :: Maybe DomainName of
+              Nothing
+                  -> return []
+              Just name
+                  -> do allRecords <- zoneResponder zone name
+
+                        let filtered = filterRecords (SomeQ q') allRecords
+                            q'       = Question {
+                                         qName  = name
+                                       , qType  = A
+                                       , qClass = IN
+                                       }
+                        return filtered
+
+      filterRecords :: SomeQ -> [SomeRR] -> [SomeRR]
+      filterRecords (SomeQ q)
+          | Just (qType  q) == cast ANY &&
+            Just (qClass q) == cast ANY    = id
+          | Just (qType  q) == cast ANY    = filter matchClass
+          | Just (qClass q) == cast ANY    = filter matchType
+          | otherwise                      = filter matchBoth
+          where
+            matchClass (SomeRR rr)
+                = Just (qClass q) == cast (rrClass rr)
+
+            matchType (SomeRR rr)
+                = Just (qType  q) == cast (rrType  rr) ||
+                  Just CNAME      == cast (rrType  rr)
+
+            matchBoth rr
+                = matchType rr && matchClass rr
+
+      handleAXFR :: SomeQ -> Zone -> IO (Builder ())
+      handleAXFR (SomeQ _q) _zone
+          = fail "FIXME: not implemented yet"
 
 
 validateQuery :: Message -> ResponseCode
@@ -129,15 +213,5 @@ unpackMessage = decode . LBS.fromChunks . return
 
 mkErrorReply :: ResponseCode -> Message -> Message
 mkErrorReply err msg
-    = let header = msgHeader msg
-          msg'   = msg {
-                     msgHeader = header {
-                                   hdMessageType           = Response
-                                 , hdIsAuthoritativeAnswer = False
-                                 , hdIsTruncated           = False
-                                 , hdIsRecursionAvailable  = False
-                                 , hdResponseCode          = err
-                                 }
-                   }
-      in
-        msg'
+    = runBuilder msg $ do unauthorise
+                          setResponseCode err