X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FDNS%2FMessage.hs;h=17c037f7dba99a18a3c4457f670a5aaa017b5a54;hb=caf521ccd3edd8a9f042d1aa8a097b98cf40c1da;hp=ab1a15426430bb9b7d559561562a1e5fc4b35af8;hpb=2afb9d8072fdf52e9ed100027cf97aad8b9abd8d;p=haskell-dns.git diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs index ab1a154..17c037f 100644 --- a/Network/DNS/Message.hs +++ b/Network/DNS/Message.hs @@ -10,14 +10,17 @@ module Network.DNS.Message , DomainName , DomainLabel , TTL + + , QueryType + , QueryClass , RecordType - , RecordClass(..) + , RecordClass , SOAFields(..) + , WKSFields(..) - , SomeQT + , SomeQ , SomeRR - , SomeRT , A(..) , NS(..) @@ -29,15 +32,25 @@ module Network.DNS.Message , MG(..) , MR(..) , NULL(..) + , WKS(..) , PTR(..) , HINFO(..) , MINFO(..) , MX(..) , TXT(..) + , AXFR(..) + , MAILB(..) + , MAILA(..) + , ANY(..) + + , IN(..) + , CS(..) + , CH(..) + , HS(..) + , mkDomainName - , wrapQueryType - , wrapRecordType + , wrapQuestion , wrapRecord ) where @@ -51,9 +64,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 +81,7 @@ import Network.Socket data Message = Message { msgHeader :: !Header - , msgQuestions :: ![Question] + , msgQuestions :: ![SomeQ] , msgAnswers :: ![SomeRR] , msgAuthorities :: ![SomeRR] , msgAdditionals :: ![SomeRR] @@ -113,31 +129,82 @@ data ResponseCode | Refused deriving (Show, Eq) -data Question +data (QueryType qt, QueryClass qc) => Question qt qc = Question { qName :: !DomainName - , qType :: !SomeQT - , qClass :: !RecordClass + , qType :: !qt + , qClass :: !qc } - deriving (Show, Eq) + deriving (Typeable) + +instance (QueryType qt, QueryClass qc) => Show (Question qt qc) where + show q = "Question { qName = " ++ show (qName q) ++ + ", qType = " ++ show (qType q) ++ + ", qClass = " ++ show (qClass q) ++ " }" + +instance (QueryType qt, QueryClass qc) => Eq (Question qt qc) where + a == b = qName a == qName b && + qType a == qType b && + qClass a == qClass b + +data SomeQ = forall qt qc. (QueryType qt, QueryClass qc) => SomeQ (Question qt qc) + +instance Show SomeQ where + show (SomeQ q) = show q + +instance Eq SomeQ where + (SomeQ a) == (SomeQ b) = Just a == cast b -type SomeQT = SomeRT +data SomeQT = forall qt. QueryType qt => SomeQT qt -putQ :: Question -> Packer CompTable () -putQ q +instance Show SomeQT where + show (SomeQT qt) = show qt + +instance Eq SomeQT where + (SomeQT a) == (SomeQT b) = Just a == cast b + +data SomeQC = forall qc. QueryClass qc => SomeQC qc + +instance Show SomeQC where + show (SomeQC qc) = show qc + +instance Eq SomeQC where + (SomeQC a) == (SomeQC b) = Just a == cast b + +putSomeQ :: SomeQ -> Packer CompTable () +putSomeQ (SomeQ q) = do putDomainName $ qName q - putSomeRT $ qType q - putBinary $ qClass q + putQueryType $ qType q + putQueryClass $ qClass q + +getSomeQ :: Unpacker DecompTable SomeQ +getSomeQ + = do nm <- getDomainName + ty <- getSomeQT + cl <- getSomeQC + case (ty, cl) of + (SomeQT qt, SomeQC qc) + -> return $ SomeQ $ Question { + qName = nm + , qType = qt + , qClass = qc + } + +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) -getQ :: Unpacker DecompTable Question -getQ = do nm <- getDomainName - ty <- getSomeRT - cl <- getBinary - return Question { - qName = nm - , qType = ty - , qClass = cl - } +getSomeQC :: Unpacker s SomeQC +getSomeQC = do n <- liftM fromIntegral U.getWord16be + case IM.lookup n defaultQCTable of + Just sqc + -> return sqc + Nothing + -> fail ("Unknown query class: " ++ show n) newtype DomainName = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable) @@ -170,27 +237,26 @@ mkDomainName = DN . mkLabels [] . notEmpty -> mkLabels (C8.pack l : soFar) rest _ -> error ("Illegal domain name: " ++ xs) -data RecordClass - = IN - | CS -- Obsolete - | CH - | HS - | AnyClass -- Only for queries - deriving (Show, Eq) +class (Show rc, Eq rc, Typeable rc) => RecordClass rc where + rcToInt :: rc -> Int -data RecordType rt dt => ResourceRecord rt dt + putRecordClass :: rc -> Packer s () + putRecordClass = P.putWord16be . fromIntegral . rcToInt + + +data (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt = ResourceRecord { rrName :: !DomainName , rrType :: !rt - , rrClass :: !RecordClass + , rrClass :: !rc , rrTTL :: !TTL , rrData :: !dt } deriving (Show, Eq, Typeable) -data SomeRR = forall rt dt. RecordType rt dt => SomeRR (ResourceRecord rt dt) +data SomeRR = forall rt rc dt. (RecordType rt dt, RecordClass rc) => SomeRR (ResourceRecord rt rc dt) instance Show SomeRR where show (SomeRR rr) = show rr @@ -203,12 +269,14 @@ putSomeRR :: SomeRR -> Packer CompTable () putSomeRR (SomeRR rr) = putResourceRecord rr getSomeRR :: Unpacker DecompTable SomeRR -getSomeRR = do srt <- U.lookAhead $ - do getDomainName -- skip - getSomeRT - case srt of - SomeRT rt - -> getResourceRecord rt >>= return . SomeRR +getSomeRR = do (srt, src) <- U.lookAhead $ + do getDomainName -- skip + srt <- getSomeRT + src <- getSomeRC + return (srt, src) + case (srt, src) of + (SomeRT rt, SomeRC rc) + -> getResourceRecord rt rc >>= return . SomeRR type CompTable = Map DomainName Int type DecompTable = IntMap DomainName @@ -299,6 +367,24 @@ 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 qc, Eq qc, Typeable qc) => QueryClass qc where + qcToInt :: qc -> Int + + putQueryClass :: qc -> Packer s () + putQueryClass = P.putWord16be . fromIntegral . qcToInt + +instance RecordClass rc => QueryClass rc where + qcToInt = rcToInt + class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where rtToInt :: rt -> Int @@ -319,15 +405,20 @@ 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)) - - putResourceRecord :: ResourceRecord rt dt -> Packer CompTable () + 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 :: RecordClass rc => ResourceRecord rt rc dt -> Packer CompTable () putResourceRecord rr - = do putDomainName $ rrName rr - putRecordType $ rrType rr - putBinary $ rrClass rr - P.putWord32be $ rrTTL rr + = do putDomainName $ rrName rr + putRecordType $ rrType rr + putRecordClass $ rrClass rr + P.putWord32be $ rrTTL rr putRecordDataWithLength (rrType rr) (rrData rr) getRecordDataWithLength :: rt -> Unpacker DecompTable dt @@ -344,21 +435,22 @@ class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType r return dat - getResourceRecord :: rt -> Unpacker DecompTable (ResourceRecord rt dt) - getResourceRecord rt + getResourceRecord :: RecordClass rc => rt -> rc -> Unpacker DecompTable (ResourceRecord rt rc dt) + getResourceRecord rt rc = do name <- getDomainName U.skip 2 -- record type - cl <- getBinary + U.skip 2 -- record class ttl <- U.getWord32be dat <- getRecordDataWithLength rt return $ ResourceRecord { rrName = name , rrType = rt - , rrClass = cl + , rrClass = rc , rrTTL = ttl , rrData = dat } + data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt instance Show SomeRT where @@ -367,9 +459,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 +467,23 @@ getSomeRT = do n <- liftM fromIntegral U.getWord16be Just srt -> return srt +data SomeRC = forall rc. RecordClass rc => SomeRC rc + +instance Show SomeRC where + show (SomeRC rc) = show rc + +instance Eq SomeRC where + (SomeRC a) == (SomeRC b) = Just a == cast b + +getSomeRC :: Unpacker s SomeRC +getSomeRC = do n <- liftM fromIntegral U.getWord16be + case IM.lookup n defaultRCTable of + Nothing + -> fail ("Unknown resource record class: " ++ show n) + Just src + -> return src + + data SOAFields = SOAFields { soaMasterNameServer :: !DomainName @@ -390,6 +496,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 +592,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 +688,40 @@ 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 QueryClass ANY where + qcToInt _ = 255 + +data IN = IN deriving (Show, Eq, Typeable) +instance RecordClass IN where + rcToInt _ = 1 + +data CS = CS deriving (Show, Eq, Typeable) +instance RecordClass CS where + rcToInt _ = 2 + +data CH = CH deriving (Show, Eq, Typeable) +instance RecordClass CH where + rcToInt _ = 3 + +data HS = HS deriving (Show, Eq, Typeable) +instance RecordClass HS where + rcToInt _ = 4 + instance Binary Message where put m = P.liftToBinary M.empty $ @@ -560,7 +730,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 +741,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,66 +825,83 @@ 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 - fromEnum CH = 3 - fromEnum HS = 4 - fromEnum AnyClass = 255 - - toEnum 1 = IN - toEnum 2 = CS - toEnum 3 = CH - toEnum 4 = HS - toEnum 255 = AnyClass - toEnum _ = undefined - -instance Binary RecordClass where - get = liftM (toEnum . fromIntegral) G.getWord16be - put = P'.putWord16be . fromIntegral . fromEnum - defaultRTTable :: IntMap SomeRT defaultRTTable = IM.fromList $ map toPair $ - [ wrapRecordType A - , wrapRecordType NS - , wrapRecordType CNAME - , wrapRecordType HINFO + [ SomeRT A + , SomeRT NS + , SomeRT MD + , SomeRT MF + , SomeRT CNAME + , SomeRT SOA + , SomeRT MB + , SomeRT MG + , SomeRT MR + , SomeRT NULL + , SomeRT WKS + , SomeRT PTR + , SomeRT HINFO + , SomeRT MINFO + , SomeRT MX + , SomeRT TXT ] where toPair :: SomeRT -> (Int, SomeRT) toPair srt@(SomeRT rt) = (rtToInt rt, srt) +defaultQTTable :: IntMap SomeQT +defaultQTTable = mergeWithRTTable defaultRTTable $ IM.fromList $ map toPair $ + [ SomeQT AXFR + , SomeQT MAILB + , SomeQT MAILA + , SomeQT 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 + +defaultRCTable :: IntMap SomeRC +defaultRCTable = IM.fromList $ map toPair $ + [ SomeRC IN + , SomeRC CS + , SomeRC CH + , SomeRC HS + ] + where + toPair :: SomeRC -> (Int, SomeRC) + toPair src@(SomeRC rc) = (rcToInt rc, src) + +defaultQCTable :: IntMap SomeQC +defaultQCTable = mergeWithRCTable defaultRCTable $ IM.fromList $ map toPair $ + [ SomeQC ANY + ] + where + toPair :: SomeQC -> (Int, SomeQC) + toPair sqc@(SomeQC qc) = (qcToInt qc, sqc) + + mergeWithRCTable :: IntMap SomeRC -> IntMap SomeQC -> IntMap SomeQC + mergeWithRCTable rcs qcs + = IM.union (toQCTable rcs) qcs + + toQCTable :: IntMap SomeRC -> IntMap SomeQC + toQCTable = IM.map toSomeQC + + toSomeQC :: SomeRC -> SomeQC + toSomeQC (SomeRC rc) = SomeQC rc -wrapQueryType :: RecordType rt dt => rt -> SomeQT -wrapQueryType = SomeRT -wrapRecordType :: RecordType rt dt => rt -> SomeRT -wrapRecordType = SomeRT +wrapQuestion :: (QueryType qt, QueryClass qc) => Question qt qc -> SomeQ +wrapQuestion = SomeQ -wrapRecord :: RecordType rt dt => ResourceRecord rt dt -> SomeRR +wrapRecord :: (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt -> SomeRR wrapRecord = SomeRR \ No newline at end of file