Code clean up

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

diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index 7abdcd083461ba6720975c2645cba0f403271949..3ce2a9ad7d1018a86c78bb304e4d4d28d28e6c41 100644 (file)
--- a/Network/DNS/Named.hs
+++ b/Network/DNS/Named.hs
@@ -124,103 +124,37 @@ runNamed cnf zf
                      -> return $ do unauthorise
                                     setResponseCode Refused
                  Just zone
-                     -> handleQuestionForZone (SomeQ q) zone
+                     -> handleQuestionForZone q zone
 
-      handleQuestionForZone :: SomeQ -> Zone -> IO (Builder ())
-      handleQuestionForZone (SomeQ q) zone
+      handleQuestionForZone :: (Zone z, QueryType qt, QueryClass qc) => Question qt qc -> z -> IO (Builder ())
+      handleQuestionForZone q zone
           | Just (qType q) == cast AXFR
-              = handleAXFR (SomeQ q) zone
+              = handleAXFR 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 ()
-
+              = do answers     <- getRecords zone q
+                   authority   <- getRecords zone (Question (zoneName zone) NS IN)
+                   additionals <- liftM concat $ mapM (getAdditionals zone) (answers ++ authority)
+                   isAuth      <- isAuthoritativeZone zone
+                   return $ do mapM_ addAnswer     answers
+                               mapM_ addAuthority  authority
                                mapM_ addAdditional additionals
+                               unless isAuth unauthorise
 
-                               case zoneNSRecord zone of
-                                 Just rr -> addAuthority rr
-                                 Nothing -> unauthorise
-
-      getAdditionals :: Zone -> SomeRR -> IO [SomeRR]
+      getAdditionals :: Zone z => z -> SomeRR -> IO [SomeRR]
       getAdditionals zone (SomeRR rr)
           = case cast (rrData rr) :: Maybe DomainName of
               Nothing
                   -> return []
               Just name
-                  -> do allRecords <- zoneResponder zone name
-
-                        let rA = filterRecords (SomeQ qA) allRecords
-                            rB = filterRecords (SomeQ qB) allRecords
-                            qA = Question {
-                                   qName  = name
-                                 , qType  = A
-                                 , qClass = IN
-                                 }
-                            qB = Question {
-                                   qName  = name
-                                 , qType  = AAAA
-                                 , qClass = IN
-                                 }
-                        return (rA ++ rB)
-
-      filterRecords :: SomeQ -> [SomeRR] -> [SomeRR]
-      filterRecords (SomeQ q) = filter predicate
-          where
-            predicate rr
-                = predForType rr && predForClass rr
-
-            predForType (SomeRR rr)
-                | typeOf (qType q) == typeOf ANY
-                    = True
-
-                | typeOf (qType q) == typeOf MAILB
-                    = typeOf (rrType rr) == typeOf MR ||
-                      typeOf (rrType rr) == typeOf MB ||
-                      typeOf (rrType rr) == typeOf MG ||
-                      typeOf (rrType rr) == typeOf MINFO
-
-                | otherwise
-                    = typeOf (rrType rr) == typeOf (qType q) ||
-                      typeOf (rrType rr) == typeOf CNAME
-
-            predForClass (SomeRR rr)
-                | typeOf (qClass q) == typeOf ANY
-                    = True
-
-                | otherwise
-                    = typeOf (rrClass rr) == typeOf (qClass q)
-
-      handleAXFR :: SomeQ -> Zone -> IO (Builder ())
-      handleAXFR (SomeQ q) zone
-          | qName q == zoneName zone &&
-            isJust (zoneSOA zone)    &&
-            cnfAllowTransfer cnf
-              = do names      <- zoneRecordNames zone
-                   allRecords <- liftM concat $ mapM (zoneResponder zone) names
-                   return $ do addAnswer $ fromJust $ zoneSOARecord zone
-                               addAnswer $ fromJust $ zoneNSRecord  zone
-                               mapM_ addAnswer allRecords
-                               addAnswerNonuniquely $ fromJust $ zoneSOARecord zone
+                  -> do rrA    <- getRecords zone (Question name A    IN)
+                        rrAAAA <- getRecords zone (Question name AAAA IN)
+                        return (rrA ++ rrAAAA)
+
+      handleAXFR :: (Zone z, QueryType qt, QueryClass qc) => Question qt qc -> z -> IO (Builder ())
+      handleAXFR q zone
+          | cnfAllowTransfer cnf
+              = do rs <- getRecords zone q
+                   return $ mapM_ addAnswerNonuniquely rs
           | otherwise
               = return $ return ()