Farewell to the Sanity.hs

[haskell-dns.git] / Network / DNS / Named.hs

diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index dbe8e71c2865f135ac93d41d2439e3f4bf16d0e5..1eaf27af89975b0d4df987c8aed4c3180607235a 100644 (file)
--- a/Network/DNS/Named.hs
+++ b/Network/DNS/Named.hs
@@ -9,19 +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
@@ -68,13 +68,86 @@ runNamed cnf zf
 
       handleQuestion :: SomeQ -> IO (Builder ())
       handleQuestion (SomeQ q)
-          = 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 $ do mapM_ addAnswer $ concat results
-                           unless (zoneIsAuthoritative zone) $
-                                  unauthorise
+          = 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
@@ -140,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