From: PHO Date: Sat, 23 May 2009 03:29:34 +0000 (+0900) Subject: Many changes... X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=dd9ef19bda607c740eddca8c765d416749030b4f;p=haskell-dns.git Many changes... --- diff --git a/DNSUnitTest.hs b/DNSUnitTest.hs index 76a677d..e907c3b 100644 --- a/DNSUnitTest.hs +++ b/DNSUnitTest.hs @@ -25,9 +25,10 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00 , hdIsRecursionAvailable = False , hdResponseCode = NoError } - , msgQuestions = [ Question { + , msgQuestions = [ wrapQuestion $ + Question { qName = mkDomainName "mail.cielonegro.org." - , qType = wrapQueryType CNAME + , qType = CNAME , qClass = IN } ] @@ -59,9 +60,10 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00 , hdIsRecursionAvailable = False , hdResponseCode = NoError } - , msgQuestions = [ Question { + , msgQuestions = [ wrapQuestion $ + Question { qName = mkDomainName "mail.cielonegro.org." - , qType = wrapQueryType CNAME + , qType = CNAME , qClass = IN } ] diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs index ab1a154..570548c 100644 --- a/Network/DNS/Message.hs +++ b/Network/DNS/Message.hs @@ -14,7 +14,9 @@ module Network.DNS.Message , RecordClass(..) , SOAFields(..) + , WKSFields(..) + , SomeQ , SomeQT , SomeRR , SomeRT @@ -29,15 +31,20 @@ module Network.DNS.Message , MG(..) , MR(..) , NULL(..) + , WKS(..) , PTR(..) , HINFO(..) , MINFO(..) , MX(..) , TXT(..) + , AXFR(..) + , MAILB(..) + , MAILA(..) + , ANY(..) + , mkDomainName - , wrapQueryType - , wrapRecordType + , wrapQuestion , wrapRecord ) where @@ -51,9 +58,12 @@ import Data.Binary.Put as P' 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.Typeable import qualified Data.IntMap as IM import Data.IntMap (IntMap) +import qualified Data.IntSet as IS +import Data.IntSet (IntSet) import qualified Data.Map as M import Data.Map (Map) import Data.Word @@ -65,7 +75,7 @@ import Network.Socket data Message = Message { msgHeader :: !Header - , msgQuestions :: ![Question] + , msgQuestions :: ![SomeQ] , msgAnswers :: ![SomeRR] , msgAuthorities :: ![SomeRR] , msgAdditionals :: ![SomeRR] @@ -113,31 +123,66 @@ data ResponseCode | Refused deriving (Show, Eq) -data Question +data QueryType qt => Question qt = Question { qName :: !DomainName - , qType :: !SomeQT + , qType :: !qt , qClass :: !RecordClass } - deriving (Show, Eq) + deriving (Typeable) + +instance QueryType qt => Show (Question qt) where + show q = "Question { qName = " ++ show (qName q) ++ + ", qType = " ++ show (qType q) ++ + ", qClass = " ++ show (qClass q) ++ " }" + +instance QueryType qt => Eq (Question qt) where + a == b = qName a == qName b && + qType a == qType b && + qClass a == qClass b + +data SomeQ = forall qt. QueryType qt => SomeQ (Question qt) -type SomeQT = SomeRT +instance Show SomeQ where + show (SomeQ q) = show q -putQ :: Question -> Packer CompTable () -putQ q +instance Eq SomeQ where + (SomeQ a) == (SomeQ b) = Just a == cast b + +data SomeQT = forall qt. QueryType qt => SomeQT qt + +instance Show SomeQT where + show (SomeQT qt) = show qt + +instance Eq SomeQT where + (SomeQT a) == (SomeQT b) = Just a == cast b + +putSomeQ :: SomeQ -> Packer CompTable () +putSomeQ (SomeQ q) = do putDomainName $ qName q - putSomeRT $ qType q + putQueryType $ qType q putBinary $ qClass q -getQ :: Unpacker DecompTable Question -getQ = do nm <- getDomainName - ty <- getSomeRT - cl <- getBinary - return Question { - qName = nm - , qType = ty - , qClass = cl - } +getSomeQ :: Unpacker DecompTable SomeQ +getSomeQ + = do nm <- getDomainName + ty <- getSomeQT + cl <- getBinary + case ty of + SomeQT qt -> return $ SomeQ $ + Question { + qName = nm + , qType = qt + , qClass = cl + } + +getSomeQT :: Unpacker s SomeQT +getSomeQT = do n <- liftM fromIntegral U.getWord16be + case IM.lookup n defaultQTTable of + Just sqt + -> return sqt + Nothing + -> fail ("Unknown query type: " ++ show n) newtype DomainName = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable) @@ -299,6 +344,14 @@ putDomainName name else putDomainName rest +class (Show qt, Eq qt, Typeable qt) => QueryType qt where + qtToInt :: qt -> Int + + putQueryType :: qt -> Packer s () + putQueryType = P.putWord16be . fromIntegral . qtToInt + +instance RecordType rt dt => QueryType rt where + qtToInt = rtToInt class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where rtToInt :: rt -> Int @@ -319,8 +372,13 @@ class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType r -- Third, rewrite the dummy length to an actual value. offset' <- bytesWrote - withOffset offset - $ P.putWord16be (fromIntegral (offset' - offset - 2)) + let len = offset' - offset - 2 + if len <= 0xFFFF then + withOffset offset + $ P.putWord16be $ fromIntegral len + else + fail ("putRecordData " ++ show rt ++ " wrote " ++ show len + ++ " bytes, which is way too long") putResourceRecord :: ResourceRecord rt dt -> Packer CompTable () putResourceRecord rr @@ -367,9 +425,6 @@ instance Show SomeRT where instance Eq SomeRT where (SomeRT a) == (SomeRT b) = Just a == cast b -putSomeRT :: SomeRT -> Packer s () -putSomeRT (SomeRT rt) = putRecordType rt - getSomeRT :: Unpacker s SomeRT getSomeRT = do n <- liftM fromIntegral U.getWord16be case IM.lookup n defaultRTTable of @@ -378,6 +433,7 @@ getSomeRT = do n <- liftM fromIntegral U.getWord16be Just srt -> return srt + data SOAFields = SOAFields { soaMasterNameServer :: !DomainName @@ -390,6 +446,15 @@ data SOAFields } deriving (Show, Eq, Typeable) +data WKSFields + = WKSFields { + wksAddress :: !HostAddress + , wksProtocol :: !ProtocolNumber + , wksServices :: !IntSet + } + deriving (Show, Eq, Typeable) + + data A = A deriving (Show, Eq, Typeable) instance RecordType A HostAddress where rtToInt _ = 1 @@ -477,6 +542,53 @@ instance RecordType NULL BS.ByteString where getRecordDataWithLength _ = do len <- U.getWord16be U.getByteString $ fromIntegral len +data WKS = WKS deriving (Show, Eq, Typeable) +instance RecordType WKS WKSFields where + rtToInt _ = 11 + putRecordData _ = \ wks -> + do P.putWord32be $ wksAddress wks + P.putWord8 $ fromIntegral $ wksProtocol wks + P.putLazyByteString $ toBitmap $ wksServices wks + where + toBitmap :: IntSet -> LBS.ByteString + toBitmap is + = let maxPort = IS.findMax is + range = [0 .. maxPort] + isAvail p = p `IS.member` is + in + runBitPut $ mapM_ putBit $ map isAvail range + getRecordData _ = fail "getRecordData WKS can't be defined" + + getRecordDataWithLength _ + = do len <- U.getWord16be + addr <- U.getWord32be + proto <- liftM fromIntegral U.getWord8 + bits <- U.getByteString $ fromIntegral $ len - 4 - 1 + return WKSFields { + wksAddress = addr + , wksProtocol = proto + , wksServices = fromBitmap bits + } + where + fromBitmap :: BS.ByteString -> IntSet + fromBitmap bs + = let Right is = runBitGet bs $ worker 0 IS.empty + in + is + + worker :: Int -> IntSet -> BitGet IntSet + worker pos is + = do remain <- BG.remaining + if remain == 0 then + return is + else + do bit <- getBit + if bit then + worker (pos + 1) (IS.insert pos is) + else + worker (pos + 1) is + + data PTR = PTR deriving (Show, Eq, Typeable) instance RecordType PTR DomainName where rtToInt _ = 12 @@ -526,32 +638,22 @@ instance RecordType TXT [BS.ByteString] where worker soFar n = do str <- getCharString worker (str : soFar) (0 `max` n - 1 - BS.length str) -{- -data RecordType - = A - | NS - | MD - | MF - | CNAME - | SOA - | MB - | MG - | MR - | NULL - | WKS - | PTR - | HINFO - | MINFO - | MX - | TXT - - -- Only for queries: - | AXFR - | MAILB -- Obsolete - | MAILA -- Obsolete - | AnyType - deriving (Show, Eq) --} +data AXFR = AXFR deriving (Show, Eq, Typeable) +instance QueryType AXFR where + qtToInt _ = 252 + +data MAILB = MAILB deriving (Show, Eq, Typeable) +instance QueryType MAILB where + qtToInt _ = 253 + +data MAILA = MAILA deriving (Show, Eq, Typeable) +instance QueryType MAILA where + qtToInt _ = 254 + +data ANY = ANY deriving (Show, Eq, Typeable) +instance QueryType ANY where + qtToInt _ = 255 + instance Binary Message where put m = P.liftToBinary M.empty $ @@ -560,7 +662,7 @@ instance Binary Message where P.putWord16be $ fromIntegral $ length $ msgAnswers m P.putWord16be $ fromIntegral $ length $ msgAuthorities m P.putWord16be $ fromIntegral $ length $ msgAdditionals m - mapM_ putQ $ msgQuestions m + mapM_ putSomeQ $ msgQuestions m mapM_ putSomeRR $ msgAnswers m mapM_ putSomeRR $ msgAuthorities m mapM_ putSomeRR $ msgAdditionals m @@ -571,7 +673,7 @@ instance Binary Message where nAns <- liftM fromIntegral U.getWord16be nAth <- liftM fromIntegral U.getWord16be nAdd <- liftM fromIntegral U.getWord16be - qs <- replicateM nQ getQ + qs <- replicateM nQ getSomeQ anss <- replicateM nAns getSomeRR aths <- replicateM nAth getSomeRR adds <- replicateM nAdd getSomeRR @@ -655,30 +757,6 @@ instance Enum ResponseCode where toEnum 5 = Refused toEnum _ = undefined -{- -instance Enum RecordType where - fromEnum A = 1 / - fromEnum NS = 2 / - fromEnum MD = 3 / - fromEnum MF = 4 / - fromEnum CNAME = 5 / - fromEnum SOA = 6 / - fromEnum MB = 7 / - fromEnum MG = 8 / - fromEnum MR = 9 / - fromEnum NULL = 10 / - fromEnum WKS = 11 - fromEnum PTR = 12 / - fromEnum HINFO = 13 / - fromEnum MINFO = 14 / - fromEnum MX = 15 / - fromEnum TXT = 16 / - fromEnum AXFR = 252 - fromEnum MAILB = 253 - fromEnum MAILA = 254 - fromEnum AnyType = 255 --} - instance Enum RecordClass where fromEnum IN = 1 fromEnum CS = 2 @@ -702,19 +780,56 @@ defaultRTTable :: IntMap SomeRT defaultRTTable = IM.fromList $ map toPair $ [ wrapRecordType A , wrapRecordType NS + , wrapRecordType MD + , wrapRecordType MF , wrapRecordType CNAME + , wrapRecordType SOA + , wrapRecordType MB + , wrapRecordType MG + , wrapRecordType MR + , wrapRecordType NULL + , wrapRecordType WKS + , wrapRecordType PTR , wrapRecordType HINFO + , wrapRecordType MINFO + , wrapRecordType MX + , wrapRecordType TXT ] where toPair :: SomeRT -> (Int, SomeRT) toPair srt@(SomeRT rt) = (rtToInt rt, srt) -wrapQueryType :: RecordType rt dt => rt -> SomeQT -wrapQueryType = SomeRT +defaultQTTable :: IntMap SomeQT +defaultQTTable = mergeWithRTTable defaultRTTable $ IM.fromList $ map toPair $ + [ wrapQueryType AXFR + , wrapQueryType MAILB + , wrapQueryType MAILA + , wrapQueryType ANY + ] + where + toPair :: SomeQT -> (Int, SomeQT) + toPair sqt@(SomeQT qt) = (qtToInt qt, sqt) + + mergeWithRTTable :: IntMap SomeRT -> IntMap SomeQT -> IntMap SomeQT + mergeWithRTTable rts qts + = IM.union (toQTTable rts) qts + + toQTTable :: IntMap SomeRT -> IntMap SomeQT + toQTTable = IM.map toSomeQT + + toSomeQT :: SomeRT -> SomeQT + toSomeQT (SomeRT rt) = SomeQT rt + + +wrapQueryType :: QueryType qt => qt -> SomeQT +wrapQueryType = SomeQT wrapRecordType :: RecordType rt dt => rt -> SomeRT wrapRecordType = SomeRT +wrapQuestion :: QueryType qt => Question qt -> SomeQ +wrapQuestion = SomeQ + wrapRecord :: RecordType rt dt => ResourceRecord rt dt -> SomeRR wrapRecord = SomeRR \ No newline at end of file diff --git a/dns.cabal b/dns.cabal index b62c871..0702a10 100644 --- a/dns.cabal +++ b/dns.cabal @@ -27,8 +27,10 @@ Library Extensions: DeriveDataTypeable, ExistentialQuantification, - FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, - ScopedTypeVariables, TypeSynonymInstances + FlexibleInstances, FunctionalDependencies, + MultiParamTypeClasses, ScopedTypeVariables, + TypeSynonymInstances, UndecidableInstances, + IncoherentInstances GHC-Options: -Wall @@ -47,8 +49,10 @@ Executable DNSUnitTest Extensions: DeriveDataTypeable, ExistentialQuantification, - FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, - ScopedTypeVariables, TypeSynonymInstances + FlexibleInstances, FunctionalDependencies, + MultiParamTypeClasses, ScopedTypeVariables, + TypeSynonymInstances, UndecidableInstances, + IncoherentInstances GHC-Options: -Wall