1 module Network.DNS.Message
26 import Data.Binary.BitPut as BP
27 import Data.Binary.Get as G
28 import Data.Binary.Put as P
29 import Data.Binary.Strict.BitGet as BG
30 import qualified Data.ByteString as BS
31 import qualified Data.ByteString.Lazy as LBS
33 import qualified Data.IntMap as IM
34 import Data.IntMap (IntMap)
38 replicateM' :: Monad m => Int -> (a -> m (b, a)) -> a -> m ([b], a)
39 replicateM' = worker []
41 worker :: Monad m => [b] -> Int -> (a -> m (b, a)) -> a -> m ([b], a)
42 worker soFar 0 _ a = return (reverse soFar, a)
43 worker soFar n f a = do (b, a') <- f a
44 worker (b : soFar) (n - 1) f a'
50 , msgQuestions :: ![Question]
51 , msgAnswers :: ![SomeRR]
52 , msgAuthorities :: ![SomeRR]
53 , msgAdditionals :: ![SomeRR]
58 hdMessageID :: !MessageID
59 , hdMessageType :: !MessageType
61 , hdIsAuthoritativeAnswer :: !Bool
62 , hdIsTruncated :: !Bool
63 , hdIsRecursionDesired :: !Bool
64 , hdIsRecursionAvailable :: !Bool
65 , hdResponseCode :: !ResponseCode
67 -- These fields are supressed in this data structure:
74 type MessageID = Word16
100 , qClass :: !RecordClass
104 putQ :: Question -> Put
106 = do putDomainName $ qName q
110 getQ :: DecompTable -> Get (Question, DecompTable)
112 = do (nm, dt') <- getDomainName dt
122 newtype DomainName = DN [DomainLabel] deriving (Eq, Show, Typeable)
123 type DomainLabel = BS.ByteString
125 nameToLabels :: DomainName -> [DomainLabel]
126 nameToLabels (DN ls) = ls
128 labelsToName :: [DomainLabel] -> DomainName
137 | AnyClass -- Only for queries
141 data RecordType rt dt => ResourceRecord rt dt
143 rrName :: !DomainName
145 , rrClass :: !RecordClass
149 deriving (Show, Eq, Typeable)
152 putRR :: forall rt dt. RecordType rt dt => ResourceRecord rt dt -> Put
153 putRR rr = do putDomainName $ rrName rr
154 putRecordType $ rrType rr
156 putWord32be $ rrTTL rr
159 putRecordData (undefined :: rt) (rrData rr)
160 putWord16be $ fromIntegral $ LBS.length dat
161 putLazyByteString dat
164 getRR :: forall rt dt. RecordType rt dt => DecompTable -> rt -> Get (ResourceRecord rt dt, DecompTable)
166 = do (nm, dt1) <- getDomainName dt
167 G.skip 2 -- record type
170 G.skip 2 -- data length
171 (dat, dt2) <- getRecordData (undefined :: rt) dt1
173 let rr = ResourceRecord {
183 data SomeRR = forall rt dt. RecordType rt dt => SomeRR (ResourceRecord rt dt)
185 instance Show SomeRR where
186 show (SomeRR rr) = show rr
188 instance Eq SomeRR where
189 (SomeRR a) == (SomeRR b) = Just a == cast b
192 putSomeRR :: SomeRR -> Put
193 putSomeRR (SomeRR rr) = putRR rr
195 getSomeRR :: DecompTable -> Get (SomeRR, DecompTable)
197 = do srt <- lookAhead $
198 do getDomainName dt -- skip
201 SomeRT rt -> getRR dt rt >>= \ (rr, dt') -> return (SomeRR rr, dt')
204 type DecompTable = IntMap BS.ByteString
207 getDomainName :: DecompTable -> Get (DomainName, DecompTable)
208 getDomainName = flip worker []
210 worker :: DecompTable -> [DomainLabel] -> Get (DomainName, DecompTable)
212 = do (l, dt') <- getDomainLabel dt
214 True -> return (labelsToName (reverse (l : soFar)), dt')
215 False -> worker dt' (l : soFar)
217 getDomainLabel :: DecompTable -> Get (DomainLabel, DecompTable)
219 = do header <- getByteString 1
224 n <- liftM fromIntegral (getAsWord8 6)
226 ( True, True) -> return $ Offset n
227 (False, False) -> return $ Length n
228 _ -> fail "Illegal label header"
231 -> do let Just l = IM.lookup n dt
234 -> do offset <- liftM fromIntegral bytesRead
235 label <- getByteString n
236 let dt' = IM.insert offset label dt
239 getCharString :: Get BS.ByteString
240 getCharString = do len <- G.getWord8
241 getByteString (fromIntegral len)
243 putCharString :: BS.ByteString -> Put
244 putCharString = putDomainLabel
250 putDomainName :: DomainName -> Put
251 putDomainName = mapM_ putDomainLabel . nameToLabels
253 putDomainLabel :: DomainLabel -> Put
255 = do putWord8 $ fromIntegral $ BS.length l
258 class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
260 putRecordType :: rt -> Put
261 putRecordData :: rt -> dt -> Put
262 getRecordData :: rt -> DecompTable -> Get (dt, DecompTable)
264 putRecordType = putWord16be . fromIntegral . rtToInt
266 data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt
268 instance Show SomeRT where
269 show (SomeRT rt) = show rt
271 instance Eq SomeRT where
272 (SomeRT a) == (SomeRT b) = Just a == cast b
274 putSomeRT :: SomeRT -> Put
275 putSomeRT (SomeRT rt) = putRecordType rt
277 getSomeRT :: Get SomeRT
278 getSomeRT = do n <- liftM fromIntegral G.getWord16be
279 case IM.lookup n defaultRTTable of
281 -> fail ("Unknown resource record type: " ++ show n)
285 data CNAME = CNAME deriving (Show, Eq, Typeable)
286 instance RecordType CNAME DomainName where
288 putRecordData _ = putDomainName
289 getRecordData _ = getDomainName
291 data HINFO = HINFO deriving (Show, Eq, Typeable)
292 instance RecordType HINFO (BS.ByteString, BS.ByteString) where
294 putRecordData _ (cpu, os) = do putCharString cpu
296 getRecordData _ dt = do cpu <- getCharString
298 return ((cpu, os), dt)
327 instance Binary Message where
328 put m = do put $ msgHeader m
329 putWord16be $ fromIntegral $ length $ msgQuestions m
330 putWord16be $ fromIntegral $ length $ msgAnswers m
331 putWord16be $ fromIntegral $ length $ msgAuthorities m
332 putWord16be $ fromIntegral $ length $ msgAdditionals m
333 mapM_ putQ $ msgQuestions m
334 mapM_ putSomeRR $ msgAnswers m
335 mapM_ putSomeRR $ msgAuthorities m
336 mapM_ putSomeRR $ msgAdditionals m
339 nQ <- liftM fromIntegral G.getWord16be
340 nAns <- liftM fromIntegral G.getWord16be
341 nAth <- liftM fromIntegral G.getWord16be
342 nAdd <- liftM fromIntegral G.getWord16be
343 (qs , dt1) <- replicateM' nQ getQ IM.empty
344 (anss, dt2) <- replicateM' nAns getSomeRR dt1
345 (aths, dt3) <- replicateM' nAth getSomeRR dt2
346 (adds, _ ) <- replicateM' nAdd getSomeRR dt3
351 , msgAuthorities = aths
352 , msgAdditionals = adds
355 instance Binary Header where
356 put h = do putWord16be $ hdMessageID h
357 putLazyByteString flags
360 do putNBits 1 $ fromEnum $ hdMessageType h
361 putNBits 4 $ fromEnum $ hdOpcode h
362 putBit $ hdIsAuthoritativeAnswer h
363 putBit $ hdIsTruncated h
364 putBit $ hdIsRecursionDesired h
365 putBit $ hdIsRecursionAvailable h
366 putNBits 3 (0 :: Int)
367 putNBits 4 $ fromEnum $ hdResponseCode h
369 get = do mID <- G.getWord16be
370 flags <- getByteString 2
373 do qr <- liftM (toEnum . fromIntegral) $ getAsWord8 1
374 op <- liftM (toEnum . fromIntegral) $ getAsWord8 4
380 rc <- liftM (toEnum . fromIntegral) $ getAsWord8 4
385 , hdIsAuthoritativeAnswer = aa
387 , hdIsRecursionDesired = rd
388 , hdIsRecursionAvailable = ra
389 , hdResponseCode = rc
393 instance Enum MessageType where
395 fromEnum Response = 1
401 instance Enum Opcode where
402 fromEnum StandardQuery = 0
403 fromEnum InverseQuery = 1
404 fromEnum ServerStatusRequest = 2
406 toEnum 0 = StandardQuery
407 toEnum 1 = InverseQuery
408 toEnum 2 = ServerStatusRequest
411 instance Enum ResponseCode where
413 fromEnum FormatError = 1
414 fromEnum ServerFailure = 2
415 fromEnum NameError = 3
416 fromEnum NotImplemented = 4
420 toEnum 1 = FormatError
421 toEnum 2 = ServerFailure
423 toEnum 4 = NotImplemented
428 instance Enum RecordType where
448 fromEnum AnyType = 255
473 instance Enum RecordClass where
478 fromEnum AnyClass = 255
484 toEnum 255 = AnyClass
487 instance Binary RecordClass where
488 get = liftM (toEnum . fromIntegral) G.getWord16be
489 put = putWord16be . fromIntegral . fromEnum
492 defaultRTTable :: IntMap SomeRT
493 defaultRTTable = IM.fromList $ map toPair $
497 toPair :: SomeRT -> (Int, SomeRT)
498 toPair srt@(SomeRT rt) = (rtToInt rt, srt)