ZoneFinder comes back

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

diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index 8b50060634547d1284dcaf80eb2b18dd50bfcc20..7abdcd083461ba6720975c2645cba0f403271949 100644 (file)
--- a/Network/DNS/Named.hs
+++ b/Network/DNS/Named.hs
@@ -23,18 +23,28 @@ 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
-         _tcpListenerTID <- forkIO $ tcpListen
-         udpListen
+
+         let hint = defaultHints {
+                      addrFlags      = [AI_PASSIVE, AI_V4MAPPED]
+                    , addrFamily     = AF_INET6
+                    , addrSocketType = NoSocketType
+                    , addrProtocol   = defaultProtocol
+                    }
+         (ai:_) <- getAddrInfo (Just hint) Nothing (Just $ cnfServerPort cnf)
+
+         _tcpListenerTID <- forkIO $ tcpListen ai
+         udpListen ai
     where
-      udpListen :: IO ()
-      udpListen = do -- FIXME: we should support IPv6 when the network package supports it.
-                     so <- socket AF_INET Datagram defaultProtocol
-                     bindSocket so $ cnfServerAddress cnf
-                     udpLoop so
+      udpListen :: AddrInfo -> IO ()
+      udpListen ai
+          = do so <- socket (addrFamily ai) Datagram defaultProtocol
+               setSocketOption so ReuseAddr 1
+               bindSocket so (addrAddress ai)
+               udpLoop so
 
       udpLoop :: Socket -> IO ()
       udpLoop so
@@ -42,11 +52,13 @@ runNamed cnf findZone
                _handlerTID <- forkIO $ udpHandler so packet cameFrom
                udpLoop so
 
-      tcpListen :: IO ()
-      tcpListen = do so <- socket AF_INET Stream defaultProtocol
-                     bindSocket so $ cnfServerAddress cnf
-                     listen so 255
-                     tcpLoop so
+      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
 
       tcpLoop :: Socket -> IO ()
       tcpLoop so
@@ -69,7 +81,7 @@ runNamed cnf findZone
       tcpHandler :: Handle -> IO ()
       tcpHandler h
           = do lenB   <- LBS.hGet h 2
-               if LBS.null lenB then
+               if LBS.length lenB < 2 then
                    -- Got EOF
                    hClose h
                  else
@@ -106,7 +118,7 @@ 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
@@ -157,31 +169,46 @@ runNamed cnf findZone
               Just name
                   -> do allRecords <- zoneResponder zone name
 
-                        let filtered = filterRecords (SomeQ q') allRecords
-                            q'       = Question {
-                                         qName  = name
-                                       , qType  = A
-                                       , qClass = IN
-                                       }
-                        return filtered
+                        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)
-          | 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
+      filterRecords (SomeQ q) = filter predicate
           where
-            matchClass (SomeRR rr)
-                = Just (qClass q) == cast (rrClass rr)
+            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
 
-            matchType (SomeRR rr)
-                = Just (qType  q) == cast (rrType  rr) ||
-                  Just CNAME      == cast (rrType  rr)
+            predForClass (SomeRR rr)
+                | typeOf (qClass q) == typeOf ANY
+                    = True
 
-            matchBoth rr
-                = matchType rr && matchClass rr
+                | otherwise
+                    = typeOf (rrClass rr) == typeOf (qClass q)
 
       handleAXFR :: SomeQ -> Zone -> IO (Builder ())
       handleAXFR (SomeQ q) zone