Code clean up

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

diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index 3d0a6dc7841096ca1803fac1bb0a5c4ef32d6273..3ce2a9ad7d1018a86c78bb304e4d4d28d28e6c41 100644 (file)
--- a/Network/DNS/Named.hs
+++ b/Network/DNS/Named.hs
@@ -23,8 +23,8 @@ import           System.Posix.Signals
 import           System.IO
 
 
-runNamed :: Config -> (DomainName -> IO (Maybe Zone)) -> IO ()
-runNamed cnf findZone
+runNamed :: ZoneFinder zf => Config -> zf -> IO ()
+runNamed cnf zf
     = withSocketsDo $
       do installHandler sigPIPE Ignore Nothing
 
@@ -42,6 +42,7 @@ runNamed cnf findZone
       udpListen :: AddrInfo -> IO ()
       udpListen ai
           = do so <- socket (addrFamily ai) Datagram defaultProtocol
+               setSocketOption so ReuseAddr 1
                bindSocket so (addrAddress ai)
                udpLoop so
 
@@ -54,6 +55,7 @@ runNamed cnf findZone
       tcpListen :: AddrInfo -> IO ()
       tcpListen ai
           = do so <- socket (addrFamily ai) Stream defaultProtocol
+               setSocketOption so ReuseAddr 1
                bindSocket so (addrAddress ai)
                listen so 255
                tcpLoop so
@@ -116,94 +118,43 @@ runNamed cnf findZone
 
       handleQuestion :: SomeQ -> IO (Builder ())
       handleQuestion (SomeQ q)
-          = do zoneM <- findZone (qName q)
+          = do zoneM <- findZone zf (qName q)
                case zoneM of
                  Nothing
                      -> 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 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
-          | 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 ()