AAAA support

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

diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index 3d0a6dc7841096ca1803fac1bb0a5c4ef32d6273..57570cfffdc87a39de49cf065571198e08144f9e 100644 (file)
--- a/Network/DNS/Named.hs
+++ b/Network/DNS/Named.hs
@@ -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
@@ -167,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
 
-            matchType (SomeRR rr)
-                = Just (qType  q) == cast (rrType  rr) ||
-                  Just CNAME      == cast (rrType  rr)
+            predForType (SomeRR rr)
+                | typeOf (qType q) == typeOf ANY
+                    = True
 
-            matchBoth rr
-                = matchType rr && matchClass rr
+                | 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