, RecordClass(..)
, SOAFields(..)
+ , WKSFields(..)
+ , SomeQ
, SomeQT
, SomeRR
, SomeRT
, MG(..)
, MR(..)
, NULL(..)
+ , WKS(..)
, PTR(..)
, HINFO(..)
, MINFO(..)
, MX(..)
, TXT(..)
+ , AXFR(..)
+ , MAILB(..)
+ , MAILA(..)
+ , ANY(..)
+
, mkDomainName
- , wrapQueryType
- , wrapRecordType
+ , wrapQuestion
, wrapRecord
)
where
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
data Message
= Message {
msgHeader :: !Header
- , msgQuestions :: ![Question]
+ , msgQuestions :: ![SomeQ]
, msgAnswers :: ![SomeRR]
, msgAuthorities :: ![SomeRR]
, msgAdditionals :: ![SomeRR]
| 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)
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
-- 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
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
Just srt
-> return srt
+
data SOAFields
= SOAFields {
soaMasterNameServer :: !DomainName
}
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
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
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 $
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
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
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
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
projects / haskell-dns.git / commitdiff