From 845dca95afa7e073e62520ef3c4840b3b078bdad Mon Sep 17 00:00:00 2001 From: PHO Date: Thu, 28 May 2009 14:18:25 +0900 Subject: [PATCH] AAAA support --- DNSUnitTest.hs | 37 ++++++++++++------------- ExampleDNSServer.hs | 44 +++++++++++++++++------------ Network/DNS/Message.hs | 24 +++++++++++++--- Network/DNS/Named.hs | 57 +++++++++++++++++++++++++------------- Network/Socket/IsString.hs | 37 +++++++++++++++++++++++++ dns.cabal | 5 ++-- 6 files changed, 142 insertions(+), 62 deletions(-) create mode 100644 Network/Socket/IsString.hs diff --git a/DNSUnitTest.hs b/DNSUnitTest.hs index c3975a4..a77b049 100644 --- 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 Network.Socket -import System.IO.Unsafe +import Network.Socket.IsString () import Test.HUnit @@ -27,7 +26,7 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00 } , msgQuestions = [ wrapQuestion $ Question { - qName = mkDomainName "mail.cielonegro.org." + qName = "mail.cielonegro.org." , qType = CNAME , qClass = IN } @@ -62,36 +61,36 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00 } , msgQuestions = [ wrapQuestion $ Question { - qName = mkDomainName "mail.cielonegro.org." + qName = "mail.cielonegro.org." , qType = CNAME , qClass = IN } ] , msgAnswers = [ wrapRecord $ ResourceRecord { - rrName = mkDomainName "mail.cielonegro.org." + rrName = "mail.cielonegro.org." , rrType = CNAME , rrClass = IN , rrTTL = 86400 - , rrData = mkDomainName "nem.cielonegro.org." + , rrData = "nem.cielonegro.org." } ] , msgAuthorities = [ wrapRecord $ ResourceRecord { - rrName = mkDomainName "cielonegro.org." + rrName = "cielonegro.org." , rrType = NS , rrClass = IN , rrTTL = 3600 - , rrData = mkDomainName "nem.cielonegro.org." + , rrData = "nem.cielonegro.org." } ] , msgAdditionals = [ wrapRecord $ ResourceRecord { - rrName = mkDomainName "nem.cielonegro.org." + rrName = "nem.cielonegro.org." , 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 { - qName = mkDomainName "cielonegro.org." + qName = "cielonegro.org." , qType = SOA , qClass = IN } @@ -152,20 +151,20 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00 } , msgQuestions = [ wrapQuestion $ Question { - qName = mkDomainName "cielonegro.org." + qName = "cielonegro.org." , qType = SOA , qClass = IN } ] , msgAnswers = [ wrapRecord $ ResourceRecord { - rrName = mkDomainName "cielonegro.org." + rrName = "cielonegro.org." , 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 @@ -176,20 +175,20 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00 ] , msgAuthorities = [ wrapRecord $ ResourceRecord { - rrName = mkDomainName "cielonegro.org." + rrName = "cielonegro.org." , rrType = NS , rrClass = IN , rrTTL = 3600 - , rrData = mkDomainName "nem.cielonegro.org." + , rrData = "nem.cielonegro.org." } ] , msgAdditionals = [ wrapRecord $ ResourceRecord { - rrName = mkDomainName "nem.cielonegro.org." + rrName = "nem.cielonegro.org." , 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 428f261..75b261a 100644 --- 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.Socket -import System.IO.Unsafe +import Network.Socket.IsString () main :: IO () main = runNamed cnf (return . findZone) @@ -21,55 +20,66 @@ main = runNamed cnf (return . findZone) zone :: Zone zone = Zone { - zoneName = mkDN "cielonegro.org." + zoneName = "cielonegro.org." , 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 } - , 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 - | name == mkDN "ns.cielonegro.org." + | name == "ns.cielonegro.org." = [ 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 - , 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 - , rrData = mkDN "www.cielonegro.org." + , rrData = "www.cielonegro.org." } ] | otherwise = [] -- This means NXDOMAIN. - -inetAddr :: String -> HostAddress -inetAddr = unsafePerformIO . inet_addr diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs index 9713dd2..db50160 100644 --- a/Network/DNS/Message.hs +++ b/Network/DNS/Message.hs @@ -23,6 +23,7 @@ module Network.DNS.Message , SomeRR(..) , A(..) + , AAAA(..) , NS(..) , MD(..) , MF(..) @@ -50,7 +51,6 @@ module Network.DNS.Message , HS(..) , mkDomainName - , mkDN , 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 Data.String 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 +instance IsString DomainName where + fromString = mkDomainName + 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) -mkDN :: String -> DomainName -mkDN = mkDomainName - 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 +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 @@ -847,6 +862,7 @@ instance Enum ResponseCode where defaultRTTable :: IntMap SomeRT defaultRTTable = IM.fromList $ map toPair $ [ SomeRT A + , SomeRT AAAA , SomeRT NS , SomeRT MD , SomeRT MF diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs index 3d0a6dc..57570cf 100644 --- 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 diff --git a/Network/Socket/IsString.hs b/Network/Socket/IsString.hs new file mode 100644 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 cbe2435..2ecda66 100644 --- a/dns.cabal +++ b/dns.cabal @@ -35,6 +35,7 @@ Library Network.DNS.Named.Zone Network.DNS.Packer Network.DNS.Unpacker + Network.Socket.IsString Extensions: DeriveDataTypeable, ExistentialQuantification, @@ -61,7 +62,7 @@ Executable DNSUnitTest Extensions: DeriveDataTypeable, ExistentialQuantification, FlexibleInstances, FunctionalDependencies, - MultiParamTypeClasses, ScopedTypeVariables, + MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances, IncoherentInstances @@ -80,7 +81,7 @@ Executable ExampleDNSServer Extensions: DeriveDataTypeable, ExistentialQuantification, FlexibleInstances, FunctionalDependencies, - MultiParamTypeClasses, ScopedTypeVariables, + MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances, IncoherentInstances -- 2.40.0