X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FDNS%2FMessage.hs;h=9713dd2a707ed66d8776458733401346d7eb2e72;hb=248b1c63284bbe00550bf2402ee6a9da6997143e;hp=a3c04821f0f90b60a838ad7fe7fa8e10093dd20c;hpb=2778374186c39d8f30347a1f943708efd22f7d29;p=haskell-dns.git diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs index a3c0482..9713dd2 100644 --- a/Network/DNS/Message.hs +++ b/Network/DNS/Message.hs @@ -1,38 +1,133 @@ module Network.DNS.Message - ( Header(..) + ( Message(..) + , MessageID + , MessageType(..) + , Header(..) , Opcode(..) , ResponseCode(..) + , Question(..) + , ResourceRecord(..) + , DomainName + , DomainLabel + , TTL + + , QueryType + , QueryClass + , RecordType + , RecordClass + + , SOAFields(..) + , WKSFields(..) + + , SomeQ(..) + , SomeRR(..) + + , A(..) + , NS(..) + , MD(..) + , MF(..) + , CNAME(..) + , SOA(..) + , MB(..) + , MG(..) + , MR(..) + , NULL(..) + , WKS(..) + , PTR(..) + , HINFO(..) + , MINFO(..) + , MX(..) + , TXT(..) + + , AXFR(..) + , MAILB(..) + , MAILA(..) + , ANY(..) + + , IN(..) + , CS(..) + , CH(..) + , HS(..) + + , mkDomainName + , mkDN + , rootName + , isRootName + , consLabel + , unconsLabel + , nameToLabels + , isZoneOf + + , wrapQuestion + , wrapRecord ) where +import Control.Exception +import Control.Monad import Data.Binary -import Data.Binary.Get -import Data.Binary.Put -import Data.Bits +import Data.Binary.BitPut as BP +import Data.Binary.Get as G +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 Data.List +import qualified Data.Map as M +import Data.Map (Map) import Data.Word +import Network.DNS.Packer as P +import Network.DNS.Unpacker as U +import Network.Socket -data Header - = QueryHeader { - hdMessageID :: !Word16 - , hdOpcode :: !Opcode - , hdIsTruncated :: !Bool - , hdIsRecursionDesired :: !Bool +data Message + = Message { + msgHeader :: !Header + , msgQuestions :: ![SomeQ] + , msgAnswers :: ![SomeRR] + , msgAuthorities :: ![SomeRR] + , msgAdditionals :: ![SomeRR] } - | ResponseHeader { - hdMessageID :: !Word16 + deriving (Show, Eq) + +data Header + = Header { + hdMessageID :: !MessageID + , hdMessageType :: !MessageType , hdOpcode :: !Opcode , hdIsAuthoritativeAnswer :: !Bool , hdIsTruncated :: !Bool , hdIsRecursionDesired :: !Bool , hdIsRecursionAvailable :: !Bool , hdResponseCode :: !ResponseCode + + -- These fields are supressed in this data structure: + -- + QDCOUNT + -- + ANCOUNT + -- + NSCOUNT + -- + ARCOUNT } + deriving (Show, Eq) + +type MessageID = Word16 + +data MessageType + = Query + | Response + deriving (Show, Eq) data Opcode = StandardQuery | InverseQuery | ServerStatusRequest + deriving (Show, Eq) data ResponseCode = NoError @@ -43,69 +138,685 @@ data ResponseCode | Refused deriving (Show, Eq) -hdIsResponse :: Header -> Bool -hdIsResponse (QueryHeader _ _ _ _ ) = False -hdIsResponse (ResponseHeader _ _ _ _ _ _ _) = True +data (QueryType qt, QueryClass qc) => Question qt qc + = Question { + qName :: !DomainName + , qType :: !qt + , qClass :: !qc + } + 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 + +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 + +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 + 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) + +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) +type DomainLabel = BS.ByteString + +rootName :: DomainName +rootName = DN [BS.empty] + +isRootName :: DomainName -> Bool +isRootName (DN [_]) = True +isRootName _ = False + +consLabel :: DomainLabel -> DomainName -> DomainName +consLabel x (DN ys) = DN (x:ys) + +unconsLabel :: DomainName -> (DomainLabel, DomainName) +unconsLabel (DN (x:xs)) = (x, DN xs) +unconsLabel x = error ("Illegal use of unconsLabel: " ++ show x) + +nameToLabels :: DomainName -> [DomainLabel] +nameToLabels (DN xs) = xs + +isZoneOf :: DomainName -> DomainName -> Bool +isZoneOf (DN a) (DN b) = a `isSuffixOf` b + +mkDomainName :: String -> DomainName +mkDomainName = DN . mkLabels [] . notEmpty + where + notEmpty :: String -> String + notEmpty xs = assert (not $ null xs) xs + + mkLabels :: [DomainLabel] -> String -> [DomainLabel] + mkLabels soFar [] = reverse (C8.empty : soFar) + mkLabels soFar xs = case break (== '.') xs of + (l, ('.':rest)) + -> 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 + + 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 :: !rc + , rrTTL :: !TTL + , rrData :: !dt + } + deriving (Show, Eq, Typeable) + + +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 + +instance Eq SomeRR where + (SomeRR a) == (SomeRR b) = Just a == cast b + + +putSomeRR :: SomeRR -> Packer CompTable () +putSomeRR (SomeRR rr) = putResourceRecord rr + +getSomeRR :: Unpacker DecompTable 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 +type TTL = Word32 + +getDomainName :: Unpacker DecompTable DomainName +getDomainName = worker + where + worker :: Unpacker DecompTable DomainName + worker + = do offset <- U.bytesRead + hdr <- getLabelHeader + case hdr of + Offset n + -> do dt <- U.getState + case IM.lookup n dt of + Just name + -> return name + Nothing + -> fail ("Illegal offset of label pointer: " ++ show (n, dt)) + Length 0 + -> return rootName + Length n + -> do label <- U.getByteString n + rest <- worker + let name = consLabel label rest + U.modifyState $ IM.insert offset name + return name + + getLabelHeader :: Unpacker s LabelHeader + getLabelHeader + = do header <- U.lookAhead $ U.getByteString 1 + let Right h + = runBitGet header $ + do a <- getBit + b <- getBit + n <- liftM fromIntegral (getAsWord8 6) + case (a, b) of + ( True, True) -> return $ Offset n + (False, False) -> return $ Length n + _ -> fail "Illegal label header" + case h of + Offset _ + -> do header' <- U.getByteString 2 -- Pointers have 2 octets. + let Right h' + = runBitGet header' $ + do BG.skip 2 + n <- liftM fromIntegral (getAsWord16 14) + return $ Offset n + return h' + len@(Length _) + -> do U.skip 1 + return len + + +getCharString :: Unpacker s BS.ByteString +getCharString = do len <- U.getWord8 + U.getByteString (fromIntegral len) + +putCharString :: BS.ByteString -> Packer s () +putCharString xs = do P.putWord8 $ fromIntegral $ BS.length xs + P.putByteString xs + +data LabelHeader + = Offset !Int + | Length !Int + +putDomainName :: DomainName -> Packer CompTable () +putDomainName name + = do ct <- P.getState + case M.lookup name ct of + Just n + -> do let ptr = runBitPut $ + do putBit True + putBit True + putNBits 14 n + P.putLazyByteString ptr + Nothing + -> do offset <- bytesWrote + P.modifyState $ M.insert name offset + + let (label, rest) = unconsLabel name + + putCharString label + + if isRootName rest then + P.putWord8 0 + 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 + putRecordData :: rt -> dt -> Packer CompTable () + getRecordData :: rt -> Unpacker DecompTable dt + + putRecordType :: rt -> Packer s () + putRecordType = P.putWord16be . fromIntegral . rtToInt + + putRecordDataWithLength :: rt -> dt -> Packer CompTable () + putRecordDataWithLength rt dt + = do -- First, write a dummy data length. + offset <- bytesWrote + P.putWord16be 0 + + -- Second, write data. + putRecordData rt dt + + -- Third, rewrite the dummy length to an actual value. + offset' <- bytesWrote + 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 + putRecordClass $ rrClass rr + P.putWord32be $ rrTTL rr + putRecordDataWithLength (rrType rr) (rrData rr) + + getRecordDataWithLength :: rt -> Unpacker DecompTable dt + getRecordDataWithLength rt + = do len <- U.getWord16be + offset <- U.bytesRead + dat <- getRecordData rt + offset' <- U.bytesRead + + let consumed = offset' - offset + when (consumed /= len) + $ fail ("getRecordData " ++ show rt ++ " consumed " ++ show consumed ++ + " bytes but it had to consume " ++ show len ++ " bytes") + + return dat + + getResourceRecord :: RecordClass rc => rt -> rc -> Unpacker DecompTable (ResourceRecord rt rc dt) + getResourceRecord rt rc + = do name <- getDomainName + U.skip 2 -- record type + U.skip 2 -- record class + ttl <- U.getWord32be + dat <- getRecordDataWithLength rt + return $ ResourceRecord { + rrName = name + , rrType = rt + , rrClass = rc + , rrTTL = ttl + , rrData = dat + } + + +data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt + +instance Show SomeRT where + show (SomeRT rt) = show rt + +instance Eq SomeRT where + (SomeRT a) == (SomeRT b) = Just a == cast b + +getSomeRT :: Unpacker s SomeRT +getSomeRT = do n <- liftM fromIntegral U.getWord16be + case IM.lookup n defaultRTTable of + Nothing + -> fail ("Unknown resource record type: " ++ show n) + 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 + , soaResponsibleMailbox :: !DomainName + , soaSerialNumber :: !Word32 + , soaRefreshInterval :: !Word32 + , soaRetryInterval :: !Word32 + , soaExpirationLimit :: !Word32 + , soaMinimumTTL :: !Word32 + } + 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 + putRecordData _ = P.putWord32be + getRecordData _ = U.getWord32be + +data NS = NS deriving (Show, Eq, Typeable) +instance RecordType NS DomainName where + rtToInt _ = 2 + putRecordData _ = putDomainName + getRecordData _ = getDomainName + +data MD = MD deriving (Show, Eq, Typeable) +instance RecordType MD DomainName where + rtToInt _ = 3 + putRecordData _ = putDomainName + getRecordData _ = getDomainName + +data MF = MF deriving (Show, Eq, Typeable) +instance RecordType MF DomainName where + rtToInt _ = 4 + putRecordData _ = putDomainName + getRecordData _ = getDomainName + +data CNAME = CNAME deriving (Show, Eq, Typeable) +instance RecordType CNAME DomainName where + rtToInt _ = 5 + putRecordData _ = putDomainName + getRecordData _ = getDomainName + +data SOA = SOA deriving (Show, Eq, Typeable) +instance RecordType SOA SOAFields where + rtToInt _ = 6 + putRecordData _ = \ soa -> + do putDomainName $ soaMasterNameServer soa + putDomainName $ soaResponsibleMailbox soa + P.putWord32be $ soaSerialNumber soa + P.putWord32be $ soaRefreshInterval soa + P.putWord32be $ soaRetryInterval soa + P.putWord32be $ soaExpirationLimit soa + P.putWord32be $ soaMinimumTTL soa + getRecordData _ = do master <- getDomainName + mail <- getDomainName + serial <- U.getWord32be + refresh <- U.getWord32be + retry <- U.getWord32be + expire <- U.getWord32be + ttl <- U.getWord32be + return SOAFields { + soaMasterNameServer = master + , soaResponsibleMailbox = mail + , soaSerialNumber = serial + , soaRefreshInterval = refresh + , soaRetryInterval = retry + , soaExpirationLimit = expire + , soaMinimumTTL = ttl + } + +data MB = MB deriving (Show, Eq, Typeable) +instance RecordType MB DomainName where + rtToInt _ = 7 + putRecordData _ = putDomainName + getRecordData _ = getDomainName + +data MG = MG deriving (Show, Eq, Typeable) +instance RecordType MG DomainName where + rtToInt _ = 8 + putRecordData _ = putDomainName + getRecordData _ = getDomainName + +data MR = MR deriving (Show, Eq, Typeable) +instance RecordType MR DomainName where + rtToInt _ = 9 + putRecordData _ = putDomainName + getRecordData _ = getDomainName + +data NULL = NULL deriving (Show, Eq, Typeable) +instance RecordType NULL BS.ByteString where + rtToInt _ = 10 + putRecordData _ _ = fail "putRecordData NULL can't be defined" + getRecordData _ = fail "getRecordData NULL can't be defined" + putRecordDataWithLength _ = \ dat -> + do P.putWord16be $ fromIntegral $ BS.length dat + P.putByteString dat + 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 + putRecordData _ = putDomainName + getRecordData _ = getDomainName + +data HINFO = HINFO deriving (Show, Eq, Typeable) +instance RecordType HINFO (BS.ByteString, BS.ByteString) where + rtToInt _ = 13 + putRecordData _ = \ (cpu, os) -> + do putCharString cpu + putCharString os + getRecordData _ = do cpu <- getCharString + os <- getCharString + return (cpu, os) + +data MINFO = MINFO deriving (Show, Eq, Typeable) +instance RecordType MINFO (DomainName, DomainName) where + rtToInt _ = 14 + putRecordData _ = \ (r, e) -> + do putDomainName r + putDomainName e + getRecordData _ = do r <- getDomainName + e <- getDomainName + return (r, e) + +data MX = MX deriving (Show, Eq, Typeable) +instance RecordType MX (Word16, DomainName) where + rtToInt _ = 15 + putRecordData _ = \ (pref, exch) -> + do P.putWord16be pref + putDomainName exch + getRecordData _ = do pref <- U.getWord16be + exch <- getDomainName + return (pref, exch) + +data TXT = TXT deriving (Show, Eq, Typeable) +instance RecordType TXT [BS.ByteString] where + rtToInt _ = 16 + putRecordData _ = mapM_ putCharString + getRecordData _ = fail "getRecordData TXT can't be defined" + + getRecordDataWithLength _ = U.getWord16be >>= worker [] . fromIntegral + where + worker :: [BS.ByteString] -> Int -> Unpacker s [BS.ByteString] + worker soFar 0 = return (reverse soFar) + worker soFar n = do str <- getCharString + worker (str : soFar) (0 `max` n - 1 - BS.length str) + +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 $ + do putBinary $ msgHeader m + P.putWord16be $ fromIntegral $ length $ msgQuestions m + P.putWord16be $ fromIntegral $ length $ msgAnswers m + P.putWord16be $ fromIntegral $ length $ msgAuthorities m + P.putWord16be $ fromIntegral $ length $ msgAdditionals m + mapM_ putSomeQ $ msgQuestions m + mapM_ putSomeRR $ msgAnswers m + mapM_ putSomeRR $ msgAuthorities m + mapM_ putSomeRR $ msgAdditionals m + + get = U.liftToBinary IM.empty $ + do hdr <- getBinary + nQ <- liftM fromIntegral U.getWord16be + nAns <- liftM fromIntegral U.getWord16be + nAth <- liftM fromIntegral U.getWord16be + nAdd <- liftM fromIntegral U.getWord16be + qs <- replicateM nQ getSomeQ + anss <- replicateM nAns getSomeRR + aths <- replicateM nAth getSomeRR + adds <- replicateM nAdd getSomeRR + return Message { + msgHeader = hdr + , msgQuestions = qs + , msgAnswers = anss + , msgAuthorities = aths + , msgAdditionals = adds + } instance Binary Header where - put h = do putWord16be $ hdMessageID h - let qr = boolToNum $ hdIsResponse h - op = fromIntegral $ fromEnum $ hdOpcode h - aa = if hdIsResponse h then - boolToNum $ hdIsAuthoritativeAnswer h - else - 0 - tc = boolToNum $ hdIsTruncated h - rd = boolToNum $ hdIsRecursionDesired h - ra = if hdIsResponse h then - boolToNum $ hdIsRecursionAvailable h - else - 0 - rc = if hdIsResponse h then - fromIntegral $ fromEnum $ hdResponseCode h - else - 0 - flags = ((qr `shiftL` 15) .&. 0x01) .|. - ((op `shiftL` 11) .&. 0x0F) .|. - ((aa `shiftL` 10) .&. 0x01) .|. - ((tc `shiftL` 9) .&. 0x01) .|. - ((rd `shiftL` 8) .&. 0x01) .|. - ((ra `shiftL` 7) .&. 0x01) .|. - ((rc `shiftL` 0) .&. 0x0F) - putWord16be flags + put h = do P'.putWord16be $ hdMessageID h + P'.putLazyByteString flags where - boolToNum :: Num a => Bool -> a - boolToNum True = 1 - boolToNum False = 0 - - get = do mID <- getWord16be - flags <- getWord16be - let qr = testBit flags 15 - op = toEnum $ fromIntegral ((flags `shiftR` 11) .&. 0x0F) - aa = testBit flags 10 - tc = testBit flags 9 - rd = testBit flags 8 - ra = testBit flags 7 - rc = toEnum $ fromIntegral (flags .&. 0x0F) - hd = if qr then - ResponseHeader { - hdMessageID = mID - , hdOpcode = op - , hdIsAuthoritativeAnswer = aa - , hdIsTruncated = tc - , hdIsRecursionDesired = rd - , hdIsRecursionAvailable = ra - , hdResponseCode = rc - } - else - QueryHeader { - hdMessageID = mID - , hdOpcode = op - , hdIsTruncated = tc - , hdIsRecursionDesired = rd - } + flags = runBitPut $ + do putNBits 1 $ fromEnum $ hdMessageType h + putNBits 4 $ fromEnum $ hdOpcode h + putBit $ hdIsAuthoritativeAnswer h + putBit $ hdIsTruncated h + putBit $ hdIsRecursionDesired h + putBit $ hdIsRecursionAvailable h + putNBits 3 (0 :: Int) + putNBits 4 $ fromEnum $ hdResponseCode h + + get = do mID <- G.getWord16be + flags <- G.getByteString 2 + let Right hd + = runBitGet flags $ + do qr <- liftM (toEnum . fromIntegral) $ getAsWord8 1 + op <- liftM (toEnum . fromIntegral) $ getAsWord8 4 + aa <- getBit + tc <- getBit + rd <- getBit + ra <- getBit + BG.skip 3 + rc <- liftM (toEnum . fromIntegral) $ getAsWord8 4 + return Header { + hdMessageID = mID + , hdMessageType = qr + , hdOpcode = op + , hdIsAuthoritativeAnswer = aa + , hdIsTruncated = tc + , hdIsRecursionDesired = rd + , hdIsRecursionAvailable = ra + , hdResponseCode = rc + } return hd +instance Enum MessageType where + fromEnum Query = 0 + fromEnum Response = 1 + + toEnum 0 = Query + toEnum 1 = Response + toEnum _ = undefined + instance Enum Opcode where fromEnum StandardQuery = 0 fromEnum InverseQuery = 1 @@ -116,10 +827,6 @@ instance Enum Opcode where toEnum 2 = ServerStatusRequest toEnum _ = undefined -instance Bounded Opcode where - minBound = StandardQuery - maxBound = ServerStatusRequest - instance Enum ResponseCode where fromEnum NoError = 0 fromEnum FormatError = 1 @@ -136,6 +843,83 @@ instance Enum ResponseCode where toEnum 5 = Refused toEnum _ = undefined -instance Bounded ResponseCode where - minBound = NoError - maxBound = Refused + +defaultRTTable :: IntMap SomeRT +defaultRTTable = IM.fromList $ map toPair $ + [ 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 + + +wrapQuestion :: (QueryType qt, QueryClass qc) => Question qt qc -> SomeQ +wrapQuestion = SomeQ + +wrapRecord :: (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt -> SomeRR +wrapRecord = SomeRR