AAAA support

diff --git a/DNSUnitTest.hs b/DNSUnitTest.hs
index c3975a4252c044e3bf45e6e70a79847a7006dd13..a77b049a40343cab60e89dbbc1f4170f7fbe229e 100644 (file)
--- a/DNSUnitTest.hs
+++ b/DNSUnitTest.hs
@@ -2,8 +2,7 @@ import           Data.Binary
 import qualified Data.ByteString.Lazy as LBS
 import           Data.Word
 import           Network.DNS.Message
 import qualified Data.ByteString.Lazy as LBS
 import           Data.Word
 import           Network.DNS.Message

-import           Network.Socket
-import           System.IO.Unsafe
+import           Network.Socket.IsString ()

 import           Test.HUnit
 
 
 import           Test.HUnit
 
 


@@ -27,7 +26,7 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00
                              }
                , msgQuestions   = [ wrapQuestion $
                                     Question {
                              }
                , msgQuestions   = [ wrapQuestion $
                                     Question {

-                                      qName  = mkDomainName "mail.cielonegro.org."
+                                      qName  = "mail.cielonegro.org."

                                     , qType  = CNAME
                                     , qClass = IN
                                     }
                                     , qType  = CNAME
                                     , qClass = IN
                                     }


@@ -62,36 +61,36 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00
                              }
                , msgQuestions   = [ wrapQuestion $
                                     Question {
                              }
                , msgQuestions   = [ wrapQuestion $
                                     Question {

-                                      qName  = mkDomainName "mail.cielonegro.org."
+                                      qName  = "mail.cielonegro.org."

                                     , qType  = CNAME
                                     , qClass = IN
                                     }
                                   ]
                , msgAnswers     = [ wrapRecord $
                                     ResourceRecord {
                                     , qType  = CNAME
                                     , qClass = IN
                                     }
                                   ]
                , msgAnswers     = [ wrapRecord $
                                     ResourceRecord {

-                                      rrName  = mkDomainName "mail.cielonegro.org."
+                                      rrName  = "mail.cielonegro.org."

                                     , rrType  = CNAME
                                     , rrClass = IN
                                     , rrTTL   = 86400
                                     , rrType  = CNAME
                                     , rrClass = IN
                                     , rrTTL   = 86400

-                                    , rrData  = mkDomainName "nem.cielonegro.org."
+                                    , rrData  = "nem.cielonegro.org."

                                     }
                                   ]
                , msgAuthorities = [ wrapRecord $
                                     ResourceRecord {
                                     }
                                   ]
                , msgAuthorities = [ wrapRecord $
                                     ResourceRecord {

-                                      rrName  = mkDomainName "cielonegro.org."
+                                      rrName  = "cielonegro.org."

                                     , rrType  = NS
                                     , rrClass = IN
                                     , rrTTL   = 3600
                                     , rrType  = NS
                                     , rrClass = IN
                                     , rrTTL   = 3600

-                                    , rrData  = mkDomainName "nem.cielonegro.org."
+                                    , rrData  = "nem.cielonegro.org."

                                     }
                                   ]
                , msgAdditionals = [ wrapRecord $
                                     ResourceRecord {
                                     }
                                   ]
                , msgAdditionals = [ wrapRecord $
                                     ResourceRecord {

-                                      rrName  = mkDomainName "nem.cielonegro.org."
+                                      rrName  = "nem.cielonegro.org."

                                     , rrType  = A
                                     , rrClass = IN
                                     , rrTTL   = 3600
                                     , rrType  = A
                                     , rrClass = IN
                                     , rrTTL   = 3600

-                                    , rrData  = unsafePerformIO (inet_addr "219.94.130.139")
+                                    , rrData  = "219.94.130.139"

                                     }
                                   ]
                }
                                     }
                                   ]
                }


@@ -114,7 +113,7 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00
                              }
                , msgQuestions   = [ wrapQuestion $
                                     Question {
                              }
                , msgQuestions   = [ wrapQuestion $
                                     Question {

-                                      qName  = mkDomainName "cielonegro.org."
+                                      qName  = "cielonegro.org."

                                     , qType  = SOA
                                     , qClass = IN
                                     }
                                     , qType  = SOA
                                     , qClass = IN
                                     }


@@ -152,20 +151,20 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00
                              }
                , msgQuestions   = [ wrapQuestion $
                                     Question {
                              }
                , msgQuestions   = [ wrapQuestion $
                                     Question {

-                                      qName  = mkDomainName "cielonegro.org."
+                                      qName  = "cielonegro.org."

                                     , qType  = SOA
                                     , qClass = IN
                                     }
                                   ]
                , msgAnswers     = [ wrapRecord $
                                     ResourceRecord {
                                     , qType  = SOA
                                     , qClass = IN
                                     }
                                   ]
                , msgAnswers     = [ wrapRecord $
                                     ResourceRecord {

-                                      rrName  = mkDomainName "cielonegro.org."
+                                      rrName  = "cielonegro.org."

                                     , rrType  = SOA
                                     , rrClass = IN
                                     , rrTTL   = 3600
                                     , rrData  = SOAFields {
                                     , rrType  = SOA
                                     , rrClass = IN
                                     , rrTTL   = 3600
                                     , rrData  = SOAFields {

-                                                  soaMasterNameServer   = mkDomainName "nem.cielonegro.org."
-                                                , soaResponsibleMailbox = mkDomainName "root.nem.cielonegro.org."
+                                                  soaMasterNameServer   = "nem.cielonegro.org."
+                                                , soaResponsibleMailbox = "root.nem.cielonegro.org."

                                                 , soaSerialNumber       = 2008022148
                                                 , soaRefreshInterval    = 3600
                                                 , soaRetryInterval      = 900
                                                 , soaSerialNumber       = 2008022148
                                                 , soaRefreshInterval    = 3600
                                                 , soaRetryInterval      = 900


@@ -176,20 +175,20 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00
                                   ]
                , msgAuthorities = [ wrapRecord $
                                     ResourceRecord {
                                   ]
                , msgAuthorities = [ wrapRecord $
                                     ResourceRecord {

-                                      rrName  = mkDomainName "cielonegro.org."
+                                      rrName  = "cielonegro.org."

                                     , rrType  = NS
                                     , rrClass = IN
                                     , rrTTL   = 3600
                                     , rrType  = NS
                                     , rrClass = IN
                                     , rrTTL   = 3600

-                                    , rrData  = mkDomainName "nem.cielonegro.org."
+                                    , rrData  = "nem.cielonegro.org."

                                     }
                                   ]
                , msgAdditionals = [ wrapRecord $
                                     ResourceRecord {
                                     }
                                   ]
                , msgAdditionals = [ wrapRecord $
                                     ResourceRecord {

-                                      rrName  = mkDomainName "nem.cielonegro.org."
+                                      rrName  = "nem.cielonegro.org."

                                     , rrType  = A
                                     , rrClass = IN
                                     , rrTTL   = 3600
                                     , rrType  = A
                                     , rrClass = IN
                                     , rrTTL   = 3600

-                                    , rrData  = unsafePerformIO (inet_addr "219.94.130.139")
+                                    , rrData  = "219.94.130.139"

                                     }
                                   ]
                }
                                     }
                                   ]
                }

diff --git a/ExampleDNSServer.hs b/ExampleDNSServer.hs
index 428f261856dd892fa8d8a2862996239eb8b91f9d..75b261aa9effb9349a6f4e7d9a0f75fd557b5803 100644 (file)
--- a/ExampleDNSServer.hs
+++ b/ExampleDNSServer.hs
@@ -2,8 +2,7 @@ import           Network.DNS.Message
 import           Network.DNS.Named
 import           Network.DNS.Named.Config
 import           Network.DNS.Named.Zone
 import           Network.DNS.Named
 import           Network.DNS.Named.Config
 import           Network.DNS.Named.Zone

-import           Network.Socket
-import           System.IO.Unsafe
+import           Network.Socket.IsString ()

 
 main :: IO ()
 main = runNamed cnf (return . findZone)
 
 main :: IO ()
 main = runNamed cnf (return . findZone)


@@ -21,55 +20,66 @@ main = runNamed cnf (return . findZone)
 
       zone :: Zone
       zone = Zone {
 
       zone :: Zone
       zone = Zone {

-               zoneName = mkDN "cielonegro.org."
+               zoneName = "cielonegro.org."

              , zoneSOA  = Just SOAFields {
              , zoneSOA  = Just SOAFields {

-                            soaMasterNameServer   = mkDN "ns.cielonegro.org."
-                          , soaResponsibleMailbox = mkDN "root.ns.cielonegro.org."
+                            soaMasterNameServer   = "ns.cielonegro.org."
+                          , soaResponsibleMailbox = "root.ns.cielonegro.org."

                           , soaSerialNumber       = 2008022148
                           , soaRefreshInterval    = 3600
                           , soaRetryInterval      = 900
                           , soaExpirationLimit    = 3600000
                           , soaMinimumTTL         = 3600
                           }
                           , soaSerialNumber       = 2008022148
                           , soaRefreshInterval    = 3600
                           , soaRetryInterval      = 900
                           , soaExpirationLimit    = 3600000
                           , soaMinimumTTL         = 3600
                           }

-             , zoneRecordNames = return [ mkDN "ns.cielonegro.org."
-                                        , mkDN "www.cielonegro.org."
-                                        , mkDN "git.cielonegro.org."
+             , zoneRecordNames = return [ "ns.cielonegro.org."
+                                        , "www.cielonegro.org."
+                                        , "git.cielonegro.org."

                                         ]
              , zoneResponder   = return . responder
              }
 
       responder :: DomainName -> [SomeRR]
       responder name
                                         ]
              , zoneResponder   = return . responder
              }
 
       responder :: DomainName -> [SomeRR]
       responder name

-          | name == mkDN "ns.cielonegro.org."
+          | name == "ns.cielonegro.org."

               = [ wrapRecord ResourceRecord {
                                    rrName  = name
                                  , rrType  = A
                                  , rrClass = IN
                                  , rrTTL   = 9600
               = [ wrapRecord ResourceRecord {
                                    rrName  = name
                                  , rrType  = A
                                  , rrClass = IN
                                  , rrTTL   = 9600

-                                 , rrData  = inetAddr "127.0.0.1"
+                                 , rrData  = "127.0.0.1"
+                                 }
+                , wrapRecord ResourceRecord {
+                                   rrName  = name
+                                 , rrType  = AAAA
+                                 , rrClass = IN
+                                 , rrTTL   = 9600
+                                 , rrData  = "::1"

                                  }
                 ]
                                  }
                 ]

-          | name == mkDN "www.cielonegro.org."
+          | name == "www.cielonegro.org."

               = [ wrapRecord ResourceRecord {
                                    rrName  = name
                                  , rrType  = A
                                  , rrClass = IN
                                  , rrTTL   = 9600
               = [ wrapRecord ResourceRecord {
                                    rrName  = name
                                  , rrType  = A
                                  , rrClass = IN
                                  , rrTTL   = 9600

-                                 , rrData  = inetAddr "127.0.0.2"
+                                 , rrData  = "127.0.0.2"
+                                 }
+                , wrapRecord ResourceRecord {
+                                   rrName  = name
+                                 , rrType  = AAAA
+                                 , rrClass = IN
+                                 , rrTTL   = 9600
+                                 , rrData  = "fe80::216:cbff:fe39:56a4"

                                  }
                 ]
                                  }
                 ]

-          | name == mkDN "git.cielonegro.org."
+          | name == "git.cielonegro.org."

               = [ wrapRecord ResourceRecord {
                                    rrName  = name
                                  , rrType  = CNAME
                                  , rrClass = IN
                                  , rrTTL   = 9600
               = [ wrapRecord ResourceRecord {
                                    rrName  = name
                                  , rrType  = CNAME
                                  , rrClass = IN
                                  , rrTTL   = 9600

-                                 , rrData  = mkDN "www.cielonegro.org."
+                                 , rrData  = "www.cielonegro.org."

                                  }
                 ]
           | otherwise
               = [] -- This means NXDOMAIN.
 
                                  }
                 ]
           | otherwise
               = [] -- This means NXDOMAIN.
 

-
-inetAddr :: String -> HostAddress
-inetAddr = unsafePerformIO . inet_addr

diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs
index 9713dd2a707ed66d8776458733401346d7eb2e72..db5016096df79dc83788770b21de2aa014d60f1e 100644 (file)
--- a/Network/DNS/Message.hs
+++ b/Network/DNS/Message.hs
@@ -23,6 +23,7 @@ module Network.DNS.Message
     , SomeRR(..)
 
     , A(..)
     , SomeRR(..)
 
     , A(..)

+    , AAAA(..)

     , NS(..)
     , MD(..)
     , MF(..)
     , NS(..)
     , MD(..)
     , MF(..)


@@ -50,7 +51,6 @@ module Network.DNS.Message
     , HS(..)
 
     , mkDomainName
     , HS(..)
 
     , mkDomainName

-    , mkDN

     , rootName
     , isRootName
     , consLabel
     , rootName
     , isRootName
     , consLabel


@@ -73,6 +73,7 @@ import           Data.Binary.Strict.BitGet as BG
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
 import qualified Data.ByteString.Lazy as LBS

+import           Data.String

 import           Data.Typeable
 import qualified Data.IntMap as IM
 import           Data.IntMap (IntMap)
 import           Data.Typeable
 import qualified Data.IntMap as IM
 import           Data.IntMap (IntMap)


@@ -219,6 +220,9 @@ getSomeQC = do n <- liftM fromIntegral U.getWord16be
 newtype DomainName  = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
 type DomainLabel    = BS.ByteString
 
 newtype DomainName  = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
 type DomainLabel    = BS.ByteString
 

+instance IsString DomainName where
+    fromString = mkDomainName
+

 rootName :: DomainName
 rootName = DN [BS.empty]
 
 rootName :: DomainName
 rootName = DN [BS.empty]
 


@@ -252,9 +256,6 @@ mkDomainName = DN . mkLabels [] . notEmpty
                                 -> mkLabels (C8.pack l : soFar) rest
                             _   -> error ("Illegal domain name: " ++ xs)
 
                                 -> mkLabels (C8.pack l : soFar) rest
                             _   -> error ("Illegal domain name: " ++ xs)
 

-mkDN :: String -> DomainName
-mkDN = mkDomainName
-

 
 class (Show rc, Eq rc, Typeable rc) => RecordClass rc where
     rcToInt :: rc -> Int
 
 class (Show rc, Eq rc, Typeable rc) => RecordClass rc where
     rcToInt :: rc -> Int


@@ -529,6 +530,20 @@ instance RecordType A HostAddress where
     putRecordData _ = P.putWord32be
     getRecordData _ = U.getWord32be
 
     putRecordData _ = P.putWord32be
     getRecordData _ = U.getWord32be
 

+data AAAA = AAAA deriving (Show, Eq, Typeable)
+instance RecordType AAAA HostAddress6 where
+    rtToInt       _ = 28
+    putRecordData _ = \ (a, b, c, d) ->
+                      do P.putWord32be a
+                         P.putWord32be b
+                         P.putWord32be c
+                         P.putWord32be d
+    getRecordData _ = do a <- U.getWord32be
+                         b <- U.getWord32be
+                         c <- U.getWord32be
+                         d <- U.getWord32be
+                         return (a, b, c, d)
+

 data NS = NS deriving (Show, Eq, Typeable)
 instance RecordType NS DomainName where
     rtToInt       _ = 2
 data NS = NS deriving (Show, Eq, Typeable)
 instance RecordType NS DomainName where
     rtToInt       _ = 2


@@ -847,6 +862,7 @@ instance Enum ResponseCode where
 defaultRTTable :: IntMap SomeRT
 defaultRTTable = IM.fromList $ map toPair $
                  [ SomeRT A
 defaultRTTable :: IntMap SomeRT
 defaultRTTable = IM.fromList $ map toPair $
                  [ SomeRT A

+                 , SomeRT AAAA

                  , SomeRT NS
                  , SomeRT MD
                  , SomeRT MF
                  , SomeRT NS
                  , SomeRT MD
                  , SomeRT MF

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
       udpListen :: AddrInfo -> IO ()
       udpListen ai
           = do so <- socket (addrFamily ai) Datagram defaultProtocol

+               setSocketOption so ReuseAddr 1

                bindSocket so (addrAddress ai)
                udpLoop so
 
                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
       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
                bindSocket so (addrAddress ai)
                listen so 255
                tcpLoop so


@@ -167,31 +169,46 @@ runNamed cnf findZone
               Just name
                   -> do allRecords <- zoneResponder zone name
 
               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 -> [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
           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
 
       handleAXFR :: SomeQ -> Zone -> IO (Builder ())
       handleAXFR (SomeQ q) zone

diff --git a/Network/Socket/IsString.hs b/Network/Socket/IsString.hs
new file mode 100644 (file)
index 0000000..6ea9f8c
--- /dev/null
+++ b/Network/Socket/IsString.hs
@@ -0,0 +1,37 @@
+module Network.Socket.IsString () where
+
+import Data.String
+import Network.Socket
+import System.IO.Unsafe
+
+instance IsString HostAddress where
+    fromString str
+        = let hint = defaultHints {
+                                addrFlags  = [AI_NUMERICHOST]
+                              , addrFamily = AF_INET
+                              }
+              ret  = unsafePerformIO $
+                     getAddrInfo (Just hint) (Just str) Nothing
+          in
+            case ret of
+              []     -> error (str ++ " seems not to be a valid IPv4 address")
+              (x:xs) -> case addrAddress x of
+                          SockAddrInet _ addr
+                              -> addr
+                          _   -> error ("getAddrInfo (" ++ str ++ ") returned a strange result: " ++ show (x:xs))
+
+instance IsString HostAddress6 where
+    fromString str
+        = let hint = defaultHints {
+                                 addrFlags  = [AI_NUMERICHOST]
+                               , addrFamily = AF_INET6
+                               }
+              ret  = unsafePerformIO $
+                     getAddrInfo (Just hint) (Just str) Nothing
+          in
+            case ret of
+              []     -> error (str ++ " seems not to be a valid IPv6 address")
+              (x:xs) -> case addrAddress x of
+                          SockAddrInet6 _ _ addr _
+                              -> addr
+                          _   -> error ("getAddrInfo (" ++ str ++ ") returned a strange result: " ++ show (x:xs))

diff --git a/dns.cabal b/dns.cabal
index cbe24359e8e26237be07b8284e8fe01cfc8f1cc6..2ecda6609a172f3d3b49a5d6865def4c755f6bec 100644 (file)
--- a/dns.cabal
+++ b/dns.cabal
@@ -35,6 +35,7 @@ Library
         Network.DNS.Named.Zone
         Network.DNS.Packer
         Network.DNS.Unpacker
         Network.DNS.Named.Zone
         Network.DNS.Packer
         Network.DNS.Unpacker

+        Network.Socket.IsString

 
     Extensions:
         DeriveDataTypeable, ExistentialQuantification,
 
     Extensions:
         DeriveDataTypeable, ExistentialQuantification,


@@ -61,7 +62,7 @@ Executable DNSUnitTest
     Extensions:
         DeriveDataTypeable, ExistentialQuantification,
         FlexibleInstances, FunctionalDependencies,
     Extensions:
         DeriveDataTypeable, ExistentialQuantification,
         FlexibleInstances, FunctionalDependencies,

-        MultiParamTypeClasses, ScopedTypeVariables,
+        MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables,

         TypeSynonymInstances, UndecidableInstances,
         IncoherentInstances
 
         TypeSynonymInstances, UndecidableInstances,
         IncoherentInstances
 


@@ -80,7 +81,7 @@ Executable ExampleDNSServer
     Extensions:
         DeriveDataTypeable, ExistentialQuantification,
         FlexibleInstances, FunctionalDependencies,
     Extensions:
         DeriveDataTypeable, ExistentialQuantification,
         FlexibleInstances, FunctionalDependencies,

-        MultiParamTypeClasses, ScopedTypeVariables,
+        MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables,

         TypeSynonymInstances, UndecidableInstances,
         IncoherentInstances
 
         TypeSynonymInstances, UndecidableInstances,
         IncoherentInstances